home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / OB3.2D2.DMS / in.adf / Module / UntracedAVL.mod < prev    next >
Encoding:
Text File  |  1994-08-05  |  12.0 KB  |  526 lines
  1. (*-------------------------------------------------------------------------*)
  2. (*                                                                         *)
  3. (*  Amiga Oberon Library Module: UntracedAVL          Date: 02-Nov-92      *)
  4. (*                                                                         *)
  5. (*   © 1992 by Fridtjof Siebert                                            *)
  6. (*                                                                         *)
  7. (*-------------------------------------------------------------------------*)
  8.  
  9. MODULE UntracedAVL;
  10.  
  11. IMPORT BasicTypes;
  12.  
  13. TYPE
  14.  
  15.   NodePtr * = UNTRACED POINTER TO Node;
  16.   Node * = RECORD (BasicTypes.ANYDesc)
  17.     l   - : NodePtr;
  18.     r   - : NodePtr;
  19.     bal   : INTEGER;
  20.   END;
  21.  
  22.   RootPtr * = UNTRACED POINTER TO Root;
  23.   Root * = RECORD (BasicTypes.ANYDesc)
  24.     root - : NodePtr;
  25.     cmp    : PROCEDURE(a,b: NodePtr): INTEGER;
  26.     find   : PROCEDURE(VAR root: Root; a: NodePtr): INTEGER;
  27.   END;
  28.  
  29.  
  30.   CompProc * = PROCEDURE(a,b: NodePtr): INTEGER;
  31.  
  32. (* Prozedur zum Vergleichen zweier Nodes.
  33.    Ergebnis ist:
  34.      = 0, wenn beide gleich sind
  35.      < 0, wenn a < b
  36.      > 0, wenn a > b
  37. *)
  38.  
  39.   FindProc * = PROCEDURE(VAR root: Root; a: NodePtr): INTEGER;
  40.  
  41. (* Diese Prozedur wird von Find() verwendet.
  42.    Ihr Ergebnis ist
  43.      = 0, wenn a das gesuchte Element ist
  44.      < 0, wenn a < dem gesuchten Element ist
  45.      > 0, wenn a > dem gesuchten Element ist
  46. *)
  47.  
  48.   UANY * = UNTRACED POINTER TO BasicTypes.ANYDesc;
  49.  
  50.   DoProc * = PROCEDURE(a: NodePtr);
  51.   DoProc2 * = PROCEDURE(x,par: UANY);
  52.  
  53.  
  54. CONST
  55.  
  56. (* Node.bal *)
  57.   left  * = -1;
  58.   ok    * = 0;
  59.   right * = 1;
  60.  
  61.  
  62. TYPE
  63.   String * = ARRAY 80 OF CHAR;
  64.  
  65.   SNodePtr * = UNTRACED POINTER TO SNode;
  66.   SNode * = RECORD (Node)
  67.               name * : String;
  68.             END;
  69.  
  70.   SRoot * = RECORD (Root)
  71.               findstr: String;
  72.             END;
  73.  
  74.  
  75. (*-------------------------------------------------------------------------*)
  76.  
  77.  
  78. (*------  Init:  ------*)
  79.  
  80.  
  81. PROCEDURE Init* (VAR root: Root;
  82.                      cmp:  CompProc;
  83.                      find: FindProc);
  84.  
  85. (* initialisiert (leert) den AVL-Baum und setzt die Vergleichsprozedur und
  86.    Suchprozedur. Diesen Prozeduren werden die Nodes übergeben, die mit
  87.    Add() in den Baum eingetragen wurden. *)
  88.  
  89. BEGIN
  90.   root.root := NIL;
  91.   root.cmp  := cmp;
  92.   root.find := find;
  93. END Init;
  94.  
  95.  
  96. (*------  Add:  ------*)
  97.  
  98.  
  99. PROCEDURE Add* (VAR root: Root;
  100.                     node: NodePtr): BOOLEAN;
  101.  
  102. (* fügt node in den Baum ein. Das Ergebnis ist FALSE, wenn ein gleicher
  103.    (z.B. gleichnamiger) Knoten bereits im Baum enthalten ist, also nicht
  104.    eingefügt werden konnte. *)
  105.  
  106. VAR
  107.   res: BOOLEAN;
  108.   grown: BOOLEAN;
  109.   n1,n2: NodePtr;
  110.  
  111.   PROCEDURE Search(VAR n: NodePtr);
  112.  
  113.   VAR c: INTEGER;
  114.  
  115.   BEGIN
  116.     IF n=NIL THEN                       (* neues Element einfügen: *)
  117.       grown := TRUE;
  118.       n := node;
  119.       n.l := NIL; n.r := NIL; n.bal := 0;
  120.       res := TRUE;
  121.     ELSE
  122.       c := root.cmp(n,node);
  123.       IF c>0 THEN
  124.         Search(n.l);
  125.         IF grown THEN                   (* linker Zweig gewachsen: *)
  126.           CASE n.bal OF
  127.           right: n.bal := ok; grown := FALSE |
  128.           ok:    n.bal := left |
  129.           left:  n1 := n.l;             (* rebalance *)
  130.                  IF n1.bal = left THEN  (* einfache LL Rotation *)
  131.                    n.l := n1.r; n1.r := n; n.bal := ok; n := n1
  132.                  ELSE                   (* doppelte LR Rotation *)
  133.                    n2 := n1.r; n1.r := n2.l; n2.l := n1; n.l := n2.r; n2.r := n;
  134.                    IF n2.bal=left  THEN n .bal := right ELSE n .bal := ok END;
  135.                    IF n2.bal=right THEN n1.bal := left  ELSE n1.bal := ok END;
  136.                    n := n2;
  137.                  END;
  138.                  n.bal := ok; grown := FALSE |
  139.           END;
  140.         END;
  141.       ELSIF c<0 THEN
  142.         Search(n.r);
  143.         IF grown THEN                   (* rechter Zweig gewachsen: *)
  144.           CASE n.bal OF
  145.           left:  n.bal := ok; grown := FALSE |
  146.           ok:    n.bal := right |
  147.           right: n1 := n.r;             (* rebalance *)
  148.                  IF n1.bal = right THEN (* einfache RR Rotation *)
  149.                    n.r := n1.l; n1.l := n; n.bal := ok; n := n1
  150.                  ELSE                   (* doppelte RL Rotation *)
  151.                    n2 := n1.l; n1.l := n2.r; n2.r := n1;
  152.                    n.r  := n2.l; n2.l := n;
  153.                    IF n2.bal = right THEN n .bal := left  ELSE n .bal := ok END;
  154.                    IF n2.bal = left  THEN n1.bal := right ELSE n1.bal := ok END;
  155.                    n := n2;
  156.                  END;
  157.                  n.bal := ok; grown := FALSE |
  158.           END;
  159.         END;
  160.       ELSE
  161.         grown := FALSE;
  162.         res := FALSE;
  163.       END;
  164.     END;
  165.   END Search;
  166.  
  167. BEGIN
  168.   Search(root.root);
  169.   RETURN res;
  170. END Add;
  171.  
  172.  
  173. (*------  Find:  ------*)
  174.  
  175.  
  176. PROCEDURE Find* (VAR root: Root): NodePtr;
  177.  
  178. (* Sucht denjenigen Knoten, für den Root.FindProc das Ergebnis 0 liefert und
  179.    gibt seine Adresse oder NIL zurück. *)
  180.  
  181. VAR
  182.   n: NodePtr;
  183.   c: INTEGER;
  184.  
  185. BEGIN
  186.   n := root.root;
  187.   LOOP
  188.     IF n=NIL THEN RETURN NIL END;
  189.     c := root.find(root,n);
  190.     IF    c<0 THEN n := n.r
  191.     ELSIF c>0 THEN n := n.l
  192.               ELSE RETURN n END;
  193.   END;
  194. END Find;
  195.  
  196.  
  197. (*------  Remove:  ------*)
  198.  
  199.  
  200. PROCEDURE Remove* (VAR root: Root;
  201.                        node: NodePtr): BOOLEAN;
  202.  
  203. (* Entfernt node aus dem Baum. Ergebnis ist FALSE, wenn node nicht im
  204.    Baum enthalten war. Der Speicher von node muß danach noch freigegeben werden. *)
  205.  
  206. VAR
  207.   h: BOOLEAN;
  208.   deleted: BOOLEAN;
  209.  
  210.  
  211.   PROCEDURE BalL(VAR n: NodePtr);
  212.   VAR n1, n2 : NodePtr;
  213.       b1, b2 : INTEGER;
  214.   BEGIN
  215.     CASE n.bal OF
  216.     left:  n.bal := ok |
  217.     ok:    n.bal := right; h := FALSE |
  218.     right: n1 := n.r; b1 := n1.bal;     (* rebalance *)
  219.            IF b1 # left THEN            (* single RR rotation *)
  220.              n.r := n1.l; n1.l := n;
  221.              IF b1 = ok THEN n.bal := right; n1.bal := left; h := FALSE
  222.                         ELSE n.bal := ok;    n1.bal := ok;               END;
  223.              n := n1;
  224.            ELSE                         (* double RL rotation *)
  225.              n2 := n1.l; b2 := n2.bal;
  226.              n1.l := n2.r; n2.r := n1;
  227.              n .r := n2.l; n2.l := n;
  228.              IF b2 = right THEN n .bal := left  ELSE n .bal := ok END;
  229.              IF b2 = left  THEN n1.bal := right ELSE n1.bal := ok END;
  230.              n := n2; n2.bal := ok;
  231.            END |
  232.     END;
  233.   END BalL;
  234.  
  235.   PROCEDURE BalR(VAR n: NodePtr);
  236.   VAR n1, n2 : NodePtr;
  237.       b1, b2 : INTEGER;
  238.   BEGIN
  239.     CASE n.bal OF
  240.     right: n.bal :=  ok |
  241.     ok:    n.bal := left; h := FALSE |
  242.     left:  n1 := n.l; b1 := n1.bal;     (* rebalance *)
  243.            IF b1 # right THEN           (* single LL rotation *)
  244.              n.l := n1.r; n1.r := n;
  245.              IF b1 = ok THEN n.bal := left; n1.bal := right; h := FALSE
  246.                         ELSE n.bal := ok;   n1.bal := ok;               END;
  247.              n := n1;
  248.            ELSE                         (* double LR rotation *)
  249.              n2 := n1.r; b2 := n2.bal;
  250.              n1.r := n2.l; n2.l := n1;
  251.              n .l := n2.r; n2.r := n;
  252.              IF b2 = left  THEN n .bal := right ELSE n .bal := ok END;
  253.              IF b2 = right THEN n1.bal := left  ELSE n1.bal := ok END;
  254.              n := n2; n2.bal := ok;
  255.            END |
  256.     END;
  257.   END BalR;
  258.  
  259.   PROCEDURE Rem(VAR n: NodePtr);
  260.  
  261.   VAR
  262.     c: INTEGER;
  263.     New,Q: NodePtr;
  264.  
  265.     PROCEDURE del(VAR m: NodePtr);
  266.     VAR
  267.       s: Node;
  268.     BEGIN
  269.       IF m.r#NIL THEN
  270.         del(m.r); IF h THEN BalR(m) END
  271.       ELSE
  272.         New := m;
  273.         m := m.l;
  274.         h := TRUE;
  275.       END;
  276.     END del;
  277.  
  278.   BEGIN
  279.     IF n # NIL THEN
  280.       c := root.cmp(n,node);
  281.       IF    c>0 THEN Rem(n.l); IF h THEN BalL(n) END
  282.       ELSIF c<0 THEN Rem(n.r); IF h THEN BalR(n) END
  283.       ELSE
  284.         deleted := TRUE;
  285.         IF    n.r=NIL THEN n := n.l; h := TRUE
  286.         ELSIF n.l=NIL THEN n := n.r; h := TRUE
  287.         ELSE
  288.           Q := n;
  289.           del(n.l);
  290.           n := New;
  291.           n.l := Q.l;
  292.           n.r := Q.r;
  293.           n.bal := Q.bal;
  294.           IF h THEN BalL(n) END
  295.         END;
  296.       END;
  297.     END;
  298.   END Rem;
  299.  
  300. BEGIN
  301.   h := FALSE; deleted := FALSE; Rem(root.root); RETURN deleted;
  302. END Remove;
  303.  
  304.  
  305. (*------  DoForward:  ------*)
  306.  
  307.  
  308. PROCEDURE DoForward* (root: Root;
  309.                       proc: DoProc);
  310.  
  311. (* ruft proc nacheinander (von links nach rechts) mit allen Elementen des Baumes
  312.    auf *)
  313.  
  314.   PROCEDURE DoFrwd(n: NodePtr);
  315.  
  316.   BEGIN
  317.     IF n#NIL THEN
  318.       DoFrwd(n.l);
  319.       proc(n);
  320.       DoFrwd(n.r);
  321.     END;
  322.   END DoFrwd;
  323.  
  324. BEGIN
  325.   DoFrwd(root.root);
  326. END DoForward;
  327.  
  328.  
  329. (*------  DoBackward:  ------*)
  330.  
  331.  
  332. PROCEDURE DoBackward* (root: Root;
  333.                        proc: DoProc);
  334.  
  335. (* ruft proc nacheinander rückwärts (von rechts nach links) mit allen
  336.    Elementen des Baumes auf *)
  337.  
  338.   PROCEDURE DoBkwd(n: NodePtr);
  339.  
  340.   BEGIN
  341.     IF n#NIL THEN
  342.       DoBkwd(n.r);
  343.       proc(n);
  344.       DoBkwd(n.l);
  345.     END;
  346.   END DoBkwd;
  347.  
  348. BEGIN
  349.   DoBkwd(root.root);
  350. END DoBackward;
  351.  
  352.  
  353. (*------  Dispose:  ------*)
  354.  
  355.  
  356. PROCEDURE Dispose* (VAR root: Root);
  357.  
  358. (* Ruft DISPOSE() mit allen Elementen des Baumes auf, gibt also seinen
  359.    gesamten Speicher frei. *)
  360.  
  361.   PROCEDURE Disp(n: NodePtr);
  362.  
  363.   BEGIN
  364.     IF n#NIL THEN
  365.       Disp(n.l);
  366.       Disp(n.r);
  367.       DISPOSE(n);
  368.     END;
  369.   END Disp;
  370.  
  371. BEGIN
  372.   Disp(root.root); root.root := NIL;
  373. END Dispose;
  374.  
  375.  
  376. (*-------------------------------------------------------------------------*)
  377.  
  378.  
  379. PROCEDURE (tree: RootPtr) Add        * (x: UANY);
  380. (*
  381.  * add x to tree.
  382.  *)
  383. BEGIN
  384.   IF ~ Add(tree^,x(Node)) THEN HALT(20) END;
  385. END Add;
  386.  
  387.  
  388. PROCEDURE (tree: RootPtr) Remove     * (x: UANY);
  389. (* removes x from tree.
  390.  *)
  391. BEGIN
  392.   IF ~ Remove(tree^,x(Node)) THEN HALT(20) END;
  393. END Remove;
  394.  
  395.  
  396. PROCEDURE (tree: RootPtr) nbElements * (): LONGINT;
  397. (* returns the number of elements within tree.
  398.  *)
  399.  
  400.   PROCEDURE CountElements(n: NodePtr): LONGINT;
  401.   BEGIN
  402.     IF n=NIL THEN RETURN 0
  403.              ELSE RETURN CountElements(n.l) + CountElements(n.r) + 1
  404.     END;
  405.   END CountElements;
  406.  
  407. BEGIN
  408.   RETURN CountElements(tree.root);
  409. END nbElements;
  410.  
  411.  
  412. PROCEDURE (tree: RootPtr) Do         * (p: DoProc2; par: UANY);
  413. (* calls p(x,par) for every element x stored within tree.
  414.  * par passes some additional information to p. par is not touched by Do.
  415.  *)
  416.  
  417.   PROCEDURE Do(n: NodePtr);
  418.   BEGIN
  419.     IF n#NIL THEN
  420.       Do(n.l);
  421.       p(n,par);
  422.       Do(n.r);
  423.     END;
  424.   END Do;
  425.  
  426. BEGIN
  427.   Do(tree.root);
  428. END Do;
  429.  
  430.  
  431. (*-------------------------------------------------------------------------*)
  432.  
  433.  
  434. (*------  internes:  ------*)
  435.  
  436.  
  437. PROCEDURE * SCompProc(a,b: NodePtr): INTEGER;
  438.  
  439. BEGIN
  440.   WITH a: SNode DO
  441.     WITH b: SNode DO
  442.       IF    a.name>b.name THEN RETURN  1
  443.       ELSIF a.name<b.name THEN RETURN -1
  444.                           ELSE RETURN  0 END;
  445.     END;
  446.   END;
  447. END SCompProc;
  448.  
  449.  
  450. PROCEDURE * SFindProc(VAR root: Root; a: NodePtr): INTEGER;
  451.  
  452. BEGIN
  453.   WITH a: SNode DO
  454.     WITH root: SRoot DO
  455.       IF    a.name>root.findstr THEN RETURN  1
  456.       ELSIF a.name<root.findstr THEN RETURN -1
  457.                                 ELSE RETURN  0 END;
  458.     END;
  459.   END;
  460. END SFindProc;
  461.  
  462.  
  463. (*-------------------------------------------------------------------------*)
  464.  
  465.  
  466. (*------  SInit:  ------*)
  467.  
  468.  
  469. PROCEDURE SInit*(VAR root: SRoot);
  470.  
  471. (* initialisiert (leert) String-AVL-Baum und setzt die Vergleichsprozeduren
  472.    richtig. *)
  473.  
  474. BEGIN
  475.   Init(root,SCompProc,SFindProc);
  476. END SInit;
  477.  
  478.  
  479. (*------  SAdd:  ------*)
  480.  
  481.  
  482. PROCEDURE SAdd* (VAR root: SRoot;
  483.                      node: SNodePtr): BOOLEAN;
  484.  
  485. (* fügt node in den Baum ein. Das Ergebnis ist FALSE, wenn ein gleichnamiger
  486.    Knoten bereits im Baum enthalten ist, also nicht eingefügt werden
  487.    konnte. *)
  488.  
  489. BEGIN
  490.   RETURN Add(root,node);
  491. END SAdd;
  492.  
  493.  
  494. (*------  SFind:  ------*)
  495.  
  496.  
  497. PROCEDURE SFind*(VAR root: SRoot;
  498.                      str:  String): SNodePtr;
  499.  
  500. (* Sucht den Knoten mit dem Namen str und gibt seine Adresse oder NIL
  501.    bei Mißerfolg zurück. *)
  502.  
  503. VAR n: NodePtr;
  504.  
  505. BEGIN
  506.   root.findstr := str;
  507.   n := Find(root);
  508.   RETURN n(SNode);
  509. END SFind;
  510.  
  511.  
  512. (*-------------------------------------------------------------------------
  513.  
  514.   Bei String-AVL-Bäumen können die Prozeduren Remove, DoForward, DoBackward
  515.   und Dispose von oben verwendent werden. Sie sind deshalb nicht noch
  516.   einmal Implementiert.
  517.  
  518. -------------------------------------------------------------------------*)
  519.  
  520. END UntracedAVL.
  521.  
  522.  
  523.  
  524.  
  525.  
  526.