io-multiplex/queue.lisp

   1 ;;;; -*- coding:utf-8 -*-
   2 ;;;;****************************************************************************
   3 ;;;;FILE:               queue.lisp
   4 ;;;;LANGUAGE:           Common-Lisp
   5 ;;;;SYSTEM:             Common-Lisp
   6 ;;;;USER-INTERFACE:     None
   7 ;;;;DESCRIPTION
   8 ;;;;
   9 ;;;;    This module exports a queue type. This is a structure optimized for
  10 ;;;;    FIFO operations, keeping a pointer to the head and the tail of a list.
  11 ;;;;
  12 ;;;;AUTHORS
  13 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
  14 ;;;;    <SI>  Stelian Ionescu <sionescu@common-lisp.net>
  15 ;;;;MODIFICATIONS
  16 ;;;;    2007-02-03 <SI>  Added QUEUE-SORTED-INSERT, QUEUE-FILTER-AND-DELETE,
  17 ;;;;                     QUEUE-DELETE-IF and QUEUE-FILTER
  18 ;;;;    2005-08-31 <PJB> Added QUEUE-DELETE
  19 ;;;;    2004-02-26 <PJB> Formated for publication.
  20 ;;;;    2001-12-31 <PJB> Added pjb-queue-requeue.
  21 ;;;;                     Corrected the return value of some methods.
  22 ;;;;    2001-11-12 <PJB> Creation.
  23 ;;;;BUGS
  24 ;;;;LEGAL
  25 ;;;;    LLGPL
  26 ;;;;
  27 ;;;;    Copyright Pascal J. Bourguignon 2001 - 2005
  28 ;;;;              Stelian Ionescu 2007
  29 ;;;;
  30 ;;;;    This library is licenced under the Lisp Lesser General Public
  31 ;;;;    License.
  32 ;;;;
  33 ;;;;    This library is free software; you can redistribute it and/or
  34 ;;;;    modify it under the terms of the GNU Lesser General Public
  35 ;;;;    License as published by the Free Software Foundation; either
  36 ;;;;    version 2 of the License, or (at your option) any later
  37 ;;;;    version.
  38 ;;;;
  39 ;;;;    This library is distributed in the hope that it will be
  40 ;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
  41 ;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  42 ;;;;    PURPOSE.  See the GNU Lesser General Public License for more
  43 ;;;;    details.
  44 ;;;;
  45 ;;;;    You should have received a copy of the GNU Lesser General
  46 ;;;;    Public License along with this library; if not, write to the
  47 ;;;;    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  48 ;;;;    Boston, MA 02111-1307 USA
  49 ;;;;****************************************************************************
  50
  51 (in-package :io.multiplex)
  52
  53 ;;; The structure of a queue is as follow:
  54 ;;;
  55 ;;;                  queue
  56 ;;;                    |
  57 ;;;                    V
  58 ;;;             +------+------+
  59 ;;;             | head | tail |--------------------------+
  60 ;;;             +------+------+                          |
  61 ;;;                |                                     |
  62 ;;;                V                                     V
  63 ;;;         +------+------+    +------+------+    +------+------+
  64 ;;;         | car  | cdr  |--->| car  | cdr  |--->| car  | cdr  |--->nil
  65 ;;;         +------+------+    +------+------+    +------+------+
  66 ;;;            |                  |                  |
  67 ;;;            V                  V                  V
  68 ;;;         +------+           +------+           +------+
  69 ;;;         | elem |           | elem |           | elem |
  70 ;;;         +------+           +------+           +------+
  71
  72
  73 (defstruct (queue (:constructor %make-queue))
  74   (head nil :type list)
  75   (tail nil :type list))
  76
  77
  78 (defun queue-invariant (queue)
  79   (assert (queue-p queue))
  80   (assert (or (and (null (queue-head queue))  (null (queue-tail queue)))
  81               (and (queue-head queue) (queue-tail queue))))
  82   (when (queue-head queue)
  83     (assert (list-length (queue-head queue))) ; not a circular list.
  84     (assert (search (queue-tail queue) (queue-head queue) :test (function eq)))
  85     (assert (null (cdr (queue-tail queue))))))
  86
  87
  88 (defun make-queue () (%make-queue))
  89
  90
  91 (defun queue-length (queue)
  92   "
  93 PRE:     (queue-p queue)
  94 RETURN:  The number of elements in the queue.
  95 "
  96   (assert (queue-p queue))
  97   (length (queue-head queue))) ;;queue-length
  98
  99
 100 (defun queue-empty-p (queue)
 101   "
 102 RETURN:  (= 0 (queue-length queue))
 103 "
 104   (assert (queue-p queue))
 105   (null (queue-head queue)))
 106
 107
 108 (defun queue-first-element (queue)
 109   "
 110 PRE:     (queue-p queue)
 111 RETURN:  The first element of the queue.
 112 "
 113   (assert (queue-p queue))
 114   (first (queue-head queue)))
 115
 116
 117 (defun queue-last-element (queue)
 118   "
 119 PRE:     (queue-p queue)
 120 RETURN:  The last element of the queue.
 121 "
 122   (assert (queue-p queue))
 123   (first (queue-tail queue)))
 124
 125
 126 (defun queue-enqueue  (queue element)
 127   "
 128 PRE:     (queue-p queue)
 129          l=(queue-length queue)
 130 POST:    (eq (queue-last-element queue) element),
 131          (queue-p queue),
 132          l+1=(queue-length queue)
 133 RETURN:  queue
 134 "
 135   (assert (queue-p queue))
 136   ;; (car q) = head      (cdr q) = tail
 137   (if (queue-head queue)
 138       (progn
 139         ;; There's already an element, just add to the tail.
 140         (setf (cdr (queue-tail queue)) (cons element nil))
 141         (setf (queue-tail queue)       (cdr (queue-tail queue))))
 142       (progn
 143         ;; The queue is empty, let's set the head.
 144         (setf (queue-head queue) (cons element nil))
 145         (setf (queue-tail queue) (queue-head queue))))
 146   queue)
 147
 148
 149 (defun queue-delete (queue element &key (test (function eql)))
 150   "
 151 POST:    (not (member element queue :test test))
 152 RETURN:  queue
 153 "
 154   (assert (queue-p queue))
 155   (setf (queue-head queue) (delete element (queue-head queue) :test test)
 156         (queue-tail queue) (last (queue-head queue)))
 157   queue)
 158
 159
 160 (defun queue-delete-if (queue test)
 161   (assert (queue-p queue))
 162   (setf (queue-head queue) (delete-if test (queue-head queue))
 163         (queue-tail queue) (last (queue-head queue)))
 164   queue)
 165
 166
 167 (defun queue-dequeue (queue)
 168   "
 169 PRE:     (queue-p queue)
 170          l=(queue-length queue)
 171          f=(queue-first-element queue)
 172 POST:    l>0 ==> l-1=(queue-length queue)
 173          l=0 ==> 0=(queue-length queue)
 174 RETURN:  f
 175 "
 176   (assert (queue-p queue))
 177   (prog1 (pop (queue-head queue))
 178     (when (null (queue-head queue))
 179       (setf (queue-tail queue) nil))))
 180
 181
 182 (defun queue-requeue (queue element)
 183   "
 184 DO:      Insert the element at the beginning of the queue.
 185 PRE:     (queue-p queue)
 186          l=(queue-length queue)
 187 POST:    (eq (queue-first-element queue) element)
 188          (queue-p queue),
 189          l+1=(queue-length queue)
 190 RETURN:  queue
 191 "
 192   (assert (queue-p queue))
 193   (push element (queue-head queue))
 194   (when (null (queue-tail queue))
 195     (setf (queue-tail queue) (queue-head queue)))
 196   queue)
 197
 198
 199 (defun queue-sort (queue predicate &optional (key #'identity))
 200   (assert (queue-p queue))
 201   (setf (queue-head queue) (sort (queue-head queue) predicate :key key)
 202         (queue-tail queue) (last (queue-head queue))))
 203
 204
 205 (defun queue-sorted-insert (queue element predicate &optional (key #'identity))
 206   "Scan the queue comparing the elements of the queue
 207 with ELEMENT until PREDICATE returns NIL, then insert
 208 ELEMENT right before the last compared queue element."
 209   (assert (queue-p queue))
 210   (if (null (queue-head queue))
 211       (progn
 212         (push element (queue-head queue))
 213         (setf (queue-tail queue) (queue-head queue)))
 214       (progn
 215         (if (funcall predicate
 216                      (funcall key element)
 217                      (funcall key (queue-first-element queue)))
 218             (push element (queue-head queue))
 219             (do* ((curr-list (queue-head queue) next-list)
 220                   (next-list (cdr curr-list) (cdr curr-list))
 221                   (next-elem (car next-list) (car next-list))
 222                   end-flag)
 223                  (end-flag)
 224               (when (or (null next-elem)
 225                         (funcall predicate
 226                                  (funcall key element)
 227                                  (funcall key next-elem)))
 228                 (setf end-flag t)
 229                 (if (null next-elem)
 230                     ;; end of the queue has been reached
 231                     (setf (cdr curr-list) (list element)
 232                           (queue-tail queue) (cdr curr-list))
 233                     (let ((newcons (list element)))
 234                       (setf (cdr curr-list) newcons
 235                             (cdr newcons) next-list))))))))
 236   queue)
 237
 238
 239 ;; TODO: make it traverse the queue only once
 240 (defun queue-filter (queue test &optional (key #'identity))
 241   "Delete from the queue all elements that satisfy TEST
 242 and return them as list."
 243   (assert (queue-p queue))
 244   (remove-if-not test (queue-head queue) :key key))
 245
 246
 247 ;; TODO: make it traverse the queue only once
 248 (defun queue-filter-and-delete (queue test &optional (key #'identity))
 249   "Delete from the queue all elements that satisfy TEST
 250 and return them as list."
 251   (assert (queue-p queue))
 252   (prog1 (remove-if-not test (queue-head queue) :key key)
 253     (setf (queue-head queue) (delete-if test (queue-head queue) :key key)
 254           (queue-tail queue) (last (queue-head queue)))))
 255
 256
 257 ;;;; queue.lisp                       --                     --          ;;;;