Commit | Line | Data |
---|---|---|
2626af66 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 | |
77f935da | 25 | (:use #:common-lisp)) |
2626af66 MW |
26 | (in-package #:queue) |
27 | ||
77f935da | 28 | (export 'make-queue) |
2626af66 MW |
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 | ||
77f935da | 38 | (export 'queue-emptyp) |
2626af66 MW |
39 | (defun queue-emptyp (q) |
40 | "Answer whether the queue Q is empty." | |
41 | (null (cdr q))) | |
42 | ||
77f935da | 43 | (export 'enqueue) |
2626af66 MW |
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 | ||
77f935da | 50 | (export 'pushqueue) |
dd33a773 MW |
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 | ||
77f935da | 58 | (export 'dequeue) |
2626af66 MW |
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) | |
dd33a773 | 88 | (case (random 3) |
2626af66 MW |
89 | (0 (setf want (nconc want (list i))) |
90 | (enqueue i q)) | |
dd33a773 MW |
91 | (1 (push i want) |
92 | (pushqueue i q)) | |
93 | (2 (if (null want) | |
2626af66 MW |
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 -------------------------------------------------- |