btree.l (12807B)
1 # 26dec12abu 2 # (c) Software Lab. Alexander Burger 3 4 # *Prune 5 6 (de root (Tree) 7 (cond 8 ((not Tree) (val *DB)) 9 ((atom Tree) (val Tree)) 10 ((ext? (cdr Tree)) (get @ (car Tree))) 11 ((atom (cdr Tree)) 12 (get *DB (cdr Tree) (car Tree)) ) 13 (T (get (cddr Tree) (cadr Tree) (car Tree))) ) ) 14 15 # Fetch 16 (de fetch (Tree Key) 17 (let? Node (cdr (root Tree)) 18 (and *Prune (idx '*Prune Node T)) 19 (use R 20 (loop 21 (T 22 (and 23 (setq R (rank Key (cdr (val Node)))) 24 (= Key (car R)) ) 25 (or (cddr R) (fin (car R))) ) 26 (NIL 27 (setq Node (if R (cadr R) (car (val Node)))) ) ) ) ) ) 28 29 # Store 30 (de store (Tree Key Val Dbf) 31 (default Dbf (1 . 256)) 32 (if (atom Tree) 33 (let Base (or Tree *DB) 34 (_store (or (val Base) (set Base (cons 0)))) ) 35 (let Base 36 (if (atom (cdr Tree)) 37 (or 38 (ext? (cdr Tree)) 39 (get *DB (cdr Tree)) 40 (put *DB (cdr Tree) (new T)) ) 41 (or 42 (get (cddr Tree) (cadr Tree)) 43 (put (cddr Tree) (cadr Tree) (new T)) ) ) 44 (_store 45 (or 46 (get Base (car Tree)) 47 (put Base (car Tree) (cons 0)) ) ) ) ) ) 48 49 50 (de _store (Root) 51 (and *Prune (cdr Root) (idx '*Prune @ T)) 52 (ifn Val 53 (when (and (cdr Root) (_del @)) 54 (touch Base) 55 (cond 56 (*Solo (zap (cdr Root))) 57 (*Zap (push @ (cdr Root))) ) 58 (con Root) ) 59 (and (= Val (fin Key)) (off Val)) 60 (if (cdr Root) 61 (when (_put @) 62 (touch Base) 63 (con Root (def (new (car Dbf)) (list (car @) (cdr @)))) ) 64 (touch Base) 65 (con Root 66 (def (new (car Dbf)) 67 (list NIL (cons Key NIL Val)) ) ) 68 (inc Root) ) ) ) 69 70 (de _put (Top) 71 (let (V (val Top) R (rank Key (cdr V))) 72 (cond 73 (R 74 (if (= Key (car R)) 75 (nil (touch Top) (con (cdr R) Val)) 76 (let X (memq R V) 77 (if (cadr R) 78 (when (_put @) 79 (touch Top) 80 (set (cdr R) (car @)) 81 (con X (cons (cdr @) (cdr X))) 82 (_splitBt) ) 83 (touch Top) 84 (con X 85 (cons (cons Key (cons NIL Val)) (cdr X)) ) 86 (touch Base) 87 (inc Root) 88 (_splitBt) ) ) ) ) 89 ((car V) 90 (when (_put @) 91 (touch Top) 92 (set V (car @)) 93 (con V (cons (cdr @) (cdr V))) 94 (_splitBt) ) ) 95 (T 96 (touch Top) 97 (con V 98 (cons (cons Key (cons NIL Val)) (cdr V)) ) 99 (touch Base) 100 (inc Root) 101 (_splitBt) ) ) ) ) 102 103 (de _splitBt () 104 (when (and (cddddr V) (> (size Top) (cdr Dbf))) 105 (let (N (>> 1 (length V)) X (get V (inc N))) 106 (set (cdr X) 107 (def (new (car Dbf)) 108 (cons (cadr X) (nth V (+ 2 N))) ) ) 109 (cons 110 (if *Solo 111 (prog (set Top (head N V)) Top) 112 (and *Zap (push @ Top)) 113 (def (new (car Dbf)) (head N V)) ) 114 X ) ) ) ) 115 116 # Del 117 (de _del (Top) 118 (let (V (val Top) R (rank Key (cdr V))) 119 (cond 120 ((not R) 121 (when (and (car V) (_del @)) 122 (touch Top) 123 (cond 124 (*Solo (zap (car V))) 125 (*Zap (push @ (car V))) ) 126 (set V) 127 (not (cdr V)) ) ) 128 ((= Key (car R)) 129 (if (cadr R) 130 (let X (val @) 131 (while (car X) (setq X (val @))) 132 (touch Top) 133 (xchg R (cadr X)) 134 (con (cdr R) (cddr (cadr X))) 135 (when (_del (cadr R)) 136 (cond 137 (*Solo (zap (cadr R))) 138 (*Zap (push @ (cadr R))) ) 139 (set (cdr R)) ) ) 140 (touch Base) 141 (dec Root) 142 (nand 143 (or 144 (con V (delq R (cdr V))) 145 (car V) ) 146 (touch Top) ) ) ) 147 ((cadr R) 148 (when (_del @) 149 (touch Top) 150 (cond 151 (*Solo (zap (cadr R))) 152 (*Zap (push @ (cadr R))) ) 153 (set (cdr R)) ) ) ) ) ) 154 155 156 # Delayed deletion 157 (de zap_ () 158 (let (F (cdr *Zap) Z (pack F "_")) 159 (cond 160 ((info Z) 161 (in Z (while (rd) (zap @))) 162 (if (info F) 163 (call 'mv F Z) 164 (call 'rm Z) ) ) 165 ((info F) (call 'mv F Z)) ) ) ) 166 167 168 # Tree node count 169 (de count (Tree) 170 (or (car (root Tree)) 0) ) 171 172 # Return first leaf 173 (de leaf (Tree) 174 (let (Node (cdr (root Tree)) X) 175 (while (val Node) 176 (setq X (cadr @) Node (car @)) ) 177 (cddr X) ) ) 178 179 # Reverse node 180 (de revNode (Node) 181 (let? Lst (val Node) 182 (let (L (car Lst) R) 183 (for X (cdr Lst) 184 (push 'R (cons (car X) L (cddr X))) 185 (setq L (cadr X)) ) 186 (cons L R) ) ) ) 187 188 # Key management 189 (de minKey (Tree Min Max) 190 (default Max T) 191 (let (Node (cdr (root Tree)) K) 192 (use (V R X) 193 (loop 194 (NIL (setq V (val Node)) K) 195 (T 196 (and 197 (setq R (rank Min (cdr V))) 198 (= Min (car R)) ) 199 Min ) 200 (if R 201 (prog 202 (and 203 (setq X (cdr (memq R V))) 204 (>= Max (caar X)) 205 (setq K (caar X)) ) 206 (setq Node (cadr R)) ) 207 (when (>= Max (caadr V)) 208 (setq K (caadr V)) ) 209 (setq Node (car V)) ) ) ) ) ) 210 211 (de maxKey (Tree Min Max) 212 (default Max T) 213 (let (Node (cdr (root Tree)) K) 214 (use (V R X) 215 (loop 216 (NIL (setq V (revNode Node)) K) 217 (T 218 (and 219 (setq R (rank Max (cdr V) T)) 220 (= Max (car R)) ) 221 Max ) 222 (if R 223 (prog 224 (and 225 (setq X (cdr (memq R V))) 226 (>= (caar X) Min) 227 (setq K (caar X)) ) 228 (setq Node (cadr R)) ) 229 (when (>= (caadr V) Min) 230 (setq K (caadr V)) ) 231 (setq Node (car V)) ) ) ) ) ) 232 233 # Step 234 (de init (Tree Beg End) 235 (or Beg End (on End)) 236 (let (Node (cdr (root Tree)) Q) 237 (use (V R X) 238 (if (>= End Beg) 239 (loop 240 (NIL (setq V (val Node))) 241 (T 242 (and 243 (setq R (rank Beg (cdr V))) 244 (= Beg (car R)) ) 245 (push 'Q (memq R V)) ) 246 (if R 247 (prog 248 (and 249 (setq X (cdr (memq R V))) 250 (>= End (caar X)) 251 (push 'Q X) ) 252 (setq Node (cadr R)) ) 253 (and 254 (cdr V) 255 (>= End (caadr V)) 256 (push 'Q (cdr V)) ) 257 (setq Node (car V)) ) ) 258 (loop 259 (NIL (setq V (revNode Node))) 260 (T 261 (and 262 (setq R (rank Beg (cdr V) T)) 263 (= Beg (car R)) ) 264 (push 'Q (memq R V)) ) 265 (if R 266 (prog 267 (and 268 (setq X (cdr (memq R V))) 269 (>= (caar X) End) 270 (push 'Q X) ) 271 (setq Node (cadr R)) ) 272 (and 273 (cdr V) 274 (>= (caadr V) End) 275 (push 'Q (cdr V)) ) 276 (setq Node (car V)) ) ) ) ) 277 (cons (cons (cons Beg End) Q)) ) ) 278 279 (de step (Q Flg) 280 (use (L F X) 281 (catch NIL 282 (loop 283 (until (cdar Q) 284 (or (cdr Q) (throw)) 285 (set Q (cadr Q)) 286 (con Q (cddr Q)) ) 287 (setq 288 L (car Q) 289 F (>= (cdar L) (caar L)) 290 X (pop (cdr L)) ) 291 (or (cadr L) (con L (cddr L))) 292 (if ((if F > <) (car X) (cdar L)) 293 (con (car Q)) 294 (for (V (cadr X) ((if F val revNode) V) (car @)) 295 (con L (cons (cdr @) (cdr L))) 296 (wipe V) ) 297 (unless (and Flg (flg? (fin (car X)))) 298 (throw NIL 299 (or (cddr X) (fin (car X))) ) ) ) ) ) ) ) 300 301 (====) 302 303 # Scan tree nodes 304 (de scan ("Tree" "Fun" "Beg" "End" "Flg") 305 (default "Fun" println) 306 (or "Beg" "End" (on "End")) 307 ((if (>= "End" "Beg") _scan _nacs) 308 (cdr (root "Tree")) ) ) 309 310 (de _scan ("Node") 311 (let? "V" (val "Node") 312 (for "X" 313 (if (rank "Beg" (cdr "V")) 314 (let "R" @ 315 (if (= "Beg" (car "R")) 316 (memq "R" (cdr "V")) 317 (_scan (cadr "R")) 318 (cdr (memq "R" (cdr "V"))) ) ) 319 (_scan (car "V")) 320 (cdr "V") ) 321 (T (> (car "X") "End")) 322 (unless (and "Flg" (flg? (fin (car "X")))) 323 ("Fun" 324 (car "X") 325 (or (cddr "X") (fin (car "X"))) ) ) 326 (_scan (cadr "X")) ) 327 (wipe "Node") ) ) 328 329 (de _nacs ("Node") 330 (let? "V" (revNode "Node") 331 (for "X" 332 (if (rank "Beg" (cdr "V") T) 333 (let "R" @ 334 (if (= "Beg" (car "R")) 335 (memq "R" (cdr "V")) 336 (_nacs (cadr "R")) 337 (cdr (memq "R" (cdr "V"))) ) ) 338 (_nacs (car "V")) 339 (cdr "V") ) 340 (T (> "End" (car "X"))) 341 (unless (and "Flg" (flg? (fin (car "X")))) 342 ("Fun" 343 (car "X") 344 (or (cddr "X") (fin (car "X"))) ) ) 345 (_nacs (cadr "X")) ) 346 (wipe "Node") ) ) 347 348 (====) 349 350 # Iterate tree values 351 (de iter ("Tree" "Fun" "Beg" "End" "Flg") 352 (default "Fun" println) 353 (or "Beg" "End" (on "End")) 354 ((if (>= "End" "Beg") _iter _reti) 355 (cdr (root "Tree")) ) ) 356 357 (de _iter ("Node") 358 (let? "V" (val "Node") 359 (for "X" 360 (if (rank "Beg" (cdr "V")) 361 (let "R" @ 362 (if (= "Beg" (car "R")) 363 (memq "R" (cdr "V")) 364 (_iter (cadr "R")) 365 (cdr (memq "R" (cdr "V"))) ) ) 366 (_iter (car "V")) 367 (cdr "V") ) 368 (T (> (car "X") "End")) 369 (unless (and "Flg" (flg? (fin (car "X")))) 370 ("Fun" (or (cddr "X") (fin (car "X")))) ) 371 (_iter (cadr "X")) ) 372 (wipe "Node") ) ) 373 374 (de _reti ("Node") 375 (let? "V" (revNode "Node") 376 (for "X" 377 (if (rank "Beg" (cdr "V") T) 378 (let "R" @ 379 (if (= "Beg" (car "R")) 380 (memq "R" (cdr "V")) 381 (_reti (cadr "R")) 382 (cdr (memq "R" (cdr "V"))) ) ) 383 (_reti (car "V")) 384 (cdr "V") ) 385 (T (> "End" (car "X"))) 386 (unless (and "Flg" (flg? (fin (car "X")))) 387 ("Fun" (or (cddr "X") (fin (car "X")))) ) 388 (_reti (cadr "X")) ) 389 (wipe "Node") ) ) 390 391 (====) 392 393 (de prune (Done) 394 (for Node (idx '*Prune) 395 (recur (Node) 396 (let? V (val (lieu Node)) 397 (if (nor (car V) (find cadr (cdr V))) 398 (wipe Node) 399 (recurse (car V)) 400 (for X (cdr V) 401 (recurse (cadr X)) 402 (wipe (lieu (cddr X))) ) ) ) ) ) 403 (setq *Prune (not Done)) ) 404 405 # Delete Tree 406 (de zapTree (Node) 407 (let? V (val Node) 408 (zapTree (car V)) 409 (for L (cdr V) 410 (zapTree (cadr L)) ) 411 (zap Node) ) ) 412 413 # Check tree structure 414 (de chkTree ("Node" "Fun") 415 (let ("N" 0 "X") 416 (when "Node" 417 (recur ("Node") 418 (let "V" (val "Node") 419 (let "L" (car "V") 420 (for "Y" (cdr "V") 421 (when "L" 422 (unless (ext? "L") 423 (quit "Bad node link" "Node") ) 424 (recurse "L") ) 425 (when (>= "X" (car "Y")) 426 (quit "Bad sequence" "Node") ) 427 (setq "X" (car "Y")) 428 (inc '"N") 429 (and 430 "Fun" 431 (not ("Fun" (car "Y") (cddr "Y"))) 432 (quit "Check fail" "Node") ) 433 (setq "L" (cadr "Y")) ) 434 (and "L" (recurse "L")) ) ) 435 (wipe "Node") ) ) 436 "N" ) ) 437 438 # vi:et:ts=3:sw=3