Kumpulan Program Pascal

Kumpulan program pascal ini merupakan kumpulan latihan saat penulis belajar bahasa
pemrograman pascal. Penulis menggunakan Turbo Pascal for Windows (TPW) Versi
1.5 sebagai kompilernya. Mungkin ada kekurangan disana sini, tapi mudah-mudahan
kumpulan program ini bermanfaat bagi pembaca yang berminat dan baru mempelajari
bahasa pemrograman pascal.
Program Menghitung_Jarak;
Uses WinCrt;
var
x1,x2,y1,y2:integer;
d:real;
begin
Writeln('Program Menghitung Jarak Titik A dan B');
Writeln('======================================');
Writeln;
Write('Masukan Nilai A (X1): ');readln(x1);
Write('Masukan Nilai B (X2): ');readln(x2);
Write('Masukan Nilai A (Y1): ');readln(y1);
Write('Masukan Nilai B (Y2): ');readln(y2);
d:=sqrt(sqr(x2-x1)+sqr(y2-y1));
Writeln;
Writeln('Jadi Jarak Titik A ke B Adalah: ',d:4:2);
end.

Output:

Program Konversi_Suhu;
Uses WinCrt;
var f,c:real;
begin
Writeln('Program Konversi Fareinheit Ke Celcius');
Writeln('======================================');
Writeln;
Write('Masukan Suhu dalam Farenheit: ');readln(f);
c:=5/9*(f-32);
Writeln;
Writeln('Jadi Suhu Dalam Celcius Adalah: ',c:4:2);
end.

Output:

Program Konversi_Waktu;
Uses Wincrt;
Var j,m,d,h:integer;
begin
Writeln('Program Konversi Waktu');
Writeln('======================');
Writeln;
Write('Masukkan Jumlah Jam
: ');readln(j);
Write('Masukkan Jumlah Menit : ');readln(m);
Write('Masukkan Jumlah Detik : ');readln(d);
Writeln;
h:=(j*3600)+(m*60)+d;
Writeln('Jadi Hasil Konversi : ',h,' Detik');
end.

Output:

Program Konversi_Waktu1;
Uses WinCrt;
var j,m,d,dm,sisa,sisa1:integer;
begin
Writeln('Program Konversi Waktu 1');
Writeln('========================');
Writeln;
Write('Masukkan Jumlah Detik : ');readln(dm);
if (dm/3600)>0 then
begin
j:=dm div 3600;
sisa:=dm-(j*3600);

end
else
begin
j:=0;
sisa:=dm;
end;
if (sisa/60)>0 then
begin
m:=sisa div 60;
sisa1:=sisa-(m*60);
end
else
begin
m:=0;
sisa1:=sisa;
end;
d:=sisa1;
Writeln;
Writeln('Hasil => ',j,' jam ',m,' menit ',d,' detik');
end.

Output:

Program Menghitung_Selisih_Waktu;
Uses WinCrt;
Var j,m,d,h,j1,m1,d1,h1,hj,hm,sl,sisa,sisa1:longint;
Begin
Writeln('Program Menghitung Selisih Waktu');
Writeln('================================');
Writeln;
Write('Waktu ke-1 jam
: ');readln(j);
Write('Waktu ke-1 Menit : ');readln(m);
Write('Waktu ke-1 Detik : ');readln(d);
Writeln('================================');
Write('Waktu ke-2 jam
: ');readln(j1);
Write('Waktu ke-2 Menit : ');readln(m1);
Write('Waktu ke-2 Detik : ');readln(d1);
h:=(j*3600)+(m*60)+d; h1:=(j1*3600)+
(m1*60)+d1;
sl:=h1-h;
if (sl/3600)>0 then
begin
hj:=sl div 3600;
sisa:=sl-(hj*3600);
end
else
begin
hj:=0;
sisa:=sl;
end;
if (sisa/60)>0 then
begin
hm:=sisa div 60;

sisa1:=sisa-(hm*60);
end
else
begin hm:=0;
sisa1:=sisa;
end;
Writeln;
Writeln('Selisih Waktu: ',hj,' jam ',hm,' Menit ',sisa1,' Detik');
End.

Output:

Program Menukar_Nilai;
Uses WinCrt;
var A,B,C:integer;
Begin
Writeln('Program Menukar Nilai A Menjadi B');
Writeln('=================================');
Writeln;
Write('Masukkan Nilai A: ');readln(A);
Write('Masukkan Nilai B: ');readln(B);
Writeln;
C:=A;
A:=B;
B:=C;
Writeln;
Writeln('Hasil A=',A,' B=',B);
End.

Output:

Program Menukar_Nilai1;
Uses WinCrt;
var A,B:integer;
Begin
Writeln('Program Menukar Nilai A Menjadi B');
Writeln('=================================');
Writeln;
Write('Masukkan Nilai A: ');readln(A);

Write('Masukkan Nilai B: ');readln(B);

Writeln;
A:=A-B;
B:=B+A;
A:=B-A;
Writeln;
Writeln('Hasil A=',A,' B=',B);
End.

Output:

Program Urut_Bilangan;
Uses Wincrt;
Var A,B,C:integer;
Begin
Writeln('Program Mengurut Bilangan');
Writeln('=========================');
Writeln;
Write('Masukkan Nilai A: ');readln(A);
Write('Masukkan Nilai B: ');readln(B);
Write('Masukkan Nilai C: ');readln(C);
Writeln;
if (A<=B) and (A<=C) then
if (B<=C) then
Writeln(A,' ',B,' ',C)
else
Writeln(A,' ',C,' ',B)
else if (B<=A) and (B<=C) then
if (A<=C) then
Writeln(B,' ',A,' ',C)
else
Writeln(B,' ',C,' ',A)
else if (C<=A) and (C<=B) then
if (A<=B) then
Writeln(C,' ',A,' ',B)
else
Writeln(C,' ',B,' ',A)
End.

Output:

Program Menentukan_Segitiga;
Uses Wincrt;
Var A,B,C,X,Y:integer;
Begin
Writeln('Program Menentukan Segitiga');
Writeln('=========================');
Writeln;
Write('Masukkan Sisi A: ');readln(A);
Write('Masukkan Sisi B: ');readln(B);
Write('Masukkan Sisi C: ');readln(C);
Writeln;
X:=sqr(C);
Y:=sqr(A)+sqr(B);
if (X<Y) then
Writeln('Segitiga Lancip')
else if (X=Y) then
Writeln('Segitiga Siku-Siku')
else
Writeln('Segitiga Tumpul')
End.

Output:

Program Persamaan_Kuadrat;
Uses Wincrt;
Var A,B,C:integer;
D,X1,X2:real;
Begin
Writeln('Program Persamaan Kuadrat');
Writeln('=========================');
Writeln;
Write('Masukkan Nilai A: ');readln(A);
Write('Masukkan Nilai B: ');readln(B);
Write('Masukkan Nilai C: ');readln(C);
Writeln;
D:=sqr(B)-(4*A*C);
if (D>0) then
begin
X1:=(-B+sqrt(D))/2*A;
X2:=(-B-sqrt(D))/2*A;
Writeln('X1= ',X1:4:1,'
end
else if (D=0) then
begin
X1:=-B/(2*A);
Writeln('X1=X2=',X1:4:1);
end
else
Writeln('Akar Imajiner!');
End.

Output:

','X2= ',X2:4:1);

Program Faktorial;
Uses Wincrt;
Var i,n,x:integer;
Begin
Writeln('Program Faktorial');
Writeln('=================');
Writeln;
Write('Masukkan Nilai Faktorial: ');Readln(n);
Writeln;
if (n<=0) then
Writeln('Hasil Faktorial: ',1)
else
Begin
x:=1;
For i := 1 to n do
x:=x*i;
Writeln('Hasil Faktorial: ',x);
End;
End.

Output:

Program Menghitung_Rata_Rata;
Uses Wincrt;
Var n,x,i,tot:integer;
rata:real;
Begin
Writeln('Program Menghitung Rata-Rata');
Writeln('============================');
Writeln;
Write('Masukkan Jumlah Bilangan: ');readln(n);
Writeln;
Writeln('Masukkan Bilangan: ');
tot:=0;
For i:= 1 to n do
Begin
Readln(x);
tot:=tot+x;
End;
rata:=tot/n;
Writeln;
Writeln('Total Bilangan: ',tot:6);
Writeln('Rata-Rata
End.

: ',rata:6:2);

Output:

Program Menghitung_Pangkat;
Uses Wincrt;
Var i,n,m: integer;
x: real;
Begin
Writeln('Program Menghitung Pangkat');
Writeln('==========================');
Writeln;
Write('Masukkan Jumlah Pangkat
: ');readln(n);
Write('Masukkan Bil. Yang DiPangkat : ');readln(m);
Writeln;
x:=1;
if (n>0) then
For i:= 1 to n do
x:=x*m
else if (n=0) then
x:=1
else
begin
n:=-1*n;
For i:= 1 to n do
begin
x:=x*(1/m);
end;
end;
Writeln('Hasil Pangkat: ',x:6:2);
End.

Output:

Program Menampilkan_Bintang;
Uses Wincrt;
Var i,j,n:integer;
Begin
Writeln('Program Menampilkan Bintang');

Writeln('===========================');
Writeln;
Write('Masukkan Jumlah Baris: ');readln(n);
For i:= 1 to n do
Begin
For j:= 1 to i do
Write('*');
Writeln;
End;
End.

Output:

Program Solusi_Bilangan_Bulat;
Uses Wincrt;
Var i,n,x,y,z:integer;
Begin
Writeln('Program Solusi Bilangan Bulat');
Writeln('=============================');
Writeln;
for x:= 0 to 25 do
for y:= 0 to 25 do
for z:= 0 to 25 do
if (x+y+z=25) then
begin
writeln(x,' ',y,' ',z);
readln;
end;
End.

Output:

Program Array1;

Uses Wincrt;
Var x
: array [1..100] of integer;
n,i :integer;
Begin
Writeln('Program Array');
Writeln('=============');
Writeln;
Write('Masukkan Jumlah Data: ');readln(n);
Writeln;
For i:= 1 to n do
Readln(x[i]);
Writeln;
Write('Data Yang Telah Dimasukkan: ');
For i:= 1 to n do
Write(x[i],'
');
End.

Output:

Program Array2;
Uses Wincrt;
Var x : array [1..100] of integer;
n,i,max,min : integer;
Begin
Writeln('Program Array');
Writeln('=============');
Writeln;
Write('Masukkan Jumlah Data: ');readln(n);
Writeln;Writeln('Data Harus Urut');
For i:= 1 to n do
Readln(x[i]);
Writeln;
Write('Data Yang Telah Dimasukkan: ');
max:=x[1];
min:=x[1];
For i:= 1 to n do
Begin
Write(x[i],'
');
if (max<x[i]) then
max:=x[i]
else
min:=x[i];
End;
Writeln;
Writeln('Nilai Maximal: ',max);
Writeln('Nilai Minimal: ',min);
End.

Output:
1010

Program Array3;
Uses Wincrt;
Var x: array [1..100] of integer;
n,i,max,min,tot,pos:integer;
rt,sdt,sd,md:real;
Begin
Writeln('Program Array');
Writeln('=============');
Writeln;
Write('Masukkan Jumlah Data (Data harus Urut): ');readln(n);
Writeln;
For i:= 1 to n do
Readln(x[i]);
Writeln;
Write('Data Yang Telah Dimasukkan: ');
max:=x[1];
min:=x[1];
tot:=0;
sdt:=0;
For i:= 1 to n do
Begin
Write(x[i],'
');
if (max<x[i]) then
max:=x[i]
else
min:=x[i];
tot:=tot+x[i];
End;
rt:=tot/n;
For i:= 1 to n do
Begin
sdt:=sdt+sqr(x[i]-rt);
End;
sd:=sqrt(sdt/(n-1));
if (n mod 2 = 1) then
begin
pos:=(n div 2)+1;
md:=x[pos];
end
else
begin
pos:=(n div 2);
md:=(x[pos]+x[pos+1])/2;
end;

1111

Writeln;
Writeln('Nilai Maximal
Writeln('Nilai Minimal
Writeln('Nilai Rata-Rata
Writeln('Standar Deviasi
Writeln('Median
End.

:
:
:
:
:

',max);
',min);
',rt:4:2);
',sd:4:2);
',md:4:2);

Output:

Program Polindrom;
Uses Wincrt;
Var kt,hkt,hkt1:string;
i,j:integer;
Begin
Writeln('Program Polindrom');
Writeln('=================');
Writeln;
Write('Masukkan Kata: ');Readln(kt);
Writeln;
j:=length(kt);
hkt:='';
For i:= 1 to j do
hkt:=hkt+kt[i];
For i:= j downto 1 do
hkt1:=hkt1+kt[i];
Writeln('Asal: ',hkt,'

Dibalik: ',hkt1);

Writeln;
if (hkt=hkt1) then
Writeln('Kata Tersebut Termasuk Polindrom!')
else
Writeln('Kata Tersebut Tidak Termasuk Polindrom!');
End.

Output:

Program Data_mahasiswa;

1212

Uses Wincrt;
Type mhs = record
NIM
: String[4];
Nama : String[20];
Prodi : String[20];
IP
: Real;
End;
Var data : mhs;
Begin
With data do
Begin
Write('NIM
Write('Nama
Write('Program Studi
Write('IP
End;
Writeln;
Writeln;
Writeln('NIM
Writeln('Nama
Writeln('Program Studi
Writeln('IP
End.

:
:
:
:

');Readln(NIM);
');Readln(Nama);
');Readln(Prodi);
');Readln(IP);

:
:
:
:

',data.NIM);
',data.Nama);
',data.Prodi);
',data.IP:2:2);

Output:

Program Pecahan;
Uses Wincrt;
Var pmb,pny
: array [1..10] of integer;
i,j,n,t1,t2 : integer;
Begin
Writeln('Program Pecahan');
Writeln('===============');
Writeln;
Write('Jumlah Data Pecahan: ');Readln(n);
Writeln;
For i := 1 to n do
Begin
Write('Pembilang ke-',i,' : ');Readln(pmb[i]);
Write('Penyebut ke-',i,' : ');Readln(pny[i]);
End;
Writeln;
Writeln('Pecahan Yang Di Masukkan:');
For i := 1 to n do
Writeln(pmb[i],'/',pny[i]);
For i := 1 to n-1 do
For j := i+1 to n do
Begin
if ((pmb[i]/pny[i])>(pmb[j]/pny[j]))

1313

then

Begin t1:=pmb[i];
t2:=pny[i];
pmb[i]:=pmb[j];
pny[i]:=pny[j];
pmb[j]:=t1;
pny[j]:=t2;
End;
End;
Writeln;
Writeln('Hasilnya: ');
For i := 1 to n do
Writeln(pmb[i],'/',pny[i]);
End.

Output:

Program DataPegawai;
Uses Wincrt;
Type Pegawai = record
NIP
: String[9];
Nama
: String[30];
Golongan : Char;
Jamkerja : Real;
End;
Var
Data
Gapok
Insentif,Gaber
Ul
Begin
Repeat

:
:
:
:

Pegawai;
Real;
Real;
Char;

Clrscr;
Writeln('Entry Data Pegawai PT. XYZ');
Writeln('==========================');
Writeln;
Write('NIP
: ');Readln(Data.NIP);
Write('Nama
: ');Readln(Data.Nama);
Write('Golongan
: ');Readln(Data.Golongan);
Write('Jam Kerja
: ');Readln(Data.Jamkerja);
Writeln;
Writeln;
Case Data.Golongan of

1414

'1' : Gapok:=1000000;
'2' : Gapok:=1500000;
'3' : Gapok:=2000000;
Else
Gapok:=0;
End;
if Data.Jamkerja>200 then
Insentif:=(Data.Jamkerja-200)*10000
else
Insentif:=0;
Gaber:=Gapok+Insentif;
Clrscr;
Writeln('Laporan Gaji Pegawai');
Writeln('PT. XYZ');
Writeln;
Writeln('=============================================================
===============');
Writeln('|NIP
| Nama
| Golongan | Jam
Kerja | Gaji
|');
Writeln('=============================================================
===============');
Writeln('|',Data.NIP:10,'|',Data.Nama:25,'|',Data.Golongan:10,'|',Data
.Jamkerja:11:0,'|',Gaber:14:2,'|');
Writeln('=============================================================
===============');
Writeln;
Write('Mau Ulang Lagi? [Y/T]: ');Readln(Ul);
Until Upcase(Ul)<>'Y';
End.

Output:

Program DataPegawai_Array;
Uses Wincrt;
Type Pegawai = record
NIP
: String[9];
Nama
: String[30];
Golongan : Char;
Jamkerja : Real;
End;
Var

Data
Gapok,Insentif,Gaber
Tot,Rata

: Array [1..100] of Pegawai;

: Real;
: Real;

Ul
: Char;
i,n
: Integer;
Begin
Repeat
Clrscr;
Write('Masukkan Jumlah Data Pegawai : ');Readln(n);
For i := 1 to n do
Begin
Clrscr;
Writeln('Entry Data Pegawai PT. XYZ');
Writeln('==========================');
Writeln;
Writeln('Data Ke-',i);
Writeln;
Write('NIP
: ');Readln(Data[i].NIP);
Write('Nama
: ');Readln(Data[i].Nama);
Write('Golongan
: ');Readln(Data[i].Golongan);
Write('Jam Kerja
: ');Readln(Data[i].Jamkerja);
Writeln;
End;
Clrscr;
Writeln('Laporan Gaji Pegawai');
Writeln('PT. XYZ');
Writeln;
Writeln('=============================================================
==================');
Writeln('|NO. |NIP
| Nama
| Golongan | Jam
Kerja | Gaji
|');
Writeln('=============================================================
==================');
Tot:=0;
For i := 1 to n do
Begin
Case Data[i].Golongan of
'1' : Gapok:=1000000;
'2' : Gapok:=1500000;
'3' : Gapok:=2000000;
Else
Gapok:=0;
End;
if Data[i].Jamkerja>200 then
Insentif:=(Data[i].Jamkerja-200)*10000
else
Insentif:=0;
Gaber:=Gapok+Insentif;
Tot:=Tot+Gaber;
Writeln('|',i:4,'|',Data[i].NIP:10,'|',Data[i].Nama:25,'|',Data[i].Gol
ongan:10,'|',Data[i].Jamkerja:10:0,
'|',Gaber:13:0,'|');
End;
Rata:=Tot/n;
Writeln('=============================================================
==================');
Writeln('Total Gaji Keseluruhan : Rp.',Tot:12:0);
Writeln('Rata Gaji Pegawai
: Rp.',Rata:12:0);

Writeln;
Write('Mau Ulang Lagi? [Y/T]: ');Readln(Ul);
Until Upcase(Ul)<>'Y';
End.

Output:

Program Prosedur_aktual;
Uses Wincrt;
Var Y:char;
m:byte;
Procedure Tampil(x:char;n:byte);
Var i:integer;
Begin
for i := 1 to n do
Write(x);
Writeln;
End;
Begin
Tampil('+',8);
Tampil('*',10);
Tampil('A',5);
Y:='B';
m:=11;
Tampil(Y,m);
End.

Output:

a:=2;b:=3;c:=0;
Coba(a,b,c);
Writeln('a = ',a);
Writeln('b = ',b);
Writeln('c = ',c);
End.

Output:

Program Tukar_Nilai;
Uses WinCrt;
Type Larik = Array [1..100] of Integer;
Var
A,B
: Larik;
i,x,m : Byte;
Procedure Tukar;
Var T:Integer;
Begin
x:=0;
For i := 1 to m do
Begin
T:=A[i];
A[i]:=B[i];
B[i]:=T;
Gotoxy(15+x,6);Write(A[i]);
Gotoxy(15+x,7);Write(B[i]);
x:=x+2;
End;
End;
Procedure Input;
Var x:Byte;
Begin
Randomize;
x:=0;
For i := 1 to m do
Begin A[i]:=Random(10);
B[i]:=Random(10);
Gotoxy(15+x,12);Write(A[i]);
Gotoxy(15+x,13);Write(B[i]);
x:=x+2;
End;
End;
Begin
Gotoxy(21,1);Write('Program Menukar Nilai Larik A & B');
Gotoxy(21,2);Write('=================================');
Gotoxy(1,4);Write('Jumlah Data : ');Readln(m);
Gotoxy(5,6);Write('Nilai A:');
Gotoxy(5,7);Write('Nilai B:');
Input;
Gotoxy(1,9);Write('Setelah Di Tukar');
Gotoxy(1,10);Write('================');
Gotoxy(5,12);Write('Nilai A:');

Gotoxy(5,13);Write('Nilai
Tukar;
End.

B:');

Output:

Program Urut_Pecahan;
Uses Wincrt;
Var pmb,pny
: array [1..10] of integer;
i,j,n
: integer;
Procedure Urut(x : integer);
Var t1,t2 : integer;
Begin
For i := 1 to x-1 do
For j := i+1 to x do
Begin
if ((pmb[i]/pny[i])>(pmb[j]/pny[j]))
Begin t1:=pmb[i];
t2:=pny[i];
pmb[i]:=pmb[j];
pny[i]:=pny[j];
pmb[j]:=t1;
pny[j]:=t2;
End;

then

End;
End;
Begin
Gotoxy(30,1);Write('Program Urut Pecahan');
Gotoxy(30,2);Write('====================');
Gotoxy(1,4);Write('Jumlah Data Pecahan: ');Readln(n);
For i := 1 to n do
Begin
Gotoxy(1,5+i);Write('Input Pecahan ke-',i,' : ');Readln(pmb[i]);
Gotoxy(24,5+i);Write('/ ');Readln(pny[i]);
End;
Urut(n);
Writeln;
Writeln('Hasilnya: ');
For i := 1 to n do
Writeln(pmb[i],'/',pny[i]);
End.

Output:

Program Indeks_Larik;
Uses Wincrt;
Var
x
: Array [1..100] of Integer;
i,n
Ul

: Integer;
: Char;

Procedure CekIndeks(m: integer);

Var t: Integer;
Begin
Writeln;
Write('Nomor Indeks > Total Nilai Larik Sebelumnya Adalah: ');
t:=0;
For i := 1 to m-1 do
Begin
t:=t+x[i];
if x[i+1]>t then
Write(i+1,' ');
End;

End;

Begin
Repeat
ClrScr;
Writeln('Program Menentukan Indeks Larik');
Writeln('===============================');
Writeln;
Write('Jumlah Data : ');Readln(n);
Writeln;
For i := 1 to n do
Begin
Write('Data Ke-',i,': ');Readln(x[i]);
End;
CekIndeks(n);
Writeln;Writeln;
Write('Mau Coba Lagi [Y/T]: ');Readln(Ul);
Until Upcase(Ul)<>'Y';
End.

Output:

2020

Program Acckerman;
Uses Wincrt;
Function ACC(m,n:integer):integer;
Begin
if m=0 then
begin ACC:=n+1;
Write(n+1,' ');
end
else if n=0 then
begin
ACC:=ACC(m-1,1);
Writeln(ACC(m-1,1),'
');
end
else
begin
ACC:=ACC(m-1,ACC(m,n-1));
Writeln(ACC(m-1,ACC(m,n-1)),'
end;
End;
Begin
Writeln(ACC(2,1));
End.

Program Menghitung_Suku;
Uses Wincrt;
Var tot,suku:real;
i:integer;
Begin
tot:=0;
suku:=2;
While tot <= 3.9999 Do
Begin
tot:=tot+suku;
i:=i+1;
suku:=suku/2;
End;
writeln(i);
End.

Output:
16

');

Program Menyusun_Kali_Matrik;
Uses Wincrt;
Var i,j,n:integer;
Begin
Write('Masukkan Jumlah Perkalian: ');Readln(n);
Write('*':5);
For i:= 1 to n do
Write(i:5);
Writeln;
For i:= 1 to n do
Begin
Write(i:5);
For j:= 1 to n do
write(i*j:5);
Writeln;
End;
End.

Output:

Program matrik;
uses wincrt;
type data = array[1..10,1..10] of integer;
var matrikI,matrikII : data;
baris,kolom,pil : integer;
procedure isimatrik;
var i,j : integer;
begin
writeln('Penentuan ORDO MATRIK I');
write('Masukan banyak baris matrik I = ');readln(baris);
write('Masukan banyak kolom matrik I = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikI[i,j]);
end;
clrscr;
writeln('Penentuan ORDO MATRIK II');
write('Masukan banyak baris matrik II = ');readln(baris);
write('Masukan banyak kolom matrik II = ');readln(kolom);
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
readln(matrikII[i,j]);
end;
end;

procedure jumlahmatrik(m1,m2 : data);

var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin hasil[i,j]:=m1[i,j]
+m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kurangmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=m1[i,j]-m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;
procedure kalimatrik(m1,m2 : data);
var hasil : data;
i,j,z : integer;
begin
for i:=1 to baris do
for j:=1 to kolom do
begin
hasil[i,j]:=0;
for z:=1 to baris do
hasil[i,j]:=hasil[i,j]+m1[i,z]*m2[z,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
for i:=1 to baris do
for j:=1 to kolom do
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;

begin
writeln(' M E N U');
writeln('(1) Penjumlahan Matrik');
writeln('(2) Pengurangan Matrik');
writeln('(3) Perkalian Matrik');
write('Pilihan = ');readln(pil);
clrscr;
case pil of
1 : begin isimatrik;
jumlahmatrik(matrikI,matrikII);
end;
2 : begin isimatrik;
kurangmatrik(matrikI,matrikII);
end;
3 : begin isimatrik;
kalimatrik(matrikI,matrikII);
end;
end;
end.

Output:

Program Max1_Max2;
Uses Wincrt;
Var
x: array[1..100] of integer;
i,n,max,sec: integer;
Begin
Write('Masukkan Jumlah Data: ');readln(n);
for i := 1 to n do
begin
x[i]:=random(18);
write(x[i],' ');
{readln(x[i]);}
end;
max:=x[1];
sec:=0;
for i := 1 to n do
begin
if (x[i]>max) then
begin
if (sec<max) then
sec:=max;
max:=x[i];
end;
if (max>x[i]) and (sec<x[i]) then sec:=x[i];
end;
writeln;
writeln('Max= ',max);

writeln('Second= ',sec);
End.

Ouput:

Program Pisahkan_Rekursif;
Uses Wincrt;
Procedure pisah(x,y:integer);
Begin
Writeln(x,'<--->',y);
if x<y then
begin
pisah(x,(x+y) div 2);
pisah((x+y) div 2+1,y);
end;
End;
Begin
pisah(5,10);
End.

Output:

Program Polinomial;
Uses Wincrt;
Type Larik = Array [1..10] of Integer;
var P1,P2,HP: Larik;
i,n,m,o: Integer;
Procedure Input(q:integer; var P:Larik);
Begin
for i := q+1 downto 1 do
begin
Write('nilai dari pangkat ke-',i-1,': ');Readln(P[i]);
end;
End;
Procedure Tampil(q:integer; P:Larik);
Begin
for i := q+1 downto 1 do
begin
if P[i]<>0 then

if i=q+1 then
Write(P[i],'x^',i-1)
else if P[i]>0 then
begin
if i=1 then
Write('+',P[i])
else if i=2 then
Write('+',P[i],'x')
else
Write('+',P[i],'x^',i-1);
end
else
begin
if i=1 then
Write(P[i])
else if i=2 then
Write(P[i],'x')
else
Write(P[i],'x^',i-1);
end;

end;

End;

Begin
Clrscr;
Writeln('Program Penjumlahan 2 Polinomial');
Writeln('================================');
Write('Masukkan
Jumlah
Pangkat
Tertinggi
');Readln(n);
Input(n,P1);
Write('P1 = ');
Tampil(n,P1);
Writeln;Writeln;
Write('Masukkan
');Readln(m);
Input(m,P2);
Write('P2 = ');
Tampil(m,P2);

Jumlah

Pangkat

if m>n then
o:=m
else
o:=n;
Writeln;
Writeln;
Write('Hasil Polinomial (P1+P2): ');
for i := o+1 downto 1 do
HP[i]:=P1[i]+P2[i];
Tampil(o,HP);
End.

Output:

Tertinggi

Polinomial

Ke-1:

Polinomial

Ke-2:

Program Menyusun_Rentang_Nilai;
Uses Wincrt;
Var i,tot,n:integer;
Begin
Write('Masukkan Jumlah Rentang Nilai: ');Readln(n);
For i:= 1 to n do
Begin
if (i mod 3 = 0) then
Begin
tot:=tot-i;
write('-',i);
End
else
Begin
tot:=tot+i;
if (i=1) then
write(i)
else
write('+',i);
End;
End;
Writeln;
Writeln('Total Rentang Nilai: ',tot);
End.

Output:

Program Segitiga_Pascal;
Uses Wincrt;
Var
i,j,n:integer;
x: array[1..100, 1..100] of integer;
Begin
Write('Masukkan Jumlah Baris: ');Readln(n);
For i:= 1 to n do
For j:= 1 to i do
Begin

if j=1 then x[i,j]:=1

else if j=i then x[i,j]:=1
else x[i,j]:=x[i-1,j-1]+x[i-1,j];
End;
For i:= 1 to n do
Begin
Gotoxy(40-3*i,2+i);
For j:= 1 to i do
write(x[i,j]:6);
End.

End;

Output:

Program Menyusun_Angka;
Uses Wincrt;
Var i,j,n:integer;
Begin
Write('Masukkan Jumlah Baris: ');Readln(n);
For i:= 1 to n do
Begin
Gotoxy(40-3*i,1+i);
For j:= 1 to i do
write(i:6);
End.

End;

Output:

Program Menyusun_Bintang;
Uses Wincrt;
Var i,j,n:integer;
Begin
Write('Masukkan Jumlah Baris: ');Readln(n);
For i:= 1 to n do
Begin
Gotoxy(40-3*i,1+i);
For j:= 1 to i do
write('*':6);
End.

End;

Output:

Program Transpose_Matrix;
Uses Wincrt;
Var A: Array [1..10,1..10] of integer;
i,j,baris,kolom :integer;
Begin
Clrscr;
Write('Masukkan Jumlah Baris : ');Readln(baris);
Write('Masukkan Jumlah Kolom : ');Readln(kolom);
Writeln;
Gotoxy(1,5);Write('A= ');
for i := 1 to baris do
for j := 1 to kolom do
begin
Gotoxy(j*5,i*2+3);
Readln(A[i,j]);
end;
Gotoxy(20,5);Write('AT=');
for i := 1 to kolom do
for j := 1 to baris do
begin
Gotoxy(j*5+20,i*2+3);
Write(A[j,i]);
end;
End.

Output:

Program Hitung_Nilai_Mhs;
Uses Wincrt;
Type Larik = array [1..100] of integer;
Var nilai,A,B,C,D,E : Larik;
n,i,tot
: Integer;
mean,sdt,sd
iA,iB,iC,iD,iE

: real;
: Integer;

Procedure input;
Begin
Writeln('Program Hitung Nilai');
Writeln('====================');
Write('Jumlah Data : ');readln(n);
Writeln;
Randomize;

For i:= 1 to n do
Begin
Write('Masukan Nilai [0..100] ke-',i,' : ');Readln(nilai[i]);
End;
Writeln;
End;
Procedure hitung_mean_sd;
Begin
tot:=0;
sdt:=0;
For i:= 1 to n do
Begin
tot:=tot+nilai[i];
End;
mean:=tot/n;
For i:= 1 to n do
Begin
sdt:=sdt+sqr(nilai[i]-mean);
End;
sd:=sqrt(sdt/(n));
End;
Procedure cari_nilai;
Begin
iA:=0; iB:=0; iC:=0; iD:=0; iE:=0;
For i := 1 to n Do
Begin
If (nilai[i]>=(mean+(1.5*sd))) Then
Begin Inc(iA);
A[iA]:=nilai[i];
End
Else If ((nilai[i]>=mean+(0.5*sd)) And (nilai[i]<mean+(1.5*sd)))
Then
Then
Then

Begin Inc(iB);
B[iB]:=nilai[i];
End
Else If ((nilai[i]>=mean-(0.5*sd))

And (nilai[i]<mean+(0.5*sd)))

Begin Inc(iC);
C[iC]:=nilai[i];
End
Else If ((nilai[i]>=mean-(1.5*sd))

And (nilai[i]<mean-(0.5*sd)))

Begin Inc(iD);
D[iD]:=nilai[i];
End
Else
Begin Inc(iE);
E[iE]:=nilai[i];
End;
End;

End;

Procedure urut_desc(z:Integer;Var

3030

X:Larik);

Var i,j,T: Integer;

Begin
For i:= 1 to z-1 Do
For j := 1 to z-1 Do
If X[j]<x[j+1] Then
Begin
T:=X[j];
X[j]:=X[j+1];
X[j+1]:=T;
End;

{kalau ascending X[j]>x[j+1]}

End;
Procedure tampil;
Begin
Writeln('Rata-Rata Nilai : ',mean:3:2);
Writeln('Standar Deviasi : ',sd:3:2);
Writeln;
Write('Nilai A: ');
urut_desc(iA,A);
For i:= 1 to iA Do
Write(A[i]:3,' ');
Writeln;
Write('Nilai B: ');
urut_desc(iB,B);
For i:= 1 to iB Do
Write(B[i]:3,' ');
Writeln;
Write('Nilai C: ');
urut_desc(iC,C);
For i:= 1 to iC Do
Write(C[i]:3,' ');
Writeln;
Write('Nilai D: ');
urut_desc(iD,D);
For i:= 1 to iD Do
Write(D[i]:3,' ');
Writeln;
Write('Nilai E: ');
urut_desc(iE,E);
For i:= 1 to iE Do
Write(E[i]:3,' ');
Writeln;
End;
Begin
Clrscr;
input;
hitung_mean_sd;
cari_nilai;
tampil;
End.

Output:

Program Konversi_Decimal_Ke_Romawi_Pakai_Array;
Uses WinCrt;
Const
Romawi : array [1..13] of String =
('M','CM','D','CD','C','XC','L','XL','X','IX','V','IV','I');
Desimal : array [1..13] of integer =
(1000,900,500,400,100,90,50,40,10,9,5,4,1);
VarB,B1,i : Integer;
Ul:Char;
Rom : String;
Begin
Repeat
Clrscr;
Writeln('Program Konversi Desimal Menjadi Romawi');
Writeln('=======================================');
Writeln;
Write('Masukkan Bilangan Antara [1..9999] : ');Readln(B);
Writeln;
Rom:='';
B1:=B;
If (B>0) And (B<10000) Then
Begin
For i:=1 To 13 Do
Begin
While (B>=Desimal[i]) Do
Begin
B:=B-Desimal[i];
Rom:=Rom+Romawi[i]
End;
End;
Writeln('Desimal ',B1,' = ',Rom,' Romawi');
End
Else
Writeln('Tidak Diketahui Simbol Romawinya!');
Writeln;
Write('Mau Ulang Lagi? [Y/T]: ');Readln(Ul);
Ul:=Upcase(Ul);
Until (Ul<>'Y');

End.

Output:

Program Konversi_Decimal_Ke_Romawi_Pakai_If;
Uses WinCrt;
Var
B,B1,i : Integer;
Ul:Char;
Rom : String;
Begin
Repeat
Clrscr;
Writeln('Program Konversi Desimal Menjadi Romawi');
Writeln('=======================================');
Writeln;
Write('Masukkan Bilangan Antara [1..9999] : ');Readln(B);
Writeln;
Rom:='';
B1:=B;
if (B>0) And (B<10000) Then
Begin
While (B>0) Do
Begin
If (B>=1000) Then
Begin
B:=B-1000;
Rom:=Rom+'M';
End
Else If (B>=900) Then
Begin
B:=B-900;
Rom:=Rom+'CM';
End
Else If (B>=500) Then
Begin
B:=B-500;
Rom:=Rom+'D';
End
Else If (B>=400) Then
Begin
B:=B-400;
Rom:=Rom+'CD';
End
Else If (B>=100) Then
Begin
B:=B-100;
Rom:=Rom+'C';
End
Else If (B>=90) Then

Begin
B:=B-90;
Rom:=Rom+'XC';
End
Else If (B>=50) Then
Begin
B:=B-50;
Rom:=Rom+'L';
End
Else If (B>=40) Then
Begin
B:=B-40;
Rom:=Rom+'XL';
End
Else If (B>=10) Then
Begin
B:=B-10;
Rom:=Rom+'X';
End
Else If (B>=9) Then
Begin
B:=B-9;
Rom:=Rom+'IX';
End
Else If (B>=5) Then
Begin
B:=B-5;
Rom:=Rom+'V';
End
Else If (B>=4) Then
Begin
B:=B-4;
Rom:=Rom+'IV';
End
Else If (B>=1) Then
Begin
B:=B-1;
Rom:=Rom+'I';
End
Else
B:=B-1;
End;
Writeln('Desimal ',B1,' = ',Rom,' Romawi');
End
Else
Writeln('Tidak Diketahui Simbol Romawinya!');
Writeln;
Write('Mau Coba Lagi? [Y/T]: ');
Ul:=Upcase(ReadKey);
Until (Ul<>'Y');
End.

Output:

Program Konversi_Desimal_Ke_Biner;
Uses WinCrt;
Var
Des,Desi: Integer;
Bin: String;
Ul:Char;
Begin
Repeat
Clrscr;
Writeln('Program Konversi Desimal Menjadi Biner');
Writeln('======================================');
Writeln;
Write('Masukkan Bilangan Desimal: ');Readln(Des);
Desi:=Des;
Bin:='';
Repeat
If(Des Mod 2 = 0) Then
Bin:='0'+Bin
Else
Bin:='1'+Bin;
Des:=Des Div 2;
Until Des=0;
Writeln;
Writeln(Desi,' Desimal = ',Bin,' Biner');
Writeln;
Write('Mau Ulang Lagi? [Y/T]: ');Readln(Ul);
Ul:=Upcase(Ul);
Until (Ul<>'Y');
End.

Output:

Program String1;
Uses WinCrt;
Var JumKal : Integer;
Kal
: String;
Ul
: Char;
Procedure CekJKal(Teks: String; Var JK: Integer);
Var i: Integer;
Begin
If (Teks[1]=' ') Then
JK:=0
Else
JK:=1;
For i:= 1 To Length(Teks) Do
Begin
If (Teks[i]=' ') And (Teks[i+1]<>' ') And (Teks[i+2]<>' ') Then
Inc(JK)
Else If (Teks[i]='-') And (Teks[i-1]<>' ') And (Teks[i+1]<>' ')
Then

End; Inc(JK);
End;

Begin
Repeat
Clrscr;
Writeln('Program Menghitung Jumlah Kata Dalam Kalimat');
Writeln('============================================');
Writeln;
Writeln('Masukkan Kalimat:');Readln(Kal);
CekJKal(Kal,JumKal);
Writeln;
Writeln('Jumlah
Buah');
Writeln;

Kata

Dalam

Kalimat

Di

Atas

Sebanyak:

',JumKal,'

Write('Mau Ulang Lagi [Y/T]: ');Ul:=Upcase(Readkey);

Until Ul<>'Y';
End.

Output:

Program String2;
Uses WinCrt;
Type Data=Record
Kata
: String;
End;
Larikdata
Var KataPjg :
i,j,idx :
Kal
:
Ul
:

= Array [1..100] of Data;

Larikdata;
Integer;
String;
Char;

Procedure Ambilkata(Var a,b: Integer; Kalimat: String);

Var Tmp : String;
Begin
Tmp:='';
While (Kalimat[a]<>' ') And (Kalimat[a]<>'-') And (Kalimat[a]<>'!')
And
(Kalimat[a]<>'?')
And
(Kalimat[a]<>',')
And
(Kalimat[a]<>'.')
And
(Kalimat[a]<>':')
And
(Kalimat[a]<>';')
And
(a<=Length(Kalimat)) Do
Begin
Tmp:=Tmp+Kalimat[a];
Inc(a);
End; Inc(b);
KataPjg[b].Kata:=Tmp;
End;

Procedure CariKataTerpanjang(x:Integer;Var
Var i,max: Integer;
Begin

indeks: Integer);

max:=0;
For i:= 1 to x Do
If max<Length(KataPjg[i].Kata) Then
Begin
max:=Length(KataPjg[i].Kata);
indeks:=i;
End;
End;
Begin
Repeat
Clrscr;
Writeln('Program Cari Kata Terpanjang Dalam Kalimat');
Writeln('==========================================');
Writeln;
Writeln('Masukkan Kalimat:');Readln(Kal);
i:=1;
j:=0;
While i<=Length(Kal) Do
Begin
If (i=1) And (Kal[1]<>' ') Then
AmbilKata(i,j,Kal)
Else If (Kal[i]=' ') And (Kal[i+1]<>'

') And (Kal[i+2]<>'

')

Begin Inc(i);
AmbilKata(i,j,Kal);
End
Else If (Kal[i]='-') And (Kal[i-1]<>'

') And (Kal[i+1]<>'

')

Then

Begin Inc(i);
AmbilKata(i,j,Kal);
End
Else

Then

End;

Inc(i);

CariKataTerpanjang(j,idx);
Writeln;
Writeln('Kata
Terpanjang
Dalam
Kalimat
',Katapjg[idx].kata);
Writeln;
Write('Mau Ulang Lagi [Y/T]: ');Ul:=Upcase(Readkey);
Until Ul<>'Y';
End.

Output:

Di

Atas:

Program String3;
Uses WinCrt;
Type Data=Record
Kata
: String;
End;
Larikdata
Var Katacr
i,j
Kal
Ul
Crkata,idx
ketemu

=
:
:
:
:
:
:

Array [1..100] of Data;

Larikdata;
Integer;
String;
Char;
String;
Integer;

Procedure Ambilkata(Var a,b: Integer; Kalimat: String);

Var Tmp : String;
Begin
Tmp:='';
While (Kalimat[a]<>' ') And (Kalimat[a]<>'-') And (Kalimat[a]<>'!')
And
(Kalimat[a]<>'?')
And
(Kalimat[a]<>',')
And
(Kalimat[a]<>'.')
And
(Kalimat[a]<>':')
And
(Kalimat[a]<>';')
And
(a<=Length(Kalimat)) Do
Begin
Tmp:=Tmp+Kalimat[a];
Inc(a);
End; Inc(b);
Katacr[b].Kata:=Tmp;
End;
Procedure
CariKata(x:Integer;Carikt:String;Var
ktm:Integer);
Function IntToStr(k: Longint): String;
Var
S: string[11];
Begin
Str(k, S);
IntToStr := S;
End;
Var i: Integer;
Begin
For i:= 1 to x Do
Begin
If Carikt=Katacr[i].Kata Then
Begin Inc(ktm);
indeks:=indeks+IntToStr(i)+'
End;
End;

';

End;

Begin
Repeat
Clrscr;
Writeln('Program Cari Kata Dalam Kalimat');
Writeln('===============================');
Writeln;
Writeln('Masukkan Kalimat:');Readln(Kal);

indeks:String;Var

Writeln;
Write('Masukkan Kata Yang Dicari: ');Readln(Crkata);
i:=1;
j:=0;
idx:='';
ketemu:=0;
While i<=Length(Kal) Do
Begin
If (i=1) And (Kal[1]<>' ') Then
AmbilKata(i,j,Kal)
Else If (Kal[i]=' ') And (Kal[i+1]<>' ') And (Kal[i+2]<>'

')

Then
Begin Inc(i);
AmbilKata(i,j,Kal);
End
Else If (Kal[i]='-')

And (Kal[i-1]<>'

') And (Kal[i+1]<>'

')

Begin Inc(i);
AmbilKata(i,j,Kal);
End
Else

Then

End;

Inc(i);

CariKata(j,Crkata,idx,ketemu);
Writeln;
if (ketemu>0) then
Writeln('Kata "',Crkata,'" Ditemukan Dalam Kalimat Pada Posisi:
',idx,'.')
else
Writeln('Kata "',Crkata,'" Tidak Ditemukan Dalam Kalimat!');
Writeln;
Write('Mau Ulang Lagi [Y/T]: ');Ul:=Upcase(Readkey);
Until Ul<>'Y';
End.

Output:

Program Data_Mahasiswa;
Uses WinCrt;
Type Mahasiswa = Record
NoMhs : Word;
Nama : String[20];
IPK
: Real;
Usia : Byte;
End;

Var Filemhs
Data
Pil,Ul

: File of Mahasiswa;
: Mahasiswa;
: Char;

Procedure Menu;
Begin
Clrscr;
Gotoxy(34,1);Write('MENU PILIHAN');
Gotoxy(34,2);Write('============');
Gotoxy(27,4);Write('1. Tambah Data Mahasiswa');
Gotoxy(27,5);Write('2. Edit Data Mahasiswa');
Gotoxy(27,6);Write('3. Hapus Data Mahasiswa');
Gotoxy(27,7);Write('4. Tampilkan Data Mahasiswa');
Gotoxy(27,8);Write('5. View Mahasiswa Berdasarkan Umur');
Gotoxy(27,9);Write('6. Hapus NoMhs Ganjil');
Gotoxy(27,10);Write('9. Keluar (Exit)');
Gotoxy(32,12);Write('Pilihan [1..9]: ');Pil:=Readkey;
End;
Procedure BukaFile;
Begin
Assign(FileMhs,'Mhs.Dat');
{$I-};
Reset(FileMhs);
{$I+};
End;
Procedure
Var Lagi:
Ada :
i
:
NOCR:
Begin

Tambah;
Char;
Boolean;
Integer;
Word;

Ul:='Y';
Lagi:='Y';
Clrscr;
BukaFile;
If IOResult<>0 Then
Rewrite(FileMhs);
Repeat
Clrscr;
Ada:=False;
i:=0;
Gotoxy(30,1);Write('TAMBAH DATA MAHASISWA');
Gotoxy(30,2);Write('=====================');
Gotoxy(20,4);Write('No. Mahasiswa : ');Readln(NOCR);
While (Ada=False) And (i<>Filesize(FileMhs)) Do
Begin
Seek(FileMhs,i);
Read(FileMhs,Data);
If Data.NoMhs=NOCR Then
Ada:=True
Else
Inc(i);
End;
If (Ada=True) Then
Begin

4040

Ada!');

Gotoxy(20,9);Write('Nomor

Mahasiswa

"',NOCR,'"

Ini

Sudah

End
Else
Begin
Seek(FileMhs,Filesize(FileMhs));
Data.NoMhs:=NOCR;
Gotoxy(20,5);Write('Nama Mahasiswa : ');Readln(Data.Nama);
Gotoxy(20,6);Write('IPK
: ');Readln(Data.IPK);
Gotoxy(20,7);Write('Umur
: ');Readln(Data.Usia);
Write(FileMhs,Data);
End;
Gotoxy(20,10);Write('Mau
Tambah
Data
Lagi
[Y/T]:
');Lagi:=Upcase(Readkey);
Until Lagi<>'Y';
Close(FileMhs);
End;
Procedure Edit;
Var Lagi: Char;
Ada : Boolean;
i
: Integer;
NOCR: Word;
Begin
Ul:='Y';
Lagi:='Y';
Clrscr;
BukaFile;
If IOResult<>0 Then
Write('Data Masih Kosong...!')
Else
Begin
Repeat
Clrscr;
Ada:=False;
i:=0;
Gotoxy(30,1);Write('EDIT

DATA MAHASISWA');

Gotoxy(30,2);Write('=====================');
Gotoxy(20,4);Write('No. Mahasiswa : ');Readln(NOCR);
While (Ada=False) And (i<>Filesize(FileMhs)) Do
Begin
Seek(FileMhs,i);
Read(FileMhs,Data);
If Data.NoMhs=NOCR Then
Begin
Ada:=True;
Gotoxy(20,5);Write('Nama Mahasiswa : ',Data.Nama);
Gotoxy(20,6);Write('IPK
: ',Data.IPK:1:2);
Gotoxy(20,7);Write('Umur
: ',Data.Usia);
End
Else
Inc(i);
End;
If (Ada=True) Then
Begin
Data.NoMhs:=NOCR;
Gotoxy(20,9);Write('Nama
Gotoxy(20,10);Write('IPK

4141

Mahasiswa : ');Readln(Data.Nama);
: ');Readln(Data.IPK);

Gotoxy(20,11);Write('Umur
');Readln(Data.Usia);
Seek(FileMhs,i);
Write(FileMhs,Data);
End
Else
Begin
Gotoxy(20,13);Write('Nomor
Ada!');

End;
Gotoxy(20,14);Write('Mau

Mahasiswa

Edit

"',NOCR,'"

Data

Lagi

Ini Tidak
[Y/T]:

');Lagi:=Upcase(Readkey);
Until Lagi<>'Y';
End;
Close(FileMhs);
End;
Procedure Hapus;
Var FileTmp
: File of Mahasiswa;
Lagi,Hapus: Char;
Ada
: Boolean;
i
NOCR
Begin

: Integer;
: Word;

Ul:='Y';
Lagi:='Y';
Clrscr;
Repeat
BukaFile;
If IOResult<>0 Then
Write('Data Masih Kosong...!')
Else
Begin
Clrscr;
Assign(FileTmp,'mhs.tmp');
Rewrite(FileTmp);
Ada:=False;
i:=0;
Gotoxy(30,1);Write('HAPUS DATA MAHASISWA');
Gotoxy(30,2);Write('=====================');
Gotoxy(20,4);Write('No. Mahasiswa : ');Readln(NOCR);
While (Ada=False) And (i<>Filesize(FileMhs)) Do
Begin
Seek(FileMhs,i);
Read(FileMhs,Data);
If Data.NoMhs=NOCR Then
Ada:=True
Else
Inc(i);
End;
If (Ada=True) Then
Begin
Gotoxy(20,5);Write('Nama Mahasiswa : ',Data.Nama);
Gotoxy(20,6);Write('IPK
: ',Data.IPK:1:2);
Gotoxy(20,7);Write('Umur
: ',Data.Usia);
Gotoxy(20,9);Write('Data
Ini
Mau
Di
Hapus
[Y/T]:
');Readln(Hapus);
If Upcase(Hapus)='Y' Then
Begin

For i := 1 to Filesize(FileMhs) Do
Begin
Seek(FileMhs,i-1);
Read(FileMhs,Data);
If Data.NoMhs<>NOCR Then
Write(FileTmp,Data);
End; Close(FileMhs);
Assign(FileMhs,'MHS.Dat');
Erase(FileMhs);
Assign(FileTmp,'Mhs.tmp');
Rename(FileTmp,'Mhs.Dat');
Gotoxy(20,10);Write('Nomor
Di Hapus!');

Mahasiswa

"',NOCR,'"

Sudah

End;

End
Else
Begin
Gotoxy(20,10);Write('Nomor

Mahasiswa

"',NOCR,'"

Ini Tidak

Ada!');
End;
Gotoxy(20,11);Write('Mau

Hapus

Data

Lagi

[Y/T]:

');Lagi:=Upcase(Readkey);
End;
Until Lagi<>'Y';
End;
Function RataIPK(TIPK:Real;n:integer):Real;
Begin
RataIPK:=TIPK/n;
End;
Procedure Tampil;
Var i
: Integer;
TIPK : Real;
Begin
Ul:='Y';
TIPK:=0;
BukaFile;
If IoResult <> 0 Then
Write('Maaf Data Masih Kosong ! ')
Else
Begin
Clrscr;
Writeln('
DATA MAHASISWA
');
Writeln;
Writeln('================================================');
Writeln(' NO
NIM
NAMA
IPK
UMUR ');
Writeln('================================================');
i:=0;
While Not EoF(FileMhs) Do
Begin Inc(i);
Read(FileMhs,Data);
Writeln(i:3,Data.NoMhs:6,Data.Nama:20,Data.IPK:8:2,Data.Usia:10);
TIPK:=TIPK+Data.IPK;
End;
Writeln('================================================');

Writeln('Rata-Rata IPK: ',RataIPK(TIPK,i):1:2);

Writeln('================================================');
Close(FileMhs);
End;
Writeln;
Write('Press Any Key to Continue...');Readkey;
End;
Procedure View_Umur;
Var i
: Integer;
Umur : Byte;
Lagi : Char;
Begin
Ul:='Y';
Lagi:='Y';
Repeat
Clrscr;
Write('Tampilkan Umur Besar Dari: ');Readln(Umur);
BukaFile;
If IoResult <> 0 Then
Write('Maaf Data Masih Kosong ! ')
Else
Begin
Writeln('
DATA MAHASISWA
');
Writeln('
UMUR DI ATAS ',Umur:2,' TAHUN');
Writeln;
Writeln('================================================');
Writeln(' NO
NIM
NAMA
IPK
UMUR ');
Writeln('================================================');
i:=0;
While Not EoF(FileMhs) Do
Begin
Read(FileMhs,Data);
If Data.Usia>Umur Then
Begin
Inc(i);
Writeln(i:3,Data.NoMhs:6,Data.Nama:20,Data.IPK:8:2,Data.Usia:10);
End;
End;
Writeln('================================================');
Close(FileMhs);
End;
Writeln;
Write('Mau Lihat Data Lagi [Y/T]: ');Lagi:=Upcase(Readkey);
Until Lagi<>'Y';
End;
Procedure Hapus_NoMhs;
Var FileTmp
: File of Mahasiswa;
Lagi,Hapus: Char;
i
: Integer;
Begin
Ul:='Y';
Lagi:='Y';
Clrscr;
Repeat
BukaFile;

If IOResult<>0 Then
Write('Data Masih Kosong...!')
Else
Begin Clrscr;
Assign(FileTmp,'mhs.tmp');
Rewrite(FileTmp);
i:=0;
Gotoxy(20,3);Write('Mau
Menghapus No.
[Y/T]: ');Readln(Hapus);
If Upcase(Hapus)='Y' Then
Begin
For i := 1 to Filesize(FileMhs) Do
Begin
Seek(FileMhs,i-1);
Read(FileMhs,Data);
If (Data.NoMhs Mod 2)=0 Then
Write(FileTmp,Data);

Mahasiswa

Yang

Ganjil

End; Close(FileMhs);
Assign(FileMhs,'Mhs.Dat');
Erase(FileMhs);
Assign(FileTmp,'Mhs.tmp');
Rename(FileTmp,'Mhs.Dat');
Gotoxy(20,10);Write('Nomor Mahasiswa Sudah Di Hapus!');
End;
Gotoxy(20,11);Write('Mau
Hapus
Data
Lagi
[Y/T]:
');Lagi:=Upcase(Readkey);
End;
Until Lagi<>'Y';
End;
Begin
Repeat
Menu;
Case Pil Of
'1' : Tambah;
'2' : Edit;
'3' : Hapus;
'4' : Tampil;
'5' : View_Umur;
'6' : Hapus_NoMhs;
End;
Until (Ul<>'Y') Or (Pil='9');
DoneWinCrt;
End.

Output:

Program Sorting;
Uses WinCrt,WinDos;
Const Max=1000;
Type Larik = Array [0..Max] Of Word;
Var X
n
PolaIns,PolaBub,PolaQck,
PolaMrg,PolaSlk,PolaShl
J1,J2,M1,M2,D1,D2,MD1,MD2
SI,SB,SQ,SM,SS,SH
Lg

: Larik;
: Longint;
:
:
:
:

Longint;
Word;
Longint;
Char;

Procedure AcakData(Var A: Larik; m: Longint);

Var i:Longint;
Begin
Writeln('Data Yang Di Acak: ');
Randomize;
For i:= 1 To m Do
Begin
A[i]:=Random(1000)+1;
Write(A[i],' ');
End;
End;
Procedure Ganti(Var A,B: Word);
Var G:Word;
Begin
G:=A;
A:=B;
B:=G;
End;
Procedure Insert(A: Larik; m: Longint; Var baca: Longint);
Var i,j,G: Longint;
Begin
baca:=0;
For i:= 2 To m Do
Begin
G:=A[i];
j:=i-1;
A[0]:=G;
While G<A[j] Do
Begin
A[j+1]:=A[j];
Dec(j);

Inc(baca);
End;
A[j+1]:=G;
End;
Writeln('Hasil Pengurutan Insert: ');
For i:= 1 To m Do
Write(A[i],' ');
End;
Procedure Buble(A: Larik; m:Longint; Var baca: Longint);
Var i,j: Longint;
Begin
baca:=0;
For i:= 1 To m-1 Do
For j := 1 To m-i Do
if A[j]>A[j+1] Then
Begin
Ganti(A[j],A[j+1]);
Inc(baca);
End;
Writeln('Hasil Pengurutan Buble: ');
For i:= 1 To m Do
Write(A[i],' ');
End;
Procedure Quick(A: Larik; m : Longint; Var baca:Longint);
Var i: Longint;
Procedure Urut(awal, akhir: Longint);
Var kiri, kanan, pusat : Longint;
Begin
pusat:=A[(awal+akhir) div 2];
kiri:=awal;
kanan:=akhir;
While kiri<=kanan Do
Begin
While A[kiri]<pusat Do
Inc(kiri);
While A[kanan]>pusat Do
Dec(kanan);
If kiri<=kanan Then
Begin
Ganti(A[kiri],A[kanan]);
Inc(kiri);
Dec(kanan);
Inc(baca);
End;
End;
If kanan>awal Then
Urut(awal,kanan);
If akhir>kiri Then
Urut(kiri,akhir);
End;
Begin
baca:=0;
Urut(1,m);
Writeln('Hasil Pengurutan Quick: ');
For i:= 1 To m Do

End;

Write(A[i],'

');

Procedure Merge(A: Larik; m : Integer; Var baca : Longint);

Var cch,i : Longint;
B
: Larik;
Procedure MergeSort(Var A,B: Larik; awal, tengah, akhir: Longint);
Var i,j,k,t: Longint;
Begin
i:=awal;
k:=awal;
j:=tengah+1;
Repeat
If A[i]<A[j] Then
Begin
B[k]:=A[i];
Inc(i);
End
Else
Begin
B[k]:=A[j];
Inc(j);
End;
Inc(k);
Inc(baca);
Until (i>tengah) Or (j>akhir);
If i>tengah Then
For t:= j To akhir Do
Begin
B[k+t-j]:=A[t];
End
Else
For t:= i To tengah Do
Begin
B[k+t-i]:=A[t];
End;
End;
Procedure Iterasi(Var A,B: Larik; m,cch: Longint);
Var i,t: Longint;
Begin
i:=1;
While i<=(m-2*cch+1) Do
Begin
MergeSort(A,B,i,i+cch-1,i+2*cch-1);
i:=i+2*cch;
End;
If (i+cch-1)<m Then
MergeSort(A,B,i,i+cch-1,m)
Else
For t:= i To m do
B[t]:=A[t];
End;
Begin
baca:=0;
cch:=1;
While cch<m Do
Begin

Iterasi(A,B,m,cch);
cch:=2*cch;
Iterasi(B,A,m,cch);
cch:=2*cch;
End;
Writeln('Hasil Pengurutan Merge: ');
For i:= 1 To m Do
Write(A[i],' ');
End;
Procedure Selek(A: Larik; m: Longint; Var baca : Longint);
Var i,j,tempat: Longint;
Begin
baca:=0;
For i:= 1 To m-1 Do
Begin
tempat:=i;
For j:= i+1 To m Do
If A[tempat]>A[j] Then
tempat:=j;
Ganti(A[i],A[tempat]);
Inc(baca);
End;
Writeln('Hasil Pengurutan Seleksi: ');
For i:= 1 To m Do
Write(A[i],' ');
End;
Procedure Shell(A: Larik; m: Longint; Var baca: Longint);
Var i,j: Longint;
Begin
baca:=0;
For i:= (m Div 2) Downto 1 Do
For j:= 1 To m-i Do
If A[j]>A[j+i] Then
Begin
Ganti(A[j],A[j+i]);
Inc(baca);
End;
Writeln('Hasil Pengurutan Shell: ');
For i:= 1 To m Do
Write(A[i],' ');
Writeln;
End;
Procedure SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2:
Longint);
Begin
Selisih:=((J2*360000)+(M2*6000)+(D2*100)+MD2)((J1*360000)+(M1*6000)+(D1*100)+MD1);
End;
Begin
Repeat
Clrscr;
Writeln('Program Pengurutan/Sorting');
Writeln('==========================');
Write('Masukkan Jumlah Data: ');Readln(n);

Word;

Var

Selisih:

AcakData(X,n);
Writeln;Writeln;
GetTime(J1,M1,D1,MD1);
Insert(X,n,PolaIns);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SI);
Writeln;
GetTime(J1,M1,D1,MD1);
Buble(X,n,PolaBub);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SB);
Writeln;
GetTime(J1,M1,D1,MD1);
Quick(X,n,PolaQck);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SQ);
Writeln;
GetTime(J1,M1,D1,MD1);
Merge(X,n,PolaMrg);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SM);
Writeln;
GetTime(J1,M1,D1,MD1);
Selek(X,n,PolaSlk);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SS);
Writeln;
GetTime(J1,M1,D1,MD1);
Shell(X,n,PolaShl);
GetTime(J2,M2,D2,MD2);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SH);
Writeln;
Writeln('Jumlah Data Sebanyak "',n,'" Dapat Dilakukan:');
Writeln('1. Pola Urut Data (Insert)
: ',PolaIns:10,' Kali,
',SI:5,' MiliDetik');
Writeln('2. Pola Urut Data (Buble)
: ',PolaBub:10,' Kali,
',SB:5,' MiliDetik');
Writeln('3. Pola Urut Data (Quick)
: ',PolaQck:10,' Kali,
',SQ:5,' MiliDetik');
Writeln('4. Pola Urut Data (Merge)
: ',PolaMrg:10,' Kali,
',SM:5,' MiliDetik');
Writeln('5. Pola Urut Data (Seleksi) : ',PolaSlk:10,' Kali,
',SS:5,' MiliDetik');
Writeln('6. Pola Urut Data (Shell)
: ',PolaShl:10,' Kali,
',SH:5,' MiliDetik');
Writeln;
Write('Mau Coba Lagi? [Y/T]: ');Lg:=Upcase(Readkey);
Until Lg<>'Y';
End.

Output:

5050

Waktu:
Waktu:
Waktu:
Waktu:
Waktu:
Waktu:

Program Antrian_Statis_Tanpa_Geser;
Uses Wincrt;
Const Max_Antrian = 10;
Type Antri = Array [1..Max_Antrian] of Char;
Var Antrian
: Antri;
Depan, Belakang : Integer;
Elemen,Pil,Pil1 : Char;
Procedure InitAntrian;
Begin
Depan:=0;
Belakang:=0;
End;
Procedure Tambah(Var Antrian: Antri; X: Char);
Begin
If Belakang<>Max_Antrian Then
Begin Inc(Belakang);
Antrian[Belakang]:=X;
End
Else
Writeln('ANTRIAN SUDAH PENUH');
End;
Procedure Hapus(Var Antrian: Antri);
Begin
If Depan<>Belakang Then
Begin Inc(Depan);
Antrian[Depan]:=' ';
If Depan=Belakang Then
Begin

5151

{Depan:=0;Belakang:=0;}InitAntrian;
End;
End
Else
Begin

End;

Writeln('ANTRIAN KOSONG');
{Depan:=0;Belakang:=0;}w
InitAntrian;
End;

Procedure Tampilkan;
Var i : Integer;
Begin
Write('Keluar <== |');
For i := 1 To Max_Antrian Do
Write(' ',Antrian[i],' |');
Write(' <== Masuk');
End;
Begin
InitAntrian;
Repeat
Clrscr;
Writeln('DAFTAR MENU PILIHAN');
Writeln('===================');
Writeln('1. Tambah Elemen');
Writeln('2. Hapus Elemen');
Writeln('3. Exit');
Write('Pilihan [1..3]: ');Pil:=ReadKey;
Case Pil of
'1' : Begin
Repeat
Clrscr;
Writeln('TAMBAH ELEMEN');
Writeln('=============');
Writeln;
Write('Isikan Elemen: ');Readln(Elemen);
Tambah(Antrian,Elemen);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Tambah
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
'2' : Begin
Repeat
Clrscr;
Writeln('HAPUS ELEMEN');
Writeln('=============');
Hapus(Antrian);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Hapus
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;

5252

Elemen

Lagi?

[Y/T]:

Elemen

Lagi?

[Y/T]:

End;
Until Pil='3';
End.
Program Antrian_Statis_Geser;
Uses Wincrt;
Const Max_Antrian = 5;
Type Antri = Array [1..Max_Antrian] of Char;
Var Antrian
: Antri;
Depan, Belakang : Integer;
Elemen,Pil,Pil1 : Char;
Procedure InitAntrian;
Begin
Depan:=0;
Belakang:=0;
End;
Procedure Tambah(Var Antrian: Antri; X: Char);
Begin
If Belakang<>Max_Antrian Then
Begin Inc(Belakang);
Antrian[Belakang]:=X;
End
Else
Writeln('ANTRIAN SUDAH PENUH');
End;
Procedure Hapus(Var Antrian: Antri);
Var i: Integer;
Begin
If Depan<>Belakang Then
Begin
For i:= 2 To Belakang Do
Begin
Antrian[i-1]:=Antrian[i];
End;
Antrian[Belakang]:=' ';
Dec(Belakang);
End
Else
Writeln('ANTRIAN KOSONG');
End;
Procedure Tampilkan;
Var i : Integer;
Begin
Write('Keluar <== |');
For i := 1 To Max_Antrian Do
Write(' ',Antrian[i],' |');
Write(' <== Masuk');
End;
Begin
InitAntrian;
Repeat

Clrscr;
Writeln('DAFTAR MENU PILIHAN');
Writeln('===================');
Writeln('1. Tambah Elemen');
Writeln('2. Hapus Elemen');
Writeln('3. Exit');
Write('Pilihan [1..3]: ');Pil:=ReadKey;
Case Pil of
'1' : Begin
Repeat
Clrscr;
Writeln('TAMBAH ELEMEN');
Writeln('=============');
Writeln;
Write('Isikan Elemen: ');Readln(Elemen);
Tambah(Antrian,Elemen);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Tambah
Elemen
Lagi?
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
'2' : Begin
Repeat
Clrscr;
Writeln('HAPUS ELEMEN');
Writeln('=============');
Hapus(Antrian);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Hapus
Elemen
Lagi?
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
End;
Until Pil='3';
End.
Program Antrian_Statis_Circular;
Uses Wincrt;
Const Max_Antrian = 5;
Type Antri = Array [1..Max_Antrian] of Char;
Var Antrian
: Antri;
Depan, Belakang : Integer;
Elemen,Pil,Pil1 : Char;
Procedure InitAntrian;
Begin
Depan:=0;
Belakang:=0;
End;
Procedure Tambah(Var Antrian: Antri; X: Char);
Begin
If Belakang=Max_Antrian Then

[Y/T]:

[Y/T]:

Begin
Belakang:=1;
End
Else
Inc(Belakang);
If Depan=Belakang Then
Begin
Writeln('ANTRIAN SUDAH PENUH');
Dec(Belakang);
If Belakang=0 Then
Belakang:=Max_Antrian;
End
Else
Antrian[Belakang]:=X;
Writeln('Depan: ',Depan,'
End;

Belakang: ',Belakang);

Procedure Hapus(Var Antrian: Antri);

Begin
If Depan<>Belakang Then
Begin
If Depan=Max_Antrian Then
Depan:=1
Else
Begin Inc(Depan);
Antrian[Depan]:=' ';
End;
End
Else
Writeln('ANTRIAN KOSONG');
Writeln('Depan: ',Depan,'
End;

Belakang: ',Belakang);

Procedure Tampilkan;
Var i : Integer;
Begin
Write('Keluar <== |');
For i := 1 To Max_Antrian Do
Write(' ',Antrian[i],' |');
Write(' <== Masuk');
End;
Begin
InitAntrian;
Repeat
Clrscr;
Writeln('DAFTAR MENU PILIHAN');
Writeln('===================');
Writeln('1. Tambah Elemen');
Writeln('2. Hapus Elemen');
Writeln('3. Exit');
Write('Pilihan [1..3]: ');Pil:=ReadKey;
Case Pil of
'1' : Begin
Repeat
Clrscr;

Writeln('TAMBAH ELEMEN');
Writeln('=============');
Writeln;
Write('Isikan Elemen: ');Readln(Elemen);
Tambah(Antrian,Elemen);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Tambah
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
'2' : Begin
Repeat
Clrscr;
Writeln('HAPUS ELEMEN');
Writeln('=============');
Hapus(Antrian);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Write('Mau
Hapus
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
End;
Until Pil='3';
End.

Elemen

Lagi?

[Y/T]:

Elemen

Lagi?

[Y/T]: