Program Binary tree dalam pascal

{ada beberapa fungsi/prosedur yang merupakan jawaban dari soal ujian tentang Binary Tree}

Program binary_tree;
uses
winCrt;

type
PBinaryTree = ^Node;
Node = record
Info: Integer;
Left: PBinaryTree;
Right: PBinaryTree;
end;
Type
Enums = (sama,beratkiri,beratkanan);

{const iscomplete=false;}


var
BinaryTree: PBinaryTree;

pilih : char;
selesai : char;
bil : integer;
data,code : integer;


function max(a,b : integer): integer;
Begin
if a < b then
max:=b
else
max:=a;
End;

Function kedalaman(bt : Pbinarytree):integer;
Begin
if (bt=nil) then
kedalaman:=0
else
kedalaman:= 1 + max(kedalaman(bt^.left), kedalaman(bt^.right));

End;

function setimbang(bt : PbinaryTree):boolean;
Begin
setimbang:=abs(kedalaman(bt^.left) - kedalaman(bt^.right)) <=1;

End;

function kesetimbangan(bt : Pbinarytree): EnumS;
{Enums = (sama,beratkiri,beratkanan);}

begin
kesetimbangan:=sama;
if (kedalaman(bt^.left) - kedalaman(bt^.right)) <=-1 then
kesetimbangan:=beratkanan
else
if (kedalaman(bt^.left) - kedalaman(bt^.right)) >=1 then
kesetimbangan:=Beratkiri;
End;


Procedure Putarkiri(var bt :Pbinarytree);
var
x : Pbinarytree;
Begin
x:=bt;
bt:=bt^.right;
x^.right :=bt^.left;
bt^.left:=x;

End;

Procedure Putarkanan(var bt :Pbinarytree);
var
x : Pbinarytree;
Begin
x:=bt;
bt:=bt^.left;
x^.left :=bt^.right;
bt^.right:=x;

End;


Procedure Putar(var bt :PbinaryTree);
Begin
if not (setimbang(bt)) then
if (kesetimbangan(bt) = beratkanan) then
begin
if (kesetimbangan(bt^.right) = beratkiri) then
begin
putarkanan(bt^.right);
putarkiri(bt);
end
else
if (kesetimbangan(bt) = beratkiri) then
begin
if (kesetimbangan(bt^.left) = beratkanan) then
putarkiri(bt^.left);
putarkanan(bt);
End;
end;
End;

function Find(bt: PBinaryTree; Search: Integer): Boolean;
begin
if (bt = nil) then
Find := False
else
if (Search < bt^.Info) then
Find := Find(bt^.Left, Search)
else
if (Search > bt^.Info) then
Find := Find(bt^.Right, Search)
else
Find := True;
putar(bt);
end;

function Delete(var bt: PBinaryTree; Info: Integer): Boolean;
var
x, y: PBinaryTree;
begin
if not(Find(bt, Info)) then
Delete := False
else
if (Info < bt^.Info) then
Delete := Delete(bt^.Left, Info)
else
if (Info > bt^.Info) then
Delete := Delete(bt^.Right, Info)
else
begin
x := bt;
if (x^.Right <> nil) then
begin
bt := x^.Right;
y := bt;
while (y^.Left <> nil) do
y := y^.Left;
y^.Left := x^.Left;
end
else
bt := x^.Left;
Delete := True;
end;
end;

Procedure hapusdata(var bt :Pbinarytree);
var
s : integer;
ulangi : char;
Begin
clrscr;
writeln('Hapus data ');
repeat
write('masukan node yang akan dihapus :');
readln(s);
if (Delete(bt,s)) then
writeln('Data jadi dihapus')
else
writeln('Data tidak ditemukan');
writeln;
write('ulangi(Y/T):');
ulangi:=readkey;
writeln;
until (upcase(ulangi)='T');
End;

function NodeCount(bt: PBinaryTree): Integer;
begin
if (bt = nil) then
NodeCount := 0
else
NodeCount := 1 + NodeCount(bt^.Left) + NodeCount(bt^.Right);
end;


function iscomplete(bt : PbinaryTree):boolean;
begin
if bt=nil then iscomplete:=false
else if (nodecount(bt) = 3) then iscomplete:=true
else iscomplete:=iscomplete(bt^.left) and iscomplete(bt^.right);

end;


procedure InOrder(bt: PBinaryTree);
begin
if (bt <> nil) then
begin
InOrder(bt^.Left);
Write(bt^.Info:6);
InOrder(bt^.Right);
end;
end;

procedure PreOrder(bt: PBinaryTree);
begin
if (bt <> nil) then
begin
Write(bt^.Info:6);
PreOrder(bt^.Left);
PreOrder(bt^.Right);
end;
end;

procedure PostOrder(bt: PBinaryTree);
begin
if (bt <> nil) then
begin
PostOrder(bt^.Left);
PostOrder(bt^.Right);
Write(bt^.Info:6);
end;
end;

Procedure level(bt:PbinaryTree);
Begin
clrscr;
writeln('kedalamanpohon :',kedalaman(bt));
write('tekan sembarang tombol');
readkey;
End;

function iselement(bt : Pbinarytree; invalue : integer) : integer;

var
number : integer;

begin
if bt = nil then
number := 0
else
begin
number := iselement(bt^.right, invalue)
+ iselement(bt^.left, invalue);

if bt^.info >= invalue then
number := number + 1
end;
iselement := number
end;

function Fx(bt : Pbinarytree; n :integer):integer;
begin
if bt=nil then Fx:=0
else
if n=1 then Fx:=1
else Fx:=Fx(bt^.left,n-1)+Fx(bt^.right,n-1);
end;

Procedure Insert(var bt: PBinaryTree; Info: Integer);
var
x: PBinaryTree;
begin
if (bt = nil) then
begin
new(x);
x^.Info := Info;
x^.Left := nil;
x^.Right := nil;
bt := x;
end
else
if (Info <= bt^.Info) then
Insert(bt^.Left, Info)
else
Insert(bt^.Right, Info);
end;


Procedure caridata(bt :Pbinarytree);
var
s : integer;
ulangi : char;
Begin
clrscr;
writeln('Pencarian data ');
repeat
write('masukan data yang akan dicari :');
readln(s);
if (find(bt,s)) then
writeln('Data Ditemukan')
else
writeln('Data tidak ketemukan');
writeln;
write('ulangi(Y/T):');
ulangi:=readkey;
writeln;
until (upcase(ulangi)='T');
End;

procedure Menu;
begin
WriteLn('Ordered Binary Tree');
WriteLn('===================');
WriteLn;
WriteLn('1. Input data');
WriteLn('2. Cari data');
WriteLn('3. Hapus data');
WriteLn('4. Jumlah node');
WriteLn('5. Tampilkan data secara In order');
WriteLn('6. Tampilkan data secara Pre order');
WriteLn('7. Tampilkan data secara Post order');
Writeln('8. Kedalaman Pohon');
writeln('9. ISElement');
writeln('x.putarkiri');
writeln('!. biner telusur');
writeln('@.pohon komplit');
WriteLn('0. Keluar');

WriteLn;
Write('Silahkan pilih (0-7): ');
end;

var i,n : integer;
begin
write('jumlah node:');readln(n);
selesai:='N';
repeat

menu;
readln(pilih);
case pilih of
'1' : begin
for i := 1 to n do
begin
write('input data ke ',i,' :');readln(bil);
insert(binarytree,bil);
end;
end;
'2' : begin
{ write('node yang dicari:');readln(bil);}
caridata(binarytree);
{writeln('ketemu : ',find(binarytree,bil));}
end;
'3' :begin
hapusdata(binarytree);
{write('node yang dihapus:');readln(bil);
writeln('Hapus : ',delete(binarytree,bil));
writeln;}
end;

'4' :begin
write('jumlah node :',nodecount(binarytree));
writeln;
end;
'5' : begin
inorder(binarytree);
writeln;
end;
'6' :begin
preorder(binarytree);
writeln;
end;
'7' : begin
postorder(binarytree);
writeln;
end;
'8' : begin
level(binarytree);
writeln;
end;
'9' :begin
writeln('mencek node yang sama:');readln(bil);
writeln('ketemu elemen yang sama: ',iselement(binarytree,bil));
end;
'x' : begin
putarkiri(binarytree);
writeln;
end;
'!' :begin
write('nilai:',Fx(binarytree,0));

end;
'@' : begin
writeln('complete : ',iscomplete(binarytree));
end;

'0' :begin
selesai:='Y';
end;
end;
readln;
until (selesai='Y') or (selesai='y');
end.
.