[ create a new paste ] login | about

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

programmingpraxis - Scheme, pasted on Sep 19:
; red-black trees

(define (tree c k v l r) (vector c k v l r))
(define empty (tree 'black 'nil 'nil 'nil 'nil))
(define (empty? t) (eqv? t empty))
(define (color t) (vector-ref t 0))
(define (key t) (vector-ref t 1))
(define (value t) (vector-ref t 2))
(define (lkid t) (vector-ref t 3))
(define (rkid t) (vector-ref t 4))
(define (red? c) (eqv? c 'red))
(define (black? c) (eqv? c 'black))

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

(define (insert lt? t k v)
  (define (ins t)
    (cond ((empty? t) (tree 'red k v empty empty))
          ((lt? k (key t))
            (balance (color t) (key t) (value t) (ins (lkid t)) (rkid t)))
          ((lt? (key t) k)
            (balance (color t) (key t) (value t) (lkid t) (ins (rkid t))))
          (else (tree (color t) k v (lkid t) (rkid t)))))
  (let ((z (ins t)))
    (tree 'black (key z) (value z) (lkid z) (rkid z))))

(define (balance c k v l r)
  (cond ((and (black? c) (red? (color l)) (red? (color (lkid l))))
          (tree 'red (key l) (value l)
            (tree 'black (key (lkid l)) (value (lkid l))
              (lkid (lkid l)) (rkid (lkid l)))
            (tree 'black k v (rkid l) r)))
        ((and (black? c) (red? (color l)) (red? (color (rkid l))))
          (tree 'red (key (rkid l)) (value (rkid l))
            (tree 'black (key l) (value l) (lkid l) (lkid (rkid l)))
            (tree 'black k v (rkid (rkid l)) r)))
        ((and (black? c) (red? (color r)) (red? (color (lkid r))))
          (tree 'red (key (lkid r)) (value (lkid r))
            (tree 'black k v l (lkid (lkid r)))
            (tree 'black (key r) (value r) (rkid (lkid r)) (rkid r))))
        ((and (black? c) (red? (color r)) (red? (color (rkid r))))
          (tree 'red (key r) (value r)
            (tree 'black k v l (lkid r))
            (tree 'black (key (rkid r)) (value (rkid r))
              (lkid (rkid r)) (rkid (rkid r)))))
        (else (tree c k v l r))))

(define (enlist t)
  (let enlist ((t t) (xs '()))
    (cond ((empty? t) xs)
          ((and (empty? (lkid t)) (empty? (rkid t)))
            (cons (cons (key t) (value t)) xs))
          (else (enlist (lkid t)
                        (cons (cons (key t) (value t))
                              (enlist (rkid t) xs)))))))

(define t
  (insert <
    (insert <
      (insert <
        (insert <
          (insert <
            empty
            2 "b")
          5 "e")
        3 "c")
      4 "d")
    1 "a"))

(display (lookup < t 7)) (newline)
(display (lookup < t 4)) (newline)
(display (enlist t)) (newline)


Output:
1
2
3
#f
(4 . d)
((1 . a) (2 . b) (3 . c) (4 . d) (5 . e))


Create a new paste based on this one


Comments: