io-multiplex/queue.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; queue.lisp --- 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 :io.multiplex)
  27
  28 \f
  29 ;;;
  30 ;;; Heap (for the priority queue)
  31 ;;;
  32
  33 (defun heap-parent (i)
  34   (ash i -1))
  35
  36 (defun heap-left (i)
  37   (ash i 1))
  38
  39 (defun heap-right (i)
  40   (1+ (ash i 1)))
  41
  42 (defun heap-size (heap)
  43   (1- (length heap)))
  44
  45 (defun heapify (heap start &key (key #'identity) (test #'>=))
  46   (declare (function key test))
  47   (flet ((key (obj) (funcall key obj))
  48          (ge (i j) (funcall test i j)))
  49     (let ((l (heap-left start))
  50           (r (heap-right start))
  51           (size (heap-size heap))
  52           largest)
  53       (setf largest (if (and (<= l size)
  54                              (not (ge (key (aref heap start))
  55                                       (key (aref heap l)))))
  56                         l
  57                         start))
  58       (when (and (<= r size)
  59                  (not (ge (key (aref heap largest))
  60                           (key (aref heap r)))))
  61         (setf largest r))
  62       (when (/= largest start)
  63         (rotatef (aref heap largest) (aref heap start))
  64         (heapify heap largest :key key :test test)))
  65     (values heap)))
  66
  67 (defun heap-insert (heap new-item &key (key #'identity) (test #'>=))
  68   (declare (function key test))
  69   (flet ((key (obj) (funcall key obj))
  70          (ge (i j) (funcall test i j)))
  71     (incf (fill-pointer heap))
  72     (loop for i = (heap-size heap) then parent-i
  73           for parent-i = (heap-parent i)
  74           while (and (> i 0)
  75                      (not (ge (key (aref heap parent-i))
  76                               (key new-item))))
  77           do (setf (aref heap i) (aref heap parent-i))
  78           finally (setf (aref heap i) new-item))
  79     (values heap)))
  80
  81 (defun heap-mimimum (heap)
  82   (unless (zerop (length heap))
  83     (aref heap 0)))
  84
  85 (defun heap-extract (heap i &key (key #'identity) (test #'>=))
  86   (when (< (length heap) i)
  87     (error "Heap underflow"))
  88   (prog1
  89       (aref heap i)
  90     (setf (aref heap i) (aref heap (heap-size heap)))
  91     (decf (fill-pointer heap))
  92     (heapify heap i :key key :test test)))
  93
  94 (defun heap-extract-mimimum (heap &key (key #'identity) (test #'>=))
  95   (heap-extract heap 0 :key key :test test))
  96
  97 \f
  98 ;;;
  99 ;;; Priority queue
 100 ;;;
 101
 102 (defstruct (priority-queue
 103              (:conc-name %pqueue-)
 104              (:constructor %make-priority-queue))
 105   contents
 106   keyfun)
 107
 108 (defmethod print-object ((object priority-queue) stream)
 109   (print-unreadable-object (object stream :type t :identity t)
 110     (format stream "~[empty~:;~:*~D item~:P~]"
 111             (length (%pqueue-contents object)))))
 112
 113 (defun make-priority-queue (&key (key #'identity) (element-type t))
 114   (let ((contents (make-array 100 :adjustable t
 115                               :fill-pointer 0
 116                               :element-type element-type)))
 117     (%make-priority-queue :keyfun key
 118                           :contents contents)))
 119
 120 (defun priority-queue-minimum (priority-queue)
 121   "Return the item in PRIORITY-QUEUE with the largest key."
 122   (symbol-macrolet ((contents (%pqueue-contents priority-queue)))
 123     (unless (zerop (length contents))
 124       (heap-mimimum contents))))
 125
 126 (defun priority-queue-extract-minimum (priority-queue)
 127   "Remove and return the item in PRIORITY-QUEUE with the largest key."
 128   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 129                     (keyfun (%pqueue-keyfun priority-queue)))
 130     (unless (zerop (length contents))
 131       (heap-extract-mimimum contents :key keyfun :test #'<=))))
 132
 133 (defun priority-queue-insert (priority-queue new-item)
 134   "Add NEW-ITEM to PRIORITY-QUEUE."
 135   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 136                     (keyfun (%pqueue-keyfun priority-queue)))
 137     (heap-insert contents new-item :key keyfun :test #'<=)))
 138
 139 (defun priority-queue-empty-p (priority-queue)
 140   (zerop (length (%pqueue-contents priority-queue))))
 141
 142 (defun priority-queue-remove (priority-queue item &key (test #'eq))
 143   "Remove and return ITEM from PRIORITY-QUEUE."
 144   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 145                     (keyfun (%pqueue-keyfun priority-queue)))
 146     (let ((i (position item contents :test test)))
 147       (when i
 148         (heap-extract contents i :key keyfun :test #'<=)))))
 149
 150 (defun priority-queue-reorder (priority-queue)
 151   (symbol-macrolet ((contents (%pqueue-contents priority-queue))
 152                     (keyfun (%pqueue-keyfun priority-queue)))
 153     (heapify contents 0 :key keyfun :test #'<=)))