[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/ll2dgmTM    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Sep 5:
; 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)


Output:
No errors or program output.


Create a new paste based on this one


Comments: