contoh pascal sederhana

contoh function 

uses crt;

procedure header;
begin
writeln('================================');
writeln('||  :: ALL ABOUT FUNCTION ::  ||');
writeln('================================');
writeln;
end;
function menu_utama:byte;
var menu:byte;
begin
writeln('Menu : ');
writeln('1. Faktorial');
writeln('2. Pangkat');
writeln('3. Phytagoras');
writeln('4. Nilai Maksimum');
writeln('5. Faktor');
writeln('6. Bilangan Prima');
writeln('0. EXIT');
writeln;
writeln('================================');
write('Pilihan anda : ');{gotoxy(17,15);}readln(menu);
menu_utama:=menu;
end;
function factorial(n:word):longint;
var i,hasil:longint;
begin
hasil:=1;
for i:=n downto 1 do
  begin
  hasil:=hasil*i;
  end;
factorial:=hasil;
end;
function pangkat(x,y:integer):longint;
var i,z:longint;
begin
z:=1;
for i:=1 to y do
  begin
  z:=z*x;
  end;
pangkat:=z;
end;
function phytagoras(a,b:integer):real;
var c:real;
begin
c:=sqrt(a*a+b*b);
phytagoras:=c;
end;
function maksimum(a,b,c:integer):integer;
var d:integer;
begin
if (a>b) and (a>c) then
  d:=aelse
  if b>c then
    d:=b
  else
    d:=c;
maksimum:=d;
end;
function faktor(n:integer):byte;
var i:integer;j,e:byte;
begin
e:=0;
for i:=n downto 1 do
  begin
  j:=n mod i;
  if j=0 then
    e:=e+1;
  end;
faktor:=e;
end;
function prima(n:integer):boolean;
var e:integer;
begin
e:=faktor(n);
if e=2 then
  f:=true
else
  f:=false;
prima:=f;
end;

var a,b:longint;
    c:real;
    d,g,h,n,o,p,q,r,s,x,y:integer;
    e,menu:byte;
    f:boolean;
begin
repeat
  clrscr;
  header;
  menu:=menu_utama;
  if (menu>=1) and (menu<=6) then
    begin
    clrscr;
    if menu=1 then
      begin
      header;
      writeln(':: FAKTORIAL ::');
      writeln('n! = ...');
      writeln;
      write('faktorial dari : '); readln(n);
      a:=factorial(n);
      writeln;
      writeln(n,'! = ',a);
      end;
    if menu=2 then
      begin
      header;
      writeln(':: PANGKAT ::');
      writeln('X pangkat Y (X^Y)');
      writeln;
      write('X : '); readln(x);
      write('Y : '); readln(y);
      b:=pangkat(x,y);
      writeln;
      writeln('Jadi, ',x,'^',y,' = ',b);
      end;
    if menu=3 then
      begin
      header;
      writeln(':: PHYTAGORAS ::');
      writeln('perhitungan menggunakan rumus phytagoras');
      writeln;
      write('masukkan nilai A : ');readln(g);
      write('masukkan nilai B : ');readln(h);
      c:=phytagoras(g,h);
      writeln;
      writeln('Jadi, C = ',c:0:2);
      end;
    if menu=4 then
      begin
      header;
      writeln(':: NILAI MAKSIMUM ::');
      writeln('membandingkan antara 3 nilai');
      writeln;
      write('A : ');readln(o);
      write('B : ');readln(p);
      write('C : ');readln(q);
      d:=maksimum(o,p,q);
      writeln;
      writeln('nilai yang paling besar : ',d);
      end;
    if menu=5 then
      begin
      header;
      writeln(':: FAKTOR ::');
      writeln('mencari berapa banyak faktor yang dimiliki bilangan X');
      writeln;
      write('masukkan bilangan : ');readln(r);
      e:=faktor(r);
      writeln;
      writeln(r,' memiliki faktor sebanyak ',e);
      end;
    if menu=6 then
      begin
      header;
      writeln(':: BILANGAN PRIMA ::');
      writeln('menentukan suatu bilangan apakah termasuk bilangan prima atau tidak');
      writeln;
      write('masukkan bilangan : ');readln(s);
      f:=prima(s);
      writeln;
      if f=true then
        writeln(s,' adalah bilangan prima')
      else
        writeln(s,' bukan bilangan prima');
      end;
    writeln;
    writeln;
    writeln;
    write('Press ENTER untuk kembali ke menu ');readkey;
    end;
  if menu=0 then
    begin
    writeln;
    writeln;
    writeln;
    write('Press Any Key to EXIT');readkey;
    end;
  if menu>6 then
    begin
    clrscr;
    header;
    writeln('Maaf, pilihan anda tidak ada di dalam menu');
    writeln;
    writeln;
    write('Press ENTER untuk kembali ke menu ');readkey;
    end;
until (menu=0);
end.

array & procedure..

uses crt;
type arr=array[1..10] of integer;

procedure header;
begin
writeln('=============================================');
writeln('||  :: TUGAS MATA KULIAH STRUKTUR DATA ::  ||');
writeln('=============================================');
writeln;
end;

procedure identitas;
begin
writeln('Nama : -------------');
writeln('NIM  : -------------');
writeln;
end;

procedure menu_utama(var menu:byte);
begin
writeln('Menu : ');
writeln('1. Inisialisasi Array');
writeln('2. Mengisi data pada Array');
writeln('3. Mencetak data yang ada pada Array');
writeln('4. Mengisi data pada indeks paling depan pada Array');
writeln('5. Mengisi data pada indeks paling belakang pada Array');
writeln('6. Mengisi data pada indeks bagian tengah pada Array');
writeln('0. EXIT');
writeln;
writeln('=============================================');
write('Pilihan anda : ');readln(menu);
end;

procedure inisialisasi(var a:arr;var e:byte);
var i:integer;
begin
for i:=1 to 10 do
  begin
  a[i]:=0;
  end;
e:=0;
end;

procedure isi(n:byte;var a:arr;var e:byte);
var i:integer;
begin
for i:=1 to n do
  begin
  write('Masukkan data ke-',i,' : ');readln(a[i]);
  e:=e+1;
  end;
end;

procedure cetak(a:arr;n:byte);
var i:integer;
begin
for i:=1 to n do
  begin
  writeln('Data ke-',i,' : ',a[i]);
  end;
end;

procedure geser_value(x,y:byte;var a:arr;var e:byte);
var i:integer;
begin
for i:=y downto x do
  begin
  a[i+1]:=a[i];
  end;
e:=e+1;
end;

procedure masuk_depan(value:integer;var a:arr;var e:byte);
var i:integer;
begin
if e=0 then
  begin
  a[1]:=value;
  e:=e+1;
  end
else
  begin
  geser_value(1,e,a,e);
  a[1]:=value;
  end;
end;

procedure masuk_belakang(value:integer;var a:arr;var e:byte);
begin
e:=e+1;
a[e]:=value;
end;

procedure masuk_tengah(value:integer;var a:arr;var e:byte);
var i:integer;
begin
i:=1;
while a[i] < value do
  begin
  i:=i+1;
  end;
geser_value(i,e,a,e);
a[i]:=value;
end;


var e,n,menu:byte;
    a:arr;
    value:integer;
begin
repeat
  clrscr;
  header;
  identitas;
  menu_utama(menu);
  if (menu>=1) and (menu<=6) then
    begin
    clrscr;
    if menu=1 then
      begin
      header;
      writeln(':: INISIALISASI ARRAY ::');
      writeln('Keterangan : setiap elemen diberi nilai nol');
      writeln;
      inisialisasi(a,e);
      writeln;
      writeln('Inisialisasi Array ... ... ... ... DONE');
      end;
    if menu=2 then
      begin
      header;
      writeln(':: MENGISI DATA ::');
      writeln('Berapa banyak data yang akan anda masukkan(maks:10)? ');readln(n);
      writeln;
      isi(n,a,e);
      end;
    if menu=3 then
      begin
      header;
      writeln(':: MENCETAK DATA ::');
      writeln;
      if e>0 then
        cetak(a,e)
      else
        writeln('Maaf, data masih kosong, silahkan gunakan menu ke-2 untuk mengisi data');
      writeln;
      end;
    if menu=4 then
      begin
      header;
      writeln(':: MENGISI DATA DI DEPAN ::');
      writeln('Keterangan : Mengisi data pada indeks paling depan pada Array');
      writeln;
      write('Data yang ingin anda masukkan : ');readln(value);
      masuk_depan(value,a,e);
      writeln;
      end;
    if menu=5 then
      begin
      header;
      writeln(':: MENGISI DATA DI BELAKANG ::');
      writeln('Keterangan : Mengisi data pada indeks paling belakang pada Array');
      writeln;
      write('Data yang ingin anda masukkan : ');readln(value);
      masuk_belakang(value,a,e);
      writeln;
      end;
    if menu=6 then
      begin
      header;
      writeln(':: MENGISI DATA DI TENGAH ::');
      writeln('Keterangan : Mengisi data pada indeks bagian tengah pada Array');
      writeln;
      write('Data yang ingin anda masukkan : ');readln(value);
      masuk_tengah(value,a,e);
      writeln;
      end;
    writeln;
    writeln;
    writeln;
    write('Press ENTER untuk kembali ke menu ');readkey;
    end;
  if menu=0 then
    begin
    writeln;
    writeln;
    writeln;
    write('Press Any Key to EXIT');
    end;
  if menu>6 then
    begin
    clrscr;
    header;
    writeln('Maaf, pilihan anda tidak ada di dalam menu');
    writeln;
    writeln;
    write('Press ENTER untuk kembali ke menu ');readkey;
    end;
until (menu=0);
readkey;
end.  

contoh selection sort sma buble sort 

uses crt;
type array1D=array[1..10] of integer;


procedure SelectionSort(var a:array1D; n:integer);
var i,j,b:integer;
begin
for i:=1 to n-1 do
  begin
  for j:=i+1 to n do
    begin
    if a[i]>a[j] then
      begin
      b:=a[i];
      a[i]:=a[j];
      a[j]:=b;
      end;
    end;
  end;
end;

procedure BubleSort(var a:array1D; n:integer);
var i,j,b:integer;
begin
for i:=n downto 2 do
  begin
  for j:=1 to n-1 do
    begin
    if a[j]>a[j+1] then
      begin
      b:=a[j];
      a[j]:=a[j+1];
      a[j+1]:=b;
      end;
    end;
  end;
end;

var a:array1D;
    i,ms:integer;
begin
clrscr;
for i:=1 to 5 do
  begin
  write('Input angka ke ',i,' : ');
  readln(a[i]);
  end;

writeln;
writeln('===================');
writeln('Metode sorting : ');
writeln('1. Selection Sort');
writeln('2. Buble Sort');
writeln;
write('Pilihan anda : ');readln(ms);
writeln('===================');
writeln;
if ms=1 then
  begin
  SelectionSort(a,5);
  writeln;
  writeln('hasil selection sort : ');
  for i:=1 to 5 do
    begin
    write('angka ke ',i,' : ');
    writeln(a[i]);
    end;
  end;
if ms=2 then
  begin
  BubleSort(a,5);
  writeln;
  writeln('hasil buble sort : ');
  for i:=1 to 5 do
    begin
    write('angka ke ',i,' : ');
    writeln(a[i]);
    end;
  end;


readkey;
end. 

credit:ngekngok snutz