Category : Files from Magazines
Archive   : ISSUE-51.ZIP
Filename : AVL_TREE.PAS

(* This code supports an article in issue #51 of:

Micro Cornucopia Magazine
P.O. Box 223
Bend, OR 97709
*)

UNIT GenAvlTree;
(*
Michael S. Hunt
Micro Cornucopia
Issue #50, November - December 1989
Released as Public Domain Software
*)
INTERFACE

TYPE dataPtr = ^dataType;
dataType = array [1..32767] of CHAR;
treePtr = ^treeNode;
treeNode = RECORD
data, key : dataPtr;
dataLen, keyLen : WORD;
llink, rlink : treePtr;
bf : SHORTINT
END;

PROCEDURE GenAvlTrIns(k, d : dataPtr; keyLen, dataLen : WORD;
VAR p : treePtr; VAR h :BOOLEAN);
PROCEDURE GenAvlTrDel(k : dataPtr; VAR p : treePtr; VAR h : BOOLEAN);
PROCEDURE GenAvlTrDis(root : treePtr;tab : INTEGER);
PROCEDURE GenAvlTrRetDelSmRec(VAR p : treePtr; VAR key, data : dataPtr;
VAR keyLen, dataLen : WORD; VAR h : BOOLEAN);

IMPLEMENTATION

CONST tabinc = 3;
VAR boo : BOOLEAN;

FUNCTION CompArr(VAR arr1, arr2 : dataType; len : WORD) : INTEGER;
VAR k : WORD;
BEGIN
k := 1;
CompArr := 0;
WHILE k < len DO
BEGIN
IF arr1[k] < arr2[k] THEN
BEGIN
CompArr := -1;
k := len + 1
END
ELSE IF arr1[k] > arr2[k] THEN
BEGIN
CompArr := 1;
k := len + 1
END
ELSE
Inc(k);
END
END;

PROCEDURE BalLeft(VAR p : treePtr; VAR h : BOOLEAN);
VAR p1, p2 : treePtr;
b1, b2 : SHORTINT;
BEGIN
IF p^.bf = -1 THEN
p^.bf := 0
ELSE IF p^.bf = 0 THEN
BEGIN
p^.bf := 1;
h := FALSE
END
ELSE
BEGIN
p1 := p^.rlink;
b1 := p1^.bf;
IF b1 >= 0 THEN (* single RR rotation *)
BEGIN
p^.rlink := p1^.llink;
p1^.llink := p;
IF b1 = 0 THEN
BEGIN
p^.bf := 1;
p1^.bf := -1;
h := FALSE
END
ELSE
BEGIN
p^.bf := 0;
p1^.bf := 0
END;
p := p1
END
ELSE
BEGIN
p2 := p1^.llink;
b2 := p2^.bf;
p1^.llink := p2^.rlink;
p2^.rlink := p1;
p^.rlink := p^.llink;
p2^.llink := p;
IF b2 = 1 THEN
p^.bf := -1
ELSE
p^.bf := 0;
IF b2 = -1 THEN
p^.bf := 1
ELSE
p^.bf := 0;
p := p2;
p2^.bf := 0
END
END
END; (* BalLeft *)

PROCEDURE BalRight(VAR p : treePtr; VAR h : BOOLEAN);
VAR p1, p2 : treePtr;
b1, b2 : SHORTINT;
BEGIN
IF p^.bf = 1 THEN
p^.bf := 0
ELSE IF p^.bf = 0 THEN
BEGIN
p^.bf := -1;
h := FALSE
END
ELSE
BEGIN
p1 := p^.llink;
b1 := p1^.bf;
IF b1 <= 0 THEN (* single LL rotation *)
BEGIN
p^.llink := p1^.rlink;
p1^.rlink := p;
IF b1 = 0 THEN
BEGIN
p^.bf :=- 1;
p1^.bf := 1;
h := FALSE
END
ELSE
BEGIN
p^.bf := 0;
p1^.bf := 0
END;
p := p1
END
ELSE
BEGIN
p2 := p1^.rlink;
b2 := p2^.bf;
p1^.rlink := p2^.llink;
p2^.llink := p1;
p^.llink := p^.rlink;
p2^.rlink := p;
IF b2 = -1 THEN
p^.bf := 1
ELSE
p^.bf := 0;
IF b2 = 1 THEN
p^.bf := -1
ELSE
p^.bf := 0;
p := p2;
p2^.bf := 0
END
END
END; (* BalRight *)

PROCEDURE GenAvlTrIns(k, d : dataPtr; keyLen, dataLen : WORD;
VAR p : treePtr; VAR h :BOOLEAN);
VAR p1, p2 : treePtr;
BEGIN
IF p = NIL THEN (* insert *)
BEGIN
GetMem(p, SizeOf(treeNode));
h := TRUE;
p^.data := d;
p^.key := k;
p^.dataLen := dataLen;
p^.keyLen := keyLen;
p^.llink := NIL;
p^.rlink := NIL;
p^.bf := 0
END
ELSE IF CompArr(p^.key^, k^, p^.keyLen) = 1 THEN
BEGIN
GenAvlTrIns(k, d, keyLen, dataLen, p^.llink, h);
IF h THEN (* left branch has grown *)
BEGIN
IF p^.bf = 1 THEN
BEGIN
p^.bf := 0;
h := FALSE
END
ELSE IF p^.bf = 0 THEN
p^.bf := -1
ELSE IF p^.bf = -1 THEN
BEGIN
p1 := p^.llink;
IF p1^.bf = -1 THEN (* single LL rotation *)
BEGIN
p^.llink := p1^.rlink;
p1^.rlink := p;
p^.bf := 0;
p := p1
END
ELSE (* double LR rotation *)
BEGIN
p2 := p1^.rlink;
p1^.rlink := p2^.llink;
p2^.llink := p1;
p^.llink := p2^.rlink;
p2^.rlink := p;
IF p2^.bf = -1 THEN
p^.bf := 1
ELSE
p^.bf := 0;
IF p2^.bf = 1 THEN
p1^.bf := -1
ELSE
p1^.bf := 0;
p := p2
END;
p^.bf := 0;
h := false
END
END
END
ELSE IF CompArr(p^.key^, k^, p^.keyLen) <= 0 THEN
BEGIN
GenAvlTrIns(k, d, keyLen, dataLen, p^.rlink, h);
IF h THEN (* right branch has grown *)
BEGIN
IF p^.bf = -1 THEN
BEGIN
p^.bf := 0;
h := FALSE
END
ELSE IF p^.bf = 0 THEN
p^.bf := 1
ELSE IF p^.bf = 1 THEN
BEGIN
p1 := p^.rlink;
IF p1^.bf = 1 THEN (* single RR rotation *)
BEGIN
p^.rlink := p1^.llink;
p1^.llink := p;
p^.bf := 0;
p := p1
END
ELSE (* double RL rotation *)
BEGIN
p2 := p1^.llink;
p1^.llink := p2^.rlink;
p2^.rlink := p1;
p^.rlink := p2^.llink;
p2^.llink := p;
IF p2^.bf = 1 THEN
p^.bf := -1
ELSE
p^.bf := 0;
IF p2^.bf = -1 THEN
p1^.bf := 1
ELSE
p1^.bf := 0;
p := p2
END;
p^.bf := 0;
h := false
END
END
END
END (* GenAvlTrIns *);

PROCEDURE GenAvlTrDel(k : dataPtr; VAR p : treePtr; VAR h : BOOLEAN);
VAR q : treePtr;

PROCEDURE del(VAR r : treePtr; VAR h : BOOLEAN);
BEGIN
IF r^.rlink <> NIL THEN
BEGIN
del(r^.rlink, h);
IF h THEN BalRight(r, h)

END
ELSE
BEGIN
q^.key^ := r^.key^;
q := r;
r := r^.llink;
h := TRUE
END
END; (* del *)

BEGIN
IF p = NIL THEN (* key not in tree *)
ELSE IF CompArr(p^.key^, k^, p^.keyLen) = 1 THEN
BEGIN
GenAvlTrDel(k, p^.llink, h);
IF h THEN BalLeft(p, h)
END
ELSE IF CompArr(p^.key^, k^, p^.keyLen) = -1 THEN
BEGIN
GenAvlTrDel(k, p^.rlink, h);
IF h THEN BalRight(p, h)
END
ELSE (* delete p^ *)
BEGIN
q := p;
IF q^.rlink = NIL THEN
BEGIN
p := q^.llink;
h := TRUE
END
ELSE IF q^.llink = NIL THEN
BEGIN
p := q^.rlink;
h := TRUE
END
ELSE
BEGIN
del(q^.llink, h);
IF h THEN BalLeft(p, h)
END;
(* FreeMem(q^.data, q^.dataLen); { responsibility of calling program } *)
FreeMem(q^.key, q^.keyLen);
FreeMem(q, SizeOf(treeNode));
END
END; (* GenAvlTrDel *)

PROCEDURE GenAvlTrDis(root : treePtr;tab : INTEGER);
VAR space, k : INTEGER;
BEGIN
IF root <> NIL THEN
BEGIN
IF root^.rlink <> NIL THEN
BEGIN
GenAvlTrDis(root^.rlink,tab + tabinc)
END;
FOR space := 1 to tab DO
write(' ');
FOR k := 1 to 6 DO
write(root^.data^[k]);
writeln(' ',root^.bf);
IF root^.llink <> NIL THEN
BEGIN
GenAvlTrDis(root^.llink,tab + tabinc)
END
END (* root # nil *)
ELSE
writeln('Nil')
END (* GenAvlTrDis *);

PROCEDURE GenAvlTrRetDelSmRec(VAR p : treePtr; VAR key, data : dataPtr;
VAR keyLen, dataLen : WORD; VAR h : BOOLEAN);
VAR q : treePtr;
BEGIN
q := p;
WHILE p^.llink <> NIL DO
BEGIN
p := p^.llink
END;
data := p^.data;
dataLen := p^.dataLen;
key := p^.key;
keyLen := p^.keyLen;
p := q;
GenAvlTrDel(key, p, h);
END; (* GenAvlTrDel *)

BEGIN
END.