Menghitung luas segiempat dalam pascal versi 1

Program segiempat;

uses wincrt;

type titik=record
     x:integer;
     y:integer;
     end;

var
a:array [1..2] of titik;
i,luas,panjang,lebar:integer;

begin
writeln('(1)********');
writeln('   ********');
writeln('   ********(2)');
writeln;
for i:= 1 to 2 do
    begin
    writeln('titik ',i);
    write('masukan absis = ');readln(a[i].x);
    write('masukan ordinat = ');readln(a[i].y);
    end;
if (a[2].x>a[1].x) and (a[1].y>a[2].y) then
begin
     panjang:=a[2].x-a[1].x;
     lebar:=a[1].y-a[2].y;
     luas:=panjang*lebar;
     writeln('panjang = ',panjang);
     writeln('lebar   = ',lebar);
     writeln('luas    = ',luas);
end
else
writeln('nilai panjang/lebar bernilai minus');
end.

› Read More

Menghitung luas segitiga dalam pascal versi 1

Program segitiga;

uses wincrt;

type point=record
     absis:integer;
     ordinat:integer;
     end;

var
titik:array [1..3] of point;
i,alas,tinggi:integer;
jawaban:real;
begin
writeln('     *(3)   ');
writeln('    ***     ');
writeln('(1)******(2)');
writeln('masukan nilai titik 1, 2, 3 : ');
writeln;
for i := 1 to 3 do
    begin
        writeln('titik ',i);
        write('nilai absis = ');readln(titik[i].absis);
        write('nilai ordinat = ');readln(titik[i].ordinat);
    end;
if (titik[1].ordinat=0) and( titik[2].ordinat=0)  then
   begin
   alas:=titik[2].absis-titik[1].absis;
   tinggi:=titik[3].ordinat;
   jawaban:=((0.5*alas)*tinggi);
   writeln('alas   = ',alas);
   writeln('tinggi = ',tinggi);
   writeln('luas   = ',jawaban:0:2);
   end
else
    writeln('titik 1 dan 2 tidak menempel di garis X');
end.

› Read More

penjualan tiket pesawat dalam pascal

Program menjual_tiket;
Uses wincrt;
Type mat = array[1..10,1..10] of integer;
Function free(a: mat): Boolean;
Var
I,j : integer;
                found: boolean;
Begin
Found:= true;
I:= 1;
While (found) and (i<=8) do
                      begin
J:=1;
While (found) and (j<=5) do
If a[I,j] =0 then
Found:=false
Else
J:= j+1;
I:= i+1;
                      end;
                free:= found;
End;

        Function cek_damping(a: mat): boolean;
        Var
  I,j : integer;
  Found : boolean;
        Begin
    Found := false;
    I:= 1;
        While (not found) and (i<=8) do
                     begin
      J:=1;
      While (not found) and (j<5) do
            If (a[I,j] <> 0) and (a[I,j+1]<>0) then
Found := true
    Else
J:= j+1;
      I:= i+1;
                     end;
    Cek_damping:= found;
        End;

        Function kursi_pinggir(a: mat): boolean;
        Var
  I,j : integer;
  Found : boolean;
        Begin
    Found := false;
    j:= 1;
    While (not found) and (j<=5) do
                begin
  I:=1;
  While (not found) and (i<8) do
If a[I,j] <> 0 then
Found := true
Else
   i:= i+1;
  j:= j+4;
                end;
     kursi_pinggir:= found;
        End;


        Function kursi_nonton(a: mat): boolean;
        Var
  I,j : integer;
  Found : boolean;
        Begin
    Found := false;
    I:= 2;
        While (not found) and (i<=8) do
                     begin
      J:=1;
      While (not found) and (j<5) do
            If (a[I,j] <> 0) and (a[I,j+1]<>0) then
Found := true
    Else
J:= j+1;
      I:= i+1;
                     end;
    kursi_nonton:= found;
        End;

        procedure rubah(n : integer; var a:mat);
        var
           i,j : integer;
        begin
           For i:= 1 to 8 do
For j:= 1 to 5 do
If a[I,j] = n then
If a[I,j] = n then
A[I,j] :=0;
        end;
Var
   y: string;
   a: mat;
   i,j,n: integer;
   hasil, hasil1, hasil2, hasil3 : boolean;
Begin
For i:= 1 to 8 do
For j:= 1 to 5 do
A[I,j] := ((i*5)-5+j);
For i:= 1 to 8 do
begin
For j:= 1 to 5 do
Write(a[I,j], '             ');
Writeln;
End;

        repeat
Writeln('masukkan no tempat duduk yang anda inginkan');
        Readln(n);
        clrscr;
        hasil := free(a);
        writeln('bangku yang anda pesan masih dalam keadaan ', hasil);
        writeln;
rubah(n,a);
For i:= 1 to 8 do
begin
For j:= 1 to 5 do
Write(a[I,j], '             ');
Writeln;
End;
        writeln('apakah masih ada yang ingin memesan tiket pesawat???? (Y/N) ');
        readln(y);
        until y = 'n';
        hasil1:= cek_damping(a);
        writeln(hasil1);
        hasil2:= kursi_pinggir(a);
        writeln(hasil2);
        hasil3:= kursi_nonton(a);
        writeln(hasil3);
End.

› Read More

program konversi desimal ke heksa dalam pascal

Program Convert_Decimal_To_heksa;

Uses wincrt;

Const N = 100;

Type Stack = record
      Isi : Array[1..N]of integer;
      Top : integer;
     end;

Procedure CreateStack(Var S:Stack);
     begin
          S.Top := 0;
     end;

Function IsFull(S:Stack):boolean;
     begin
         IsFull := (S.Top = N);
     end;

Function IsEmpty(S:Stack):boolean;
     begin
          IsEmpty := (S.Top = 0);
     end;

Procedure Push(X:integer; var S:Stack);
     begin
          If Not IsFull(S) then
           begin
                S.Top := S.Top + 1;
                S.Isi[S.Top] := X;
           end;
     end;
Procedure Pop(var X:integer; var S:Stack);
    begin
         IF NOt IsEmpty(S) then
          begin
               X := S.Isi[S.Top];
               S.Top := S.Top - 1;
          end;
    end;

Procedure Convert(var S:Stack; X:integer);
    var Sisa : integer;
    begin
         Repeat
          Sisa := X mod 16;
          X := X div 16;
          Push(Sisa,S);
         Until X = 0 ;
    end;

function rubah (x:integer):string;
begin
if x=10 then
rubah:='A';
if x=11 then
rubah:='B';
if x=12 then
rubah:='C';
if x=13 then
rubah:='D';
if x=14 then
rubah:='E';
if x=15 then
rubah:='F';
end;


{Main Program}
Var S : Stack;
    X,i,biner: integer;
    biner2:string;

Begin
     writeln('+---------------------------------+');
     Writeln('|Program Konversi Desimal ke Biner|');
     writeln('+---------------------------------+');
     Writeln;            
     Write('Masukkan angka Desimal : ');
     readln(X);
     writeln;
     write('Angka heksadesimal dari ',X,' adalah ');
     CreateStack(S);
     Convert(S,X);
     for i:=1 to S.Top do
      begin
           Pop(biner,S);
           if biner>=10 then
           begin
           biner2:=rubah (biner);
           write(biner2);
           end
           else
           write(biner);
      end;
End.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          

› Read More

program queue dalam pascal

Program Queveueeueueueueueueueuee;

Uses wincrt;

Const N = 100;

Type Queve = record
      isi : Array[1..N]of integer;
      head:integer;
      tail: integer;
     end;

Procedure CreateQueve(Var S:Queve);
     begin
          S.head:=0;
          S.tail:=0;
     end;

Function IsFull(S:Queve):boolean;
     begin
         IsFull := (S.head = 1) and (S.tail = N);
     end;

Function IsEmpty(S:Queve):boolean;
     begin
          IsEmpty := (S.head = 0 ) and (S.tail = 0);
     end;

Procedure add(X:integer; var S:Queve);
     begin
          If Not IsFull(S) then
           begin
                S.tail := S.tail + 1;
                S.isi[S.tail] := X;
                if S.head=0 then
                S.head:=S.head+1;

           end;
     end;

Procedure remove(var X:integer; var S:Queve);
var i:integer;
    begin
         IF NOt IsEmpty(S) then
          begin
               X:=S.isi[S.head];
               for i:= 2 to S.tail do
               S.isi[i-1]:=S.isi[i];
               S.tail :=S.tail - 1;
               if S.tail=0 then
               S.head:=S.head-1;
          end;
    end;

{Main Program}
Var S : Queve;
    X,i,z,m,Y: integer;

Begin
      write('masukan jumlah data ');readln(X);
      CreateQueve(S);
      for i:= 1 to X do
          begin
               write('masukan data ke',i,' : ');readln(m);
               add(m,S);
          end;
      writeln;
        write('jumlah data yang akan dikeluarkan ');readln(Y);
        writeln('data yang dikeluarkan : ');
      for i:= 1 to Y do
          begin
               remove(z,S);
               writeln(z);
          end;
          writeln;
          writeln('data yang tersisa : ');
          for i:= 1 to S.tail do
          writeln(S.isi[i]);
          writeln;
          writeln('S.tail berada di elemen ke ',S.tail);
          writeln('S.head berada di elemen ke ',S.head);

End.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                          

› Read More

mengubah desimal menjadi biner dalam pascal

program ubah_desimal_binary;
uses wincrt;
const n=100;
type stack = record
             elemen:array[1..n]of integer;
             top:integer;
             end;
   
function isiempty(s:stack):boolean;
begin
isiempty:=(s.top=0);
end;

function isifull(s:stack):boolean;
begin
isifull:=(s.top=n);
end;

procedure create_stack(var s:stack);
begin
s.top:=0;
end;

procedure push(var s:stack; a:integer);
begin
if not (isifull(s)) then
   begin
   s.top:=s.top+1;
   s.elemen[s.top]:=a;
   end
end;

procedure pop(var s:stack; var a:integer);
begin
if not (isiempty(s)) then
   begin
   a:=s.elemen[s.top];
   s.top:=s.top-1;
   end
end;

function convert(a:integer):integer;
var y,x:integer;
    z,tmp:string;
    s:stack;
begin
create_stack(s);
while a>0 do
      begin
      y:=a mod 2;
      push(s,y);
      a:=a div 2;
      end;
tmp:='';
while not isiempty(s) do
      begin
      pop(s,a);
      str(a,z);
      tmp:=tmp+z;
      end;
val(tmp,a,a);
convert:=a;
end;

var i,hasil:integer;
begin
write('Masukan nilai desimal = ');readln(i);
hasil:=convert(i);
writeln(hasil);    
end.

› Read More

program matrik dalam pascal

program matiks;

uses wincrt;

type
arin=array [1..100] of integer;

function cari(b:arin;m,n,x:integer):integer;
var
i,j,domp:integer;
begin
domp:=0;
for i:=1 to m do
begin
for j:= 1 to n do
begin
if b[j]=x then
domp:=domp+1;
end;
end;
cari:=domp;
end;


var
a:arin;
i,j,m,n,x,domp:integer;

begin
write('masukan jumlah baris : ');readln(n);
write('masukan jumlah kolom : ');readln(m);
for i:=1 to m do
begin
for j:= 1 to n do
begin
write('a[',i,',',j,'] : ');readln(a[j]);
end;
end;
write('masukan bilangan yang dicari : ');readln(x);
domp:=cari(a,m,n,x);
writeln('jadi bilangan yang dicari ada ',domp);
end.

› Read More

statistik (mean dan titik tengah) dalam pascal

Program interval;

uses wincrt;

type tabin=array [1..200] of integer;

function mean (a:tabin; n:integer):real;
var
i,domp:integer;
begin
domp:=0;
for i:= 1 to n do
domp:=domp+a[i];
mean:=domp/n;
end;

function ttktngah(a:tabin; n:integer):real;
begin
if n mod 2 = 0 then
ttktngah:=(a[n div 2]+a[(n div 2)+1])/2
else
ttktngah:=(a[(n div 2)+1]);
end;

var
a:tabin;
i,n:integer;
hsl,hsl2:real;
begin
write('masukan batas : ');readln(n);
for i:= 1 to n do
begin
write('masukan data ke ',i,' : ');readln(a[i]);
end;
hsl:=mean(a,n);
write('mean : ',hsl:0:2);
hsl2:=ttktngah(a,n);
writeln;
writeln('titik tengah : ',hsl2:0:2);
end.

› Read More

program warnet dalam pascal

program wartel;

uses wincrt;

type waktu=record
jam:longint;
menit:longint;
detik:longint;
end;

function hitungselisih(jam1,jam2:waktu):longint;
begin
hitungselisih:=((jam2.jam*3600)+(jam2.menit*60)+jam2.detik)-((jam1.jam*3600)+(jam1.menit*60)+jam1.detik);
end;

function hitungbiaya(jam1,jam2:waktu):longint;
var
temp1:longint;
begin
temp1:=hitungselisih(jam1,jam2);
if (temp1 mod 30 >0) then
hitungbiaya:=((temp1 div 30)*250)+250
else
hitungbiaya:=(temp1 div 30)*250;
end;

var
jam1,jam2:waktu;
biaya,lama:longint;

begin
writeln('masukan waktu awal ');
write('jam = ');readln(jam1.jam);
write('menit = ');readln(jam1.menit);
write('detik = ');readln(jam1.detik);
writeln;
writeln('masukan waktu akhir ');
write('jam = ');readln(jam2.jam);
write('menit = ');readln(jam2.menit);
write('detik = ');readln(jam2.detik);
writeln;
biaya:=hitungbiaya(jam1,jam2);
lama:=hitungselisih(jam1,jam2);
writeln('lama percakapan = ',lama,' detik');
writeln('biaya menelpon = ',biaya);
end.

› Read More

program stack dalam pascal

program stackkkkk;

uses wincrt;

type stack=record
     isistack:array [1..100] of integer;
     top:integer;
     end;

const n:integer=100;

procedure createstack(var s:stack);
begin
s.top:=0;
end;

function isfull(s:stack):boolean;
begin
isfull:=(s.top=n);
end;

function isempty(s:stack):boolean;
begin
isempty:=(s.top=0);
end;

procedure push(var s:stack;x:integer);
begin
if not isfull(s) then
begin
s.top:=s.top+1;
s.isistack[s.top]:=x;
end;
end;

procedure pop(var s:stack;x:integer);
begin
if not isempty(s) then
begin
x:=s.isistack[s.top];
s.top:=s.top-1;
end;
end;

procedure biner(x:integer;var s:stack);
var
a,z:integer;
begin
a:=x;
repeat
begin
z:=a mod 2;
push( s ,z );
a:=a div 2;
end
until (a  = 1);
push( s,a);
end;

var
s:stack;
x,a:integer;

begin
readln(x);
biner (x,s);
repeat
begin
pop (s,a);
writeln(a);
end
until s.top=0;
end.

› Read More

menghitung jumlah, perkalian dan rata-rata dalam pascal

program ulang;

uses wincrt;

type a=array[1..10000] of longint;

var
T:a;
n,temp,temp2,i,j:longint;
c:real;

begin
i:=1;
repeat
write('masukan angka = ');read(n);
T[i]:=n;
i:=i+1;
until (n>9999);
clrscr;
temp:=T[1];
write('penjumlahan = ',T[1],'+');
for j:=2 to (i-2) do
begin
write(T[j]);
temp:=temp+T[j];
if (j<>(i-2)) then
write('+')
else
write('=');
end;
write(temp);
writeln;
temp2:=T[1];
write('perkalian   = ',T[1],'*');
for j:=2 to (i-2) do
begin
write(T[j]);
temp2:=temp2*T[j];
if (j<>(i-2)) then
write('*')
else
write('=');
end;
write(temp2);
writeln;
c:=(temp/(i-2));
writeln('rata-rata   = ',c:0:2);
end.

› Read More

program warnet dalam pascal

program wartel;

uses wincrt;

type waktu=record
jam:longint;
menit:longint;
detik:longint;
end;

function hitungselisih(jam1,jam2:waktu):longint;
begin
hitungselisih:=((jam2.jam*3600)+(jam2.menit*60)+jam2.detik)-((jam1.jam*3600)+(jam1.menit*60)+jam1.detik);
end;

function hitungbiaya(jam1,jam2:waktu):longint;
var
temp1:longint;
begin
temp1:=hitungselisih(jam1,jam2);
if (temp1 mod 30 >0) then
hitungbiaya:=((temp1 div 30)*250)+250
else
hitungbiaya:=(temp1 div 30)*250;
end;

var
jam1,jam2:waktu;
biaya,lama:longint;

begin
writeln('masukan waktu awal ');
write('jam = ');readln(jam1.jam);
write('menit = ');readln(jam1.menit);
write('detik = ');readln(jam1.detik);
writeln;
writeln('masukan waktu akhir ');
write('jam = ');readln(jam2.jam);
write('menit = ');readln(jam2.menit);
write('detik = ');readln(jam2.detik);
writeln;
biaya:=hitungbiaya(jam1,jam2);
lama:=hitungselisih(jam1,jam2);
writeln('lama percakapan = ',lama,' detik');
writeln('biaya menelpon = ',biaya);
end.

› Read More

penjualan minuman dalam pascal

Program hitung;

uses wincrt;

const m:longint=5;

type barang=record
     kode:longint;
     nama:string;
     harga:longint;
     berat:longint;
     stok:longint;
     pembelian:longint;
     end;

function cekharga(uang,harga:longint):boolean;
var
cek:boolean;
begin
     cek:=false;
     if (uang>=harga) then
     begin
          cek:=true;
     end;
     cekharga:=cek;
end;

function cekberat(berat,barang:longint):boolean;
var
cek:boolean;
begin
     cek:=false;
     if (barang>=berat) then
     begin
          cek:=true;
     end;
     cekberat:=cek;
end;

function cekstok(stok:longint):boolean;
var
cek:boolean;
begin
     cek:=true;
     if (stok=0) then
     begin
          cek:=false;
     end;
     cekstok:=cek;
end;

procedure hitungstok(var stok:longint);
begin
    stok:=stok-1;
end;

procedure beli(var uang:longint; harga:longint );
begin
     uang:=uang-harga;    
end;

procedure penuh(var kranjang:longint; berat:longint );
begin
     kranjang:=kranjang-berat;    
end;


var
product,simpan:array [1..50] of barang;
i,n,uang,kranjang,temp:longint;
pil:string;
begin
temp:=0;
     product[1].kode:=1;
     product[1].nama:=('coke');
     product[1].harga:=5000;
     product[1].berat:=350;
     product[1].stok:=5;
     product[2].kode:=2;
     product[2].nama:=('sprite');
     product[2].harga:=3500;
     product[2].berat:=275;
     product[2].stok:=7;
     product[3].kode:=3;
     product[3].nama:=('bear');
     product[3].harga:=6000;
     product[3].berat:=400;
     product[3].stok:=9;
     product[4].kode:=4;
     product[4].nama:=('fanta');
     product[4].harga:=4000;
     product[4].berat:=275;
     product[4].stok:=4;
     product[5].kode:=5;
     product[5].nama:=('redbull');
     product[5].harga:=6000;
     product[5].berat:=350;
     product[5].stok:=5;
     for i:= 1 to m do
     begin
          simpan[i]:=product[i];
          simpan[i].pembelian:=0;
     end;
     writeln('|-------------------------------------|');
     writeln('|kode  |nama    |harga  |berat  |stok |');
     writeln('|-------------------------------------|');
     writeln('| 1    |coke    |5000   |350    |  ',product[1].stok,'  |');
     writeln('| 2    |sprite  |3500   |275    |  ',product[2].stok,'  |');
     writeln('| 3    |bear    |6000   |400    |  ',product[3].stok,'  |');
     writeln('| 4    |fanta   |4000   |275    |  ',product[4].stok,'  |');
     writeln('| 5    |redbull |6000   |350    |  ',product[5].stok,'  |');
     writeln('|-------------------------------------|');
     writeln;
     writeln;
     write('masukan jumlah uang anda : ');readln(uang);
     write('masukan kapasitas keranjang anda : ');readln(kranjang);
     writeln;
     write('apakah anda ingin berbelanja (y/t) ');readln(pil);
     writeln;
     while (pil='y') do
     begin
          write('masukan kode minuman yg ingin dibeli : ');readln(n);
          writeln;
          if (n<=m) then
          begin
               if (cekstok(product[n].stok)=true) then
               begin
                    if (cekberat(product[n].berat,kranjang)=true) and (cekharga(uang,product[n].harga)=true) then
                    begin
                         beli(uang,product[n].harga);
                         penuh(kranjang,product[n].berat);
                         hitungstok(product[n].stok);
                         simpan[n].pembelian:=simpan[n].pembelian+1;
                         temp:=temp+1;
                         write('apakah anda ingin berbelanja lagi (y/t) ');readln(pil);
                         writeln;
                    end
                    else
                    begin
                         clrscr;
                         writeln('maav anda tidak bisa melakukan transaksi');
                         writeln('terima kasih');
                         writeln;
                         writeln('sisa uang anda : ',uang);
                         writeln('sisa kapasitas kranjang : ',kranjang);
                         writeln;
                         if (temp>0) then
                         begin
                              writeln('barang yg telah dibeli : ');
                              for i:= 1 to m do
                              begin
                                   if (simpan[i].pembelian>0) then
                                   begin
                                        writeln(simpan[i].nama,' jumlah yg dibeli ',simpan[i].pembelian);
                                   end
                              end;
                         end
                         else
                             writeln('tidak ada barang yg dibeli');
                    writeln;
                    writeln;
                    writeln('sisa minuman');
                    writeln;
                    writeln('|-------------------------------------|');
                    writeln('|kode  |nama    |harga  |berat  |stok |');
                    writeln('|-------------------------------------|');
                    writeln('| 1    |coke    |5000   |350    |  ',product[1].stok,'  |');
                    writeln('| 2    |sprite  |3500   |275    |  ',product[2].stok,'  |');
                    writeln('| 3    |bear    |6000   |400    |  ',product[3].stok,'  |');
                    writeln('| 4    |fanta   |4000   |275    |  ',product[4].stok,'  |');
                    writeln('| 5    |redbull |6000   |350    |  ',product[5].stok,'  |');
                    writeln('|-------------------------------------|');
                    writeln;
                    pil:=' ';
                    end;
               end
               else
               begin
                    writeln('maav stok kosong');
                    writeln;
                    write('apakah anda ingin berbelanja lagi (y/t) ');readln(pil);
                    writeln;
               end;
          end
          else
          begin
               writeln('maaf kode barang tidak terdaftar');
               writeln;
               write('apakah anda ingin berbelanja lagi (y/t) ');readln(pil);
               writeln;
          end;
     end;
     if (pil='t') then
     begin
        clrscr;
        writeln('terima kasih');
        writeln;
        writeln('sisa uang anda : ',uang);
        writeln('sisa kapasitas kranjang : ',kranjang);
        writeln;
        if (temp>0) then
        begin
           writeln('barang yg telah dibeli : ');
           for i:= 1 to m do
           begin
                if (simpan[i].pembelian>0) then
                begin
                     writeln(simpan[i].nama,' jumlah yg dibeli ',simpan[i].pembelian);
                end
           end;
        end
        else
            writeln('tidak ada barang yg dibeli');
        writeln;
        writeln;
        writeln('sisa minuman');
        writeln;
        writeln('|-------------------------------------|');
        writeln('|kode  |nama    |harga  |berat  |stok |');
        writeln('|-------------------------------------|');
        writeln('|  1   |coke    | 5000  | 350   |  ',product[1].stok,'  |');
        writeln('|  2   |sprite  | 3500  | 275   |  ',product[2].stok,'  |');
        writeln('|  3   |bear    | 6000  | 400   |  ',product[3].stok,'  |');
        writeln('|  4   |fanta   | 4000  | 275   |  ',product[4].stok,'  |');
        writeln('|  5   |redbull | 6000  | 350   |  ',product[5].stok,'  |');
        writeln('|-------------------------------------|');
        writeln;
     end;
end.

› Read More

mencari niali terkecil array 2 dimensi

program matiks;


uses wincrt;

type
tab=record
kolom:integer;
baris:integer;
bil:integer;
end;

type
arin=array [1..100] of integer;

procedure min(b:arin;m,n:integer;var c:tab);
var
i,j,domp,temp:integer;
begin
domp:=b[1];
c.baris:=1;
c.kolom:=1;
for i:=1 to m do
begin
for j:= 1 to n do
begin
if domp>=b[j] then
begin
domp:=b[j];
c.baris:=i;
c.kolom:=j;
end;
end;
end;
c.bil:=domp;
end;


var
a:arin;
i,j,m,n,x:integer;
domp:tab;

begin
write('masukan jumlah baris : ');readln(n);
write('masukan jumlah kolom : ');readln(m);
for i:=1 to m do
begin
for j:= 1 to n do
begin
write('a[',i,',',j,'] : ');readln(a[j]);
end;
end;
writeln;
min(a,m,n,domp);
writeln('jadi bilangan terkecil adalah : ',domp.bil,' berada di a[',domp.baris,',',domp.kolom,']');
end.

› Read More

menghitung nilai 4 bilangan dalam pascal

program min_4bil;

uses wincrt;

function min2(a,b:integer):integer;
var
x : integer;

begin
     if a > b then
     x:=a
     else
     x:=b;
     min2:=x;
end;

var
a,b,c,d,x,y,z:integer;

begin
readln(a);
readln(b);
readln(c);
readln(d);
x:=min2(a,b);
y:=min2(c,d);
z:=min2(x,y);
writeln('nilai max = ',z);
end.

› Read More

mencari bilangan terkecil dalam array 2 dimensi

program matiks;

uses wincrt;

type
arin=array [1..100] of integer;

function min(b:arin;m,n:integer):integer;
var
i,j,domp:integer;
begin
domp:=b[1];
for i:=1 to m do
begin
for j:= 1 to n do
begin
if domp>=b[j] then
domp:=b[j];
end;
end;
min:=domp;
end;


var
a:arin;
i,j,m,n,x,domp:integer;

begin
write('masukan jumlah baris : ');readln(n);
write('masukan jumlah kolom : ');readln(m);
for i:=1 to m do
begin
for j:= 1 to n do
begin
write('a[',i,',',j,'] : ');readln(a[j]);
end;
end;
domp:=min(a,m,n);
writeln('jadi bilangan bilangan terkecil adalah ',domp);
end.

› Read More

metode regulafalsi dalam pascal.

Program hitung_bifeksi;

uses wincrt;

function f(x:real):real;
         begin
         f:=(((sqr(x))*x)-(sqr(x))-(2*(x))+1);
         end;

function error(x1,x2:real):real;
         var
         err:real;
         begin
         err:=(((x2-x1)/x2)*100);
         if err<0 then
            error:=err*(-1)
         else
             error:=err;
         end;

function hitxc(xa,xb:real):real;
         begin
         hitxc:=(xb-((f(xb)*(xb-xa))/(f(xb)-f(xa))));
         end;

procedure pilakar(var xa,xb:real;xc:real);
         begin
         if (f(xa)*f(xc)<0 )then
            begin
              xb:=xc;
              end
         else
             begin
             xa:=xc;
             end;
         end;

function cek(xa,xb:real):boolean;
         var
         c:boolean;
         cek1:real;
         begin
         c:=false;
         cek1:=(f(xa)*f(xb));
         if (cek1<0) then
          begin
c:=true;
end;
         cek:=c;
         end;

procedure lanjut(var it:integer; var xc1,xc2:real;xc:real);
          begin
          it:=it+1;
          xc1:=xc2;
          xc2:=xc;
          end;


var
x1,x2,emin,er,xc,xc1,xc2,a,b,c:real;
iterasi:integer;
cek2:boolean;
begin
repeat
      begin
      clrscr;
      write('masukan x1 : ');readln(x1);
      write('masukan x2 : ');readln(x2);
      write('masukan error min : ');readln(emin);
      cek2:=(cek(x1,x2));
      if (cek2=false) then
         begin
         writeln('iterasi tidak dapat dilakukan');
         write('tekan enter');readln;
         end;
      end;
until(cek2=true);
iterasi:=0;
er:=100;
xc1:=0;
xc2:=0;
clrscr;
writeln('|ite  |   x1   |   x2   |   f(x1) |   f(x2) |   xc   |   f(xc) | eror   |');
while (er > emin) do
      begin
         xc:=hitxc(x1,x2);
         a:=f(x1);
         b:=f(x2);
         c:=f(xc);
         lanjut(iterasi,xc1,xc2,xc);
         if (iterasi<2) THEN
            writeln('|  ',iterasi,'  | ',x1:0:5,'| ',x2:0:5,'| ',a:0:5,'| ',b:0:5,'| ',x1:0:5,'| ',c:0:5,'|         |')
         else
             begin
             er:=error(xc1,xc2);
             writeln('|  ',iterasi,'  | ',x1:0:5,'| ',x2:0:5,'| ',a:0:5,'| ',b:0:5,'| ',x1:0:5,'| ',c:0:5,'| ',er:0:5,' |');
             end;
         pilakar(x1,x2,xc);
      end;
      writeln;
      writeln('jawaban = ',xc:0:5);  
   
end.

› Read More

metode newton reption dalam pascal.

Program hitung_secant;

uses wincrt;

function f(x:real):real;
         begin
         f:=(((sqr(x))*x)+(sqr(x))-(3*(x))-3);
         end;

function ff(x:real):real;
         begin
         ff:=((3*(sqr(x)))+(2*(x))-3);
         end;

function error(x1,x2:real):real;
         var
         err:real;
         begin
         err:=(((x2-x1)/x2)*100);
         if err<0 then
            error:=err*(-1)
         else
             error:=err;
         end;

function hitxc(xa:real):real;
         begin
         hitxc:=(xa-(f(xa)/ff(xa)));
         end;

procedure pilakar(var xa:real;xc:real);
         begin
         xa:=xc;
         end;

procedure lanjut(var it:integer; var xc1,xc2:real;xc:real);
          begin
          it:=it+1;
          xc1:=xc2;
          xc2:=xc;
          end;

var
x1,emin,er,xc,xc1,xc2,a,b,c:real;
iterasi:integer;
begin
      write('masukan x1 : ');readln(x1);
      write('masukan error min : ');readln(emin);
iterasi:=0;
er:=100;
xc1:=0;
xc2:=0;
clrscr;
writeln('|ite  |   xi   |   f(xi) |   f"(xi) |   xc   |   f(xc) | eror   |');
while (er > emin) do
      begin
         xc:=hitxc(x1);
         a:=f(x1);
         c:=f(xc);
         b:=ff(x1);
         lanjut(iterasi,xc1,xc2,xc);
         if (iterasi<2) THEN
            writeln('|  ',iterasi,'  | ',x1:0:5,'| ',a:0:5,'| ',b:0:5,'| ',xc:0:5,'| ',c:0:5,'|         |')
         else
             begin
             er:=error(xc1,xc2);
             writeln('|  ',iterasi,'  | ',x1:0:5,'| ',a:0:5,'| ',b:0:5,'| ',xc:0:5,'| ',c:0:5,'| ',er:0:5,' |');
             end;
         pilakar(x1,xc);
      end;
      writeln;
      writeln('jawaban = ',xc:0:5);
   
end.

› Read More

metode bisection (interval tengah) dalam pascal.

Program hitung_bifeksi;

uses wincrt;

function f(x:real):real;
         begin
         f:=(((sqr(x))*x)+(sqr(x))-(3*(x))-3);
         end;

function error(x1,x2:real):real;
         var
         err:real;
         begin
         err:=(((x2-x1)/x2)*100);
         if err<0 then
            error:=err*(-1)
         else
             error:=err;
         end;

function hitxc(xa,xb:real):real;
         begin
         hitxc:=(xa+xb)/2;
         end;

procedure pilakar(var xa,xb:real;xc:real);
         begin
         if (f(xa)*f(xc)<0 )then
            begin
              xb:=xc;
              end
         else
             begin
             xa:=xc;
             end;
         end;

function cek(xa,xb:real):boolean;
         var
         c:boolean;
         cek1:real;
         begin
         c:=false;
         cek1:=(f(xa)*f(xb));
         if (cek1<0) then
          begin
c:=true;
end;
         cek:=c;
         end;

procedure lanjut(var it:integer; var xc1,xc2:real;xc:real);
          begin
          it:=it+1;
          xc1:=xc2;
          xc2:=xc;
          end;


var
x1,x2,emin,er,xc,xc1,xc2,a,b,c:real;
iterasi:integer;
cek2:boolean;
begin
repeat
      begin
      clrscr;
      write('masukan x1 : ');readln(x1);
      write('masukan x2 : ');readln(x2);
      write('masukan error min : ');readln(emin);
      cek2:=(cek(x1,x2));
      if (cek2=false) then
         begin
         writeln('iterasi tidak dapat dilakukan');
         write('tekan enter');readln;
         end;
      end;
until(cek2=true);
iterasi:=0;
er:=100;
xc1:=0;
xc2:=0;
clrscr;
writeln('|ite  |   x1   |   x2   |   f(x1) |   f(x2) |   xc   |   f(xc) | eror   |');
while (er > emin) do
      begin
         xc:=hitxc(x1,x2);
         a:=f(x1);
         b:=f(x2);
         c:=f(xc);
         lanjut(iterasi,xc1,xc2,xc);
         if (iterasi<2) THEN
            writeln('|  ',iterasi,'  | ',x1:0:5,'| ',x2:0:5,'| ',a:0:5,'| ',b:0:5,'| ',x1:0:5,'| ',c:0:5,'|         |')
         else
             begin
             er:=error(xc1,xc2);
             writeln('|  ',iterasi,'  | ',x1:0:5,'| ',x2:0:5,'| ',a:0:5,'| ',b:0:5,'| ',x1:0:5,'| ',c:0:5,'| ',er:0:5,' |');
             end;
         pilakar(x1,x2,xc);
      end;
      writeln;
      writeln('jawaban = ',xc:0:5);  
   
end.

› Read More

cek 2 tabel apakah sama dalam pascal.

program lat31;
uses wincrt;
type values = array[1..100]of integer;

procedure balik(var a:values; n:integer);
var i,tmp,j:integer;
begin
j:=n;
for i:=1 to (n div 2) do
    begin
    tmp:=a[i];
    a[i]:=a[j];
    a[j]:=tmp;
    j:=j-1;
    end
end;

function sama(a,b:values; n,m:integer):boolean;
var k,i:integer;
    search:boolean;
begin
balik(a,n);
search:=true;
if n<m then k:=n
else k:=m;
i:=1;
while search and (i<=k) do
      begin
      if a[i]<>b[i] then search:=false
      else i:=i+1;
      end;
sama:=search;
end;

var a,b:values;
    n,m,i:integer;
    hasil:boolean;
begin
write('Masukan banyak elemen tabel a = ');readln(n);
writeln;
for i:=1 to n do
    begin
    write('a[',i,'] = ');readln(a[i]);
    end;
writeln;
write('Masukan banyak elemen tabel b = ');readln(m);
writeln;
for i:=1 to m do
    begin
    write('b[',i,'] = ');readln(b[i]);
    end;
writeln;
hasil:=sama(a,b,n,m);
if hasil then writeln('Kedua tabel sama')
else writeln('Kedua tabel tidak sama');
end.

› Read More