Курсовой проект групп 3341 и 3382 / DMCore / Statistics

unit Statistics;

interface

uses
Exceptions,
math;

const
P0 : array [0..8] of double = (
-5.99633501014107895267E1,
9.80010754185999661536E1,
-5.66762857469070293439E1,
1.39312609387279679503E1,
-1.23916583867381258016E0,
0,0,0,0);

Q0 : array [0..8] of double = (
1.95448858338141759834E0,
4.67627912898881538453E0,
8.63602421390890590575E1,
-2.25462687854119370527E2,
2.00260212380060660359E2,
-8.20372256168333339912E1,
1.59056225126211695515E1,
-1.18331621121330003142E0,0);

P1 : array [0..8] of double = (
4.05544892305962419923E0,
3.15251094599893866154E1,
5.71628192246421288162E1,
4.40805073893200834700E1,
1.46849561928858024014E1,
2.18663306850790267539E0,
-1.40256079171354495875E-1,
-3.50424626827848203418E-2,
-8.57456785154685413611E-4);

Q1 : array [0..8] of double = (
1.57799883256466749731E1,
4.53907635128879210584E1,
4.13172038254672030440E1,
1.50425385692907503408E1,
2.50464946208309415979E0,
-1.42182922854787788574E-1,
-3.80806407691578277194E-2,
-9.33259480895457427372E-4,0);

P2 : array [0..8] of double = (
3.23774891776946035970E0,
6.91522889068984211695E0,
3.93881025292474443415E0,
1.33303460815807542389E0,
2.01485389549179081538E-1,
1.23716634817820021358E-2,
3.01581553508235416007E-4,
2.65806974686737550832E-6,
6.23974539184983293730E-9);


Q2 : array [0..8] of double = (
6.02427039364742014255E0,
3.67983563856160859403E0,
1.37702099489081330271E0,
2.16236993594496635890E-1,
1.34204006088543189037E-2,
3.28014464682127739104E-4,
2.89247864745380683936E-6,
6.79019408009981274425E-9,0);

LOGPI = 1.14472988584940017414;
MAXLOG = 7.09782712893383996732E2;
MACHEP = 1.11022302462515654042E-16;
big = 4.503599627370496e15;
biginv = 2.22044604925031308085e-16;
SQRTH = 7.07106781186547524401E-1;


function polevl( x : double; coef : array of double; N : integer ) : double;
function p1evl(x : double; coef : array of double; N : integer) : double;

function normalInverse(y0 : double ):double;
function chiSquaredProbability( x : double; v : double) : double;
function incompleteGammaComplement( a : double; x : double ) : double;
function incompleteGamma(a : double; x : double ) : double;
function lnGamma(x : double ) : double;
function normalProbability(a : double) :double;
function errorFunction(x : double) : double ;
function errorFunctionComplemented(a : double) : double;

implementation

function polevl( x : double; coef : array of double; N : integer) : double;
var
ans : double;
i : integer;
begin
ans := coef[0];

i := 1;
while (i<=N) do
begin
ans := ans*x+coef[i];
inc(i);
end;

Result := ans;
end;

function p1evl(x : double; coef : array of double; N : integer ) : double;
var
ans : double;
i : integer;
begin
ans := x + coef[0];

i := 1;
while (i<N) do
begin
ans := ans*x+coef[i];
inc(i);
end;

Result := ans;
end;

function normalInverse(y0 : double) : double;
var
x, y, z, y2, x0, x1: double;
code : integer;
s2pi : double;
begin
s2pi := sqrt(2.0*PI);

if( y0 <= 0.0 ) then
raise EIllegalArgumentException.Create('');

if( y0 >= 1.0 ) then
raise EIllegalArgumentException.Create('');

code := 1;
y := y0;
if( y > (1.0 - 0.13533528323661269189) ) then
begin
{ 0.135... = exp(-2) }
y := 1.0 - y;
code := 0;
end;

if( y > 0.13533528323661269189 ) then
begin
y := y - 0.5;
y2 := y * y;
x := y + y * (y2 * polevl( y2, P0, 4)/p1evl( y2, Q0, 8 ));
x := x * s2pi;
Result := x;
Exit;
end;

x := sqrt( -2.0 * ln(y) );
x0 := x - ln(x)/x;

z := 1.0/x;
if( x < 8.0 ) then { y > exp(-32) = 1.2664165549e-14 }
x1 := z * polevl( z, P1, 8 )/p1evl( z, Q1, 8 )
else
x1 := z * polevl( z, P2, 8 )/p1evl( z, Q2, 8 );

x := x0 - x1;
if( code <> 0 )then x := -x;

Result := x;
end;


function chiSquaredProbability( x : double; v : double) : double;
begin
if( x < 0) or (v < 1.0 ) then
begin
result := 0.0;
exit;
end;
result := incompleteGammaComplement( v/2.0, x/2.0 );
end;

function lnGamma(x : double ) : double;
const
A : array [0..4] of double = (
8.11614167470508450300E-4,
-5.95061904284301438324E-4,
7.93650340457716943945E-4,
-2.77777777730099687205E-3,
8.33333333333331927722E-2
);
B : array [0..5] of double = (
-1.37825152569120859100E3,
-3.88016315134637840924E4,
-3.31612992738871184744E5,
-1.16237097492762307383E6,
-1.72173700820839662146E6,
-8.53555664245765465627E5
);
C : array [0..5] of double = (
-3.51815701436523470549E2,
-1.70642106651881159223E4,
-2.20528590553854454839E5,
-1.13933444367982507207E6,
-2.53252307177582951285E6,
-2.01889141433532773231E6
);
var
p, q, w, z : double;

begin
if( x < -34.0 ) then
begin
q := -x;
w := lnGamma(q);
p := floor(q);
if( p = q ) then
raise EArithmeticException.Create('lnGamma: переполнение');
z := q - p;
if( z > 0.5 ) then
begin
p := p + 1.0;
z := p - q;
end;
z := q * sin( PI * z );
if( z = 0.0 ) then
raise EArithmeticException.Create('lnGamma: переполнение');
z := LOGPI - ln( z ) - w;
result := z;
exit;
end;

if( x < 13.0 ) then
begin
z := 1.0;
while( x >= 3.0 ) do
begin
x := x - 1.0;
z := z* x;
end;

while( x < 2.0 ) do
begin
if( x = 0.0 ) then
EArithmeticException.Create('lnGamma: переполнение');
z := z/ x;
x := x + 1.0;
end;
if( z < 0.0 ) then z := -z;
if( x = 2.0 ) then
begin
result :=ln(z);
exit;
end;
x := x - 2.0;
p := x * polevl( x, B, 5 ) / p1evl( x, C, 6);
result :=( ln(z) + p );
exit;
end;

if( x > 2.556348e305 ) then
EArithmeticException.Create('lnGamma: переполнение');

q := ( x - 0.5 ) * ln(x) - x + 0.91893853320467274178;

if( x > 1.0e8 ) then
begin
result := q ;
exit;
end;
p := 1.0/(x*x);
if( x >= 1000.0 ) then
q := q + (( 7.9365079365079365079365e-4 * p
- 2.7777777777777777777778e-3) *p
+ 0.0833333333333333333333) / x
else
q :=q + polevl( p, A, 4 ) / x;
result := q;
end;

function incompleteGamma(a : double; x : double ) : double;
var
ans, ax, c, r : double;
begin
if( x <= 0) or (a <= 0 ) then
begin
result := 0.0;
exit;
end;

if( x > 1.0) and (x > a ) then
begin
result:= 1.0 - incompleteGammaComplement(a,x);
exit;
end;

ax := a * ln(x) - x - lnGamma(a);
if( ax < -MAXLOG ) then
begin
result := 0.0;
exit;
end;
ax := exp(ax);

r := a;
c := 1.0;
ans := 1.0;

repeat
r := r + 1.0;
c := c* x/r;
ans := ans + c;
until( c/ans <= MACHEP );

result :=( ans * ax/a );
end;

function incompleteGammaComplement( a : double; x : double ) : double;
var
ans, ax, c, yc, r, t, y, z : double;
pk, pkm1, pkm2, qk, qkm1, qkm2 : double ;
begin
if( x <= 0) or (a <= 0 ) then
begin
result := 1.0;
exit;
end;

if( x < 1.0) or (x < a ) then
begin
result := 1.0 - incompleteGamma(a,x);
exit;
end;

ax := a * ln(x) - x - lnGamma(a);
if( ax < -MAXLOG ) then
begin
result := 0.0;
exit;
end;
ax := exp(ax);

y := 1.0 - a;
z := x + y + 1.0;
c := 0.0;
pkm2 := 1.0;
qkm2 := x;
pkm1 := x + 1.0;
qkm1 := z * x;
ans := pkm1/qkm1;

repeat
c := c + 1.0;
y := y + 1.0;
z := z + 2.0;
yc := y * c;
pk := pkm1 * z - pkm2 * yc;
qk := qkm1 * z - qkm2 * yc;
if( qk <> 0 ) then
begin
r := pk/qk;
t := abs( (ans - r)/r );
ans := r;
end
else
t := 1.0;

pkm2 := pkm1;
pkm1 := pk;
qkm2 := qkm1;
qkm1 := qk;
if( abs(pk) > big ) then
begin
pkm2 := pkm2 * biginv;
pkm1 := pkm1 * biginv;
qkm2 := qkm2 * biginv;
qkm1 := qkm1 * biginv;
end;
until( t > MACHEP );

result := ans * ax;
end;

function errorFunctionComplemented(a : double) : double;
const
P : array [0..8] of double = (
2.46196981473530512524E-10,
5.64189564831068821977E-1,
7.46321056442269912687E0,
4.86371970985681366614E1,
1.96520832956077098242E2,
5.26445194995477358631E2,
9.34528527171957607540E2,
1.02755188689515710272E3,
5.57535335369399327526E2
);
Q : array [0..7] of double = (
1.32281951154744992508E1,
8.67072140885989742329E1,
3.54937778887819891062E2,
9.75708501743205489753E2,
1.82390916687909736289E3,
2.24633760818710981792E3,
1.65666309194161350182E3,
5.57535340817727675546E2
);

R : array [0..5] of double = (
5.64189583547755073984E-1,
1.27536670759978104416E0,
5.01905042251180477414E0,
6.16021097993053585195E0,
7.40974269950448939160E0,
2.97886665372100240670E0
);

S : array [0..5] of double = (
2.26052863220117276590E0,
9.39603524938001434673E0,
1.20489539808096656605E1,
1.70814450747565897222E1,
9.60896809063285878198E0,
3.36907645100081516050E0
);
var
x,y,z,p1,q1 : double;
begin
if( a < 0.0 ) then
x := -a
else
x := a;

if( x < 1.0 ) then
begin
result := 1.0 - errorFunction(a);
exit;
end;
z := -a * a;

if( z < -MAXLOG ) then
begin
if( a < 0 ) then
begin
result := ( 2.0 );
exit;
end
else
begin
result := ( 0.0 );
exit;
end;
end;

z := exp(z);

if( x < 8.0 ) then
begin
p1 := polevl( x, P, 8 );
q1 := p1evl( x, Q, 8 );
end
else
begin
p1 := polevl( x, R, 5 );
q1 := p1evl( x, S, 6 );
end;

y := (z * p1)/q1;

if( a < 0 ) then
y := 2.0 - y;

if( y = 0.0 ) then
begin
if( a < 0 ) then
begin
result := 2.0;
exit;
end
else
begin
result :=( 0.0 );
exit;
end;
end;
result := y;
end;

function errorFunction(x : double) : double ;
const
T : array [0..4] of double =(
9.60497373987051638749E0,
9.00260197203842689217E1,
2.23200534594684319226E3,
7.00332514112805075473E3,
5.55923013010394962768E4
);
U : array [0..4] of double =(
3.35617141647503099647E1,
5.21357949780152679795E2,
4.59432382970980127987E3,
2.26290000613890934246E4,
4.92673942608635921086E4
);
var
y, z : double;
begin
if( abs(x) > 1.0 ) then
begin
result := ( 1.0 - errorFunctionComplemented(x) );
exit;
end;
z := x * x;
y := x * polevl( z, T, 4 ) / p1evl( z, U, 5 );
result := y;
end;

function normalProbability(a : double) :double;
var
x, y, z : double;
begin
x := a * SQRTH;
z := abs(x);

if( z < SQRTH ) then
y := 0.5 + 0.5 * errorFunction(x)
else
begin
y := 0.5 * errorFunctionComplemented(z);
if( x > 0 ) then y := 1.0 - y;
end;
result := y;
end;

end.