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.

Changeset 3985 for branches


Ignore:
Timestamp:
2016-05-30T20:50:14-07:00 (8 years ago)
Author:
Marek Rychlik
Message:

* empty log message *

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/f4grobner/priority-queue.lisp

    r3984 r3985  
    2828(defpackage "PRIORITY-QUEUE"
    2929  (:use :cl :heap)
    30   (:export "*PRIORITY-QUEUE-ALLOCATION-SIZE*"
    31            "PRIORITY-QUEUE"
    32            "PRIORITY-QUEUE-HEAP"
    33            "PRIORITY-QUEUE-TEST"
     30  (:export "PRIORITY-QUEUE"
    3431           "MAKE-PRIORITY-QUEUE"
    3532           "PRIORITY-QUEUE-INSERT"
     
    4037
    4138(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 1
    46               :adjustable t))
    4739
    4840(defstruct (priority-queue (:constructor priority-queue-construct))
    49   (heap (priority-queue-make-heap))
     41  (heap (make-heap))
    5042  test)
    5143
     
    5446                            (element-key #'identity))
    5547  (priority-queue-construct
    56    :heap (priority-queue-make-heap :element-type element-type)
     48   :heap (make-heap :element-type element-type)
    5749   :test #'(lambda (x y) (funcall test (funcall element-key y) (funcall element-key x)))))
    5850 
    5951(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)))
    6153
    6254(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)))
    6456
    6557(defun priority-queue-empty-p (pq)
    66   (priority-queue-heap-empty-p (priority-queue-heap pq)))
     58  (heap-empty-p (priority-queue-heap pq)))
    6759
    6860(defun priority-queue-size (pq)
    6961  (fill-pointer (priority-queue-heap pq)))
    70 
    71 (defun priority-queue-upheap (a k
    72                &optional
    73                (test #'<=)
    74                &aux  (v (aref a k)))
    75   (declare (fixnum k))
    76   (assert (< 0 k (fill-pointer a)))
    77   (loop
    78    (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 k
    93                  &optional
    94                  (test #'<=)
    95                  &aux  (v (aref a k)) (j 0) (n (fill-pointer a)))
    96   (declare (fixnum k n j))
    97   (loop
    98    (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.