home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / clisp / avl.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-10-23  |  13.1 KB  |  333 lines
  1. ; AVL-Bäume, implementiert in COMMON LISP
  2. ; Version für den Compiler, mit vielen Deklarationen
  3.  
  4. ; Ein AVL-Baum ist ein Binärbaum, bei dem in jedem Knoten ein Datum
  5. ; (value) sitzt. Der Baum ist stets balanciert, in der Weise, daß die Höhen
  6. ; zweier linker und rechter Teilbäume sich um höchstens 1 unterscheiden.
  7. ; Die Ordnungsrelation auf den values ist durch eine Vergleichsfunktion comp
  8. ; festgelegt, die feststellt, wann x<y ist (eine fest gewählte
  9. ; Ordnungsrelation). Bei (not (or (comp x y) (comp y x))) gelten x und y als
  10. ; gleich.
  11.  
  12. (provide 'avl)
  13. (in-package 'avl)
  14. (shadow '(member delete copy merge))
  15. (export '(treep member insert delete do-avl avl-to-seq seq-to-avl copy merge))
  16.  
  17. (eval-when (compile) (proclaim '(optimize (speed 3))))
  18.  
  19. ; Datenstruktur eines Baumes: leerer Baum=nil, sonst Knoten ("node")
  20.  
  21. (deftype tree ()
  22.   '(or null node))
  23.  
  24. (defstruct node
  25.   (level 0 :type fixnum)
  26.   (left nil :type tree)
  27.   (right nil :type tree)
  28.   (value nil)
  29. )
  30. (proclaim '(inline node-level node-left node-right node-value))
  31.  
  32. ; (level tree) ergibt die Höhe eines Baumes
  33. (proclaim '(function level (node) fixnum))
  34. (proclaim '(inline level))
  35. (defun level (tr)
  36.   (if tr (locally (declare (type node tr)) (node-level tr)) 0)
  37. )
  38.  
  39. ; (deftype avl-tree (comp) ...) funktioniert nicht.
  40.  
  41. ; (treep tr comp) stellt fest, ob ein AVL-Baum vorliegt.
  42. (proclaim '(function treep (tree function &optional t) symbol))
  43. (defun treep (tr comp &optional (el-type t))
  44.   (or (null tr)
  45.       (and
  46.         (typep tr 'node)
  47.         (locally (declare (type node tr))
  48.           (and
  49.             (typep (node-value tr) el-type)
  50.             (let ((trl (node-left tr))
  51.                   (trr (node-right tr)))
  52.               (declare (type tree trl trr) (type node tr))
  53.               (and (= (level tr)
  54.                       (1+ (the fixnum
  55.                             (max (the fixnum (level trl))
  56.                                  (the fixnum (level trr))
  57.                    )  )   ) )
  58.                    (<= (the fixnum
  59.                          (abs (the fixnum
  60.                                 (- (the fixnum (level trl))
  61.                                    (the fixnum (level trr))
  62.                        ) )    ) )
  63.                        1
  64.                    )
  65.                    (or (null trl)
  66.                        (locally (declare (type node tr trl))
  67.                          (funcall comp (node-value trl) (node-value tr))
  68.                    )   )
  69.                    (or (null trr)
  70.                        (locally (declare (type node tr trr))
  71.                          (funcall comp (node-value tr) (node-value trr))
  72.                    )   )
  73.                    (treep trl comp el-type)
  74.                    (treep trr comp el-type)
  75. ) )   ) ) ) ) )
  76.  
  77.  
  78. ; (ganzrechts tr) liefert das "größte" Element eines nichtleeren Baumes
  79. (proclaim '(function ganzrechts (node) node))
  80. (defun ganzrechts (tr)
  81.   (declare (type node tr))
  82.   (if (node-right tr) (ganzrechts (node-right tr)) (node-value tr)))
  83.  
  84. (proclaim '(function ganzlinks (node) node))
  85. ; (ganzlinks tr) liefert das "kleinste" Element eines nichtleeren Baumes
  86. (defun ganzlinks (tr)
  87.   (declare (type node tr))
  88.   (if (node-left tr) (ganzlinks (node-left tr)) (node-value tr)))
  89.  
  90.  
  91. ; (member item tree comp) testet, ob item ein Element des Baumes tree ist.
  92. ; Durch Angabe eines Gleichheitstests eq-test kann geprüft werden, ob die
  93. ; beiden Werte (item und der Wert im Baum) in einem engeren Sinne gleich sind.
  94. ; Trick: Falls man im Baum keine values mit dem Wert NIL abspeichert, kann man
  95. ; sich durch eq-test = #'(lambda (it val) (and ("=" it val) val)) den im Baum
  96. ; stehenden Wert val zurückgeben lassen.
  97. (proclaim '(function member (t tree function &optional function) t))
  98. (defun member (item tr comp &optional (eq-test #'equal))
  99.   (if (null tr) nil
  100.     (locally (declare (type node tr))
  101.       (cond ((funcall eq-test item (node-value tr)))
  102.             ((funcall comp item (node-value tr))
  103.              (member item (node-left tr) comp eq-test))
  104.             ((funcall comp (node-value tr) item)
  105.              (member item (node-right tr) comp eq-test))
  106. ) ) ) ) ; sonst NIL
  107.  
  108.  
  109. ; (balance tree) balanciert einen nichtleeren Baum tree aus. Voraussetzung
  110. ; ist, daß höchstens ein Element den Baum aus der Balance gebracht hat.
  111. ; tree selbst wird verändert!
  112. (proclaim '(function balance (node) node))
  113. (defun balance (b)
  114.   (let ((l (level (node-left b)))
  115.         (r (level (node-right b))))
  116.     (declare (fixnum l r) (type node b c d))
  117.     (setf (node-level b) (the fixnum (1+ (the fixnum (max l r)))))
  118.     (case (the fixnum (- r l))
  119.       ((-2)(let ((c (node-left b))
  120.                  (d nil))
  121.              (cond ((< (the fixnum (level (node-left c)))
  122.                        (the fixnum (level (node-right c))))
  123.                     (setq d (node-right c))
  124.                     (setf (node-right c) (node-left d))
  125.                     (setf (node-left b) (node-right d))
  126.                     (setf (node-left d) c)
  127.                     (setf (node-right d) b)
  128.                     (setf (node-level b) (node-level d))
  129.                     (setf (node-level d) (node-level c))
  130.                     (setf (node-level c) (node-level b))
  131.                     d
  132.                     )
  133.                     (t
  134.                       (setf (node-left b) (node-right c))
  135.                       (setf (node-right c) b)
  136.                       (setf (node-level b)
  137.                         (the fixnum (1+ (the fixnum (level (node-left b))))))
  138.                       (setf (node-level c)
  139.                         (the fixnum (1+ (the fixnum (node-level b)))))
  140.                       c
  141.       )    ) )     )
  142.       ((2) (let ((c (node-right b))
  143.                  (d nil))
  144.              (cond ((< (the fixnum (level (node-right c)))
  145.                        (the fixnum (level (node-left c))))
  146.                     (setq d (node-left c))
  147.                     (setf (node-left c) (node-right d))
  148.                     (setf (node-right b) (node-left d))
  149.                     (setf (node-right d) c)
  150.                     (setf (node-left 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.                     d
  155.                    )
  156.                    (t
  157.                       (setf (node-right b) (node-left c))
  158.                       (setf (node-left c) b)
  159.                       (setf (node-level b)
  160.                         (the fixnum (1+ (the fixnum (level (node-right b))))))
  161.                       (setf (node-level c)
  162.                         (the fixnum (1+ (the fixnum (node-level b)))))
  163.                       c
  164.       )    ) )     )
  165.       ((-1 0 1) b)
  166. ) ) )
  167.  
  168.  
  169. ; (insert item tree comp) fügt item zusätzlich in tree ein.
  170. ; Das Ergebnis ist ebenfalls ein AVL-Baum. Falls item bereits vorkommt,
  171. ; wird item an dessen Stelle eingesetzt.
  172. ; Durch Angabe eines Gleichheitstest eq-test kann angegeben werden, was
  173. ; für Elemente als gleich zu gelten haben. (Das muß diejenigen Elemente
  174. ; umfassen, die nicht vergleichbar sind: stets x<y oder y<x oder (eq-test x y).)
  175. ; tree selbst wird verändert!
  176. (proclaim '(function insert (t tree function &optional function) node))
  177. (defun insert (item tr comp &optional (eq-test #'equal))
  178.   (if (null tr) (make-node :level 1 :value item)
  179.     (locally (declare (type node tr))
  180.       (cond
  181.         ((funcall eq-test item (node-value tr))
  182.          (setf (node-value tr) item)
  183.          tr)
  184.         (t
  185.            (cond
  186.              ((funcall comp item (node-value tr))
  187.               (setf (node-left tr) (insert item (node-left tr) comp eq-test)))
  188.              ((funcall comp (node-value tr) item)
  189.               (setf (node-right tr) (insert item (node-right tr) comp eq-test)))
  190.              (t (error "Element paßt nicht in AVL-Baum-Ordnung!"))
  191.            )
  192.            (balance tr)
  193. ) ) ) ) )
  194.  
  195.  
  196. ; (delete item tree comp) entfernt item aus tree und liefert das
  197. ; verkleinerte tree zurück.
  198. (proclaim '(function delete (t tree function &optional function) tree))
  199. (defun delete (item tr comp &optional (eq-test #'equal))
  200.   (if (null tr) tr
  201.     (locally (declare (type node tr))
  202.       (cond
  203.         ((funcall eq-test item (node-value tr))
  204.          (let ((r (node-right tr)))
  205.            (declare (type node tr))
  206.            (if (null r)
  207.                (node-left tr)
  208.                (multiple-value-bind (rest del) (delete-ganzlinks r)
  209.                     (declare (type node del))
  210.                     (setf (node-left del) (node-left tr))
  211.                     (setf (node-right del) rest)
  212.                     (balance del)
  213.         )) )   )
  214.         ((funcall comp item (node-value tr))
  215.          (setf (node-left tr) (delete item (node-left tr) comp eq-test))
  216.          (balance tr))
  217.         ((funcall comp (node-value tr) item)
  218.          (setf (node-right tr) (delete item (node-right tr) comp eq-test))
  219.          (balance tr))
  220.         (t (error "Element paßt nicht in AVL-Baum-Ordnung!"))
  221. ) ) ) )
  222.  
  223. ; (delete-ganzlinks tree) entfernt aus dem nichtleeren tree das "kleinste"
  224. ; Element und gibt den Restbaum zurück. Das entfernte Element erscheint als
  225. ; zweiter Wert (als Knoten, zur Vermeidung von Garbage Produktion).
  226. (proclaim '(function delete-ganzlinks (node) tree))
  227. (defun delete-ganzlinks (tr)
  228.   (declare (type node tr))
  229.   (if (null (node-left tr))
  230.       (values (node-right tr) tr)
  231.       (multiple-value-bind (tl el) (delete-ganzlinks (node-left tr))
  232.         (setf (node-left tr) tl)
  233.         (values tr el)
  234. ) )   )
  235.  
  236.  
  237. ; (do-avl (var treeform [resultform]) {declaration}* {tag|statement}* )
  238. ; ist ein Macro wie dolist: Für alle var aus dem AVL-Baum, der bei
  239. ; treeform herauskommt, wird der Rest ausgeführt.
  240. (defmacro do-avl (varform &rest body)
  241.   `(progn
  242.      (traverse ,(second varform)
  243.                #'(lambda (,(first varform)) ,@body)
  244.      )
  245.      ,(cond ((third varform) `(let ((,(first varform) nil)) ,(third varform))))
  246. )  )
  247.  
  248. (defmacro do-avl-1 ((var treeform &optional resultform) &body body)
  249.   (let ((abstieg (gensym)) ; Labels
  250.         (aufstieg (gensym))
  251.         (ende (gensym))
  252.         (stack (gensym)) ; (cons ,top ,stack) ist ein "Stack"
  253.         (top (gensym)))
  254.     `(prog ((,stack nil) (,top ,treeform))
  255.         ,abstieg
  256.         (if (null ,top) (go ,aufstieg))
  257.         (push ,top ,stack) (setq ,top (node-left (the node ,top)))
  258.         (go ,abstieg)
  259.         ,aufstieg
  260.         (if (null ,stack) (go ,ende))
  261.         (if (eq ,top (node-right (the node (setq ,top (pop ,stack)))))
  262.             (go ,aufstieg))
  263.         (let ((,var (node-value (the node ,top)))) ,@body)
  264.         (push ,top ,stack) (setq ,top (node-right (the node ,top)))
  265.         (go ,aufstieg)
  266.         ,ende
  267.         (let ((,var nil)) (return ,resultform))
  268.      )
  269. ) )
  270.  
  271. (proclaim '(function traverse (tree (function (t) t)) null))
  272. (defun traverse (tr fun)
  273.   (if (null tr) nil
  274.       (locally (declare (type node tr))
  275.         (traverse (node-left tr) fun)
  276.         (funcall fun (node-value tr))
  277.         (traverse (node-right tr) fun)
  278. ) )   )
  279.  
  280.  
  281. ; (avl-to-seq tree) ergibt eine sortierte Liste aller values des Baumes tree.
  282. ; (avl-to-seq tree seq-type) ergibt eine sortierte Sequence des angegebenen
  283. ; Typs aus allen Werten des Baumes tree.
  284. (proclaim '(function avl-to-seq (tree &optional t) sequence))
  285. (defun avl-to-seq (tr &optional (result-type 'list))
  286.   (if (null tr)
  287.       (make-sequence result-type 0)
  288.       (locally (declare (type node tr))
  289.         (concatenate result-type
  290.           (avl-to-seq (node-left tr))
  291.           (make-sequence result-type 1 :initial-element (node-value tr))
  292.           (avl-to-seq (node-right tr))
  293. ) )   ) )
  294.  
  295. ; (seq-to-avl l comp) ergibt aus einer (unsortierten) sequence l von Elementen
  296. ; einen AVL-Baum.
  297. (proclaim '(function seq-to-avl (sequence function &optional function) tree))
  298. (defun seq-to-avl (l comp &optional (eq-test #'equal))
  299.   (reduce #'(lambda (tr item) (insert item tr comp eq-test))
  300.           l :initial-value nil
  301. ) )
  302.  
  303.  
  304. ; (copy tree) ergibt eine Kopie des AVL-Baumes tree.
  305. ; Nur die Baumstruktur wird kopiert, die Werte werden übernommen.
  306. ; insert und delete sind jetzt auf dem Original und auf der Kopie unabhängig
  307. ; voneinander durchführbar.
  308. (proclaim '(function copy (tree) tree))
  309. (defun copy (tr)
  310.   (if (null tr) nil
  311.       (locally (declare (type node tr))
  312.         (make-node :level (node-level tr)
  313.                    :left (copy (node-left tr))
  314.                    :right (copy (node-right tr))
  315.                    :value (node-value tr)
  316. ) )   ) )
  317.  
  318.  
  319. ; (merge tree1 tree2 comp) ergibt einen neuen AVL-Baum, der aus den Elementen
  320. ; der Bäume tree1 und tree2 besteht.
  321. ; Durch Angabe eines Gleichheitstests kann spezifiert werden, was für
  322. ; Elemente (weil gleich) nicht doppelt in den neuen AVL-Baum übernommen zu
  323. ; werden brauchen. (Je zwei nicht vergleichbare Elemente müssen in diesem
  324. ; Sinne gleich sein.)
  325. (proclaim '(function merge (tree tree function &optional function) tree))
  326. (defun merge (tr1 tr2 comp &optional (eq-test #'equal))
  327.   (if (< (the fixnum (level tr1)) (the fixnum (level tr2))) (rotatef tr1 tr2))
  328.   ; jetzt ist tr1 der größere der Bäume
  329.   (let ((tr (copy tr1)))
  330.     (do-avl (x tr2 tr) (setq tr (insert x tr comp eq-test)))
  331. ) )
  332.  
  333.