Pembangkit angka acak
Interface
Uses util, tipe;
{Type
tipe1 = array[1..5] of double;}
Var
tipe11 : tipe1;
{ 1 } Function Uniform (a,b : double) : double;
{ 2 } Function Eksponensial (beta : double) : double;
{ 3 } Function Erlang (n : longint ; beta : double) : double;
{ 4a} Function Gamma (alfa,beta : double) : double;
{ 4b} Function InvGamma (alfa,beta : double) : double;
{ 5 } Function Weibull (alfa,beta: double) : double;
{ 6a} Procedure Normal (mean,variance : double ; Var z1,z2 : double);
{ 6b} procedure lognormal (mean,varr : double; Var zln1,zln2 : double);
{ 7 } Function Beta (alfa1,alfa2,a,b : double) : double;
{ 8 } Function Bernoulli (p : double) : double;
{ 9 } Function Acak_Diskrit_Sebarang (n : longint ; x,probd : tipe1) : double;
{10 } Function Randi (n : longint ; probd : tipe1) : longint;
{11 } Function Binomial (n : longint ; p : double) : double;
{12 } Function Geometri (p : double) : double;
{13 } Function Binomial_Negatip (n : longint ; p : double) : double;
{14 } Function Poisson (beta : double) : double;
{15 } Function tdistribution(m:integer):double;
Implementation
Function Uniform (a,b : double) : double;
Var u : double;
Begin
u := random;
Uniform := (b-a) * u + a;
End;
Function Eksponensial (beta : double) : double;
Var u : double;
Begin
u := random;
Eksponensial := -beta * ln(u);
End;
Function Erlang (n : longint ; beta : double) : double;
Var u,sum : double;
i : longint;
Begin
sum := 1;
for i:=1 to n do
begin
u := random;
sum := sum * u;
end;
Erlang := -beta * ln(sum);
End;
Function Gamma (alfa,beta : double) : double;
Var selesai : boolean;
a,b,u,p,y,q,teta,d,u1,u2,v,w,z : double;
Begin
if alfa < 1 then
begin
b := 1 + alfa/exp(1);
Repeat
selesai := false;
u := random;
p := b * u;
if p > 1 then
begin
y := -ln((b-p)/alfa);
u := random;
if exp((alfa-1)*ln(y)) >= u then
begin
Gamma := beta * y;
selesai := true
end
end
else
begin
y := exp (ln(p)/alfa);
u := random;
if exp(-y) >= u then
begin
Gamma := beta * y;
selesai := true
end
end
Until selesai;
end
else
if (alfa > 0.99999999) and (alfa < 1.0000001) then
begin
y := Eksponensial (1);
Gamma := beta * y;
end
else
begin
a := 1 / sqrt(2*alfa-1);
b := alfa - ln(4);
q := alfa + 1/a;
teta := 4.5;
d := 1 + ln(teta);
Repeat
selesai := false;
u1 := random;
u2 := random;
v := a * ln(u1/(1-u1));
y := alfa * exp(v);
z := sqr(u1) * u2;
w := b + q * v - y;
if (w+d-teta*z >= 0) then
begin
Gamma := beta * y;
selesai := true;
end
else
if w >= ln(z) then
begin
Gamma := beta * y;
selesai := true
end
Until selesai;
end
End;
Function InvGamma(alfa,beta : double) : double;
Var temp : double;
begin
temp := gamma(alfa,beta);
InvGamma := sqrt(1/temp);
end;
Function Weibull (alfa,beta: double) : double;
Var u,z : double;
Begin
u := random;
z := -ln(u);
Weibull := beta * exp (ln(z)/alfa);
End;
Procedure Normal (mean,variance : double ; Var z1,z2 : double);
Var u1,u2,v1,v2,w,y,x1,x2 : double;
Begin
Repeat
u1 := random;
u2 := random;
v1 := 2 * u1 - 1;
v2 := 2 * u2 - 1;
w := sqr(v1) + sqr(v2);
if w <= 1 then
begin
y := sqrt ((-2*ln(w))/w);
x1 := v1 * y;
x2 := v2 * y;
z1 := sqrt (variance) * x1 + mean;
z2 := sqrt (variance) * x2 + mean;
end
Until w <= 1;
End;
Function Beta (alfa1,alfa2,a,b : double) : double;
Var u1,u2,y : double;
Begin
u1 := Gamma (alfa1,1);
u2 := Gamma (alfa2,1);
y := u1/(u1+u2);
Beta := a + (b-a) * y;
End;
Function Bernoulli (p : double) : double;
Var u : double;
Begin
u := random;
if u <= p then
Bernoulli := 1
else
Bernoulli := 0;
End;
Function Acak_Diskrit_Sebarang (n : longint ; x,probd : tipe1) : double;
Var u : double;
i : longint;
Begin
u := random;
for i:=1 to n-1 do
if u <= probd[i] then
begin
Acak_Diskrit_Sebarang := x[i];
exit
end;
Acak_Diskrit_Sebarang := x[i];
End;
Function Randi (n : longint ; probd : tipe1) : longint;
Var u : double;
i : longint;
Begin
u := random;
for i:=1 to n-1 do
if u <= probd[i] then
begin
Randi := i;
exit
end;
Randi := n;
End;
Function Binomial (n : longint ; p : double) : double;
Var sum,u : double;
i : longint;
Begin
sum := 0;
for i:=1 to n do
begin
u := Bernoulli(p);
sum := sum + u;
end;
Binomial := sum
End;
Function Geometri (p : double) : double;
Var u : double;
Begin
u := random;
Geometri := ln(u) / ln(1-p);
End;
Function Binomial_Negatip (n : longint ; p : double) : double;
Var sum,u : double;
i : longint;
Begin
sum := 1;
for i:=1 to n do
begin
u := random;
sum := sum * u;
end;
Binomial_Negatip := ln(sum) / ln(1-p);
End;
Function Poisson (beta : double) : double;
Var lamda,a,b,u : double;
i : longint;
Begin
lamda := 1/beta;
a := exp(-lamda);
b := 1; i := 0;
Repeat
u := random;
b := b * u;
if b < a then
Poisson := i
else
i := i + 1;
Until b < a;
End;
procedure lognormal (mean,varr : double;
Var zln1,zln2 : double);
Var y1, y2 : double;
begin
Normal (mean,varr,y1,y2);
zln1 := exp(y1);
zln2 := exp(y2);
end;
function tdistribution(m:integer):double;
{ created :
based on Principles of Random Variate Generation
by John Dagpunar, 1988
published by Claredon Press - OXFORD
please check if any other theory of t-distribution }
Label r2;
Var v,x,r,s,c,a,f,g,mm : real;
begin
mm:=0;
if m < 1 then
begin
writeln('impermissible degrees of freedom.');
halt;
end;
if (m <> mm) then
begin
s:=m;
c:=-0.25*(s+1);
a:=4/power((1+1/s),c);
f:=16/a;
if m>1 then
begin
g:=s-1;
g:=power(((s+1)/g),c)*sqrt((s+s)/g);
end else
g := 1;
mm:=m;
end;
r2:repeat
r:=random;
until r > 0.0;
x:=(2*random-1)*g/r;
v:=x*x;
if (v>(5-a*r)) then
begin
if ((m>=3) and (r*(v+3)>f)) then goto r2;
if (r>power((1+v/s),c)) then goto r2;
end;
tdistribution :=x;
end;
begin
tipe11[1]:=0.2;
tipe11[1]:=0.3;
tipe11[1]:=0.5;
tipe11[1]:=0.8;
tipe11[1]:=1.0;
end.
Fungsion Bernauli
program bernoul;
uses wincrt;
Function Bernoulli(p : real) : real;
Var u : real;
Begin
u:= random;
if u <= p then
Bernoulli := 1
else
Bernoulli := 0;
End;
var i,n:integer;
s,p:real;
begin
write('berapa peluang p =');read(p);
write('berapa data = ');read(n);
for i:=1 to n do
begin
s:=bernoulli(p);
writeln;
write('data',s:10:0);
end;
end.
Fungsion binomial
uses wincrt;
Function Binomial_Negatip (n : longint ; p : real) : real;
Var sum,u : real;
i : longint;
Begin
sum := 1;
for i:=1 to n do
begin
u := random;
sum := sum * u;
end;
Binomial_Negatip := ln(sum) / ln(1-p);
End;
var p,x:real;
j,n,m:integer;
begin
write('Banyak data yang akan dibangkitkan =');read(m);
write('Peluang suatu kejadian =');read(p);
write('Kejadian ke- =');read(n);
for j:=1 to m do
begin
x:=binomial_negatip(n,p);
writeln('data =',x:10:0);
end;
end.
Fungsion log normal
uses wincrt;
procedure normal(mean,variance:real; Var z1,z2 : real);
Var u1,u2,v1,v2,w,y,x1,x2: real;
Begin
Repeat
u1 := random;
u2 := random;
v1 := 2 * u1 - 1;
v2 := 2 * u2 - 1;
w := sqr(v1) + sqr(v2);
if w <= 1 then
begin
y := sqrt ((-2*ln(w))/w);
x1 := v1 * y;
x2 := v2 * y;
z1 := sqrt (variance) * x1 + mean;
z2 := sqrt (variance) * x2 + mean;
end
Until w > 1;
End;
procedure lognormal (mean,varr : real; Var zln1,zln2 : real);
Var y1, y2 : real;
begin
Normal (mean,varr,y1,y2);
zln1 := exp(y1);
zln2 := exp(y2);
end;
var a,b,c,d,e,f:real;
i,n:integer;
begin
write('mean =');read(a);
write('variance =');read(b);
write('
write('berapa data yang akan dibangkitkan ?');read(n);
for i:=1 to n do
begin
lognormal(a,b,c,d);
writeln('zln1 =',e);
writeln('zln2 =',f);
write('-------------------');
end;
Fungsion normal
uses wincrt;
procedure normal(mean,variance:real; Var z1,z2 : real);
Var u1,u2,v1,v2,w,y,x1,x2: real;
Begin
Repeat
u1 := random;
u2 := random;
v1 := 2 * u1 - 1;
v2 := 2 * u2 - 1;
w := sqr(v1) + sqr(v2);
if w <= 1 then
begin
y := sqrt ((-2*ln(w))/w);
x1 := v1 * y;
x2 := v2 * y;
z1 := sqrt (variance) * x1 + mean;
z2 := sqrt (variance) * x2 + mean;
end
Until w > 1;
End;
var p,o,i,u:real;
f,n:integer;
begin
write('mean =');read(p);
write('variance =');read(o);
write('berapa data yang dibangkitkan ?');read(n);
for f:=1 to n do
begin
normal(p,o,i,u);
writeln('z1 =',i:10:2);
writeln('z2 =',u:10:2);
writeln('---------------------------------');
end;
Fungsion Bublesort
program sorting;
uses wincrt;
type tipelarik=array [1..100] of real;
var e,c,m:integer;
d:tipelarik;
procedure tukarkan(var a,b:real);
var t:real;
begin
t:=a;
a:=b;
b:=t;
end;
procedure bublesort(var a:tipelarik;n:integer);
var i,j: integer;
begin
for i:=1 to n-1 do
for j:=1 to n-i do
if a[j]>a[j+1] then tukarkan(a[j],a[j+1])
end;
begin
write('jumlah data');readln(m);
for e:=1 to m do
readln(d[e]);
bublesort(d,m);
for c:=1 to m do
writeln(d[c]:0:0)
Fungsion median
function median (vektor:larik; N:integer);
var x,med:real;
begin
x:=n div 2
if n mod 2=0
med:=vektor[x]+vektor[x+1]/2;
else
med:=vektor[x+1]
end;
end.
Fungion run test
program sorting;
uses wincrt;
type tipelarik=array [1..100] of real;
var e,c,m,z:integer;
d,f,vektor:tipelarik;
med:real;
procedure tukarkan(var a,b:real);
var t:real;
begin
t:=a;
a:=b;
b:=t;
end;
procedure median(vektor:tipelarik;n:integer);
var x:integer;
begin
x:=n div 2;
if n mod 2=0 then
med:=(vektor[x]+vektor[x+1])/2
else
med:=vektor[x+1];
end;
procedure bublesort(var a:tipelarik;n:integer);
var i,j: integer;
begin
for i:=1 to n-1 do
for j:=1 to n-i do
if a[j]>a[j+1] then tukarkan(a[j],a[j+1])
end;
begin
write('jumlah data=');
readln(m);
writeln('masukkan data=');
for e:=1 to m do
readln(d[e]);
f:=d;
{mengecek bahwa f adalah data awal}
Write('data sebelum urut=');
writeln(f[1]);
writeln('data yang diurutkan=');
bublesort(d,m);
for c:=1 to m do
writeln(d[c]:0:0);
median(d,m);
write('median=');
writeln(med:0:2);
for z:=1 to m do
begin
f[z]:=f[z]-med;
writeln(f[z]:0:2);
end;
