uses crt;
type
pointer = ^ptr;
ptr = record
isi : byte;
left,right : pointer;
end;
var
x,y,sel,pil : byte;
tree,root,now : pointer;
procedure create;
begin
root:=nil; tree:=nil;
end;
procedure clear;
begin
if root<>nil then
begin
tree:=root; dispose(tree); root:=nil;
end;
end;
procedure push(var tree:pointer; bil:byte);
begin
if tree=nil then
begin
new(tree);
tree^.isi :=bil;
tree^.right:=nil;
tree^.left:=nil;
end else
if tree^.isi < bil then
push(tree^.right,bil)
else
push(tree^.left,bil);
end;
procedure find(var ketemu:boolean; tree:pointer; 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);
if not ketemu then
find(ketemu,tree^.right,angka);
end;
end;
procedure show(var tree:pointer; 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(x,y+1); write('+');
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 checklevel(var tree:pointer; var level:byte; bil:byte);
begin
if tree<>nil then
begin
inc(level);
if tree^.isi < bil then
checklevel(tree^.right,level,bil)
else
checklevel(tree^.left,level,bil);
end;
end;
procedure insert;
var
isi,level : byte;
ketemu : boolean;
begin
repeat
clrscr;
gotoxy(30,1);write('Insert Binary Search Tree');
gotoxy(27,2);write('=========================');
if root<>nil then show(root,40,5,20);
repeat
gotoxy(3,4);clreol;write('Insert [Level max :5] = ');
readln(isi);
until isi in [0..100];
if isi=0 then exit;
level:=1;
checklevel(root,level,isi);
find(ketemu,root,isi);
if(NOT ketemu) and (level<=5) then push(root,isi) else
begin
Textcolor(12);
gotoxy(3,5);write('Level Maksimum/Bil sudah ada');
delay(750);
Textcolor(15);
end;
until isi=0;
end;
procedure delete(var tree:pointer; bil:byte);
var temp:pointer;
begin
if tree=nil then
begin
Textcolor(12);gotoxy(2,4);write(bil, 'tidak ada');
Textcolor(15);
end else
if bil < tree^.isi then
delete(tree^.left,bil)
else if bil > tree^.isi then
delete(tree^.right,bil)
else if tree^.left = nil then
begin
temp:=tree^.right;
dispose(tree);
tree:=temp;
end
else if tree^.right=nil then
begin
temp:=tree^.left;
dispose(tree);
tree:=temp;
end else
begin
temp:=tree^.right;
while temp^.left <> nil do
temp:=temp^.left;
tree^.isi :=temp^.isi;
delete(tree^.right,temp^.isi);
end
end;
procedure update;
var
ketmu :boolean;
bil,bil2,level : byte;
begin
repeat
clrscr;
gotoxy(30,1);write('Update Binary Search Tree');
gotoxy(27,2);write('===============================');
if root<>nil then show(root,40,5,20);
gotoxy(2,3);write('Update [0-->exit] = '); readln(bil);
find(ketemu,root,bil);
if NOT ketemu then
begin
gotoxy(2,4);write(bil,'tidak ada'');
end else
begin
gotoxy(2,4);write('dengan =');readln(bil2);
find (ketemu,root,bil2);
level:=1;
checklevel(root,level,bil2);
if (NOT ketemu) and (level<=5) then
begin
delete(root,bil);
push(root,bil2);
end else
begin
textcolor(12);
gotoxy(3,5);write('Bil sudah ada/Level sudah Max');
delay(750);
Textcolor(15);
end;
end;
until bil=0;
end;
procedure preorder(tree:pointer);
begin
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:pointer);
begin
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:pointer);
begin
if tree<>nil then
begin
postorder(tree^.left);
postorder(tree^.right);
gotoxy(x,y);write(tree^.isi);inc(x,3);
end;
end;
procedure search(var tree:pointer; 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 <> nl 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(12); write(cari);
gotoxy(2,4); write(cari,' Ketemu');Readkey;
gotoxy(x,y); textcolor(15); write(cari);
gotoxy(2,4); write(' ':20);
end;
end;
procedure menu;
var
bil : byte;
sign : char;
ketemu : boolean;
begin
clrscr;
gotoxy(25,3);write('Menu Binary Search Tree');
gotoxy(23,4);write('==========================');
gotoxy(28,6);write('1.Create');
gotoxy(28,7);write('2.Insert');
gotoxy(28,8);write('3.Delete');
gotoxy(28,9);write('4.Search');
gotoxy(28,10);write('5.Update');
gotoxy(28,11);write('6.Traverse');
gotoxy(28,12);write(7.Clear');
gotoxy(28,13);write(8.Exit');
repeat
gotoxy(25,15);clreol;write('Pilihan Anda [1..8] : ');
readln(pil);
until pil in [1..8];
case pil of
1: Create;
2: Insert;
3: begin
repeat
clrscr;
gotoxy(30,1);write('Delete Binary Search Tree');
gotoxy(27,2);write('==========================');
if root<>nil then show(root,40,5,20);
gotoxy(2,3);write('Delete [0-->exit] = ');
readln(bil);
delete(rot,bil);
until bil =0;
end;
4 : begin
repeat
clrscr;
gotoxy(30,1);write('Search Binary Search Tree');
gotoxy(27,2);write(' ========================== ');
if root<>nil then show(root,40,5,20);
gotoxy(2,3);write('Search [0-->exit] = ');
readln(bil);
if bil <> 0 then search(root,40,5,20,bil);
until bil=0;
end;
5: Update;
6: begin
clrscr;
gotoxy(25,1);write('Traverse Order Binary Search Tree');
gotoxy(23,2);write(' ==================================== ');
if root<>nil then show(root,40,5,20);
gotoxy(36,15);write('Pre Order : ');
gotoxy(25,16);write('*****************************************');
x:=1;y:=17;Preorder(root);
gotoxy(36,78);write('In Order : ');
gotoxy(25,19);write('*****************************************');
x:=1;y:=20;InOrder(root);
gotoxy(36,21);write('Post Prder : ');
gotoxy(25,22);write('*****************************************');
x:=1;y:=23;PostOrder(Root); Readkey;
end;
7: begin clear; create; end;
8: exit;
end;
end;
begin
textcolor(15);
repeat
menu;
until pil=8;
clear;
end.
RaceTech Titanium | Tithium Engineering
BalasHapusTithium Engineering, Limited is a titanium auto sales group of engineers who develop titanium wedding bands for men innovative, high-performing and high-performing applications apple watch titanium and services for the apple watch series 6 titanium world's where is titanium found largest