Contoh-contoh Source Code Bahasa
Pemrograman Pascal
A.
Array
uses wincrt;
(untuk windows version and for dos “uses crt;”)
var
nama:array [1..5] of string;
x:integer;
begin
clrscr;
for x := 1 to 5 do
begin
write('Nama ',x,' = ');
readln(nama[x]);
end;
for x := 1 to 5 do
begin
writeln(nama[x]);
end;
readln;
end.
uses
crt;
var
nama:array [1..5] of string;
x:integer;
begin
clrscr;
nama[1]:='aco';
nama[2]:='oco';
nama[3]:='aci';
nama[4]:='ece';
for x := 1 to 4 do
begin
writeln(nama[x]);
end;
readln;
end.
uses
wincrt;
var
angka: array [1..5] of integer;
x,y:integer;
begin
clrscr;
for x := 1 to 5 do
begin
write('Angka ',x,' =
');readln(angka[x]);
end;
for x := 1 to 5 do
begin
writeln(angka[x]);
y:=y+angka[x];
end;
writeln;
writeln('------------');
writeln('Jumlah Angka = ', y);
readln;
end.
uses
wincrt;
var
no,bbarang,hbarang,bayar,rata2 : array
[1..3] of integer;
npembeli,nbarang: array [1..3] of string;
x,a,y,z : integer;
begin
clrscr;
gotoxy(20,1);writeln(': : : : : : : : : :
: : : : : : : : : ');
gotoxy(20,2);writeln(': : : : : : Selamat
Datang : : : : : :');
gotoxy(20,3);writeln('_ _ _ _ _ _ _ _ _ _
_ _ _ _ _ _ _ _ _ ');
writeln;
writeln;
write('Masukan Jumlah Transaksi =
');readln(a);
writeln;
clrscr;
for x := 1 to a do
begin
writeln('No.', x);
write('Nama Pembeli = ');readln(npembeli[x]);
write('Nama Barang = ');readln(nbarang[x]);
write('Banyak Barang = ');readln(bbarang[x]);
write('Harga Barang =
');readln(hbarang[x]);
writeln;
y:=bbarang[x]*hbarang[x];
z:=y;
writeln;
writeln;
end;
writeln('No Pembeli
Barang Banyak Harga
Bayar Rata2');
for x := 1 to a do
begin
writeln(x,' ', npembeli[x],' ', nbarang[x],' ', bbarang[x],' ', hbarang[x],' ', y,'
',z);
end;
readln;
end.
uses
wincrt;
var
baris : array[1..3] of integer;
kolom : array[1..3] of integer;
gab
: array[1..3,1..3] of integer;
x,y
: integer;
begin
clrscr;
baris[1] :=2;
baris[2] :=3;
baris[3] :=4;
kolom[1] :=5;
kolom[2] :=6;
kolom[3] :=7;
for x := 1 to 3 do
begin
for y:= 1 to 3 do
begin
gab[x,y]:=baris[x] +
kolom[y];
end;
end;
for x:= 1 to 3 do
begin
for y:= 1 to 3 do
begin
write(gab[x,y],' ');
end;
writeln;
end;
readln;
end.
uses
wincrt;
var
baris : array[1..3] of string;
kolom : array[1..3] of string;
gab
: array[1..3,1..3] of string;
x,y,t
: integer;
begin
clrscr;
for x:= 1 to 3 do
begin
write('Masukan Jumlah Baris ',
x,' = ');readln(baris[x]);
end;
for y:= 1 to 3 do
begin
write('Masukan Jumlah Kolom ',
y,' = ');readln(kolom[y]);
end;
writeln;
for x := 1 to 3 do
begin
for y:= 1 to 3 do
begin
gab[x,y]:=baris[x] + kolom[y];
end;
end;
for x:= 1 to 3 do
begin
for y:= 1 to 3 do
begin
write(gab[x,y],' ');
end;
writeln;
end;
readln;
end.
uses
wincrt;
type
matriks = array[1..2,1..2] of integer;
var
matriksA,matriksB,Hasil : matriks;
x,y
: integer;
begin
clrscr;
writeln('Matriks A');
writeln('---------');
for x:= 1 to 2 do
begin
for y:= 1 to 2 do
begin
write('Matriks A ke ', x,y ,'
= ');readln(matriksA[x,y]);
end;
end;
writeln;
writeln('Matriks B');
writeln('---------');
for x:= 1 to 2 do
begin
for y:= 1 to 2 do
begin
write('Matriks B ke ', x,y ,'
= ');readln(matriksB[x,y]);
end;
end;
writeln;
writeln('Matriks A');
writeln('---------');
for x:= 1 to 2 do
begin
for y:= 1 to 2 do
begin
write(matriksA[x,y]:5,' ');
end;
writeln;
end;
writeln;
writeln('Matriks B');
writeln('---------');
for x:= 1 to 2 do
begin
for y:= 1 to 2 do
begin
write(matriksB[x,y]:5,' ');
end;
writeln;
end;
writeln;
writeln('Hasil Penjumlahan Matriks A +
Matriks B');
for x:= 1 to 2 do
begin
for y:= 1 to 2 do
begin
hasil[x,y]:=matriksA[x,y]+matriksB[x,y];
write(hasil[x,y]:5,' ');
end;
writeln;
end;
readln;
end.
B.
Procedure
uses wincrt;
label
ulang;
procedure jumlah;
var a,b,c:integer;
begin
write('Masukan Nilai Pertama
:');readln(a);
write('Masukan Nilai Kedua :');readln(b);
c:=a+b;
writeln('Hasil ', a, ' + ', b,' = ', c);
end;
procedure kurang;
var a,b,c:integer;
begin
write('Masukan Nilai Pertama
:');readln(a);
write('Masukan Nilai Kedua :');readln(b);
c:=a-b;
writeln('Hasil ', a, ' - ', b,' = ', c);
end;
procedure kali;
var a,b,c:integer;
begin
write('Masukan Nilai Pertama
:');readln(a);
write('Masukan Nilai Kedua :');readln(b);
c:=a*b;
writeln('Hasil ', a, ' * ', b,' = ', c);
end;
procedure bagi;
var a,b:integer;
c:real;
begin
write('Masukan Nilai Pertama
:');readln(a);
write('Masukan Nilai Kedua :');readln(b);
c:=a/b;
writeln('Hasil ', a, ' / ', b,' = ',
c:0:2);
end;
var
pilih,x:char;
begin
ulang:
clrscr;
writeln('::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::');
writeln(' Pilihan Anda ');
writeln('1. Penjumlahan');
writeln('2. Pengurangan');
writeln('3. Perkalian');
writeln('4. Pembagian');
write('Masukan Pilihan Anda :
');readln(pilih);
writeln;
case pilih of
'1': jumlah;
'2': kurang;
'3': kali;
'4': bagi;
else
writeln('Maaf anda memilih nomor yang
salah');
end;
writeln;
write('Apakah anda ingin mengulang (y/t) :
');readln(x);
if (x='Y') or (x = 'y') then
begin
goto ulang;
end;
readln;
end.
procedure
faktorial(n:word);
var
i,hasil:integer;
begin
hasil:=1;
for i := n downto 1 do
begin
hasil:=hasil*i;
end;
writeln('Faktorial ', n,'! = ', hasil);
end;
procedure
fibonacci(x,y:integer);
var
z:array [1..50] of integer;
begin
z[1]:=1; z[2]:=1;
write(z[1],' ');
write(z[2],' ');
for x := 3 to y do
begin
z[x]:=z[x-1]+z[x-2];
write(z[x],' ');
end;
writeln;
writeln('Suku ke-',y,' = ',z[x]);
end;
var
a,b,c:integer;
begin
{bilangan faktorial}
writeln('Bilangan Faktorial');
write('Masukan Nilai Faktorial =
');readln(a);
faktorial(a);
writeln;
{bilangan fibonacci}
writeln('Bilangan Fibonacci');
write('Suku yang akan dicari =
');readln(b);
fibonacci(c,b);
readln;
end.
C.
Record
uses wincrt;
procedure nowith;
type
luassegitiga=record
alas
:integer;
tinggi :integer;
luas
:real;
end;
var
ls:luassegitiga;
begin
read(ls.alas);
read(ls.tinggi);
ls.luas := ls.alas*ls.tinggi/2;
writeln('Luas Segita = ', ls.luas:4:0);
end;
procedure with1;
type
luassegitiga=record
alas
:integer;
tinggi :integer;
luas
:real;
end;
var
ls:luassegitiga;
begin
with ls do
begin
read(alas);
read(tinggi);
ls.luas := alas*tinggi/2;
writeln('Luas Segita = ', luas:4:0);
end;
end;
begin
writeln('No With');
nowith;
writeln;
writeln('With');
with1;
end.
uses wincrt;
type
mahasiswa=record
nim,nama,ket :string;
umur :integer;
end;
var
msiswa:array[1..3] of mahasiswa;
i,x:integer;
begin
write('Masukan Jumlah Mahasiswa =
');readln(x);
for i := 1 to x do
begin
with msiswa[i] do
begin
write('NIM :');readln(nim);
write('Nama :');readln(nama);
write('Umur :');readln(umur);
end;
writeln;
end;
for i := 1 to x do
begin
with msiswa[i] do
begin
if umur <= 17 then
begin
ket:='Belum cukup umur untuk
menonton';
end
else
begin
ket:='Silahkan Menonton';
end
end;
end;
writeln('------------------------------------------------------------------------------');
for i := 1 to x do
begin
with msiswa[i] do
begin
writeln(i,' |
',nim:2,' | ',nama:2,'
| ',umur:2,' |
',ket:2);
end;
end;
end.
D.
Function
uses wincrt;
function
pangkat(a,b:integer):longint;
var z,i:integer;
begin
z:=1;
for i:= 1 to b do
begin
z:=z*a;
pangkat:=z;
end;
end;
function pangkat1(var
a,b,z:integer):longint;
var i:integer;
begin
z:=1;
for i:= 1 to b do
begin
z:=z*a;
pangkat1:=z;
end;
end;
var x,y,c:integer;
begin
readln(x);
readln(y);
writeln('', x ,' pangkat ', y ,' = ',
pangkat(x,y));
writeln;
writeln('', x ,' pangkat ', y ,' = ',
pangkat1(x,y,c));
end.
