Implementasi Pascal

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.