| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; A simple queue |
| 4 | ;;; |
| 5 | ;;; (c) 2008 Mark Wooding |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This program is free software; you can redistribute it and/or modify |
| 11 | ;;; it under the terms of the GNU General Public License as published by |
| 12 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 13 | ;;; (at your option) any later version. |
| 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 General Public License |
| 21 | ;;; along with this program; if not, write to the Free Software Foundation, |
| 22 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 23 | |
| 24 | (defpackage #:queue |
| 25 | (:use #:common-lisp)) |
| 26 | (in-package #:queue) |
| 27 | |
| 28 | (export 'make-queue) |
| 29 | (defun make-queue () |
| 30 | "Make a new queue object." |
| 31 | ;; A queue is just a cons cell. The cdr is the head of the list of items |
| 32 | ;; in the queue, and the car points to the last entry in the list. If the |
| 33 | ;; queue is empty, then the car points to the queue itself for the sake of |
| 34 | ;; uniformity. |
| 35 | (let ((q (cons nil nil))) |
| 36 | (setf (car q) q))) |
| 37 | |
| 38 | (export 'queue-emptyp) |
| 39 | (defun queue-emptyp (q) |
| 40 | "Answer whether the queue Q is empty." |
| 41 | (null (cdr q))) |
| 42 | |
| 43 | (export 'enqueue) |
| 44 | (defun enqueue (x q) |
| 45 | "Enqueue the object X into the queue Q." |
| 46 | (let ((c (cons x nil))) |
| 47 | (setf (cdr (car q)) c |
| 48 | (car q) c))) |
| 49 | |
| 50 | (export 'pushqueue) |
| 51 | (defun pushqueue (x q) |
| 52 | "Push the object X onto the front of the queue Q." |
| 53 | (let* ((first (cdr q)) |
| 54 | (new (cons x first))) |
| 55 | (setf (cdr q) new) |
| 56 | (unless first (setf (car q) new)))) |
| 57 | |
| 58 | (export 'dequeue) |
| 59 | (defun dequeue (q) |
| 60 | "Remove and return the object at the head of the queue Q." |
| 61 | (if (queue-emptyp q) |
| 62 | (error "Queue is empty.") |
| 63 | (let ((c (cdr q))) |
| 64 | (prog1 (car c) |
| 65 | (unless (setf (cdr q) (cdr c)) |
| 66 | (setf (car q) q)))))) |
| 67 | |
| 68 | #+ test |
| 69 | (defun queue-check (q) |
| 70 | "Check consistency of the queue Q." |
| 71 | (assert (car q)) |
| 72 | (if(null (cdr q)) |
| 73 | (assert (eq (car q) q)) |
| 74 | (do ((tail (car q)) |
| 75 | (collection nil (cons (car item) collection)) |
| 76 | (item (cdr q) (cdr item))) |
| 77 | ((endp item) (nreverse collection)) |
| 78 | (if (cdr item) |
| 79 | (assert (not (eq item tail))) |
| 80 | (assert (eq item tail)))))) |
| 81 | |
| 82 | #+ test |
| 83 | (defun test-queue () |
| 84 | "Randomized test of the queue functions." |
| 85 | (let ((q (make-queue)) |
| 86 | (want nil)) |
| 87 | (dotimes (i 10000) |
| 88 | (case (random 3) |
| 89 | (0 (setf want (nconc want (list i))) |
| 90 | (enqueue i q)) |
| 91 | (1 (push i want) |
| 92 | (pushqueue i q)) |
| 93 | (2 (if (null want) |
| 94 | (assert (queue-emptyp q)) |
| 95 | (progn |
| 96 | (let ((j (dequeue q)) |
| 97 | (k (pop want))) |
| 98 | (assert (= j k))))))) |
| 99 | (assert (equal want (queue-check q)))))) |
| 100 | |
| 101 | ;;;----- That's all, folks -------------------------------------------------- |