Курсовой проект групп 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.