[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Nov 25:
; avl trees

(define (tree k v l r)
  (vector k v l r (+ (max (ht l) (ht r)) 1)))
(define (key t) (vector-ref t 0))
(define (val t) (vector-ref t 1))
(define (lkid t) (vector-ref t 2))
(define (rkid t) (vector-ref t 3))
(define (ht t) (vector-ref t 4))
(define (bal t) (- (ht (lkid t)) (ht (rkid t))))
(define nil (vector 'nil 'nil 'nil 'nil 0))
(vector-set! nil 2 nil)
(vector-set! nil 3 nil)
(define (nil? t) (eq? t nil))

(define (rot-left t)
  (if (nil? t) t
    (tree (key (rkid t))
          (val (rkid t))
          (tree (key t) (val t) (lkid t) (lkid (rkid t)))
          (rkid (rkid t)))))

(define (rot-right t)
  (if (nil? t) t
    (tree (key (lkid t))
          (val (lkid t))
          (lkid (lkid t))
          (tree (key t) (val t) (rkid (lkid t)) (rkid t)))))

(define (balance t)
  (let ((b (bal t)))
    (cond ((< (abs b) 2) t)
          ((positive? b)
            (if (< -1 (bal (lkid t))) (rot-right t)
              (rot-right (tree (key t) (val t)
                (rot-left (lkid t)) (rkid t)))))
          ((negative? b)
            (if (< (bal (rkid t)) 1) (rot-left t)
              (rot-left (tree (key t) (val t)
                (lkid t) (rot-right (rkid t)))))))))

(define (lookup lt? t k)
  (cond ((nil? t) #f)
        ((lt? k (key t)) (lookup lt? (lkid t) k))
        ((lt? (key t) k) (lookup lt? (rkid t) k))
        (else (cons k (val t)))))

(define (insert lt? t k v)
  (cond ((nil? t) (tree k v nil nil))
        ((lt? k (key t))
          (balance (tree (key t) (val t)
            (insert lt? (lkid t) k v) (rkid t))))
        ((lt? (key t) k)
          (balance (tree (key t) (val t)
            (lkid t) (insert lt? (rkid t) k v))))
        (else (tree k v (lkid t) (rkid t)))))

(define (delete-successor t)
  (if (nil? (lkid t)) (values (rkid t) (key t) (val t))
      (lambda () (delete-successor (lkid t)))
      (lambda (l k v)
        (values (balance (tree (key t) (val t) l (rkid t))) k v)))))

(define (delete lt? t k)
  (cond ((nil? t) nil)
        ((lt? k (key t))
          (balance (tree (key t) (val t)
            (delete lt? (lkid t) k) (rkid t))))
        ((lt? (key t) k)
          (balance (tree (key t) (val t)
            (lkid t) (delete lt? (rkid t) k))))
        ((nil? (lkid t)) (rkid t))
        ((nil? (rkid t)) (lkid t))
        (else (call-with-values
                (lambda () (delete-successor (rkid t)))
                (lambda (r k v) (balance (tree k v (lkid t) r)))))))

(define (enlist t)
  (cond ((nil? t) (list))
        ((and (nil? (lkid t)) (nil? (rkid t)))
          (list (cons (key t) (val t))))
        (else (append (enlist (lkid t))
                      (list (cons (key t) (val t)))
                      (enlist (rkid t))))))

; testing utilities from the standard prelude

(define (range . args)
  (case (length args)
    ((1) (range 0 (car args) (if (negative? (car args)) -1 1)))
    ((2) (range (car args) (cadr args) (if (< (car args) (cadr args)) 1 -1)))
    ((3) (let ((le? (if (negative? (caddr args)) >= <=)))
           (let loop ((x(car args)) (xs '()))
             (if (le? (cadr args) x)
                 (reverse xs)
                 (loop (+ x (caddr args)) (cons x xs))))))
    (else (error 'range "unrecognized arguments"))))

(define rand #f)
(define randint #f)
(let ((two31 #x80000000) (a (make-vector 56 -1)) (fptr #f))
  (define (mod-diff x y) (modulo (- x y) two31)) ; generic version
  ; (define (mod-diff x y) (logand (- x y) #x7FFFFFFF)) ; fast version
  (define (flip-cycle)
    (do ((ii 1 (+ ii 1)) (jj 32 (+ jj 1))) ((< 55 jj))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (do ((ii 25 (+ ii 1)) (jj 1 (+ jj 1))) ((< 55 ii))
      (vector-set! a ii (mod-diff (vector-ref a ii) (vector-ref a jj))))
    (set! fptr 54) (vector-ref a 55))
  (define (init-rand seed)
    (let* ((seed (mod-diff seed 0)) (prev seed) (next 1))
      (vector-set! a 55 prev)
      (do ((i 21 (modulo (+ i 21) 55))) ((zero? i))
        (vector-set! a i next) (set! next (mod-diff prev next))
        (set! seed (+ (quotient seed 2) (if (odd? seed) #x40000000 0)))
        (set! next (mod-diff next seed)) (set! prev (vector-ref a i)))
      (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle) (flip-cycle)))
  (define (next-rand)
    (if (negative? (vector-ref a fptr)) (flip-cycle)
      (let ((next (vector-ref a fptr))) (set! fptr (- fptr 1)) next)))
  (define (unif-rand m)
    (let ((t (- two31 (modulo two31 m))))
      (let loop ((r (next-rand)))
        (if (<= t r) (loop (next-rand)) (modulo r m)))))
  (init-rand 19380110) ; happy birthday donald e knuth
  (set! rand (lambda seed
    (cond ((null? seed) (/ (next-rand) two31))
          ((eq? (car seed) 'get) (cons fptr (vector->list a)))
          ((eq? (car seed) 'set) (set! fptr (caadr seed))
                                 (set! a (list->vector (cdadr seed))))
          (else (/ (init-rand (modulo (numerator
                  (inexact->exact (car seed))) two31)) two31)))))
  (set! randint (lambda args
    (cond ((null? (cdr args))
            (if (< (car args) two31) (unif-rand (car args))
              (floor (* (next-rand) (car args)))))
          ((< (car args) (cadr args))
            (let ((span (- (cadr args) (car args))))
              (+ (car args)
                 (if (< span two31) (unif-rand span)
                   (floor (* (next-rand) span))))))
          (else (let ((span (- (car args) (cadr args))))
                  (- (car args)
                     (if (< span two31) (unif-rand span)
                       (floor (* (next-rand) span))))))))))

(define (shuffle x)
  (do ((v (list->vector x)) (n (length x) (- n 1)))
      ((zero? n) (vector->list v))
    (let* ((r (randint n)) (t (vector-ref v r)))
      (vector-set! v r (vector-ref v (- n 1)))
      (vector-set! v (- n 1) t))))

(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))))))

; test code

(define (display-avl t . indent)
  (let ((indent (if (null? indent) "" (car indent))))
    (if (nil? t)
        (begin (display indent) (display "nil nil 0") (newline))
        (begin (display indent) (display (key t))
               (display " ") (display (val t))
               (display " ") (display (ht t)) (newline)
               (display-avl (lkid t) (string-append "  " indent))
               (display-avl (rkid t) (string-append "  " indent))))))

(define (check? lt? t)
  (if (nil? t) #t
    (and (or (nil? (lkid t)) (lt? (key (lkid t)) (key t)))
         (or (nil? (rkid t)) (lt? (key t) (key (rkid t))))
         (< (abs (bal t)) 2)
         (check? lt? (lkid t))
         (check? lt? (rkid t)))))

(define (test n)
  (let ((t nil) (phi (/ (+ 1 (sqrt 5)) 2)))
    (do ((xs (shuffle (range n)) (cdr xs))) ((null? xs))
      (set! t (insert < t (car xs) (car xs)))
      (assert (check? < t) #t))
    (assert (< (ht t) (- (/ (log (+ n 2)) (log phi)) 1)) #t)
    (assert (enlist t) (map (lambda (x) (cons x x)) (range n)))
    (do ((xs (range n) (cdr xs))) ((null? xs))
      (assert (car (lookup < t (car xs))) (car xs))
      (assert (cdr (lookup < t (car xs))) (car xs)))
    (assert (lookup < t n) #f)
    (do ((xs (shuffle (range n)) (cdr xs))) ((null? xs))
      (set! t (delete < t (car xs)))
      (assert (check? < t) #t))
    (assert t nil)))

; demonstration and test

(define t nil)
(set! t (insert < t 4 4))
(set! t (insert < t 1 1))
(set! t (insert < t 3 3))
(set! t (insert < t 5 5))
(set! t (insert < t 2 2))
(display-avl t)
(display (enlist t)) (newline)
(display (lookup < t 3)) (newline)
(display (lookup < t 9)) (newline)
(set! t (delete < t 3))
(set! t (delete < t 2))
(set! t (delete < t 5))
(set! t (delete < t 9))
(set! t (delete < t 4))
(set! t (delete < t 1))
(display (enlist t)) (newline)
(test 100)

3 3 3
  1 1 2
    nil nil 0
    2 2 1
      nil nil 0
      nil nil 0
  4 4 2
    nil nil 0
    5 5 1
      nil nil 0
      nil nil 0
((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5))
(3 . 3)

Create a new paste based on this one