Beberapa Contoh Implementasi Program Pascal

Program perpangkatan;

uses wincrt;
var i,o,n:longint;

hasil:real;
begin writeln('a pangkat b');
      writeln('Masukkan a= ');readln(o);
      writeln('Masukkan b= ');readln(n);
      hasil:=1;
      for i:=1 to abs(n) do
      hasil:=o * hasil;
      if (n<0) then
      begin
      write('hasil= ');write(1/hasil);
      end
      else
      begin
      write('hasil= ');write(hasil);
      end;
end.

Program faktorial;
uses wincrt;
var
i,n,f:integer;

begin
readln(n);
f:=1;
while i<n do
begin i:=i+1;
f:=f*i;
end;
write(n,'faktorial=',f);
end.

Program rata2;
uses wincrt;
var
i,n:integer;
x,sum,mean:real;

begin
writeln('banyaknya data= ');
readln(n);sum:=0;i:=0;
repeat
i:=i+1;
writeln('data ke',i,'=');
readln(x);
sum:=sum+x;
until i=n;
mean:=sum/n;
writeln('rata-rata= ',mean:9:4);
end.

Program permutasi_kombinasi;
uses wincrt;
var
a,b,a_k,kombinasi,permutasi:real;
i,n,k:longint;
begin
writeln('MENGHITUNG PERMUTASI DAN KOMBINASI:');
write('masukkan bilangan n= ');readln(n);
write('masukkan bilangan k= ');readln (k);
a:=1;
b:=1;
a_k:=1;
for i:=2 to n do
a := a*i;
for i:=2 to k do
b :=b*i;
for i :=2 to (n-k) do
a_k := a_k * i;
kombinasi := a/(b*a_k);
permutasi :=a/ (a_k);
writeln ( n, ' Kombinasi',k,'=', kombinasi:4:1);
writeln (n, ' permutasi',k,'=',permutasi :4:1);
end.

Program binomial;
uses wincrt;
var
i,j,k,n,x:longint;
a,b,c,d,e,p:real;

begin
readln(n);
readln(x);
readln(p);
a:=1;
b:=1;
c:=1;
d:=1;
e:=1;
for i:=1 to n do
a:= a*i;
for j:=1 to x do
begin
b:=b*j;
c:=c*p;
end;
for k:=1 to (n-x) do
begin
d:=d*k;
e:=e*(1-p);
end;
writeln(a/(b*d)*c*e:0:4);
end.

Program persegi;
uses winCrt;
procedure gb (brs,kol:integer);
var i,j:integer;
begin
for i:=1 to brs do
    begin
    for j:=1 to kol do
        begin
        if ((i=1)or(i=brs)or(j=1)or(j=kol))then
        write ('*')
        else write(' ');
        end;
        writeln;
        end;                   
    end;
        var x,y:integer;
        begin                 
        write('banyak baris= ');readln(y);
        write('banyak kolom= ');readln(x);
        writeln('bentuknya:');
        gb(y,x);
        end.

Program segitiga_pascal_kombinasi;
uses wincrt;
var   a,b,c,n:integer;

function fkom(n:integer; m:integer): real;
var x,y,z,i: integer;
begin
x:=1; y:=1; z:=1;
for i:=1 to n do x:=x*i;
for i:=1 to m do y:=y*i;
for i:=1 to (n-m) do z:=z*i;
fkom:=x/(y*z);
end;

begin
write('masukkan nilai n = '); readln(n);
if n>=0 then
for a:=0 to n do
    begin
    for b:=n downto a do write('*');
        begin
        for c:=0 to a do write(fkom(a,c):3:0);
        writeln;
        end;
    end;
end.




Program susunan;
uses wincrt;
var
x:array[1..100] of real;
i,n:integer;

begin
write('Masukkan n banyaknya angka = ');readln(n);
for i:=1 to n do
begin
write(i,' = ');readln(x[i]);
end;
write ('panggil data ke = ') ;readln (i);
write (x[i]);
end.

Program lognatural;
uses wincrt;
var
x:array[1..1000] of real;
y:array[1..1000] of real;
i,j,n,k:longint;
a,p,sum,r:real;
begin
readln(n);
readln(a);
sum:=1;
for i:=1 to n do
begin
r:=1;
for k:=1 to i do
r:=r*k;
x[i]:=r;
p:=1;
for j:=1 to i do
p:=p*a;
y[i]:=p;
sum:=sum+y[i]/x[i];
end;
writeln ('hasil = ' , sum:0:7);
writeln ('asli  = ' ,exp(a):0:7);
writeln ('error = ',exp(a)-sum:0:8);
end.

Program dua_dimensi;
uses wincrt;
var
x:array[1..100,1..100] of integer;
p,l,i,j:integer;

begin
write('p = '); readln(p);
write('l = '); readln(l);
for i:=1 to l do
for j:=1 to p do
readln(x[i,j]);
writeln;
writeln('Bentuk Matriknya');
for i:=1 to l do
begin
for j:=1 to p do
write(x[i,j],' ');
writeln;
end;
end.





Program transpose;
uses wincrt;
var
x:array[1..100,1..100] of integer;
p,l,i,j:integer;

begin
write('p = '); readln(p);
write('l = '); readln(l);
for i:=1 to l do
for j:=1 to p do
readln(x[i,j]);
writeln;
writeln('Bentuk Matriknya');
for i:=1 to l do
begin
for j:=1 to p do
write(x[i,j],' ');
writeln;
end;

writeln('Bentuk Matrik Transpose');
for i:=1 to p do
begin
for j:=1 to l do
write(x[j,i],' ');
writeln;
end;
end.




Program bilangan_prima_antara_1_sd_n;
uses wincrt;
var
   batas : real;
   n:integer;
   i,j,jumlah :word;
   prima: array[1..1000] of char;
begin
write('bilangan prima antara 1 sampai dengan ');  read (n);
     writeln('------------------------------------');
     batas:=sqrt(n);
     jumlah:=0;
     writeln;
     for i:=2 to n do
     begin
          if prima[i]<>'*' then
          begin
               write(i:5);
               jumlah:=jumlah+1;
               if i<batas then
          begin
               j:=i;
               while j<n do
               begin
                    j:=j+i;
                    prima[j] := '*';
               end;
          end;
     end;
     end;
writeln;
writeln;
writeln;
writeln('ada sejumlah  ',jumlah, ' bilangan prima');
end.




Program matrix;
uses wincrt;
type
    larik=array[1..25,1..25] of real;
var
   i,j,k:byte;
   bar,col:byte;
   a,b,c,d,e:larik;
begin
     write ('baris matrik ?  ');readln(bar);
     write ('kolom matrik ? ');readln(col);
   
     writeln;

     writeln ('matrik pertama');
     for i:=1 to bar do
     begin
          for j:=1 to col do
          begin
               write ('nilai[',i,',',j,']');readln(a[i,j]);
          end;
          writeln;
     end;
     writeln;

     writeln ('matrik kedua');
     writeln;
    
     for i:=1 to bar do
     begin
          for j:=1 to col do
          begin
               write ('nilai[',i,',',j,']');readln(b[i,j]);
          end;
          writeln;
     end;

      writeln;

    
      writeln;
     for i:=1 to bar do
     begin
          for j:=1 to bar do
          begin
               for k:=1 to col do
                   d[i,j]:=a[i,j]+b[i,j]
               end;
          end;

     writeln;
     for i:=1 to bar do
     begin
          for j:=1 to bar do
          begin
               for k:=1 to col do
                   e[i,j]:=a[i,j]-b[i,j]
               end;
          end;
     clrscr;
      writeln ('matrik pertama:');
      for i:=1 to bar do
     begin
          for j:=1 to col do
          begin
               write (a[i,j]:0:0,' ');
          end;
     writeln;
     end;

     writeln ('matrik kedua:');

      for i:=1 to bar do
     begin
          for j:=1 to col do
          begin
               write (b[i,j]:0:0,' ');
          end;
     writeln;
     end;


     writeln ('hasil penjumlahan matrik:');
     writeln;
     for i:=1 to bar do
     begin
          for j:=1 to col do
          write(d[i,j]:9:2);
          writeln;
     end;

     writeln ('hasil pengurangan matrik:');
     writeln;
     for i:=1 to bar do
     begin
          for j:=1 to col do
          write(e[i,j]:9:2);
          writeln;
     end;
end.




Program determinan;
uses wincrt;
var A : array[1..2,1..2] of integer;
j,k,D : integer;
begin
For j:=1 to 2 do
begin
write('Entrikan baris ',j,' matriks A : ');
readln(A[j,1] , A[j,2]);
end;
For j:=1 to 2 do
begin
For k:=1 to 2 do write(A[j,k] : 5);
writeln;
end;
writeln;writeln;writeln;
D := A[1,1]*A[2,2] - A[1,2]*A[2,1];
writeln('Det(A) = ',D);
end.




Program matriks_invers;
uses wincrt;

var n,i,j,x,y,k,l,m: integer;
a:array[1..20,1..20] of real;

begin
{gotoxy (10,1);}
writeln (‘Program Pencarian Invers Matriks’); 
writeln;
writeln (‘Masukkan ordo matrik (n x n).’);
write (‘n : ‘);
readln (n);
writeln;
for i:=1 to n do
begin
for j:=1 to n do
begin
write (‘A(‘,i,’,',j,’) : ‘);
readln (a[i,j]);
end;
end;
writeln;
for i:=1 to n do
begin
for j:=1 to n do
write (‘ ‘,a[i,j]:0:0);
writeln;
end;

{MATTRIK SISI KANAN}

for j:=n+1 to n+n do
begin
i:=j-n;
a[i,j]:=1;
end;
for j:=n+1 to n+n do
begin
for i:=1 to n do
if i<>j-n then a[i,j]:=0;
end;

{PROSES PENGINVERSAN}
for i:=1 to n do
begin
for j:=1 to n+n do
begin
if i<>j then a[i,j]:=a[i,j]/a[i,i];
end;
for j:=1 to n+n do
begin
if i=j then a[i,j]:=1;
end;

{PENJUMLAHAN KESATU BARIS ELEMENT}
for l:=1 to n do
begin
if i<>l then
begin
for j:=i+1 to n+n do
begin
a[l,j]:=a[l,j]-(a[i,j]*a[l,i]);
end;
end;
end;

{PEMBUATAN NOL DISEKITAR MATRIKS KIRI}
for k:=1 to n do
begin
if i<>k then
begin
a[k,i]:=0;
end;
end;
end;

{PENCETAKAN}
readln;
writeln(‘Maka invers dari matrik adalah :’);
for i:=1 to n do
begin
for j:=n+1 to n+n do
write (‘ ‘,a[i,j]:0:2);
writeln;
end;

readln;
end.

Program mencari_modus;
uses wincrt;
var i,n,j,modus:integer;
A,frek:array[1..100] of integer;
begin
write('masukkan jumlah data=');
readln(n);
for i:=1 to n do
readln(A[i]);
for i:=1 to n-1 do
begin
for j:=i+1 to n do
if A[i]=A[j] then
frek[i]:=frek[i]+1;
end;
modus:=1;
for i:=1 to n do
begin
write(frek[i],' ');
if frek[modus]<frek[i] then
modus:=i;
end;
write('modus= ',A[modus],' banyaknya ',frek[modus]+1);
end.

 

Sumber : http://dachoy1311100101.blogspot.com/p/implementasi-pascal.html.

Contoh Case Of Pascal

      Contoh Case …Of perhitungan berat dan harga barang :
Ketentuan soal :
1. Kualitas Barang di masukkan
Kualitas Harga Per Kg
A/a 1000
B/b 750
C/c 500

Uses crt;
Var
Berat,harga,hargaperkg:integer;
Kualitas:char;
Begin
Clrscr;
Write(‘ Massukkan Kualitas Buah [A/B/C] : ‘); readln(kualitas);
Write(‘ Berapa Kg berat yang di beli : ‘ ); readln(berat);
Case kualitas of
‘A’,’a’: hargaperkg:=1000;
‘B’,’b’: hargaperkg:=750;
‘C’,’c’: hargaperkg:=500;
Else
Begin
Hargaperkg:=0;
Writeln(‘Salah Input’);
End;
End;

Harga:=hargaperkg*berat;
Writeln(‘ Harga Per Kg : Rp.’,hargaperkg);
Writeln(‘ Harga Total : Rp.’,harga);
End.


         Contoh Program Pascal If Perhitungan Gaji :

Uses crt;
Var nama:string[20];jabatan:string;
Gaji:longint;
Tunj,ppn,gajibersih:real;
Begin
Clrscr;
Write(‘Nama Karyawan : ‘); readln(nama);
Write(‘Masukkan Jabatan : ‘); readln(jabatan);
If (jabatan=’Direktur’) or (jabatan=’direktur’) then
Begin
Gaji:=3000000;
Tunj:=0.1* gaji;
End
Else If (jabatan=’Manager’) or (jabatan=’manager’) then
Begin
Gaji:=2000000;
Tunj:=0.05* gaji;
End
Else If (jabatan=’Karyawan’) or (jabatan=’karyawan’) then
Begin
Gaji:=1000000;
Tunj:=0.1* gaji;
End
Else
Begin
Gaji:=800000;
Tunj:=0.1* gaji;
End;
Writeln(‘Gaji Bersih : Rp.‘,gaji);
Writeln(‘Tunjangan Jabatan : Rp.‘,tunj:9:2);
Ppn:=0.1*gaji;
Writeln(‘PPN 10 % : Rp.‘,ppn:9:2);
Total:=(gaji+total)-ppn;
Writeln(‘Total Gaji : Rp.‘,total:9:2);
Readln;
End.


           Program Penghitung Luas segitiga :


uses crt;
var
alas,tinggi:integer;
procedure hitung_luas(a,t:integer);
var
luas:real;
begin
clrscr;
luas:=a*t/2;
writeln('Luas segitiga =',luas);
end;
begin
writeln('Masukkan alas =');readln(alas);
writeln('Masukkan tinggi =');readln(tinggi);
hitung_luas(alas,tinggi);
readln;
end.


        Membuat File txt Melalui Pascal :


uses crt;
var
Tulisan:text;
a,b:byte;
c:byte;
begin
clrscr;
writeln('Masukkan Angka 1 =');readln(a);
writeln('Masukkan Angka 2 =');readln(b);
c:=a+b;
writeln('Jadi nilainya adalah =',c);
assign(Tulisan,'hitung.txt');
rewrite(Tulisan);
write(tulisan,a);
write(Tulisan,'+');
write(Tulisan,b);
write(Tulisan,'=');
write(Tulisan,c);
Close(Tulisan);
readln;
end.


        Program Pencari Biaya Dan Grade :

uses crt;
var
nilai:byte;
begin
clrscr;
Write('masukkan Nilai anda =');Readln(nilai);

if nilai>0 then
begin
Writeln('GRADE = O ');
Writeln('Besar biaya = Rp.550000');
end
else

if nilai<=1 then begin Writeln('GRADE = E '); Writeln('Besar biaya = Rp.450000'); end else if nilai<=40 then begin Writeln('GRADE = D'); Writeln('Besar biaya = Rp.350000'); end else if nilai<=60 then begin Writeln('GRADE = C'); Writeln('Besar biaya = Rp.250000'); end Else if nilai<=70 then begin Writeln('GRADE = B'); Writeln('Besar biaya = Rp.150000'); end else begin If nilai >=100 then
Writeln('GRADE = A');
Writeln('Besar biaya = Rp.50000');
end;
readln;
end.


        Program Pencari Predikat :
USES CRT;
VAR
nilai:byte;
A,B,C,D:string;
begin
clrscr;
write ('masukkan nilai=');readln(nilai);
if nilai< 69 then
writeln('predikat D');
if nilai<79then
writeln ('predikat C');
if nilai<90 then
writeln ('predikat B');
if nilai<101 then
writeln('predikat A');
readln;
end.


       Konversi bilangan Desimal Ke Biner :


USES CRT;
VAR Des:integer;
Bin:string;
begin
clrscr;
writeln('PROGRAM KONVERSI MENGUBAH BILANGAN DECIMAL KE BINER');
write('Masukkan bilangan Decimal=');
readln(Des);
Bin:=’’;
repeat
begin

{menghitung biner dari hasil bagi}

If Des mod 2=0 then Bin:='0'+Bin
else Bin:='1'+Bin;

{membagi bulat bilangan desimal}

Des:= Des div 2;
end;
Until Des=0;
Writeln('Bilangan Biner =',Bin);
readln;
end.