A functional red-black tree.

red-black-tree.lisa

;; Lisa implementation for http://matt.might.net/articles/red-black-delete/
;; Tree = () | (:black) | (Color (Left Tree) Element (Right Tree))
;; Color = :black-1 :red :black :black+1
(define empty-tree ())
(declare remove-max)

(define (contains? () _) false)
(define (contains? (:black) _) false)
(define (contains? (_ _ x _) x) true)
(define (contains? (_ left y right) x (when (< x y)))
  (contains? left x))
(define (contains? (_ _ y right) x) (contains? right x))

(define (color-mapper fn)
  (lambda ((color left elem right))
    (list (fn color) left elem right)))

(define (black+1 :black-1) :red)
(define (black+1 :red) :black)
(define (black+1 :black) :black+1)
(define (black+1 ()) '(:black))
(define black+1 (color-mapper black+1))

(define (black+1? (:black)) true)
(define (black+1? (:black+1 _ _ _)) true)
(define (black+1? _) false)

(define (black-1 :red) :black-1)
(define (black-1 :black) :red)
(define (black-1 :black+1) :black)
(define (black-1 (:black)) ())
(define black-1 (color-mapper black-1))

;; Mark root as black.
(define (blacken ()) ())
(define (blacken (:black)) ())
(define blacken (color-mapper &:black))

(define (balance (:black (:red a x (:red b y c)) z d))
  `'(:red (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black (:red (:red a x b) y c) z d))
  `'(:red (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black a x (:red b y (:red c z d))))
  `'(:red (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black a x (:red (:red b y c) z d)))
  `'(:red (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))

(define (balance (:black+1 (:red a x (:red b y c)) z d))
  `'(:black (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black+1 (:red (:red a x b) y c) z d))
  `'(:black (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black+1 a x (:red b y (:red c z d))))
  `'(:black (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black+1 a x (:red (:red b y c) z d)))
  `'(:black (:black ~a ~x ~b) ~y (:black ~c ~z ~d)))
(define (balance (:black+1 a x (:black-1 (:black b y c) z (:black d e f))))
  `'(:black (:black ~a ~x ~b) ~y ~(balance (list :black c z (list :red d e f)))))
(define (balance (:black+1 (:black-1 (:black ...ta) x (:black b y c)) z d))
  `'(:black ~(balance `'(:black (:red ~...ta) ~x ~b)) ~y (:black ~c ~z ~d)))

(define (balance tree) tree); Otherwise, no need to balance.

(define (bubble (color left elem right) (when (or (black+1? left) (black+1? right))))
  (balance (list (black+1 color) (black-1 left) elem (black-1 right))))
(define (bubble tree) (balance tree))

(define (tree-max (_ _ x ())) x)
(define (tree-max (_ _ _ r)) (tree-max r))

(define (insert tree x)
  (define (ins ()) `'(:red () ~x ()))
  (define (ins (color left `x` right)) (list color left x right))
  (define (ins (color left y right))
    (if (< x y)
      (balance (list color (ins left) y right))
      (balance (list color left y (ins right)))))
  (blacken (ins tree)))

(define (remove tree x)
  (define (rem ()) ())
  (define (rem (color left `x` right))
    (remove (list color left x right)))
  (define (rem (color left y right))
    (if (< x y)
      (bubble (list color (rem left) y right))
      (bubble (list color left y (rem right)))))

  (blacken (rem tree)))

(define (remove ()) ())
(define (remove (:red () _ ())) ())
(define (remove (:black () _ ())) '(:black))
(define (remove (:black () _ (:red a x b))) `'(:black ~a ~x ~b))
(define (remove (:black (:red a x b) _ ())) `'(:black ~a ~x ~b))
(define (remove (color left elem right))
  (define max-value (tree-max left))
  (define removed-left (remove-max left))
  (bubble (list color removed-left max-value right)))

(define (remove-max (color left elem ()))
  (remove `'(~color ~left ~elem ())))
(define (remove-max (color left elem right))
  (bubble `'(~color ~left ~elem ~(remove-max right))))

test-tree.lisa

(import-env! system)
(define (assert true _) ())
(define (assert false reason)
    (throw (new AssertionError reason)))
(define (assert c) (assert c "AssertioError"))

(define-macro (assert! expr)
    (define code (write expr))
    `'(~assert ~expr $"Assertion failed: ${ ~code }"))

(define-macro (lambda* ...cases)
  (define sym (gen-sym))
  `'(let ()
      ~...(map cases &`'(define ~sym (lambda ~...#)))
      ~sym))

(define-macro (|> x ...fns)
  (.foldLeft fns x
    (lambda*
      ((x (fn ...args) (when (not (= fn 'lambda))))
        `'(~fn ~x ~...args))
      ((x fn) `'(~fn ~x)))))

(import! red-black-tree)

(define tree (|> empty-tree
  (insert 1)
  (insert 2)
  (insert 3)
  (insert 4)
  (insert 5)))

(assert! (contains? tree 3))
(assert! (not (contains? tree 114)))
(assert! (not (contains? tree -1)))

(define removed
  (|> tree
    (remove 3)
    (remove 1)))

(assert! (contains? removed 2))
(assert! (not (contains? removed 3)))
(assert! (not (contains? removed 1)))

(assert! (not (contains? (remove tree 5) 5)))

(assert! 
  (nil?
    (|> tree
      (remove 1)
      (remove 2)
      (remove 3)
      (remove 4)
      (remove 5))))

(assert! 
  (nil?
    (|> tree
      (remove 5)
      (remove 4)
      (remove 3)
      (remove 2)
      (remove 1))))