АВЛ - деревья / AVLtree1

unit AVLtree1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Menus;

type
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
Button3: TButton;
Button4: TButton;
Button5: TButton;
OpenDialog1: TOpenDialog;
Label1: TLabel;
Label2: TLabel;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N4: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
N7: TMenuItem;
N3: TMenuItem;
Label3: TLabel;
procedure FormCreate(Sender: TObject);
procedure Insert1(Sender: TObject);
procedure Delete1(Sender: TObject);
procedure Exit1(Sender: TObject);
procedure Print(Sender: TObject);
procedure Paint(Sender: TObject);
procedure Intf(Sender: TObject);
procedure Ins1(Sender: TObject);
procedure Del1(Sender: TObject);
procedure Insn(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

type
elem=record
val:integer;
r,l:integer;
hr,hl:integer;
f:integer
end;
tree=record
nom:array [1..100]of elem;
kol:integer
end;

var b:tree;

implementation

{$R *.dfm}

procedure line(x1,y1,x2,y2:integer);
begin
form1.Canvas.MoveTo(x1,y1);
form1.Canvas.LineTo(x2,y2);
end;


function check(s:string):boolean;
var c,n:integer;
begin
val(s,n,c);
if c<>0 then check:=false else check:=true

end;

procedure printtree(var t:tree);
var i,put,x1,y1,sm:integer;

procedure print(x,y,n,sm:integer;var tr:tree);
begin
form1.Canvas.Pen.Color:=clred;
form1.Canvas.Brush.Color:=clgreen;
form1.Canvas.Ellipse(x-10,y-10,x+20,y+20);
form1.Canvas.TextOut(x,y,inttostr(tr.nom[n].val));
sm:=sm div 2;

if tr.nom[n].r<>0 then begin
line(x+15,y+15,x+sm,y+70);
print(x+sm,y+70,tr.nom[n].r,sm,tr);
end;

if tr.nom[n].l<>0 then begin
line(x-10,y+10,x-sm,y+70);
print(x-sm,y+70,tr.nom[n].l,sm,tr);
end;
end;

begin
form1.Canvas.Brush.Color:=clwhite;
form1.Canvas.Rectangle(20,30,400,430);
i:=1;
while t.nom[i].f<>0 do i:=i+1;
put:=i;
x1:=200;
y1:=50;
sm:=200;
print(x1,y1,put,sm,t);
end;


{Вращение верева вправо}
procedure reverseR(n:integer;var t:tree);
var m,i,put,h:integer;
begin
m:=t.nom[n].l;
t.nom[m].f:=t.nom[n].f;
t.nom[n].f:=m;
t.nom[n].l:=t.nom[m].r;
t.nom[m].r:=n;
t.nom[n].hl:=t.nom[m].hr;
t.nom[m].hr:=t.nom[n].hr+1;
i:=t.nom[m].f;
if i<>0 then begin
if t.nom[i].val<t.nom[m].val then t.nom[i].r:=m
else t.nom[i].l:=m;
end;

put:=m;
while put<>0 do begin
if t.nom[put].hr>=t.nom[put].hl then h:=t.nom[put].hr
else h:=t.nom[put].hl;
m:=put;
put:=t.nom[put].f;
if put<>0 then begin
if t.nom[put].val<t.nom[m].val then t.nom[put].hr:=h+1
else t.nom[put].hl:=h+1;
end;
end;
end;

{Вращение дерева влево}
procedure reverseL(n:integer;var t:tree);
var m,i,put,h:integer;
begin
m:=t.nom[n].r;
t.nom[m].f:=t.nom[n].f;
t.nom[n].f:=m;
t.nom[n].r:=t.nom[m].l;
t.nom[m].l:=n;
t.nom[n].hr:=t.nom[m].hl;
t.nom[m].hl:=t.nom[n].hl+1;
i:=t.nom[m].f;
if i<>0 then begin
if t.nom[i].val<t.nom[m].val then t.nom[i].r:=m
else t.nom[i].l:=m;
end;

put:=m;
while put<>0 do begin
if t.nom[put].hr>=t.nom[put].hl then h:=t.nom[put].hr
else h:=t.nom[put].hl;
m:=put;
put:=t.nom[put].f;
if put<>0 then begin
if t.nom[put].val<t.nom[m].val then t.nom[put].hr:=h+1
else t.nom[put].hl:=h+1;
end;
end;
end;

procedure otlad(var t:tree);
var i:integer;

procedure otl1(x:integer;var tr:tree);
begin
if (tr.nom[x].hl-tr.nom[x].hr)>1 then reverseR(x,tr)
else
if (tr.nom[x].hr-tr.nom[x].hl)>1 then reverseL(x,tr);
if tr.nom[x].r<>0 then otl1(tr.nom[x].r,tr);
if tr.nom[x].l<>0 then otl1(tr.nom[x].l,tr);
end;

begin
for i:=1 to t.kol do
otl1(i,t);
end;




procedure TForm1.FormCreate(Sender: TObject);
var i:integer;
begin
b.kol:=0;
for i:=1 to 100 do begin
b.nom[i].val:=0;
b.nom[i].r:=0;
b.nom[i].l:=0;
b.nom[i].hr:=0;
b.nom[i].hl:=0;
b.nom[i].f:=0;
end;
end;





procedure TForm1.Insert1(Sender: TObject);
var x,i,put,m,n:integer;
prod:boolean;
begin
if check(edit1.Text) then begin

x:=strtoint(edit1.Text);

prod:=true;
for i:=1 to b.kol do
if b.nom[i].val=x then prod:=false;
if prod then begin


if b.kol=0 then begin
b.nom[1].val:=x;
b.kol:=1
end else begin
{Дерево не пусто}
i:=1;
while b.nom[i].f<>0 do i:=i+1;
put:=i;
m:=0;
while put<>0 do begin
m:=put;
if b.nom[put].val<x then put:=b.nom[put].r;
if b.nom[put].val>x then put:=b.nom[put].l;
end;

b.kol:=b.kol+1;
n:=b.kol;
b.nom[n].val:=x;
b.nom[n].f:=m;
{Если в правое поддерево}
if b.nom[m].val<x then begin
b.nom[m].r:=b.kol;
b.nom[m].hr:=b.nom[m].hr+1;
put:=m;
while put<>0 do begin
if b.nom[put].hr>b.nom[put].hl then begin
n:=put;put:=b.nom[put].f;
if b.nom[put].val<b.nom[n].val then
b.nom[put].hr:=b.nom[put].hr+1
else b.nom[put].hl:=b.nom[put].hl+1;
end else put:=0;
end;
end;
{Если в левое поддерево}
if b.nom[m].val>x then begin
b.nom[m].l:=b.kol;
b.nom[m].hl:=b.nom[m].hl+1;
put:=m;
while put<>0 do begin
if b.nom[put].hl>b.nom[put].hr then begin
n:=put;put:=b.nom[put].f;
if b.nom[put].val<b.nom[n].val then
b.nom[put].hr:=b.nom[put].hr+1
else b.nom[put].hl:=b.nom[put].hl+1;
end else put:=0;
end;
end;
end;
otlad(b);
if b.kol<>0 then printtree(b);
end;
end;
end;

procedure TForm1.Delete1(Sender: TObject);
var x,k,i,n,put,m,h:integer;
prod:boolean;
begin
if check(edit1.Text) then begin
x:=strtoint(edit1.Text);

if b.kol<>0 then begin
i:=1;
prod:=true;
while (b.nom[i].val<>x)and(i<>b.kol) do i:=i+1;
if (i=b.kol) and (b.nom[i].val<>x) then prod:=false;

if prod then begin
n:=i;
{Вращение правого, чтобы добраться до элемента}
if b.nom[n].hr>=b.nom[n].hl then begin
while b.nom[n].l<>0 do reverseR(n,b);
m:=b.nom[n].r;
b.nom[m].f:=b.nom[n].f;
k:=b.nom[n].f;
b.nom[k].hr:=b.nom[k].hr-1;
if b.nom[k].val>b.nom[m].val then b.nom[k].l:=m
else b.nom[k].r:=m;

put:=m;
while put<>0 do begin
if b.nom[put].hr>=b.nom[put].hl then h:=b.nom[put].hr
else h:=b.nom[put].hl;
m:=put;
put:=b.nom[put].f;
if put<>0 then begin
if b.nom[put].val<b.nom[m].val then b.nom[put].hr:=h+1
else b.nom[put].hl:=h+1;
end;
end;

end else begin {Вращение левого }
while b.nom[n].r<>0 do reversel(n,b);
m:=b.nom[n].l;
b.nom[m].f:=b.nom[n].f;
k:=b.nom[n].f;
b.nom[k].hl:=b.nom[k].hl-1;
if b.nom[k].val>b.nom[m].val then b.nom[k].l:=m
else b.nom[k].r:=m;

put:=m;
while put<>0 do begin
if b.nom[put].hr>=b.nom[put].hl then h:=b.nom[put].hr
else h:=b.nom[put].hl;
m:=put;
put:=b.nom[put].f;
if put<>0 then begin
if b.nom[put].val<b.nom[m].val then b.nom[put].hr:=h+1
else b.nom[put].hl:=h+1;
end;
end;
end;

{Смещение записей в карте}
for i:=n to b.kol-1 do begin
b.nom[i].val:=b.nom[i+1].val;

if (b.nom[i+1].r>=n)and(b.nom[i+1].r<>0) then
b.nom[i].r:=b.nom[i+1].r-1
else b.nom[i].r:=b.nom[i+1].r;

if (b.nom[i+1].l>=n)and(b.nom[i+1].l<>0) then
b.nom[i].l:=b.nom[i+1].l-1
else b.nom[i].l:=b.nom[i+1].l;

b.nom[i].hr:=b.nom[i+1].hr;
b.nom[i].hl:=b.nom[i+1].hl;

if (b.nom[i+1].f>=n)and(b.nom[i+1].f<>0) then
b.nom[i].f:=b.nom[i+1].f-1
else b.nom[i].f:=b.nom[i+1].f;
end;
b.kol:=b.kol-1;

for i:=1 to n-1 do begin
if (b.nom[i].r>=n)and(b.nom[i].r<>0) then
b.nom[i].r:=b.nom[i].r-1
else b.nom[i].r:=b.nom[i].r;

if (b.nom[i].l>=n)and(b.nom[i].l<>0) then
b.nom[i].l:=b.nom[i].l-1
else b.nom[i].l:=b.nom[i].l;

if (b.nom[i].f>=n)and(b.nom[i].f<>0) then
b.nom[i].f:=b.nom[i].f-1
else b.nom[i].f:=b.nom[i].f;
end;
end;
otlad(b);
if b.kol<>0 then printtree(b);

end;

end;
end;


procedure TForm1.Exit1(Sender: TObject);
begin
form1.Close
end;

procedure TForm1.Print(Sender: TObject);
begin
if b.kol<>0 then begin
printtree(b);
end;
end;




procedure TForm1.Paint(Sender: TObject);
begin
form1.Canvas.Brush.Color:=clwhite;
form1.Canvas.Rectangle(20,30,400,430);
end;



procedure TForm1.Intf(Sender: TObject);
var f:textfile;
x:integer;
begin
if form1.OpenDialog1.Execute then begin
assignfile(f,opendialog1.FileName);
reset(f);
while not eof(f) do begin
read(f,x);
edit1.Text:=inttostr(x);
button1.Click
end;
end;
end;




procedure TForm1.Ins1(Sender: TObject);
begin
form1.Button1.Click;
end;

procedure TForm1.Del1(Sender: TObject);
begin
form1.Button3.Click;
end;

procedure TForm1.Insn(Sender: TObject);
var fs:textfile;
s:string;
x:integer;
begin
s:=edit1.Text;
assignfile(fs,'avltree.txt');
rewrite(fs);
write(fs,s);
closefile(fs);
reset(fs);
while not eof(fs) do begin
read(fs,x);
edit1.Text:=inttostr(x);
button1.Click
end;
end;

end.