AVL tree: Difference between revisions
Add Emacs Lisp
(BlackBox Component Builder implementation) |
(Add Emacs Lisp) |
||
| (2 intermediate revisions by 2 users not shown) | |||
Line 4,381:
=={{header|Component Pascal}}==
{{works with|BlackBox Component Builder}}
Two modules are provided - one for implementing and one for using AVL trees
Line 4,950:
<pre>Inserting values 1 to 10
Printing balance: 0 0 0 1 0 0 0 0 1 0 </pre>
=={{header|Emacs Lisp}}==
{{trans|Java}}
<syntaxhighlight lang="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) " ")))
</syntaxhighlight>
{{out}}
<pre>
Inserting values 1 to 10
Printing balance: 0 0 0 1 0 1 0 0 0 0
</pre>
=={{header|Fortran}}==
Line 14,432 ⟶ 14,656:
=={{header|Wren}}==
{{trans|Kotlin}}
<syntaxhighlight lang="
construct new(key, parent) {
_key = key
| |||