home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / examples / avlseq.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-10-23  |  24.7 KB  |  592 lines
  1. ; AVL-Bäume, implementiert in COMMON LISP, als Sequences
  2. ; Bruno Haible, 22.09.1988
  3. ; CLISP-Version 29.12.1988
  4. ; Version mit vielen Deklarationen,
  5. ;             Buchführung über die Länge jedes Teilbaums,
  6. ;             Definition eines Sequence-Untertyps AVL-TREE.
  7.  
  8. ; Ein AVL-Baum ist ein Binärbaum, bei dem in jedem Knoten ein Datum
  9. ; (value) sitzt. Der Baum ist stets balanciert, in der Weise, daß die Höhen
  10. ; zweier linker und rechter Teilbäume sich um höchstens 1 unterscheiden.
  11. ; Die Ordnungsrelation auf den values ist durch eine Vergleichsfunktion comp
  12. ; festgelegt, die feststellt, wann x<y ist (eine fest gewählte
  13. ; Ordnungsrelation). Bei (not (or (comp x y) (comp y x))) gelten x und y als
  14. ; gleich.
  15. ; Der Baum kann wie eine Sequence von links nach rechts oder von rechts nach
  16. ; links durchlaufen werden, alle Sequence-Funktionen operieren somit auch auf
  17. ; AVL-Bäumen.
  18.  
  19. (provide 'avlseq)
  20. (in-package 'avl)
  21. (shadow '(length member delete copy merge))
  22. (export '(treep member insert delete do-avl avl-to-seq seq-to-avl copy merge))
  23. (require 'sequences)
  24. (import '(seq::avl-tree seq::seq))
  25.  
  26. ; Datenstruktur eines Baumes: leerer Baum=nil, sonst Knoten ("node")
  27.  
  28. (deftype tree ()
  29.   '(or null node))
  30.  
  31. (defstruct node
  32.   (level 0 :type fixnum)
  33.   (left nil :type tree)
  34.   (right nil :type tree)
  35.   (value nil)
  36.   (length 1 :type (integer 1 *))
  37. )
  38. (proclaim '(inline node-level node-left node-right node-value node-length))
  39.  
  40. ; (level tree) ergibt die Höhe eines Baumes
  41. (proclaim '(function level (node) fixnum))
  42. (proclaim '(inline level))
  43. (defun level (tr)
  44.   (if tr (locally (declare (type node tr)) (node-level tr)) 0)
  45. )
  46.  
  47. ; (length tree) ergibt die Breite (= Anzahl der Nodes) eines Baumes
  48. (proclaim '(function length (tree) integer))
  49. (proclaim '(inline length))
  50. (defun length (tr)
  51.   (if tr (locally (declare (type node tr)) (node-length tr)) 0)
  52. )
  53.  
  54. ; (recalc-length node) berechnet (node-length node) neu
  55. (proclaim '(function recalc-length (node) integer))
  56. (proclaim '(inline recalc-length))
  57. (defun recalc-length (tr)
  58.   (declare (type node tr))
  59.   (setf (node-length tr) (+ (length (node-left tr)) 1 (length (node-right tr))))
  60. )
  61.  
  62. ; (deftype avl-tree (comp) ...) funktioniert nicht.
  63.  
  64. ; (treep tr comp) stellt fest, ob ein AVL-Baum vorliegt.
  65. (proclaim '(function treep (tree function &optional t) symbol))
  66. (defun treep (tr comp &optional (el-type t))
  67.   (or (null tr)
  68.       (and
  69.         (typep tr 'node)
  70.         (locally (declare (type node tr))
  71.           (and
  72.             (typep (node-value tr) el-type)
  73.             (let ((trl (node-left tr))
  74.                   (trr (node-right tr)))
  75.               (declare (type tree trl trr) (type node tr))
  76.               (and (= (level tr)
  77.                       (1+ (the fixnum
  78.                             (max (the fixnum (level trl))
  79.                                  (the fixnum (level trr))
  80.                    )  )   ) )
  81.                    (<= (the fixnum
  82.                          (abs (the fixnum
  83.                                 (- (the fixnum (level trl))
  84.                                    (the fixnum (level trr))
  85.                        ) )    ) )
  86.                        1
  87.                    )
  88.                    (or (null trl)
  89.                        (locally (declare (type node tr trl))
  90.                          (funcall comp (node-value trl) (node-value tr))
  91.                    )   )
  92.                    (or (null trr)
  93.                        (locally (declare (type node tr trr))
  94.                          (funcall comp (node-value tr) (node-value trr))
  95.                    )   )
  96.                    (treep trl comp el-type)
  97.                    (treep trr comp el-type)
  98. ) )   ) ) ) ) )
  99.  
  100.  
  101. ; (ganzrechts tr) liefert das "größte" Element eines nichtleeren Baumes
  102. (proclaim '(function ganzrechts (node) node))
  103. (defun ganzrechts (tr)
  104.   (declare (type node tr))
  105.   (if (node-right tr) (ganzrechts (node-right tr)) (node-value tr)))
  106.  
  107. (proclaim '(function ganzlinks (node) node))
  108. ; (ganzlinks tr) liefert das "kleinste" Element eines nichtleeren Baumes
  109. (defun ganzlinks (tr)
  110.   (declare (type node tr))
  111.   (if (node-left tr) (ganzlinks (node-left tr)) (node-value tr)))
  112.  
  113.  
  114. ; (member item tree comp) testet, ob item ein Element des Baumes tree ist.
  115. ; Durch Angabe eines Gleichheitstests eq-test kann geprüft werden, ob die
  116. ; beiden Werte (item und der Wert im Baum) in einem engeren Sinne gleich sind.
  117. ; Trick: Falls man im Baum keine values mit dem Wert NIL abspeichert, kann man
  118. ; sich durch eq-test = #'(lambda (it val) (and ("=" it val) val)) den im Baum
  119. ; stehenden Wert val zurückgeben lassen.
  120. (proclaim '(function member (t tree function &optional function) t))
  121. (defun member (item tr comp &optional (eq-test #'equal))
  122.   (if (null tr) nil
  123.     (locally (declare (type node tr))
  124.       (cond ((funcall eq-test item (node-value tr)))
  125.             ((funcall comp item (node-value tr))
  126.              (member item (node-left tr) comp eq-test))
  127.             ((funcall comp (node-value tr) item)
  128.              (member item (node-right tr) comp eq-test))
  129. ) ) ) ) ; sonst NIL
  130.  
  131.  
  132. ; (balance tree) balanciert einen nichtleeren Baum tree aus. Voraussetzung
  133. ; ist, daß höchstens ein Element den Baum aus der Balance gebracht hat.
  134. ; tree selbst wird verändert!
  135. (proclaim '(function balance (node) node))
  136. (defun balance (b)
  137.   (let ((l (level (node-left b)))
  138.         (r (level (node-right b))))
  139.     (declare (fixnum l r) (type node b c d))
  140.     (setf (node-level b) (the fixnum (1+ (the fixnum (max l r)))))
  141.     (case (the fixnum (- r l))
  142.       ((-2)(let ((c (node-left b))
  143.                  (d nil))
  144.              (cond ((< (the fixnum (level (node-left c)))
  145.                        (the fixnum (level (node-right c))))
  146.                     (setq d (node-right c))
  147.                     (setf (node-right c) (node-left d))
  148.                     (setf (node-left b) (node-right d))
  149.                     (setf (node-left d) c)
  150.                     (setf (node-right d) b)
  151.                     (setf (node-level b) (node-level d))
  152.                     (setf (node-level d) (node-level c))
  153.                     (setf (node-level c) (node-level b))
  154.                     (recalc-length b)
  155.                     (recalc-length c)
  156.                     (recalc-length d)
  157.                     d
  158.                     )
  159.                     (t
  160.                       (setf (node-left b) (node-right c))
  161.                       (setf (node-right c) b)
  162.                       (setf (node-level b)
  163.                         (the fixnum (1+ (the fixnum (level (node-left b))))))
  164.                       (setf (node-level c)
  165.                         (the fixnum (1+ (the fixnum (node-level b)))))
  166.                       (recalc-length b)
  167.                       (recalc-length c)
  168.                       c
  169.       )    ) )     )
  170.       ((2) (let ((c (node-right b))
  171.                  (d nil))
  172.              (cond ((< (the fixnum (level (node-right c)))
  173.                        (the fixnum (level (node-left c))))
  174.                     (setq d (node-left c))
  175.                     (setf (node-left c) (node-right d))
  176.                     (setf (node-right b) (node-left d))
  177.                     (setf (node-right d) c)
  178.                     (setf (node-left d) b)
  179.                     (setf (node-level b) (node-level d))
  180.                     (setf (node-level d) (node-level c))
  181.                     (setf (node-level c) (node-level b))
  182.                     (recalc-length b)
  183.                     (recalc-length c)
  184.                     (recalc-length d)
  185.                     d
  186.                    )
  187.                    (t
  188.                       (setf (node-right b) (node-left c))
  189.                       (setf (node-left c) b)
  190.                       (setf (node-level b)
  191.                         (the fixnum (1+ (the fixnum (level (node-right b))))))
  192.                       (setf (node-level c)
  193.                         (the fixnum (1+ (the fixnum (node-level b)))))
  194.                       (recalc-length b)
  195.                       (recalc-length c)
  196.                       c
  197.       )    ) )     )
  198.       ((-1 0 1) (recalc-length b) b)
  199. ) ) )
  200.  
  201.  
  202. ; (insert item tree comp) fügt item zusätzlich in tree ein.
  203. ; Das Ergebnis ist ebenfalls ein AVL-Baum. Falls item bereits vorkommt,
  204. ; wird item an dessen Stelle eingesetzt.
  205. ; Durch Angabe eines Gleichheitstest eq-test kann angegeben werden, was
  206. ; für Elemente als gleich zu gelten haben. (Das muß diejenigen Elemente
  207. ; umfassen, die nicht vergleichbar sind: stets x<y oder y<x oder (eq-test x y).)
  208. ; tree selbst wird verändert!
  209. (proclaim '(function insert (t tree function &optional function) node))
  210. (defun insert (item tr comp &optional (eq-test #'equal))
  211.   (if (null tr) (make-node :level 1 :value item)
  212.     (locally (declare (type node tr))
  213.       (cond
  214.         ((funcall eq-test item (node-value tr))
  215.          (setf (node-value tr) item)
  216.          tr)
  217.         (t
  218.            (cond
  219.              ((funcall comp item (node-value tr))
  220.               (setf (node-left tr) (insert item (node-left tr) comp eq-test)))
  221.              ((funcall comp (node-value tr) item)
  222.               (setf (node-right tr) (insert item (node-right tr) comp eq-test)))
  223.              (t (error "Element paßt nicht in AVL-Baum-Ordnung!"))
  224.            )
  225.            (balance tr)
  226. ) ) ) ) )
  227.  
  228.  
  229. ; (delete item tree comp) entfernt item aus tree und liefert das
  230. ; verkleinerte tree zurück.
  231. (proclaim '(function delete (t tree function &optional function) tree))
  232. (defun delete (item tr comp &optional (eq-test #'equal))
  233.   (if (null tr) tr
  234.     (locally (declare (type node tr))
  235.       (cond
  236.         ((funcall eq-test item (node-value tr))
  237.          (let ((r (node-right tr)))
  238.            (declare (type node tr))
  239.            (if (null r)
  240.                (node-left tr)
  241.                (multiple-value-bind (rest del) (delete-ganzlinks r)
  242.                     (declare (type node del))
  243.                     (setf (node-left del) (node-left tr))
  244.                     (setf (node-right del) rest)
  245.                     (balance del)
  246.         )) )   )
  247.         ((funcall comp item (node-value tr))
  248.          (setf (node-left tr) (delete item (node-left tr) comp eq-test))
  249.          (balance tr))
  250.         ((funcall comp (node-value tr) item)
  251.          (setf (node-right tr) (delete item (node-right tr) comp eq-test))
  252.          (balance tr))
  253.         (t (error "Element paßt nicht in AVL-Baum-Ordnung!"))
  254. ) ) ) )
  255.  
  256. ; (delete-ganzlinks tree) entfernt aus dem nichtleeren tree das "kleinste"
  257. ; Element und gibt den Restbaum zurück. Das entfernte Element erscheint als
  258. ; zweiter Wert (als Knoten, zur Vermeidung von Garbage Produktion).
  259. (proclaim '(function delete-ganzlinks (node) tree))
  260. (defun delete-ganzlinks (tr)
  261.   (declare (type node tr))
  262.   (if (null (node-left tr))
  263.       (values (node-right tr) tr)
  264.       (multiple-value-bind (tl el) (delete-ganzlinks (node-left tr))
  265.         (setf (node-left tr) tl)
  266.         (decf (node-length tr))
  267.         (values tr el)
  268. ) )   )
  269.  
  270.  
  271. ; (do-avl (var treeform [resultform]) {declaration}* {tag|statement}* )
  272. ; ist ein Macro wie dolist: Für alle var aus dem AVL-Baum, der bei
  273. ; treeform herauskommt, wird der Rest ausgeführt.
  274. (defmacro do-avl (varform &rest body)
  275.   `(progn
  276.      (traverse ,(second varform)
  277.                #'(lambda (,(first varform)) ,@body)
  278.      )
  279.      ,(cond ((third varform) `(let ((,(first varform) nil)) ,(third varform))))
  280. )  )
  281.  
  282. (defmacro do-avl-1 ((var treeform &optional resultform) &body body)
  283.   (let ((abstieg (gensym)) ; Labels
  284.         (aufstieg (gensym))
  285.         (ende (gensym))
  286.         (stack (gensym)) ; (cons ,top ,stack) ist ein "Stack"
  287.         (top (gensym)))
  288.     `(prog ((,stack nil) (,top ,treeform))
  289.         ,abstieg
  290.         (if (null ,top) (go ,aufstieg))
  291.         (push ,top ,stack) (setq ,top (node-left (the node ,top)))
  292.         (go ,abstieg)
  293.         ,aufstieg
  294.         (if (null ,stack) (go ,ende))
  295.         (if (eq ,top (node-right (the node (setq ,top (pop ,stack)))))
  296.             (go ,aufstieg))
  297.         (let ((,var (node-value (the node ,top)))) ,@body)
  298.         (push ,top ,stack) (setq ,top (node-right (the node ,top)))
  299.         (go ,aufstieg)
  300.         ,ende
  301.         (let ((,var nil)) (return ,resultform))
  302.      )
  303. ) )
  304.  
  305. (proclaim '(function traverse (tree (function (t) t)) null))
  306. (defun traverse (tr fun)
  307.   (if (null tr) nil
  308.       (locally (declare (type node tr))
  309.         (traverse (node-left tr) fun)
  310.         (funcall fun (node-value tr))
  311.         (traverse (node-right tr) fun)
  312. ) )   )
  313.  
  314.  
  315. ; (avl-to-seq tree) ergibt eine sortierte Liste aller values des Baumes tree.
  316. ; (avl-to-seq tree seq-type) ergibt eine sortierte Sequence des angegebenen
  317. ; Typs aus allen Werten des Baumes tree.
  318. (proclaim '(function avl-to-seq (tree &optional t) sequence))
  319. (defun avl-to-seq (tr &optional (result-type 'list))
  320.   (if (null tr)
  321.       (make-sequence result-type 0)
  322.       (locally (declare (type node tr))
  323.         (concatenate result-type
  324.           (avl-to-seq (node-left tr))
  325.           (make-sequence result-type 1 :initial-element (node-value tr))
  326.           (avl-to-seq (node-right tr))
  327. ) )   ) )
  328.  
  329. ; (seq-to-avl l comp) ergibt aus einer (unsortierten) sequence l von Elementen
  330. ; einen AVL-Baum.
  331. (proclaim '(function seq-to-avl (sequence function &optional function) tree))
  332. (defun seq-to-avl (l comp &optional (eq-test #'equal))
  333.   (reduce #'(lambda (tr item) (insert item tr comp eq-test))
  334.           l :initial-value nil
  335. ) )
  336.  
  337.  
  338. ; (copy tree) ergibt eine Kopie des AVL-Baumes tree.
  339. ; Nur die Baumstruktur wird kopiert, die Werte werden übernommen.
  340. ; insert und delete sind jetzt auf dem Original und auf der Kopie unabhängig
  341. ; voneinander durchführbar.
  342. (proclaim '(function copy (tree) tree))
  343. (defun copy (tr)
  344.   (if (null tr) nil
  345.       (locally (declare (type node tr))
  346.         (make-node :level (node-level tr)
  347.                    :left (copy (node-left tr))
  348.                    :right (copy (node-right tr))
  349.                    :value (node-value tr)
  350. ) )   ) )
  351.  
  352.  
  353. ; (merge tree1 tree2 comp) ergibt einen neuen AVL-Baum, der aus den Elementen
  354. ; der Bäume tree1 und tree2 besteht.
  355. ; Durch Angabe eines Gleichheitstests kann spezifiert werden, was für
  356. ; Elemente (weil gleich) nicht doppelt in den neuen AVL-Baum übernommen zu
  357. ; werden brauchen. (Je zwei nicht vergleichbare Elemente müssen in diesem
  358. ; Sinne gleich sein.)
  359. (proclaim '(function merge (tree tree function &optional function) tree))
  360. (defun merge (tr1 tr2 comp &optional (eq-test #'equal))
  361.   (if (< (the fixnum (level tr1)) (the fixnum (level tr2))) (rotatef tr1 tr2))
  362.   ; jetzt ist tr1 der größere der Bäume
  363.   (let ((tr (copy tr1)))
  364.     (do-avl (x tr2 tr) (setq tr (insert x tr comp eq-test)))
  365. ) )
  366.  
  367. ; AVL-Bäume als Sequences:
  368.  
  369. ; Ausgabefunktion:
  370. (defun print-avl-tree (seq stream depth)
  371.   (declare (ignore depth))
  372.   (format stream "~@!#S(~;~S ~:_~S ~:_~:S ~:_~S ~:_~S~;)~."
  373.     'avl-tree ':contents (seq::coerce seq 'list) ':length (seq::length seq)
  374. ) )
  375.  
  376. ; als solcher erkennbarer AVL-Baum:
  377. (defstruct (avl-tree (:constructor box-tree (tree))
  378.                      (:print-function print-avl-tree))
  379.   (tree nil)
  380. )
  381. (proclaim '(inline box-tree avl-tree-tree))
  382.  
  383. ; neue Konstruktorfunktion (für den Reader):
  384. (defun new-avl-tree-constructor (&key contents &allow-other-keys)
  385.   (seq::coerce contents 'avl-tree)
  386. )
  387. (setf (svref (get 'avl-tree 'SYSTEM::DEFSTRUCT-DESCRIPTION) 3)
  388.       'new-avl-tree-constructor
  389. )
  390.  
  391. (defmacro unbox (seq) `(avl-tree-tree ,seq))
  392.  
  393. ; (make-tree size) kreiert einen leeren AVL-Baum mit size Knoten.
  394. (defun make-tree (size)
  395.   (if (zerop size)
  396.     nil
  397.     (let ((left (make-tree (floor (1- size) 2)))
  398.           (right (make-tree (ceiling (1- size) 2))))
  399.       (make-node :level (1+ (level right)) :left left :right right :length size)
  400. ) ) )
  401.  
  402. (defun make-avl-tree (size)
  403.   (box-tree (make-tree size))
  404. )
  405.  
  406. ; AVL-Baum als Sequence vom Typ AVL-TREE :
  407. ; Pointer ist ein Vektor mit Fill-Pointer.
  408. ; Fill-Pointer=0 -> am Ende angelangt.
  409. ; Fill-Pointer=2*k+1 -> Der Vektor enthält den Pfad zum nächsten NODE,
  410. ;   abwechselnd ein NODE und ein Richtungsindikator (LEFT, RIGHT).
  411. (seq::define-sequence AVL-TREE
  412.   :init        #'(lambda ()
  413.                    (let* ((tr (unbox seq))
  414.                           (l (level tr))
  415.                           (pointer (make-array (* 2 l) :fill-pointer 0)))
  416.                      (if tr
  417.                        (locally (declare (type node tr))
  418.                          (loop
  419.                            (vector-push tr pointer)
  420.                            (if (null (node-left tr)) (return))
  421.                            (vector-push 'LEFT pointer)
  422.                            (setq tr (node-left tr))
  423.                      ) ) )
  424.                      pointer
  425.                  ) )
  426.   :upd         #'(lambda (pointer)
  427.                    (if (zerop (fill-pointer pointer))
  428.                      (error "Am rechten Ende eines ~S angelangt." 'avl-tree)
  429.                      (let ((tr (aref pointer (1- (fill-pointer pointer)))))
  430.                        (declare (type node tr))
  431.                        (if (node-right tr)
  432.                          (progn
  433.                            (setq tr (node-right tr))
  434.                            (vector-push 'RIGHT pointer)
  435.                            (loop
  436.                              (vector-push tr pointer)
  437.                              (if (null (node-left tr)) (return))
  438.                              (setq tr (node-left tr))
  439.                              (vector-push 'LEFT pointer)
  440.                          ) )
  441.                          (loop
  442.                            (vector-pop pointer)
  443.                            (if (zerop (fill-pointer pointer)) (return))
  444.                            (if (eq (vector-pop pointer) 'LEFT) (return))
  445.                        ) )
  446.                        pointer
  447.                  ) ) )
  448.   :endtest     #'(lambda (pointer) (zerop (fill-pointer pointer)))
  449.   :fe-init     #'(lambda ()
  450.                    (let* ((tr (unbox seq))
  451.                           (l (level tr))
  452.                           (pointer (make-array (* 2 l) :fill-pointer 0)))
  453.                      (if tr
  454.                        (locally (declare (type node tr))
  455.                          (loop
  456.                            (vector-push tr pointer)
  457.                            (if (null (node-right tr)) (return))
  458.                            (vector-push 'RIGHT pointer)
  459.                            (setq tr (node-right tr))
  460.                      ) ) )
  461.                      pointer
  462.                  ) )
  463.   :fe-upd      #'(lambda (pointer)
  464.                    (if (zerop (fill-pointer pointer))
  465.                      (error "Am linken Ende eines ~S angelangt." 'avl-tree)
  466.                      (let ((tr (aref pointer (1- (fill-pointer pointer)))))
  467.                        (declare (type node tr))
  468.                        (if (node-left tr)
  469.                          (progn
  470.                            (setq tr (node-left tr))
  471.                            (vector-push 'LEFT pointer)
  472.                            (loop
  473.                              (vector-push tr pointer)
  474.                              (if (null (node-right tr)) (return))
  475.                              (setq tr (node-right tr))
  476.                              (vector-push 'RIGHT pointer)
  477.                          ) )
  478.                          (loop
  479.                            (vector-pop pointer)
  480.                            (if (zerop (fill-pointer pointer)) (return))
  481.                            (if (eq (vector-pop pointer) 'RIGHT) (return))
  482.                        ) )
  483.                        pointer
  484.                  ) ) )
  485.   :fe-endtest  #'(lambda (pointer) (zerop (fill-pointer pointer)))
  486.   :access      #'(lambda (pointer)
  487.                    (if (zerop (fill-pointer pointer))
  488.                      (error "Am Ende eines ~S angelangt." 'avl-tree)
  489.                      (node-value (aref pointer (1- (fill-pointer pointer))))
  490.                  ) )
  491.   :access-set  #'(lambda (pointer value)
  492.                    (if (zerop (fill-pointer pointer))
  493.                      (error "Am Ende eines ~S angelangt." 'avl-tree)
  494.                      (setf (node-value (aref pointer (1- (fill-pointer pointer))))
  495.                            value
  496.                  ) ) )
  497.   :copy        #'(lambda (pointer)
  498.                    (make-array (array-dimensions pointer)
  499.                                :initial-contents pointer
  500.                                :fill-pointer (fill-pointer pointer)
  501.                  ) )
  502.   :length      #'(lambda ()
  503.                    (let ((tr (unbox seq)))
  504.                      (if tr (node-length tr) 0)
  505.                  ) )
  506.   :make        #'make-avl-tree
  507.   :elt         #'(lambda (index)
  508.                    (let ((tr (unbox seq)))
  509.                      (if (and tr (< index (node-length tr)))
  510.                        (locally (declare (type node tr))
  511.                          (loop ; Hier ist 0 <= index < (node-length tr)
  512.                            (let ((lleft (length (node-left tr))))
  513.                              (cond ((< index lleft)
  514.                                     (setq tr (node-left tr))
  515.                                    )
  516.                                    ((= index lleft) (return (node-value tr)))
  517.                                    (t ; (> index lleft)
  518.                                     (setq index (- index (+ lleft 1)))
  519.                                     (setq tr (node-right tr))
  520.                        ) ) ) )     )
  521.                        (error "Unzulässiger Index: ~S" index)
  522.                  ) ) )
  523.   :set-elt     #'(lambda (index value)
  524.                    (let ((tr (unbox seq)))
  525.                      (if (and tr (< index (node-length tr)))
  526.                        (locally (declare (type node tr))
  527.                          (loop ; Hier ist 0 <= index < (node-length tr)
  528.                            (let ((lleft (length (node-left tr))))
  529.                              (cond ((< index lleft)
  530.                                     (setq tr (node-left tr))
  531.                                    )
  532.                                    ((= index lleft)
  533.                                     (return (setf (node-value tr) value))
  534.                                    )
  535.                                    (t ; (> index lleft)
  536.                                     (setq index (- index (+ lleft 1)))
  537.                                     (setq tr (node-right tr))
  538.                        ) ) ) )     )
  539.                        (error "Unzulässiger Index: ~S" index)
  540.                  ) ) )
  541.   :init-start  #'(lambda (index)
  542.                    (let* ((tr (unbox seq))
  543.                           (l (level tr))
  544.                           (pointer (make-array (* 2 l) :fill-pointer 0)))
  545.                      (if (<= 0 index (length tr))
  546.                        (if (and tr (< index (node-length tr)))
  547.                          (locally (declare (type node tr))
  548.                            (loop ; Hier ist 0 <= index < (node-length tr)
  549.                              (vector-push tr pointer)
  550.                              (let ((lleft (length (node-left tr))))
  551.                                (cond ((< index lleft)
  552.                                       (vector-push 'LEFT pointer)
  553.                                       (setq tr (node-left tr))
  554.                                      )
  555.                                      ((= index lleft) (return))
  556.                                      (t ; (> index lleft)
  557.                                       (vector-push 'RIGHT pointer)
  558.                                       (setq index (- index (+ lleft 1)))
  559.                                       (setq tr (node-right tr))
  560.                        ) ) ) ) )     )
  561.                        (error "Unzulässiger Index: ~S" index)
  562.                      )
  563.                      pointer
  564.                  ) )
  565.   :fe-init-end   #'(lambda (index)
  566.                    (let* ((tr (unbox seq))
  567.                           (l (level tr))
  568.                           (pointer (make-array (* 2 l) :fill-pointer 0)))
  569.                      (if (<= 0 index (length tr))
  570.                        (if (and tr (plusp index))
  571.                          (locally (declare (type node tr))
  572.                            (loop ; Hier ist 0 < index <= (node-length tr)
  573.                              (vector-push tr pointer)
  574.                              (let ((lleft (length (node-left tr))))
  575.                                (cond ((<= index lleft)
  576.                                       (vector-push 'LEFT pointer)
  577.                                       (setq tr (node-left tr))
  578.                                      )
  579.                                      ((plusp (setq index (- index (1+ lleft))))
  580.                                       (vector-push 'RIGHT pointer)
  581.                                       (setq tr (node-right tr))
  582.                                      )
  583.                                      (t ; (= index (1+ lleft))
  584.                                       (return)
  585.                        ) ) ) ) )     )
  586.                        (error "Unzulässiger Index: ~S" index)
  587.                      )
  588.                      pointer
  589.                  ) )
  590. )
  591.  
  592.