Red Black Tree using optima in Common Lisp

rb-tree.lisp

(defpackage :rb-tree
  (:use :cl :optima)
  (:export #:rb-empty
           #:rb-member
           #:rb-insert))
(in-package :rb-tree)

(defstruct (leaf (:constructor leaf)))
(defstruct (node (:constructor node (color left label right)))
  color left label right)

(defun rb-empty () (leaf))

(defun rb-member (x tree)
  (match tree
    ((leaf) nil)
    ((node left label right)
     (cond ((< x label) (rb-member x left))
           ((> x label) (rb-member x right))
           (t           t)))))

(defun red (left label right)
  (node :red left label right))

(defun black (left label right)
  (node :black left label right))

(defpattern red (left label right)
  `(node (color :red) (left,left) (label ,label) (right ,right)))

(defpattern black (left label right)
  `(node (color :black) (left,left) (label ,label) (right ,right)))

(defun balance (tree)
  (match tree
    ((or (black (red (red a x b) y c) z d)
         (black (red a x (red b y c)) z d)
         (black a x (red (red b y c) z d))
         (black a x (red b y (red c z d))))
     (red (black a x b) y (black c z d)))
    (otherwise tree)))

(defun rb-insert (x tree)
  (labels ((ins (tree)
           (match tree
             ((leaf) (red (leaf) x (leaf)))
             ((node color left label right)
              (cond ((< x label)
                     (balance (node color (ins left) label right)))
                    ((> x label)
                     (balance (node color left label (ins right))))
                    (t tree))))))
    (match (ins tree)
      ((node left label right)
       (black left label right)))))