(*-------------------------------------------------------------------------*)
(*                                                                         *)
(*  Amiga Oberon Library Module: UntracedAVL          Date: 02-Nov-92      *)
(*                                                                         *)
(*   © 1992 by Fridtjof Siebert                                            *)
(*                                                                         *)
(*-------------------------------------------------------------------------*)

MODULE UntracedAVL;

IMPORT BasicTypes;

TYPE

  NodePtr * = UNTRACED POINTER TO Node;
  Node * = RECORD (BasicTypes.ANYDesc)
    l   - : NodePtr;
    r   - : NodePtr;
    bal   : INTEGER;
  END;

  RootPtr * = UNTRACED POINTER TO Root;
  Root * = RECORD (BasicTypes.ANYDesc)
    root - : NodePtr;
    cmp    : PROCEDURE(a,b: NodePtr): INTEGER;
    find   : PROCEDURE(VAR root: Root; a: NodePtr): INTEGER;
  END;


  CompProc * = PROCEDURE(a,b: NodePtr): INTEGER;

(* Prozedur zum Vergleichen zweier Nodes.
   Ergebnis ist:
     = 0, wenn beide gleich sind
     < 0, wenn a < b
     > 0, wenn a > b
*)

  FindProc * = PROCEDURE(VAR root: Root; a: NodePtr): INTEGER;

(* Diese Prozedur wird von Find() verwendet.
   Ihr Ergebnis ist
     = 0, wenn a das gesuchte Element ist
     < 0, wenn a < dem gesuchten Element ist
     > 0, wenn a > dem gesuchten Element ist
*)

  UANY * = UNTRACED POINTER TO BasicTypes.ANYDesc;

  DoProc * = PROCEDURE(a: NodePtr);
  DoProc2 * = PROCEDURE(x,par: UANY);


CONST

(* Node.bal *)
  left  * = -1;
  ok    * = 0;
  right * = 1;


TYPE
  String * = ARRAY 80 OF CHAR;

  SNodePtr * = UNTRACED POINTER TO SNode;
  SNode * = RECORD (Node)
              name * : String;
            END;

  SRoot * = RECORD (Root)
              findstr: String;
            END;


(*-------------------------------------------------------------------------*)


(*------  Init:  ------*)


PROCEDURE Init* (VAR root: Root;
                     cmp:  CompProc;
                     find: FindProc);

(* initialisiert (leert) den AVL-Baum und setzt die Vergleichsprozedur und
   Suchprozedur. Diesen Prozeduren werden die Nodes übergeben, die mit
   Add() in den Baum eingetragen wurden. *)

BEGIN
  root.root := NIL;
  root.cmp  := cmp;
  root.find := find;
END Init;


(*------  Add:  ------*)


PROCEDURE Add* (VAR root: Root;
                    node: NodePtr): BOOLEAN;

(* fügt node in den Baum ein. Das Ergebnis ist FALSE, wenn ein gleicher
   (z.B. gleichnamiger) Knoten bereits im Baum enthalten ist, also nicht
   eingefügt werden konnte. *)

VAR
  res: BOOLEAN;
  grown: BOOLEAN;
  n1,n2: NodePtr;

  PROCEDURE Search(VAR n: NodePtr);

  VAR c: INTEGER;

  BEGIN
    IF n=NIL THEN                       (* neues Element einfügen: *)
      grown := TRUE;
      n := node;
      n.l := NIL; n.r := NIL; n.bal := 0;
      res := TRUE;
    ELSE
      c := root.cmp(n,node);
      IF c>0 THEN
        Search(n.l);
        IF grown THEN                   (* linker Zweig gewachsen: *)
          CASE n.bal OF
          right: n.bal := ok; grown := FALSE |
          ok:    n.bal := left |
          left:  n1 := n.l;             (* rebalance *)
                 IF n1.bal = left THEN  (* einfache LL Rotation *)
                   n.l := n1.r; n1.r := n; n.bal := ok; n := n1
                 ELSE                   (* doppelte LR Rotation *)
                   n2 := n1.r; n1.r := n2.l; n2.l := n1; n.l := n2.r; n2.r := n;
                   IF n2.bal=left  THEN n .bal := right ELSE n .bal := ok END;
                   IF n2.bal=right THEN n1.bal := left  ELSE n1.bal := ok END;
                   n := n2;
                 END;
                 n.bal := ok; grown := FALSE |
          END;
        END;
      ELSIF c<0 THEN
        Search(n.r);
        IF grown THEN                   (* rechter Zweig gewachsen: *)
          CASE n.bal OF
          left:  n.bal := ok; grown := FALSE |
          ok:    n.bal := right |
          right: n1 := n.r;             (* rebalance *)
                 IF n1.bal = right THEN (* einfache RR Rotation *)
                   n.r := n1.l; n1.l := n; n.bal := ok; n := n1
                 ELSE                   (* doppelte RL Rotation *)
                   n2 := n1.l; n1.l := n2.r; n2.r := n1;
                   n.r  := n2.l; n2.l := n;
                   IF n2.bal = right THEN n .bal := left  ELSE n .bal := ok END;
                   IF n2.bal = left  THEN n1.bal := right ELSE n1.bal := ok END;
                   n := n2;
                 END;
                 n.bal := ok; grown := FALSE |
          END;
        END;
      ELSE
        grown := FALSE;
        res := FALSE;
      END;
    END;
  END Search;

BEGIN
  Search(root.root);
  RETURN res;
END Add;


(*------  Find:  ------*)


PROCEDURE Find* (VAR root: Root): NodePtr;

(* Sucht denjenigen Knoten, für den Root.FindProc das Ergebnis 0 liefert und
   gibt seine Adresse oder NIL zurück. *)

VAR
  n: NodePtr;
  c: INTEGER;

BEGIN
  n := root.root;
  LOOP
    IF n=NIL THEN RETURN NIL END;
    c := root.find(root,n);
    IF    c<0 THEN n := n.r
    ELSIF c>0 THEN n := n.l
              ELSE RETURN n END;
  END;
END Find;


(*------  Remove:  ------*)


PROCEDURE Remove* (VAR root: Root;
                       node: NodePtr): BOOLEAN;

(* Entfernt node aus dem Baum. Ergebnis ist FALSE, wenn node nicht im
   Baum enthalten war. Der Speicher von node muß danach noch freigegeben werden. *)

VAR
  h: BOOLEAN;
  deleted: BOOLEAN;


  PROCEDURE BalL(VAR n: NodePtr);
  VAR n1, n2 : NodePtr;
      b1, b2 : INTEGER;
  BEGIN
    CASE n.bal OF
    left:  n.bal := ok |
    ok:    n.bal := right; h := FALSE |
    right: n1 := n.r; b1 := n1.bal;     (* rebalance *)
           IF b1 # left THEN            (* single RR rotation *)
             n.r := n1.l; n1.l := n;
             IF b1 = ok THEN n.bal := right; n1.bal := left; h := FALSE
                        ELSE n.bal := ok;    n1.bal := ok;               END;
             n := n1;
           ELSE                         (* double RL rotation *)
             n2 := n1.l; b2 := n2.bal;
             n1.l := n2.r; n2.r := n1;
             n .r := n2.l; n2.l := n;
             IF b2 = right THEN n .bal := left  ELSE n .bal := ok END;
             IF b2 = left  THEN n1.bal := right ELSE n1.bal := ok END;
             n := n2; n2.bal := ok;
           END |
    END;
  END BalL;

  PROCEDURE BalR(VAR n: NodePtr);
  VAR n1, n2 : NodePtr;
      b1, b2 : INTEGER;
  BEGIN
    CASE n.bal OF
    right: n.bal :=  ok |
    ok:    n.bal := left; h := FALSE |
    left:  n1 := n.l; b1 := n1.bal;     (* rebalance *)
           IF b1 # right THEN           (* single LL rotation *)
             n.l := n1.r; n1.r := n;
             IF b1 = ok THEN n.bal := left; n1.bal := right; h := FALSE
                        ELSE n.bal := ok;   n1.bal := ok;               END;
             n := n1;
           ELSE                         (* double LR rotation *)
             n2 := n1.r; b2 := n2.bal;
             n1.r := n2.l; n2.l := n1;
             n .l := n2.r; n2.r := n;
             IF b2 = left  THEN n .bal := right ELSE n .bal := ok END;
             IF b2 = right THEN n1.bal := left  ELSE n1.bal := ok END;
             n := n2; n2.bal := ok;
           END |
    END;
  END BalR;

  PROCEDURE Rem(VAR n: NodePtr);

  VAR
    c: INTEGER;
    New,Q: NodePtr;

    PROCEDURE del(VAR m: NodePtr);
    VAR
      s: Node;
    BEGIN
      IF m.r#NIL THEN
        del(m.r); IF h THEN BalR(m) END
      ELSE
        New := m;
        m := m.l;
        h := TRUE;
      END;
    END del;

  BEGIN
    IF n # NIL THEN
      c := root.cmp(n,node);
      IF    c>0 THEN Rem(n.l); IF h THEN BalL(n) END
      ELSIF c<0 THEN Rem(n.r); IF h THEN BalR(n) END
      ELSE
        deleted := TRUE;
        IF    n.r=NIL THEN n := n.l; h := TRUE
        ELSIF n.l=NIL THEN n := n.r; h := TRUE
        ELSE
          Q := n;
          del(n.l);
          n := New;
          n.l := Q.l;
          n.r := Q.r;
          n.bal := Q.bal;
          IF h THEN BalL(n) END
        END;
      END;
    END;
  END Rem;

BEGIN
  h := FALSE; deleted := FALSE; Rem(root.root); RETURN deleted;
END Remove;


(*------  DoForward:  ------*)


PROCEDURE DoForward* (root: Root;
                      proc: DoProc);

(* ruft proc nacheinander (von links nach rechts) mit allen Elementen des Baumes
   auf *)

  PROCEDURE DoFrwd(n: NodePtr);

  BEGIN
    IF n#NIL THEN
      DoFrwd(n.l);
      proc(n);
      DoFrwd(n.r);
    END;
  END DoFrwd;

BEGIN
  DoFrwd(root.root);
END DoForward;


(*------  DoBackward:  ------*)


PROCEDURE DoBackward* (root: Root;
                       proc: DoProc);

(* ruft proc nacheinander rückwärts (von rechts nach links) mit allen
   Elementen des Baumes auf *)

  PROCEDURE DoBkwd(n: NodePtr);

  BEGIN
    IF n#NIL THEN
      DoBkwd(n.r);
      proc(n);
      DoBkwd(n.l);
    END;
  END DoBkwd;

BEGIN
  DoBkwd(root.root);
END DoBackward;


(*------  Dispose:  ------*)


PROCEDURE Dispose* (VAR root: Root);

(* Ruft DISPOSE() mit allen Elementen des Baumes auf, gibt also seinen
   gesamten Speicher frei. *)

  PROCEDURE Disp(n: NodePtr);

  BEGIN
    IF n#NIL THEN
      Disp(n.l);
      Disp(n.r);
      DISPOSE(n);
    END;
  END Disp;

BEGIN
  Disp(root.root); root.root := NIL;
END Dispose;


(*-------------------------------------------------------------------------*)


PROCEDURE (tree: RootPtr) Add        * (x: UANY);
(*
 * add x to tree.
 *)
BEGIN
  IF ~ Add(tree^,x(Node)) THEN HALT(20) END;
END Add;


PROCEDURE (tree: RootPtr) Remove     * (x: UANY);
(* removes x from tree.
 *)
BEGIN
  IF ~ Remove(tree^,x(Node)) THEN HALT(20) END;
END Remove;


PROCEDURE (tree: RootPtr) nbElements * (): LONGINT;
(* returns the number of elements within tree.
 *)

  PROCEDURE CountElements(n: NodePtr): LONGINT;
  BEGIN
    IF n=NIL THEN RETURN 0
             ELSE RETURN CountElements(n.l) + CountElements(n.r) + 1
    END;
  END CountElements;

BEGIN
  RETURN CountElements(tree.root);
END nbElements;


PROCEDURE (tree: RootPtr) Do         * (p: DoProc2; par: UANY);
(* calls p(x,par) for every element x stored within tree.
 * par passes some additional information to p. par is not touched by Do.
 *)

  PROCEDURE Do(n: NodePtr);
  BEGIN
    IF n#NIL THEN
      Do(n.l);
      p(n,par);
      Do(n.r);
    END;
  END Do;

BEGIN
  Do(tree.root);
END Do;


(*-------------------------------------------------------------------------*)


(*------  internes:  ------*)


PROCEDURE * SCompProc(a,b: NodePtr): INTEGER;

BEGIN
  WITH a: SNode DO
    WITH b: SNode DO
      IF    a.name>b.name THEN RETURN  1
      ELSIF a.name<b.name THEN RETURN -1
                          ELSE RETURN  0 END;
    END;
  END;
END SCompProc;


PROCEDURE * SFindProc(VAR root: Root; a: NodePtr): INTEGER;

BEGIN
  WITH a: SNode DO
    WITH root: SRoot DO
      IF    a.name>root.findstr THEN RETURN  1
      ELSIF a.name<root.findstr THEN RETURN -1
                                ELSE RETURN  0 END;
    END;
  END;
END SFindProc;


(*-------------------------------------------------------------------------*)


(*------  SInit:  ------*)


PROCEDURE SInit*(VAR root: SRoot);

(* initialisiert (leert) String-AVL-Baum und setzt die Vergleichsprozeduren
   richtig. *)

BEGIN
  Init(root,SCompProc,SFindProc);
END SInit;


(*------  SAdd:  ------*)


PROCEDURE SAdd* (VAR root: SRoot;
                     node: SNodePtr): BOOLEAN;

(* fügt node in den Baum ein. Das Ergebnis ist FALSE, wenn ein gleichnamiger
   Knoten bereits im Baum enthalten ist, also nicht eingefügt werden
   konnte. *)

BEGIN
  RETURN Add(root,node);
END SAdd;


(*------  SFind:  ------*)


PROCEDURE SFind*(VAR root: SRoot;
                     str:  String): SNodePtr;

(* Sucht den Knoten mit dem Namen str und gibt seine Adresse oder NIL
   bei Mißerfolg zurück. *)

VAR n: NodePtr;

BEGIN
  root.findstr := str;
  n := Find(root);
  RETURN n(SNode);
END SFind;


(*-------------------------------------------------------------------------

  Bei String-AVL-Bäumen können die Prozeduren Remove, DoForward, DoBackward
  und Dispose von oben verwendent werden. Sie sind deshalb nicht noch
  einmal Implementiert.

-------------------------------------------------------------------------*)

END UntracedAVL.