212 lines
6.8 KiB
Common Lisp
212 lines
6.8 KiB
Common Lisp
(defvar avl-all-nodes (make-vector 100 nil))
|
|
(defvar avl-root-node nil "root node")
|
|
|
|
(defun avl-create-node (key parent)
|
|
(copy-tree `((:key . ,key) (:balance . nil) (:height . nil)
|
|
(:left . nil) (:right . nil) (:parent . ,parent))))
|
|
|
|
(defun avl-node (pos)
|
|
(if (or (null pos) (> pos (1- (length avl-all-nodes))))
|
|
nil
|
|
(aref avl-all-nodes pos)))
|
|
|
|
(defun avl-node-prop (noderef &rest props)
|
|
(if (null noderef)
|
|
nil
|
|
(progn
|
|
;;(when (integerp noderef) (setq node (avl-node node)))
|
|
(let ((val noderef))
|
|
(dolist (prop props)
|
|
(if (null (avl-node val))
|
|
(setq val nil)
|
|
(progn
|
|
(setq val (alist-get prop (avl-node val))))))
|
|
val)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
(defun avl-set-prop (node &rest props-and-value)
|
|
(when (integerp node) (setq node (avl-node node)))
|
|
(when (< (length props-and-value) 2)
|
|
(error "Both property name and value must be given."))
|
|
(let (noderef (props (seq-take props-and-value (1- (length props-and-value))))
|
|
(value (seq-elt props-and-value (1- (length props-and-value)))))
|
|
(when (> (length props) 0)
|
|
(dolist (prop (seq-take props (1- (length props))))
|
|
(if (null node)
|
|
(progn (setq noderef nil) (setq node nil))
|
|
(progn
|
|
(setq noderef (alist-get prop node))
|
|
(setq node (avl-node noderef))))))
|
|
|
|
(if (or (null (last props)) (null node))
|
|
nil
|
|
(setcdr (assoc (car (last props)) node) value))))
|
|
|
|
|
|
(defun avl-height (noderef)
|
|
(or (avl-node-prop noderef :height) -1))
|
|
|
|
(defun avl-reheight (noderef)
|
|
(if (null noderef)
|
|
nil
|
|
(avl-set-prop noderef :height
|
|
(1+ (max (avl-height (avl-node-prop noderef :left))
|
|
(avl-height (avl-node-prop noderef :right)))))))
|
|
|
|
(defun avl-setbalance (noderef)
|
|
;;(when (integerp node) (setq node (avl-node node)))
|
|
(avl-reheight noderef)
|
|
(avl-set-prop noderef :balance
|
|
(- (avl-height (avl-node-prop noderef :right))
|
|
(avl-height (avl-node-prop noderef :left)))))
|
|
|
|
(defun avl-add-node (key parent)
|
|
(let (result (idx 0))
|
|
(cl-loop for idx from 0 to (1- (seq-length avl-all-nodes))
|
|
while (null result) do
|
|
(when (null (aref avl-all-nodes idx))
|
|
(aset avl-all-nodes idx (avl-create-node key parent))
|
|
(setq result idx)))
|
|
result))
|
|
|
|
(defun avl-insert (key)
|
|
(if (null avl-root-node)
|
|
(progn (setq avl-root-node (avl-add-node key nil)) avl-root-node)
|
|
(progn
|
|
(let ((n avl-root-node) (end-loop nil) parent go-left result)
|
|
(while (not end-loop)
|
|
(if (equal key (avl-node-prop n :key))
|
|
(setq end-loop 't)
|
|
(progn
|
|
(setq parent n)
|
|
(setq go-left (> (avl-node-prop n :key) key))
|
|
(setq n (if go-left
|
|
(avl-node-prop n :left)
|
|
(avl-node-prop n :right)))
|
|
|
|
(when (null n)
|
|
(setq result (avl-add-node key parent))
|
|
(if go-left
|
|
(progn
|
|
(avl-set-prop parent :left result))
|
|
(progn
|
|
(avl-set-prop parent :right result)))
|
|
(avl-rebalance parent) ;;rebalance
|
|
(setq end-loop 't)))))
|
|
result))))
|
|
|
|
|
|
(defun avl-rotate-left (noderef)
|
|
(when (not (integerp noderef)) (error "parameter must be an integer"))
|
|
(let ((a noderef) b)
|
|
(setq b (avl-node-prop a :right))
|
|
(avl-set-prop b :parent (avl-node-prop a :parent))
|
|
|
|
(avl-set-prop a :right (avl-node-prop b :left))
|
|
|
|
(when (avl-node-prop a :right) (avl-set-prop a :right :parent a))
|
|
|
|
(avl-set-prop b :left a)
|
|
(avl-set-prop a :parent b)
|
|
|
|
(when (not (null (avl-node-prop b :parent)))
|
|
(if (equal (avl-node-prop b :parent :right) a)
|
|
(avl-set-prop b :parent :right b)
|
|
(avl-set-prop b :parent :left b)))
|
|
|
|
(avl-setbalance a)
|
|
(avl-setbalance b)
|
|
b))
|
|
|
|
|
|
|
|
(defun avl-rotate-right (node-idx)
|
|
(when (not (integerp node-idx)) (error "parameter must be an integer"))
|
|
(let ((a node-idx) b)
|
|
(setq b (avl-node-prop a :left))
|
|
(avl-set-prop b :parent (avl-node-prop a :parent))
|
|
|
|
(avl-set-prop a :left (avl-node-prop b :right))
|
|
|
|
(when (avl-node-prop a :right) (avl-set-prop a :right :parent a))
|
|
|
|
(avl-set-prop b :left a)
|
|
(avl-set-prop a :parent b)
|
|
|
|
(when (not (null (avl-node-prop b :parent)))
|
|
(if (equal (avl-node-prop b :parent :right) a)
|
|
(avl-set-prop b :parent :right b)
|
|
(avl-set-prop b :parent :left b)))
|
|
|
|
(avl-setbalance a)
|
|
(avl-setbalance b)
|
|
b))
|
|
|
|
(defun avl-rotate-left-then-right (noderef)
|
|
(avl-set-prop noderef :left (avl-rotate-left (avl-node-prop noderef :left)))
|
|
(avl-rotate-right noderef))
|
|
|
|
(defun avl-rotate-right-then-left (noderef)
|
|
(avl-set-prop noderef :right (avl-rotate-left (avl-node-prop noderef :right)))
|
|
(avl-rotate-left noderef))
|
|
|
|
(defun avl-rebalance (noderef)
|
|
(avl-setbalance noderef)
|
|
(cond
|
|
((equal -2 (avl-node-prop noderef :balance))
|
|
(if (>= (avl-height (avl-node-prop noderef :left :left))
|
|
(avl-height (avl-node-prop noderef :left :right)))
|
|
(setq noderef (avl-rotate-right noderef))
|
|
(setq noderef (avl-rotate-left-then-right noderef)))
|
|
)
|
|
((equal 2 (avl-node-prop noderef :balance))
|
|
(if (>= (avl-height (avl-node-prop noderef :right :right))
|
|
(avl-height (avl-node-prop noderef :right :left)))
|
|
(setq noderef (avl-rotate-left noderef))
|
|
(setq noderef (avl-rotate-right-then-left noderef)))))
|
|
|
|
(if (not (null (avl-node-prop noderef :parent)))
|
|
(avl-rebalance (avl-node-prop noderef :parent))
|
|
(setq avl-root-node noderef)))
|
|
|
|
|
|
(defun avl-delete (noderef)
|
|
(when noderef
|
|
(when (and (null (avl-node-prop noderef :left))
|
|
(null (avl-node-prop noderef :right)))
|
|
(if (null (avl-node-prop noderef :parent))
|
|
(setq avl-root-node nil)
|
|
(let ((parent (avl-node-prop noderef :parent)))
|
|
(if (equal noderef (avl-node-prop parent :left))
|
|
(avl-set-prop parent :left nil)
|
|
(avl-set-prop parent :right nil))
|
|
(avl-rebalance parent))))
|
|
|
|
(if (not (null (avl-node-prop noderef :left)))
|
|
(let ((child (avl-node-prop noderef :left)))
|
|
(while (not (null (avl-node-prop child :right)))
|
|
(setq child (avl-node-prop child :right)))
|
|
(avl-set-prop noderef :key (avl-node-prop child :key))
|
|
(avl-delete child))
|
|
(let ((child (avl-node-prop noderef :right)))
|
|
(while (not (null (avl-node-prop child :left)))
|
|
(setq child (avl-node-prop child :left)))
|
|
(avl-set-prop noderef :key (avl-node-prop child :key))
|
|
(avl-delete child)))))
|
|
|
|
;; Main procedure
|
|
(let ((cnt 10) balances)
|
|
(fillarray avl-all-nodes nil)
|
|
(setq avl-root-node nil)
|
|
|
|
(dotimes (val cnt)
|
|
(avl-insert (1+ val)))
|
|
|
|
(setq balances (seq-map (lambda (x) (or (avl-node-prop x :balance) 0))
|
|
(number-sequence 0 (1- cnt))))
|
|
|
|
(message "Inserting values 1 to %d" cnt)
|
|
(message "Printing balance: %s" (string-join (seq-map (lambda (x) (format "%S" x)) balances) " ")))
|