[ create a new paste ] login | about

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

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


Output:
1
2
3
4
map: expects type <proper list> as 2nd argument, given: #<syntax:/t.scm:26:23>; other arguments were: #<procedure:/t.scm:25:15>

 === context ===
Line 8:0


Create a new paste based on this one


Comments: