Commit | Line | Data |
---|---|---|
ee79a5f1 MW |
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 | (:export #:make-queue #:queue-emptyp #:enqueue #:dequeue)) | |
27 | (in-package #:queue) | |
28 | ||
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 | (defun queue-emptyp (q) | |
39 | "Answer whether the queue Q is empty." | |
40 | (null (cdr q))) | |
41 | ||
42 | (defun enqueue (x q) | |
43 | "Enqueue the object X into the queue Q." | |
44 | (let ((c (cons x nil))) | |
45 | (setf (cdr (car q)) c | |
46 | (car q) c))) | |
47 | ||
48 | (defun dequeue (q) | |
49 | "Remove and return the object at the head of the queue Q." | |
50 | (if (queue-emptyp q) | |
51 | (error "Queue is empty.") | |
52 | (let ((c (cdr q))) | |
53 | (prog1 (car c) | |
54 | (unless (setf (cdr q) (cdr c)) | |
55 | (setf (car q) q)))))) | |
56 | ||
57 | #+ test | |
58 | (defun queue-check (q) | |
59 | "Check consistency of the queue Q." | |
60 | (assert (car q)) | |
61 | (if(null (cdr q)) | |
62 | (assert (eq (car q) q)) | |
63 | (do ((tail (car q)) | |
64 | (collection nil (cons (car item) collection)) | |
65 | (item (cdr q) (cdr item))) | |
66 | ((endp item) (nreverse collection)) | |
67 | (if (cdr item) | |
68 | (assert (not (eq item tail))) | |
69 | (assert (eq item tail)))))) | |
70 | ||
71 | #+ test | |
72 | (defun test-queue () | |
73 | "Randomized test of the queue functions." | |
74 | (let ((q (make-queue)) | |
75 | (want nil)) | |
76 | (dotimes (i 10000) | |
77 | (case (random 2) | |
78 | (0 (setf want (nconc want (list i))) | |
79 | (enqueue i q)) | |
80 | (1 (if (null want) | |
81 | (assert (queue-emptyp q)) | |
82 | (progn | |
83 | (let ((j (dequeue q)) | |
84 | (k (pop want))) | |
85 | (assert (= j k))))))) | |
86 | (assert (equal want (queue-check q)))))) | |
87 | ||
88 | ;;;----- That's all, folks -------------------------------------------------- |