Program Sorting dalam Pascal

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. 

Sekian artikel tentang Program Sorting dalam Pascal, semoga bermanfaat.