uses crt;
type
ptr =^pohon;
pohon = record
isi : byte;
left,right : ptr;
code : -1..+1;
end;
var
pil : char;
check : boolean;
root,now : ptr;
jml,x,y : byte;
procedure create;
begin
root:=nil; now:=nil;
end;
procedure insert(var tree:ptr; var check:boolean; angka:byte);
var tr1,tr2:ptr;
begin
if tree=nil then
begin
new(tree);
check:=true;
with tree^do
begin
isi:=angka;
left:=nil;
right:=nil;
code:=0;
end
end else
if angka < tree^.isi then
begin
insert(tree^.left,check,angka);
if check then
case tree^.code of
+1 : begin
tree^.code:=0;
check:=false;
end;
0: tree^.code:=-1;
-1: begin
tr1:=tree^.left;
if tr1^.code=-1 then
begin
tree^.left :=tr1^.right;
tr1^.right :=tree;
tree^.code:=0;
tree :=tr1;
end else
begin
tr2:=tr1^.right;
tr1^.right:=tr2^.left;
tr2^.left :=tr1;
tree^.right :=tree;
if tr2^.code=-1 then
tree^.code:=+1
else
tree^.code:=0;
if tr2^.code=+1 then
tr1^.code:=-1
else
tr1^.code:=0;
tree:=tr2;
end;
tree^.code:=0; check:=false;
end
end
end
else
if angka > tree^.isi then
begin
insert(tree^.right,check,angka);
if check then
case tree^.code of
-1: begin
tree^.code:=0;
check:=false;
end;
0:tree^.code:=+1;
+1: begin
tr1:=tree^.right;
if tr1^.code=+1 then
begin
tree^.right:=tr1^.left;
tr1^.left:=tree;
tree^.code:=0; tree:=tr1;
end else
begin
tr2:=tr1^.left;
tr1^.left:=tr2^.right;
tr2^.right :=tr1;
tree^.right:=tr2^.left;
tr2^.left:=tree;
if tr2^.code=+1 then
tree^.code:=-1
else
tree^.code:=0;
if tr2^.code=-1 then
tr1^.code:=+1
else
tr1^.code:=0;
tree:=tr2;
end;
tree^.code:=0; check:=false;
end
end
end
else
check:=false;
end;
procedure delete(var tree:ptr; var check:boolean; angka:byte);
var bantu:ptr;
kd1,kd2 : -1..+1;
begin
case tree^.code of
-1:tree^.code:=0;
0: begin
tree^.code:=+1;
check:=false;
end;
+1: begin
r1:=tree^.right; kd1:=tr1.code;
if kd1 >= 0 then
begin
tree^.code:=+1; tr1^.code:=-1;
check:=false;
end else
begin
tr2:=tr1^.left; kd2:=tr2^.code;
tr1^left:=tr2^right; tr2^.right:=tr1;
tree^.right:=tr2.left; tr2.left:=tree;
if kd2=+1 then tree^.code:=-1 else
tree^.code:=0;
if kd2=-1 then tr1^.code:=+1 else
tr1^.code:=0;
tree:=tr2; tr2^.code:=0;
end
end
end
end;
Procedure BalanceL(var tree:ptr; var chaeck:boolean);
var
tr1,tr2 : ptr;
kd1,kd2 : -1..+1;
begin
case tree^.code of
1 : tree^.code:=0;
0:begin
tree^.code:=-1;
check:=false;
end;
-1:begin
tr1:=tree^.left; kd1:=tr1^.code;
if kd1 <= 0 then
begin
tree^.left:=tr1^.right; tr1.right:=tree;
if kd1=0 then
begin
tree^.code:=-1; tr1.code:=+1;
check:=false;
end else
begin
tree^.code:=0; tr1^.code:=0;
end;
tree:=tr1;
end else
begin
tr2:=tr1^.right; kd2:=tr2.code;
tr1^right:=tr2.left; tr2^left:=tr1;
tree^left:=tr2^right; tr2^.right:=tree;
if kd2=-1 then tree^.code:=+1 else
tree^.code:=0;
if kd2=+1 then tr1^.code:=-1 else
tr1^.code:=0;
tree:=tr2; tr2^code:=0;
end
end
end
end;
Procedure Pop(var Rd: ptr; var check:boolean);
begin
if Rd^.right <> nil then
begin
Pop(Rd^.right,check);
if check then balanceL(Rd,Check);
end else
begin
bantu^.isi:=Rd^.isi; Rd:=Rd^.left; Check:=true;
end
end;
begin
if tree=nil then
begin
gotoxy(15,18);write('Bilangan tersebut tidak ada');
check:=false;
end else
if angka < tree^.isi then
begin
delete(tree^.left,check,angka);
if check then BalanceR(tree,check);
end else
if angka > tree^.isi then
begin
delete(tree^.right,check,angka);
if check then balanceL(tree,check);
end else
begin
bantu:=tree;
if bantu^.right = nil then
begin
tree:=bantu^.left; check:= true;
end else
if bantu^.left = nil then
begin
tree:= bantu^.right; check:=true;
end else
begin
pop(bantu^.left,check);
if check then balanceR(tree,check);
end
end
end:
Procedure Search(var tree:ptr; x,y,selisih,cari:byte);
begin
inc(y,2);
if cari < tree^.isi then
begin
if tree^.left <> nil then
search(tree^left, x-selisih,y,selisih div 2,cari)
end else
if cari > tree^.isi then
begin
if tree^.right <> nil then
search(tree^.right, x+selisih,y,selisih div 2,cari)
end else
if cari = tree^.isi then
begin
dec(y,2);
gotoxy(x,y); textcolor(10); write(cari);
gotoxy(15,20); write('Data Found'); readkey;
gotoxy(x,y); textcolor(15); write(cari);
gotoxy(15,20); write(' ':20);
end;
if((tree^.left=nil) or ( tree^.right=nil)) and
(cari <> tree^.isi) then
begin
gotoxy(15,20); write(cari,' Not Found'); delay(750);
gotoxy(15,20); write(' ' :20);
end;
end;
procedure preorder(tree:ptr);
begin
if x=75 then
begin
x:=18; inc(y);
end;
if tree<>nil then
begin
gotoxy(x,y); write(tree^.isi);inc(x,3);
preorder(tree^.left);
preorder(tree^.right);
end;
end;
procedure inorder(tree:ptr);
begin
if x=75 then
begin
x:=18; inc(y);
end;
if tree<>nil then
begin
inorder(tree^.left);
gotoxy(x,y); write(tree^.isi); inc(x,3);
inorder(tree^.right);
end;
end;
procedure postorder(tree:ptr);
begin
if tree<>nil then
begin
postorder(tree^.left);
postorder(tree^.right);
gotoxy(x,y); write(tree^.isi); inc(x,3);
if x=75 then
begin
x:=18; inc(y);
end;
end;
end;
procedure clear(tree:ptr);
begin
if(tree^.left) <> nil then
begin
clear(tree^.left);
tree^.left:=nil;
end;
if(tree^.right) <> nil then
begin
clear(tree^.right);
tree^.right:=nil;
end
if (tree^.left=nil) and (tree^right=nil) then dispose(Tree);
end;
procedure find(var ketemu:boolean; tree:ptr; angka:byte);
begin
ketemu:=false
if tree<>nil then
begin
if tree^.isi=angka then
begin
ketemu:=true;
exit;
end;
find(ketemu,tree^.left,angka);
end;
end;
procedure Frame(x1,y1,x2,y2);
var i : byte;
begin
gotoxy (x1,y1); write('['); gotoxy(x2,y1); write(']');
gotoxy (x1,y2); write('['); gotoxy(x2,y2); write(']');
for i := (x1+1) to (x2-1) do
begin
gotoxy(i,y1); write('-')
gotoxy(i,y2); write('-');
end;
for i := (y1+1) to (y2-1) do
begin
gotoxy(x1,i); write('I');
gotoxy(x2,i); write('I');
end;
end;
procedure screen(x1,y1,x2,y2:byte);
begin
clrscr; window(x1,y1,x2,y2); TextBackground(BLUE);
clrscr; window(1,1,80,25); frame(x1,y1.x2,y2);
end;
procedure show(var tree:ptr; x,y,sel:byte);
var i:byte;
begin
gotoxy(x,y); write(tree^.isi);
if(tree^.left <> nil) or (tree^.right <> nil) then
begin
gotoxy(x-sel,y+1); write('[');
gotoxy(x+sel,y+1); write(']');
for i := (x-sel)+1 to (x+sel)-1 do
begin
gotoxy(i,y+1); write('-');
end;
gotoxy('+');
end;
inc(y,2);
if tree^.left <> nil then show(tree^.left,x-sel,y,sel div 2);
if tree^.right <> nil then show(tree^.right,x+sel,y,sel div 2);
end;
procedure cursoroff;assembler;
asm
mov ah,1;
mov cx,0100h;
int 10h;
end;
procedure cursoron;assembler;
asm
mov ah,1;
mov cx,0607h;
int 10h;
end;
procedure screen2;
begin
clrscr;
cursoroff;
textattr:=15;
screen(2,15,79,24);
TextBackground(black);
if root <> nil then show(root,40,1,20);
cursor on;
textbackground(blue);
end;
procedure menu;
var ketemu : boolean;
temp1, temp2 : byte;
begin
gotoxy(30,5); write('Menu AVL Tree ')'
gotoxy(25,6); write('============================= ');
gotoxy(28,8); write('1.Create ');
gotoxy(28,9); write('2.Insert ');
gotoxy(28,10); write('3.Delete ');
gotoxy(28,11); write('4.Search ');
gotoxy(28,12); write('5.Update ');
gotoxy(28,13); write('6.Travers');
gotoxy(28,14); write('7.Clear ');
gotoxy(28,15); write('8.Exit ');
gotoxy(28,17); write('Pilihan Anda : ');
repeat
pil:=readkey;
gotoxy(42,17);write(Pil);delay(100);
if not(pil in['1'..'8']) then
begin
gotoxy(42,17);write(' ');
end;
until pil in('1'..'8');
clrscr;
TextAttr:=15;
Screen(2,15,79,24);
case pil of
'1' : begin
create; jml:=0;
end;
'2' : begin
repeat
screen2;
gotoxy(63,15); write('Jumlah Node : ',jml);
gotoxy(60,21);write('* 0 - - > exit *');
gotoxy(8,22); write('Maksimum Level :
5 - 6 (31 Nodes) ');
if(not ketemu) and (temp1<>0) and
(jml<31) then
begin
insert(root,check,temp1); inc(jml);
end else
if(temp1<>0) and (jml>=31) then
begin
gotoxy(15,20); write('The Level is
Maximum');
delay(750);
end else
if ketemu then
begin
gotoxy(15,20);write(temp1,' is
Existed');
delay(750);
end;
until ( temp1= 0);
end;
'3' : begin
repeat
screen2;
gotoxy(63,15);write('Jumlah Node : ',jml);
gotoxy(60,21);write('* 0 - -> exit *');
gotoxy(15,19);write('Delete : '); readln(temp1);
if temp1=0 then exit;
find(ketemu,root,temp1);
if ketemu and (jml<>0) then
begin
delete(root,check,temp1);dec(jml);
end else
if jml=0 then
begin
gotoxy(15,20);write('The Tree Is Empty');
delay(750);
end else
begin
gotoxy(15,20);write(temp1,' Not Found');
delay(750);
end;
gotoxy(15,20);write(' ':25);
until (temp1=0);
end;
'4' : begin
repeat
screen2;
gotoxy(63,15);write('Jumlah Node : ',jml);
gotoxy(60,21);write('* 0 - -> exit *');
gotoxy(15,19);write('Search : ');Readln(temp1);
if temp1=0 then exit;
if jml>0 then search(root,40,1,20,temp1) else
begin
gotoxy(15,20);write(The Tree Is
Empty '); delay(750);
end;
gotoxy(15,20);write(' ':25);
until temp1=0;
end;
'5' : begin
repeat
screen2;
gotoxy(63,15);write('Jumlah Node : ',jml);
gotoxy(60,21);write('* 0 - -> exit *');
gotoxy(15,19);write('Update: '); Readln(temp1);
if temp1=0 then exit;
find(ketemu,root,temp1);
if ketemu then
begin
gotoxy(15,20);write('with : ');
Readln(temp2);
find(ketemu,root,temp2);
if not ketemu then
begin
Delete(root,Check,temp1);
Insert(Root,Check,temp2);
end else
begin
gotoxy(15,21);write(temp2,'
is Existed'); delay(750);
gotoxy(15,21);write(' ':20);
end;
end else
if jml=0 then
begin
gotoxy(15,20);write('The Tree Is Empty');
delay(750);
end else
begin
gotoxy(15,20);write(temp1,' Not Found');
delay(750);
end;
gotoxy(22,19);write(' ': 6); gotoxy(15,20);
write(' ': 15);
until temp1=0
end;
'6' : begin
screen2;
gotoxy(63,15);write('Jumlah Node : ',jml);
gotoxy(33,16);write('*** Transversal *** ');
gotoxy(5,18);write('Pre Order : ');
x:=18;y:=18;PreOrder(root);
gotoxy(5,20);write('In Order : ');
x:=18;y:=20;InOrder(root);
gotoxy(5,22);write('Post Order : ');
x:=18;y:=22;PostOrder(root);
ReadKey;
end;
'7' : begin
if root<>nil then Clear(root);
create;
jml:=0;
end;
'8' : begin
exit;
end;
end;
end;
begin
clrscr;
jml:=0;
repeat
TextAttr:=15;
Screen (20,3,60,18);
Menu;
until pil='8';
end.
Tidak ada komentar:
Posting Komentar