Programming Praxis

The datatype Rlist is a list of (int * α Tree), where an α Tree is either a Leaf of α or a Node of (α * α Tree * α Tree). We provide the following structures, where an item is a single element of an Rlist:

(define-structure leaf x)
(define-structure node x t1 t2)
(define-structure item w t)

The empty Rlist is trivial:

(define empty (list))
(define empty? null?)

The cons function, which we spell kons to distinguish it from the built-in function on normal lists, adds a new item if the Rlist is empty or singleton, otherwise it builds a new Node from the first two Items in the Rlist:

(define (kons x ts)
  (if (or (empty? ts) (empty? (cdr ts)))
      (cons (make-item 1 (make-leaf x)) ts)
      (let ((w1 (item-w (car ts))) (w2 (item-w (cadr ts)))
            (t1 (item-t (car ts))) (t2 (item-t (cadr ts))))
        (if (= w1 w2)
            (cons (make-item (+ 1 w1 w2) (make-node x t1 t2)) (cddr ts))
            (cons (make-item 1 (make-leaf x)) ts)))))

The head and tail functions look at the first item in the Rlist and branch on whether it is a Leaf or a Node. Both functions are careful to report an error if handed an empty list. Note the “impossible” conditions, which were, sadly, very valuable during development of the functions:

(define (head ts)
  (cond ((empty? ts) (error 'head "empty list"))
        ((leaf? (item-t (car ts)))
          (if (= (item-w (car ts)) 1)
              (leaf-x (item-t (car ts)))
              (error 'head "impossible")))
        ((node? (item-t (car ts)))
          (node-x (item-t (car ts))))
        (else (error 'head "impossible"))))

(define (tail ts)
  (cond ((empty? ts) (error 'tail "empty list"))
        ((leaf? (item-t (car ts)))
          (if (= (item-w (car ts)) 1)
              (cdr ts)
              (error 'tail "impossible")))
        ((node? (item-t (car ts)))
          (let* ((w (item-w (car ts))) (w2 (quotient w 2))
                 (t (item-t (car ts))) (ts (cdr ts))
                 (t1 (node-t1 t)) (t2 (node-t2 t)))
            (cons (make-item w2 t1) (cons (make-item w2 t2) ts))))
        (else (error 'tail "impossible"))))

That dispenses with the normal list functions of the random access lists, so it is a good time to stop and test what we have done:

> (define x (kons 7 empty))
> (set! x (kons 6 x))
> (set! x (kons 5 x))
> (set! x (kons 4 x))
> (set! x (kons 3 x))
> (set! x (kons 2 x))
> (set! x (kons 1 x))
> (set! x (kons 0 x))
> (head x)
0
> (head (tail x))
1
> (head (tail (tail x)))
2

Now we can continue with the random access part of the data structure. The lookup function is similar to the list-ref function of Scheme; it first finds the right item in the Rlist (which takes O(log n) time, since that’s the length of the Rlist), then the auxiliary function lookup-tree determines if the item is a Leaf or Node and responds appropriately. Note that lookup and update! both check that subscripts are in range:

(define (lookup i ts)
  (define (lookup-tree w i t)
    (cond ((and (= w 1) (zero? i) (leaf? t))
            (leaf-x t))
          ((and (= w 1) (leaf? t))
            (error 'lookup-tree "subscript out of range"))
          ((and (zero? i) (node? t))
            (node-x t))
          ((node? t)
            (let ((w2 (quotient w 2)) (t1 (node-t1 t)) (t2 (node-t2 t)))
              (if (<= i w2)
                  (lookup-tree w2 (- i 1) t1)
                  (lookup-tree w2 (- i 1 w2) t2))))
          (else (error 'lookup-tree "impossible"))))
  (cond ((empty? ts) (error 'lookup "subscript out of range"))
        ((< i (item-w (car ts)))
          (let ((w (item-w (car ts))) (t (item-t (car ts))))
            (lookup-tree w i t)))
        (else (let ((w (item-w (car ts))))
                (lookup (- i w) (cdr ts))))))

Update! is similar to lookup, except that it returns a newly-allocated Rlist that shares items with its input:

(define (update! i y ts)
  (define (update-tree w i y t)
    (cond ((and (= w 1) (zero? i) (leaf? t))
          (make-leaf y))
          ((and (= w 1) (leaf? t))
            (error 'update-tree "subscript out of range"))
          ((and (zero? i) (node? t))
            (make-node y (node-t1 t) (node-t2 t)))
          ((node? t)
            (let ((w2 (quotient w 2)) (x (node-x t))
                  (t1 (node-t1 t)) (t2 (node-t2 t)))
              (if (<= i w2)
                  (make-node x (update-tree w2 (- i 1) y t1) t2)
                  (make-node x t1 (update-tree w2 (- i 1 w2) y t2)))))
          (else (error 'update-tree "impossible"))))
  (cond ((empty? ts) (error 'update! "subscript out of range"))
        ((< i (item-w (car ts)))
          (let ((w (item-w (car ts))) (t (item-t (car ts))))
            (cons (make-item w (update-tree w i y t)) (cdr ts))))
        (else (let* ((t (car ts)) (ts (cdr ts)) (w (item-w t)))
                (cons t (update! (- i w) y ts))))))

It’s time for some more testing:

> (lookup 2 x)
2
> (set! x (update 2 12 x))
> (lookup 2 x)
12
> (head (tail (tail x)))
12

We used define-structure from the Standard Prelude. The code is collected at http://programmingpraxis.codepad.org/CDtlf2Sy, but I couldn’t make it run; it runs fine on my machine at home, but something about the macros provided by MzScheme in the codepad system doesn’t work with this code.

Pages: 1 2