mfiano
/
binary-search-tree
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

First commit.

main
Michael Fiano 4 months ago
commit
a5efcd4d42
Signed by: mfiano
GPG Key ID: F87DF4666D70FC63
5 changed files with 329 additions and 0 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 21
      LICENSE
  2. 15
      README.md
  3. 13
      binary-search-tree.asd
  4. 256
      src/binary-search-tree.lisp
  5. 24
      src/package.lisp

21
LICENSE
Unescape View File

@ -0,0 +1,21 @@
MIT License
Copyright (c) Michael Fiano
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:
The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
SOFTWARE.

15
README.md
Unescape View File

@ -0,0 +1,15 @@
# binary-search-tree
An implementation of the binary search tree data structure.
## Install
```lisp
(ql:quickload :binary-search-tree)
```
## License
Copyright © 2018-2022 Michael Fiano <mail@mfiano.net>
Licensed under the MIT License.

13
binary-search-tree.asd
Unescape View File

@ -0,0 +1,13 @@
(asdf:defsystem #:binary-search-tree
:description "An implementation of the binary search tree data structure."
:author "Michael Fiano <mail@mfiano.net>"
:license "MIT"
:homepage "https://github.com/mfiano/binary-search-tree"
:version "0.1.0"
:encoding :utf-8
:depends-on (#:mfiano-utils)
:pathname "src"
:serial t
:components
((:file "package")
(:file "binary-search-tree")))

256
src/binary-search-tree.lisp
Unescape View File

@ -0,0 +1,256 @@
(in-package #:binary-search-tree)
(defstruct (tree
(:constructor %make-tree)
(:predicate nil)
(:copier nil))
sentinel
root
item-type
(key #'identity :type function)
(sorter #'< :type function)
(hash-test #'eql :type function))
(defstruct (node
(:constructor %make-node)
(:predicate nil)
(:copier nil))
tree
key
data
parent
left
right)
(u:define-printer (tree stream :identity t :type nil)
(format stream "TREE"))
(u:define-printer (node stream :identity t :type nil)
(format stream "NODE"))
(declaim (inline node-p))
(defun node-p (node)
(declare (optimize speed))
(unless (and node (eq node (tree-sentinel (node-tree node))))
node))
(u:fn-> make-node (tree t) node)
(defun make-node (tree item)
(declare (optimize speed))
(let ((sentinel (tree-sentinel tree))
(node (%make-node :tree tree
:key (when item (funcall (tree-key tree) item))
:data (u:dict (tree-hash-test tree) item item))))
(setf (node-left node) sentinel
(node-right node) sentinel)
node))
(u:fn-> make-tree (&key (:item-type symbol) (:key function) (:sort function) (:hash-test function))
tree)
(defun make-tree (&key item-type (key #'identity) (sort #'<) (hash-test #'eql))
(declare (optimize speed))
(unless item-type
(error "Must specify :ITEM-TYPE denoting the type of items stored in the ~
tree."))
(let* ((tree (%make-tree :item-type item-type :key key :sorter sort :hash-test hash-test))
(sentinel (make-node tree nil)))
(setf (tree-sentinel tree) sentinel
(node-left sentinel) sentinel
(node-right sentinel) sentinel
(tree-root tree) sentinel)
(clrhash (node-data (tree-sentinel tree)))
tree))
(u:fn-> valid-p (tree) boolean)
(defun valid-p (tree)
(declare (optimize speed))
(let ((previous nil))
(labels ((%check (node sorter)
(declare (function sorter))
(when (node-p node)
(when (or (null (%check (node-left node) sorter))
(and previous (funcall sorter (node-key node) (node-key previous))))
(return-from %check))
(setf previous node)
(return-from %check
(%check (node-right node) sorter)))
t))
(%check (tree-root tree) (tree-sorter tree)))))
(u:fn-> %walk/pre-order (node function) null)
(defun %walk/pre-order (node func)
(declare (optimize speed))
(when (node-p node)
(u:do-hash-keys (k (node-data node))
(funcall func k))
(%walk/pre-order (node-left node) func)
(%walk/pre-order (node-right node) func)))
(u:fn-> %walk/in-order (node function) null)
(defun %walk/in-order (node func)
(declare (optimize speed))
(when (node-p node)
(loop :with current = node
:with stack
:do (cond
((node-p current)
(push current stack)
(setf current (node-left current)))
(stack
(setf current (pop stack))
(u:do-hash-keys (k (node-data current))
(funcall func k))
(setf current (node-right current)))
(t (loop-finish))))))
(u:fn-> %walk/post-order (node function) null)
(defun %walk/post-order (node func)
(declare (optimize speed))
(when (node-p node)
(%walk/post-order (node-left node) func)
(%walk/post-order (node-right node) func)
(u:do-hash-keys (k (node-data node))
(funcall func k))))
(u:fn-> walk (tree function &key (:order keyword)) null)
(defun walk (tree func &key (order :in))
(declare (optimize speed))
(let ((node (tree-root tree)))
(ecase order
(:pre (%walk/pre-order node func))
(:in (%walk/in-order node func))
(:post (%walk/post-order node func)))))
(u:fn-> transplant (node node) node)
(declaim (inline transplant))
(defun transplant (node1 node2)
(declare (optimize speed))
(let ((parent (node-parent node1)))
(cond
((not (node-p parent))
(setf (tree-root (node-tree node1)) node2))
((eq node1 (node-left parent))
(setf (node-left parent) node2))
(t (setf (node-right parent) node2)))
(setf (node-parent node2) (node-parent node1))))
(u:fn-> insert (tree t) node)
(defun insert (tree item)
(declare (optimize speed))
(u:if-let ((node (node-p (nth-value 1 (find tree item)))))
(prog1 node
(setf (u:href (node-data node) item) item))
(let ((node (make-node tree item)))
(loop :with sorter = (tree-sorter tree)
:with key = (node-key node)
:with current = (tree-root tree)
:with parent = (tree-sentinel tree)
:while (node-p current)
:do (setf parent current)
(if (funcall sorter key (node-key current))
(setf current (node-left current))
(setf current (node-right current)))
:finally (setf (node-parent node) parent)
(cond
((not (node-p parent))
(setf (tree-root tree) node))
((funcall sorter key (node-key parent))
(setf (node-left parent) node))
(t (setf (node-right parent) node))))
node)))
(u:fn-> delete (tree t) (or node null))
(defun delete (tree item)
(declare (optimize speed))
(labels ((%delete (node)
(cond
((not (node-p (node-left node)))
(transplant node (node-right node)))
((not (node-p (node-right node)))
(transplant node (node-left node)))
(t (let* ((successor (min (node-right node)))
(left (node-left successor))
(right (node-right successor)))
(unless (eq node (node-parent successor))
(transplant successor right)
(setf (node-right successor) (node-right node)
(node-parent right) successor))
(transplant node successor)
(setf (node-left successor) (node-left node))
(when (node-p left)
(setf (node-parent left) successor)))))))
(u:when-let ((node (node-p (nth-value 1 (find tree item))))
(sentinel (tree-sentinel tree)))
(when (u:href (node-data node) item)
(if (<= (hash-table-count (node-data node)) 1)
(progn
(u:when-let ((new-root (%delete node)))
(setf (tree-root tree) new-root))
(setf (node-parent sentinel) sentinel)
(clrhash (node-data node)))
(remhash item (node-data node))))
node)))
(u:fn-> min (node) (or node null))
(defun min (node)
(declare (optimize speed))
(when (node-p node)
(loop :with current = node
:for left = (node-left node)
:while (node-p left)
:do (setf current left)
:finally (return current))))
(u:fn-> max (node) (or node null))
(defun max (node)
(declare (optimize speed))
(when (node-p node)
(loop :with current = node
:for right = (node-right node)
:while (node-p right)
:do (setf current right)
:finally (return current))))
(u:fn-> previous (node) (or node null))
(defun previous (node)
(declare (optimize speed))
(when (node-p node)
(u:if-let ((left (node-p (node-left node))))
(max left)
(loop :for current = node :then parent
:for parent = (node-parent current)
:while (and (node-p parent)
(eq current (node-left parent)))
:finally (return parent)))))
(u:fn-> next (node) (or node null))
(defun next (node)
(declare (optimize speed))
(when (node-p node)
(u:if-let ((right (node-p (node-right node))))
(min right)
(loop :for current = node :then parent
:for parent = (node-parent current)
:while (and (node-p parent)
(eq current (node-right parent)))
:finally (return parent)))))
(u:fn-> find (tree t) (values &optional t node))
(defun find (tree item)
(declare (optimize speed))
(labels ((%find (node key sorter)
(declare (function sorter))
(u:when-let ((result (and (node-p node) (node-key node))))
(cond
((funcall sorter key result)
(%find (node-left node) key sorter))
((funcall sorter result key)
(%find (node-right node) key sorter))
(t node)))))
(locally (declare #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))
(when (typep item (tree-item-type tree))
(u:when-let ((node (%find (tree-root tree)
(funcall (tree-key tree) item)
(tree-sorter tree))))
(values (u:href (node-data node) item)
node))))))

24
src/package.lisp
Unescape View File

@ -0,0 +1,24 @@
(in-package #:cl-user)
(defpackage #:binary-search-tree
(:local-nicknames
(#:u #:mfiano-utils))
(:use #:cl)
(:shadow
#:delete
#:find
#:max
#:min)
(:export
#:delete
#:find
#:insert
#:make-tree
#:max
#:min
#:next
#:node
#:previous
#:tree
#:valid-p
#:walk))
Write Preview
Loading…
Cancel
Save