pattern matching: red-black trees

This is based on Okasaki's "Purely Functional Data Structures", Chapter 3.3.

(include "lib/core.scm")
(include "lib/random.scm")

(datatype T
  (:E)
  (:R (T 'a) 'a (T 'a))
  (:B (T 'a) 'a (T 'a))
  )

(define (T/insert root < k)

  (define lbalance
    (T:R (T:R a x b) y c) z d -> (T:R (T:B a x b) y (T:B c z d))
    (T:R a x (T:R b y c)) z d -> (T:R (T:B a x b) y (T:B c z d))
    a x b                     -> (T:B a x b)
    )

  (define rbalance
    a x (T:R (T:R b y c) z d) -> (T:R (T:B a x b) y (T:B c z d))
    a x (T:R b y (T:R c z d)) -> (T:R (T:B a x b) y (T:B c z d))
    a x b                     -> (T:B a x b)
    )

  (define (ins n)
    (match n with
      (T:E)
      -> (T:R (T:E) k (T:E))

      (T:R l k2 r)
      -> (cond ((< k k2)
                (T:R (ins l) k2 r))
               ((< k2 k)
                (T:R l k2 (ins r)))
               (else n))

      (T:B l k2 r)
      -> (cond ((< k k2)
                (lbalance (ins l) k2 r))
               ((< k2 k)
                (rbalance l k2 (ins r)))
               (else n))
      ))

  (let ((s (ins root)))
    (match s with
      (T:R l k r) -> (T:B l k r)
      (T:B _ _ _) -> s
      (T:E s)     -> (impossible)
      )))

(define (print-spaces n)
  (let loop ((n n))
    (cond ((> n 0)
           (print-string "  ")
           (loop (- n 1))))))

(define (print-item x d)
  (print-spaces d)
  (printn x))

(define T/print
  d (T:E)       -> #u
  d (T:R l x r) -> (begin (T/print (+ d 1) l) (print-item x d) (T/print (+ d 1) r))
  d (T:B l x r) -> (begin (T/print (+ d 1) l) (print-item x d) (T/print (+ d 1) r))
  )

(define (n-random n)
  (let loop ((n n)
             (t (T:E)))
    (if (= n 0)
        t
        (loop (- n 1) (T/insert t < (random))))))

(T/print 0 (n-random 20))