Sabtu, 29 September 2012

kumpulan progam paskal


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:
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.
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
2
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
3
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
4
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
5
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
6
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,' ','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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
7
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.
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
8
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');
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
9
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
10
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
11
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
12
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
13
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
14
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 : 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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
15
'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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
16
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
17
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:
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
18
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:');
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
19
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
Writeln(pmb[i],'/',pny[i]);
End.
Output:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
20
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);
Until Upcase(Ul)<>'Y';
End.
Output:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
21
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
22
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
23
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
24
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
25
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
26
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
27
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
28
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
29
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
30
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
31
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
32
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;
Write('Mau Ulang Lagi? [Y/T]: ');Readln(Ul);
Ul:=Upcase(Ul);
Until (Ul<>'Y');
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
33
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
34
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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
35
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
36
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
37
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;
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]<>' ')
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;
Write('Mau Ulang Lagi [Y/T]: ');Ul:=Upcase(Readkey);
Until Ul<>'Y';
End.
Output:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
38
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('Masukkan Kalimat:');Readln(Kal);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
39
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;
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
40
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
41
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('=====================');
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 Mahasiswa : ');Readln(Data.Nama);
Gotoxy(20,10);Write('IPK : ');Readln(Data.IPK);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
42
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]:
');Lagi:=Upcase(Readkey);
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
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
43
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]:
');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('================================================');
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
44
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
45
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. 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]:
');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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
46
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
47
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
48
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
49
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);
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
50
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, 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:
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
51
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
52
{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]:
');Pil1:=Upcase(ReadKey);
Until Pil1<>'Y';
End;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
53
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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
54
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]:
');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
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
55
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,' Belakang: ',Belakang);
End;
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,' Belakang: ',Belakang);
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;
Komunitas eLearning IlmuKomputer.Com
Copyright © 2003-2008 IlmuKomputer.Com
56
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]:
');Pil1:=Upcase(ReadKey);
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.

gambar lucu