2021-06-11 12:18:53 +00:00
|
|
|
#lang racket/base
|
|
|
|
;;; SPDX-License-Identifier: LGPL-3.0-or-later
|
2022-01-16 08:48:18 +00:00
|
|
|
;;; SPDX-FileCopyrightText: Copyright © 2011-2022 Tony Garnock-Jones <tonyg@leastfixedpoint.com>
|
2021-06-11 12:18:53 +00:00
|
|
|
|
|
|
|
(provide make-queue
|
|
|
|
queue?
|
|
|
|
enqueue
|
|
|
|
enqueue-all
|
|
|
|
undequeue
|
|
|
|
queue-prepare-for-dequeue
|
|
|
|
dequeue
|
|
|
|
dequeue*
|
|
|
|
queue-prepare-for-unenqueue
|
|
|
|
unenqueue
|
|
|
|
unenqueue*
|
|
|
|
list->queue
|
|
|
|
queue->list
|
|
|
|
queue-length
|
|
|
|
queue-empty?
|
|
|
|
queue-append
|
|
|
|
queue-append-list
|
|
|
|
queue-extract
|
|
|
|
queue-filter
|
|
|
|
queue-remove
|
|
|
|
queue-partition)
|
|
|
|
|
|
|
|
(require (only-in racket/list partition))
|
|
|
|
|
|
|
|
(struct queue (head tail) #:transparent)
|
|
|
|
|
|
|
|
(define (make-queue)
|
|
|
|
(queue '() '()))
|
|
|
|
|
|
|
|
(define (enqueue q v)
|
|
|
|
(queue (queue-head q)
|
|
|
|
(cons v (queue-tail q))))
|
|
|
|
|
|
|
|
(define (enqueue-all q v)
|
|
|
|
(queue (queue-head q)
|
|
|
|
(append (reverse v) (queue-tail q))))
|
|
|
|
|
|
|
|
(define (undequeue v q)
|
|
|
|
(queue (cons v (queue-head q))
|
|
|
|
(queue-tail q)))
|
|
|
|
|
|
|
|
(define (queue-prepare-for-dequeue q)
|
|
|
|
(if (null? (queue-head q))
|
|
|
|
(queue (reverse (queue-tail q)) '())
|
|
|
|
q))
|
|
|
|
|
|
|
|
(define (dequeue q)
|
|
|
|
(let* ((q1 (queue-prepare-for-dequeue q))
|
|
|
|
(h (queue-head q1)))
|
|
|
|
(if (pair? h)
|
|
|
|
(values (car h) (queue (cdr h) (queue-tail q1)))
|
|
|
|
(values))))
|
|
|
|
|
|
|
|
(define (dequeue* q)
|
|
|
|
(call-with-values (lambda () (dequeue q)) list))
|
|
|
|
|
|
|
|
(define (queue-prepare-for-unenqueue q)
|
|
|
|
(if (null? (queue-tail q))
|
|
|
|
(queue '() (reverse (queue-head q)))
|
|
|
|
q))
|
|
|
|
|
|
|
|
(define (unenqueue q)
|
|
|
|
(let* ((q1 (queue-prepare-for-unenqueue q))
|
|
|
|
(t (queue-tail q1)))
|
|
|
|
(if (pair? t)
|
|
|
|
(values (queue (queue-head q1) (cdr t)) (car t))
|
|
|
|
(values))))
|
|
|
|
|
|
|
|
(define (unenqueue* q)
|
|
|
|
(call-with-values (lambda () (unenqueue q)) list))
|
|
|
|
|
|
|
|
(define (list->queue xs)
|
|
|
|
(queue xs '()))
|
|
|
|
|
|
|
|
(define (queue->list q)
|
|
|
|
(append (queue-head q) (reverse (queue-tail q))))
|
|
|
|
|
|
|
|
(define (queue-length q)
|
|
|
|
(+ (length (queue-head q))
|
|
|
|
(length (queue-tail q))))
|
|
|
|
|
|
|
|
(define (queue-empty? q)
|
|
|
|
(and (null? (queue-head q))
|
|
|
|
(null? (queue-tail q))))
|
|
|
|
|
|
|
|
(define (queue-append q1 q2)
|
|
|
|
(queue (append (queue-head q1)
|
|
|
|
(reverse (queue-tail q1))
|
|
|
|
(queue-head q2))
|
|
|
|
(queue-tail q2)))
|
|
|
|
|
|
|
|
(define (queue-append-list q1 xs)
|
|
|
|
(queue (queue-head q1)
|
|
|
|
(append (reverse xs) (queue-tail q1))))
|
|
|
|
|
|
|
|
(define (queue-extract q predicate [default-value #f])
|
|
|
|
(let search-head ((head (queue-head q))
|
|
|
|
(rejected-head-rev '()))
|
|
|
|
(cond
|
|
|
|
((null? head) (let search-tail ((tail (reverse (queue-tail q)))
|
|
|
|
(rejected-tail-rev '()))
|
|
|
|
(cond
|
|
|
|
((null? tail) (values default-value q))
|
|
|
|
((predicate (car tail)) (values (car tail)
|
|
|
|
(queue (queue-head q)
|
|
|
|
(append (reverse (cdr tail))
|
|
|
|
rejected-tail-rev))))
|
|
|
|
(else (search-tail (cdr tail) (cons (car tail) rejected-tail-rev))))))
|
|
|
|
((predicate (car head)) (values (car head)
|
|
|
|
(queue (append (reverse rejected-head-rev)
|
|
|
|
(cdr head))
|
|
|
|
(queue-tail q))))
|
|
|
|
(else (search-head (cdr head) (cons (car head) rejected-head-rev))))))
|
|
|
|
|
|
|
|
(define (queue-filter pred q)
|
|
|
|
(queue (filter pred (queue-head q))
|
|
|
|
(filter pred (queue-tail q))))
|
|
|
|
|
|
|
|
(define (queue-remove item q)
|
|
|
|
(list->queue (remove item (queue->list q))))
|
|
|
|
|
|
|
|
(define (queue-partition pred q)
|
|
|
|
(define-values (head-t head-f) (partition pred (queue-head q)))
|
|
|
|
(define-values (tail-t tail-f) (partition pred (queue-tail q)))
|
|
|
|
(values (queue head-t tail-t)
|
|
|
|
(queue head-f tail-f)))
|