Kumpulan program pascal

Kumpulan Program Pascal

Decky Hendarsyah
dex_3000@yahoo.com

Lisensi Dokumen:
Copyright © 2003-2008 IlmuKomputer.Com
Seluruh dokumen di IlmuKomputer.Com dapat digunakan, dimodifikasi dan disebarkan secara
bebas untuk tujuan bukan komersial (nonprofit), dengan syarat tidak menghapus atau merubah
atribut penulis dan pernyataan copyright yang disertakan dalam setiap dokumen. Tidak
diperbolehkan melakukan penulisan ulang, kecuali mendapatkan ijin terlebih dahulu dari
IlmuKomputer.Com.

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:

Komunitas eLearning IlmuKomputer.Com 1

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;


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 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 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,' ','X2= ',X2: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:


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 : ',rata:6:2);
End.


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('=============');
Writeln;
Writeln;Writeln('Data Harus Urut');
For i:= 1 to n do
Readln(x[i]);
Writeln;
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:


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('=============');
Writeln;
Write('Masukkan Jumlah Data (Data harus Urut): ');readln(n);
Writeln;
For i:= 1 to n do
Readln(x[i]);
Writeln;
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;


Writeln;
Writeln('Nilai Maximal : ',max);
Writeln('Nilai Minimal : ',min);
Writeln('Nilai Rata-Rata : ',rt:4:2);
Writeln('Standar Deviasi : ',sd:4:2);
Writeln('Median : ',md:4:2);
End.
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;


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 : ');Readln(NIM);
Write('Nama : ');Readln(Nama);
Write('Program Studi : ');Readln(Prodi);
Write('IP : ');Readln(IP);
End;
Writeln;
Writeln;
Writeln('NIM : ',data.NIM);
Writeln('Nama : ',data.Nama);
Writeln('Program Studi : ',data.Prodi);
Writeln('IP : ',data.IP:2:2);
End.
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])) 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
End.
Output:

Program DataPegawai;
Uses Wincrt;
Type Pegawai = record
NIP : String[9];
Nama : String[30];
Golongan : Char;
Jamkerja : Real;
End;
Var
Data : Pegawai;
Gapok : Real;
Insentif,Gaber : Real;
Ul : Char;
Begin
Repeat
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


'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 : Array [1..100] of Pegawai;
Gapok,Insentif,Gaber : Real;
Tot,Rata : 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;
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:

Program Prosedur_reference;
Uses Wincrt;
Var a,b,c : Integer;

Procedure Coba(x,y:integer; var z:integer);
Begin
x:=x+1;
y:=y+1;
z:=x+y;
End;

Begin


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 B:');
Tukar;
End.
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])) then
Begin
t1:=pmb[i];
t2:=pny[i];
pmb[i]:=pmb[j];
pny[i]:=pny[j];
pmb[j]:=t1;
pny[j]:=t2;
End;
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

End.
Output:


Program Indeks_Larik;
Uses Wincrt;
Var
x : Array [1..100] of Integer;
i,n : Integer;
Ul : 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);
End.
Output:


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);
begin
gotoxy(j*10,i*5);
readln(matrikII[i,j]);
end;
end;


procedure jumlahmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
begin
hasil[i,j]:=m1[i,j]+m2[i,j];
end;
clrscr;
writeln('Hasil Penjumlahan MATRIK');
begin
gotoxy(j*10,i*5);
write(hasil[i,j]);
end;
end;

procedure kurangmatrik(m1,m2 : data);
var hasil : data;
i,j : integer;
begin
begin
hasil[i,j]:=m1[i,j]-m2[i,j];
end;
clrscr;
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
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;
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
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 Polinomial Ke-1:
');Readln(n);
Input(n,P1);
Write('P1 = ');
Tampil(n,P1);

Writeln;Writeln;
Write('Masukkan Jumlah Pangkat Tertinggi Polinomial Ke-2:
');Readln(m);
Input(m,P2);
Write('P2 = ');
Tampil(m,P2);

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:


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
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
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 : real;
iA,iB,iC,iD,iE : 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
Begin
Inc(iB);
B[iB]:=nilai[i];
End
Else If ((nilai[i]>=mean-(0.5*sd)) And (nilai[i]<mean+(0.5*sd)))
Then
Begin
Inc(iC);
C[iC]:=nilai[i];
End
Else If ((nilai[i]>=mean-(1.5*sd)) And (nilai[i]<mean-(0.5*sd)))
Then
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 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 {kalau ascending X[j]>x[j+1]}
Begin
T:=X[j];
X[j]:=X[j+1];
X[j+1]:=T;
End;
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);
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
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;
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
Begin
B:=B-500;
Rom:=Rom+'D';
End
Begin
B:=B-400;
Rom:=Rom+'CD';
End
Begin
B:=B-100;
Rom:=Rom+'C';
End


Begin
B:=B-90;
Rom:=Rom+'XC';
End
Begin
B:=B-50;
Rom:=Rom+'L';
End
Begin
B:=B-40;
Rom:=Rom+'XL';
End
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;
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


Inc(JK);
End;
End;

Begin
Repeat
Clrscr;
Writeln('Program Menghitung Jumlah Kata Dalam Kalimat');
Writeln('============================================');
Writeln;
Writeln('Masukkan Kalimat:');Readln(Kal);
CekJKal(Kal,JumKal);
Writeln;
Writeln('Jumlah Kata Dalam Kalimat Di Atas Sebanyak: ',JumKal,'
Buah');
Writeln;
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 = Array [1..100] of Data;
Var KataPjg : Larikdata;
i,j,idx : Integer;
Kal : String;
Ul : 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 indeks: Integer);
Var i,max: Integer;
Begin
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;

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]<>' ')
Then
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
Inc(i);
End;

CariKataTerpanjang(j,idx);

Writeln;
Writeln('Kata Terpanjang Dalam Kalimat Di Atas:
',Katapjg[idx].kata);
Writeln;
Until Ul<>'Y';
End.
Output:


Program String3;
Uses WinCrt;
Type Data=Record
Kata : String;
End;
Larikdata = Array [1..100] of Data;
Var Katacr : Larikdata;
i,j : Integer;
Kal : String;
Ul : Char;
Crkata,idx : String;
ketemu : 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 indeks: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;
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]<>' ')
Then
Begin
Inc(i);
AmbilKata(i,j,Kal);
End
Else
Inc(i);
End;
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;
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 : File of Mahasiswa;
Data : Mahasiswa;
Pil,Ul : 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 Tambah;
Var Lagi: Char;
Ada : Boolean;
i : Integer;
NOCR: Word;
Begin
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


Gotoxy(20,9);Write('Nomor Mahasiswa "',NOCR,'" Ini Sudah
Ada!');
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('=====================');
Begin
Seek(FileMhs,i);
Read(FileMhs,Data);
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 Mahasiswa : ');Readln(Data.Nama);
Gotoxy(20,10);Write('IPK : ');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 Mahasiswa "',NOCR,'" Ini Tidak
Ada!');
End;
Gotoxy(20,14);Write('Mau Edit Data Lagi [Y/T]:
Until Lagi<>'Y';
End;
Close(FileMhs);
End;

Procedure Hapus;
Var FileTmp : File of Mahasiswa;
Lagi,Hapus: Char;
Ada : Boolean;
i : Integer;
NOCR : Word;
Begin
Ul:='Y';
Lagi:='Y';
Clrscr;
Repeat
BukaFile;
If IOResult<>0 Then
Else
Begin
Clrscr;
Assign(FileTmp,'mhs.tmp');
Rewrite(FileTmp);
Ada:=False;
i:=0;
Gotoxy(30,1);Write('HAPUS DATA MAHASISWA');
Gotoxy(30,2);Write('=====================');
Begin
Seek(FileMhs,i);
Read(FileMhs,Data);
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 Mahasiswa "',NOCR,'" Sudah
Di Hapus!');
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]:
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
Else
Begin
Clrscr;
Assign(FileTmp,'mhs.tmp');
Rewrite(FileTmp);
i:=0;
Gotoxy(20,3);Write('Mau Menghapus No. Mahasiswa Yang Ganjil
[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);
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]:
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 : Larik;
n : Longint;
PolaIns,PolaBub,PolaQck,
PolaMrg,PolaSlk,PolaShl : Longint;
J1,J2,M1,M2,D1,D2,MD1,MD2 : Word;
SI,SB,SQ,SM,SS,SH : Longint;
Lg : 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


Write(A[i],' ');
End;

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: Word; Var Selisih:
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);


AcakData(X,n);
Writeln;Writeln;

GetTime(J1,M1,D1,MD1);
Insert(X,n,PolaIns);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SI);

Writeln;
Buble(X,n,PolaBub);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SB);

Writeln;
Quick(X,n,PolaQck);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SQ);

Writeln;
Merge(X,n,PolaMrg);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SM);

Writeln;
Selek(X,n,PolaSlk);
SelisihWaktu(J1,M1,D1,MD1,J2,M2,D2,MD2,SS);

Writeln;
Shell(X,n,PolaShl);
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, Waktu:
',SI:5,' MiliDetik');
Writeln('2. Pola Urut Data (Buble) : ',PolaBub:10,' Kali, Waktu:
',SB:5,' MiliDetik');
Writeln('3. Pola Urut Data (Quick) : ',PolaQck:10,' Kali, Waktu:
',SQ:5,' MiliDetik');
Writeln('4. Pola Urut Data (Merge) : ',PolaMrg:10,' Kali, Waktu:
',SM:5,' MiliDetik');
Writeln('5. Pola Urut Data (Seleksi) : ',PolaSlk:10,' Kali, Waktu:
',SS:5,' MiliDetik');
Writeln('6. Pola Urut Data (Shell) : ',PolaShl:10,' Kali, Waktu:
',SH:5,' MiliDetik');
Writeln;
Write('Mau Coba Lagi? [Y/T]: ');Lg:=Upcase(Readkey);
Until Lg<>'Y';
End.
Output:


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


{Depan:=0;Belakang:=0;}InitAntrian;
End;
End
Else
Begin
Writeln('ANTRIAN KOSONG');
{Depan:=0;Belakang:=0;}w
InitAntrian;
End;
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? [Y/T]:
');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? [Y/T]:
Until Pil1<>'Y';
End;


End;
Until Pil='3';
End.

Program Antrian_Statis_Geser;
Uses Wincrt;

Begin
Depan:=0;
Belakang:=0;
End;

Begin
If Belakang<>Max_Antrian Then
Begin
Inc(Belakang);
End
Else
End;

Var i: Integer;
Begin
Begin
For i:= 2 To Belakang Do
Begin
Antrian[i-1]:=Antrian[i];
End;
Antrian[Belakang]:=' ';
Dec(Belakang);
End
Else
End;

Var i : Integer;
Begin
End;

Begin
InitAntrian;
Repeat


Clrscr;
Writeln('===================');
Writeln('3. Exit');
Case Pil of
'1' : Begin
Repeat
Clrscr;
Writeln('=============');
Writeln;
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Until Pil1<>'Y';
End;
'2' : Begin
Repeat
Clrscr;
Writeln('=============');
Hapus(Antrian);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Until Pil1<>'Y';
End;
End;
Until Pil='3';
End.

Program Antrian_Statis_Circular;
Uses Wincrt;

Begin
Depan:=0;
Belakang:=0;
End;

Begin
If Belakang=Max_Antrian Then


Begin
Belakang:=1;
End
Else
Inc(Belakang);

If Depan=Belakang Then
Begin
Dec(Belakang);
If Belakang=0 Then
Belakang:=Max_Antrian;
End
Else
Writeln('Depan: ',Depan,' Belakang: ',Belakang);
End;

Begin
Begin
If Depan=Max_Antrian Then
Depan:=1
Else
Begin
Inc(Depan);
Antrian[Depan]:=' ';
End;
End
Else

Writeln('Depan: ',Depan,' Belakang: ',Belakang);
End;

Var i : Integer;
Begin
End;

Begin
InitAntrian;
Repeat
Clrscr;
Writeln('===================');
Writeln('3. Exit');
Case Pil of
'1' : Begin
Repeat
Clrscr;


Writeln('=============');
Writeln;
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Until Pil1<>'Y';
End;
'2' : Begin
Repeat
Clrscr;
Writeln('=============');
Hapus(Antrian);
Writeln;Writeln;
Tampilkan;
Writeln;Writeln;
Until Pil1<>'Y';
End;
End;
Until Pil='3';
End.

Biografi Penulis
Decky Hendarsyah, lahir di Bukittinggi Sumatera Barat pada tahun
1978. SD sampai SMU ditempuh di Padang Panjang Sumatera Barat.
Merupakan Alumni SMU Negeri 1 Padang Panjang, tamat tahun
1997. Kemudian melanjutkan pendidikan Komputer 1 tahun
setingkat Diploma 1 (D1) di IPK Bukittinggi, tamat pada tahun 1998.
Kuliah S1 di Universitas Putra Indonesia (UPI) “YPTK” Padang
mengambil jurusan Sistem Informasi, lulus tahun 2002. Bekerja
sebagai dosen dan Kepala UPT Puskom STIE Syari’ah Bengkalis.
Pertengahan tahun 2008 melanjutkan pendidikan S2 di Megister Ilmu Komputer
FMIPA UGM Yogyakarta. Menyukai kryptographi, database, pemrograman seperti
bahasa pemrograman Pascal, Borland Delphi dan PHP. Sekarang sedang mempelajari
dan ingin memperdalam bahasa pemrograman java dan juga tertarik pada GIS/SIG dan
komunikasi data.


Kumpulan program pascal

More Related Content

What's hot (20)

Similar to Kumpulan program pascal (8)

Kumpulan program pascal