1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
#| queues.jl -- fifo queues
$Id: queues.jl,v 1.6 2002/04/14 07:22:40 jsh Exp $
Copyright (C) 2000 John Harper <john@dcs.warwick.ac.uk>
This file is part of librep.
librep 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, or (at your option)
any later version.
librep 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 Jade; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|#
(define-structure rep.data.queues
(export make-queue
enqueue
dequeue
queue-empty-p
queuep
queue->list
queue-length
delete-from-queue)
(open rep
rep.data.datums
rep.test.framework)
(define-structure-alias queues rep.data.queues)
(define type-id (cons))
(define-datum-printer type-id (lambda (q stream)
(declare (unused q))
(write stream "#<queue>")))
;; Each queue is (TAIL . HEAD). HEAD is the list of items, TAIL
;; points to the last cell in HEAD, or the empty list.
(define (make-queue)
(make-datum (cons) type-id))
(define (enqueue q x)
(let ((cell (datum-ref q type-id))
(new (list x)))
(if (null (cdr cell))
;; empty queue
(progn
(rplacd cell new)
(rplaca cell new))
;; tail pointer is set
(rplacd (car cell) new)
(rplaca cell new))))
(define (dequeue q)
(let ((cell (datum-ref q type-id)))
(if (null (cdr cell))
(error "Can't dequeue from empty queue")
(prog1 (car (cdr cell))
(if (not (eq (car cell) (cdr cell)))
;; at least one element left
(rplacd cell (cdr (cdr cell)))
;; queue needs to be empty now
(rplacd cell '())
(rplaca cell '()))))))
(define (queue-empty-p q)
(null (cdr (datum-ref q type-id))))
(define (queuep q)
(has-type-p q type-id))
(define (queue->list q)
(cdr (datum-ref q type-id)))
(define (queue-length q)
(length (queue->list q)))
(define (delete-from-queue q x)
(let ((cell (datum-ref q type-id)))
(let loop ((ptr cell))
(if (null (cdr ptr))
;; avoid pointing tail to itself..
(if (null (cdr cell))
(rplaca cell '())
(rplaca cell ptr))
(if (eq (cadr ptr) x)
(progn
(rplacd ptr (cddr ptr))
(loop ptr))
(loop (cdr ptr)))))))
;;; tests
;;###autoload
(define-self-test 'rep.data.queues
(lambda ()
(let ((queue (make-queue)))
(test (queuep queue))
(test (queue-empty-p queue))
(test (null (queue->list queue)))
(test (= (queue-length queue) 0))
(enqueue queue 1)
(test (not (queue-empty-p queue)))
(test (equal (queue->list queue) '(1)))
(test (= (queue-length queue) 1))
(enqueue queue 2)
(test (equal (queue->list queue) '(1 2)))
(test (= (queue-length queue) 2))
(test (= (dequeue queue) 1))
(test (equal (queue->list queue) '(2)))
(test (= (queue-length queue) 1))
(enqueue queue 3)
(enqueue queue 4)
(enqueue queue 5)
(test (equal (queue->list queue) '(2 3 4 5)))
(delete-from-queue queue 2)
(test (equal (queue->list queue) '(3 4 5)))
(delete-from-queue queue 4)
(test (equal (queue->list queue) '(3 5)))
(delete-from-queue queue 5)
(test (equal (queue->list queue) '(3)))
(delete-from-queue queue 3)
(test (= (queue-length queue) 0))
(test (queue-empty-p queue))))))
|
