src/multiplex/queue.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Data structures for managing scheduled timers.
   4 ;;;
   5 ;;; Copyright (C) 2003 Zach Beane <xach@xach.com>
   6 ;;;
   7 ;;; Permission is hereby granted, free of charge, to any person obtaining
   8 ;;; a copy of this software and associated documentation files (the
   9 ;;; "Software"), to deal in the Software without restriction, including
  10 ;;; without limitation the rights to use, copy, modify, merge,publish,
  11 ;;; distribute, sublicense, and/or sell copies of the Software, and to
  12 ;;; permit persons to whom the Software is furnished to do so, subject to
  13 ;;; the following conditions:
  14 ;;;
  15 ;;; The above copyright notice and this permission notice shall be
  16 ;;; included in all copies or substantial portions of the Software.
  17 ;;;
  18 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  19 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  20 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  21 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
  22 ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
  23 ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
  24 ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  25
  26 (in-package :iolib.multiplex)
  27
  28 \f
  29 ;;;
  30 ;;; Heap (for the priority queue)
  31 ;;;
  32
  33 (declaim (inline heap-parent heap-left heap-right heap-size))
  34
  35 (defun heap-parent (i)
  36   (ash (1- i) -1))
  37
  38 (defun heap-left (i)
  39   (1+ (ash i 1)))
  40
  41 (defun heap-right (i)
  42   (+ 2 (ash i 1)))
  43
  44 (defun heap-size (heap)
  45   (1- (length heap)))
  46
  47 (defun heapify (heap start &key (key #'identity) (test #'>=))
  48   (declare (function key test))
  49   (flet ((key (obj) (funcall key obj))
  50          (ge (i j) (funcall test i j)))
  51     (let ((l (heap-left start))
  52           (r (heap-right start))
  53           (size (heap-size heap))
  54           largest)
  55       (setf largest (if (and (<= l size)
  56                              (not (ge (key (aref heap start))
  57                                       (key (aref heap l)))))
  58                         l
  59                         start))
  60       (when (and (<= r size)
  61                  (not (ge (key (aref heap largest))
  62                           (key (aref heap r)))))
  63         (setf largest r))
  64       (when (/= largest start)
  65         (rotatef (aref heap largest) (aref heap start))
  66         (heapify heap largest :key key :test test)))
  67     heap))
  68
  69 (defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
  70   (declare (function key test))
  71   (flet ((key (obj) (funcall key obj))
  72          (ge (i j) (funcall test i j)))
  73     (vector-push-extend nil heap)
  74     (loop for i = (heap-size heap) then parent-i
  75           for parent-i = (heap-parent i)
  76           while (and (> i 0)
  77                      (not (ge (key (aref heap parent-i))
  78                               (key new-item))))
  79           do (setf (aref heap i) (aref heap parent-i))
  80           finally (setf (aref heap i) new-item)
  81           (return-from heap-insert i))))
  82
  83 (defun heap-maximum (heap)
  84   (unless (zerop (length heap))
  85     (aref heap 0)))
  86
  87 (defun heap-extract (heap i &key (key #'identity) (test #'>=))
  88   (unless (> (length heap) i)
  89     (error "Heap underflow"))
  90   (prog1
  91       (aref heap i)
  92     (setf (aref heap i) (aref heap (heap-size heap)))
  93     (decf (fill-pointer heap))
  94     (heapify heap i :key key :test test)))
  95
  96 (defun heap-extract-maximum (heap &key (key #'identity) (test #'>=))
  97   (heap-extract heap 0 :key key :test test))
  98
  99 \f
 100 ;;;
 101 ;;; Priority queue
 102 ;;;
 103
 104 (defstruct (priority-queue
 105              (:conc-name %pqueue-)
 106              (:constructor %make-priority-queue))
 107   contents
 108   keyfun)
 109
 110 (defun make-priority-queue (&key (key #'identity) (element-type t))
 111   (let ((contents (make-array 100 :adjustable t
 112                               :fill-pointer 0
 113                               :element-type element-type)))
 114     (%make-priority-queue :keyfun key
 115                           :contents contents)))
 116
 117 (defmethod print-object ((object priority-queue) stream)
 118   (print-unreadable-object (object stream :type t :identity t)
 119     (format stream "~[empty~:;~:*~D item~:P~]"
 120             (length (%pqueue-contents object)))))
 121
 122 (defun priority-queue-maximum (priority-queue)
 123   "Return the item in PRIORITY-QUEUE with the largest key."
 124   (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
 125     (unless (zerop (length contents))
 126       (heap-maximum contents))))
 127
 128 (defun priority-queue-extract-maximum (priority-queue)
 129   "Remove and return the item in PRIORITY-QUEUE with the largest key."
 130   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 131                     (keyfun (%pqueue-keyfun priority-queue)))
 132     (unless (zerop (length contents))
 133       (heap-extract-maximum contents :key keyfun :test #'<=))))
 134
 135 (defun priority-queue-insert (priority-queue new-item)
 136   "Add NEW-ITEM to PRIORITY-QUEUE."
 137   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 138                     (keyfun (%pqueue-keyfun priority-queue)))
 139     (heap-insert contents new-item :key keyfun :test #'<=)))
 140
 141 (defun priority-queue-empty-p (priority-queue)
 142   (zerop (length (%pqueue-contents priority-queue))))
 143
 144 (defun priority-queue-remove (priority-queue item &key (test #'eq))
 145   "Remove and return ITEM from PRIORITY-QUEUE."
 146   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 147                     (keyfun (%pqueue-keyfun priority-queue)))
 148     (let ((i (position item contents :test test)))
 149       (when i
 150         (heap-extract contents i :key keyfun :test #'<=)
 151         i))))
 152
 153 (defun priority-queue-reorder (priority-queue)
 154   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 155                     (keyfun (%pqueue-keyfun priority-queue)))
 156     (heapify contents 0 :key keyfun :test #'<=)))