; destructuring-bind

(define-syntax bind (lambda (stx) ; (bind pattern values body ...)
  ; Pattern is a possibly-nested list of symbols, values is a list of items of
  ; the same "shape" as pattern, and body is a non-empty sequence of expressions.
  ; The bind macro executes the body expressions in an environment with each
  ; value let-bound to the corresponding symbol. Writing "& x" at the end of the
  ; pattern list causes the remaining values to be bound to x in a list. Symbol
  ; "_" in the pattern matches the corresponding value but causes no binding.
  ; Extra values are silently ignored, missing values cause an error. Examples:
  ;     (bind (a b c) '(1 2 3) (list c b a)) => (3 2 1)
  ;     (bind (a b c) '(1 2 3 4) (list c b a)) => (3 2 1)
  ;     (bind (a b c) '(1 2) (list c b a)) => causes an error
  ;     (bind (a b (c d)) '(1 2 (3 4)) (list d c b a)) => (4 3 2 1)
  ;     (bind (a b & c) '(1 2 3 4) (list c b a)) => ((3 4) 2 1)
  ;     (bind (a _ c) '(1 2 3) (list c a)) => (3 1)
  ;     (let ((x 3)) (bind (a b c) '(1 (+ 1 1) x) (list c b a))) => (x (+ 1 1) 1)
  ;     (let ((x 3)) (bind (a b c) `(1 ,(+ 1 1) ,x) (list c b a))) => (3 2 1)
  ; As an example, the macro-expression (bind (a b c) '(1 2 3) (list c b a))
  ; expands to (let ((a 1)) (let ((b 2)) (let ((c 3)) (list c b a)))). Similar to
  ; Common Lisp destruturing-bind or many "match" macro libraries in Scheme.
  (define (underscore? x) (and (identifier? x) (free-identifier=? x (syntax _))))
  (syntax-case stx (&)
    ((bind () vals body ...) ; end of pattern, ignore extra values
      (syntax (begin body ...)))
    ((bind (& pat) vals body ...) ; rest pattern, collect remaining values
      (syntax (let ((pat vals)) body ...)))
    ((bind (underscore) vals body ...) ; non-binding pattern at end
      (underscore? (syntax underscore)) (syntax (begin body ...)))
    ((bind (underscore pat ...) vals body ...) ; non-binding pattern not at end
      (underscore? (syntax underscore))
        (syntax (bind (pat ...) (cdr vals) body ...)))
    ((bind ((nest ...) pat ...) vals body ...) ; nested pattern
      (syntax (bind (pat ...) (cdr vals) (bind (nest ...) (car vals) body ...))))
    ((bind (pat) vals body ...) ; last binding in pattern
      (syntax (let ((pat (car vals))) body ...)))
    ((bind (pat1 pat2 ...) vals body ...) ; more bindings in pattern
      (syntax (let ((pat1 (car vals))) (bind (pat2 ...) (cdr vals) body ...)))))))
 
 (define queue list)

(define empty (queue '() 0 (delay '()) 0 '()))
(define (empty? q) (bind (_ lenf _ _ _) q (zero? lenf)))

(define (checkw q) (bind (w lenf f lenr r) q
  (if (null? w) (queue (force f) lenf f lenr r) q)))
(define (check q) (bind (w lenf f lenr r) q
  (if (< lenr lenf) (checkw q)
    (let ((fprime (force f)))
      (checkw (queue fprime (+ lenf lenr)
                     (delay (append fprime (reverse r))) 0 '()))))))

(define (snoc q x) (bind (w lenf f lenr r) q
  (check (queue w lenf f (+ lenr 1) (cons x r)))))

(define (head q) (bind (w _ _ _ _) q
  (if (null? w) (error 'head "empty queue") (car w))))
(define (tail q) (bind (w lenf f lenr r) q
  (if (null? w) (error 'tail "empty queue")
    (check (queue (cdr w) (- lenf 1) (delay (cdr (force f))) lenr r)))))

(define q empty)
(set! q (snoc q 1))
(set! q (snoc q 2))
(set! q (snoc q 3))
(display (head q)) (newline)
(set! q (tail q))
(display (head q)) (newline)
(set! q (tail q))
(display (head q)) (newline)
(set! q (tail q))
(display (empty? q)) (newline)