Clisp of binary sort tree algorithm to realize improved version of General edition __clisp

Major improvements:

1, transformation node data structure, list =>clsss node

2. Add node Parent element

(In-package:cl-user) (Defun Reload ()
(Load "H:/LISPTOOL/BTREE.LSP"))


(Defclass node ()
((Node-value
: Initarg:value
: Accessor Node-value
: InitForm Nil)
(Node-left
: Initarg:left
: Accessor Node-left
: InitForm Nil)
(Node-right
: Initarg:right
: Accessor Node-right
: InitForm Nil)
(Node-level
: Initarg:level
: Accessor Node-level
: InitForm Nil)
(node-parent; recursive, list not recursive
: Initarg:p Arent
: Accessor Node-parent
: InitForm nil))


(Defun Make-treenode (val &key level)
(make-instance ' node:value val:level level))
(Defun make-btree ()
(Make-treenode nil:level 1))


; Add data
(Defun Tree-add-val (Val rootnode)
(if (Node-value rootnode)
(Tree-insert-value (Make-treenode val) rootnode)
(Progn
(SETF (Node-value RootNode) val)
RootNode)))
; Find data
(Defun Tree-find-val (Val rootnode)
(When RootNode
(If (= (Node-value rootnode) val)
(Return-from tree-find-val RootNode); return results
(Return-from Tree-find-val
(Or (Tree-find-val val (node-left rootnode))
(Tree-find-val Val (node-right RootNode)))))

; The data in the tree is converted to a list;
(Defun tree-value-list (RootNode)
(If RootNode
(Append
(Tree-value-list (Node-left rootnode))
(if (Node-value rootnode) (list (Node-value RootNode)) nil)
(Tree-value-list (Node-right RootNode))))


; Tree Depth
(Defun tree-height (RootNode)
(If RootNode
(1+ (max
(Tree-height (Node-left rootnode))
(Tree-height (Node-right rootnode)))
0))


; hierarchy traversal
(Defun tree-print-level (RootNode)
((Tmp-node-list (list rootnode))
(Do* (Tmp-node (pop tmp-node-list) (pop tmp-node-list))
(Tmp-level (Node-level tmp-node) (If Tmp-node (Node-level tmp-node) nil))
(Pre-level 0))

((null Tmp-node))

(Unless (= Pre-level tmp-level)
(TERPRI)
(Psetq pre-level Tmp-level)
(Format T "level=~a" Tmp-level))

(Format T "~a" (Node-value Tmp-node))


(Let ((Left-node (Node-left tmp-node)) (Right-node (Node-right tmp-node)))
(When Left-node
(SETF tmp-node-list (Append tmp-node-list (List left-node)))
(When Right-node
(SETF tmp-node-list (Append tmp-node-list (List right-node)))))

; first-order traversal
(Defun tree-print-pre (RootNode)
(When RootNode
(Tree-print-pre (Node-left rootnode))
(Format T "Level:~a value=~a~%" (Node-level rootnode) (Node-value rootnode))
(Tree-print-pre (Node-right rootnode)))


; Insert Node
(Defun tree-insert-value (NewNode parentnode)
(Let ((Left-node (Node-left parentnode)) (Right-node (Node-right parentnode)))
(If (< (Node-value NewNode) (Node-value parentnode))
(If Left-node
(Tree-insert-value NewNode Left-node)
(SETF
(Node-left parentnode) NewNode
(Node-parent NewNode) parentnode
(Node-level NewNode) (1+ (Node-level parentnode)))
(If Right-node
(Tree-insert-value NewNode Right-node)
(SETF
(Node-right parentnode) NewNode
(Node-parent NewNode) parentnode
(Node-level NewNode) (1+ (Node-level parentnode)))))


; Data modification
(Defun tree-replace-val (old-val new-val rootnode)
((Tmp-node (Tree-find-val old-val rootnode))
(When Tmp-node
(SETF (Node-value tmp-node) new-val)))

(Defun left-node-p (node)
(EQ (Node-left (node-parent node) node))

;p setq setting must be a symbol and cannot be an expression: illegal expression => (psetq (node-left tmp-node-parent) nil)


; Returns an element, returns (True/false RootNode)
(Defun Tree-remove-val (Val rootnode)
(Let* (Tmp-node (Tree-find-val val rootnode))
(Tmp-node-parent (node-parent tmp-node))

(If Tmp-node-parent
(Progn
(SETF
(if (left-node-p tmp-node)
(Node-left tmp-node-parent)
(Node-right tmp-node-parent))
(Node-left Tmp-node))
(When (Node-right Tmp-node)
(Tree-insert-value (node-right tmp-node) tmp-node-parent))
(Values T rootnode))
(Progn; When the parent node
(if (Node-left tmp-node)
(Progn
(When (Node-right Tmp-node) (Tree-insert-value (Node-right tmp-node) (Node-left tmp-node)))
(Values T (node-left tmp-node))
(if (Node-right tmp-node)
(Values T (node-right tmp-node))
(Values T nil))))


; For test
(Defun make-tree ()
((RootNode (Make-btree))
(Dotimes (i 10)
((x (random 99))
(Format T "~a~t" x)
(Tree-add-val x RootNode))
(TERPRI)
RootNode))


; Test Delele
(Defun test-1 ()
(Let* (RootNode (Make-tree))
(Value-list (tree-value-list rootnode))

(Tree-print-level RootNode)
(TERPRI)

(Print value-list)
(TERPRI)

; Upset order.
(Dotimes (* 2 (length value-list))
(Rotatef
(Elt value-list (random (length value-list))
(Elt value-list (random (length value-list))))

(Print value-list)
(TERPRI)

(Dolist (n value-list)
(Multiple-value-bind (flag Tmp-rootnode) (tree-remove-val n rootnode)
(Format T "flag:~a rootnode-value:~a remove-value:~a~%"
Flag
(If Tmp-rootnode (Node-value tmp-rootnode) nil)
N
(if (flag) (Not (EQ rootnode tmp-rootnode))
(Psetq rootnode Tmp-rootnode))))