``````{
> Does anyone have code(preferably TP) the implements AVL trees?
> I'm having trouble With the insertion part of it.  I'm writing a small
> parts inventory Program For work(although I'm not employed as a
> Programmer) and the AVL tree would be very fast For it.
}

Program avl;

Type
nodeptr = ^node;
node    = Record
key   : Char;
bal   : -1..+1; { bal = h(right) - h(left) }
left,
right : nodeptr
end;

tree = nodeptr;

Var
t : tree;
h : Boolean; { insert & delete parameter }

Procedure maketree(Var t : tree);
begin
t := nil;
end;

Function member(k : Char; t : tree) : Boolean;
begin { member }
if t = nil then
member := False
else
if k = t^.key then
member := True
else
if k < t^.key then
member := member(k, t^.left)
else
member := member(k, t^.right);
end;

Procedure ll(Var t : tree);
Var
p : tree;
begin
p := t^.left;
t^.left  := p^.right;
p^.right := t;
t := p;
end;

Procedure rr(Var t : tree);
Var
p : tree;
begin
p := t^.right;
t^.right := p^.left;
p^.left  := t;
t := p;
end

Procedure lr(Var t : tree);
begin
rr(t^.left);
ll(t);
end;

Procedure rl(Var t : tree);
begin
ll(t^.right);
rr(t);
end;

Procedure insert(k : Char; Var t : tree; Var h : Boolean);

Procedure balanceleft(Var t : tree; Var h : Boolean);
begin
Writeln('balance left');
Case t^.bal of
+1 :
begin
t^.bal := 0;
h := False;
end;
0 : t^.bal := -1;
-1 :
begin { rebalance }
if t^.left^.bal = -1 then
begin { single ll rotation }
Writeln('single ll rotation');
ll(t);
t^.right^.bal := 0;
end
else { t^.left^.bal  = +1 }
begin  { double lr rotation }
Writeln('double lr rotation');
lr(t);
if t^.bal = -1 then
t^.right^.bal := +1
else
t^.right^.bal := 0;
if t^.bal = +1 then
t^.left^.bal := -1
else
t^.left^.bal := 0;
end;
t^.bal := 0;
h := False;
end;
end;
end;

Procedure balanceright(Var t : tree; Var h : Boolean);
begin
Writeln('balance right');
Case t^.bal of
-1 :
begin
t^.bal := 0;
h := False;
end;
0 : t^.bal := +1;
+1 :
begin { rebalance }
if t^.right^.bal = +1 then
begin { single rr rotation }
Writeln('single rr rotation');
rr(t);
t^.left^.bal := 0
end
else { t^.right^.bal  = -1 }
begin  { double rl rotation }
Writeln('double rl rotation');
rl(t);
if t^.bal = -1 then
t^.right^.bal := +1
else
t^.right^.bal := 0;
if t^.bal = +1 then
t^.left^.bal := -1
else
t^.left^.bal := 0;
end;
t^.bal := 0;
h := False;
end;
end;
end;

begin { insert }
if t = nil then
begin
new(t);
t^.key   := k;
t^.bal   := 0;
t^.left  := nil;
t^.right := nil;
h := True;
end
else
if k < t^.key then
begin
insert(k, t^.left, h);
if h then
balanceleft(t, h);
end
else
if k > t^.key then
begin
insert(k, t^.right, h);
if h then
balanceright(t, h);
end;
end;

Procedure delete(k : Char; Var t : tree; Var h : Boolean);

Procedure balanceleft(Var t : tree; Var h : Boolean);
begin
Writeln('balance left');
Case t^.bal of
-1 :
begin
t^.bal := 0;
h := True;
end;
0 :
begin
t^.bal := +1;
h := False;
end;
+1 :
begin { rebalance }
if t^.right^.bal >= 0 then
begin
Writeln('single rr rotation'); { single rr rotation }
if t^.right^.bal = 0 then
begin
rr(t);
t^.bal := -1;
h := False;
end
else
begin
rr(t);
t^.left^.bal := 0;
t^.bal := 0;
h := True;
end;
end
else { t^.right^.bal  = -1 }
begin
Writeln('double rl rotation');
rl(t);
t^.left^.bal := 0;
t^.right^.bal := 0;
h := True;
end;
end;
end;
end;

Procedure balanceright(Var t : tree; Var h : Boolean);
begin
Writeln('balance right');
Case t^.bal of
+1 :
begin
t^.bal := 0;
h := True;
end;
0 :
begin
t^.bal := -1;
h := False;
end;
-1 :
begin { rebalance }
if t^.left^.bal <= 0 then
begin { single ll rotation }
Writeln('single ll rotation');
if t^.left^.bal = 0 then
begin
ll(t);
t^.bal := +1;
h := False;
end
else
begin
ll(t);
t^.left^.bal := 0;
t^.bal := 0;
h := True;
end;
end
else { t^.left^.bal  = +1 }
begin  { double lr rotation }
Writeln('double lr rotation');
lr(t);
t^.left^.bal := 0;
t^.right^.bal := 0;
h := True;
end;
end;
end;
end;

Function deletemin(Var t : tree; Var h : Boolean) : Char;
begin { deletemin }
if t^.left = nil then
begin
deletemin := t^.key;
t := t^.right;
h := True;
end
else
begin
deletemin := deletemin(t^.left, h);
if h then
balanceleft(t, h);
end;
end;

begin { delete }
if t <> nil then
begin
if k < t^.key then
begin
delete(k, t^.left, h);
if h then
balanceleft(t, h);
end
else
if k > t^.key then
begin
delete(k, t^.right, h);
if h then
balanceright(t, h);
end
else
if (t^.left = nil) and (t^.right = nil) then
begin
t := nil;
h := True;
end
else
if t^.left = nil then
begin
t := t^.right;
h := True;
end
else
if t^.right = nil then
begin
t := t^.left;
h := True;
end
else
begin
t^.key := deletemin(t^.right, h);
if h then
balanceright(t, h);
end;
end;
end;

begin
end.

``````