contoh program pascal

4

Hasilnya adalah:

Program ganjil_genap;

uses wincrt;

var

bil, i,g1,g2,j1,j2,n: integer;

rt1,rt2:real;

begin

write('Masukkan Banyaknya Data ' );readln(n);

for i := 1 to n do

begin

write('Bilangan ke:',i ,' ');readln(bil);

if bil mod 2 = 0 then

j1:=j1 +1;

g1:=g1+bil;

if bil mod 2 =1 then

j2:=j2+1;

g2:=g2+bil;

end;

rt1:=g1/j1;

rt2:=g2/j2;

writeln('Jumlah bil. Ganjil=' ,j2);

writeln('Jumlah bil. Genap=' ,j1);

writeln('Rerata Ganjil=' ,rt2:4:2);

writeln('Rerata Genap=' ,rt1:4:2);

end.

Hasilnya adalah:

5

Program Tumpukan

uses wincrt;

const MaxElemen=5;

type Tumpukan =record

isi:array[1..MaxElemen] of integer;

atas: 0..MaxElemen

end;

type isi=array[0..maxelemen] of integer;

const isilama1:isi=(3,7,2,6,4,8);

isibaru1:isi=(4,8,3,6,5,1);

var

Nilailama,Nilaibaru:isi;

T:tumpukan;

{---------------------------------------------------------------------}

Procedure Ganti_NilaiStack(T:tumpukan;Nilailama,Nilaibaru:isi);

var

penuh,habis: boolean;

x,i:integer;

{---------------------------------------------------------------------}

procedure push( var T:tumpukan; var penuh:boolean;x:integer);

begin

if T.atas = maxElemen then penuh:=true

else

begin

penuh :=false;

T.isi[T.atas]:=x;

T.atas:=T.atas+1;

end;

end;

{---------------------------------------------------------------------}

procedure pop(var T:tumpukan;var habis:boolean; var x:integer);

begin

if T.atas =0 then habis:=true

else

begin

habis:=false;

T.atas:=T.atas-1;

x:=T.isi[T.atas];

end;

end;

{---------------------------------------------------------------------}

begin

clrscr;

write('Nilai Lama Sebelum Masuk Tumpukan : ');

for i:=0 to maxelemen do

write(isilama1[i]);

writeln;

write('Nilai Baru Sebelum Masuk Tumpukan : ');

for i:=0 to maxelemen do

write(isibaru1[i]);

6

writeln;

penuh:=false;

while penuh=false do

begin

push(T,penuh,Nilailama[T.atas]);

end;

write('Isi Tumpukan Lama : ');

while T.atas<>0 do

begin

pop(T,habis,x);

write(x);

end;

writeln;penuh:=false;

while penuh=false do

begin

push(T,penuh,Nilaibaru[T.atas]);

end;

write('Isi Tumpukan Baru : ');

while T.atas<>0 do

begin

pop(T,habis,x);

write(x);

end;

end;

{---------------------------------------------------------------------}

begin

Nilailama:=isilama1;Nilaibaru:=isibaru1;

Ganti_NilaiStack(T,Nilailama,Nilaibaru);

readkey;

end.

Hasilnya adalah:

Antrian Melingkar

uses wincrt;

type lingkar=array[1..10] of char;

type ling=record

nilai:lingkar;

dep:integer;

bel:integer;

isi:integer;

end;

var n:integer;

antrian:ling;

{---------------------------------------------------------------------}

procedure push(var antrian:ling;x:char);

7

begin

if antrian.isi=n then write('antrian penuh')

else

begin

if antrian.bel=n then antrian.bel:=1

else antrian.bel:=antrian.bel+1;

antrian.nilai[antrian.bel]:=x;

antrian.isi:=antrian.isi+1;

end;

end;

{---------------------------------------------------------------------}

procedure pop(var antrian:ling;var x:char);

begin

if antrian.isi=0 then write('antrian kosong')

else

begin

antrian.dep:=antrian.dep+1;

if antrian.dep=n+1 then antrian.dep:=1;

x:=antrian.nilai[antrian.dep];

antrian.nilai[antrian.dep]:=' ';

antrian.isi:=antrian.isi-1;

end;

end;

{---------------------------------------------------------------------}

var i,ingin:integer;

x:char;

begin

n:=5;

i:=0;

repeat

i:=i+1;

write('antrian ke - ',i,' = ');readln(x);

push(antrian,x);

until i=n;

for i:=1 to antrian.bel do write(antrian.nilai[i],' ');

readln;

repeat

write('Anda ingin 0. Udah, 1. Push, 2. pop');readln(ingin);

if ingin<>0 then

case ingin of

1: begin

write('nilai yang akan masuk : ');readln(x);

push(antrian,x);

for i:=1 to n do

write(antrian.nilai[i],' ');

writeln;

end;

2: begin

x:=' ';

pop(antrian,x);

writeln('Data keluar = ',x);

for i:=1 to n do

write(antrian.nilai[i],' ');

8

writeln;

end;

end

until ingin=0;

end.

Hasilnya adalah:

Program Hitung_Huruf;

Uses WinCrt;

Var

Teks : string;

banyak : array['A'..'Z'] of byte;

i : byte;

begin

Write('Masukkan Suatu Kalimat :');

Readln(Teks);

for i:=1 to length(teks) do

banyak[upcase(teks[i])]:=banyak[upcase(teks[i])]+1;

for i:=1 to 26 do

if (banyak[upcase(chr(64+i))]<>0) then

writeln(upcase(chr(64+i)),' banyaknya

=',banyak[upcase(chr(64+i))]);

end.

Hasilnya adalah:

Program Konversi_Bilangan;

Uses WinCrt;

Var

des,desi : integer;

Bin,temp : String;

Begin

Write('Masukkan Suatu Bilangan Desimal :');Readln(des);

desi:=des;

bin:='';

repeat

str(des mod 2, temp);

bin:=temp+bin;

9

des:=des div 2;

writeln(des:4,bin:20);

until des=0;

writeln('(',desi,') desimal =',bin,' (Biner)');

end.

Hasilnya adalah:

Program find kata dalam kalimat

uses wincrt;

var kalimat,kata:string;

i,j,k,sama:integer;

begin

write('Masukkan sebuah kalimat : ');readln(kalimat);

write('Masukkan sebuah kata : ');readln(kata);

k:=0;

if length(kata)<= length(kalimat) then

repeat

begin

i:=k+1;

while upcase(kalimat[i])<>upcase(kata[1]) do

i:=i+1;

k:=i;

sama:=1;

for j:=2 to length(kata) do

if upcase(kalimat[i+j-1])=upcase(kata[j]) then

sama:=sama+1;

if sama=length(kata) then

begin

write(kata,' adalah substring dari ',kalimat);

k:=length(kalimat)

end;

end;

until k>=length(kalimat);

if sama < length(kata) then

write(kata,' adalah bukan substring dari ',kalimat);

end.

10

Hasilnya adalah:

program cari_suku_fibonacci;

uses wincrt;

var x:array[1..50] of integer;

i,n:integer;

begin

x[1]:=1;

x[2]:=1;

write('Anda mencari suku ke : ');readln(n);

write(x[1],' ');

write(x[2],' ');

for i:=3 to n do

begin

x[i]:=x[i-1]+x[i-2];

write(x[i],' ');

end;

writeln;

writeln('Suku ke ',i,' = ',x[i]);

end.

Hasilnya adalah:

Program deret

uses wincrt;

var

i,t :integer;

a :real;

begin

i:=1; t:=-2; a:=0;

while i<= 10 do

begin

if i mod 2 = 1 then

begin

t:=t+3;

write('+1/',t);

a:=a+(1/t);

end

else

if i mod 2 = 0 then

begin

t:=t+2;

write('-1/',t);

11

a:=a-(1/t);

end;

i:=i+1;

end;

write(a);

end.

program krs_mahasiswa;

uses wincrt;

type

siswa=record

nim:string[5];

nama:string[15];

krs:array[1..4,1..5] of integer;

end;

type kuliah=array[1..20] of siswa;

var kul:kuliah;

{--------------------------------------------------------------------}

function huruf(bobot:integer):char;

begin

case bobot of

0:huruf:='E';

1:huruf:='D';

2:huruf:='C';

3:huruf:='B';

4:huruf:='A';

end;

end;

{--------------------------------------------------------------------}

procedure khs(n:integer;kul:kuliah);

var jumsks,usaha,i,j:integer;

ipnya:real;

begin

for i:=1 to n do

begin

Writeln('Nim : ',kul[i].nim);

Writeln('Nama : ',kul[i].nama);

writeln;

writeln('Kode sks nilai');

jumsks:=0;usaha:=0;

for j:=1 to 2 do

begin

writeln(kul[i].krs[1,j]:3,' ',kul[i].krs[2,j]:3,'

',huruf(kul[i].krs[4,j]):5);

jumsks:=jumsks+kul[i].krs[2,j];

usaha:=usaha + kul[i].krs[2,j]*kul[i].krs[4,j];

end;

if jumsks<>0 then

ipnya:=usaha/jumsks;

writeln;

writeln('IP = ',ipnya:0:2);

readkey;

sumber https://dirgamath29.fies.wordpress.com