close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/priority-queue.lisp@ 78

Last change on this file since 78 was 50, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 2.4 KB
RevLine 
[50]1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;;
3;; Priority queue stuff
4;;
5;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
6
7(defparameter *priority-queue-allocation-size* 16)
8
9(defun priority-queue-make-heap (&key (element-type 'fixnum))
10 (make-array *priority-queue-allocation-size* :element-type element-type :fill-pointer 1
11 :adjustable t))
12
13(defstruct (priority-queue (:constructor priority-queue-construct))
14 (heap (priority-queue-make-heap))
15 test)
16
17(defun make-priority-queue (&key (element-type 'fixnum)
18 (test #'<=)
19 (element-key #'identity))
20 (priority-queue-construct
21 :heap (priority-queue-make-heap :element-type element-type)
22 :test #'(lambda (x y) (funcall test (funcall element-key y) (funcall element-key x)))))
23
24(defun priority-queue-insert (pq item)
25 (priority-queue-heap-insert (priority-queue-heap pq) item (priority-queue-test pq)))
26
27(defun priority-queue-remove (pq)
28 (priority-queue-heap-remove (priority-queue-heap pq) (priority-queue-test pq)))
29
30(defun priority-queue-empty-p (pq)
31 (priority-queue-heap-empty-p (priority-queue-heap pq)))
32
33(defun priority-queue-size (pq)
34 (fill-pointer (priority-queue-heap pq)))
35
36(defun priority-queue-upheap (a k
37 &optional
38 (test #'<=)
39 &aux (v (aref a k)))
40 (declare (fixnum k))
41 (assert (< 0 k (fill-pointer a)))
42 (loop
43 (let ((parent (ash k -1)))
44 (when (zerop parent) (return))
45 (unless (funcall test (aref a parent) v)
46 (return))
47 (setf (aref a k) (aref a parent)
48 k parent)))
49 (setf (aref a k) v)
50 a)
51
52
53(defun priority-queue-heap-insert (a item &optional (test #'<=))
54 (vector-push-extend item a)
55 (priority-queue-upheap a (1- (fill-pointer a)) test))
56
57(defun priority-queue-downheap (a k
58 &optional
59 (test #'<=)
60 &aux (v (aref a k)) (j 0) (n (fill-pointer a)))
61 (declare (fixnum k n j))
62 (loop
63 (unless (<= k (ash n -1))
64 (return))
65 (setf j (ash k 1))
66 (if (and (< j n) (not (funcall test (aref a (1+ j)) (aref a j))))
67 (incf j))
68 (when (funcall test (aref a j) v)
69 (return))
70 (setf (aref a k) (aref a j)
71 k j))
72 (setf (aref a k) v)
73 a)
74
75(defun priority-queue-heap-remove (a &optional (test #'<=) &aux (v (aref a 1)))
76 (when (<= (fill-pointer a) 1) (error "Empty queue."))
77 (setf (aref a 1) (vector-pop a))
78 (priority-queue-downheap a 1 test)
79 (values v a))
80
81(defun priority-queue-heap-empty-p (a)
82 (<= (fill-pointer a) 1))
Note: See TracBrowser for help on using the repository browser.