Functional Queues ala Okasaki in Racket

queue.rkt

#lang racket/base
(provide
 queue?          ;; any -> boolean
 queue           ;; any ... -> queue
 empty-queue     ;; queue
 queue-empty?    ;; queue -> boolean
 queue-count     ;; queue -> nonnegative-integer
 queue-first     ;; queue -> any
 queue-rest      ;; queue -> queue
 queue-add       ;; queue any -> queue
 in-queue        ;; e.g. (for ([x (in-queue ....)]) ....)
 queue->list
 list->queue)

(require
 racket/promise
 racket/match
 (only-in racket/stream gen:stream empty-stream stream-cons)
 (only-in racket/struct make-constructor-style-printer)
 (only-in racket/sequence sequence-append)
 (for-syntax racket/base))

;; =======================================================================================
;; FIFO Queues, implemented using the lazy queue with prefix
;; method of Okasaki (Ch 3.5).

(struct queue-internal [prefix front front-len back back-len]
  #:methods gen:custom-write
  [(define write-proc
     (make-constructor-style-printer
      (λ (_) 'queue)
      (λ (q) (queue->list q))))]

  #:methods gen:stream
  [(define (stream-first q) (queue-first q))
   (define (stream-rest q) (queue-rest q))
   (define (stream-empty? q) (queue-empty? q))]

  #:methods gen:equal+hash
  [(define (equal-proc p q =?) (queue=?/recur p q =?))
   (define (hash-proc q hsh) (queue-hash q hsh 4457 3217))
   (define (hash2-proc q hsh) (queue-hash q hsh 797 6451))])

(define queue?
  (procedure-rename queue-internal? 'queue?))

(define empty-queue
  (queue-internal '[] (lazy '[]) 0 '[] 0))

(define (list->queue l)
  (unless (list? l)
    (raise-argument-error 'list->queue "list?"))
  (queue-internal l (lazy l) (length l) '[] 0))

;; (queue x1 x2 ... xN)
(define-match-expander queue
  (syntax-rules () [(_ pat ...) (app queue->list (list pat ...))])
  (syntax-rules () [(_ elem ...) (list->queue (list elem ...))]))

;; Pseudo-constructor for building queues internally
;; w : list               prefix
;; f : [promise list]     front
;; nf : nat               front length
;; b : list               back
;; nb : nat               back length
(define (mk-queue w f nf b nb)
  (define-values [w* f* nf* b* nb*]
    (cond
      [(<= nb nf) (values w f nf b nb)]
      [else (define w* (force f))
            (define w+revb (lazy (append w* (reverse b))))
            (values w* w+revb (+ nf nb) '[] 0)]))
  (define w**
    (if (null? w*) (force f*) w*))
  (queue-internal w** f* nf* b* nb*))

(define-syntax-rule
  (define/queue (name w f nf b nb arg ...) body ...)
  (define (name q arg ...)
    (match q
      [(queue-internal w f nf b nb) (let () body ...)]
      [_ (raise-argument-error 'name "queue?" q)])))

(define/queue (queue-empty? w _ _  _ _ ) (null? w))
(define/queue (queue-count  _ _ nf _ nb) (+ nf nb))
(define/queue (queue->list  _ f _  b _ ) (append (force f) (reverse b)))
(define/queue (queue-add    w f nf b nb elem)
  (mk-queue w f nf (cons elem b) (add1 nb)))

(define-syntax-rule
  (define/ne-queue (name x w f nf b nb arg ...) body ...)
  (define (name q arg ...)
    (match q
      [(queue-internal (cons x w) f nf b nb) (let () body ...)]
      [_ (raise-argument-error 'name "(and/c queue? (not/c queue-empty?))" q)])))

(define/ne-queue (queue-first x _ _ _  _ _ ) x)
(define/ne-queue (queue-rest  _ w f nf b nb)
  (mk-queue w (lazy (cdr (force f))) (sub1 nf) b nb))

(define (in-queue/proc q)
  (unless (queue-internal? q)
    (raise-argument-error 'in-queue "queue?" q))
  (if (queue-empty? q)
      empty-stream
      (stream-cons (queue-first q)
                   (in-queue/proc (queue-rest q)))))

(define-sequence-syntax in-queue
  (λ () #'in-queue/proc)
  (λ (stx)
    (syntax-case stx []
      [[(elem) (_ q-expr)]
       #'[(elem)
          (:do-in ([(q0) q-expr])
                  (unless (queue-internal? q0)
                    (raise-argument-error 'in-queue "queue?" q0))
                  ([q q0])
                  (not (queue-empty? q))
                  ([(elem) (queue-first q)] [(rst) (queue-rest q)])
                  #t
                  #t
                  (rst))]]
      [_ #f])))

(define (queue=?/recur p q elem=?)
  (match* {p q}
    [{(queue-internal w1 f1 nf1 b1 nb1)
      (queue-internal w2 f2 nf2 b2 nb2)}
     (and (= (+ nf1 nb1) (+ nf2 nb2))
          (for/and ([x (sequence-append (force f1) (reverse b1))]
                    [y (sequence-append (force f2) (reverse b2))])
            (elem=? x y)))]))

(define (queue-hash q elem-hash n k)
  (+ n (for/sum ([x (in-queue q)])
         (* (elem-hash x) k))))