Commit | Line | Data |
---|---|---|
6a4d3cfd JB |
1 | ;;;; q.scm --- Queues |
2 | ;;;; | |
64705682 TTN |
3 | ;;;; Copyright (C) 1995, 2001 Free Software Foundation, Inc. |
4 | ;;;; | |
a6401ee0 JB |
5 | ;;;; This program is free software; you can redistribute it and/or modify |
6 | ;;;; it under the terms of the GNU General Public License as published by | |
7 | ;;;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;;;; any later version. | |
64705682 | 9 | ;;;; |
a6401ee0 JB |
10 | ;;;; This program is distributed in the hope that it will be useful, |
11 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;;;; GNU General Public License for more details. | |
64705682 | 14 | ;;;; |
a6401ee0 JB |
15 | ;;;; You should have received a copy of the GNU General Public License |
16 | ;;;; along with this software; see the file COPYING. If not, write to | |
17 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, | |
18 | ;;;; Boston, MA 02111-1307 USA | |
64705682 | 19 | ;;;; |
a482f2cc MV |
20 | ;;;; As a special exception, the Free Software Foundation gives permission |
21 | ;;;; for additional uses of the text contained in its release of GUILE. | |
22 | ;;;; | |
23 | ;;;; The exception is that, if you link the GUILE library with other files | |
24 | ;;;; to produce an executable, this does not by itself cause the | |
25 | ;;;; resulting executable to be covered by the GNU General Public License. | |
26 | ;;;; Your use of that executable is in no way restricted on account of | |
27 | ;;;; linking the GUILE library code into it. | |
28 | ;;;; | |
29 | ;;;; This exception does not however invalidate any other reasons why | |
30 | ;;;; the executable file might be covered by the GNU General Public License. | |
31 | ;;;; | |
32 | ;;;; This exception applies only to the code released by the | |
33 | ;;;; Free Software Foundation under the name GUILE. If you copy | |
34 | ;;;; code from other Free Software Foundation releases into a copy of | |
35 | ;;;; GUILE, as the General Public License permits, the exception does | |
36 | ;;;; not apply to the code that you add in this way. To avoid misleading | |
37 | ;;;; anyone as to the status of such modified files, you must delete | |
38 | ;;;; this exception notice from them. | |
39 | ;;;; | |
40 | ;;;; If you write modifications of your own for GUILE, it is your choice | |
41 | ;;;; whether to permit this exception to apply to your modifications. | |
42 | ;;;; If you do not wish that, delete this exception notice. | |
43 | ;;;; | |
a6401ee0 | 44 | |
64705682 | 45 | ;;; Commentary: |
6a4d3cfd | 46 | |
64705682 | 47 | ;;; Q: Based on the interface to |
a6401ee0 | 48 | ;;; |
64705682 | 49 | ;;; "queue.scm" Queues/Stacks for Scheme |
a6401ee0 | 50 | ;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992. |
a6401ee0 | 51 | |
a6401ee0 JB |
52 | ;;; {Q} |
53 | ;;; | |
1168a720 JB |
54 | ;;; A list is just a bunch of cons pairs that follows some constrains, |
55 | ;;; right? Association lists are the same. Hash tables are just | |
56 | ;;; vectors and association lists. You can print them, read them, | |
57 | ;;; write them as constants, pun them off as other data structures | |
58 | ;;; etc. This is good. This is lisp. These structures are fast and | |
59 | ;;; compact and easy to manipulate arbitrarily because of their | |
60 | ;;; simple, regular structure and non-disjointedness (associations | |
61 | ;;; being lists and so forth). | |
a6401ee0 | 62 | ;;; |
64705682 | 63 | ;;; So I figured, queues should be the same -- just a "subtype" of cons-pair |
a6401ee0 JB |
64 | ;;; structures in general. |
65 | ;;; | |
66 | ;;; A queue is a cons pair: | |
67 | ;;; ( <the-q> . <last-pair> ) | |
68 | ;;; | |
1168a720 JB |
69 | ;;; <the-q> is a list of things in the q. New elements go at the end |
70 | ;;; of that list. | |
a6401ee0 | 71 | ;;; |
1168a720 | 72 | ;;; <last-pair> is #f if the q is empty, and otherwise is the last |
64705682 | 73 | ;;; pair of <the-q>. |
a6401ee0 | 74 | ;;; |
1168a720 JB |
75 | ;;; q's print nicely, but alas, they do not read well because the |
76 | ;;; eq?-ness of <last-pair> and (last-pair <the-q>) is lost by read. | |
77 | ;;; | |
78 | ;;; All the functions that aren't explicitly defined to return | |
79 | ;;; something else (a queue element; a boolean value) return the queue | |
80 | ;;; object itself. | |
64705682 TTN |
81 | |
82 | ;;; Code: | |
83 | ||
1a179b03 MD |
84 | (define-module (ice-9 q) |
85 | :export (sync-q! make-q q? q-empty? q-empty-check q-front q-rear | |
86 | q-remove! q-push! enq! q-pop! deq! q-length)) | |
64705682 TTN |
87 | |
88 | ;;; sync-q! | |
89 | ;;; The procedure | |
1168a720 | 90 | ;;; |
a6401ee0 JB |
91 | ;;; (sync-q! q) |
92 | ;;; | |
64705682 | 93 | ;;; recomputes and resets the <last-pair> component of a queue. |
a6401ee0 | 94 | ;;; |
1a179b03 | 95 | (define (sync-q! q) |
1168a720 JB |
96 | (set-cdr! q (if (pair? (car q)) (last-pair (car q)) |
97 | #f)) | |
98 | q) | |
a6401ee0 JB |
99 | |
100 | ;;; make-q | |
101 | ;;; return a new q. | |
102 | ;;; | |
1a179b03 | 103 | (define (make-q) (cons '() #f)) |
a6401ee0 JB |
104 | |
105 | ;;; q? obj | |
106 | ;;; Return true if obj is a Q. | |
1168a720 JB |
107 | ;;; An object is a queue if it is equal? to '(() . #f) |
108 | ;;; or it is a pair P with (list? (car P)) | |
109 | ;;; and (eq? (cdr P) (last-pair (car P))). | |
a6401ee0 | 110 | ;;; |
1a179b03 | 111 | (define (q? obj) |
1168a720 JB |
112 | (and (pair? obj) |
113 | (if (pair? (car obj)) | |
114 | (eq? (cdr obj) (last-pair (car obj))) | |
115 | (and (null? (car obj)) | |
116 | (not (cdr obj)))))) | |
a6401ee0 JB |
117 | |
118 | ;;; q-empty? obj | |
64705682 | 119 | ;;; |
1a179b03 | 120 | (define (q-empty? obj) (null? (car obj))) |
a6401ee0 JB |
121 | |
122 | ;;; q-empty-check q | |
123 | ;;; Throw a q-empty exception if Q is empty. | |
1a179b03 | 124 | (define (q-empty-check q) (if (q-empty? q) (throw 'q-empty q))) |
a6401ee0 | 125 | |
a6401ee0 JB |
126 | ;;; q-front q |
127 | ;;; Return the first element of Q. | |
1a179b03 | 128 | (define (q-front q) (q-empty-check q) (caar q)) |
a6401ee0 JB |
129 | |
130 | ;;; q-rear q | |
131 | ;;; Return the last element of Q. | |
1a179b03 | 132 | (define (q-rear q) (q-empty-check q) (cadr q)) |
a6401ee0 JB |
133 | |
134 | ;;; q-remove! q obj | |
135 | ;;; Remove all occurences of obj from Q. | |
1a179b03 | 136 | (define (q-remove! q obj) |
1168a720 JB |
137 | (set-car! q (delq! obj (car q))) |
138 | (sync-q! q)) | |
a6401ee0 JB |
139 | |
140 | ;;; q-push! q obj | |
141 | ;;; Add obj to the front of Q | |
1a179b03 | 142 | (define (q-push! q obj) |
1168a720 | 143 | (let ((h (cons obj (car q)))) |
a6401ee0 | 144 | (set-car! q h) |
1168a720 JB |
145 | (or (cdr q) (set-cdr! q h))) |
146 | q) | |
a6401ee0 JB |
147 | |
148 | ;;; enq! q obj | |
149 | ;;; Add obj to the rear of Q | |
1a179b03 | 150 | (define (enq! q obj) |
1168a720 JB |
151 | (let ((h (cons obj '()))) |
152 | (if (null? (car q)) | |
153 | (set-car! q h) | |
154 | (set-cdr! (cdr q) h)) | |
155 | (set-cdr! q h)) | |
156 | q) | |
a6401ee0 JB |
157 | |
158 | ;;; q-pop! q | |
159 | ;;; Take the front of Q and return it. | |
1a179b03 | 160 | (define (q-pop! q) |
a6401ee0 JB |
161 | (q-empty-check q) |
162 | (let ((it (caar q)) | |
163 | (next (cdar q))) | |
164 | (if (not next) | |
165 | (set-cdr! q #f)) | |
166 | (set-car! q next) | |
167 | it)) | |
168 | ||
169 | ;;; deq! q | |
170 | ;;; Take the front of Q and return it. | |
1a179b03 | 171 | (define deq! q-pop!) |
a6401ee0 JB |
172 | |
173 | ;;; q-length q | |
174 | ;;; Return the number of enqueued elements. | |
175 | ;;; | |
1a179b03 | 176 | (define (q-length q) (length (car q))) |
64705682 TTN |
177 | |
178 | ;;; q.scm ends here |