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