(*********************************************************************
 *                                                                   *
 *  :Program.    AVL.mod                                             *
 *  :Author.     Michael Frieß                                       *
 *  :Address.    Kernerstr. 22a                                      *
 *  :shortcut.   [MiF]                                               *
 *  :Version.    1.0                                                 *
 *  :Date.       22.09.88                                            *
 *  :Copyright.  PD                                                  *
 *  :Language.   Modula-II                                           *
 *  :Translator. M2Amiga                                             *
 *  :Imports.    MemSystem (at least V1.0 --> Amok#5)                *
 *  :Contents.   Generic data type: AVL-Tree                         *
 *                                                                   *
 *********************************************************************)

IMPLEMENTATION MODULE AVL;

FROM SYSTEM    IMPORT BYTE, ADR, ADDRESS, CAST;
FROM MemSystem IMPORT Allocate, Deallocate;
FROM Exec      IMPORT CopyMem;
FROM Arts      IMPORT Assert;
FROM Strings   IMPORT Length, Insert, Copy, Compare;
FROM FileSystem IMPORT File, Response, Lookup, Close,
                       ReadBytes, WriteBytes;

CONST copyright = "MODULE AVL: (C) Copyright 1988 by Michael Frieß";
      module    = "MODULE AVL";
      BufferSize = 1024; (* buffer size for loading and *)
                         (* saving trees                *)


TYPE balance    = [-1..1]; (* every element knows about balance *)
                           (* of its subtrees                   *)
     tree       = POINTER TO treebody; (* opaque type must be   *)
                                       (* pointer type          *)
     elementptr = POINTER TO element;
     treebody   = RECORD
                    Root : elementptr;
                    Number,            (* number of elements    *)
                    Size,              (* Size of data          *)
                    KeySize : INTEGER; (* Size of key           *)
                    Compare : compareProcedure;
                    Name    : ARRAY [1..20] OF CHAR;
                  END;
     element    = RECORD
                   Key, Data : ADDRESS;
                   l, r : elementptr;  (* pointers to subtrees  *)
                   Bal  : balance      (* info about balance    *)
                  END;


PROCEDURE Compatible (VAR t: tree;
                      VAR Key, Data : ARRAY OF BYTE
                     ) : BOOLEAN;
 BEGIN
  RETURN (HIGH(Data)+1  = t^.Size) AND
         (HIGH(Key)+1  <= t^.KeySize)
 END Compatible;


PROCEDURE Error (VAR t: tree; b: BOOLEAN; i: INTEGER);
 (* Error procedure to show detailed error info *)
 VAR s: ARRAY [1..70] OF CHAR;
 BEGIN
  IF b THEN
   s := module;
   CASE i OF
    1      : Insert (s, 11, "tree doesn´t exist") |
    11..30 : Insert (s, 11, "cannot create ");
       CASE i OF
        11 : Insert (s, Length(s), "tree")    |
        12 : Insert (s, Length(s), "element") |
       END                                        |
    31..50: Insert (s, 11, "tree");
            Insert (s, 16, t^.Name);
            Insert (s, Length(s)+1, "incompatible use of ");
       CASE i OF
        31 : Insert (s, Length(s), "Write" )  |
        32 : Insert (s, Length(s), "Read"  )  |
        33 : Insert (s, Length(s), "Delete")  |
       END
   END;
   Assert (FALSE, ADR(s))
  END
 END Error;


PROCEDURE Init (VAR t:tree; Name: ARRAY OF CHAR;
                ks, s: INTEGER;
                Cmp : compareProcedure);
 BEGIN
   Allocate (t, SIZE(treebody));
   Error (t, t=NIL, 11);
   WITH t^ DO
    Root    := NIL;
    Number  := 0;
    Size    := s;
    KeySize := ks;
    Compare := Cmp
   END;
   Copy (t^.Name, Name, 0, Length(Name))
 END Init;


PROCEDURE Discard (VAR t: tree);
 PROCEDURE del (VAR e:elementptr);
  BEGIN
   IF e # NIL THEN
    del (e^.l);
    del (e^.r);
    Deallocate (e)
   END
  END del;

 BEGIN
  Error (t, t=NIL, 1);
  del (t^.Root); (* remove memory recursive! *)
  Deallocate (t);
 END Discard;

(*-----------------------------------------------------------*)
(* now follows a internal procedure to handle Write and Read
   in a similiar way.
*)


PROCEDURE searchStart (Tree: tree; VAR k, d: ARRAY OF BYTE;
                       VAR InsertAndFound: BOOLEAN);
 (* following variables are defined at this position to speed
    up recursive call of searchRecursive.
 *)
 VAR t1, t2 : elementptr;
     h : BOOLEAN; (* determines whether balancing is necessary *)

 PROCEDURE searchRecursive (VAR t: elementptr; VAR h: BOOLEAN);
  BEGIN
   IF t = NIL THEN (* not found *)
     IF InsertAndFound THEN (* insert *)
      (* allocate memory for the whole element ! *)
      Allocate (t, SIZE(element) + Tree^.Size + Tree^.KeySize);
      Error (Tree, t=NIL, 2);
      (* branch has grown *)
      h := TRUE;
      INC(Tree^.Number);
      WITH t^ DO
       l := NIL; r := NIL; Bal := 0;
       (* calculate pointers ! *)
       Key  := CAST(LONGINT,t) + LONGINT(SIZE(element));
       Data := Key + LONGINT(Tree^.KeySize)
      END; (* With t^ *)
      (* insert data *)
      CopyMem (ADR(k), t^.Key, Tree^.KeySize);
      CopyMem (ADR(d), t^.Data, Tree^.Size)
     ELSE
      (* branch has not grown *)
      h := FALSE;
     END; (* InsertAndFound *)
     InsertAndFound := FALSE;
   ELSIF Tree^.Compare (t^.Key^, k) > 0 THEN
     searchRecursive (t^.l, h);
     IF h THEN (* left branch has grown *)
      CASE t^.Bal OF
        1: t^.Bal := 0; h := FALSE |
        0: t^.Bal := -1 |
       -1: (* rebalance *)
           t1 := t^.l;
           IF t1^.Bal = -1 THEN (* single LL rotation *)
             t^.l := t1^.r; t1^.r := t;
             t^.Bal := 0; t := t1
           ELSE (* double LR rotation *)
             t2 := t1^.r;
             t1^.r := t2^.l; t2^.l := t1;
             t^.l  := t2^.r; t2^.r := t;
             IF t2^.Bal = -1 THEN t^.Bal  :=  1
                             ELSE t^.Bal  := 0 END;
             IF t2^.Bal = +1 THEN t1^.Bal := -1
                             ELSE t1^.Bal := 0 END;
             t := t2;
           END; (* IF *)
           t^.Bal := 0; h := FALSE;
      END; (* of CASE t^.Bal *)
     END; (* IF h *)
   ELSIF Tree^.Compare (t^.Key^, k) < 0 THEN
     searchRecursive (t^.r, h);
     IF h THEN (* right branch has grown *)
      CASE t^.Bal OF
       -1: t^.Bal := 0; h := FALSE |
        0: t^.Bal := 1 |
        1: (* rebalance *)
           t1 := t^.r;
           IF t1^.Bal = 1 THEN (* single RR rotation *)
             t^.r := t1^.l; t1^.l := t;
             t^.Bal := 0; t := t1
           ELSE (* double RL rotation *)
             t2 := t1^.l;
             t1^.l := t2^.r; t2^.r := t1;
             t^.r  := t2^.l; t2^.l := t;
             IF t2^.Bal = +1 THEN t^.Bal  := -1
                             ELSE t^.Bal  := 0 END;
             IF t2^.Bal = -1 THEN t1^.Bal :=  1
                             ELSE t1^.Bal := 0 END;
             t := t2;
           END; (* IF *)
           t^.Bal := 0; h := FALSE;
      END; (* of CASE t^.Bal *)
     END; (* IF h *)
   ELSE (* element found *)
     IF InsertAndFound THEN
       (* write data *)
       CopyMem (ADR(d), t^.Data, Tree^.Size)
     ELSE
       (* read data *)
       CopyMem (t^.Data, ADR(d), Tree^.Size)
     END;
     (* branch has not grown *)
     h := FALSE;
     InsertAndFound := TRUE;
   END;
  END searchRecursive;

BEGIN
 searchRecursive (Tree^.Root, h)
END searchStart;


PROCEDURE Write (t: tree; Key : ARRAY OF BYTE;
                 VAR Data : ARRAY OF BYTE;
                 VAR OverWritten: BOOLEAN);
 BEGIN
  Error (t, t=NIL, 1);
  Error (t, NOT Compatible (t, Key, Data), 31);
  OverWritten := TRUE; (* write element *)
  searchStart (t, Key, Data, OverWritten)
 END Write;


PROCEDURE Read (t: tree; Key : ARRAY OF BYTE;
                VAR Data: ARRAY OF BYTE; VAR Found : BOOLEAN);
 BEGIN
  Error (t, t=NIL, 1);
  Error (t, NOT Compatible (t, Key, Data), 32);
  Found := FALSE; (* read element *)
  searchStart (t, Key, Data, Found)
 END Read;


PROCEDURE Delete (t: tree; Key: ARRAY OF BYTE;
                  VAR Deleted: BOOLEAN);
 VAR r : INTEGER;
     h : BOOLEAN;

 PROCEDURE deleteRecursive (VAR e: elementptr;
                           VAR h : BOOLEAN);
  VAR q : elementptr;

  PROCEDURE balanceL (VAR t: elementptr; VAR h : BOOLEAN);
   VAR t1, t2 : elementptr;
       b1, b2 : balance;
   BEGIN
    CASE t^.Bal OF
      -1: t^.Bal := 0 |
       0: t^.Bal := 1; h := FALSE |
       1: (* rebalance *)
          t1 := t^.r; b1 := t1^.Bal;
          IF b1 >= 0 THEN (* single RR rotation *)
            t^.r := t1^.l; t1^.l := t;
            IF b1 = 0 THEN t^.Bal := 1; t1^.Bal := -1; h := FALSE
            ELSE t^.Bal := 0; t1^.Bal := 0
            END;
            t := t1;
          ELSE (* double RL rotation *)
            t2 := t1^.l; b2 := t2^.Bal;
            t1^.l := t2^.r; t2^.r := t1;
            t^.r  := t2^.l; t2^.l := t;
            IF b2 = +1 THEN t^.Bal  := -1
                       ELSE t^.Bal  := 0 END;
            IF b2 = -1 THEN t1^.Bal :=  1
                       ELSE t1^.Bal := 0 END;
            t := t2; t2^.Bal := 0;
          END; (* IF *)
    END; (* of CASE t^.bal *)
   END balanceL;

  PROCEDURE balanceR (VAR t: elementptr; VAR h: BOOLEAN);
   VAR t1, t2 : elementptr;
      b1, b2 : balance;
   BEGIN
    CASE t^.Bal OF
       1: t^.Bal :=  0 |
       0: t^.Bal := -1; h := FALSE |
      -1: (* rebalance *)
          t1 := t^.l; b1 := t1^.Bal;
          IF b1 <= 0 THEN (* single LL rotation *)
            t^.l := t1^.r; t1^.r := t;
            IF b1 = 0 THEN t^.Bal := -1; t1^.Bal := 1; h := FALSE
            ELSE t^.Bal := 0; t1^.Bal := 0
            END;
            t := t1;
          ELSE (* double LR rotation *)
            t2 := t1^.r; b2 := t2^.Bal;
            t1^.r := t2^.l; t2^.l := t1;
            t^.l  := t2^.r; t2^.r := t;
            IF b2 = -1 THEN t^.Bal  := 1
                       ELSE t^.Bal  := 0 END;
            IF b2 =  1 THEN t1^.Bal := -1
                       ELSE t1^.Bal := 0 END;
            t := t2; t2^.Bal := 0;
          END; (* IF *)
    END; (* of CASE t^.Bal *)
   END balanceR;

  PROCEDURE del (VAR r: elementptr; VAR h : BOOLEAN);
   VAR q : elementptr;
   BEGIN
    IF r^.r # NIL THEN
      del (r^.r, h);
      IF h THEN balanceR (r,h) END
    ELSE
      (* move Key and Data *)
      CopyMem (r^.Key,  q^.Key, t^.KeySize + t^.Size);
      q := r; r := r^.l;
      h := TRUE;
    END;
   END del;

  BEGIN
   IF e= NIL THEN (* key not in tree *)
    Deleted := FALSE;
   ELSIF t^.Compare (e^.Key^, Key) > 0 THEN
    deleteRecursive (e^.l, h);
    IF h THEN balanceL (e,h) END
   ELSIF t^.Compare (e^.Key^, Key) < 0 THEN
    deleteRecursive (e^.r, h);
    IF h THEN balanceR (e,h) END
   ELSE (* delete e^ *)
    Deleted := TRUE;
    q := e;
    IF q^.r = NIL THEN e := q^.l; h := TRUE
    ELSIF q^.l = NIL THEN e := q^.r; h := TRUE
    ELSE del (q^.l, h);
      IF h THEN balanceL (e,h) END
    END;
    Deallocate (q);
    DEC(t^.Number)
   END;
  END deleteRecursive;

 BEGIN
  Error (t, t=NIL, 1);
  Error (t, HIGH(Key)+1 > t^.KeySize, 33);
  deleteRecursive (t^.Root, h);
 END Delete;


PROCEDURE Empty (t: tree) : BOOLEAN;
 BEGIN
  Error (t, t=NIL, 1);
  RETURN (t^.Root = NIL)
 END Empty;

PROCEDURE Number (t: tree) : INTEGER;
 BEGIN
  Error (t, t=NIL, 1);
  RETURN t^.Number
 END Number;

PROCEDURE Save (t: tree; Name: ARRAY OF CHAR;
                VAR res : Response);
 VAR f : File;
     id : ARRAY [1..10] OF CHAR;
     i  : INTEGER;
     Count : LONGINT;

 PROCEDURE saveRecursive (VAR e: elementptr);
  BEGIN
   IF e # NIL THEN
    saveRecursive (e^.l);
    WriteBytes (f, e^.Key, t^.Size+t^.KeySize, Count);
    saveRecursive (e^.r)
   END
  END saveRecursive;

 BEGIN
  Error (t, t=NIL, 1);
  Lookup (f, Name, BufferSize, TRUE);
  IF f.res = done THEN
   id := module;
   WriteBytes (f, ADR(module), 10, Count);
   WriteBytes (f, t, SIZE(treebody), Count);
   saveRecursive (t^.Root);
   Close (f)
  END;
  res := f.res
 END Save;


PROCEDURE Load (t: tree; Name: ARRAY OF CHAR;
                VAR res: Response);
 VAR f : File;
     Count : LONGINT;
     id : ARRAY [1..10] OF CHAR;

 PROCEDURE loadRecursive (n : INTEGER): elementptr;
  VAR e, left : elementptr;
      nh : INTEGER;
  BEGIN
   IF n = 0 THEN
     e := NIL
   ELSE
    nh := n DIV 2;
    left := loadRecursive (nh);
    Allocate (e, SIZE(element)+t^.Size+t^.KeySize);
    Error (t, e=NIL, 12);
    WITH e^ DO
     Key  := CAST(LONGINT,e) + LONGINT(SIZE(element));
     Data := Key + LONGINT(t^.KeySize);
     nh := n - nh - 1;
     (* Bal ist bei den 2er Potenzen gleich -1, ansonsten null *)
     WHILE n > 1 DO n := n DIV 2 END;
     Bal := n - 1;
     ReadBytes (f, Key, t^.Size+t^.KeySize, Count);
     l := left;
     r := loadRecursive (nh)
    END
   END;
   RETURN e
  END loadRecursive;

 BEGIN
  Error (t, t=NIL, 1);
  Lookup (f, Name, BufferSize, FALSE);
  IF f.res = done THEN
   ReadBytes (f, ADR(id), 10, Count);
   IF Compare(id, 0, 10, module, TRUE) = 0 THEN
    ReadBytes (f, t, SIZE(treebody), Count);
    t^.Root := loadRecursive(t^.Number);
    res := done
   ELSE
    res := notdone
   END;
   Close (f)
  ELSE
   res := f.res
  END
 END Load;


PROCEDURE Do (t: tree; Action: action; Order: order);
 PROCEDURE doRecursive (VAR e: elementptr);
  BEGIN
   IF e # NIL THEN
    CASE Order OF
     pre : Action (e^.Key^, e^.Data^);
           doRecursive (e^.l);
           doRecursive (e^.r) |
     in  : doRecursive (e^.l);
           Action (e^.Key^, e^.Data^);
           doRecursive (e^.r) |
     post: doRecursive (e^.l);
           doRecursive (e^.r);
           Action (e^.Key^, e^.Data^)
    END
   END
  END doRecursive;

 BEGIN
  Error (t, t=NIL, 1);
  doRecursive (t^.Root)
 END Do;

END AVL.