Interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
Menus;
type
TPNode = ^TNode;
TNode = record
Data : Integer;
Pleft : TPNode;
Pright : TPNode;
depth : -1..1;
end;
type
{ TForm3 }
TForm3 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Edit1: TEdit;
Edit2: TEdit;
Image1: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
MainMenu1: TMainMenu;
Memo1: TMemo;
MenuItem1: TMenuItem;
MenuItem2: TMenuItem;
PaintBox1: TPaintBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Edit1KeyPress(Sender: TObject; var Key: char);
procedure Edit2KeyPress(Sender: TObject; var Key: char);
procedure FormClose(Sender: TObject);
procedure MenuItem2Click(Sender: TObject);
procedure TreeWriteln(const aPNode : TPNode; const aName : String; aSL : TStrings);
procedure Draw(aName : String);
procedure DrawText (aName, aPNode_date : String);
procedure TreeFree(var aPNode : TPNode);
procedure find(const aPNode : TPNode; const aName : String);
private
public
end;
var
Form3: TForm3;
AVL : TPNode;//указатель на веришину дерева
b : boolean;
cs,x : Integer;
rez:string;
Implementation
{$R *.lfm}
procedure PrightTurn(var p : TPNode);
var
tmp : TPNode;
begin
tmp := p^.Pleft;
p^.Pleft := tmp^.Pright;
tmp^.Pright := p;
p^.depth := 0;
p := tmp;
end;
procedure PleftTurn(var p : TPNode);
var
tmp : TPNode;
begin
tmp := p^.Pright;
p^.Pright := tmp^.Pleft;
tmp^.Pleft := p;
p^.depth := 0;
p := tmp;
end;
procedure PrightPleftTurn(var p : TPNode);
var
tmp : TPNode;
t : TPNode;
begin
tmp := p^.Pleft;
t := tmp^.Pright;
tmp^.Pright := t^.Pleft;
t^.Pleft := tmp;
p^.Pleft := t^.Pright;
t^.Pright := p;
if (t^.depth = -1)
then
p^.depth := 1
else
p^.depth := 0;
if (t^.depth = 1)
then
tmp^.depth := -1
else
tmp^.depth := 0;
p := t;
end;
procedure PleftPrightTurn(var p : TPNode);
var
tmp : TPNode;
t : TPNode;
begin
tmp := p^.Pright;
t := tmp^.Pleft;
tmp^.Pleft := t^.Pright;
t^.Pright := tmp;
p^.Pright := t^.Pleft;
t^.Pleft := p;
if (t^.depth = 1)
then
p^.depth := -1
else
p^.depth := 0;
if (t^.depth = -1)
then
tmp^.depth := 1
else
tmp^.depth := 0;
p := t;
end;
procedure Add(x : Integer; var p : TPNode; var h : boolean);
begin
if (p = nil)
then // Если дерево пустое
begin
new(p);
h := true;
p^.Data := x;
p^.Pleft := nil;
p^.Pright := nil;
p^.depth := 0;
end
else
if (x < p^.Data)
then
begin
Add(x, p^.Pleft, h);
if h then //увеличиваем левую ветвь
case p^.depth of
1: begin
p^.depth := 0;
h := false;
end;
0: p^.depth:=-1;
-1: begin //балансировка
if (p^.Pleft^.depth = -1)
then
PrightTurn(p)
else
PrightPleftTurn(p);
p^.depth := 0;
h := false;
end;
end;
end
else
if (x > p^.Data)
then
begin
Add(x, p^.Pright, h);
if h then //увеличиваем правую ветвь
case p^.depth of
-1: begin
p^.depth := 0;
h := false;
end ;
0: p^.depth:=1;
1: begin //балансировка
if (p^.Pright^.depth = 1)
then
PleftTurn(p)
else
PleftPrightTurn(p);
p^.depth := 0;
h:= false;
end;
end;
end
else
h := false;
end;
procedure TForm3.find(const aPNode : TPNode; const aName : String);
begin
if aPNode <> nil then
begin
if edit2.text = inttostr(aPNode^.Data) then
rez:=aName;
find(aPNode^.PLeft, aName + '1'); //Рекурсивный вызов для левого поддерева.
find(aPNode^.PRight, aName + '2'); //Рекурсивный вызов для правого поддерева.
end;
end;
//Процедура для освобождения памяти, занятой деревом. (Удаление дерева).
procedure TForm3.TreeFree(var aPNode : TPNode);
begin
if aPNode = nil then
Exit;
TreeFree(aPNode^.PLeft); //Рекурсивный вызов для освобождения памяти в левом поддереве.
TreeFree(aPNode^.PRight); //Рекурсивный вызов для освобождения памяти в правом поддереве.
Dispose(aPNode); //Освобождение памяти, занятой для текущего узла.
aPNode := nil; //Обнуление указателя на текущий узел.
end;
procedure TForm3.TreeWriteln(const aPNode : TPNode; const aName : String; aSL : TStrings);
var
arrname: array of array of string;
i:integer;
begin
i:=0;
if aPNode <> nil then
begin
setlength(arrname,Length(arrname)+1,2);
arrname[i,0]:= aName;
arrname[i,1]:= IntToStr(aPNode^.Data);
inc(i);
aSL.Add(aName + ': ' + IntToStr(aPNode^.Data));
TreeWriteln(aPNode^.Pleft, aName + '1', aSL); //Рекурсивный вызов для левого поддерева.
TreeWriteln(aPNode^.Pright, aName + '2', aSL); //Рекурсивный вызов для правого поддерева.
end;
for i:=0 to Length(arrname)-1 do begin
Form3.Draw (arrname[i,0]);
Form3.DrawText (arrname[i,0], arrname[i,1]);
end;
arrname:=nil;
end;
procedure TForm3.Draw (aName : String); // Рисунок дерева
const
LevelHeight = 50;
var
s,s1:string;
i,x,y,dx:integer;
begin
PaintBox1.Canvas.Pen.Width:=3; // толщина линий
dx:= round(PaintBox1.Width / 5);
x:= round(PaintBox1.Width / 2);
y:=25;
s:='';
s1:='';
for i:=1 to length(aName) do begin
s:=copy(aName,i,1);
s1:=copy (aName,i-1,1);
if s='0' then begin
PaintBox1.Canvas.MoveTo(x,y);
end;
if s='1' then
begin
if s1='0' then
begin
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y) ;
PaintBox1.Canvas.Ellipse((x+(dx*2))-20,(y-LevelHeight)-20,(x+(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
if s1='1' then
begin
PaintBox1.Canvas.MoveTo(x,y);
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y);
PaintBox1.Canvas.Ellipse((x+(dx*2))-20,(y-LevelHeight)-20,(x+(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
if s1='2' then
begin
PaintBox1.Canvas.MoveTo(x,y);
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y);
PaintBox1.Canvas.Ellipse((x+(dx*2))-20,(y-LevelHeight)-20,(x+(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
end;
if s='2' then
begin
if s1='0' then
begin
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y) ;
PaintBox1.Canvas.Ellipse((x-(dx*2))-20,(y-LevelHeight)-20,(x-(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
if s1='1' then
begin
PaintBox1.Canvas.MoveTo(x,y);
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y);
PaintBox1.Canvas.Ellipse((x-(dx*2))-20,(y-LevelHeight)-20,(x-(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
if s1='2' then
begin
PaintBox1.Canvas.MoveTo(x,y);
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
PaintBox1.Canvas.lineTo(x,y);
PaintBox1.Canvas.Ellipse((x-(dx*2))-20,(y-LevelHeight)-20,(x-(dx*2))+20,(y-LevelHeight)+20);
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
end;
end;
end;
end;
procedure TForm3.DrawText (aName, aPNode_date : String); // Рисунок TEXT на дереве
const
LevelHeight = 50;
var
s,s1:string;
i,x,y,dx:integer;
begin
PaintBox1.Canvas.Font.Size := 8;
PaintBox1.Canvas.Font.Name := 'courier';
dx:= round(PaintBox1.Width / 5);
x:= round(PaintBox1.Width / 2);
y:=25;
s:='';
s1:='';
if length(aName) = 1 then begin
PaintBox1.Canvas.Ellipse(x-20,y-20,x+20,y+20);
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
for i:=1 to length(aName) do begin
s:=copy(aName,i,1);
s1:=copy (aName,i-1,1);
if s='1' then
begin
if s1='0' then
begin
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
if s1='1' then
begin
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
if s1='2' then
begin
x:= x-dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
end;
if s='2' then
begin
if s1='0' then
begin
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
if s1='1' then
begin
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
if s1='2' then
begin
x:= x+dx;
y:=y+LevelHeight;
dx:=round(dx/2);
if i = length(aName) then
PaintBox1.Canvas.TextOut(x-5,y-5,aPNode_date);
end;
end;
end;
end;
{ TForm3 }
procedure TForm3.Button1Click(Sender: TObject); // добавить
begin
if edit1.text = '' then begin
Label1.Caption := 'Нет значения!';;
exit;
end;
Add(strtoint(edit1.text), AVL, b);
Label1.Caption := edit1.text;
edit1.clear;
end;
procedure TForm3.Button2Click(Sender: TObject); // Найти
begin
if edit2.text = '' then begin
showmessage ('Ошибка! Введите значение');
exit;
end;
if AVL = nil then begin
showmessage ('Дерево пустое!');
exit;
end;
rez:='';
find (AVL,'0'); // Поиск
if rez = '' then
Memo1.Lines.Add('Вершина: ' + edit2.text + '; Не найдена!')
else
Memo1.Lines.Add('Вершина: ' + edit2.text + '; Адрес: ' + rez);
edit2.clear;
end;
procedure TForm3.Button3Click(Sender: TObject); // печать
begin
Memo1.Lines.Add('-----');
Memo1.Lines.Add('Дерево:');
if AVL = nil then
Memo1.Lines.Add('Дерево пустое.')
else
TreeWriteln(AVL, '0', Memo1.Lines);
end;
procedure TForm3.Button4Click(Sender: TObject); // Очистить данные
begin
TreeFree(AVL); //Освобождение памяти, занятой для элементов дерева (очистка дерева).
Memo1.clear;
Memo1.Lines.Add('Память, выделенная для дерева - освобождена.');
PaintBox1.Invalidate; // Очищает рисунок фон оставляет прозрачным
end;
procedure TForm3.Edit1KeyPress(Sender: TObject; var Key: char); // Ограничение ввода
begin
if not (Key in ['0'..'9', #8]) then
if not (Key in ['-', #8]) then
Key := #0;
end;
procedure TForm3.Edit2KeyPress(Sender: TObject; var Key: char); // Ограничение ввода
begin
if not (Key in ['0'..'9', #8]) then
if not (Key in ['-', #8]) then
Key := #0;
end;
procedure TForm3.FormClose(Sender: TObject);
begin
TreeFree(AVL); //Освобождение памяти, занятой для элементов дерева (очистка дерева).
end;
procedure TForm3.MenuItem2Click(Sender: TObject); // Задание
begin
Showmessage('Ввести 10-15 целых чисел и построить из них АВЛ-дерево. Выпол'+
'нить операцию поиска указанных элементов в АВЛ-дереве.');
end;
end.
Листинг программы Задание 3:
unit Unit4;
{$mode objfpc}{$H+}