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-left-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 rb)
16 665c255d 2023-08-04 jrmu   (setf (caddr tree) rb))
17 665c255d 2023-08-04 jrmu (defun make-record (key data)
18 665c255d 2023-08-04 jrmu   (list key data))
19 665c255d 2023-08-04 jrmu (defun key (record)
20 665c255d 2023-08-04 jrmu   (car record))
21 665c255d 2023-08-04 jrmu (defun data (record)
22 665c255d 2023-08-04 jrmu   (cadr record))
23 665c255d 2023-08-04 jrmu 
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 ((tree-root ()
27 665c255d 2023-08-04 jrmu 	       (cdr local-table))
28 665c255d 2023-08-04 jrmu 	     (set-tree-root! (node)
29 665c255d 2023-08-04 jrmu 	       (setf (cdr local-table) node))
30 665c255d 2023-08-04 jrmu 	     (node-lookup (key node)
31 665c255d 2023-08-04 jrmu 	       (if (null node)
32 665c255d 2023-08-04 jrmu 		   nil
33 665c255d 2023-08-04 jrmu 		   (let* ((cur-entry (entry node))
34 665c255d 2023-08-04 jrmu 			  (cur-key (key cur-entry)))
35 665c255d 2023-08-04 jrmu 		     (cond ((funcall <? key cur-key)
36 665c255d 2023-08-04 jrmu 			    (node-lookup
37 665c255d 2023-08-04 jrmu 			     key
38 665c255d 2023-08-04 jrmu 			     (left-branch node)))
39 665c255d 2023-08-04 jrmu 			   ((funcall <? cur-key key)
40 665c255d 2023-08-04 jrmu 			    (node-lookup
41 665c255d 2023-08-04 jrmu 			     key
42 665c255d 2023-08-04 jrmu 			     (right-branch node)))
43 665c255d 2023-08-04 jrmu 			   (t ; equal
44 665c255d 2023-08-04 jrmu 			    cur-entry)))))
45 665c255d 2023-08-04 jrmu 	     (lookup (key)
46 665c255d 2023-08-04 jrmu 	       (node-lookup key (cdr local-table)))
47 665c255d 2023-08-04 jrmu 	     (node-insert (key data node)
48 665c255d 2023-08-04 jrmu 	       (let* ((cur-entry (entry node))
49 665c255d 2023-08-04 jrmu 		      (cur-key (key cur-entry)))
50 665c255d 2023-08-04 jrmu 		 (cond ((funcall <? key cur-key)
51 665c255d 2023-08-04 jrmu 			(if if (null (left-branch node))
52 665c255d 2023-08-04 jrmu 			    (set-left-branch!
53 665c255d 2023-08-04 jrmu 			     node
54 665c255d 2023-08-04 jrmu 			     (make-leaf
55 665c255d 2023-08-04 jrmu 			      (make-record key data)))
56 665c255d 2023-08-04 jrmu 			    (node-insert
57 665c255d 2023-08-04 jrmu 			     key data (left-branch node))))
58 665c255d 2023-08-04 jrmu 		       ((funcall <? cur-key key)
59 665c255d 2023-08-04 jrmu 			(if (null (right-branch node))
60 665c255d 2023-08-04 jrmu 			    (set-right-branch!
61 665c255d 2023-08-04 jrmu 			     node
62 665c255d 2023-08-04 jrmu 			     (make-leaf
63 665c255d 2023-08-04 jrmu 			      (make-record key data)))
64 665c255d 2023-08-04 jrmu 			    (node-insert
65 665c255d 2023-08-04 jrmu 			     key data (right-branch node))))
66 665c255d 2023-08-04 jrmu 		       (t ;equal
67 665c255d 2023-08-04 jrmu 			(set-entry!
68 665c255d 2023-08-04 jrmu 			 node (make-record key data))))))
69 665c255d 2023-08-04 jrmu 	     (insert! (key data)
70 665c255d 2023-08-04 jrmu 	       (if (null (tree-root))
71 665c255d 2023-08-04 jrmu 		   (set-tree-root!
72 665c255d 2023-08-04 jrmu 		    (make-leaf (make-record key data)))
73 665c255d 2023-08-04 jrmu 		   (node-insert key data (tree-root))))
74 665c255d 2023-08-04 jrmu 	     (dispatch (m)
75 665c255d 2023-08-04 jrmu 	       (case m
76 665c255d 2023-08-04 jrmu 		 ('lookup-proc #'lookup)
77 665c255d 2023-08-04 jrmu 		 ('insert-proc! #'insert!)
78 665c255d 2023-08-04 jrmu 		 (otherwise (error "Bad dispatch ~a" m)))))
79 665c255d 2023-08-04 jrmu       #'dispatch)))
80 665c255d 2023-08-04 jrmu