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