io-multiplex/queue.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; queue.lisp --- FIFO-optimized queues.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;; Copyright (C) 2001-2005, Pascal J. Bourguignon  <pjb@informatimago.com>
   7 ;;;
   8 ;;; This code is free software; you can redistribute it and/or
   9 ;;; modify it under the terms of the version 2.1 of
  10 ;;; the GNU Lesser General Public License as published by
  11 ;;; the Free Software Foundation, as clarified by the
  12 ;;; preamble found here:
  13 ;;;     http://opensource.franz.com/preamble.html
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Lesser General
  21 ;;; Public License along with this library; if not, write to the
  22 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  23 ;;; Boston, MA 02110-1301, USA
  24
  25 (in-package :io.multiplex)
  26
  27 ;;; The structure of a queue is as follows:
  28 ;;;
  29 ;;;                  queue
  30 ;;;                    |
  31 ;;;                    V
  32 ;;;             +------+------+
  33 ;;;             | head | tail |--------------------------+
  34 ;;;             +------+------+                          |
  35 ;;;                |                                     |
  36 ;;;                V                                     V
  37 ;;;         +------+------+    +------+------+    +------+------+
  38 ;;;         | car  | cdr  |--->| car  | cdr  |--->| car  | cdr  |--->nil
  39 ;;;         +------+------+    +------+------+    +------+------+
  40 ;;;            |                  |                  |
  41 ;;;            V                  V                  V
  42 ;;;         +------+           +------+           +------+
  43 ;;;         | elem |           | elem |           | elem |
  44 ;;;         +------+           +------+           +------+
  45
  46 (defstruct (queue (:constructor %make-queue))
  47   (head nil :type list)
  48   (tail nil :type list))
  49
  50 (defun queue-invariant (queue)
  51   (assert (queue-p queue))
  52   (assert (or (and (null (queue-head queue))  (null (queue-tail queue)))
  53               (and (queue-head queue) (queue-tail queue))))
  54   (when (queue-head queue)
  55     (assert (list-length (queue-head queue))) ; not a circular list.
  56     (assert (search (queue-tail queue) (queue-head queue) :test (function eq)))
  57     (assert (null (cdr (queue-tail queue))))))
  58
  59 (defun make-queue () (%make-queue))
  60
  61 ;;; Returns the number of elements in the queue.
  62 (defun queue-length (queue)
  63   (assert (queue-p queue))
  64   (length (queue-head queue))) ;;queue-length
  65
  66 (defun queue-empty-p (queue)
  67   (assert (queue-p queue))
  68   (null (queue-head queue)))
  69
  70 ;;; Returns the first element of the queue.
  71 (defun queue-first-element (queue)
  72   (assert (queue-p queue))
  73   (first (queue-head queue)))
  74
  75 ;;; Returns the last element of the queue.
  76 (defun queue-last-element (queue)
  77   (assert (queue-p queue))
  78   (first (queue-tail queue)))
  79
  80 (defun queue-enqueue  (queue element)
  81   (assert (queue-p queue))
  82   ;; (car q) = head      (cdr q) = tail
  83   (if (queue-head queue)
  84       (progn
  85         ;; There's already an element, just add to the tail.
  86         (setf (cdr (queue-tail queue)) (cons element nil))
  87         (setf (queue-tail queue)       (cdr (queue-tail queue))))
  88       (progn
  89         ;; The queue is empty, let's set the head.
  90         (setf (queue-head queue) (cons element nil))
  91         (setf (queue-tail queue) (queue-head queue))))
  92   queue)
  93
  94 (defun queue-delete (queue element &key (test (function eql)))
  95   (assert (queue-p queue))
  96   (setf (queue-head queue) (delete element (queue-head queue) :test test)
  97         (queue-tail queue) (last (queue-head queue)))
  98   queue)
  99
 100 (defun queue-delete-if (queue test)
 101   (assert (queue-p queue))
 102   (setf (queue-head queue) (delete-if test (queue-head queue))
 103         (queue-tail queue) (last (queue-head queue)))
 104   queue)
 105
 106 (defun queue-dequeue (queue)
 107   (assert (queue-p queue))
 108   (prog1 (pop (queue-head queue))
 109     (when (null (queue-head queue))
 110       (setf (queue-tail queue) nil))))
 111
 112 ;;; Insert the element at the beginning of the queue.
 113 (defun queue-requeue (queue element)
 114   (assert (queue-p queue))
 115   (push element (queue-head queue))
 116   (when (null (queue-tail queue))
 117     (setf (queue-tail queue) (queue-head queue)))
 118   queue)
 119
 120 (defun queue-sort (queue predicate &optional (key #'identity))
 121   (assert (queue-p queue))
 122   (setf (queue-head queue) (sort (queue-head queue) predicate :key key)
 123         (queue-tail queue) (last (queue-head queue))))
 124
 125 ;;; Scan the queue comparing the elements of the queue with ELEMENT
 126 ;;; until PREDICATE returns NIL, then insert ELEMENT right before the
 127 ;;; last compared queue element.
 128 (defun queue-sorted-insert (queue element predicate &optional (key #'identity))
 129   (assert (queue-p queue))
 130   (if (null (queue-head queue))
 131       (progn
 132         (push element (queue-head queue))
 133         (setf (queue-tail queue) (queue-head queue)))
 134       (progn
 135         (if (funcall predicate
 136                      (funcall key element)
 137                      (funcall key (queue-first-element queue)))
 138             (push element (queue-head queue))
 139             (do* ((curr-list (queue-head queue) next-list)
 140                   (next-list (cdr curr-list) (cdr curr-list))
 141                   (next-elem (car next-list) (car next-list))
 142                   end-flag)
 143                  (end-flag)
 144               (when (or (null next-elem)
 145                         (funcall predicate
 146                                  (funcall key element)
 147                                  (funcall key next-elem)))
 148                 (setf end-flag t)
 149                 (if (null next-elem)
 150                     ;; end of the queue has been reached
 151                     (setf (cdr curr-list) (list element)
 152                           (queue-tail queue) (cdr curr-list))
 153                     (let ((newcons (list element)))
 154                       (setf (cdr curr-list) newcons
 155                             (cdr newcons) next-list))))))))
 156   queue)
 157
 158 ;;; TODO: make it traverse the queue only once
 159 ;;;
 160 ;;; Delete from the queue all elements that satisfy TEST and return
 161 ;;; them as list.
 162 (defun queue-filter (queue test &optional (key #'identity))
 163   (assert (queue-p queue))
 164   (remove-if-not test (queue-head queue) :key key))
 165
 166 ;;; TODO: make it traverse the queue only once
 167 ;;;
 168 ;;; Delete from the queue all elements that satisfy TEST and return
 169 ;;; them as list.
 170 (defun queue-filter-and-delete (queue test &optional (key #'identity))
 171   (assert (queue-p queue))
 172   (prog1 (remove-if-not test (queue-head queue) :key key)
 173     (setf (queue-head queue) (delete-if test (queue-head queue) :key key)
 174           (queue-tail queue) (last (queue-head queue)))))