+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; A simple queue
-;;;
-;;; (c) 2008 Mark Wooding
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This program is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with this program; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(defpackage #:queue
- (:use #:common-lisp)
- (:export #:make-queue #:queue-emptyp #:enqueue #:dequeue))
-(in-package #:queue)
-
-(defun make-queue ()
- "Make a new queue object."
- ;; A queue is just a cons cell. The cdr is the head of the list of items
- ;; in the queue, and the car points to the last entry in the list. If the
- ;; queue is empty, then the car points to the queue itself for the sake of
- ;; uniformity.
- (let ((q (cons nil nil)))
- (setf (car q) q)))
-
-(defun queue-emptyp (q)
- "Answer whether the queue Q is empty."
- (null (cdr q)))
-
-(defun enqueue (x q)
- "Enqueue the object X into the queue Q."
- (let ((c (cons x nil)))
- (setf (cdr (car q)) c
- (car q) c)))
-
-(defun dequeue (q)
- "Remove and return the object at the head of the queue Q."
- (if (queue-emptyp q)
- (error "Queue is empty.")
- (let ((c (cdr q)))
- (prog1 (car c)
- (unless (setf (cdr q) (cdr c))
- (setf (car q) q))))))
-
-#+ test
-(defun queue-check (q)
- "Check consistency of the queue Q."
- (assert (car q))
- (if(null (cdr q))
- (assert (eq (car q) q))
- (do ((tail (car q))
- (collection nil (cons (car item) collection))
- (item (cdr q) (cdr item)))
- ((endp item) (nreverse collection))
- (if (cdr item)
- (assert (not (eq item tail)))
- (assert (eq item tail))))))
-
-#+ test
-(defun test-queue ()
- "Randomized test of the queue functions."
- (let ((q (make-queue))
- (want nil))
- (dotimes (i 10000)
- (case (random 2)
- (0 (setf want (nconc want (list i)))
- (enqueue i q))
- (1 (if (null want)
- (assert (queue-emptyp q))
- (progn
- (let ((j (dequeue q))
- (k (pop want)))
- (assert (= j k)))))))
- (assert (equal want (queue-check q))))))
-
-;;;----- That's all, folks --------------------------------------------------
~mdw / jlisp / blobdiff