1 665c255d 2023-08-04 jrmu (defun make-tree (entry left right)
 2 665c255d 2023-08-04 jrmu   (list entry left right))
 3 665c255d 2023-08-04 jrmu (defun make-leaf (entry)
 4 665c255d 2023-08-04 jrmu   (list entry nil nil))
 5 665c255d 2023-08-04 jrmu (defun entry (tree)
 6 665c255d 2023-08-04 jrmu   (car tree))
 7 665c255d 2023-08-04 jrmu (defun set-entry! (tree ent)
 8 665c255d 2023-08-04 jrmu   (setf (car tree) ent))
 9 665c255d 2023-08-04 jrmu (defun left-branch (tree)
10 665c255d 2023-08-04 jrmu   (cadr tree))
11 665c255d 2023-08-04 jrmu (defun set-let-branch! (tree lb)
12 665c255d 2023-08-04 jrmu   (setf (cadr tree) lb))
13 665c255d 2023-08-04 jrmu (defun right-branch (tree)
14 665c255d 2023-08-04 jrmu   (caddr tree))
15 665c255d 2023-08-04 jrmu (defun set-right-branch! (tree lb)
16 665c255d 2023-08-04 jrmu   (setf (caddr tree) lb))
17 665c255d 2023-08-04 jrmu 
18 665c255d 2023-08-04 jrmu (defun make-record (key data)
19 665c255d 2023-08-04 jrmu   (list key data))
20 665c255d 2023-08-04 jrmu (defun key (record)
21 665c255d 2023-08-04 jrmu   (car record))
22 665c255d 2023-08-04 jrmu (defun data (record)
23 665c255d 2023-08-04 jrmu   (cadr record))
24 665c255d 2023-08-04 jrmu (defun make-table (&key (<? #'<))
25 665c255d 2023-08-04 jrmu   (let ((local-table (cons '*head* nil)))
26 665c255d 2023-08-04 jrmu     (labels (
27 665c255d 2023-08-04 jrmu 	     (tree-root ()
28 665c255d 2023-08-04 jrmu 	       (cdr local-table))
29 665c255d 2023-08-04 jrmu 	     (set-tree-root! (node)
30 665c255d 2023-08-04 jrmu 	       (setf (cdr local-table) node))
31 665c255d 2023-08-04 jrmu 	     (node-lookup (key node)
32 665c255d 2023-08-04 jrmu 	       (if (null node)
33 665c255d 2023-08-04 jrmu 		   nil
34 665c255d 2023-08-04 jrmu 		   (let* ((cur-entry (entry node))
35 665c255d 2023-08-04 jrmu 			  (cur-key (key cur-entry)))
36 665c255d 2023-08-04 jrmu 		     (cond ((funcall <? key cur-key)
37 665c255d 2023-08-04 jrmu 			    (node-lookup
38 665c255d 2023-08-04 jrmu 			     key
39 665c255d 2023-08-04 jrmu 			     (left-branch node)))
40 665c255d 2023-08-04 jrmu 			   ((funcall <? cur-key key)
41 665c255d 2023-08-04 jrmu 			    (node-lookup
42 665c255d 2023-08-04 jrmu 			     key
43 665c255d 2023-08-04 jrmu 			     (right-branch node)))
44 665c255d 2023-08-04 jrmu 			   (t
45 665c255d 2023-08-04 jrmu 			    cur-entry))))))