Posted by Materi Teknik Informatika • Informasi Teknologi Informasi • Digital Marketing on 8/14/2014
Program Sorting dalam Pascal - Software house kali ini membahas tentang kumpulan
source code pascal tentang
Selection Sort,
Bubble Sort,
Quick Sort dan
Insert Sort.
Berikut ini source code sorting menggunakan compiler dev-pascal :
uses crt;
const
jml = 5000;
type
arr = array[1..jml] of integer;
var
p,q,k,i,x,ms,j,max: integer;
data: arr;
lagi,y: char;
procedure nama;
begin
clrscr;
gotoxy(33,2) ; writeln('**_Struktur Data_**');
gotoxy(1,4) ; writeln('================================================================================');
gotoxy(35,6) ; writeln('Ditujukan Kepada');
gotoxy(20,8) ; writeln('Nama Dosen : Ramdhani Hidayat, S.Kom, M.M.');
gotoxy(40,11); writeln('****');
gotoxy(20,14); writeln('Disusun oleh : ');
gotoxy(20,16); writeln('Kelompok : I (Satu)');
gotoxy(20,18); writeln('Anggota : ');
gotoxy(35,18); writeln('- Fedri Kurniawan');
gotoxy(35,20); writeln('- M. Ilma Nur Irfan');
gotoxy(35,22); writeln('- Topan Setiawan');
gotoxy(35,24); writeln('- Yuliana Dwi Eftiana');
gotoxy(20,26); writeln('Kelas : Manajemen Informatika/A');
gotoxy(20,28); writeln('Semester : II (Dua)');
gotoxy(24,32); writeln('Akademi Manajemen Informatika dan Komputer');
gotoxy(40,36); write('****');
readln;
end;
procedure menu;
begin
clrscr;
while (x > 5000) or (x < 2) do
begin
gotoxy(24,4); write('Berapa data yang akan di inputkan : '); readln(max);
if (max > 5000) or (max < 2) then
begin
gotoxy(20,8); write('Data yang dimasukan tidak boleh lebih dari 5000');
gotoxy(20,10); write('Tekan enter untuk mengulang !!!');
readln;
clrscr;
end
else
begin
clrscr;
gotoxy(30,2); write('**_Masukan data dari x1..xn');
gotoxy(1,4) ; write('================================================================================');
writeln;
for x:= 1 to max do
begin
write('Bilangan ke ',x,' = '); readln(data[x]);
writeln;
end;
end;
end;
clrscr;
gotoxy(29,2); write('**_Data sebelum diurutkan_**');
writeln;
writeln;
writeln('================================================================================');
for x:= 1 to max do
write(data[x],' ');
gotoxy(1,14) ; writeln('================================================================================');
gotoxy(3,16) ; writeln('**_Metode Sort_**' );
gotoxy(3,18) ; writeln('1. Selection Sort' );
gotoxy(3,20) ; writeln('2. Bubble Sort' );
gotoxy(3,22) ; writeln('3. Quick Sort' );
gotoxy(3,24) ; writeln('4. Insert Sort' );
gotoxy(3,26) ; writeln('5. Exit' );
gotoxy(40,39); write('****');
ms:= 0;
while (ms < 1) or (ms > 5) do
begin
gotoxy(3,28) ; write('Masukan Pilihan (1-5): ');
readln(ms);
if (ms < 1) or (ms > 5) then
clrscr;
write(^G);
end;
end;
procedure change(var a,b: integer);
var
c: integer;
begin
c:=a; a:=b; b:=c;
end;
procedure Asc_Selection;
var
pos: integer;
begin
for i:= 1 to max-1 do
begin
pos:= i;
for j:= i+1 to max do
if (data[j]) < (data[pos]) then
pos:= j;
if i <> pos then
change(data[i], data[pos]);
end;
end;
procedure Desc_Selection;
var
pos: integer;
begin
for i:= 1 to max-1 do
begin
pos:= i;
for j:= i+1 to max do
if (data[pos]) < (data[j]) then
pos:= j;
if i <> pos then
change(data[i], data[pos]);
end;
end;
procedure Asc_Bubble;
var
flag: boolean;
begin
flag:= false;
p:= 2;
while (p<max) and (not flag) do
begin
flag:= true;
for q:= max downto p do
if data[q] < data [q-1] then
begin
change (data[q], data[q-1]);
flag:= false;
end;
inc (i);
end;
end;
procedure Desc_Bubble;
var
flag: boolean;
begin
flag:= false;
p:= 2;
while (p<max) and (not flag) do
begin
flag:= true;
for q:= max downto p do
if data[q] > data [q-1] then
begin
change (data[q], data[q-1]);
flag:= false;
end;
inc (i);
end;
end;
procedure Asc_Quick(L, R: integer);
var
mid: integer;
begin
j:= L; k:= R; mid:=(L+R) div 2;
repeat
while data[j] < data[mid] do inc(j);
while data[k] > data[mid] do dec(k);
if j <= k then
begin
change (data[j], data[k]);
inc(j); dec(k);
end;
until j>k;
if L<k then Asc_Quick(L,k);
if j<R then Asc_Quick(j,R);
end;
procedure Desc_Quick(L, R: integer);
var
mid: integer;
begin
j:= L; k:= R; mid:=(L+R) div 2;
repeat
while data[j] > data[mid] do inc(j);
while data[k] < data[mid] do dec(k);
if j <= k then
begin
change (data[j], data[k]);
inc(j); dec(k);
end;
until j>k;
if L<k then Desc_Quick(L,k);
if j<R then Desc_Quick(j,R);
end;
procedure Asc_Insert;
var
temp: integer;
begin
for i:= 2 to max do
begin
temp:= data[i];
j:= i-1;
while (data[j] > temp) and (j>0) do
begin
data[j+1]:= data[j];
dec(j);
end;
data[j+1]:= temp;
end;
end;
procedure Desc_Insert;
var
temp: integer;
begin
for i:= 2 to max do
begin
temp:= data[i];
j:= i-1;
while (data[j] < temp) and (j>0) do
begin
data[j+1]:= data[j];
dec(j);
end;
data[j+1]:= temp;
end;
end;
procedure output;
begin
clrscr;
gotoxy(29,2); write('**_Data setelah diurutkan_**');
gotoxy(1,4) ; write('================================================================================');
gotoxy(35,6); write('**_Ascending_**');
writeln;
writeln;
writeln;
for x:= max downto 1 do
write(data[x],' ');
gotoxy(35,19); write('**_Descending_**');
writeln;
writeln;
writeln;
for x:= 1 to max do
write(data[x],' ');
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
writeln;
writeln('================================================================================');
end;
begin
clrscr;
nama;
begin
lagi:='y';
while upcase(lagi)='Y' do
begin
menu;
if ms=1 then
begin
Asc_Selection;
Desc_Selection;
end
else
if ms=2 then
begin
Asc_Bubble;
Desc_Bubble;
end
else
if ms=3 then
begin
Asc_Quick(1,max);
Desc_Quick(1,max);
end
else
if ms=4 then
begin
Asc_Insert;
Desc_Insert;
end
else
exit;
output;
gotoxy(29,32); write('Coba metode yang lain [Y/T] ? ');
readln(lagi);
end;
end;
end.
