1. Operasi 2 Bil. Bulat dengan Prosedur
program prosedu1;
uses wincrt;
var
x, y : integer;
function NamaFungsi:jenis;
begin
statemen1;
statemen2;
...
end;
function
NamaFungsi(parameter):jenis;
begin
statemen1;
statemen2;
...
Petunjuk Praktikum Pemrograman Komputer dengan Turbo Pascal 57
hasil : integer;
hasilkali: longint;
lagi : char;
procedure tambah(bil1, bil2: integer; var jumlah: integer);
begin
jumlah := bil1 + bil2;
end;
procedure selisih(bil1, bil2: integer; var sisa: integer);
begin
sisa := bil1 - bil2;
end;
procedure kali(bil1, bil2: longint; var hasil: longint);
begin
hasil := bil1*bil2;
end;
label baca;
begin
baca: clrscr;
writeln('Operasi dua buah bilangan bulat dengan prosedur');
writeln('Masukkan dua buah bilangan (pisahkan dengan spasi).');
readln(x, y);
tambah(x, y, hasil);
writeln('Jumlahnya adalah ', hasil, '.');
selisih(x, y, hasil);
writeln('Selisihnya adalah ', hasil, '.');
kali(x, y, hasilkali);
writeln('Hasil kalinya adalah ', hasilkali, '.');
write('Coba lagi?<Y/T>_');readln(lagi);
if upcase(lagi)='Y' then goto baca;
donewincrt;
end.
2. Program Operasi 2 Bil.Bulat dengan Fungsi
program fungsi1;
uses wincrt;
var
x, y : integer;
lagi : char;
function tambah(bil1, bil2: integer): integer;
begin
tambah := bil1 + bil2;
end;
function selisih(bil1, bil2: integer): integer;
begin
selisih := bil1 - bil2;
end;
function kali(bil1, bil2: longint): longint;
begin
kali := bil1*bil2;
end;
label baca;
begin
baca: clrscr;
writeln('Operasi dua buah bilangan bulat dengan fungsi:');
writeln('Masukkan dua buah bilangan (pisahkan dengan spasi).');
readln(x, y);
writeln('Jumlahnya adalah ', tambah(x,y), '.');
writeln('Selisihnya adalah ',selisih(x,y), '.');
writeln('Hasil kalinya adalah ', kali(x,y), '.');
write('Coba lagi?<Y/T>_');readln(lagi);
if upcase(lagi)='Y' then goto baca;
donewincrt;
end.
3. Program Permutasi
Program Permtasi;
uses wincrt;
type
permutasi=array[1..10] of char;
var
P : permutasi;
i, K : byte;
lagi : char;
total: longint;
procedure masukan(N:byte;var P:permutasi);
var
i : byte;
huruf : char;
begin
for i:=1 to N do
begin
write('Karakter ke-',i,': '); readln(huruf);
P[i]:=huruf;
end;
end;
procedure CetakPerm(P: permutasi;awal:byte;var total:longint);
var
i : byte;
tmp : char;
begin
if awal=K then
begin
for i:=1 to K do write(P[i]);
writeln;inc(total);
if (total mod 20 = 0) then
begin writeln('Tekan ENTER ...');readln; end;
end
else
begin
for i:=awal to K do
begin
tmp:=P[i];P[i]:=P[awal];P[awal]:=tmp;
CetakPerm(P,awal+1,total);
end;
end;
end;
label mulai;
begin
mulai: clrscr;
writeln('Program Permutasi Huruf');
write('Masukkan cacah huruf<=10 : ');readln(K);
if (K<1) or (K>10) then goto mulai;
masukan(K,P);
write('Permutasi lengkap dari huruf ');
for i:=1 to K do write(P[i],', '); writeln(' adalah :');
total:=0;
CetakPerm(P,1,total);
writeln('Terdapat sebanyak ', total,' permutasi.');
write('Mau coba lagi? <Y/T>: ');readln(lagi);
if upcase(lagi)='Y' then goto mulai;
donewincrt;
end.
4. Program Matrik
Program Matriks3;
uses wincrt;
type matrix3 = array[1..3,1..3]of integer; {definisi matriks 3 x 3}
var a,b,c,d,e,h:matrix3;
procedure baca_matriks(var a:matrix3); {untuk memasukkan matriks 3 x 3}
var i:integer;
begin {baca matriks 3 x 3 baris demi baris }
for i:=1 to 3 do readln(a[i,1],a[i,2],a[i,3]);
end;
procedure cetak_matriks(a:matrix3); {mencetak matriks 3 x 3}
var i: integer;
begin {cetak matriks 3 x 3 baris demi baris}
for i:=1 to 3 do writeln(a[i,1]:4,a[i,2]:4,a[i,3]:4);
end;
procedure jumlah(a,b:matrix3;var m:matrix3); {hitung m=a+b}
var i,j: integer;
begin
for I:=1 to 3 do
for j:=1 to 3 do
m[i,j]:=a[i,j]+b[i,j];
end;
procedure selisih(a,b:matrix3;var m:matrix3); {hitung m=a-b}
var i,j: integer;
begin
for I:=1 to 3 do
for j:=1 to 3 do
m[i,j]:=a[i,j]-b[i,j];
end;
procedure kali(a,b:matrix3; var m:matrix3); {hitung m=ab}
var i,j,k: integer;
begin
for I:=1 to 3 do
for j:=1 to 3 do
begin {hitung c[i,j] = a[i,1]*[b[1,j] +
...+a[i,3]*b[3,j]}
m[i,j]:=0;
for k:=1 to 3 do
m[i,j]:=m[i,j]+a[i,k]*b[k,j];
end;
end;
procedure transpose(a:matrix3; var m:matrix3); {hitung m=a'}
var i,j:integer;
60 Petunjuk Praktikum Pemrograman Komputer dengan Turbo Pascal
begin
for i:=1 to 3 do
for j:=1 to 3 do
m[i,j]:=a[j,i];
end;
begin {bagian utama}
writeln('Program Operasi Matriks 3 x 3');
writeln('Caca memasukkan matriks:');
writeln('Antar elemen sebaris pisahkan dengan SPASI.');
writeln('Antar baris pisahkan dengan ENTER.');
writeln('Masukkan matriks A:');baca_matriks(a);
writeln('Masukkan matriks B:');baca_matriks(b);
jumlah(a,b,c);selisih(a,b,d);kali(a,b,e);transpose(a,h);
write('Tekan ENTER ...');readln;
writeln('A = ');cetak_matriks(a);
writeln('B = ');cetak_matriks(b);
writeln('A + B = ');cetak_matriks(c);
writeln('A - B = ');cetak_matriks(d);
writeln('AxB = ');cetak_matriks(e);
writeln('A'' = ');cetak_matriks(h);
end.
5. Program Rekursi
Program rekursi1;
uses wincrt;
function faktorial(n:byte):longint;
begin
if (n=0) or (n=1) then faktorial:=1
else faktorial:=n*faktorial(n-1);
end;
function Fibonacci(n:byte):longint;
begin
if (n=0) then Fibonacci:=0 else
if (n=1) then Fibonacci:=1 else
Fibonacci:=Fibonacci(n-1)+Fibonacci(n-2);
end;
function FPB(m,n:integer):integer;
begin
if (m=0) then FPB:= n else
if (m<n) then FPB:=FPB(n,m)
else FPB:=FPB(m mod n,n);
end;
function KPK(m,n:integer):integer;
begin
KPK:=m*n div FPB(m,n);
end;
function kombinasi(m,k:integer):integer;
begin
if m<k then kombinasi:= 0 else
kombinasi:=faktorial(m) div (faktorial(k)*faktorial(m-k));
end;
var
pilih,lagi: char;
i,n : byte;
a,b : integer;
label mulai;
begin
mulai: clrscr;
writeln('Program Matematika:');
writeln('==================');
writeln('1. Barisan Fibonacci');
writeln('2. Menghitung Faktorial');
writeln('3. Menghitung FPB dan KPK');
writeln('4. Menghitung Nilai Kombinasi');
writeln('5. Keluar Program');
write('Masukkan nomor pilihan Anda :_');readln(pilih);
case pilih of
'1': begin
write('Masukkan cacah suku : ');readln(n);
for i:=1 to (n-1) do write(Fibonacci(i),', ');
writeln(Fibonacci(n));
end;
'2': begin
write('Masukkan sebuah bilangan asli : ');readln(n);
writeln(n,'! = ',faktorial(n));
end;
'3': begin
write('Masukkan dua buah bilangan asli : ');
readln(a,b);
writeln('FPB(',a,',',b,') = ',FPB(a,b));
writeln('KPK(',a,',',b,') = ',KPK(a,b));
end;
'4': begin
write('Masukkan dua buah bilangan asli : ');
readln(a,b);
writeln('C(',a,',',b,') = ',kombinasi(a,b));
end;
'5': donewincrt;
else writeln('Anda salah memasukkan pilihan!');
end;
write('Mau coba lagi? <Y/T>: ');readln(lagi);
if upcase(lagi)='Y' then goto mulai;
donewincrt;
end.
6. Program Menu
Program Menu1;
uses wincrt;
Var a,b,n,pilihan:integer;
lagi:char;
label baca,awal;
Procedure Faktor(a:integer);
var x,bf:integer;
pembagi:array[1..50] of integer;
begin
pembagi[1]:=1;bf:=1; { 1 adalah faktor a}
if a>3 then {kita perlu menghitung semua faktor a}
for x:=2 to a-1 do if a mod x = 0 then
begin
bf:=bf+1; {berarti x adalah faktor a}
pembagi[bf]:=x; {simpan nilai x}
end;
bf:=bf+1;pembagi[bf]:=a; { a merupakan faktor a}
{cetak faktor:}
Writeln('Faktor-faktor dari ',a,' adalah: ');
for x:=1 to bf do writeln(pembagi[x]:5);
if bf=2 then writeln('Jelas bahwa ', a,' adalah prima!')
else writeln ('Jelas bahwa ', a,' adalah komposit!');
end;
Procedure Fibonacci(a,b,n:integer);
var Fib:array[1..50] of integer;
i:integer;
begin
Fib[1]:=a; Fib[2]:=b;i:=2;
while i<n do
begin
i:=i+1;
Fib[i]:=Fib[i-2]+Fib[i-1];
end;
for i:=1 to n do
begin
write(Fib[i]);if i<n then write(', ');
end;
writeln;
end;
Procedure Menu;
begin
clrscr;
writeln('Program Memilih Menu');
writeln('====================');writeln;
writeln('Menu Pilihan:');writeln;
writeln('1. Faktor Bilangan');writeln;
writeln('2. Barisan Fibonacci');writeln;
writeln('3. Keluar');writeln;
end;
begin {Program utama}
awal:
Menu; {tampilkan menu}
repeat
write('Tulis nomor pilihan Anda: ');readln(pilihan);
until pilihan in [1,2,3];
{case pilihan of}
if pilihan=1 then
begin
repeat
baca: Write('Masukkan sebuah bilangan asli > 1 : ');
readln(a);
if a<2 then goto baca;
Faktor(a);
write('Mau coba lagi? <Y/T>: ');readln(lagi);
until upcase(lagi)<>'Y';
goto awal;
end;
if pilihan=2 then
begin
repeat
Write('Masukkan suku ke-1, 2, dan banyak suku (n) : ');
readln(a,b,n);
Fibonacci(a,b,n);
write('Mau coba lagi? <Y/T>: ');readln(lagi);
until upcase(lagi)<>'Y';
goto awal;
end;
if pilihan=3 then writeln('Terima kasih!');
end.
7. Program Mengubah Basis Bilangan
program dec2base; { mengubah basis bilangan }
uses wincrt;
function pangkat(x, y: integer):longint;
{menghitung x pangkat y, diperlukan pada fungsi desimal }
var
i, hasil: longint;
begin
hasil := 1;
for i := 1 to y do
hasil := hasil * x;
pangkat := hasil;
end;
function nondesimal(x: longint; basis: integer):string;
{ mengubah basis 10 ke basis basis lain < 37 }
const
simbolbil: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
{ simbol-simbol untuk lambang bilangan }
var
i: integer;
hasil, hasilbagi, sisa: longint;
simpan: string;
begin
if basis > 36 then
nondesimal := '!' {karakter penanda kegagalan fungsi ini }
else
begin
simpan := '';
hasil := x;
while hasilbagi <> 0 do
begin
hasilbagi := hasil div basis;
sisa := hasil mod basis;
simpan := simbolbil[sisa + 1] + simpan;
{ penyajian sesungguhnya }
hasil := hasilbagi;
end;
nondesimal := simpan;
end;
end;
function desimal(x: string; basis: integer):longint;
{ mengubah sembarang basis < 37 ke basis 10 }
const
simbolbil: string = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
var
i, pkt: integer;
hasil: longint;
cacahsimbol: integer;
begin
if basis > 36 then
desimal := -1 {untuk menandai kegagalan fungsi ini }
else
begin
hasil := 0;
i := 1;
pkt := length(x) - 1;
while i <> length(x)+1 do { kembalikan ke basis 10 }
begin
hasil := hasil + (pos(x[i], simbolbil)-1) *
pangkat(basis, pkt);
i := i + 1;
pkt := pkt - 1;
end;
end;
desimal := hasil;
end;
var
bil, basis1: longint;
basis2: string;
lagi : char;
label mulai;
begin
mulai: clrscr;
writeln('Program konversi basis bilangan:');
writeln('-------------------------------');
write('Tuliskan sebuah bilangan (basis 10): ');
readln(bil);
write('Ingin diubah ke dalam basis berapa? ');
readln(basis1);
writeln;
basis2 := nondesimal(bil, basis1);
if basis2 = '!' then
writeln('Tuliskan basis yang kurang dari 37')
else begin
write(bil,' (basis 10) sama dengan ', basis2);
writeln(' (basis ',basis1, ').');
bil := 0;
write('Untuk mengecek: ',basis2, ' (basis ', basis1);
writeln(') sama dengan ',desimal(basis2, basis1),' (basis 10).');
end;
write('Mau coba lagi?<Y/T>_ ');readln(lagi);
if upcase(lagi)='Y' then goto mulai;
donewincrt;
end.
No comments:
Post a Comment