[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Mar 4:
; binary search tree

(define rand
  (let* ((a 3141592653) (c 2718281829)
         (m (expt 2 35)) (x 5772156649)
         (next (lambda ()
                 (let ((x-prime (modulo (+ (* a x) c) m)))
                   (set! x x-prime) x-prime)))
         (k 103)
         (v (list->vector (reverse
              (let loop ((i k) (vs (list x)))
                (if (= i 1) vs
                  (loop (- i 1) (cons (next) vs)))))))
         (y (next))
         (init (lambda (s)
                 (set! x s) (vector-set! v 0 x)
                 (do ((i 1 (+ i 1))) ((= i k))
                   (vector-set! v i (next))))))
    (lambda seed
      (cond ((null? seed)
              (let* ((j (quotient (* k y) m))
                     (q (vector-ref v j)))
                (set! y q)
                (vector-set! v j (next)) (/ y m)))
            ((eq? (car seed) 'get) (list a c m x y k v))
            ((eq? (car seed) 'set)
              (let ((state (cadr seed)))
                (set! a (list-ref state 0))
                (set! c (list-ref state 1))
                (set! m (list-ref state 2))
                (set! x (list-ref state 3))
                (set! y (list-ref state 4))
                (set! k (list-ref state 5))
                (set! v (list-ref state 6))))
            (else (init (modulo (numerator
                    (inexact->exact (car seed))) m))
                  (rand))))))

(define (randint . args)
  (cond ((null? (cdr args))
          (floor (* (rand) (car args))))
        ((< (car args) (cadr args))
          (+ (floor (* (rand) (- (cadr args) (car args)))) (car args)))
        (else (+ (ceiling (* (rand) (- (cadr args) (car args)))) (car args)))))

(define (tree k v l r) (vector k v l r))
(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 nil (vector 'nil 'nil 'nil 'nil))
(define (nil? t) (eq? t nil))
(define (nil! k) (vector-set! nil 0 k))
(define (leaf-or-nil? t) (eq? (lkid t) (rkid t)))
(define (leaf? t) (and (nil? (lkid t)) (nil? (rkid t))))

(define (rot-left t)
  (let ((l (tree (key t) (val t) (lkid t) (lkid (rkid t)))))
    (tree (key (rkid t)) (val (rkid t)) l (rkid (rkid t)))))

(define (rot-right t)
  (let ((r (tree (key t) (val t) (rkid (lkid t)) (rkid t))))
    (tree (key (lkid t)) (val (lkid t)) (lkid (lkid t)) r)))

(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)) (tree (key t) (val t) (insert lt? (lkid t) k v) (rkid t)))
        ((lt? (key t) k) (tree (key t) (val t) (lkid t) (insert lt? (rkid t) k v)))
        (else (tree k v (lkid t) (rkid t)))))

(define (deroot t left?)
  (cond ((leaf-or-nil? t) nil)
        (left? (let ((t (rot-left t)))
                 (tree (key t) (val t) (deroot (lkid t) #f) (rkid t))))
        (else (let ((t (rot-right t)))
                (tree (key t) (val t) (lkid t) (deroot (rkid t) #t))))))

(define (delete lt? t k)
  (nil! k)
  (cond ((lt? k (key t))
          (tree (key t) (val t) (delete lt? (lkid t) k) (rkid t)))
        ((lt? (key t) k)
          (tree (key t) (val t) (lkid t) (delete lt? (rkid t) k)))
        (else (deroot t (zero? (randint 2))))))

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

(define t (insert < nil 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 (enlist t)) (newline)
(display (lookup < t 3)) (newline)
(display (lookup < t 9)) (newline)
(set! t (delete < t 4))
(set! t (delete < t 2))
(set! t (delete < t 3))
(set! t (delete < t 5))
(set! t (delete < t 1))
(display (enlist t)) (newline)


Output:
1
2
3
4
((1 . 1) (2 . 2) (3 . 3) (4 . 4) (5 . 5))
(3 . 3)
#f
()


Create a new paste based on this one


Comments: