contoh kode pascal 5

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

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
      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);
    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.