Mercurial > emacs
comparison lisp/emacs-lisp/avl-tree.el @ 83827:17a8beea7b8c
Use defstruct rather than macros.
Change naming to use "avl-tree--" for internal functions.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Fri, 31 Aug 2007 20:15:34 +0000 |
parents | 7224e10a56f5 |
children | b9e8ab94c460 |
comparison
equal
deleted
inserted
replaced
83826:41451b9525da | 83827:17a8beea7b8c |
---|---|
26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | 26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
27 ;; Boston, MA 02110-1301, USA. | 27 ;; Boston, MA 02110-1301, USA. |
28 | 28 |
29 ;;; Commentary: | 29 ;;; Commentary: |
30 | 30 |
31 ;; An AVL tree is a nearly-perfect balanced binary tree. A tree | 31 ;; An AVL tree is a nearly-perfect balanced binary tree. A tree consists of |
32 ;; consists of two cons cells, the first one holding the tag | 32 ;; two elements, the root node and the compare function. The actual tree |
33 ;; 'AVL-TREE in the car cell, and the second one having the tree | 33 ;; has a dummy node as its root with the real root in the left pointer. |
34 ;; in the car and the compare function in the cdr cell. The tree has | |
35 ;; a dummy node as its root with the real tree in the left pointer. | |
36 ;; | 34 ;; |
37 ;; Each node of the tree consists of one data element, one left | 35 ;; Each node of the tree consists of one data element, one left |
38 ;; sub-tree and one right sub-tree. Each node also has a balance | 36 ;; sub-tree and one right sub-tree. Each node also has a balance |
39 ;; count, which is the difference in depth of the left and right | 37 ;; count, which is the difference in depth of the left and right |
40 ;; sub-trees. | 38 ;; sub-trees. |
41 ;; | 39 ;; |
42 ;; The "public" functions (prefixed with "avl-tree") are: | 40 ;; The functions with names of the form "avl-tree--" are intended for |
43 ;; -create, -p, -compare-function, -empty, -enter, -delete, | 41 ;; internal use only. |
44 ;; -member, -map, -first, -last, -copy, -flatten, -size, -clear. | |
45 | 42 |
46 ;;; Code: | 43 ;;; Code: |
47 | 44 |
48 ;;; ================================================================ | 45 (eval-when-compile (require 'cl)) |
49 ;;; Functions and macros handling an AVL tree node. | 46 |
50 | 47 ;; ================================================================ |
51 (defmacro avl-tree-node-create (left right data balance) | 48 ;;; Functions and macros handling an AVL tree node. |
52 ;; Create and return an avl-tree node. | 49 |
53 `(vector ,left ,right ,data ,balance)) | 50 (defstruct (avl-tree--node |
54 | 51 ;; We force a representation without tag so it matches the |
55 (defmacro avl-tree-node-left (node) | 52 ;; pre-defstruct representation. Also we use the underlying |
56 ;; Return the left pointer of NODE. | 53 ;; representation in the implementation of avl-tree--node-branch. |
57 `(aref ,node 0)) | 54 (:type vector) |
58 | 55 (:constructor nil) |
59 (defmacro avl-tree-node-right (node) | 56 (:constructor avl-tree--node-create (left right data balance)) |
60 ;; Return the right pointer of NODE. | 57 (:copier nil)) |
61 `(aref ,node 1)) | 58 left right data balance) |
62 | 59 |
63 (defmacro avl-tree-node-data (node) | 60 (defalias 'avl-tree--node-branch 'aref |
64 ;; Return the data of NODE. | 61 ;; This implementation is efficient but breaks the defstruct abstraction. |
65 `(aref ,node 2)) | 62 ;; An alternative could be |
66 | 63 ;; (funcall (aref [avl-tree-left avl-tree-right avl-tree-data] branch) node) |
67 (defmacro avl-tree-node-set-left (node newleft) | |
68 ;; Set the left pointer of NODE to NEWLEFT. | |
69 `(aset ,node 0 ,newleft)) | |
70 | |
71 (defmacro avl-tree-node-set-right (node newright) | |
72 ;; Set the right pointer of NODE to NEWRIGHT. | |
73 `(aset ,node 1 ,newright)) | |
74 | |
75 (defmacro avl-tree-node-set-data (node newdata) | |
76 ;; Set the data of NODE to NEWDATA. | |
77 `(aset ,node 2 ,newdata)) | |
78 | |
79 (defmacro avl-tree-node-branch (node branch) | |
80 "Get value of a branch of a node. | 64 "Get value of a branch of a node. |
81 | 65 |
82 NODE is the node, and BRANCH is the branch. | 66 NODE is the node, and BRANCH is the branch. |
83 0 for left pointer, 1 for right pointer and 2 for the data.\"" | 67 0 for left pointer, 1 for right pointer and 2 for the data.\" |
84 `(aref ,node ,branch)) | 68 \(fn node branch)") |
85 | 69 ;; The funcall/aref trick doesn't work for the setf method, unless we try |
86 (defmacro avl-tree-node-set-branch (node branch newval) | 70 ;; and access the underlying setter function, but this wouldn't be |
87 "Set value of a branch of a node. | 71 ;; portable either. |
88 | 72 (defsetf avl-tree--node-branch aset) |
89 NODE is the node, and BRANCH is the branch. | |
90 0 for left pointer, 1 for the right pointer and 2 for the data. | |
91 NEWVAL is new value of the branch.\"" | |
92 `(aset ,node ,branch ,newval)) | |
93 | |
94 (defmacro avl-tree-node-balance (node) | |
95 ;; Return the balance field of a node. | |
96 `(aref ,node 3)) | |
97 | |
98 (defmacro avl-tree-node-set-balance (node newbal) | |
99 ;; Set the balance field of a node. | |
100 `(aset ,node 3 ,newbal)) | |
101 | 73 |
102 | 74 |
103 ;;; ================================================================ | 75 ;; ================================================================ |
104 ;;; Internal functions for use in the AVL tree package | 76 ;;; Internal functions for use in the AVL tree package |
105 | 77 |
106 (defmacro avl-tree-root (tree) | 78 (defstruct (avl-tree- |
79 ;; A tagged list is the pre-defstruct representation. | |
80 ;; (:type list) | |
81 :named | |
82 (:constructor nil) | |
83 (:constructor avl-tree-create (cmpfun)) | |
84 (:predicate avl-tree-p) | |
85 (:copier nil)) | |
86 (dummyroot (avl-tree--node-create nil nil nil 0)) | |
87 cmpfun) | |
88 | |
89 (defmacro avl-tree--root (tree) | |
107 ;; Return the root node for an avl-tree. INTERNAL USE ONLY. | 90 ;; Return the root node for an avl-tree. INTERNAL USE ONLY. |
108 `(avl-tree-node-left (car (cdr ,tree)))) | 91 `(avl-tree--node-left (avl-tree--dummyroot tree))) |
109 | 92 (defsetf avl-tree--root (tree) (node) |
110 (defmacro avl-tree-dummyroot (tree) | 93 `(setf (avl-tree--node-left (avl-tree--dummyroot ,tree)) ,node)) |
111 ;; Return the dummy node of an avl-tree. INTERNAL USE ONLY. | |
112 `(car (cdr ,tree))) | |
113 | |
114 (defmacro avl-tree-cmpfun (tree) | |
115 ;; Return the compare function of AVL tree TREE. INTERNAL USE ONLY. | |
116 `(cdr (cdr ,tree))) | |
117 | 94 |
118 ;; ---------------------------------------------------------------- | 95 ;; ---------------------------------------------------------------- |
119 ;; Deleting data | 96 ;; Deleting data |
120 | 97 |
121 (defun avl-tree-del-balance1 (node branch) | 98 (defun avl-tree--del-balance1 (node branch) |
122 ;; Rebalance a tree and return t if the height of the tree has shrunk. | 99 ;; Rebalance a tree and return t if the height of the tree has shrunk. |
123 (let ((br (avl-tree-node-branch node branch)) | 100 (let ((br (avl-tree--node-branch node branch)) |
124 p1 b1 p2 b2 result) | 101 p1 b1 p2 b2 result) |
125 (cond | 102 (cond |
126 ((< (avl-tree-node-balance br) 0) | 103 ((< (avl-tree--node-balance br) 0) |
127 (avl-tree-node-set-balance br 0) | 104 (setf (avl-tree--node-balance br) 0) |
128 t) | 105 t) |
129 | 106 |
130 ((= (avl-tree-node-balance br) 0) | 107 ((= (avl-tree--node-balance br) 0) |
131 (avl-tree-node-set-balance br +1) | 108 (setf (avl-tree--node-balance br) +1) |
132 nil) | 109 nil) |
133 | 110 |
134 (t | 111 (t |
135 ;; Rebalance. | 112 ;; Rebalance. |
136 (setq p1 (avl-tree-node-right br) | 113 (setq p1 (avl-tree--node-right br) |
137 b1 (avl-tree-node-balance p1)) | 114 b1 (avl-tree--node-balance p1)) |
138 (if (>= b1 0) | 115 (if (>= b1 0) |
139 ;; Single RR rotation. | 116 ;; Single RR rotation. |
140 (progn | 117 (progn |
141 (avl-tree-node-set-right br (avl-tree-node-left p1)) | 118 (setf (avl-tree--node-right br) (avl-tree--node-left p1)) |
142 (avl-tree-node-set-left p1 br) | 119 (setf (avl-tree--node-left p1) br) |
143 (if (= 0 b1) | 120 (if (= 0 b1) |
144 (progn | 121 (progn |
145 (avl-tree-node-set-balance br +1) | 122 (setf (avl-tree--node-balance br) +1) |
146 (avl-tree-node-set-balance p1 -1) | 123 (setf (avl-tree--node-balance p1) -1) |
147 (setq result nil)) | 124 (setq result nil)) |
148 (avl-tree-node-set-balance br 0) | 125 (setf (avl-tree--node-balance br) 0) |
149 (avl-tree-node-set-balance p1 0) | 126 (setf (avl-tree--node-balance p1) 0) |
150 (setq result t)) | 127 (setq result t)) |
151 (avl-tree-node-set-branch node branch p1) | 128 (setf (avl-tree--node-branch node branch) p1) |
152 result) | 129 result) |
153 | 130 |
154 ;; Double RL rotation. | 131 ;; Double RL rotation. |
155 (setq p2 (avl-tree-node-left p1) | 132 (setq p2 (avl-tree--node-left p1) |
156 b2 (avl-tree-node-balance p2)) | 133 b2 (avl-tree--node-balance p2)) |
157 (avl-tree-node-set-left p1 (avl-tree-node-right p2)) | 134 (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) |
158 (avl-tree-node-set-right p2 p1) | 135 (setf (avl-tree--node-right p2) p1) |
159 (avl-tree-node-set-right br (avl-tree-node-left p2)) | 136 (setf (avl-tree--node-right br) (avl-tree--node-left p2)) |
160 (avl-tree-node-set-left p2 br) | 137 (setf (avl-tree--node-left p2) br) |
161 (if (> b2 0) | 138 (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) |
162 (avl-tree-node-set-balance br -1) | 139 (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) |
163 (avl-tree-node-set-balance br 0)) | 140 (setf (avl-tree--node-branch node branch) p2) |
164 (if (< b2 0) | 141 (setf (avl-tree--node-balance p2) 0) |
165 (avl-tree-node-set-balance p1 +1) | |
166 (avl-tree-node-set-balance p1 0)) | |
167 (avl-tree-node-set-branch node branch p2) | |
168 (avl-tree-node-set-balance p2 0) | |
169 t))))) | 142 t))))) |
170 | 143 |
171 (defun avl-tree-del-balance2 (node branch) | 144 (defun avl-tree--del-balance2 (node branch) |
172 (let ((br (avl-tree-node-branch node branch)) | 145 (let ((br (avl-tree--node-branch node branch)) |
173 p1 b1 p2 b2 result) | 146 p1 b1 p2 b2 result) |
174 (cond | 147 (cond |
175 ((> (avl-tree-node-balance br) 0) | 148 ((> (avl-tree--node-balance br) 0) |
176 (avl-tree-node-set-balance br 0) | 149 (setf (avl-tree--node-balance br) 0) |
177 t) | 150 t) |
178 | 151 |
179 ((= (avl-tree-node-balance br) 0) | 152 ((= (avl-tree--node-balance br) 0) |
180 (avl-tree-node-set-balance br -1) | 153 (setf (avl-tree--node-balance br) -1) |
181 nil) | 154 nil) |
182 | 155 |
183 (t | 156 (t |
184 ;; Rebalance. | 157 ;; Rebalance. |
185 (setq p1 (avl-tree-node-left br) | 158 (setq p1 (avl-tree--node-left br) |
186 b1 (avl-tree-node-balance p1)) | 159 b1 (avl-tree--node-balance p1)) |
187 (if (<= b1 0) | 160 (if (<= b1 0) |
188 ;; Single LL rotation. | 161 ;; Single LL rotation. |
189 (progn | 162 (progn |
190 (avl-tree-node-set-left br (avl-tree-node-right p1)) | 163 (setf (avl-tree--node-left br) (avl-tree--node-right p1)) |
191 (avl-tree-node-set-right p1 br) | 164 (setf (avl-tree--node-right p1) br) |
192 (if (= 0 b1) | 165 (if (= 0 b1) |
193 (progn | 166 (progn |
194 (avl-tree-node-set-balance br -1) | 167 (setf (avl-tree--node-balance br) -1) |
195 (avl-tree-node-set-balance p1 +1) | 168 (setf (avl-tree--node-balance p1) +1) |
196 (setq result nil)) | 169 (setq result nil)) |
197 (avl-tree-node-set-balance br 0) | 170 (setf (avl-tree--node-balance br) 0) |
198 (avl-tree-node-set-balance p1 0) | 171 (setf (avl-tree--node-balance p1) 0) |
199 (setq result t)) | 172 (setq result t)) |
200 (avl-tree-node-set-branch node branch p1) | 173 (setf (avl-tree--node-branch node branch) p1) |
201 result) | 174 result) |
202 | 175 |
203 ;; Double LR rotation. | 176 ;; Double LR rotation. |
204 (setq p2 (avl-tree-node-right p1) | 177 (setq p2 (avl-tree--node-right p1) |
205 b2 (avl-tree-node-balance p2)) | 178 b2 (avl-tree--node-balance p2)) |
206 (avl-tree-node-set-right p1 (avl-tree-node-left p2)) | 179 (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) |
207 (avl-tree-node-set-left p2 p1) | 180 (setf (avl-tree--node-left p2) p1) |
208 (avl-tree-node-set-left br (avl-tree-node-right p2)) | 181 (setf (avl-tree--node-left br) (avl-tree--node-right p2)) |
209 (avl-tree-node-set-right p2 br) | 182 (setf (avl-tree--node-right p2) br) |
210 (if (< b2 0) | 183 (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) |
211 (avl-tree-node-set-balance br +1) | 184 (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) |
212 (avl-tree-node-set-balance br 0)) | 185 (setf (avl-tree--node-branch node branch) p2) |
213 (if (> b2 0) | 186 (setf (avl-tree--node-balance p2) 0) |
214 (avl-tree-node-set-balance p1 -1) | |
215 (avl-tree-node-set-balance p1 0)) | |
216 (avl-tree-node-set-branch node branch p2) | |
217 (avl-tree-node-set-balance p2 0) | |
218 t))))) | 187 t))))) |
219 | 188 |
220 (defun avl-tree-do-del-internal (node branch q) | 189 (defun avl-tree--do-del-internal (node branch q) |
221 (let ((br (avl-tree-node-branch node branch))) | 190 (let ((br (avl-tree--node-branch node branch))) |
222 (if (avl-tree-node-right br) | 191 (if (avl-tree--node-right br) |
223 (if (avl-tree-do-del-internal br +1 q) | 192 (if (avl-tree--do-del-internal br +1 q) |
224 (avl-tree-del-balance2 node branch)) | 193 (avl-tree--del-balance2 node branch)) |
225 (avl-tree-node-set-data q (avl-tree-node-data br)) | 194 (setf (avl-tree--node-data q) (avl-tree--node-data br)) |
226 (avl-tree-node-set-branch node branch | 195 (setf (avl-tree--node-branch node branch) |
227 (avl-tree-node-left br)) | 196 (avl-tree--node-left br)) |
228 t))) | 197 t))) |
229 | 198 |
230 (defun avl-tree-do-delete (cmpfun root branch data) | 199 (defun avl-tree--do-delete (cmpfun root branch data) |
231 ;; Return t if the height of the tree has shrunk. | 200 ;; Return t if the height of the tree has shrunk. |
232 (let ((br (avl-tree-node-branch root branch))) | 201 (let ((br (avl-tree--node-branch root branch))) |
233 (cond | 202 (cond |
234 ((null br) | 203 ((null br) |
235 nil) | 204 nil) |
236 | 205 |
237 ((funcall cmpfun data (avl-tree-node-data br)) | 206 ((funcall cmpfun data (avl-tree--node-data br)) |
238 (if (avl-tree-do-delete cmpfun br 0 data) | 207 (if (avl-tree--do-delete cmpfun br 0 data) |
239 (avl-tree-del-balance1 root branch))) | 208 (avl-tree--del-balance1 root branch))) |
240 | 209 |
241 ((funcall cmpfun (avl-tree-node-data br) data) | 210 ((funcall cmpfun (avl-tree--node-data br) data) |
242 (if (avl-tree-do-delete cmpfun br 1 data) | 211 (if (avl-tree--do-delete cmpfun br 1 data) |
243 (avl-tree-del-balance2 root branch))) | 212 (avl-tree--del-balance2 root branch))) |
244 | 213 |
245 (t | 214 (t |
246 ;; Found it. Let's delete it. | 215 ;; Found it. Let's delete it. |
247 (cond | 216 (cond |
248 ((null (avl-tree-node-right br)) | 217 ((null (avl-tree--node-right br)) |
249 (avl-tree-node-set-branch root branch (avl-tree-node-left br)) | 218 (setf (avl-tree--node-branch root branch) (avl-tree--node-left br)) |
250 t) | 219 t) |
251 | 220 |
252 ((null (avl-tree-node-left br)) | 221 ((null (avl-tree--node-left br)) |
253 (avl-tree-node-set-branch root branch (avl-tree-node-right br)) | 222 (setf (avl-tree--node-branch root branch) (avl-tree--node-right br)) |
254 t) | 223 t) |
255 | 224 |
256 (t | 225 (t |
257 (if (avl-tree-do-del-internal br 0 br) | 226 (if (avl-tree--do-del-internal br 0 br) |
258 (avl-tree-del-balance1 root branch)))))))) | 227 (avl-tree--del-balance1 root branch)))))))) |
259 | 228 |
260 ;; ---------------------------------------------------------------- | 229 ;; ---------------------------------------------------------------- |
261 ;; Entering data | 230 ;; Entering data |
262 | 231 |
263 (defun avl-tree-enter-balance1 (node branch) | 232 (defun avl-tree--enter-balance1 (node branch) |
264 ;; Rebalance a tree and return t if the height of the tree has grown. | 233 ;; Rebalance a tree and return t if the height of the tree has grown. |
265 (let ((br (avl-tree-node-branch node branch)) | 234 (let ((br (avl-tree--node-branch node branch)) |
266 p1 p2 b2 result) | 235 p1 p2 b2 result) |
267 (cond | 236 (cond |
268 ((< (avl-tree-node-balance br) 0) | 237 ((< (avl-tree--node-balance br) 0) |
269 (avl-tree-node-set-balance br 0) | 238 (setf (avl-tree--node-balance br) 0) |
270 nil) | 239 nil) |
271 | 240 |
272 ((= (avl-tree-node-balance br) 0) | 241 ((= (avl-tree--node-balance br) 0) |
273 (avl-tree-node-set-balance br +1) | 242 (setf (avl-tree--node-balance br) +1) |
274 t) | 243 t) |
275 | 244 |
276 (t | 245 (t |
277 ;; Tree has grown => Rebalance. | 246 ;; Tree has grown => Rebalance. |
278 (setq p1 (avl-tree-node-right br)) | 247 (setq p1 (avl-tree--node-right br)) |
279 (if (> (avl-tree-node-balance p1) 0) | 248 (if (> (avl-tree--node-balance p1) 0) |
280 ;; Single RR rotation. | 249 ;; Single RR rotation. |
281 (progn | 250 (progn |
282 (avl-tree-node-set-right br (avl-tree-node-left p1)) | 251 (setf (avl-tree--node-right br) (avl-tree--node-left p1)) |
283 (avl-tree-node-set-left p1 br) | 252 (setf (avl-tree--node-left p1) br) |
284 (avl-tree-node-set-balance br 0) | 253 (setf (avl-tree--node-balance br) 0) |
285 (avl-tree-node-set-branch node branch p1)) | 254 (setf (avl-tree--node-branch node branch) p1)) |
286 | 255 |
287 ;; Double RL rotation. | 256 ;; Double RL rotation. |
288 (setq p2 (avl-tree-node-left p1) | 257 (setq p2 (avl-tree--node-left p1) |
289 b2 (avl-tree-node-balance p2)) | 258 b2 (avl-tree--node-balance p2)) |
290 (avl-tree-node-set-left p1 (avl-tree-node-right p2)) | 259 (setf (avl-tree--node-left p1) (avl-tree--node-right p2)) |
291 (avl-tree-node-set-right p2 p1) | 260 (setf (avl-tree--node-right p2) p1) |
292 (avl-tree-node-set-right br (avl-tree-node-left p2)) | 261 (setf (avl-tree--node-right br) (avl-tree--node-left p2)) |
293 (avl-tree-node-set-left p2 br) | 262 (setf (avl-tree--node-left p2) br) |
294 (if (> b2 0) | 263 (setf (avl-tree--node-balance br) (if (> b2 0) -1 0)) |
295 (avl-tree-node-set-balance br -1) | 264 (setf (avl-tree--node-balance p1) (if (< b2 0) +1 0)) |
296 (avl-tree-node-set-balance br 0)) | 265 (setf (avl-tree--node-branch node branch) p2)) |
297 (if (< b2 0) | 266 (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) |
298 (avl-tree-node-set-balance p1 +1) | |
299 (avl-tree-node-set-balance p1 0)) | |
300 (avl-tree-node-set-branch node branch p2)) | |
301 (avl-tree-node-set-balance (avl-tree-node-branch node branch) 0) | |
302 nil)))) | 267 nil)))) |
303 | 268 |
304 (defun avl-tree-enter-balance2 (node branch) | 269 (defun avl-tree--enter-balance2 (node branch) |
305 ;; Return t if the tree has grown. | 270 ;; Return t if the tree has grown. |
306 (let ((br (avl-tree-node-branch node branch)) | 271 (let ((br (avl-tree--node-branch node branch)) |
307 p1 p2 b2) | 272 p1 p2 b2) |
308 (cond | 273 (cond |
309 ((> (avl-tree-node-balance br) 0) | 274 ((> (avl-tree--node-balance br) 0) |
310 (avl-tree-node-set-balance br 0) | 275 (setf (avl-tree--node-balance br) 0) |
311 nil) | 276 nil) |
312 | 277 |
313 ((= (avl-tree-node-balance br) 0) | 278 ((= (avl-tree--node-balance br) 0) |
314 (avl-tree-node-set-balance br -1) | 279 (setf (avl-tree--node-balance br) -1) |
315 t) | 280 t) |
316 | 281 |
317 (t | 282 (t |
318 ;; Balance was -1 => Rebalance. | 283 ;; Balance was -1 => Rebalance. |
319 (setq p1 (avl-tree-node-left br)) | 284 (setq p1 (avl-tree--node-left br)) |
320 (if (< (avl-tree-node-balance p1) 0) | 285 (if (< (avl-tree--node-balance p1) 0) |
321 ;; Single LL rotation. | 286 ;; Single LL rotation. |
322 (progn | 287 (progn |
323 (avl-tree-node-set-left br (avl-tree-node-right p1)) | 288 (setf (avl-tree--node-left br) (avl-tree--node-right p1)) |
324 (avl-tree-node-set-right p1 br) | 289 (setf (avl-tree--node-right p1) br) |
325 (avl-tree-node-set-balance br 0) | 290 (setf (avl-tree--node-balance br) 0) |
326 (avl-tree-node-set-branch node branch p1)) | 291 (setf (avl-tree--node-branch node branch) p1)) |
327 | 292 |
328 ;; Double LR rotation. | 293 ;; Double LR rotation. |
329 (setq p2 (avl-tree-node-right p1) | 294 (setq p2 (avl-tree--node-right p1) |
330 b2 (avl-tree-node-balance p2)) | 295 b2 (avl-tree--node-balance p2)) |
331 (avl-tree-node-set-right p1 (avl-tree-node-left p2)) | 296 (setf (avl-tree--node-right p1) (avl-tree--node-left p2)) |
332 (avl-tree-node-set-left p2 p1) | 297 (setf (avl-tree--node-left p2) p1) |
333 (avl-tree-node-set-left br (avl-tree-node-right p2)) | 298 (setf (avl-tree--node-left br) (avl-tree--node-right p2)) |
334 (avl-tree-node-set-right p2 br) | 299 (setf (avl-tree--node-right p2) br) |
335 (if (< b2 0) | 300 (setf (avl-tree--node-balance br) (if (< b2 0) +1 0)) |
336 (avl-tree-node-set-balance br +1) | 301 (setf (avl-tree--node-balance p1) (if (> b2 0) -1 0)) |
337 (avl-tree-node-set-balance br 0)) | 302 (setf (avl-tree--node-branch node branch) p2)) |
338 (if (> b2 0) | 303 (setf (avl-tree--node-balance (avl-tree--node-branch node branch)) 0) |
339 (avl-tree-node-set-balance p1 -1) | |
340 (avl-tree-node-set-balance p1 0)) | |
341 (avl-tree-node-set-branch node branch p2)) | |
342 (avl-tree-node-set-balance (avl-tree-node-branch node branch) 0) | |
343 nil)))) | 304 nil)))) |
344 | 305 |
345 (defun avl-tree-do-enter (cmpfun root branch data) | 306 (defun avl-tree--do-enter (cmpfun root branch data) |
346 ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. | 307 ;; Return t if height of tree ROOT has grown. INTERNAL USE ONLY. |
347 (let ((br (avl-tree-node-branch root branch))) | 308 (let ((br (avl-tree--node-branch root branch))) |
348 (cond | 309 (cond |
349 ((null br) | 310 ((null br) |
350 ;; Data not in tree, insert it. | 311 ;; Data not in tree, insert it. |
351 (avl-tree-node-set-branch | 312 (setf (avl-tree--node-branch root branch) |
352 root branch (avl-tree-node-create nil nil data 0)) | 313 (avl-tree--node-create nil nil data 0)) |
353 t) | 314 t) |
354 | 315 |
355 ((funcall cmpfun data (avl-tree-node-data br)) | 316 ((funcall cmpfun data (avl-tree--node-data br)) |
356 (and (avl-tree-do-enter cmpfun br 0 data) | 317 (and (avl-tree--do-enter cmpfun br 0 data) |
357 (avl-tree-enter-balance2 root branch))) | 318 (avl-tree--enter-balance2 root branch))) |
358 | 319 |
359 ((funcall cmpfun (avl-tree-node-data br) data) | 320 ((funcall cmpfun (avl-tree--node-data br) data) |
360 (and (avl-tree-do-enter cmpfun br 1 data) | 321 (and (avl-tree--do-enter cmpfun br 1 data) |
361 (avl-tree-enter-balance1 root branch))) | 322 (avl-tree--enter-balance1 root branch))) |
362 | 323 |
363 (t | 324 (t |
364 (avl-tree-node-set-data br data) | 325 (setf (avl-tree--node-data br) data) |
365 nil)))) | 326 nil)))) |
366 | 327 |
367 ;; ---------------------------------------------------------------- | 328 ;; ---------------------------------------------------------------- |
368 | 329 |
369 (defun avl-tree-mapc (map-function root) | 330 (defun avl-tree--mapc (map-function root) |
370 ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. | 331 ;; Apply MAP-FUNCTION to all nodes in the tree starting with ROOT. |
371 ;; The function is applied in-order. | 332 ;; The function is applied in-order. |
372 ;; | 333 ;; |
373 ;; Note: MAP-FUNCTION is applied to the node and not to the data itself. | 334 ;; Note: MAP-FUNCTION is applied to the node and not to the data itself. |
374 ;; INTERNAL USE ONLY. | 335 ;; INTERNAL USE ONLY. |
376 (stack nil) | 337 (stack nil) |
377 (go-left t)) | 338 (go-left t)) |
378 (push nil stack) | 339 (push nil stack) |
379 (while node | 340 (while node |
380 (if (and go-left | 341 (if (and go-left |
381 (avl-tree-node-left node)) | 342 (avl-tree--node-left node)) |
382 ;; Do the left subtree first. | 343 ;; Do the left subtree first. |
383 (progn | 344 (progn |
384 (push node stack) | 345 (push node stack) |
385 (setq node (avl-tree-node-left node))) | 346 (setq node (avl-tree--node-left node))) |
386 ;; Apply the function... | 347 ;; Apply the function... |
387 (funcall map-function node) | 348 (funcall map-function node) |
388 ;; and do the right subtree. | 349 ;; and do the right subtree. |
389 (if (avl-tree-node-right node) | 350 (setq node (if (setq go-left (avl-tree--node-right node)) |
390 (setq node (avl-tree-node-right node) | 351 (avl-tree--node-right node) |
391 go-left t) | 352 (pop stack))))))) |
392 (setq node (pop stack) | 353 |
393 go-left nil)))))) | 354 (defun avl-tree--do-copy (root) |
394 | |
395 (defun avl-tree-do-copy (root) | |
396 ;; Copy the avl tree with ROOT as root. | 355 ;; Copy the avl tree with ROOT as root. |
397 ;; Highly recursive. INTERNAL USE ONLY. | 356 ;; Highly recursive. INTERNAL USE ONLY. |
398 (if (null root) | 357 (if (null root) |
399 nil | 358 nil |
400 (avl-tree-node-create | 359 (avl-tree--node-create |
401 (avl-tree-do-copy (avl-tree-node-left root)) | 360 (avl-tree--do-copy (avl-tree--node-left root)) |
402 (avl-tree-do-copy (avl-tree-node-right root)) | 361 (avl-tree--do-copy (avl-tree--node-right root)) |
403 (avl-tree-node-data root) | 362 (avl-tree--node-data root) |
404 (avl-tree-node-balance root)))) | 363 (avl-tree--node-balance root)))) |
405 | 364 |
406 | 365 |
407 ;;; ================================================================ | 366 ;; ================================================================ |
408 ;;; The public functions which operate on AVL trees. | 367 ;;; The public functions which operate on AVL trees. |
409 | 368 |
410 (defun avl-tree-create (compare-function) | 369 (defalias 'avl-tree-compare-function 'avl-tree--cmpfun |
411 "Create a new empty avl tree and return it. | 370 "Return the comparison function for the avl tree TREE. |
412 COMPARE-FUNCTION is a function which takes two arguments, A and B, | 371 |
413 and returns non-nil if A is less than B, and nil otherwise." | 372 \(fn TREE)") |
414 (cons 'AVL-TREE | |
415 (cons (avl-tree-node-create nil nil nil 0) | |
416 compare-function))) | |
417 | |
418 (defun avl-tree-p (obj) | |
419 "Return t if OBJ is an avl tree, nil otherwise." | |
420 (eq (car-safe obj) 'AVL-TREE)) | |
421 | |
422 (defun avl-tree-compare-function (tree) | |
423 "Return the comparison function for the avl tree TREE." | |
424 (avl-tree-cmpfun tree)) | |
425 | 373 |
426 (defun avl-tree-empty (tree) | 374 (defun avl-tree-empty (tree) |
427 "Return t if avl tree TREE is emtpy, otherwise return nil." | 375 "Return t if avl tree TREE is emtpy, otherwise return nil." |
428 (null (avl-tree-root tree))) | 376 (null (avl-tree--root tree))) |
429 | 377 |
430 (defun avl-tree-enter (tree data) | 378 (defun avl-tree-enter (tree data) |
431 "In the avl tree TREE insert DATA. | 379 "In the avl tree TREE insert DATA. |
432 Return DATA." | 380 Return DATA." |
433 (avl-tree-do-enter (avl-tree-cmpfun tree) | 381 (avl-tree--do-enter (avl-tree--cmpfun tree) |
434 (avl-tree-dummyroot tree) | 382 (avl-tree--dummyroot tree) |
435 0 | 383 0 |
436 data) | 384 data) |
437 data) | 385 data) |
438 | 386 |
439 (defun avl-tree-delete (tree data) | 387 (defun avl-tree-delete (tree data) |
440 "From the avl tree TREE, delete DATA. | 388 "From the avl tree TREE, delete DATA. |
441 Return the element in TREE which matched DATA, | 389 Return the element in TREE which matched DATA, |
442 nil if no element matched." | 390 nil if no element matched." |
443 (avl-tree-do-delete (avl-tree-cmpfun tree) | 391 (avl-tree--do-delete (avl-tree--cmpfun tree) |
444 (avl-tree-dummyroot tree) | 392 (avl-tree--dummyroot tree) |
445 0 | 393 0 |
446 data)) | 394 data)) |
447 | 395 |
448 (defun avl-tree-member (tree data) | 396 (defun avl-tree-member (tree data) |
449 "Return the element in the avl tree TREE which matches DATA. | 397 "Return the element in the avl tree TREE which matches DATA. |
450 Matching uses the compare function previously specified in | 398 Matching uses the compare function previously specified in |
451 `avl-tree-create' when TREE was created. | 399 `avl-tree-create' when TREE was created. |
452 | 400 |
453 If there is no such element in the tree, the value is nil." | 401 If there is no such element in the tree, the value is nil." |
454 (let ((node (avl-tree-root tree)) | 402 (let ((node (avl-tree--root tree)) |
455 (compare-function (avl-tree-cmpfun tree)) | 403 (compare-function (avl-tree--cmpfun tree)) |
456 found) | 404 found) |
457 (while (and node | 405 (while (and node |
458 (not found)) | 406 (not found)) |
459 (cond | 407 (cond |
460 ((funcall compare-function data (avl-tree-node-data node)) | 408 ((funcall compare-function data (avl-tree--node-data node)) |
461 (setq node (avl-tree-node-left node))) | 409 (setq node (avl-tree--node-left node))) |
462 ((funcall compare-function (avl-tree-node-data node) data) | 410 ((funcall compare-function (avl-tree--node-data node) data) |
463 (setq node (avl-tree-node-right node))) | 411 (setq node (avl-tree--node-right node))) |
464 (t | 412 (t |
465 (setq found t)))) | 413 (setq found t)))) |
466 (if node | 414 (if node |
467 (avl-tree-node-data node) | 415 (avl-tree--node-data node) |
468 nil))) | 416 nil))) |
469 | 417 |
470 (defun avl-tree-map (__map-function__ tree) | 418 (defun avl-tree-map (__map-function__ tree) |
471 "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." | 419 "Apply __MAP-FUNCTION__ to all elements in the avl tree TREE." |
472 (avl-tree-mapc | 420 (avl-tree--mapc |
473 (function (lambda (node) | 421 (lambda (node) |
474 (avl-tree-node-set-data | 422 (setf (avl-tree--node-data node) |
475 node (funcall __map-function__ | 423 (funcall __map-function__ (avl-tree--node-data node)))) |
476 (avl-tree-node-data node))))) | 424 (avl-tree--root tree))) |
477 (avl-tree-root tree))) | |
478 | 425 |
479 (defun avl-tree-first (tree) | 426 (defun avl-tree-first (tree) |
480 "Return the first element in TREE, or nil if TREE is empty." | 427 "Return the first element in TREE, or nil if TREE is empty." |
481 (let ((node (avl-tree-root tree))) | 428 (let ((node (avl-tree--root tree))) |
482 (if node | 429 (when node |
483 (progn | 430 (while (avl-tree--node-left node) |
484 (while (avl-tree-node-left node) | 431 (setq node (avl-tree--node-left node))) |
485 (setq node (avl-tree-node-left node))) | 432 (avl-tree--node-data node)))) |
486 (avl-tree-node-data node)) | |
487 nil))) | |
488 | 433 |
489 (defun avl-tree-last (tree) | 434 (defun avl-tree-last (tree) |
490 "Return the last element in TREE, or nil if TREE is empty." | 435 "Return the last element in TREE, or nil if TREE is empty." |
491 (let ((node (avl-tree-root tree))) | 436 (let ((node (avl-tree--root tree))) |
492 (if node | 437 (when node |
493 (progn | 438 (while (avl-tree--node-right node) |
494 (while (avl-tree-node-right node) | 439 (setq node (avl-tree--node-right node))) |
495 (setq node (avl-tree-node-right node))) | 440 (avl-tree--node-data node)))) |
496 (avl-tree-node-data node)) | |
497 nil))) | |
498 | 441 |
499 (defun avl-tree-copy (tree) | 442 (defun avl-tree-copy (tree) |
500 "Return a copy of the avl tree TREE." | 443 "Return a copy of the avl tree TREE." |
501 (let ((new-tree (avl-tree-create (avl-tree-cmpfun tree)))) | 444 (let ((new-tree (avl-tree-create (avl-tree--cmpfun tree)))) |
502 (avl-tree-node-set-left (avl-tree-dummyroot new-tree) | 445 (setf (avl-tree--root new-tree) (avl-tree--do-copy (avl-tree--root tree))) |
503 (avl-tree-do-copy (avl-tree-root tree))) | |
504 new-tree)) | 446 new-tree)) |
505 | 447 |
506 (defun avl-tree-flatten (tree) | 448 (defun avl-tree-flatten (tree) |
507 "Return a sorted list containing all elements of TREE." | 449 "Return a sorted list containing all elements of TREE." |
508 (nreverse | 450 (nreverse |
509 (let ((treelist nil)) | 451 (let ((treelist nil)) |
510 (avl-tree-mapc | 452 (avl-tree--mapc |
511 (function (lambda (node) | 453 (lambda (node) (push (avl-tree--node-data node) treelist)) |
512 (setq treelist (cons (avl-tree-node-data node) | 454 (avl-tree--root tree)) |
513 treelist)))) | |
514 (avl-tree-root tree)) | |
515 treelist))) | 455 treelist))) |
516 | 456 |
517 (defun avl-tree-size (tree) | 457 (defun avl-tree-size (tree) |
518 "Return the number of elements in TREE." | 458 "Return the number of elements in TREE." |
519 (let ((treesize 0)) | 459 (let ((treesize 0)) |
520 (avl-tree-mapc | 460 (avl-tree--mapc |
521 (function (lambda (data) | 461 (lambda (data) (setq treesize (1+ treesize))) |
522 (setq treesize (1+ treesize)) | 462 (avl-tree--root tree)) |
523 data)) | |
524 (avl-tree-root tree)) | |
525 treesize)) | 463 treesize)) |
526 | 464 |
527 (defun avl-tree-clear (tree) | 465 (defun avl-tree-clear (tree) |
528 "Clear the avl tree TREE." | 466 "Clear the avl tree TREE." |
529 (avl-tree-node-set-left (avl-tree-dummyroot tree) nil)) | 467 (setf (avl-tree--root tree) nil)) |
530 | 468 |
531 (provide 'avl-tree) | 469 (provide 'avl-tree) |
532 | 470 |
533 ;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 | 471 ;; arch-tag: 47e26701-43c9-4222-bd79-739eac6357a9 |
534 ;;; avl-tree.el ends here | 472 ;;; avl-tree.el ends here |