; deques
(define (split n xs)
(let loop ((n n) (xs xs) (zs (list)))
(if (or (zero? n) (null? xs))
(values (reverse zs) xs)
(loop (- n 1) (cdr xs) (cons (car xs) zs)))))
(define dq-null (cons (list) (list)))
(define (dq-null? xs) (equal? xs dq-null))
(define (dq-singleton? xs)
(or (and (null? (car xs)) (pair? (cdr xs)))
(and (pair? (car xs)) (null? (cdr xs)))))
(define (dq-cons x xs)
(if (null? (car xs)) (cons (list x) (cdr xs))
(if (null? (cdr xs)) (cons (list x) (car xs))
(cons (cons x (car xs)) (cdr xs)))))
(define (dq-snoc x xs)
(if (null? (cdr xs)) (cons (car xs) (list x))
(if (null? (car xs)) (cons (cdr xs) (list x))
(cons (car xs) (cons x (cdr xs))))))
(define (dq-head xs)
(if (pair? (car xs)) (caar xs)
(if (pair? (cdr xs)) (cadr xs)
(error 'dq-head "null deque"))))
(define (dq-last xs)
(if (pair? (cdr xs)) (cadr xs)
(if (pair? (car xs)) (caar xs)
(error 'dq-last "null deque"))))
(define (dq-tail xs)
(if (null? (car xs))
(if (pair? (cdr xs)) dq-null
(error 'dq-tail "null deque"))
(if (pair? (cdar xs)) (cons (cdar xs) (cdr xs))
(call-with-values
(lambda ()
(split (quotient (length (cdr xs)) 2) (reverse (cdr xs))))
(lambda (f b) (cons f (reverse b)))))))
(define (dq-init xs)
(if (null? (cdr xs))
(if (pair? (car xs)) dq-null
(error 'dq-init "null deque"))
(if (pair? (cddr xs)) (cons (car xs) (cddr xs))
(call-with-values
(lambda ()
(split (quotient (length (car xs)) 2) (reverse (car xs))))
(lambda (f b) (cons f (reverse b)))))))
(define (list->dq xs)
(call-with-values
(lambda () (split (quotient (length xs) 2) xs))
(lambda (f b) (cons f (reverse b)))))
(define (dq->list xs) (append (car xs) (reverse (cdr xs))))
; testing
(define-syntax assert
(syntax-rules ()
((assert expr result)
(if (not (equal? expr result))
(for-each display `(
#\newline "failed assertion:" #\newline
expr #\newline "expected: " ,result
#\newline "returned: " ,expr #\newline))))))
(define dq #f)
(define (test-dq)
(set! dq dq-null)
(do ((i 1 (+ i 1))) ((< 5 i))
(set! dq (dq-cons i dq)))
(assert (dq->list dq) '(5 4 3 2 1))
(do ((i 5 (- i 1))) ((zero? i))
(assert (dq-head dq) i)
(set! dq (dq-tail dq)))
(assert (dq-null? dq) #t)
(do ((i 1 (+ i 1))) ((< 5 i))
(set! dq (dq-snoc i dq)))
(assert (dq->list dq) '(1 2 3 4 5))
(do ((i 5 (- i 1))) ((zero? i))
(assert (dq-last dq) i)
(set! dq (dq-init dq)))
(assert (dq-null? dq) #t)
(assert (list->dq '()) dq-null)
(assert (dq-singleton? dq-null) #f)
(assert (dq-singleton? (list->dq '(1))) #t)
(assert (dq->list (list->dq '(1 2 3 4 5))) '(1 2 3 4 5)))
(test-dq)