40 lines
1.4 KiB
Common Lisp
40 lines
1.4 KiB
Common Lisp
(mapc #'use-package '(#:toadstool #:toadstool-system))
|
|
(defstruct (red-black-tree (:constructor tree (color left val right)))
|
|
color left val right)
|
|
|
|
(defcomponent tree (operator macro-mixin))
|
|
(defexpand tree (color left val right)
|
|
`(class red-black-tree red-black-tree-color ,color
|
|
red-black-tree-left ,left
|
|
red-black-tree-val ,val
|
|
red-black-tree-right ,right))
|
|
(pushnew 'tree *used-components*)
|
|
|
|
(defun balance (color left val right)
|
|
(toad-ecase (color left val right)
|
|
(('black (tree 'red (tree 'red a x b) y c) z d)
|
|
(tree 'red (tree 'black a x b) y
|
|
(tree 'black c z d)))
|
|
(('black (tree 'red a x (tree 'red b y c)) z d)
|
|
(tree 'red (tree 'black a x b) y (tree 'black c z d)))
|
|
(('black a x (tree 'red (tree 'red b y c) z d))
|
|
(tree 'red (tree 'black a x b) y (tree 'black c z d)))
|
|
(('black a x (tree 'red b y (tree 'red c z d)))
|
|
(tree 'red (tree 'black a x b) y (tree 'black c z d)))
|
|
((color a x b)
|
|
(tree color a x b))))
|
|
|
|
(defun %insert (x s)
|
|
(toad-ecase1 s
|
|
(nil (tree 'red nil x nil))
|
|
((tree color a y b)
|
|
(cond ((< x y)
|
|
(balance color (%insert x a) y b))
|
|
((> x y)
|
|
(balance color a y (%insert x b)))
|
|
(t s)))))
|
|
|
|
(defun insert (x s)
|
|
(toad-ecase1 (%insert x s)
|
|
((tree t a y b) (tree 'black a y b))))
|