1;;;
2;;; srfi-117 - Queues based on lists
3;;;
4;;;   Copyright (c) 2015-2020  Shiro Kawai  <shiro@acm.org>
5;;;
6;;;   Redistribution and use in source and binary forms, with or without
7;;;   modification, are permitted provided that the following conditions
8;;;   are met:
9;;;
10;;;   1. Redistributions of source code must retain the above copyright
11;;;      notice, this list of conditions and the following disclaimer.
12;;;
13;;;   2. Redistributions in binary form must reproduce the above copyright
14;;;      notice, this list of conditions and the following disclaimer in the
15;;;      documentation and/or other materials provided with the distribution.
16;;;
17;;;   3. Neither the name of the authors nor the names of its contributors
18;;;      may be used to endorse or promote products derived from this
19;;;      software without specific prior written permission.
20;;;
21;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32;;;
33
34;; srfi-117 list queue is implemented on top of data.queue in Gauche
35
36(define-module srfi-117
37  (use data.queue)
38  (export make-list-queue list-queue list-queue-copy
39          list-queue-unfold list-queue-unfold-right
40          list-queue? list-queue-empty?
41          list-queue-front list-queue-back
42          list-queue-list list-queue-first-last
43          list-queue-add-front! list-queue-add-back!
44          list-queue-remove-front! list-queue-remove-back!
45          list-queue-remove-all!
46          list-queue-set-list!
47          list-queue-append list-queue-append!
48          list-queue-concatenate
49          list-queue-map list-queue-map! list-queue-for-each))
50(select-module srfi-117)
51
52(define (make-list-queue lis :optional last)
53  (if (pair? last)
54    (rlet1 q (make-queue) ; needs to satisfy O(1) restriction
55      ((with-module data.queue %queue-set-content!) q lis last))
56    (list->queue lis)))
57
58(define (list-queue . elts) (list->queue elts))
59
60(define (list-queue-copy q) (copy-queue q))
61
62(define (list-queue-unfold stop? mapper successor seed
63                           :optional (q (make-queue)))
64  (let loop ((seed seed) (elts '()))
65    (if (stop? seed)
66      (dolist [e elts] (queue-push! q e))
67      (loop (successor seed) (cons (mapper seed) elts))))
68  q)
69
70(define (list-queue-unfold-right stop? mapper successor seed
71                                 :optional (q (make-queue)))
72  (let loop ((seed seed) (elts '()))
73    (if (stop? seed)
74      (dolist [e elts] (enqueue! q e))
75      (loop (successor seed) (cons (mapper seed) elts))))
76  q)
77
78(define (list-queue? q) (queue? q))
79(define (list-queue-empty? q) (queue-empty? q))
80(define (list-queue-front q) (queue-front q))
81(define (list-queue-back q) (queue-rear q))
82(define (list-queue-list q) (queue-internal-list q))
83
84;; This also returns internal structure.
85(define (list-queue-first-last q)
86  (when (mtqueue? q)
87    (error "Can't get internal pairs of <mtqueue>:" q))
88  (values ((with-module data.queue %qhead) q)
89          ((with-module data.queue %qtail) q)))
90
91(define (list-queue-add-front! q elt) (queue-push! q elt))
92(define (list-queue-add-back! q elt ) (enqueue! q elt))
93(define (list-queue-remove-front! q)  (dequeue! q))
94(define (list-queue-remove-back! q)
95  ;; it's ok to be O(n), so we take gratuitously inefficient path
96  (let loop ([n (queue-length q)]
97             [elts (dequeue-all! q)])
98    (if (= n 1)
99      (car elts)
100      (begin (enqueue! q (car elts))
101             (loop (- n 1) (cdr elts))))))
102
103(define (list-queue-remove-all! q) (dequeue-all! q))
104
105(define (list-queue-set-list! q lis :optional last)
106  (let1 last (last-pair lis)
107    ((with-module data.queue %queue-set-content!) q lis last)
108    q))
109
110(define (list-queue-append . qs)
111  (list-queue-concatenate qs))
112
113(define (list-queue-append! . qs)
114  (let loop ([qs qs]
115             [head '()]
116             [tail '()])
117    (if (null? qs)
118      (make-list-queue head tail)
119      (receive (hd tl) (list-queue-first-last (car qs))
120        ;; we purge the original queues, so that the mutation of internal
121        ;; cells won't confuse them.
122        (dequeue-all! (car qs))
123        (cond [(null? hd) (loop (cdr qs) head tail)]
124              [(pair? tail)
125               (begin (set-cdr! tail hd) (loop (cdr qs) head tl))]
126              [else (loop (cdr qs) hd tl)])))))
127
128(define (list-queue-concatenate qs)
129  (list->queue (concatenate (map list-queue-list qs))))
130
131(define (list-queue-map proc q)
132  (list->queue (map proc (queue->list q))))
133
134(define (list-queue-map! proc q)
135  (let1 xs (map proc (queue->list q))
136    ((with-module data.queue %queue-set-content!) q xs #f)
137    q))
138
139(define (list-queue-for-each proc q)
140  (for-each proc (queue->list q)))
141
142