; random-access lists
; empty, empty? -- equivalent to (list), null?
; O(1): kons, head, tail -- equivalent to cons, car, cdr
; O(log n): lookup, update! -- equivalent to O(n) list-ref, list-set!
; Chris Okasaki, Purely Functional Data Structures, Figure 9.7, page 134
; see also http://citeseer.ist.psu.edu/viewdoc/summary?doi=10.1.1.55.5156
(define-syntax (define-structure x)
(define (gen-id template-id . args)
(datum->syntax-object template-id
(string->symbol
(apply string-append
(map (lambda (x)
(if (string? x) x
(symbol->string
(syntax-object->datum x))))
args)))))
(syntax-case x ()
((_ name field ...)
(with-syntax
((constructor (gen-id (syntax name) "make-" (syntax name)))
(predicate (gen-id (syntax name) (syntax name) "?"))
((access ...)
(map (lambda (x) (gen-id x (syntax name) "-" x))
(syntax (field ...))))
((assign ...)
(map (lambda (x) (gen-id x "set-" (syntax name) "-" x "!"))
(syntax (field ...))))
(structure-length (+ (length (syntax (field ...))) 1))
((index ...) (let f ((i 1) (ids (syntax (field ...))))
(if (null? ids) '()
(cons i (f (+ i 1) (cdr ids)))))))
(syntax (begin
(define (constructor field ...)
(vector 'name field ...))
(define (predicate x)
(and (vector? x)
(= (vector-length x) structure-length)
(eq? (vector-ref x 0) 'name)))
(define (access x) (vector-ref x index)) ...
(define (assign x update) (vector-set! x index update))
...))))))
; alpha tree => leaf of alpha
; | node of alpha * alpha tree * alpha tree
; rlist => list of (int * alpha tree)
(define-structure leaf x)
(define-structure node x t1 t2)
(define-structure item w t) ; single item in rlist of items
(define empty (list))
(define empty? null?)
(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)))))
(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"))))
(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))))))
(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))))))
(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))
(display (head x)) (newline)
(display (head (tail x))) (newline)
(display (head (tail (tail x)))) (newline)
(display (lookup 5 x)) (newline)
(display (lookup 9 x)) (newline)
(update! 2 12 x)
(display (head (tail (tail x)))) (newline)
(display (lookup 2 x)) (newline)