diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Nikita Kartashov + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/testu/src/bbattery.c b/cbits/testu/src/bbattery.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/bbattery.c @@ -0,0 +1,4389 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: bbattery.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "config.h" +#include "bbattery.h" +#include "smultin.h" +#include "sknuth.h" +#include "smarsa.h" +#include "snpair.h" +#include "svaria.h" +#include "sstring.h" +#include "swalk.h" +#include "scomp.h" +#include "sspectral.h" +#include "swrite.h" +#include "sres.h" +#include "unif01.h" +#include "ufile.h" + +#include "gofs.h" +#include "gofw.h" +#include "fdist.h" +#include "fbar.h" +#include "num.h" +#include "chrono.h" + +#include +#include +#include +#include +#include + + + +#define LEN 120 +#define NAMELEN 30 +#define NDIM 200 /* Dimension of extern arrays */ +#define THOUSAND 1000 +#define MILLION (THOUSAND * THOUSAND) +#define BILLION (THOUSAND * MILLION) + +/* The number of tests in each battery */ +#define SMALLCRUSH_NUM 10 +#define CRUSH_NUM 96 +#define BIGCRUSH_NUM 106 +#define RABBIT_NUM 26 +#define ALPHABIT_NUM 9 + + +double bbattery_pVal[1 + NDIM] = { 0 }; +char *bbattery_TestNames[1 + NDIM] = { 0 }; +int bbattery_NTests; + +static char CharTemp[LEN + 1]; + +/* Gives the test number as enumerated in bbattery.tex. Some test applies + more than one test, so the array of p-values does not correspond with + the test number in the doc. */ +static int TestNumber[1 + NDIM] = { 0 }; + + + + +/*-------------------------------- Functions ------------------------------*/ + + +static void GetName (unif01_Gen * gen, char *genName) +{ + char *p; + int len1, len2; + + if (NULL == gen) { + genName[0] = '\0'; + return; + } + + /* Print only the generator name, without the parameters or seeds. */ + /* The parameters start after the first blank; name ends with ':' */ + genName[LEN] = '\0'; + len1 = strcspn (gen->name, ":"); + len1 = util_Min (LEN, len1); + strncpy (genName, gen->name, (size_t) len1); + genName[len1] = '\0'; + /* For Filters or Combined generators */ + p = strstr (&gen->name[1 + len1], "unif01"); + while (p != NULL) { + len1 += 2; + if (len1 >= LEN) + return; + strcat (genName, ", "); + len2 = strcspn (p, " \0"); + len2 = util_Min (LEN - len1, len2); + if (len2 <= 0) + return; + strncat (genName, p, (size_t) len2); + len1 = strlen (genName); + genName[len1] = '\0'; + p += len2; + p = strstr (p, "unif01"); + } +} + + +/*=========================================================================*/ + +static void WritepVal (double p) +/* + * Write a p-value with a nice format. + */ +{ + if (p < gofw_Suspectp) { + gofw_Writep0 (p); + + } else if (p > 1.0 - gofw_Suspectp) { + if (p >= 1.0 - gofw_Epsilonp1) { + printf (" 1 - eps1"); + } else if (p >= 1.0 - 1.0e-4) { + printf (" 1 - "); + num_WriteD (1.0 - p, 7, 2, 2); + /* printf (" 1 - %.2g ", 1.0 - p); */ + } else if (p >= 1.0 - 1.0e-2) + printf (" %.4f ", p); + else + printf (" %.2f", p); + } +} + + +/*=========================================================================*/ + +static void WriteReport ( + char *genName, /* Generator or file name */ + char *batName, /* Battery name */ + int N, /* Max. number of tests */ + double pVal[], /* p-values of the tests */ + chrono_Chrono * Timer, /* Timer */ + lebool Flag, /* = TRUE for a file, FALSE for a gen */ + lebool VersionFlag, /* = TRUE: write the version number */ + double nb /* Number of bits in the random file */ + ) +{ + int j, co; + + printf ("\n========= Summary results of "); + printf ("%s", batName); + printf (" =========\n\n"); + if (VersionFlag) + printf (" Version: %s\n", PACKAGE_STRING); + if (Flag) + printf (" File: "); + else + printf (" Generator: "); + printf ("%s", genName); + if (nb > 0) + printf ("\n Number of bits: %.0f", nb); + co = 0; + /* Some of the tests have not been done: their pVal[j] < 0. */ + for (j = 0; j < N; j++) { + if (pVal[j] >= 0.0) + co++; + } + printf ("\n Number of statistics: %1d\n", co); + printf (" Total CPU time: "); + chrono_Write (Timer, chrono_hms); + + co = 0; + for (j = 0; j < N; j++) { + if (pVal[j] < 0.0) /* That test was not done: pVal = -1 */ + continue; + if ((pVal[j] < gofw_Suspectp) || (pVal[j] > 1.0 - gofw_Suspectp)) { + co++; + break; + } + } + if (co == 0) { + printf ("\n\n All tests were passed\n\n\n\n"); + return; + } + + if (gofw_Suspectp >= 0.01) + printf ("\n The following tests gave p-values outside [%.4g, %.2f]", + gofw_Suspectp, 1.0 - gofw_Suspectp); + else if (gofw_Suspectp >= 0.0001) + printf ("\n The following tests gave p-values outside [%.4g, %.4f]", + gofw_Suspectp, 1.0 - gofw_Suspectp); + else if (gofw_Suspectp >= 0.000001) + printf ("\n The following tests gave p-values outside [%.4g, %.6f]", + gofw_Suspectp, 1.0 - gofw_Suspectp); + else + printf ("\n The following tests gave p-values outside [%.4g, %.14f]", + gofw_Suspectp, 1.0 - gofw_Suspectp); + printf (":\n (eps means a value < %6.1e)", gofw_Epsilonp); + printf (":\n (eps1 means a value < %6.1e)", gofw_Epsilonp1); + printf (":\n\n Test p-value\n"); + printf (" ----------------------------------------------\n"); + + co = 0; + for (j = 0; j < N; j++) { + if (pVal[j] < 0.0) /* That test was not done: pVal = -1 */ + continue; + if ((pVal[j] >= gofw_Suspectp) && (pVal[j] <= 1.0 - gofw_Suspectp)) + continue; /* That test was passed */ + printf (" %2d ", TestNumber[j]); + printf (" %-30s", bbattery_TestNames[j]); + WritepVal (pVal[j]); + printf ("\n"); + co++; + } + + printf (" ----------------------------------------------\n"); + if (co < N - 1) { + printf (" All other tests were passed\n"); + } + printf ("\n\n\n"); +} + + +/*=========================================================================*/ + +static void GetPVal_Walk (long N, swalk_Res * res, int *pj, char *mess, int j2) +/* + * Get the p-values in a swalk_RandomWalk1 test + */ +{ + int j = *pj; + const unsigned int len = 20; + + if (N == 1) { + bbattery_pVal[++j] = res->H[0]->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 H"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->M[0]->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 M"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->J[0]->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 J"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->R[0]->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 R"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->C[0]->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 C"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + } else { + bbattery_pVal[++j] = res->H[0]->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 H"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->M[0]->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 M"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->J[0]->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 J"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->R[0]->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 R"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + + bbattery_pVal[++j] = res->C[0]->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (CharTemp, "RandomWalk1 C"); + strncat (CharTemp, mess, (size_t) len); + strncpy (bbattery_TestNames[j], CharTemp, (size_t) LEN); + } + + *pj = j; +} + + +/*=========================================================================*/ + +static void GetPVal_CPairs (long N, snpair_Res * res, int *pj, char *mess, + int j2) +/* + * Get the p-values in a snpair_ClosePairs test + */ +{ + int j = *pj; + const unsigned int len = 20; + + if (N == 1) { + bbattery_pVal[++j] = res->pVal[snpair_NP]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs NP"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + bbattery_pVal[++j] = res->pVal[snpair_mNP]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs mNP"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + } else { + bbattery_pVal[++j] = res->pVal[snpair_NP]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs NP"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + bbattery_pVal[++j] = res->pVal[snpair_mNP]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs mNP"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + bbattery_pVal[++j] = res->pVal[snpair_mNP1]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs mNP1"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + bbattery_pVal[++j] = res->pVal[snpair_mNP2]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs mNP2"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + bbattery_pVal[++j] = res->pVal[snpair_NJumps]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs NJumps"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + + if (snpair_mNP2S_Flag) { + bbattery_pVal[++j] = res->pVal[snpair_mNP2S]; + TestNumber[j] = j2; + strcpy (CharTemp, "ClosePairs mNP2S"); + strncat (CharTemp, mess, (size_t) len); + strcpy (bbattery_TestNames[j], CharTemp); + } + } + + *pj = j; +} + + +/*=========================================================================*/ + +static void InitBat (void) +/* + * Initializes the battery of tests: sets all p-values to -1. + */ +{ + int j; + static int flag = 0; + for (j = 0; j < NDIM; j++) + bbattery_pVal[j] = -1.0; + if (0 == flag) { + flag++; + for (j = 0; j < NDIM; j++) + bbattery_TestNames[j] = util_Calloc (LEN + 1, sizeof (char)); + } +} + + +/*=========================================================================*/ + +static BatteryResult* SmallCrush (unif01_Gen * gen, char *filename, int Rep[]) +/* + * A small battery of statistical tests for Random Number Generators + * used in simulation. + * Rep[i] gives the number of times that test i will be done. The default + * values are Rep[i] = 1 for all i. + */ +{ + swrite_Basic = 0; + const int r = 0; + int i; + int j = -1; + int j2 = 0; + char genName[LEN + 1] = ""; + chrono_Chrono *Timer; + sres_Poisson *res1; + sres_Chi2 *res2; + sknuth_Res2 *res3; + swalk_Res *res4; + sknuth_Res1 *res5; + sstring_Res *res6; + lebool fileFlag; + + Timer = chrono_Create (); + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting SmallCrush\n" + " Version: %s\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n", + PACKAGE_STRING); + } + + if (NULL == gen) { + gen = ufile_CreateReadText (filename, 10 * MILLION); + fileFlag = TRUE; + } else + fileFlag = FALSE; + + ++j2; + if (fileFlag) + ufile_InitReadText (); + res1 = sres_CreatePoisson (); + for (i = 0; i < Rep[j2]; ++i) { +#ifdef USE_LONGLONG + smarsa_BirthdaySpacings (gen, res1, 1, 5 * MILLION, r, 1073741824, + 2, 1); +#else + smarsa_BirthdaySpacings (gen, res1, 10, MILLION / 2, r, 67108864, 2, 1); +#endif + bbattery_pVal[++j] = res1->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings"); + } + sres_DeletePoisson (res1); + + if (fileFlag) + ufile_InitReadText (); + ++j2; + res3 = sknuth_CreateRes2 (); + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Collision (gen, res3, 1, 5 * MILLION, 0, 65536, 2); + bbattery_pVal[++j] = res3->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Collision"); + } + sknuth_DeleteRes2 (res3); + + if (fileFlag) + ufile_InitReadText (); + ++j2; + res2 = sres_CreateChi2 (); + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res2, 1, MILLION / 5, 22, 0.0, .00390625); + bbattery_pVal[++j] = res2->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap"); + } + + ++j2; + if (fileFlag) + ufile_InitReadText (); + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res2, 1, 2 * MILLION / 5, 24, 64, 64); + bbattery_pVal[++j] = res2->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker"); + } + + ++j2; + if (fileFlag) + ufile_InitReadText (); + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res2, 1, MILLION / 2, 26, 16); + bbattery_pVal[++j] = res2->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector"); + } + + if (fileFlag) + ufile_InitReadText (); + ++j2; + res5 = sknuth_CreateRes1 (); + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res5, 1, 2 * MILLION, 0, MILLION / 10, 6); + bbattery_pVal[++j] = res5->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft"); + bbattery_pVal[++j] = res5->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD"); + } + sknuth_DeleteRes1 (res5); + + ++j2; + if (fileFlag) + ufile_InitReadText (); + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res2, 1, MILLION / 5, 27, 256, 0.0, 0.125); + bbattery_pVal[++j] = res2->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib"); + } + + ++j2; + if (fileFlag) + ufile_InitReadText (); + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res2, 1, 20 * THOUSAND, 20, 10, 60, 60); + bbattery_pVal[++j] = res2->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank"); + } + sres_DeleteChi2 (res2); + + if (fileFlag) + ufile_InitReadText (); + ++j2; + res6 = sstring_CreateRes (); + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res6, 1, MILLION/2, 20, 10, 300, 0); + bbattery_pVal[++j] = res6->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep"); + } + sstring_DeleteRes (res6); + + if (fileFlag) + ufile_InitReadText (); + ++j2; + util_Assert (j2 <= SMALLCRUSH_NUM, "SmallCrush: j2 > SMALLCRUSH_NUM"); + res4 = swalk_CreateRes (); + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res4, 1, MILLION, r, 30, 150, 150); + GetPVal_Walk (1, res4, &j, "", j2); + } + swalk_DeleteRes (res4); + + bbattery_NTests = ++j; + chrono_Delete (Timer); + return wrap(bbattery_pVal, bbattery_NTests); +} + + +/*=========================================================================*/ + +BatteryResult* bbattery_SmallCrush (unif01_Gen * gen) +{ + int i; + int Rep[1 + NDIM] = {0}; + for (i = 1; i <= SMALLCRUSH_NUM; ++i) + Rep[i] = 1; + return SmallCrush (gen, NULL, Rep); +} + + +/*=========================================================================*/ + +void bbattery_SmallCrushFile (char *filename) +{ + int i; + int Rep[1 + NDIM] = {0}; + for (i = 1; i <= SMALLCRUSH_NUM; ++i) + Rep[i] = 1; + SmallCrush (NULL, filename, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RepeatSmallCrush (unif01_Gen * gen, int Rep[]) +{ + SmallCrush (gen, NULL, Rep); +} + + +/*=========================================================================*/ + +static BatteryResult* Crush (unif01_Gen * gen, int Rep[]) +/* + * A battery of stringent statistical tests for Random Number Generators + * used in simulation. + * Rep[i] gives the number of times that test i will be done. The default + * values are Rep[i] = 1 for all i. + */ +{ + swrite_Basic = 0; + const int s = 30; + const int r = 0; + int i; + chrono_Chrono *Timer; + char genName[LEN + 1] = ""; + int j = -1; + int j2 = 0; + + Timer = chrono_Create (); + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting Crush\n" + " Version: %s\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n", + PACKAGE_STRING); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_SerialOver (gen, res, 1, 500 * MILLION, 0, 4096, 2); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SerialOver, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_SerialOver (gen, res, 1, 300 * MILLION, 0, 64, 4); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SerialOver, t = 4"); + } + sres_DeleteBasic (res); + } + { + smarsa_Res *res; + res = smarsa_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 0, 1024 * 1024, 2); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 10, 1024 * 1024, 2); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 0, 1024, 4); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 20, 1024, 4); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 0, 32, 8); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 25, 32, 8); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 0, 4, 20); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 20"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, res, 10, 10 * MILLION, 28, 4, 20); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 20"); + } + smarsa_DeleteRes (res); + } + { + sres_Poisson *res; + res = sres_CreatePoisson (); + +#ifdef USE_LONGLONG + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + long d; +#if LONG_MAX <= 2147483647L + d = 1073741824L; + smarsa_BirthdaySpacings (gen, res, 10, 10 * MILLION, 0, d, 2, 1); +#else + d = 2*1073741824L; + smarsa_BirthdaySpacings (gen, res, 5, 20 * MILLION, 0, d, 2, 1); +#endif + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 5, 20 * MILLION, 0, 2097152, 3, + 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 3"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 5, 20 * MILLION, 0, 65536, 4, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 3, 20 * MILLION, 0, 512, 7, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 3, 20 * MILLION, 7, 512, 7, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 3, 20 * MILLION, 14, 256, 8, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 3, 20 * MILLION, 22, 256, 8, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 8"); + } + +#else + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 200, 4 * MILLION / 10, 0, + 67108864, 2, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 100, 4 * MILLION / 10, 0, 131072, + 3, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 3"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 200, 4 * MILLION / 10, 0, + 1024 * 8, 4, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 100, 4 * MILLION / 10, 0, 16, 13, + 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 100, 4 * MILLION / 10, 10, 16, + 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 100, 4 * MILLION / 10, 20, 16, + 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 100, 4 * MILLION / 10, 26, 16, + 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } +#endif + + sres_DeletePoisson (res); + } + { + lebool flag = snpair_mNP2S_Flag; + snpair_Res *res; + res = snpair_CreateRes (); + + snpair_mNP2S_Flag = FALSE; + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 10, 2 * MILLION, 0, 2, 0, 30); + GetPVal_CPairs (10, res, &j, ", t = 2", j2); + } + + snpair_mNP2S_Flag = TRUE; + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 10, 2 * MILLION, 0, 3, 0, 30); + GetPVal_CPairs (10, res, &j, ", t = 3", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 5, 2 * MILLION, 0, 7, 0, 30); + GetPVal_CPairs (10, res, &j, ", t = 7", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairsBitMatch (gen, res, 4, 4 * MILLION, 0, 2); + bbattery_pVal[++j] = res->pVal[snpair_BM]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "ClosePairsBitMatch, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairsBitMatch (gen, res, 2, 4 * MILLION, 0, 4); + bbattery_pVal[++j] = res->pVal[snpair_BM]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "ClosePairsBitMatch, t = 4"); + } + snpair_DeleteRes (res); + snpair_mNP2S_Flag = flag; + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 40 * MILLION, 0, 16, 16); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, d = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 40 * MILLION, 26, 16, 16); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, d = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 10 * MILLION, 0, 64, 64); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, d = 64"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 10 * MILLION, 24, 64, 64); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, d = 64"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 40 * MILLION, 0, 4); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, d = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 40 * MILLION, 28, 4); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, d = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 10 * MILLION, 0, 16); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, d = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 10 * MILLION, 26, 16); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, d = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 100 * MILLION, 0, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 100 * MILLION, 27, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 27"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 5 * MILLION, 0, 0.0, 1.0/256.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 5 * MILLION, 22, 0.0, 1.0/256.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 22"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Run (gen, res, 1, 500 * MILLION, 0, TRUE); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of U01, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Run (gen, res, 1, 500 * MILLION, 15, FALSE); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of U01, r = 15"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, 50 * MILLION, 0, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, 50 * MILLION, 15, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, r = 15"); + } + sres_DeleteChi2 (res); + } + { + sknuth_Res2 *res; + res = sknuth_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CollisionPermut (gen, res, 5, 10 * MILLION, 0, 13); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionPermut, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CollisionPermut (gen, res, 5, 10 * MILLION, 15, 13); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionPermut, r = 15"); + } + sknuth_DeleteRes2 (res); + } + { + sknuth_Res1 *res; + res = sknuth_CreateRes1 (); + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 10, 10 * MILLION, 0, MILLION / 10, 5); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 5"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 5"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 5, 10 * MILLION, 0, MILLION / 10, 10); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 10"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 10"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 1, 10 * MILLION, 0, MILLION / 10, 20); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 20"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 20"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 1, 10 * MILLION, 0, MILLION / 10, 30); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 30"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 30"); + } + sknuth_DeleteRes1 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleProd (gen, res, 1, 10 * MILLION, 0, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleProd, t = 10"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleProd (gen, res, 1, 10 * MILLION, 0, 30); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleProd, t = 30"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleMean (gen, res, 10*MILLION, 20, 0); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleMean"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleCorr (gen, res, 1, 500 * MILLION, 0, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleCorr"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_AppearanceSpacings (gen, res, 1, 10 * MILLION, 400 * MILLION, + r, 30, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AppearanceSpacings, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_AppearanceSpacings (gen, res, 1, 10 * MILLION, 100 * MILLION, + 20, 10, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AppearanceSpacings, r = 20"); + } + sres_DeleteBasic (res); + } + { + smarsa_Res2 *res2; + sres_Chi2 *res; + res = sres_CreateChi2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 2 * MILLION, 0, 256, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 2 * MILLION, 8, 256, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 2 * MILLION, 16, 256, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 2 * MILLION, 24, 256, 0.0, 0.125); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 24"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SumCollector (gen, res, 1, 20 * MILLION, 0, 10.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SumCollector"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, MILLION, r, s, 2 * s, 2 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 60 x 60"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, MILLION, 20, 10, 2 * s, 2 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 60 x 60"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 50 * THOUSAND, r, s, 10 * s, 10 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 300 x 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 50 * THOUSAND, 20, 10, 10 * s, + 10 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 300 x 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 2 * THOUSAND, r, s, 40 * s, 40 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 1200 x 1200"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 2 * THOUSAND, 20, 10, 40 * s, 40 * s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 1200 x 1200"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_Savir2 (gen, res, 1, 20 * MILLION, 0, 1024*1024, 30); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Savir2"); + } + sres_DeleteChi2 (res); + + res2 = smarsa_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_GCD (gen, res2, 1, 100 * MILLION, 0, 30); + bbattery_pVal[++j] = res2->GCD->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "GCD, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_GCD (gen, res2, 1, 40 * MILLION, 10, 20); + bbattery_pVal[++j] = res2->GCD->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "GCD, r = 10"); + } + smarsa_DeleteRes2 (res2); + } + { + swalk_Res *res; + res = swalk_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 50 * MILLION, r, s, 90, 90); + GetPVal_Walk (1, res, &j, " (L = 90)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 10 * MILLION, 20, 10, 90, 90); + GetPVal_Walk (1, res, &j, " (L = 90)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 5 * MILLION, r, s, 1000, 1000); + GetPVal_Walk (1, res, &j, " (L = 1000)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, MILLION, 20, 10, 1000, 1000); + GetPVal_Walk (1, res, &j, " (L = 1000)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, MILLION / 2, r, s, 10000, 10000); + GetPVal_Walk (1, res, &j, " (L = 10000)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, MILLION / 10, 20, 10, 10000, 10000); + GetPVal_Walk (1, res, &j, " (L = 10000)", j2); + } + swalk_DeleteRes (res); + } + { + scomp_Res *res; + res = scomp_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LinearComp (gen, res, 1, 120 * THOUSAND, r, 1); + bbattery_pVal[++j] = res->JumpNum->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 0"); + bbattery_pVal[++j] = res->JumpSize->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LinearComp (gen, res, 1, 120 * THOUSAND, 29, 1); + bbattery_pVal[++j] = res->JumpNum->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 29"); + bbattery_pVal[++j] = res->JumpSize->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 29"); + } + scomp_DeleteRes (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LempelZiv (gen, res, 10, 25, r, s); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LempelZiv"); + } + sres_DeleteBasic (res); + } + { + sspectral_Res *res; + res = sspectral_CreateRes (); + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier3 (gen, res, 50 * THOUSAND, 14, r, s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier3, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier3 (gen, res, 50 * THOUSAND, 14, 20, 10); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier3, r = 20"); + } + sspectral_DeleteRes (res); + } + { + sstring_Res2 *res; + res = sstring_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_LongestHeadRun (gen, res, 1, 1000, r, s, 20 + 10 * MILLION); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 0"); + bbattery_pVal[++j] = res->Disc->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_LongestHeadRun (gen, res, 1, 300, 20, 10, 20 + 10 * MILLION); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 20"); + bbattery_pVal[++j] = res->Disc->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 20"); + } + sstring_DeleteRes2 (res); + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_PeriodsInStrings (gen, res, 1, 300 * MILLION, r, s); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "PeriodsInStrings, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_PeriodsInStrings (gen, res, 1, 300 * MILLION, 15, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "PeriodsInStrings, r = 15"); + } + sres_DeleteChi2 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingWeight2 (gen, res, 100, 100 * MILLION, r, s, MILLION); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingWeight2, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingWeight2 (gen, res, 30, 100 * MILLION, 20, 10, MILLION); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingWeight2, r = 20"); + } + sres_DeleteBasic (res); + } + { + sstring_Res *res; + res = sstring_CreateRes (); + /* sstring_HammingCorr will probably be removed: less sensitive than + svaria_HammingIndep */ + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, 500 * MILLION, r, s, s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 30"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, 50 * MILLION, r, s, 10 * s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, 10 * MILLION, r, s, 40 * s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 1200"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 300 * MILLION, r, s, s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 30"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 100 * MILLION, 20, 10, s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 30"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 30 * MILLION, r, s, 10 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 10 * MILLION, 20, 10, 10 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 10 * MILLION, r, s, 40 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 1200"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, MILLION, 20, 10, 40 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 1200"); + } + sstring_DeleteRes (res); + } + { + sstring_Res3 *res; + res = sstring_CreateRes3 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_Run (gen, res, 1, 1 * BILLION, r, s); + bbattery_pVal[++j] = res->NRuns->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 0"); + bbattery_pVal[++j] = res->NBits->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_Run (gen, res, 1, 1 * BILLION, 20, 10); + bbattery_pVal[++j] = res->NRuns->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 20"); + bbattery_pVal[++j] = res->NBits->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 20"); + } + sstring_DeleteRes3 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 30 + BILLION, r, s, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d = 1"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 5, 1 + BILLION, 20, 10, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d = 1"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 31 + BILLION, r, s, s); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d = 30"); + } + + ++j2; + /* util_Assert (j2 <= CRUSH_NUM, "Crush: j2 > CRUSH_NUM"); */ + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 5, 11 + BILLION, 20, 10, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d = 10"); + } + sres_DeleteBasic (res); + } + + bbattery_NTests = ++j; + GetName (gen, genName); + chrono_Delete (Timer); + return wrap(bbattery_pVal, bbattery_NTests); +} + + +/*=========================================================================*/ + +BatteryResult* bbattery_Crush (unif01_Gen * gen) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= CRUSH_NUM; ++i) + Rep[i] = 1; + return Crush (gen, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RepeatCrush (unif01_Gen * gen, int Rep[]) +{ + Crush (gen, Rep); +} + + +/*=========================================================================*/ + +static BatteryResult* BigCrush (unif01_Gen * gen, int Rep[]) +/* + * A battery of very stringent statistical tests for Random Number Generators + * used in simulation. + * Rep[i] gives the number of times that test i will be done. The default + * values are Rep[i] = 1 for all i. + */ +{ + swrite_Basic = 0; + const int s = 30; + const int r = 0; + int i; + chrono_Chrono *Timer; + char genName[LEN + 1] = ""; + int j = -1; + int j2 = 0; + + Timer = chrono_Create (); + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting BigCrush\n" + " Version: %s\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n", + PACKAGE_STRING); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_SerialOver (gen, res, 1, BILLION, 0, 256, 3); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SerialOver, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_SerialOver (gen, res, 1, BILLION, 22, 256, 3); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SerialOver, r = 22"); + } + sres_DeleteBasic (res); + } + { + smarsa_Res *resm; + resm = smarsa_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 0, 1024*1024*2, 2); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 9, 1024*1024*2, 2); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 0, 1024*16, 3); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 3"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 16, 1024*16, 3); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 3"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 0, 64, 7); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 24, 64, 7); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 0, 8, 14); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 14"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 27, 8, 14); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 14"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 0, 4, 21); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 21"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_CollisionOver (gen, resm, 30, 20 * MILLION, 28, 4, 21); + bbattery_pVal[++j] = resm->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionOver, t = 21"); + } + smarsa_DeleteRes (resm); + } + { + sres_Poisson *res; + res = sres_CreatePoisson (); +#ifdef USE_LONGLONG + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + long d; +#if LONG_MAX <= 2147483647L + d = 1073741824L; + smarsa_BirthdaySpacings (gen, res, 250, 4 * MILLION, 0, d, 2, 1); +#else + d = 2147483648L; + smarsa_BirthdaySpacings (gen, res, 100, 10 * MILLION, 0, d, 2, 1); +#endif + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 20 * MILLION, 0, 2097152, 3, + 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 3"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 30 * MILLION, 14, 65536, 4, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 20 * MILLION, 0, 512, 7, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 20 * MILLION, 7, 512, 7, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 30 * MILLION, 14, 256, 8, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 30 * MILLION, 22, 256, 8, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 30 * MILLION, 0, 16, 16, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 20, 30 * MILLION, 26, 16, 16, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 16"); + } + +#else + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 0, + 67108864, 2, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 0, + 1024 * 8, 4, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 16, + 1024 * 8, 4, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 4"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 0, 16, + 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 5, 16, + 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 10, + 16, 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 15, + 16, 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 20, + 16, 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_BirthdaySpacings (gen, res, 10 * THOUSAND, MILLION / 10, 26, + 16, 13, 1); + bbattery_pVal[++j] = res->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings, t = 13"); + } +#endif + sres_DeletePoisson (res); + } + { + lebool flag = snpair_mNP2S_Flag; + snpair_Res *res; + res = snpair_CreateRes (); + + snpair_mNP2S_Flag = TRUE; + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 30, 6 * MILLION, 0, 3, 0, 30); + GetPVal_CPairs (40, res, &j, ", t = 3", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 20, 4 * MILLION, 0, 5, 0, 30); + GetPVal_CPairs (40, res, &j, ", t = 5", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 10, 3 * MILLION, 0, 9, 0, 30); + GetPVal_CPairs (20, res, &j, ", t = 9", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairs (gen, res, 5, 2*MILLION, 0, 16, 0, 30); + GetPVal_CPairs (10, res, &j, ", t = 16", j2); + } + snpair_DeleteRes (res); + snpair_mNP2S_Flag =flag; + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 400 * MILLION, 0, 8, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 400 * MILLION, 27, 8, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, r = 27"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 100 * MILLION, 0, 32, 32); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_SimpPoker (gen, res, 1, 100 * MILLION, 25, 32, 32); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SimpPoker, r = 25"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 200 * MILLION, 0, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 200 * MILLION, 10, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, r = 10"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 200 * MILLION, 20, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, r = 20"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CouponCollector (gen, res, 1, 200 * MILLION, 27, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CouponCollector, r = 27"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, BILLION/2, 0, 0.0, 1.0/16.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 300*MILLION, 25, 0.0, 1.0/32.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 25"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, BILLION/10, 0, 0.0, 1.0/128.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Gap (gen, res, 1, 10*MILLION, 20, 0.0, 1.0/1024.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Gap, r = 20"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Run (gen, res, 5, BILLION, 0, FALSE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Run (gen, res, 10, BILLION, 15, TRUE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run, r = 15"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, BILLION, 5, 3); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, t = 3" ); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, BILLION, 5, 5); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, t = 5"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, BILLION/2, 5, 7); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, t = 7"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_Permutation (gen, res, 1, BILLION/2, 10, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Permutation, t = 10"); + } + sres_DeleteChi2 (res); + } + { + sknuth_Res2 *res; + res = sknuth_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CollisionPermut (gen, res, 20, 20 * MILLION, 0, 14); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionPermut, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_CollisionPermut (gen, res, 20, 20 * MILLION, 10, 14); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "CollisionPermut, r = 10"); + } + sknuth_DeleteRes2 (res); + } + { + sknuth_Res1 *res; + res = sknuth_CreateRes1 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 40, 10 * MILLION, 0, MILLION / 10, 8); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 8"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 30, 10 * MILLION, 0, MILLION / 10, 16); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 16"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 20, 10 * MILLION, 0, MILLION / 10, 24); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 24"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 24"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sknuth_MaxOft (gen, res, 20, 10 * MILLION, 0, MILLION / 10, 32); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft, t = 32"); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MaxOft AD, t = 32"); + } + sknuth_DeleteRes1 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleProd (gen, res, 40, 10 * MILLION, 0, 8); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleProd, t = 8"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleProd (gen, res, 20, 10*MILLION, 0, 16); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleProd, t = 16"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleProd (gen, res, 20, 10*MILLION, 0, 24); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleProd, t = 24"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleMean (gen, res, 20*MILLION, 30, 0); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleMean, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleMean (gen, res, 20*MILLION, 30, 10); + bbattery_pVal[++j] = res->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleMean, r = 10"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleCorr (gen, res, 1, 2*BILLION, 0, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleCorr, k = 1"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SampleCorr (gen, res, 1, 2*BILLION, 0, 2); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SampleCorr, k = 2"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_AppearanceSpacings (gen, res, 1, 10 * MILLION, BILLION, + r, 3, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AppearanceSpacings, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_AppearanceSpacings (gen, res, 1, 10 * MILLION, BILLION, + 27, 3, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AppearanceSpacings, r = 27"); + } + sres_DeleteBasic (res); + } + { + smarsa_Res2 *res2; + sres_Chi2 *res; + res = sres_CreateChi2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 0, 256, 0.0, 0.25); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 20, 256, 0.0, 0.25); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 20"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 28, 256, 0.0, 0.25); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 28"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 0, 256, 0.0, 0.0625); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 10, 256, 0.0, 0.0625); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 10"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_WeightDistrib (gen, res, 1, 20 * MILLION, 26, 256, 0.0, 0.0625); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "WeightDistrib, r = 26"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + svaria_SumCollector (gen, res, 1, 500 * MILLION, 0, 10.0); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "SumCollector"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 10, MILLION, r, 5, 30, 30); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=30, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 10, MILLION, 25, 5, 30, 30); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=30, r=26"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 5 * THOUSAND, r, 4, 1000, 1000); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=1000, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 5 * THOUSAND, 26, 4, 1000, 1000); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=1000, r=26"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 80, 15, 15, 5000, 5000); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=5000"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_MatrixRank (gen, res, 1, 80, 0, 30, 5000, 5000); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, L=5000"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_Savir2 (gen, res, 10, 10 * MILLION, 10, 1024*1024, 30); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Savir2"); + } + sres_DeleteChi2 (res); + + res2 = smarsa_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smarsa_GCD (gen, res2, 10, 50 * MILLION, 0, 30); + bbattery_pVal[++j] = res2->GCD->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "GCD"); + } + smarsa_DeleteRes2 (res2); + } + { + swalk_Res *res; + res = swalk_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 100 * MILLION, r, 5, 50, 50); + GetPVal_Walk (1, res, &j, " (L=50, r=0)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 100 * MILLION, 25, 5, 50, 50); + GetPVal_Walk (1, res, &j, " (L=50, r=25)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 10 * MILLION, r, 10, 1000, 1000); + GetPVal_Walk (1, res, &j, " (L=1000, r=0)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 10 * MILLION, 20, 10, 1000, 1000); + GetPVal_Walk (1, res, &j, " (L=1000, r=20)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 1 * MILLION, r, 15, 10000, 10000); + GetPVal_Walk (1, res, &j, " (L=10000, r=0)", j2); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, 1, 1 * MILLION, 15, 15, 10000, 10000); + GetPVal_Walk (1, res, &j, " (L=10000, r=15)", j2); + } + swalk_DeleteRes (res); + } + { + scomp_Res *res; + res = scomp_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LinearComp (gen, res, 1, 400 * THOUSAND + 20, r, 1); + bbattery_pVal[++j] = res->JumpNum->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 0"); + bbattery_pVal[++j] = res->JumpSize->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LinearComp (gen, res, 1, 400 * THOUSAND + 20, 29, 1); + bbattery_pVal[++j] = res->JumpNum->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 29"); + bbattery_pVal[++j] = res->JumpSize->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp, r = 0"); + } + scomp_DeleteRes (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LempelZiv (gen, res, 10, 27, r, s); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LempelZiv, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LempelZiv (gen, res, 10, 27, 15, 15); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LempelZiv, r = 15"); + } + sres_DeleteBasic (res); + } + { + sspectral_Res *res; + res = sspectral_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier3 (gen, res, 100 * THOUSAND, 14, r, 3); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier3, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier3 (gen, res, 100 * THOUSAND, 14, 27, 3); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier3, r = 27"); + } + sspectral_DeleteRes (res); + } + { + sstring_Res2 *res; + res = sstring_CreateRes2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_LongestHeadRun (gen, res, 1, 1000, r, 3, 20 + 10 * MILLION); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 0"); + bbattery_pVal[++j] = res->Disc->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_LongestHeadRun (gen, res, 1, 1000, 27, 3, 20 + 10 * MILLION); + bbattery_pVal[++j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 27"); + bbattery_pVal[++j] = res->Disc->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun, r = 27"); + } + sstring_DeleteRes2 (res); + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_PeriodsInStrings (gen, res, 10, BILLION/2, r, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "PeriodsInStrings, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_PeriodsInStrings (gen, res, 10, BILLION/2, 20, 10); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "PeriodsInStrings, r = 20"); + } + sres_DeleteChi2 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingWeight2 (gen, res, 10, BILLION, r, 3, MILLION); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingWeight2, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingWeight2 (gen, res, 10, BILLION, 27, 3, MILLION); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingWeight2, r = 27"); + } + sres_DeleteBasic (res); + } + { + sstring_Res *res; + res = sstring_CreateRes (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, BILLION, 10, 10, s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 30"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, 100 * MILLION, 10, 10, 10 * s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 300"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, 1, 100 * MILLION, 10, 10, 40 * s); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 1200"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 10, 30 * MILLION, r, 3, s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=30, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 10, 30 * MILLION, 27, 3, s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=30, r=27"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 30 * MILLION, r, 4, 10 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=300, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 30 * MILLION, 26, 4, 10 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=300, r=26"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 10 * MILLION, r, 5, 40 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=1200, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, 1, 10 * MILLION, 25, 5, 40 * s, 0); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L=1200, r=25"); + } + sstring_DeleteRes (res); + } + { + sstring_Res3 *res; + res = sstring_CreateRes3 (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_Run (gen, res, 1, 2*BILLION, r, 3); + bbattery_pVal[++j] = res->NRuns->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 0"); + bbattery_pVal[++j] = res->NBits->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_Run (gen, res, 1, 2*BILLION, 27, 3); + bbattery_pVal[++j] = res->NRuns->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 27"); + bbattery_pVal[++j] = res->NBits->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits, r = 27"); + } + sstring_DeleteRes3 (res); + } + { + sres_Basic *res; + res = sres_CreateBasic (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 30 + BILLION, r, 3, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d=1, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 30 + BILLION, r, 3, 3); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d=3, r=0"); + } + + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 30 + BILLION, 27, 3, 1); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d=1, r=27"); + } + + ++j2; + util_Assert (j2 <= BIGCRUSH_NUM, "BigCrush: j2 > BIGCRUSH_NUM"); + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, 10, 30 + BILLION, 27, 3, 3); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor, d=3, r=27"); + } + sres_DeleteBasic (res); + } + + bbattery_NTests = ++j; + GetName (gen, genName); + chrono_Delete (Timer); + return wrap(bbattery_pVal, bbattery_NTests); +} + + +/*=========================================================================*/ + +BatteryResult* bbattery_BigCrush (unif01_Gen * gen) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= BIGCRUSH_NUM; ++i) + Rep[i] = 1; + return BigCrush (gen, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RepeatBigCrush (unif01_Gen * gen, int Rep[]) +{ + BigCrush (gen, Rep); +} + + +/*=========================================================================*/ +#if 0 +static void WriteTime (time_t t0, time_t t1) +{ + int y1; + double y = 0; + + y = difftime (t1, t0); + /* printf (" Total time: %.2f sec\n\n", y); */ + printf (" Total time: "); + y1 = y / 3600; + printf ("%02d:", y1); + y -= y1 * 3600.0; + y1 = y / 60; + printf ("%02d:", y1); + y -= y1 * 60.0; + printf ("%.2f\n\n", y); +} +#endif + +/*-------------------------------------------------------------------------*/ + +static void Alphabit (unif01_Gen * gen, char *fname, double nb, int r, int s, + lebool blocFlag, int w, int Rep[]) +{ + chrono_Chrono *Timer; + /* time_t t0, t1; */ + int NbDelta = 1; + double ValDelta[] = { 1 }; + long N = 1; + long n, L; + int j = 0; + int j2 = 0; + int i; + lebool fileFlag; + long bufsiz; + char genName[LEN + 1] = ""; + double z; + unif01_Gen *gen0; + + Timer = chrono_Create (); + /* t0 = time (NULL); */ + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting Alphabit: nb = %.0f\n" + " Version: %s\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n", + nb, PACKAGE_STRING); + } + util_Assert (nb > 0, "Alphabit: nb <= 0"); + /* Bits will be read as 32-bit unsigned integers */ + nb -= fmod (nb, 32.0); + bufsiz = nb / 32.0; + + if (blocFlag) { + gen0 = ufile_CreateReadBin (fname, bufsiz); + gen = unif01_CreateBitBlockGen (gen0, r, s, w); + nb -= fmod (nb, 1024.0 / w); + fileFlag = TRUE; + } else if (NULL == gen) { + gen = ufile_CreateReadBin (fname, bufsiz); + fileFlag = TRUE; + } else { + fileFlag = FALSE; + } + + { + smultin_Param *par = NULL; + smultin_Res *res; + par = smultin_CreateParam (NbDelta, ValDelta, smultin_GenerCellSerial, + 3); + res = smultin_CreateRes (par); + if (fileFlag) + ufile_InitReadBin (); + + if (nb > BILLION) + N = 1 + nb / BILLION; + else + N = 1; + n = nb / N; + /* Set n as a multiple of s = 32 */ + n -= n % 32; + j = -1; + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBitsOver (gen, par, res, N, n, r, s, 2, FALSE); + strcpy (bbattery_TestNames[++j], "MultinomialBitsOver, L = 2"); + if (N == 1) + bbattery_pVal[j] = res->pVal2[0][gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[0][gofw_AD]; + TestNumber[j] = j2; + } + + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBitsOver (gen, par, res, N, n, r, s, 4, FALSE); + strcpy (bbattery_TestNames[++j], "MultinomialBitsOver, L = 4"); + if (N == 1) + bbattery_pVal[j] = res->pVal2[0][gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[0][gofw_AD]; + TestNumber[j] = j2; + } + + ++j2; + if (n > 250) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBitsOver (gen, par, res, N, n, r, s, 8, FALSE); + strcpy (bbattery_TestNames[++j], "MultinomialBitsOver, L = 8"); + if (N == 1) + bbattery_pVal[j] = res->pVal2[0][gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[0][gofw_AD]; + TestNumber[j] = j2; + } + } + + ++j2; + if (n > 65000) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBitsOver (gen, par, res, N, n, r, s, 16, FALSE); + strcpy (bbattery_TestNames[++j], "MultinomialBitsOver, L = 16"); + if (N == 1) + bbattery_pVal[j] = res->pVal2[0][gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[0][gofw_AD]; + TestNumber[j] = j2; + } + } + + smultin_DeleteRes (res); + smultin_DeleteParam (par); + } + + { + sstring_Res *res; + res = sstring_CreateRes (); + + if (fileFlag) + ufile_InitReadBin (); + z = nb / s; + N = 1 + z / BILLION; + n = z / N; + ++j2; + if (n >= 20) { + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, N, n, r, s, 16, 0); + j++; + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 16"); + TestNumber[j] = j2; + } + } + + if (fileFlag) + ufile_InitReadBin (); + n /= 2; + ++j2; + if (n >= 20) { + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingIndep (gen, res, N, n, r, s, 32, 0); + j++; + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 32"); + TestNumber[j] = j2; + } + } + + if (fileFlag) + ufile_InitReadBin (); + n *= 2; + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, N, n, r, s, 32); + j++; + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 32"); + } + } + + { + swalk_Res *res; + res = swalk_CreateRes (); + + if (fileFlag) + ufile_InitReadBin (); + L = 64; + z = nb / L; + N = 1 + z / BILLION; + n = z / N; + j2++; + if (n >= 30) { + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, N, n, r, s, L, L); + GetPVal_Walk (N, res, &j, " (L = 64)", j2); + } + } + + if (fileFlag) + ufile_InitReadBin (); + L = 320; + z = nb / L; + N = 1 + z / BILLION; + n = z / N; + j2++; + util_Assert (j2 <= ALPHABIT_NUM, "Alphabit: j2 > ALPHABIT_NUM"); + if (n >= 30) { + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, N, n, r, s, L, L); + GetPVal_Walk (N, res, &j, " (L = 320)", j2); + } + } + swalk_DeleteRes (res); + } + + bbattery_NTests = ++j; + if (blocFlag) { + unif01_DeleteBitBlockGen (gen); + gen = gen0; + } + if (fileFlag) { + WriteReport (fname, "Alphabit", bbattery_NTests, + bbattery_pVal, Timer, TRUE, TRUE, nb); + ufile_DeleteReadBin (gen); + } else { + GetName (gen, genName); + WriteReport (genName, "Alphabit", bbattery_NTests, bbattery_pVal, + Timer, FALSE, TRUE, nb); + } + + chrono_Delete (Timer); + /* t1 = time (NULL); + WriteTime (t0, t1); */ +} + + +/*=========================================================================*/ + +void bbattery_Alphabit (unif01_Gen * gen, double nb, int r, int s) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= ALPHABIT_NUM; ++i) + Rep[i] = 1; + Alphabit (gen, NULL, nb, r, s, FALSE, 0, Rep); +} + + +/*=========================================================================*/ + +void bbattery_AlphabitFile (char *filename, double nb) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= ALPHABIT_NUM; ++i) + Rep[i] = 1; + Alphabit (NULL, filename, nb, 0, 32, FALSE, 0, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RepeatAlphabit (unif01_Gen * gen, double nb, int r, int s, + int Rep[]) +{ + Alphabit (gen, NULL, nb, r, s, FALSE, 0, Rep); +} + + +/*=========================================================================*/ + +void bbattery_BlockAlphabit (unif01_Gen * gen, double n, int r, int s) +{ + unif01_Gen *gen2; + int L = 1; + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= ALPHABIT_NUM; ++i) + Rep[i] = 1; + while ((L <= 32) && (L <= s)) { + gen2 = unif01_CreateBitBlockGen (gen, r, s, L); + Alphabit (gen2, NULL, n, r, s, FALSE, 0, Rep); + unif01_DeleteBitBlockGen (gen2); + L *= 2; + } +} + + +/*=========================================================================*/ + +void bbattery_RepeatBlockAlphabit (unif01_Gen * gen, double nb, int r, int s, + int Rep[], int L) +{ + if ((L <= 32) && (L <= s)) { + unif01_Gen *gen2; + gen2 = unif01_CreateBitBlockGen (gen, r, s, L); + Alphabit (gen2, NULL, nb, r, s, FALSE, 0, Rep); + unif01_DeleteBitBlockGen (gen2); + } +} + + +/*=========================================================================*/ + +void bbattery_BlockAlphabitFile (char *filename, double nb) +{ + int w = 1; + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= ALPHABIT_NUM; ++i) + Rep[i] = 1; + while (w <= 32) { + Alphabit (NULL, filename, nb, 0, 32, TRUE, w, Rep); + w *= 2; + } +} + + +/*=========================================================================*/ + +static void DoMultinom (lebool fileFlag, /* */ + unif01_Gen * gen, /* */ + double nb, /* Number of bits */ + int *pj, /* j */ + int j2, /* Test number in the battery */ + int Rep[] /* Number of replications */ + ) +/* + * Do the smultin_MultinomialBits in Rabbit + */ +{ + const long NLIM = 10000000; + long n, N; + int L, t; + double x; + int i; + int j = *pj; + smultin_Res *res; + smultin_Param *par = NULL; + double ValDelta[] = { -1 }; + + util_Assert (nb > 0.0, "MultinomialBits: nb <= 0"); + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, -3); + res = smultin_CreateRes (par); + if (fileFlag) + ufile_InitReadBin (); + +#ifdef USE_LONGLONG + /* Limit sample size n to NLIM because of memory limitations. */ + /* Determine number of replications N from this. */ + N = 1 + nb / NLIM; + n = nb / N; + /* Time limit on test: N = 30 */ + N = util_Min (30, N); + /* Set n as a multiple of s = 32 */ + n -= n % 32; + L = num_Log2 (n / 200.0 * n); + L = util_Max (4, L); + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBitsOver (gen, par, res, N, n, 0, 32, L, TRUE); + strcpy (bbattery_TestNames[++j], "MultinomialBitsOver"); + bbattery_pVal[j] = res->pColl; + TestNumber[j] = j2; + } + +#else + x = nb / 32.0; + N = 1 + x / NLIM; + n = x / N; + N = util_Min (30, N); + L = 16; + t = 32 / L; + /* We want a number of collisions >= 2 */ + while ((L > 1) && (n / num_TwoExp[L] * n * t * t < 2.0)) { + L /= 2; + t = 32 / L; + } + n = n * (32 / L); + /* We want a density n / k < 2 to use case Sparse = TRUE */ + if (n > 2 * num_TwoExp[L]) { + N = n / num_TwoExp[L] * N; + n /= N; + while ((double) N * n * L > nb) + n--; + } + while (n * L % 32 > 0) + n--; + if (n > 3) { + for (i = 0; i < Rep[j2]; ++i) { + smultin_MultinomialBits (gen, par, res, N, n, 0, 32, L, TRUE); + strcpy (bbattery_TestNames[++j], "MultinomialBits"); + bbattery_pVal[j] = res->pColl; + TestNumber[j] = j2; + } + } +#endif + *pj = j; + smultin_DeleteRes (res); + smultin_DeleteParam (par); +} + + +/*-------------------------------------------------------------------------*/ + +static void DoAppear (lebool fileFlag, /* */ + unif01_Gen * gen, double nb, /* Number of bits to test */ + int *pj, /* j */ + int j2, /* Test number in the battery */ + int Rep[] + ) +/* + * Do the svaria_AppearanceSpacings test in Rabbit + */ +{ + sres_Basic *res; + const long NLIM = 2000000000; + int L; + long N, Q; + int i; + int j = *pj; + double temp = nb * (30.0 / 32.0) / 20.0; + + res = sres_CreateBasic (); + if (num_TwoExp[30] < temp / 30.0) + L = 30; + else if (num_TwoExp[15] < temp / 15.0) + L = 15; + else if (num_TwoExp[10] < temp / 10.0) + L = 10; + else if (num_TwoExp[6] < temp / 6.0) + L = 6; + else if (num_TwoExp[5] < temp / 5.0) + L = 5; + else if (num_TwoExp[3] < temp / 3.0) + L = 3; + else + L = 2; + temp = nb / 2; + temp *= 30.0 / 32.0; + temp /= L; + N = 1 + temp / NLIM; + Q = temp / N; + N = 1; + + if (Q < 50) + return; + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + svaria_AppearanceSpacings (gen, res, N, Q, Q, 0, 30, L); + j++; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AppearanceSpacings"); + } + sres_DeleteBasic (res); + *pj = j; +} + + +/*-------------------------------------------------------------------------*/ + +static void DoWalk (lebool fileFlag, /* */ + unif01_Gen * gen, /* */ + double nb, /* Number of bits to test */ + int *pj, /* j */ + int j2, /* Test number in the battery */ + int Rep[] + ) +/* + * Do 3 swalk_RandomWalk1 tests in Rabbit + */ +{ + swalk_Res *res; + long n, N, L; + double z; + int i; + + L = 128; + z = nb / L; + N = 1 + z / BILLION; + n = z / N; + N = 1; + while (n < 100) { + L /= 2; + n *= 2; + } + if (L < 4) + return; + n = nb / (L * N); + n = util_Min (n, 500 * MILLION); + if (L < 32) { + while (32 * n > nb) + n--; + } + if (n < 30) + return; + + res = swalk_CreateRes (); + ++j2; + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, N, n, 0, 32, L, L); + GetPVal_Walk (N, res, pj, "", j2); + } + if (L < 96) + return; + + L = 1024; + z = nb / L; + N = 1 + z / BILLION; + n = z / N; + n = util_Min (n, 50 * MILLION); + N = 1; + while ((double) n * L > nb) + n--; + if (n < 30) + return; + + ++j2; + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, N, n, 0, 32, L, L); + GetPVal_Walk (N, res, pj, " (L = 1024)", j2); + } + + L = 10016; + z = nb / L; + N = 1 + z / BILLION; + n = z / N; + n = util_Min (n, 5 * MILLION); + N = 1; + while ((double) n * L > nb) + n--; + if (n < 30) + return; + ++j2; + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + swalk_RandomWalk1 (gen, res, N, n, 0, 32, L, L); + GetPVal_Walk (N, res, pj, " (L = 10016)", j2); + } + + swalk_DeleteRes (res); +} + + +/*-------------------------------------------------------------------------*/ + +static void Rabbit (unif01_Gen * gen, char *fname, double nb, int Rep[]) +/* + * A battery of statistical tests for a file of n random bits. + */ +{ + const int s = 32; + int k, j = 0, j2 = 0; + int i; + long n, N, L; + double nw, x; + chrono_Chrono *Timer; + long bufsiz; + lebool fileFlag; + char genName[LEN + 1] = ""; + + Timer = chrono_Create (); + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting Rabbit: nb = %.0f\n" + " Version: %s\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n", + nb, PACKAGE_STRING); + } + util_Assert (nb >= 500.0, "bbattery_Rabbit: nb < 500"); + + /* Bits will be read as 32-bit unsigned integers */ + nb -= fmod (nb, 32.0); + nw = nb / 32.0; + bufsiz = nw; + + if (NULL == gen) { + gen = ufile_CreateReadBin (fname, bufsiz); + fileFlag = TRUE; + } else + fileFlag = FALSE; + + j = -1; + ++j2; + DoMultinom (fileFlag, gen, nb, &j, j2, Rep); + + { + const long NLIM = 4000000; + snpair_Res *res; + res = snpair_CreateRes (); + N = 1 + nw / NLIM; + n = nw / N; + N = util_Min (N, 25); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairsBitMatch (gen, res, N, n / 2, 0, 2); + bbattery_pVal[++j] = res->pVal[snpair_BM]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "ClosePairsBitMatch, t = 2"); + } + + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + snpair_ClosePairsBitMatch (gen, res, N, n / 4, 0, 4); + bbattery_pVal[++j] = res->pVal[snpair_BM]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "ClosePairsBitMatch, t = 4"); + } + snpair_DeleteRes (res); + } + + ++j2; + DoAppear (fileFlag, gen, nb, &j, j2, Rep); + + { + const long NLIM1 = 300000; + const long NLIM2 = 10000; + scomp_Res *res; + res = scomp_CreateRes (); + n = NLIM2 + 2.0 * sqrt (nb); + n = util_Min (n, nb); + n = util_Min (n, NLIM1); + N = 1; + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LinearComp (gen, res, N, n, 0, s); + j++; + if (N == 1) + bbattery_pVal[j] = res->JumpSize->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->JumpSize->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp"); + j++; + if (N == 1) + bbattery_pVal[j] = res->JumpNum->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->JumpNum->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LinearComp"); + } + scomp_DeleteRes (res); + } + + k = num_Log2 (nb + 0.5); + if (k > 28) + k = 28; + N = 1; + { + sres_Basic *res; + res = sres_CreateBasic (); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + scomp_LempelZiv (gen, res, N, k, 0, s); + j++; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LempelZiv"); + } + sres_DeleteBasic (res); + } + { + sspectral_Res *res; + k = num_Log2 (nb + 0.5); + k = util_Min (20, k); + res = sspectral_CreateRes (); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier1 (gen, res, 1, k, 0, s); + j++; + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier1"); + } + + x = sqrt (2.0 * nb); + N = x / 2.0; + if (N < 32) { + k = 5; + N = nb / 32.0; + } else if (N >= 16384) { + k = 14; + N = nb / 16384.0; + } else { + k = num_Log2 (x / 2.0 + 0.5); + N = nb / (num_TwoExp[k]); + } + N = util_Min (N, 300000); + while ((num_TwoExp[k] + 32) * N > nb) + N--; + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sspectral_Fourier3 (gen, res, N, k, 0, s); + j++; + bbattery_pVal[j] = res->Bas->pVal2[gofw_AD]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Fourier3"); + } + sspectral_DeleteRes (res); + } + { + sstring_Res2 *res; + res = sstring_CreateRes2 (); + x = util_Min (BILLION * 100.0, nb); + n = 600; + L = x / n; + if (L <= 100000) { + n /= 10; + L *= 10; + } + if (L <= 10000) { + n /= 2; + L *= 2; + } + ++j2; + if ((L >= 1032) && (n >= 30)) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + sstring_LongestHeadRun (gen, res, 1, n, 0, s, L); + j++; + bbattery_pVal[j] = res->Chi->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "LongestHeadRun"); + } + } + sstring_DeleteRes2 (res); + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + nw = nb / 32.0; + nw = util_Min (nw, 4.0 * BILLION); + N = 1 + nw / BILLION; + n = nw / N; + ++j2; + if (n >= 30) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + sstring_PeriodsInStrings (gen, res, N, n, 0, 31); + ++j; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "PeriodsInStrings"); + } + } + + nw = nb / s; + N = 1 + nw / BILLION; + n = nw / N; + N = util_Min (10, N); + ++j2; + if (n > 29) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingWeight (gen, res, N, n, 0, s, s); + ++j; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingWeight"); + } + } + sres_DeleteChi2 (res); + } + { + sstring_Res *res; + res = sstring_CreateRes (); + nw = nb / s; + N = 1 + nw / BILLION; + n = nw / N; + N = util_Min (10, N); + ++j2; + if (n > 2) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + sstring_HammingCorr (gen, res, N, n, 0, s, 32); + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 32"); + } + } + + nw = nb / 64; + N = 1 + nw / BILLION; + n = nw / N; + N = 1; + ++j2; + if (n > 2) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + sstring_HammingCorr (gen, res, N, n, 0, s, 2 * s); + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 64"); + } + } + + nw = nb / (4 * s); + N = 1 + nw / BILLION * 4; + n = nw / N; + N = 1; + ++j2; + if (n > 2) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + sstring_HammingCorr (gen, res, N, n, 0, s, 4 * s); + j++; + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingCorr, L = 128"); + } + } + + nw = nb / s; + N = 1 + nw / BILLION; + n = nw / N; + N = util_Min (5, N); + ++j2; + if (n > 29) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + sstring_HammingIndep (gen, res, N, n, 0, s, 16, 0); + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 16"); + } + } + + nw = nb / (2 * s); + N = 1 + nw / BILLION * 2; + n = nw / N; + N = 1; + ++j2; + if (n > 29) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + sstring_HammingIndep (gen, res, N, n, 0, s, s, 0); + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 32"); + } + } + + nw = nb / (4 * s); + N = 1 + nw / BILLION * 10; + n = nw / N; + N = 1; + ++j2; + if (n > 29) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + sstring_HammingIndep (gen, res, N, n, 0, s, 2 * s, 0); + if (N == 1) + bbattery_pVal[j] = res->Bas->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->Bas->pVal2[gofw_Sum]; + strcpy (bbattery_TestNames[j], "HammingIndep, L = 64"); + TestNumber[j] = j2; + } + } + sstring_DeleteRes (res); + } + { + sres_Basic *res; + int d; + res = sres_CreateBasic (); + + d = 1; + N = 1 + nb / BILLION; + n = nb / N - d; + n -= n % 32; + N = util_Min (100, N); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, N, n, 0, s, d); + j++; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor"); + } + + d = 2; + N = 1 + nb / BILLION; + n = nb / N - d; + n -= n % 32; + N = util_Min (100, N); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_AutoCor (gen, res, N, n, 0, s, d); + j++; + if (N == 1) + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "AutoCor"); + } + + sres_DeleteBasic (res); + } + { + sstring_Res3 *res; + res = sstring_CreateRes3 (); + nw = nb / 5; + N = 1 + nw / BILLION; + n = nw / N; + N = util_Min (20, N); + if (fileFlag) + ufile_InitReadBin (); + ++j2; + for (i = 0; i < Rep[j2]; ++i) { + sstring_Run (gen, res, N, n, 0, s); + j++; + if (N == 1) + bbattery_pVal[j] = res->NRuns->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->NRuns->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits"); + j++; + if (N == 1) + bbattery_pVal[j] = res->NBits->pVal2[gofw_Mean]; + else + bbattery_pVal[j] = res->NBits->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of bits"); + } + sstring_DeleteRes3 (res); + } + + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + n = nb / (s * s); + n = util_Min (n, 50 * MILLION); + ++j2; + if (n >= 50) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + smarsa_MatrixRank (gen, res, 1, n, 0, s, s, s); + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 32 x 32"); + } + } + + n = nb / (100.0 * s * s); + n = util_Min (n, 300000); + ++j2; + if (n >= 50) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + smarsa_MatrixRank (gen, res, 1, n, 0, s, 10 * s, 10 * s); + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 320 x 320"); + } + } + + n = nb / (1024.0 * s * s); + n = util_Min (n, 20000); + ++j2; + if (n >= 50) { + if (fileFlag) + ufile_InitReadBin (); + for (i = 0; i < Rep[j2]; ++i) { + j++; + smarsa_MatrixRank (gen, res, 1, n, 0, s, 32 * s, 32 * s); + bbattery_pVal[j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank, 1024 x 1024"); + } + } + sres_DeleteChi2 (res); + } + + DoWalk (fileFlag, gen, nb, &j, j2, Rep); + util_Assert (j2 <= RABBIT_NUM, "Rabbit: j2 > RABBIT_NUM"); + + bbattery_NTests = ++j; + if (fileFlag) { + WriteReport (fname, "Rabbit", bbattery_NTests, + bbattery_pVal, Timer, TRUE, TRUE, nb); + ufile_DeleteReadBin (gen); + } else { + GetName (gen, genName); + WriteReport (genName, "Rabbit", bbattery_NTests, bbattery_pVal, + Timer, FALSE, TRUE, nb); + } + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void bbattery_Rabbit (unif01_Gen * gen, double nb) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= RABBIT_NUM; ++i) + Rep[i] = 1; + Rabbit (gen, NULL, nb, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RabbitFile (char *filename, double nb) +{ + int i; + int Rep[NDIM + 1] = {0}; + for (i = 1; i <= RABBIT_NUM; ++i) + Rep[i] = 1; + Rabbit (NULL, filename, nb, Rep); +} + + +/*=========================================================================*/ + +void bbattery_RepeatRabbit (unif01_Gen * gen, double nb, int Rep[]) +{ + Rabbit (gen, NULL, nb, Rep); +} + + +/*=========================================================================*/ + +BatteryResult* bbattery_pseudoDIEHARD (unif01_Gen * gen) +/* + * As close as possible to the DIEHARD test suite. + */ +{ + chrono_Chrono *Timer; + smultin_Param *par = NULL; + double ValDelta[] = { 1 }; + char genName[LEN + 1] = ""; + int k, i, j = -1; + int j2 = 0; + double x; + long Count[7]; + double NumExp[7] = { + 67.668, 135.335, 135.335, 90.224, 45.112, 18.045, 8.282 + }; + swrite_Basic = 0; + + Timer = chrono_Create (); + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting pseudoDIEHARD\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n"); + } + { + sres_Poisson *res; + sres_Chi2 *Chi; + Chi = sres_CreateChi2 (); + sres_InitChi2 (Chi, 1, 6, ""); + res = sres_CreatePoisson (); + printf ("smarsa_BirthdaySpacings test with r = 0, 1, 2, 3, 4, 5," + " 6, 7, 8,\n .....\n\n"); + swrite_Basic = FALSE; + ++j2; + for (i = 0; i <= 8; i++) { + printf (" r = %d\n", i); + for (k = 0; k <= 6; k++) + Count[k] = 0; + for (k = 0; k < 500; k++) { + smarsa_BirthdaySpacings (gen, res, 1, 512, i, 16777216, 1, 1); + if (res->sVal2 >= 6) + ++Count[6]; + else + ++Count[(int) res->sVal2]; + } + x = gofs_Chi2 (NumExp, Count, 0, 6); + printf ("ChiSquare statistic :"); + bbattery_pVal[++j] = fbar_ChiSquare2 (6, 12, x); + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "BirthdaySpacings"); + gofw_Writep2 (x, bbattery_pVal[j]); + } + printf ("\n\n\n\n"); + sres_DeletePoisson (res); + sres_DeleteChi2 (Chi); + swrite_Basic = TRUE; + } + ++j2; + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + smarsa_MatrixRank (gen, res, 1, 40000, 0, 31, 31, 31); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "MatrixRank"); + + smarsa_MatrixRank (gen, res, 1, 40000, 0, 32, 32, 32); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank"); + + for (i = 0; i <= 24; i++) { + smarsa_MatrixRank (gen, res, 1, 100000, i, 8, 6, 8); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "MatrixRank"); + } + sres_DeleteChi2 (res); + } + { + smultin_Res *res; + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, 0); + res = smultin_CreateRes (par); + smultin_MultinomialBitsOver (gen, par, res, 20, 2097152, 0, 32, 20, + TRUE); + bbattery_pVal[++j] = res->pVal2[0][gofw_AD]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "MultinomialBitsOver"); + smultin_DeleteRes (res); + smultin_DeleteParam (par); + } + { + smarsa_Res *res; + res = smarsa_CreateRes (); + ++j2; + for (i = 22; i >= 0; i--) { + smarsa_Opso (gen, res, 1, i, 1); + bbattery_pVal[++j] = res->Pois->pVal2; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "OPSO"); + } + ValDelta[0] = -1.0; + ++j2; + for (i = 27; i >= 0; i--) { + if (swrite_Basic) + printf ("***********************************************************\n" + "Test OQSO calling smarsa_CollisionOver\n\n"); + smarsa_CollisionOver (gen, res, 1, 2097152, i, 32, 4); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "OQSO"); + } + ++j2; + for (i = 30; i >= 0; i--) { + if (swrite_Basic) + printf ("***********************************************************\n" + "Test DNA calling smarsa_CollisionOver\n\n"); + smarsa_CollisionOver (gen, res, 1, 2097152, i, 4, 10); + bbattery_pVal[++j] = res->Bas->pVal2[gofw_Mean]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "DNA"); + } + smarsa_DeleteRes (res); + } + j2 += 2; + { + snpair_Res *res; + res = snpair_CreateRes (); + snpair_ClosePairs (gen, res, 100, 8000, 0, 2, 2, 1); + bbattery_pVal[++j] = res->pVal[snpair_NP]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "ClosePairs"); + + snpair_ClosePairs (gen, res, 20, 4000, 0, 3, 2, 1); + bbattery_pVal[++j] = res->pVal[snpair_NP]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "ClosePairs"); + snpair_DeleteRes (res); + } + { + sres_Chi2 *res; + res = sres_CreateChi2 (); + smarsa_Savir2 (gen, res, 1, 100000, 0, 90000, 18); + bbattery_pVal[++j] = res->pVal2[gofw_Mean]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "Savir2"); + + ++j2; + sknuth_Run (gen, res, 10, 10000, 0, TRUE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = ++j2; + strcpy (bbattery_TestNames[j], "Run of U01"); + + sknuth_Run (gen, res, 10, 10000, 0, FALSE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of U01"); + + sknuth_Run (gen, res, 10, 10000, 0, TRUE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + TestNumber[j] = j2; + strcpy (bbattery_TestNames[j], "Run of U01"); + + sknuth_Run (gen, res, 10, 10000, 0, FALSE); + bbattery_pVal[++j] = res->pVal2[gofw_Sum]; + strcpy (bbattery_TestNames[j], "Run of U01"); + TestNumber[j] = j2; + sres_DeleteChi2 (res); + } + + bbattery_NTests = ++j; + GetName (gen, genName); + chrono_Delete (Timer); + return wrap(bbattery_pVal, bbattery_NTests); +} + + +/*=========================================================================*/ + +static double ProbabiliteLHR (long j, double Lnl) +/* + * Returns the probability that the longest series of successive 1 has + * length = j. + */ +{ + double x, temp; + temp = (j + 1) * num_Ln2 - Lnl; + x = exp (-exp (-temp)); + temp += num_Ln2; + x = exp (-exp (-temp)) - x; + return x; +} + +/*-------------------------------------------------------------------------*/ + +static double GetPLongest (int longest) +/* + * Get the probabilities for the longest run of 1 or 0 over 20000 bits. + */ +{ + double pLeft, pRight; + double LnLen; + int j; + + LnLen = log (20000.0); + pLeft = 0.0; + for (j = 0; j < longest; j++) + pLeft += ProbabiliteLHR (j, LnLen); + pRight = 1.0 - pLeft; + pLeft += ProbabiliteLHR (longest, LnLen); + return gofw_pDisc (pLeft, pRight); +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteReportFIPS_140_2 ( + char *genName, /* Generator or file name */ + lebool Flag, /* = TRUE for a file, FALSE for a gen */ + int nbit, /* Number of bits */ + int longest0, /* Longest string of 0 */ + int longest1, /* Longest string of 1 */ + int nrun0[], /* Number of 0 runs */ + int nrun1[], /* Number of 1 runs */ + int ncount[] /* Number of 4 bits values */ + ) +{ + int i, j; + double X; + fmass_INFO Q; + double p, pLeft, pRight; + lebool failFlag = FALSE; + + printf + ("\n============== Summary results of FIPS-140-2 ==============\n\n"); + if (Flag) { + printf (" File: "); + } else { + printf (" Generator: "); + } + printf ("%s", genName); + printf ("\n Number of bits: 20000\n"); + + printf ("\n Test s-value p-value FIPS Decision\n"); + printf (" --------------------------------------------------------\n"); + + /* Monobit results */ + j = 0; + printf (" %-20s", bbattery_TestNames[j]); + printf (" %5d ", nbit); + Q = fmass_CreateBinomial (20000, 0.5, 0.5); + pLeft = fdist_Binomial2 (Q, nbit); + pRight = fbar_Binomial2 (Q, nbit); + fmass_DeleteBinomial (Q); + p = gofw_pDisc (pLeft, pRight); + gofw_Writep0 (p); + if ((nbit <= 9725) || nbit >= 10275) { + printf (" %10s", "Fail"); + failFlag = TRUE; + } else + printf (" %10s", "Pass"); + + printf ("\n"); + + /* Poker results */ + X = 0; + for (i = 0; i < 16; i++) + X += (double) ncount[i] * ncount[i]; + X = 16 * X / 5000 - 5000; + j = 1; + printf (" %-16s", bbattery_TestNames[j]); + printf ("%10.2f ", X); + p = fbar_ChiSquare2 (15, 12, X); + gofw_Writep0 (p); + if ((X <= 2.16) || X >= 46.17) { + printf (" %10s", "Fail"); + failFlag = TRUE; + } else + printf (" %10s", "Pass"); + printf ("\n\n"); + + /* Run results */ + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[1]); + if ((nrun0[1] <= 2315) || nrun0[1] >= 2685) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[2]); + if ((nrun0[2] <= 1114) || nrun0[2] >= 1386) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[3]); + if ((nrun0[3] <= 527) || nrun0[3] >= 723) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[4]); + if ((nrun0[4] <= 240) || nrun0[4] >= 384) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[5]); + if ((nrun0[5] <= 103) || nrun0[5] >= 209) { + failFlag = TRUE; + printf (" %25s", "Fail"); + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun0[6]); + if ((nrun0[6] <= 103) || nrun0[6] >= 209) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[1]); + if ((nrun1[1] <= 2315) || nrun1[1] >= 2685) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[2]); + if ((nrun1[2] <= 1114) || nrun1[2] >= 1386) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[3]); + if ((nrun1[3] <= 527) || nrun1[3] >= 723) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[4]); + if ((nrun1[4] <= 240) || nrun1[4] >= 384) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[5]); + if ((nrun1[5] <= 103) || nrun1[5] >= 209) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d", nrun1[6]); + if ((nrun1[6] <= 103) || nrun1[6] >= 209) { + printf (" %25s", "Fail"); + failFlag = TRUE; + } else + printf (" %25s", "Pass"); + printf ("\n\n"); + + /* Longest run results */ + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d ", longest0); + p = GetPLongest (longest0); + gofw_Writep0 (p); + if (longest0 >= 26) { + printf (" %10s", "Fail"); + failFlag = TRUE; + } else + printf (" %10s", "Pass"); + printf ("\n"); + + printf (" %-20s", bbattery_TestNames[++j]); + printf (" %5d ", longest1); + p = GetPLongest (longest1); + gofw_Writep0 (p); + if (longest1 >= 26) { + printf (" %10s", "Fail"); + failFlag = TRUE; + } else + printf (" %10s", "Pass"); + printf ("\n"); + + if (!failFlag) { + printf (" ----------------------------------------------------------\n"); + printf (" All values are within the required intervals of FIPS-140-2\n"); + } + printf ("\n\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +#define SAMPLE 625 /* 625 * 32 = 20000 */ +#define MASK4 15 /* Mask of 4 bits */ + +static void FIPS_140_2 (unif01_Gen * gen, char *filename) +{ + int i, j; + int nbit = 0; /* Number of bits */ + int longest0 = 0; /* Longest string of 0 */ + int longest1 = 0; /* Longest string of 1 */ + int nrun0[7] = { 0 }; /* Number of 0 runs */ + int nrun1[7] = { 0 }; /* Number of 1 runs */ + int ncount[16] = { 0 }; /* Number of 4 bits values */ + int prevBit; /* Previous bit */ + int len = 0; /* Length of run */ + unsigned long jBit; /* Current bit */ + unsigned long Z; /* Block of 32 bits */ + unsigned long Bits[SAMPLE + 1]; + lebool fileFlag = FALSE; + char genName[LEN + 1] = ""; + + InitBat (); + if (swrite_Basic) { + printf ("xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n" + " Starting FIPS_140_2\n" + "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n\n\n"); + } + util_Assert (NULL == gen || NULL == filename, + "bbattery_FIPS_140_2: one of gen or filename must be NULL"); + util_Assert (!(NULL == gen && NULL == filename), + "bbattery_FIPS_140_2: no generator and no file"); + util_Assert (!(NULL == gen && !(strcmp (filename, ""))), + "bbattery_FIPS_140_2: no generator and no file"); + + if ((NULL == gen) && filename && strcmp (filename, "")) { + gen = ufile_CreateReadBin (filename, SAMPLE); + fileFlag = TRUE; + } + + for (j = 0; j < SAMPLE; j++) + Bits[j] = unif01_StripB (gen, 0, 32); + + if (fileFlag) { + ufile_DeleteReadBin (gen); + strncpy (genName, filename, (size_t) LEN); + } else { + GetName (gen, genName); + } + + /* Make sure to count the first run; set prevBit != {0, 1} */ + prevBit = 2; + + for (j = 0; j < SAMPLE; j++) { + /* Count the number of 1 */ + Z = Bits[j]; + while (Z > 0) { + Z &= Z - 1; /* Clear lowest 1 bit */ + ++nbit; + } + + /* Count the number of 4 bits values */ + Z = Bits[j]; + for (i = 0; i < 8; i++) { + (ncount[Z & MASK4])++; + Z >>= 4; + } + + /* Count the number of runs and get the longest runs */ + Z = Bits[j]; + jBit = bitset_maskUL[31]; + + while (jBit > 0) { + if (Z & jBit) { /* bit 1 */ + if (prevBit != 1) { + if (len < 6) + (nrun0[len])++; + else + (nrun0[6])++; + if (len > longest0) + longest0 = len; + len = 1; + } else { + len++; + } + prevBit = 1; + + } else { /* bit 0 */ + if (prevBit != 0) { + if (len < 6) + (nrun1[len])++; + else + (nrun1[6])++; + if (len > longest1) + longest1 = len; + len = 1; + } else { + len++; + } + prevBit = 0; + } + jBit >>= 1; + } + } + + strcpy (bbattery_TestNames[0], "Monobit"); + strcpy (bbattery_TestNames[1], "Poker"); + j = 1; + strcpy (bbattery_TestNames[++j], "0 Runs, length 1: "); + strcpy (bbattery_TestNames[++j], "0 Runs, length 2: "); + strcpy (bbattery_TestNames[++j], "0 Runs, length 3: "); + strcpy (bbattery_TestNames[++j], "0 Runs, length 4: "); + strcpy (bbattery_TestNames[++j], "0 Runs, length 5: "); + strcpy (bbattery_TestNames[++j], "0 Runs, length 6+: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 1: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 2: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 3: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 4: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 5: "); + strcpy (bbattery_TestNames[++j], "1 Runs, length 6+: "); + + strcpy (bbattery_TestNames[++j], "Longest run of 0: "); + strcpy (bbattery_TestNames[++j], "Longest run of 1: "); + + WriteReportFIPS_140_2 (genName, fileFlag, nbit, longest0, longest1, + nrun0, nrun1, ncount); +} + + +/*-------------------------------------------------------------------------*/ + +void bbattery_FIPS_140_2 (unif01_Gen * gen) +{ + FIPS_140_2 (gen, NULL); +} + + +/*-------------------------------------------------------------------------*/ + +void bbattery_FIPS_140_2File (char *filename) +{ + FIPS_140_2 (NULL, filename); +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/bitset.c b/cbits/testu/src/bitset.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/bitset.c @@ -0,0 +1,222 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: bitset.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "bitset.h" +#include "util.h" +#include +#include +#include + + +unsigned long bitset_maskUL[] = { + 1, + 2, + 4, + 8, + 16, + 32, + 64, + 128, + 256, + 512, + 1024, + 2048, + 4096, + 8192, + 16384, + 32768, + 65536, + 131072, + 262144, + 524288, + 1048576, + 2097152, + 4194304, + 8388608, + 16777216, + 33554432, + 67108864, + 134217728, + 268435456, + 536870912, + 1073741824, + 2147483648UL +#if ULONG_MAX > 4294967295UL + , + 4294967296, + 8589934592, + 17179869184, + 34359738368, + 68719476736, + 137438953472, + 274877906944, + 549755813888, + 1099511627776, + 2199023255552, + 4398046511104, + 8796093022208, + 17592186044416, + 35184372088832, + 70368744177664, + 140737488355328, + 281474976710656, + 562949953421312, + 1125899906842624, + 2251799813685248, + 4503599627370496, + 9007199254740992, + 18014398509481984, + 36028797018963968, + 72057594037927936, + 144115188075855872, + 288230376151711744, + 576460752303423488, + 1152921504606846976, + 2305843009213693952, + 4611686018427387904, + 9223372036854775808UL +#endif + }; + + +/*--------------------------------------------------------------------------*/ + +unsigned long bitset_MASK[] = { + 0, + 1, + 3, + 7, + 15, + 31, + 63, + 127, + 255, + 511, + 1023, + 2047, + 4095, + 8191, + 16383, + 32767, + 65535, + 131071, + 262143, + 524287, + 1048575, + 2097151, + 4194303, + 8388607, + 16777215, + 33554431, + 67108863, + 134217727, + 268435455, + 536870911, + 1073741823, + 2147483647, + 4294967295UL +#if ULONG_MAX > 4294967295UL + , + 8589934591, + 17179869183, + 34359738367, + 68719476735, + 137438953471, + 274877906943, + 549755813887, + 1099511627775, + 2199023255551, + 4398046511103, + 8796093022207, + 17592186044415, + 35184372088831, + 70368744177663, + 140737488355327, + 281474976710655, + 562949953421311, + 1125899906842623, + 2251799813685247, + 4503599627370495, + 9007199254740991, + 18014398509481983, + 36028797018963967, + 72057594037927935, + 144115188075855871, + 288230376151711743, + 576460752303423487, + 1152921504606846975, + 2305843009213693951, + 4611686018427387903, + 9223372036854775807, + 18446744073709551615UL +#endif + }; + +/*--------------------------------------------------------------------------*/ + + +void bitset_WriteSet (char *desc, bitset_BitSet S, int n) +{ + int i; + bitset_BitSet mask; + + util_Assert (n > 0, "bitset_WriteSet: s <= 0"); + if ((unsigned) n > CHAR_BIT * sizeof (bitset_BitSet)) { + n = CHAR_BIT * sizeof (bitset_BitSet); + printf ("********** bitset_WriteSet: only %d bits in a BitSet\n\n", n); + } + if (desc != NULL && strlen (desc) > 0) + printf ("%s", desc); + mask = (bitset_BitSet) 1 << (n - 1); + for (i = 0; i < n; i++) { + if (S & mask) + printf ("1"); + else + printf ("0"); + mask >>= 1; + } +} + + +/*--------------------------------------------------------------------------*/ + +bitset_BitSet bitset_Reverse (bitset_BitSet Z, int s) +{ + unsigned long res = 0; + int i; + + for (i = 0; i < s; i++) { + res = (res << 1) | (Z & 1); + Z >>= 1; + } + return res; +} + diff --git a/cbits/testu/src/chrono.c b/cbits/testu/src/chrono.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/chrono.c @@ -0,0 +1,226 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: chrono.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include "chrono.h" +#include "gdef.h" +#include "util.h" +#include "num.h" + +#include +#include +#include + +#ifdef HAVE_WINDOWS_H + +#include + +static HANDLE currentProcess = NULL; + +/* + * A helper function for converting FILETIME to a LONGLONG [safe from memory + * alignment point of view]. + */ +static ULONGLONG +fileTimeToInt64 (const FILETIME * time) +{ + ULARGE_INTEGER _time; + _time.LowPart = time->dwLowDateTime; + _time.HighPart = time->dwHighDateTime; + return _time.QuadPart; +} + +static void Heure (unsigned long *tsec, unsigned long *tusec) { + if (currentProcess == NULL) + currentProcess = GetCurrentProcess(); + FILETIME creationTime, exitTime, kernelTime, userTime; + /* Strongly inspired from + * http://www.javaworld.com/javaworld/javaqa/2002-11/01-qa-1108-cpu.html */ + GetProcessTimes (currentProcess, &creationTime, &exitTime, + &kernelTime, &userTime); + ULONGLONG rawTime = fileTimeToInt64 (&kernelTime) + + fileTimeToInt64 (&userTime); + /* We have to divide by 10000 to get milliseconds out of + * the computed time */ + *tsec = (unsigned long)(rawTime / 10000000); + *tusec = (unsigned long)((rawTime % 10000000) / 10); +} + + +#elif defined(USE_ANSI_CLOCK) +/* ANSI C timer */ + +static void Heure ( + unsigned long *tsec, /* Seconds */ + unsigned long *tmicrosec /* Micro-seconds */ + ) +/* + * Function returning the CPU time used by a program since it was + * started. This function is ANSI C compliant. + */ +{ + clock_t t; + double y; + + t = clock (); + y = ((double) t) / CLOCKS_PER_SEC; + *tsec = y; + *tmicrosec = (y - *tsec) * 1000000; +} + + +#else +/* POSIX timer */ + +#include +#include + +static void Heure (unsigned long *tsec, unsigned long *tusec) +/* + * Function returning the CPU time used by a program since it was + * started. This function is NOT ANSI C compliant. + */ +{ + struct tms us; + long TICKS, z; + + TICKS = sysconf(_SC_CLK_TCK); + if (TICKS == -1) { + fprintf (stdout, "chrono.c: 'sysconf(_SC_CLK_TCK)' failed\n"); + } + z = times (&us); + if (z == -1) { + fprintf (stdout, "chrono.c: timer times failed\n"); + } + + /* CPU time = user time + system time */ + *tusec = us.tms_utime + us.tms_stime; + + *tsec = *tusec / TICKS; + *tusec = (*tusec % TICKS) * 1000000 / TICKS; +} + +#endif + + +/*------------------------------------------------------------------------*/ + +void chrono_Init (chrono_Chrono *C) +{ + Heure (&C->second, &C->microsec); +} + + +chrono_Chrono * chrono_Create (void) +{ + chrono_Chrono *C; + C = (chrono_Chrono *) util_Malloc (sizeof (chrono_Chrono)); + Heure (&C->second, &C->microsec); + return C; +} + + +void chrono_Delete (chrono_Chrono *C) +{ + util_Free (C); +} + + +double chrono_Val (chrono_Chrono *C, chrono_TimeFormat Unit) +{ + double temps; /* Time elapsed, in seconds */ + chrono_Chrono now; + Heure (&now.second, &now.microsec); + temps = (((double) now.microsec - (double) C->microsec) / 1.E+6 + + (double) now.second) - (double) C->second; + + switch (Unit) { + case chrono_sec: + return temps; + case chrono_min: + return temps * 1.666666667E-2; + case chrono_hours: + return temps * 2.777777778E-4; + case chrono_days: + return temps * 1.157407407E-5; + case chrono_hms: + util_Error ("chrono_Val : hms is a wrong arg for chrono_TimeUnit"); + } + return 0.0; +} + +void chrono_Write (chrono_Chrono * C, chrono_TimeFormat Form) +{ + long centieme; + long minute; + long heure; + long seconde; + double temps; + if (Form != chrono_hms) + temps = chrono_Val (C, Form); + else + temps = 0.0; + switch (Form) { + case chrono_sec: + num_WriteD (temps, 10, 2, 1); + printf (" seconds"); + break; + case chrono_min: + num_WriteD (temps, 10, 2, 1); + printf (" minutes"); + break; + case chrono_hours: + num_WriteD (temps, 10, 2, 1); + printf (" hours"); + break; + case chrono_days: + num_WriteD (temps, 10, 2, 1); + printf (" days"); + break; + case chrono_hms: + temps = chrono_Val (C, chrono_sec); + heure = (long) (temps * 2.777777778E-4); + if (heure > 0) + temps -= (double) (heure) * 3600.0; + minute = (long) (temps * 1.666666667E-2); + if (minute > 0) + temps -= (double) (minute) * 60.0; + seconde = (long) (temps); + centieme = (long) (100.0 * (temps - (double) (seconde))); + printf ("%02ld:", heure); + printf ("%02ld:", minute); + printf ("%02ld.", seconde); + printf ("%02ld", centieme); + break; + } +} diff --git a/cbits/testu/src/fbar.c b/cbits/testu/src/fbar.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fbar.c @@ -0,0 +1,1313 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: fbar.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "fbar.h" +#include "fdist.h" + +#include "num.h" +#include "num2.h" +#include "util.h" +#include "gdef.h" + +#include +#include + +double fdist_belog(double); +extern const double fdist_XINF; +extern const double fdist_XBIG; +extern const double fdist_XBIGM; + +/* EpsArray[j]: Epsilon required for j decimal degits of precision */ +static const double EpsArray[] = { + 0.5, 0.5E-1, 0.5E-2, 0.5E-3, 0.5E-4, 0.5E-5, 0.5E-6, 0.5E-7, 0.5E-8, + 0.5E-9, 0.5E-10, 0.5E-11, 0.5E-12, 0.5E-13, 0.5E-14, 0.5E-15, 0.5E-16, + 0.5E-17, 0.5E-18, 0.5E-19, 0.5E-20, 0.5E-21, 0.5E-22, 0.5E-23, 0.5E-24, + 0.5E-25, 0.5E-26, 0.5E-27, 0.5E-28, 0.5E-29, 0.5E-30, 0.5E-31, 0.5E-32, + 0.5E-33, 0.5E-34, 0.5E-35 +}; + +/* Compute IMAX extra terms in the tails of discrete distributions */ +static const long IMAX = 20; + + + +/*=========================================================================*/ + +double fbar_Unif (double x) +{ + if (x <= 0.0) + return 1.0; + if (x >= 1.0) + return 0.0; + return 1.0 - x; +} + + +/*=========================================================================*/ + +double fbar_Expon (double x) +{ + if (x <= 0.0) + return 1.0; + if (x >= fdist_XBIGM) + return 0.0; + return exp (-x); +} + + +/*=========================================================================*/ + +double fbar_Weibull (double c, double x) +{ + double temp; + util_Assert (c > 0.0, "fbar_Weibull: c <= 0"); + if (x <= 0.0) + return 1.0; + if (x >= DBL_MAX_EXP * FLT_RADIX && c >= 1.0) + return 0.0; + temp = c*log(x); + if (temp >= DBL_MAX_EXP * num_Ln2) + return 0.0; + temp = exp(temp); + return (exp (-temp)); +} + + +/*=========================================================================*/ + +double fbar_Logistic (double x) +{ + if (x <= -fdist_XBIG) { + return 1.0; + } + if (x >= fdist_XBIG) { + return exp (-x); + } + return 1.0 / (1.0 + exp (x)); +} + + +/*=========================================================================*/ + +double fbar_Pareto (double c, double x) +{ + + util_Assert (c > 0.0, "fbar_Pareto: c <= 0"); + if (x <= 1.0) + return 1.0; + return (pow (x, -c)); +} + +/**************************************************************************/ + +double fbar_Normal1 (double x) +/* + * Returns P[X >= x] = 1 - F(x) where F is the normal distribution by + * computing the complementary distribution directly; it is thus more + * precise in the tail. + */ +{ + static const double A[25] = { + 6.10143081923200418E-1, + -4.34841272712577472E-1, + 1.76351193643605501E-1, + -6.07107956092494149E-2, + 1.77120689956941145E-2, + -4.32111938556729382E-3, + 8.54216676887098679E-4, + -1.27155090609162743E-4, + 1.12481672436711895E-5, + 3.13063885421820973E-7, + -2.70988068537762022E-7, + 3.07376227014076884E-8, + 2.51562038481762294E-9, + -1.02892992132031913E-9, + 2.99440521199499394E-11, + 2.60517896872669363E-11, + -2.63483992417196939E-12, + -6.43404509890636443E-13, + 1.12457401801663447E-13, + 1.7281533389986098E-14, + -4.2641016949424E-15, + -5.4537197788E-16, + 1.5869760776E-16, + 2.08998378E-17, + -0.5900E-17 + }; + const double kk = 5.30330085889910643300; /* 3.75 Sqrt(2) */ + double y, t; + int Neg; + + if (x >= fdist_XBIG) { + return 0.0; + } + if (x <= -fdist_XBIG) { + return 1.0; + } + + if (x >= 0.0) + Neg = 0; + else { + Neg = 1; + x = -x; + } + + t = (x - kk) / (x + kk); + y = num2_EvalCheby (A, 24, t); + y = y * exp (-x * x / 2.0) / 2.0; + + if (Neg == 1) + return (1.0 - y); + else + return (y); +} + + +/*=========================================================================*/ + +double fbar_Normal2 (double x) +{ + static const double V[121] = { + 1.2533141373155, 1.137490921203605, 1.037824575853727, + 0.951527192071207, 0.8763644564536924, 0.8105337152790306, + 0.7525711790634081, 0.7012808218544303, 0.6556795424187987, + 0.61495459615093, 0.5784303460476312, 0.5455421356582171, + 0.5158156382179634, 0.4888504415275737, 0.4643069280394423, + 0.4418957328326002, 0.4213692292880546, 0.4025146181296722, + 0.3851482907984348, 0.3691112106902635, 0.3542651113297938, + 0.3404893532870847, 0.3276783146905521, 0.31573921586941, + 0.3045902987101033, 0.2941592970402893, 0.284382146748493, + 0.2752018941576065, 0.2665677689682238, 0.2584343943120386, + 0.2507611114439651, 0.243511400615456, 0.2366523829135607, + 0.230154390478801, 0.2239905946538289, 0.2181366833614714, + 0.2125705804420318, 0.2072722008565011, 0.2022232366330547, + 0.1974069692375194, 0.1928081047153158, 0.1884126285076003, + 0.1842076773079702, 0.1801814257143918, 0.1763229857571027, + 0.1726223176578506, 0.1690701504076941, 0.1656579109468773, + 0.1623776608968675, 0.1592220399363674, 0.1561842150339759, + 0.153257834853479, 0.1504369887362691, 0.1477161697413935, + 0.145090241289131, 0.1425544070104023, 0.1401041834530503, + 0.1377353753382303, 0.1354440530967635, 0.1332265324471292, + 0.1310793558044918, 0.1289992753343376, 0.126983237485437, + 0.1250283688553504, 0.1231319632579323, 0.1212914698765462, + 0.119504482399253, 0.1177687290432979, 0.1160820633859823, + 0.1144424559276431, 0.112847986320103, 0.1112968362007359, + 0.1097872825783083, 0.1083176917221132, 0.1068865135106745, + 0.1054922762005562, 0.1041335815795983, 0.1028091004723001, + 0.1015175685681028, 0.1002577825460485, 0.09902859647173194, + 0.09782891844465691, 0.09665770747608191, 0.09551397057921558, + 0.09439676005522439, 0.09330517095996169, 0.09223833873763035, + 0.09119543700877471, 0.09017567550106469, 0.08917829811230435, + 0.08820258109597616, 0.08724783136042988, 0.08631338487354936, + 0.08539860516539227, 0.08450288192189578, 0.08362562966329139, + 0.08276628650136918, 0.08192431297018954, 0.08109919092525536, + 0.08029042250654048, 0.07949752916111721, 0.07872005072144664, + 0.07795754453568722, 0.07720958464664668, 0.07647576101624852, + 0.07575567879261112, 0.07504895761704659, 0.07435523096847724, + 0.07367414554294564, 0.07300536066605566, 0.07234854773633338, + 0.07170338969763433, 0.07106958053885212, 0.07044682481930167, + 0.06983483721825942, 0.06923334210724434, 0.06864207314371742, + 0.06806077288496332, 0.0674891924209997, 0.06692709102543307, + 0.06637423582325017 +}; + + int j; + lebool negatif; + double t, u, z, h; + double r, r1, r2, r3, r4, r5, r6, r7, r8; + + if (x >= fdist_XBIG) { + return 0.0; + } + if (x <= -fdist_XBIG) { + return 1.0; + } + if (x < 0.0) { + negatif = TRUE; + x = -x; + } else { + negatif = FALSE; + } + j = (int) (8.0 * x + 0.5); + if (j > 120) + j = 120; + z = 0.125 * j; + h = x - z; + r = V[j]; + r1 = r * z - 1.0; + r2 = 0.5 * (r + z * r1); + r3 = (r1 + z * r2) / 3.0; + r4 = 0.25 * (r2 + z * r3); + r5 = 0.2 * (r3 + z * r4); + r6 = (r4 + z * r5) / 6.0; + r7 = (r5 + z * r6) / 7.0; + r8 = 0.125 * (r6 + z * r7); + t = r + h * (r1 + h * (r2 + h * (r3 + h * (r4 + h * (r5 + h * (r6 + + h * (r7 + h * r8))))))); + u = t * exp (-0.5 * x * x - 0.9189385332046727); + if (negatif) + return 1.0 - u; + else + return u; +} + + +/*=========================================================================*/ +#ifdef HAVE_ERF + +double fbar_Normal3 (double x) +{ + return 0.5 * erfc (x * num_1Rac2); +} + +#endif +/*=========================================================================*/ + +double fbar_BiNormal1 (double x, double y, double rho, int ndig) +{ + return fdist_BiNormal1(-x, -y, rho, ndig); +} + + +/*=========================================================================*/ + +double fbar_BiNormal2 (double x, double y, double rho) +{ + return fdist_BiNormal2 (-x, -y, rho); +} + + +/*=========================================================================*/ + +double fbar_LogNormal (double mu, double sigma, double x) +{ + util_Assert (sigma > 0.0, "fbar_LogNormal: sigma <= 0"); + if (x <= 0.0) + return 1.0; + return fbar_Normal1 ((log (x) - mu) / sigma); +} + + +/*=========================================================================*/ + +double fbar_JohnsonSB (double alpha, double beta, double a, double b, + double x) +{ + util_Assert (beta > 0.0, "fbar_JohnsonSB: beta <= 0"); + util_Assert (b > a, "fbar_JohnsonSB: b <= a"); + if (x <= a) + return 1.0; + if (x >= b) + return 0.0; + return fbar_Normal1 (alpha + beta * log ((x - a) / (b - x))); +} + + +/*=========================================================================*/ + +double fbar_JohnsonSU (double alpha, double beta, double x) +{ + const double XLIM = 1.0e10; + double r; + lebool negative = FALSE; + util_Assert (beta > 0.0, "fbar_JohnsonSU: beta <= 0"); + if (x < 0.0) { + negative = TRUE; + x = -x; + } + /* compute r = x + sqrt (x * x + 1) */ + if (x < XLIM) + r = x + sqrt (x * x + 1.0); + else + r = 2.0 * x; + if (negative) + r = 1.0 / r; + + if (r > 0.0) + return fbar_Normal1 (alpha + beta * log (r)); + else + return 1.0; +} + + +/*=========================================================================*/ + +static double F2AD[103]; /* Tables for the approximation of the */ +static double CoAD[103]; /* Anderson-Darling distribution */ + +static void AndersonDarlingInit (void) +{ + F2AD[0] = 0.0; F2AD[1] = 1.7315E-10; + F2AD[2] = 2.80781E-5; F2AD[3] = 1.40856E-3; + F2AD[4] = 9.58772E-3; F2AD[5] = 2.960552E-2; + F2AD[6] = 6.185146E-2; F2AD[7] = 1.0357152E-1; + F2AD[8] = 1.5127241E-1; F2AD[9] = 2.0190317E-1; + F2AD[10] = 2.5318023E-1; F2AD[11] = 3.0354278E-1; + F2AD[12] = 3.5200015E-1; F2AD[13] = 3.9797537E-1; + F2AD[14] = 4.4117692E-1; F2AD[15] = 4.8150305E-1; + F2AD[16] = 5.1897375E-1; F2AD[17] = 5.5368396E-1; + F2AD[18] = 5.8577199E-1; F2AD[19] = 6.1539864E-1; + F2AD[20] = 6.4273362E-1; F2AD[21] = 6.6794694E-1; + F2AD[22] = 6.9120359E-1; F2AD[23] = 7.126605E-1; + F2AD[24] = 7.3246483E-1; F2AD[25] = 7.507533E-1; + F2AD[26] = 7.6765207E-1; F2AD[27] = 7.8327703E-1; + F2AD[28] = 7.9773426E-1; F2AD[29] = 8.1112067E-1; + F2AD[30] = 8.2352466E-1; F2AD[31] = 8.3502676E-1; + F2AD[32] = 8.4570037E-1; F2AD[33] = 8.5561231E-1; + F2AD[34] = 8.6482346E-1; F2AD[35] = 8.7338931E-1; + F2AD[36] = 8.8136046E-1; F2AD[37] = 8.8878306E-1; + F2AD[38] = 8.9569925E-1; F2AD[39] = 9.0214757E-1; + F2AD[40] = 9.081653E-1; F2AD[41] = 9.1378043E-1; + F2AD[42] = 9.1902284E-1; F2AD[43] = 9.2392345E-1; + F2AD[44] = 9.2850516E-1; F2AD[45] = 9.3279084E-1; + F2AD[46] = 9.3680149E-1; F2AD[47] = 9.4055647E-1; + F2AD[48] = 9.440736E-1; F2AD[49] = 9.4736933E-1; + F2AD[50] = 9.5045883E-1; F2AD[51] = 9.5335611E-1; + F2AD[52] = 9.5607414E-1; F2AD[53] = 9.586249E-1; + F2AD[54] = 9.6101951E-1; F2AD[55] = 9.6326825E-1; + F2AD[56] = 9.6538067E-1; F2AD[57] = 9.6736563E-1; + F2AD[58] = 9.6923135E-1; F2AD[59] = 9.7098548E-1; + F2AD[60] = 9.7263514E-1; F2AD[61] = 9.7418694E-1; + F2AD[62] = 9.7564704E-1; F2AD[63] = 9.7702119E-1; + F2AD[64] = 9.7831473E-1; F2AD[65] = 9.7953267E-1; + F2AD[66] = 9.8067966E-1; F2AD[67] = 9.8176005E-1; + F2AD[68] = 9.827779E-1; F2AD[69] = 9.8373702E-1; + F2AD[70] = 9.8464096E-1; F2AD[71] = 9.8549304E-1; + F2AD[72] = 9.8629637E-1; F2AD[73] = 9.8705386E-1; + F2AD[74] = 9.8776824E-1; F2AD[75] = 9.8844206E-1; + F2AD[76] = 9.8907773E-1; F2AD[77] = 9.8967747E-1; + F2AD[78] = 9.9024341E-1; F2AD[79] = 9.9077752E-1; + F2AD[80] = 9.9128164E-1; F2AD[81] = 9.9175753E-1; + F2AD[82] = 9.9220682E-1; F2AD[83] = 9.9263105E-1; + F2AD[84] = 9.9303165E-1; F2AD[85] = 9.9340998E-1; + F2AD[86] = 9.9376733E-1; F2AD[87] = 9.9410488E-1; + F2AD[88] = 9.9442377E-1; F2AD[89] = 9.9472506E-1; + F2AD[90] = 9.9500974E-1; F2AD[91] = 9.9527876E-1; + F2AD[92] = 9.95533E-1; F2AD[93] = 9.9577329E-1; + F2AD[94] = 9.9600042E-1; F2AD[95] = 9.9621513E-1; + F2AD[96] = 9.964181E-1; F2AD[97] = 0.99661; + F2AD[98] = 9.9679145E-1; F2AD[99] = 9.9696303E-1; + F2AD[100] = 9.9712528E-1; F2AD[101] = 9.9727872E-1; + F2AD[102] = 9.9742384E-1; + + CoAD[0] = 0.0; + CoAD[1] = 0.0; CoAD[2] = 0.0; + CoAD[3] = 0.0; CoAD[4] = 0.0; + CoAD[5] = -1.87E-3; CoAD[6] = 0.00898; + CoAD[7] = 0.0209; CoAD[8] = 0.03087; + CoAD[9] = 0.0377; CoAD[10] = 0.0414; + CoAD[11] = 0.04386; CoAD[12] = 0.043; + CoAD[13] = 0.0419; CoAD[14] = 0.0403; + CoAD[15] = 0.038; CoAD[16] = 3.54804E-2; + CoAD[17] = 0.032; CoAD[18] = 0.0293; + CoAD[19] = 2.61949E-2; CoAD[20] = 0.0228; + CoAD[21] = 0.0192; CoAD[22] = 1.59865E-2; + CoAD[23] = 0.0129; CoAD[24] = 0.0107; + CoAD[25] = 8.2464E-3; CoAD[26] = 0.00611; + CoAD[27] = 0.00363; CoAD[28] = 1.32272E-3; + CoAD[29] = -5.87E-4; CoAD[30] = -2.75E-3; + CoAD[31] = -3.95248E-3; CoAD[32] = -5.34E-3; + CoAD[33] = -6.892E-3; CoAD[34] = -8.10208E-3; + CoAD[35] = -8.93E-3; CoAD[36] = -9.552E-3; + CoAD[37] = -1.04605E-2; CoAD[38] = -0.0112; + CoAD[39] = -1.175E-2; CoAD[40] = -1.20216E-2; + CoAD[41] = -0.0124; CoAD[42] = -1.253E-2; + CoAD[43] = -1.27076E-2; CoAD[44] = -0.0129; + CoAD[45] = -1.267E-2; CoAD[46] = -1.22015E-2; + CoAD[47] = -0.0122; CoAD[48] = -1.186E-2; + CoAD[49] = -1.17218E-2; CoAD[50] = -0.0114; + CoAD[51] = -1.113E-2; CoAD[52] = -1.08459E-2; + CoAD[53] = -0.0104; CoAD[54] = -9.93E-3; + CoAD[55] = -9.5252E-3; CoAD[56] = -9.24E-3; + CoAD[57] = -9.16E-3; CoAD[58] = -8.8004E-3; + CoAD[59] = -8.63E-3; CoAD[60] = -8.336E-3; + CoAD[61] = -8.10512E-3; CoAD[62] = -7.94E-3; + CoAD[63] = -7.71E-3; CoAD[64] = -7.55064E-3; + CoAD[65] = -7.25E-3; CoAD[66] = -7.11E-3; + CoAD[67] = -6.834E-3; CoAD[68] = -0.0065; + CoAD[69] = -6.28E-3; CoAD[70] = -6.11008E-3; + CoAD[71] = -5.86E-3; CoAD[72] = -5.673E-3; + CoAD[73] = -5.35008E-3; CoAD[74] = -5.11E-3; + CoAD[75] = -4.786E-3; CoAD[76] = -4.59144E-3; + CoAD[77] = -4.38E-3; CoAD[78] = -4.15E-3; + CoAD[79] = -4.07696E-3; CoAD[80] = -3.93E-3; + CoAD[81] = -3.83E-3; CoAD[82] = -3.74656E-3; + CoAD[83] = -3.49E-3; CoAD[84] = -3.33E-3; + CoAD[85] = -3.20064E-3; CoAD[86] = -3.09E-3; + CoAD[87] = -2.93E-3; CoAD[88] = -2.78136E-3; + CoAD[89] = -2.72E-3; CoAD[90] = -2.66E-3; + CoAD[91] = -2.56208E-3; CoAD[92] = -2.43E-3; + CoAD[93] = -2.28E-3; CoAD[94] = -2.13536E-3; + CoAD[95] = -2.083E-3; CoAD[96] = -1.94E-3; + CoAD[97] = -1.82E-3; CoAD[98] = -1.77E-3; + CoAD[99] = -1.72E-3; CoAD[100] = -1.71104E-3; + CoAD[101] = -1.741E-3; CoAD[102] = -0.0016; + +} + +double fbar_AndersonDarling (long N, double X) +{ + /* This function is not very precise for x < 0.05 */ + const double h = 0.05; /* the step of the interpolation table */ + static int ADFlag = 0; + double q; + double Res, Cor; + int i; + + if (N == 1) { + if (X <= 0.38629436111989) + return 1.0; + if (X >= fdist_XBIGM) + return 0.0; + if (X < 6.0) { + q = 1.0 - 4.0 * exp(-X - 1.0); + return 1.0 - sqrt (q); + } else { + q = 4.0 * exp(-X - 1.0); + return 0.5*q*(1.0 + 0.25*q*(1.0 + 0.5*q*(1.0 + 0.125*q*(5.0 + 3.5*q)))); + } + } + + if (N <= 0) { + util_Warning (1, "fbar_AndersonDarling: N < 1"); + return -1.0; + } + + if (X > 10.0) + /* Sinclair-Spurr upper tail approximation (3.5) */ + return 1.732 * exp(-X) / sqrt(num_Pi * X); + + if (X > 5.0) { + /* asymptotic X: our empirical fit */ + Res = exp (-0.56 - 1.06 * X); + q = exp (-1.03 - 1.06 * X); /* Empirical correction in 1/N */ + return Res + q / N; + } + + if (X <= 0.2) + return 1.0 - fdist_AndersonDarling (N, X); + + if (ADFlag == 0) { + AndersonDarlingInit (); + ADFlag = 1; + } + + i = 1 + (int) (X / h); + q = X / h - i; + + /* Newton backwards quadratic interpolation */ + Res = (F2AD[i - 2] - 2.0 * F2AD[i - 1] + F2AD[i]) * q * (q + 1.0) / 2.0 + + (F2AD[i] - F2AD[i - 1]) * q + F2AD[i]; + + /* Empirical correction in 1/N */ + Cor = (CoAD[i] * (q + 1.0) - CoAD[i - 1] * q) / N; + + Res = 1.0 - Res - Cor; + if (Res >= 1.0) + return 1.0; + if (Res <= 0.0) + return 0.0; + return Res; +} + + +/*=========================================================================*/ + +double fbar_ChiSquare1 (long N, double x) +/* + * Returns an approximation of the complementary Chi square cdf (N degrees + * of freedom). Similar to p:116 of W.J.Kennedy Jr and J.E.Gentle. + * Statistical computing, Dekker, New York, 1980. More precise in the + * tail than simply returning 1 - fdist_ChiSquare. + */ +{ + const double XBIG_CHI = 2000.0; + const double tiers = 0.33333333333333333; + const double pt2 = 0.22222222222222222; + const double moinshuit = -8.3; + const double gam = 0.8862269254527579825931; + double H, E, DemiX, Terme, Sommation, Y; + long i; + + util_Assert (N > 0, "Calling fbar_ChiSquare1 with N < 1"); + if (x <= 0.0) + return 1.0; + if (N >= 150) { + if (x >= N * fdist_XBIG) + return 0.0; + } else { + if (x >= XBIG_CHI) + return 0.0; + } + + if (N > 1000) { + if (x < 2.0) + return 1.0; + x = (pow ((x / N), tiers) - (1.0 - pt2 / N)) / sqrt (pt2 / N); + if (x > 35.0) + return 0.0; + if (x <= moinshuit) + return 1.0; + return fbar_Normal1 (x); + } + + DemiX = x / 2.0; + + if (!(N & 1)) { /* even N */ + Terme = exp (-DemiX); + Sommation = Terme; + for (i = 1; i < N / 2; i++) { + Terme = Terme * DemiX / i; + Sommation += Terme; + } + Y = Sommation; + + } else { + H = 2.0 * fbar_Normal1 (sqrt (x)); + if (N == 1) + return H; + + E = exp (-DemiX); + Terme = sqrt (DemiX) * E / gam; + for (i = 3; i < N; i += 2) { + H += Terme; + Terme = Terme * DemiX * 2.0 / i; + } + Y = H + Terme; + } + + if (Y > 1.0) + return 1.0; + else + return Y; +} + + +/*=========================================================================*/ + +double fbar_ChiSquare2 (long n, int d, double x) +{ + util_Assert (n > 0, "fbar_ChiSquare2: n <= 0"); + if (x <= 0.0) + return 1.0; + return fbar_Gamma (n / 2.0, d, x / 2.0); +} + + +/*=========================================================================*/ + +double fbar_Gamma (double alpha, int d, double x) +{ + const double aLIM = 1.0E5; + const double RENORM = 1.0E100; + const double EPS = EpsArray[d]; + double V[6]; + double v, res, A, B, R, term, dif; + int i; + + util_Assert (alpha > 0.0, "fbar_Gamma: a <= 0"); + util_Assert (d > 0, "fbar_Gamma: d <= 0"); + util_Assert (d < 16, "fbar_Gamma: d > 15"); + if (x <= 0.0) + return 1.0; + if (1.0 == alpha) + return fbar_Expon (x); + + if (alpha >= 70.0) { + if (x >= alpha * fdist_XBIG) + return 0.0; + } else { + if (x >= fdist_XBIGM) + return 0.0; + } + + if (alpha >= aLIM) { + double d2 = x + 1.0/3.0 - alpha - 0.02/alpha; + double S = alpha - 1.0/2.0; + double z = d2 * sqrt((1 + fdist_belog(S/x))/x); + return fbar_Normal1 (z); + } + + if (x <= 1.0 || x < alpha) + return 1.0 - fdist_Gamma (alpha, d, x); + + v = exp (alpha * log (x) - x - num2_LnGamma (alpha)); + + A = 1.0 - alpha; + B = A + x + 1.0; + term = 0.0; + V[0] = 1.0; + V[1] = x; + V[2] = x + 1.0; + V[3] = x * B; + res = V[2] / V[3]; + + do { + A += 1.0; + B += 2.0; + term += 1.0; + V[4] = B * V[2] - A * term * V[0]; + V[5] = B * V[3] - A * term * V[1]; + if (V[5] != 0.0) { + R = V[4] / V[5]; + dif = fabs (res - R); + if (dif <= EPS * R) + return (v * res); + res = R; + } + for (i = 0; i < 4; i++) + V[i] = V[i + 2]; + if (fabs (V[4]) >= RENORM) { + for (i = 0; i < 4; i++) + V[i] /= RENORM; + } + } while (1); + + /* to eliminate a warning from the compiler; never reached */ + return 0.0; +} + + +/*=========================================================================*/ + +static double KSPlusbarAsymp (long n, double x) +{ + /* Compute the probability of the KSPlus distribution using + an asymptotic formula */ + double t = (6.0*n*x + 1); + double z = t*t/(18.0*n); + double v = 1.0 - (2.0*z*z - 4.0*z - 1.0)/(18.0*n); + if (v <= 0.0) + return 0.0; + v = v*exp(-z); + if (v >= 1.0) + return 1.0; + return v; +} + + +/*-------------------------------------------------------------------------*/ + +static double KSPlusbarUpper (long n, double x) +{ + /* Compute the probability of the KSPlus distribution in the upper + tail using Smirnov's stable formula */ + const double EPSILON = 1.0E-10; + double q; + double Sum = 0.0; + double term; + double t; + double LogCom; + double LOGJMAX; + int j; + int jmax = (int)(n - n*x); + + /* We must avoid log(0) for j = jmax and q ~ 1.0 */ + if ((1.0 - x - (double)jmax / n) <= 0.0) + jmax--; + + j = jmax/2; + LogCom = num2_LnFactorial((int)n) - num2_LnFactorial(j) - + num2_LnFactorial((int)(n-j)); + LOGJMAX = LogCom; + + while (j > 0) { + q = (double)j / n + x; + term = LogCom + (j - 1)*log (q) + (n - j)*num2_log1p (-q); + t = exp (term); + Sum += t; + LogCom += log ((double)j / (n - j + 1)); + if (t <= Sum*EPSILON) + break; + j--; + } + + j = jmax/2; + LogCom = LOGJMAX + log ((double)(n - j)/(j + 1)); + j++; + + while (j <= jmax) { + q = (double)j / n + x; + term = LogCom + (j - 1)*log(q) + (n - j)*num2_log1p(-q); + t = exp (term); + Sum += t; + LogCom += log ((double)(n - j)/(j + 1)); + if (t <= Sum*EPSILON) + break; + j++; + } + + Sum *= x; + /* add the term j = 0 */ + Sum += exp (n*num2_log1p (-x)); + return Sum; +} + + +/*=========================================================================*/ + +double fbar_KSPlus (long N, double x) +{ + const double NxParam = 6.5; /* frontier: alternating series */ + const long NParam = 4000; /* frontier: non-alternating series */ + const long NAsymp = 200000; /* frontier: asymptotic */ + + util_Assert (N > 0, "Calling fbar_KSPlus with N < 1"); + if (x <= 0.0) + return 1.0; + if ((x >= 1.0) || (N*x*x >= 370.0)) + return 0.0; + if (N == 1) + return 1.0 - x; + + if (N * x <= NxParam) + return 1.0 - fdist_KSPlus (N, x); + + if (N >= NAsymp) + return KSPlusbarAsymp (N, x); + + if ((N <= NParam) || (N*x*x > 1.0)) + return KSPlusbarUpper(N, x); + +/* return (1.0 - 2.0*x/3.0)*exp(-2.0*N*x*x); */ + return KSPlusbarAsymp (N, x); +} + + +/*=========================================================================*/ + +static double KSSpecial (long n, double x) +{ +#define NLIM 20 + + if ((n * x * x >= 370.0) || (x >= 1.0)) + return 0.0; + if (x <= 0.5 / n) + return 1.0; + if (n == 1) + return 2.0 - 2.0 * x; + + if (x <= 1.0 / n) { + double w; + double t = 2.0 * x - 1.0 / n; + if (n <= NLIM) { + w = num2_Factorial ((int) n); + return 1.0 - w * pow (t, (double) n); + } + w = num2_LnFactorial ((int) n) + n * log (t); + return 1.0 - exp (w); + } + + if (x >= 1.0 - 1.0 / n) { + return 2.0 * pow (1.0 - x, (double) n); + } + return -1.0; +} + +#undef NLIM +/*-------------------------------------------------------------------------*/ + +double fbar_KS1 (long n, double x) +{ + double v = KSSpecial(n, x); + if (v >= 0.0) + return v; + + if (n <= 400) { + if (n*x*x < 4.0) + return 1.0 - fdist_KS1(n, x); + else + return 2.0 * KSPlusbarUpper(n, x); + } + + if (n*x*x >= 2.2) { + if (n <= 200000) + return 2.0 * KSPlusbarUpper(n, x); + return 2.0*KSPlusbarAsymp (n, x); + } + + return 1.0 - fdist_KS1(n, x); +} + + +/*=========================================================================*/ + +double fbar_CramerMises (long N, double x) +{ + return 1.0 - fdist_CramerMises (N, x); +} + + +double fbar_WatsonG (long N, double x) +{ + return 1.0 - fdist_WatsonG (N, x); +} + + +/*=========================================================================*/ + +double fbar_WatsonU (long N, double x) +{ +/* + * Only the asymptotic form has been implemented. In the trivial case + * N = 1, we simply return 0.5 + */ + const double xSepare = 0.15; + if (x <= 0.0) + return 1.0; + if (x >= fdist_XBIG) + return 0.0; + + if (N == 1) /* N = 1, degenerate case */ + return 0.5; + + if (x > xSepare) { + /* this series converges rapidly for x > 0.15 */ + const int JMAX = 10; + int j; + double signe; + double v; + double terme; + double somme; + v = exp (-(x * 2.0 * num_Pi * num_Pi)); + signe = 1.0; + somme = 0.0; + j = 1; + do { + terme = pow (v, (double) j * j); + somme += signe * terme; + signe = -signe; + ++j; + } while (!(terme < DBL_EPSILON || j > JMAX)); + util_Warning (j > JMAX, "fbar_WatsonU: sum1 has not converged"); + v = 2.0 * somme; + if (v <= 0.0) + return 0.0; + return v; + } + + return 1.0 - fdist_WatsonU (N, x); +} + + +/*=========================================================================*/ + + + + +/******************************\ + * + * DISCRETE DISTRIBUTIONS + * +\******************************/ + + +/*=========================================================================*/ + +static const double epsilonScan = 1.0E-7; + +static double ScanGlaz (long N, double d, long m) +{ + long j, jmoy; + double temp; + double jr, jm1r, Nr = N; + int signe; + double q = 1.0 - d; + double Q4, Q3, Q2, Q1; + double Bin, BinMoy; + + jmoy = (long) ((N + 1) * d); /* max term of the Binomial */ + if (jmoy < m - 1) + jmoy = m - 1; + + /*---------------------------------------------------------*/ + /* Compute Q1: formula (2.5) in Glaz (1989) */ + /* Compute Q2: formula (A.6) in Berman and Eagleson (1985) */ + /* Compute Q3, Q4 : Theorem (3.2) in Glaz (1989) */ + /*---------------------------------------------------------*/ + + /* compute the probability of term j = jmoy */ + Q1 = 0.0; + for (j = 1; j <= jmoy; j++) { + jr = j; + Q1 += log (Nr - jr + 1.0) - log (jr); + } + Q1 += jmoy * log (d) + (Nr - jmoy) * log (q); + BinMoy = exp (Q1); + Q1 = BinMoy; + jm1r = jmoy - m + 1; + if ((jmoy - m + 1) & 1) + signe = -1; + else + signe = 1; + Q2 = signe * BinMoy; + Q3 = signe * BinMoy * (2.0 - jm1r * jm1r + jm1r); + Q4 = signe * BinMoy * (jm1r + 1.0) * (jm1r + 2.0) * (6.0 + jm1r * jm1r - + 5.0 * jm1r); + + /* compute the probability of terms j > jmoy */ + if ((jmoy - m + 1) & 1) + signe = -1; + else + signe = 1; + + jm1r = jmoy - m + 1; + Bin = BinMoy; + for (j = jmoy + 1; j <= N; j++) { + jr = j; + jm1r += 1.0; + signe = -signe; + Bin = (Bin * (Nr - jr + 1.0) * d) / (jr * q); + if (Bin < epsilonScan) + break; + Q1 += Bin; + Q2 += signe * Bin; + Q3 += signe * Bin * (2.0 - jm1r * jm1r + jm1r); + Q4 += signe * Bin * (jm1r + 1.0) * (jm1r + 2.0) * (6.0 + jm1r * jm1r - + 5.0 * jm1r); + } + + Q1 = 1.0 - Q1; + Q3 /= 2.0; + Q4 /= 12.0; + if (m == 3) { + /* Problem with this formula; I do not get the same results as Glaz */ + Q4 = ((Nr * (Nr - 1.0) * d * d * pow (q, Nr - 2.0)) / 8.0 + + Nr * d * 2.0 * pow (1.0 - 2.0 * d, Nr - 1.0)) + - 4.0 * pow (1.0 - 2.0 * d, Nr); + if (d < 1.0 / 3.0) { + Q4 += Nr * d * 2.0 * pow (1.0 - 3.0 * d, Nr - 1.0) + + 4.0 * pow (1.0 - 3.0 * d, Nr); + } + } + /* compute probability: Glaz, equations (3.2) and (3.3) */ + Q3 = Q1 - Q2 - Q3; + Q4 = Q3 - Q4; + /* when the approximation is bad, avoid overflow */ + temp = log (Q3) + (Nr - m - 2.0) * log (Q4 / Q3); + if (temp >= 0.0) + return 0.0; + if (temp < (-30.0)) + return 1.0; + Q4 = exp (temp); + return 1.0 - Q4; +} + +/*----------------------------------------------------------------------*/ + +static double ScanWNeff (long N, double d, long m) +{ + double q = 1.0 - d; + double temp; + double Bin; + double Sum; + long j; + + /*--------------------------------------*/ + /* Anderson-Titterington: equation (4) */ + /*--------------------------------------*/ + + /* compute the probability of term j = m */ + Sum = 0.0; + for (j = 1; j <= m; j++) { + Sum += log ((double) (N - j + 1)) - log ((double) j); + } + Sum += m * log (d) + (N - m) * log (q); + Bin = exp (Sum); + temp = (m / d - N - 1.0) * Bin; + Sum = Bin; + + /* compute the probability of terms j > m */ + for (j = m + 1; j <= N; j++) { + Bin *= (N - j + 1) * d / (j * q); + if (Bin < epsilonScan) + break; + Sum += Bin; + } + Sum = 2.0 * Sum + temp; + return Sum; +} + +/*----------------------------------------------------------------------*/ + +static double ScanAsympt (long N, double d, long m) +{ + double Kappa; + double temp; + double Theta; + double Sum; + + /*--------------------------------------------------------------*/ + /* Anderson-Titterington: asymptotic formula after equation (4) */ + /*--------------------------------------------------------------*/ + + Theta = sqrt (d / (1.0 - d)); + temp = sqrt ((double) N); + Kappa = m / (d * temp) - temp; + temp = Theta * Kappa; + temp = temp * temp / 2.0; + Sum = 2.0 * fbar_Normal1 (Theta * Kappa) + + (Kappa * Theta * exp (-temp)) / (d * sqrt (2.0 * num_Pi)); + return Sum; +} + +/*----------------------------------------------------------------------*/ + +double fbar_Scan (long N, double d, long m) +{ + double mu; + double prob; + + util_Assert (N >= 2, "Calling fbar_Scan with N < 2"); + util_Assert (d > 0.0 && d < 1.0, + "Calling fbar_Scan with d outside (0,1)"); + if (m > N) + return 0.0; + if (m <= 1) + return 1.0; + if (m <= 2) { + if ((N - 1) * d >= 1.0) + return 1.0; + return (1.0 - pow (1.0 - (N - 1) * d, (double) N)); + } + if (d >= 0.5 && m <= (N + 1) / 2.0) + return 1.0; + if (d > 0.5) + return (-1.0); /* Error */ + /* util_Assert (d <= 0.5, "Calling fbar_Scan with d > 1/2"); */ + + mu = N * d; /* mean of a binomial */ + if (m <= mu + d) + return 1.0; + if (mu <= 10.0) + return ScanGlaz (N, d, m); + prob = ScanAsympt (N, d, m); + if ((d >= 0.3 && N >= 50.0) || (N * d * d >= 250.0 && d < 0.3)) { + if (prob <= 0.4) + return prob; + } + prob = ScanWNeff (N, d, m); + if (prob <= 0.4) + return prob; + prob = ScanGlaz (N, d, m); + if (prob > 0.4 && prob <= 1.0) + return prob; + return 1.0; +} + + +/*=========================================================================*/ + +double fbar_Geometric (double p, long n) +{ + util_Assert (p >= 0.0 && p <= 1.0, "fbar_Geometric: p not in [0, 1]"); + if (n <= 0) + return 1.0; + if (p >= 1.0) /* In fact, p == 1 */ + return 0.0; + if (p <= 0.0) /* In fact, p == 0 */ + return 1.0; + + return pow (1.0 - p, (double) n); +} + + +/*=========================================================================*/ + +double fbar_Poisson1 (double lam, long s) +{ + const double lamlim = 150.0; + long i; + double term, sum; + + util_Assert (lam >= 0.0, "fbar_Poisson1: lambda < 0"); + if (s <= 0) + return 1.0; + + /* If lam > lamlim, we use the Chi2 distribution according to the exact + relation, with 2s + 2 degrees of freedom + + fdist_Poisson (lam, s) = 1 - fdist_ChiSquare (2s + 2, 2*lam) + + which also equals 1 - fdist_Gamma (s + 1, lam) */ + if (lam > lamlim) + return fdist_Gamma ((double) s, 15, lam); + + if (s <= lam) + return 1.0 - fdist_Poisson1 (lam, s - 1); + + /* Sum at least IMAX prob. terms from i = s to i = oo */ + sum = term = fmass_PoissonTerm1 (lam, s); + i = s + 1; + while (term > fmass_Epsilon || i <= s + IMAX) { + term *= lam / i; + sum += term; + i++; + } + return sum; +} + + +/*=========================================================================*/ + +double fbar_Poisson2 (fmass_INFO W, long s) +/* + * fbar_Poisson (lam, s) = 1 - fdist_Poisson (lam, s - 1) + */ +{ + double lam; + + util_Assert (W != NULL, "fbar_Poisson2: fmass_INFO is NULL pointer"); + lam = W->paramR[0]; + + if (s <= 0) + return 1.0; + + /* For large lam, we use the Chi2 distribution according to the exact + relation, with 2s + 2 degrees of freedom + + fdist_Poisson (lam, s) = 1 - fdist_ChiSquare (2s + 2, 2*lam) + fdist_Poisson (lam, s) = 1 - fdist_Gamma (s + 1, lam) + */ + + if (W->cdf == NULL) + return fdist_Gamma ((double) s, 15, lam); + + if (s > W->smax) + return fbar_Poisson1 (lam, s); + + if (s < W->smin) + return 1.0; + + if (s > W->smed) + /* We keep the complementary distribution in the upper part of cdf */ + return W->cdf[s - W->smin]; + else + return 1.0 - W->cdf[s - 1 - W->smin]; +} + + +/*=========================================================================*/ + +double fbar_Binomial2 (fmass_INFO W, long s) +{ + double p; + long n; + + util_Assert (W != NULL, "fbar_Binomial2: fmass_INFO is NULL pointer"); + n = W->paramI[0]; + p = W->paramR[0]; + util_Assert (p >= 0.0 && p <= 1.0, "fbar_Binomial2: p not in [0, 1]"); + + if (0 == n) + return 1.0; + if (s < 1) + return 1.0; + if (s > n) + return 0.0; + if (p == 0.0) + return 0.0; + if (p == 1.0) + return 1.0; + + if (W->cdf != NULL) { + if (s >= W->smax) { + /* Add IMAX dominant terms to get a few decimals in the tail */ + const double q = 1.0 - p; + double z, sum, term; + long i; + sum = term = fmass_BinomialTerm3 (n, p, s); + if (fabs (q) > 0.0) { + z = p / q; + } else { + z = 0.0; + util_Warning (1, "fbar_Binomial2: p / q = infinite"); + } + i = s; + while (i < n && i < s + IMAX) { + term = term * z * (n - i) / (i + 1); + sum += term; + i++; + } + return sum; + /* return fdist_Beta (s, n - s + 1, 10, p); */ + } + + if (s <= W->smin) + return 1.0; + + if (s > W->smed) + /* We keep the complementary distribution in the upper part of cdf */ + return W->cdf[s - W->smin]; + else + return 1.0 - W->cdf[s - 1 - W->smin]; + + } else { + return 1.0 - fdist_Binomial1 (n, p, s - 1); + } +} + + +/*=========================================================================*/ + +double fbar_NegaBin2 (fmass_INFO W, long s) +{ + double p; + long n; + + util_Assert (W != NULL, "fbar_NegaBin2: fmass_INFO is NULL pointer"); + n = W->paramI[0]; + p = W->paramR[0]; + util_Assert (p >= 0.0 && p <= 1.0, "fbar_NegaBin2: p not in [0, 1]"); + + if (s < 1) + return 1.0; + if (p >= 1.0) /* In fact, p == 1 */ + return 0.0; + if (p <= 0.0) /* In fact, p == 0 */ + return 1.0; + + if (W->cdf == NULL) + return fdist_Binomial1 (s - 1 + n, p, n - 1); + + if (s >= W->smax) + return fdist_Binomial1 (s - 1 + n, p, n - 1); + if (s <= W->smin) + return 1.0; + if (s > W->smed) + /* We keep the complementary distribution in the upper part of cdf */ + return W->cdf[s - W->smin]; + else + return 1.0 - W->cdf[s - 1 - W->smin]; + +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/fcho.c b/cbits/testu/src/fcho.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fcho.c @@ -0,0 +1,262 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: fcho.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "fcho.h" +#include "ftab.h" +#include "swrite.h" + +#include +#include +#include + + + +#define EPS2 1.0E-10 +#define LEN 7 + + + + +typedef struct { + double a; + double b; + double c; + fcho_FuncType F; + char *name; +} Sample_Param; + + + +int fcho_Resolution = 30; + + +/*-------------------------------- Functions ------------------------------*/ + + + +double fcho_Linear (double x) +{ + return x; +} + + +/*=========================================================================*/ + +double fcho_LinearInv (double x) +{ + return 1.0/x; +} + + +/*=========================================================================*/ + +double fcho_2Pow (double x) +{ + return pow (2.0, x); +} + + +/*=========================================================================*/ + +static void WriteSample (void *vpar, long junk, long j) +{ + Sample_Param *param = vpar; + const double a = param->a; + const double b = param->b; + const double c = param->c; + + printf ("Choose "); + if (ftab_Style == ftab_Latex) + printf ("$"); + if (param->name) + printf ("%s", param->name); + + if (param->F == fcho_2Pow) + printf (" = 2^{ "); + else if (param->F == fcho_Linear) + printf (" = "); + else + printf (" = F("); + + if (a > EPS2) + printf ("%4.2f*i ", a); + + if (fabs (b*j) > EPS2) { + if (b*j > EPS2) + printf ("+ "); + else + printf ("- "); + if (fabs (b - 1.0) > EPS2) + printf ("%4.2f*%1ld ", fabs (b), labs (j)); + else + printf ("%1ld ", labs (j)); + } + + if (c > EPS2) + printf ("+ %4.2f", fabs (c)); + else if (c < -EPS2) + printf ("- %4.2f", fabs (c)); + + if (param->F == fcho_2Pow) + printf ("}"); + else if (param->F == fcho_Linear) + ; + else + printf (")"); + + if (ftab_Style == ftab_Latex) + printf ("$"); + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static double ChooseSample (void *vpar, long i, long j) +{ + Sample_Param *param = vpar; + double x, y; + + if (swrite_Basic) + WriteSample (vpar, 0, j); + x = i * param->a + j * param->b + param->c; + y = param->F(x); + return y; +} + + +/*-------------------------------------------------------------------------*/ + +fcho_Cho * fcho_CreateSampleSize (double a, double b, double c, + fcho_FuncType F, char *name) +{ + fcho_Cho *cho; + Sample_Param *param; + size_t len; + char *name0 = "n"; + + cho = util_Malloc (sizeof (fcho_Cho)); + param = util_Malloc (sizeof (Sample_Param)); + param->a = a; + param->b = b; + param->c = c; + if (NULL == F) + param->F = fcho_2Pow; + else + param->F = F; + + if (NULL == name) + name = name0; + len = strlen (name); + cho->name = util_Calloc (len + 1, sizeof (char)); + strncpy (cho->name, name, (size_t) len); + cho->param = param; + cho->Write = WriteSample; + cho->Choose = ChooseSample; + param->name = cho->name; + return cho; +} + + +/*-------------------------------------------------------------------------*/ + +void fcho_DeleteSampleSize (fcho_Cho *cho) +{ + if (NULL == cho) + return; + cho->name = util_Free (cho->name); + cho->param = util_Free (cho->param); + util_Free (cho); +} + + +/*=========================================================================*/ + +long fcho_ChooseParamL (fcho_Cho *cho, long min, long max, long i, long j) +{ + double n; + + util_Assert (cho, "fcho_ChooseParamL: cho is NULL"); + n = cho->Choose (cho->param, i, j); + + if (n < min) { + if (cho->name) + printf ("%s < %ld\n\n", cho->name, min); + return -1; + } + if (n > max) { + if (cho->name) + printf ("%s > %ld\n\n", cho->name, max); + return -1; + } + return (long) n; +} + + +/*=========================================================================*/ + +int fcho_Chooses (int r, int s, int prec) +{ + int s1; + + if (r + s <= prec) + return s; + + s1 = prec - r; + if (s1 <= 0) + printf ("r >= Resolution of generator\n\n"); + + return s1; +} + + +/*=========================================================================*/ + +fcho_Cho2 * fcho_CreateCho2 (fcho_Cho *Chon, fcho_Cho *Chop2) +{ + fcho_Cho2 *cho; + cho = util_Malloc (sizeof (fcho_Cho2)); + memset (cho, 0, sizeof (fcho_Cho2)); + cho->Chon = Chon; + cho->Chop2 = Chop2; + return cho; +} + +/*-------------------------------------------------------------------------*/ + +void fcho_DeleteCho2 (fcho_Cho2 *cho) +{ + if (NULL == cho) + return; + util_Free (cho); +} + +/*=========================================================================*/ diff --git a/cbits/testu/src/fdist.c b/cbits/testu/src/fdist.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fdist.c @@ -0,0 +1,3585 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: fdist.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "fdist.h" +#include "fmass.h" +#include "fbar.h" + +#include "num.h" +#include "num2.h" +#include "util.h" +#include "tables.h" + +#include +#include +#include +#include + + +double fdist_belog (double); +void fdist_CalcB4 (double, double *, double *, double *, double *); +static double Pomeranz (long n, double x); + + +const double fdist_XINF = DBL_MAX; /* x infinity for some distributions */ +const double fdist_XBIG = 100.0; /* x infinity for some distributions */ +const double fdist_XBIGM = 1000.0; /* x infinity for some distributions */ + +/* EpsArray[j]: Epsilon required for j decimal degits of precision */ +static const double EpsArray[] = { + 0.5, 0.5E-1, 0.5E-2, 0.5E-3, 0.5E-4, 0.5E-5, 0.5E-6, 0.5E-7, 0.5E-8, + 0.5E-9, 0.5E-10, 0.5E-11, 0.5E-12, 0.5E-13, 0.5E-14, 0.5E-15, 0.5E-16, + 0.5E-17, 0.5E-18, 0.5E-19, 0.5E-20, 0.5E-21, 0.5E-22, 0.5E-23, 0.5E-24, + 0.5E-25, 0.5E-26, 0.5E-27, 0.5E-28, 0.5E-29, 0.5E-30, 0.5E-31, 0.5E-32, + 0.5E-33, 0.5E-34, 0.5E-35 +}; + +/* static const double EpsilonLR = 1.0E-15; */ +#define X_EPSILON 1.0e-3 /* For x --> 0 */ + +#define TWOPI 6.28318530717958647688 + + + +/*-------------------------------------------------------------------------*/ + +double fdist_belog (double x) +/* + * This is the function (1 - x*x + 2*x*log(x)) / ((1 - x)*(1 - x)) + */ +{ + if (x > 1.0) + return -fdist_belog(1.0/x); + if (x < 1.0e-20) + return 1.0; + if (x < 0.9) + return (1.0 - x * x + 2.0 * x * log (x)) / ((1.0 - x) * (1.0 - x)); + if (x == 1.0) + return 0.0; + { + /* For x near 1, use a series expansion to avoid loss of precision. */ + double term; + const double EPS = 1.0e-12; + const double Y = 1.0 - x; + double ypow = 1.0; + double sum = 0.0; + int j = 2; + do { + ypow *= Y; + term = ypow / (j * (j + 1)); + sum += term; + j++; + } while (fabs (term / sum) > EPS); + + return 2.0 * sum; + } +} + + +/*=========================================================================*/ + +double fdist_Unif (double x) +{ + if (x <= 0.0) + return 0.0; + if (x >= 1.0) + return 1.0; + return x; +} + + +/*=========================================================================*/ + +double fdist_Expon (double x) +{ + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + if (x > X_EPSILON) + return 1.0 - exp (-x); + + /* Avoid loss of precision for small x */ + return x * (1.0 - x * (0.5 - x*(1.0 / 6.0 - x/24.0))); +} + + +/*=========================================================================*/ + +double fdist_Weibull (double c, double x) +{ + double y; + util_Assert (c > 0.0, "fdist_Weibull: c <= 0"); + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG && c >= 1.0) + return 1.0; + + y = c*log(x); + if (y >= 5.0) + return 1.0; + y = exp(y); + + if (y > X_EPSILON) + return (1.0 - exp (-y)); + + /* Avoid loss of precision for small y */ + return y * (1.0 - y * (0.5 - y*(1.0/6.0 - y/24.0))); +} + + +/*=========================================================================*/ + +double fdist_ExtremeValue (double x) +{ + if (x <= -10.0) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + return exp (-exp (-x)); +} + + +/*=========================================================================*/ + +double fdist_Logistic (double x) +{ + if (x <= -fdist_XBIG) + return exp (x); + if (x >= fdist_XBIG) + return 1.0; + return 1.0 / (1.0 + exp (-x)); +} + + +/*=========================================================================*/ + +double fdist_Pareto (double c, double x) +{ + double y = c*log(x); + util_Assert (c > 0.0, "fdist_Pareto: c <= 0"); + if (x <= 1.0) + return 0.0; + if (y >= 50.0) + return 1.0; + y = exp(y); + return (1.0 - 1.0 / y); +} + + +/*=========================================================================*/ + +double fdist_Normal1 (double x) +/* + * Returns P[X <= x] for the normal distribution. + * As in p:90 of W.J.Kennedy Jr and J.E.Gentle. Statistical computing. + * Dekker, New York, 1980. + */ +{ + static const double Racinedeux = 1.4142135623730950488; + static const double racineunsurpi = 0.56418958354775628694; + + static const double p10 = 2.4266795523053175e2; + static const double p11 = 2.1979261618294152e1; + static const double p12 = 6.9963834886191355; + static const double p13 = -3.5609843701815385e-2; + + static const double p20 = 3.004592610201616005e2; + static const double p21 = 4.519189537118729422e2; + static const double p22 = 3.393208167343436870e2; + static const double p23 = 1.529892850469404039e2; + static const double p24 = 4.316222722205673530e1; + static const double p25 = 7.211758250883093659e0; + static const double p26 = 5.641955174789739711e-1; + static const double p27 = -1.368648573827167067e-7; + + static const double p30 = -2.99610707703542174e-3; + static const double p31 = -4.94730910623250734e-2; + static const double p32 = -2.26956593539686930e-1; + static const double p33 = -2.78661308609647788e-1; + static const double p34 = -2.23192459734184686e-2; + + static const double q10 = 2.1505887586986120e2; + static const double q11 = 9.1164905404514901e1; + static const double q12 = 1.5082797630407787e1; + static const double q13 = 1.0; + + static const double q20 = 3.004592609569832933e2; + static const double q21 = 7.909509253278980272e2; + static const double q22 = 9.313540948506096211e2; + static const double q23 = 6.389802644656311665e2; + static const double q24 = 2.775854447439876434e2; + static const double q25 = 7.700015293522947295e1; + static const double q26 = 1.278272731962942351e1; + static const double q27 = 1.0; + + static const double q30 = 1.06209230528467918e-2; + static const double q31 = 1.91308926107829841e-1; + static const double q32 = 1.05167510706793207e0; + static const double q33 = 1.98733201817135256e0; + static const double q34 = 1.0; + + static const double xasymp = 40.0; + double Ycarre, unsurY2, Y, R, erf; + + if (x < -xasymp) + return 0.0; + if (x > xasymp) + return 1.0; + + if (x < 0.0) + return 1.0 - fdist_Normal1 (-x); + + Y = x / Racinedeux; + Ycarre = x * x / 2.0; + if (Y < 0.447) { + R = (p10 + Ycarre * (p11 + Ycarre * (p12 + Ycarre * p13))) / + (q10 + Ycarre * (q11 + Ycarre * (q12 + Ycarre * q13))); + erf = Y * R; + } else { + if (Y <= 4.0) { + R = (p20 + Y * (p21 + Y * (p22 + Y * (p23 + Y * (p24 + Y * (p25 + + Y * (p26 + Y * p27))))))) / (q20 + Y * (q21 + + Y * (q22 + Y * (q23 + Y * (q24 + Y * (q25 + Y * (q26 + + Y * q27))))))); + if (-Ycarre < DBL_MIN_EXP * num_Ln2) + erf = 1.0; + else + erf = 1.0 - exp (-Ycarre) * R; + } else { + double temp; + unsurY2 = 1.0 / Ycarre; + R = (p30 + unsurY2 * (p31 + unsurY2 * (p32 + unsurY2 * + (p33 + unsurY2 * p34)))) / (q30 + unsurY2 * + (q31 + unsurY2 * (q32 + unsurY2 * (q33 + unsurY2 * q34)))); + if (-Ycarre < DBL_MIN_EXP * num_Ln2) + temp = 0.0; + else + temp = exp (-Ycarre); + erf = 1.0 - (temp / Y) * (racineunsurpi + R / Ycarre); + } + } + return ((1.0 + erf) / 2.0); +} + + +/**************************************************************************/ +/* + * The precision of double is 16 decimals; we shall thus use COEFFMAX = 24 + * coefficients. But the approximation is good to 30 decimals of precision + * with 44 coefficients. + */ +#define COEFFMAX 24 + +static const double Normal2_A[44] = { + 6.10143081923200417926465815756e-1, + -4.34841272712577471828182820888e-1, + 1.76351193643605501125840298123e-1, + -6.0710795609249414860051215825e-2, + 1.7712068995694114486147141191e-2, + -4.321119385567293818599864968e-3, + 8.54216676887098678819832055e-4, + -1.27155090609162742628893940e-4, + 1.1248167243671189468847072e-5, + 3.13063885421820972630152e-7, + -2.70988068537762022009086e-7, + 3.0737622701407688440959e-8, + 2.515620384817622937314e-9, + -1.028929921320319127590e-9, + 2.9944052119949939363e-11, + 2.6051789687266936290e-11, + -2.634839924171969386e-12, + -6.43404509890636443e-13, + 1.12457401801663447e-13, + 1.7281533389986098e-14, + -4.264101694942375e-15, + -5.45371977880191e-16, + 1.58697607761671e-16, + 2.0899837844334e-17, + -5.900526869409e-18, + -9.41893387554e-19, + 2.14977356470e-19, + 4.6660985008e-20, + -7.243011862e-21, + -2.387966824e-21, + 1.91177535e-22, + 1.20482568e-22, + -6.72377e-25, + -5.747997e-24, + -4.28493e-25, + 2.44856e-25, + 4.3793e-26, + -8.151e-27, + -3.089e-27, + 9.3e-29, + 1.74e-28, + 1.6e-29, + -8.0e-30, + -2.0e-30 +}; + + +double fdist_Normal2 (double x) +/* + * Returns P[X < x] for the normal distribution. + * As in J. L. Schonfelder, Math. of Computation, Vol. 32, + * pp 1232--1240, (1978). + */ +{ + double t, r; + if (x <= -fdist_XBIG) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + + x = -x / num_Rac2; + if (x < 0) { + x = -x; + t = (x - 3.75) / (x + 3.75); + r = 1.0 - 0.5 * exp (-x * x) * num2_EvalCheby (Normal2_A, COEFFMAX, t); + } else { + t = (x - 3.75) / (x + 3.75); + r = 0.5 * exp (-x * x) * num2_EvalCheby (Normal2_A, COEFFMAX, t); + } + return (r); +} + + +/*=========================================================================*/ +#ifdef HAVE_ERF + +double fdist_Normal3 (double x) +{ + return (erfc (-x * num_1Rac2)) / 2.0; +} + +#endif + + +/*=========================================================================*/ + +double fdist_Normal4 (double x) +{ + static const double V[121] = { + 1.2533141373155, 1.137490921203605, 1.037824575853727, + 0.951527192071207, 0.8763644564536924, 0.8105337152790306, + 0.7525711790634081, 0.7012808218544303, 0.6556795424187987, + 0.61495459615093, 0.5784303460476312, 0.5455421356582171, + 0.5158156382179634, 0.4888504415275737, 0.4643069280394423, + 0.4418957328326002, 0.4213692292880546, 0.4025146181296722, + 0.3851482907984348, 0.3691112106902635, 0.3542651113297938, + 0.3404893532870847, 0.3276783146905521, 0.31573921586941, + 0.3045902987101033, 0.2941592970402893, 0.284382146748493, + 0.2752018941576065, 0.2665677689682238, 0.2584343943120386, + 0.2507611114439651, 0.243511400615456, 0.2366523829135607, + 0.230154390478801, 0.2239905946538289, 0.2181366833614714, + 0.2125705804420318, 0.2072722008565011, 0.2022232366330547, + 0.1974069692375194, 0.1928081047153158, 0.1884126285076003, + 0.1842076773079702, 0.1801814257143918, 0.1763229857571027, + 0.1726223176578506, 0.1690701504076941, 0.1656579109468773, + 0.1623776608968675, 0.1592220399363674, 0.1561842150339759, + 0.153257834853479, 0.1504369887362691, 0.1477161697413935, + 0.145090241289131, 0.1425544070104023, 0.1401041834530503, + 0.1377353753382303, 0.1354440530967635, 0.1332265324471292, + 0.1310793558044918, 0.1289992753343376, 0.126983237485437, + 0.1250283688553504, 0.1231319632579323, 0.1212914698765462, + 0.119504482399253, 0.1177687290432979, 0.1160820633859823, + 0.1144424559276431, 0.112847986320103, 0.1112968362007359, + 0.1097872825783083, 0.1083176917221132, 0.1068865135106745, + 0.1054922762005562, 0.1041335815795983, 0.1028091004723001, + 0.1015175685681028, 0.1002577825460485, 0.09902859647173194, + 0.09782891844465691, 0.09665770747608191, 0.09551397057921558, + 0.09439676005522439, 0.09330517095996169, 0.09223833873763035, + 0.09119543700877471, 0.09017567550106469, 0.08917829811230435, + 0.08820258109597616, 0.08724783136042988, 0.08631338487354936, + 0.08539860516539227, 0.08450288192189578, 0.08362562966329139, + 0.08276628650136918, 0.08192431297018954, 0.08109919092525536, + 0.08029042250654048, 0.07949752916111721, 0.07872005072144664, + 0.07795754453568722, 0.07720958464664668, 0.07647576101624852, + 0.07575567879261112, 0.07504895761704659, 0.07435523096847724, + 0.07367414554294564, 0.07300536066605566, 0.07234854773633338, + 0.07170338969763433, 0.07106958053885212, 0.07044682481930167, + 0.06983483721825942, 0.06923334210724434, 0.06864207314371742, + 0.06806077288496332, 0.0674891924209997, 0.06692709102543307, + 0.06637423582325017 + }; + + int j; + lebool negatif; + double t, u, z, h; + double r, r1, r2, r3, r4, r5, r6, r7, r8; + + if (x <= -fdist_XBIG) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + if (x < 0.0) { + negatif = TRUE; + x = -x; + } else { + negatif = FALSE; + } + j = (int) (8.0 * x + 0.5); + if (j > 120) + j = 120; + z = 0.125 * j; + h = x - z; + r = V[j]; + r1 = r * z - 1.0; + r2 = 0.5 * (r + z * r1); + r3 = (r1 + z * r2) / 3.0; + r4 = 0.25 * (r2 + z * r3); + r5 = 0.2 * (r3 + z * r4); + r6 = (r4 + z * r5) / 6.0; + r7 = (r5 + z * r6) / 7.0; + r8 = 0.125 * (r6 + z * r7); + t = r + h * (r1 + h * (r2 + h * (r3 + h * (r4 + h * (r5 + h * (r6 + + h * (r7 + h * r8))))))); + u = t * exp (-0.5 * x * x - 0.9189385332046727); + if (negatif) + return u; + else + return 1.0 - u; +} + + +/*=========================================================================*/ + +static double InitBiNormal (double x, double y, double rho) +{ + /* The special cases of the BiNormal */ + if (fabs (rho) > 1.0) { + util_Error ("fdist_BiNormal: |rho| > 1"); + return -1.0; + } + if (x == 0.0 && y == 0.0) + return 0.25 + asin(rho)/TWOPI; + if (rho == 1.0) { + x = util_Min(x,y); + return fdist_Normal2 (x); + } + if (rho == 0.0) { + return fdist_Normal2 (x) * fdist_Normal2 (y); + } + if (rho == -1.0) { + if (y <= -x) + return 0.0; + else + return fdist_Normal2 (x) - fdist_Normal2 (-y); + } + if ((x <= -fdist_XBIG) || (y <= -fdist_XBIG)) + return 0.0; + if (x >= fdist_XBIG) + return fdist_Normal2 (y); + if (y >= fdist_XBIG) + return fdist_Normal2 (x); + + return -2.0; +} + + +/*=========================================================================*/ + +double fdist_BiNormal1 (double x, double y, double rho, int ndig) +{ + double a2, ap, b, cn, conex, ex, g2, gh, gk, gw, h2, h4, rr, s1, s2, + sgn, sn, sp, sqr, t, w2, wh, wk; + int is = -1; + int flag = 1; + const double ah = -x; + const double ak = -y; + const double con = num_Pi * num_TENNEGPOW[ndig]; + const double EPSILON = 0.5 * num_TENNEGPOW[ndig]; + + util_Assert (ndig <= 15, "fdist_BiNormal1: ndig > 15"); + + b = InitBiNormal (x, y, rho); + if (b >= 0.0) + return b; + + gh = fdist_Normal2 (-ah) / 2.0; + gk = fdist_Normal2 (-ak) / 2.0; + + b = 0; + rr = (1 - rho) * (1 + rho); + sqr = sqrt (rr); + flag = 1; + if (ah != 0) { + b = gh; + if (ah * ak < 0) + b = b - .5; + else if (ah * ak == 0) { + flag = 0; + } + } else if (ak == 0) { + return asin (rho) / TWOPI + .25; + } + if (flag) + b += gk; + if (ah != 0) { + flag = 0; + wh = -ah; + wk = (ak / ah - rho) / sqr; + gw = 2 * gh; + is = -1; + } + + do { + if (flag) { + wh = -ak; + wk = (ah / ak - rho) / sqr; + gw = 2 * gk; + is = 1; + } + flag = 1; + sgn = -1; + t = 0; + if (wk != 0) { + if (fabs (wk) >= 1) { + if (fabs (wk) == 1) { + t = wk * gw * (1 - gw) / 2; + b = b + sgn * t; + if (is >= 0) + break; + else + continue; + } else { + sgn = -sgn; + wh = wh * wk; + g2 = fdist_Normal2 (wh); + wk = 1 / wk; + if (wk < 0) + b = b + .5; + b = b - (gw + g2) / 2 + gw * g2; + } + } + h2 = wh * wh; + a2 = wk * wk; + h4 = h2 * .5; + ex = 0; + if (h4 < 150.0) + ex = exp (-h4); + w2 = h4 * ex; + ap = 1; + s2 = ap - ex; + sp = ap; + s1 = 0; + sn = s1; + conex = fabs (con / wk); + do { + cn = ap * s2 / (sn + sp); + s1 = s1 + cn; + if (fabs (cn) <= conex) + break; + sn = sp; + sp = sp + 1; + s2 = s2 - w2; + w2 = w2 * h4 / sp; + ap = -ap * a2; + } while (1); + t = (atan (wk) - wk * s1) / TWOPI; + b = b + sgn * t; + } + if (is >= 0) + break; + } while (ak != 0); + + if (b < EPSILON) + b = 0; + if (b > 1) + b = 1; + return b; +} + + +/*=========================================================================*/ + +double fdist_BiNormal2 (double dh, double dk, double rho) +{ + const double twopi = 2.0 * num_Pi; + double W[11][3]; + double X[11][3]; + double h, k, hk, bvn, hs, asr, sn, as, a, b, c, d, sp, rs, ep, bs, xs; + int i, lg, ng, is; + + bvn = InitBiNormal (dh, dk, rho); + if (bvn >= 0.0) + return bvn; +/* + I have made small changes in Genz's Matlab function to make it compatible + with module fdist. (R. Simard) +*/ + +/* +// Copyright (C) 2005, Alan Genz, All rights reserved. +// +// Redistribution and use in source and binary forms, with or without +// modification, are permitted provided the following conditions are met: +// 1. Redistributions of source code must retain the above copyright +// notice, this list of conditions and the following disclaimer. +// 2. Redistributions in binary form must reproduce the above copyright +// notice, this list of conditions and the following disclaimer in the +// documentation and/or other materials provided with the distribution. +// 3. The contributor name(s) may not be used to endorse or promote +// products derived from this software without specific prior written +// permission. +// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +// "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +// LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +// FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +// COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +// INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +// BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS +// OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +// ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR +// TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +// USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +// +// function p = bvnl( dh, dk, r ) +// +// A function for computing bivariate normal probabilities. +// bvnl calculates the probability that x < dh and y < dk. +// parameters +// dh 1st upper integration limit +// dk 2nd upper integration limit +// r correlation coefficient +// +// Author +// Alan Genz +// Department of Mathematics +// Washington State University +// Pullman, Wa 99164-3113 +// Email : alangenz@wsu.edu +// This function is based on the method described by +// Drezner, Z and G.O. Wesolowsky, (1989), +// On the computation of the bivariate normal inegral, +// Journal of Statist. Comput. Simul. 35, pp. 101-107, +// with major modifications for double precision, for |r| close to 1, +// and for matlab by Alan Genz - last modifications 7/98. +// +// p = bvnu( -dh, -dk, r ); +// return +// +// end bvnl +// +// function p = bvnu( dh, dk, r ) +// +// A function for computing bivariate normal probabilities. +// bvnu calculates the probability that x > dh and y > dk. +// parameters +// dh 1st lower integration limit +// dk 2nd lower integration limit +// r correlation coefficient +// +// Author +// Alan Genz +// Department of Mathematics +// Washington State University +// Pullman, Wa 99164-3113 +// Email : alangenz@wsu.edu +// +// This function is based on the method described by +// Drezner, Z and G.O. Wesolowsky, (1989), +// On the computation of the bivariate normal inegral, +// Journal of Statist. Comput. Simul. 35, pp. 101-107, +// with major modifications for double precision, for |r| close to 1, +// and for matlab by Alan Genz - last modifications 7/98. +// Note: to compute the probability that x < dh and y < dk, use +// bvnu( -dh, -dk, r ). +// +*/ + if (fabs (rho) < 0.3) { + ng = 0; + lg = 3; +/* Gauss Legendre points and weights, n = 6 */ + W[1][0] = 0.1713244923791705; + W[2][0] = 0.3607615730481384; + W[3][0] = 0.4679139345726904; + + X[1][0] = 0.9324695142031522; + X[2][0] = 0.6612093864662647; + X[3][0] = 0.2386191860831970; + + } else if (fabs (rho) < 0.75) { + ng = 1; + lg = 6; +/* Gauss Legendre points and weights, n = 12 */ + W[1][1] = 0.4717533638651177e-1; + W[2][1] = 0.1069393259953183; + W[3][1] = 0.1600783285433464; + W[4][1] = 0.2031674267230659; + W[5][1] = 0.2334925365383547; + W[6][1] = 0.2491470458134029; + + X[1][1] = 0.9815606342467191; + X[2][1] = 0.9041172563704750; + X[3][1] = 0.7699026741943050; + X[4][1] = 0.5873179542866171; + X[5][1] = 0.3678314989981802; + X[6][1] = 0.1252334085114692; + + } else { + ng = 2; + lg = 10; +/* Gauss Legendre points and weights, n = 20 */ + W[1][2] = 0.1761400713915212e-1; + W[2][2] = 0.4060142980038694e-1; + W[3][2] = 0.6267204833410906e-1; + W[4][2] = 0.8327674157670475e-1; + W[5][2] = 0.1019301198172404; + W[6][2] = 0.1181945319615184; + W[7][2] = 0.1316886384491766; + W[8][2] = 0.1420961093183821; + W[9][2] = 0.1491729864726037; + W[10][2] = 0.1527533871307259; + + X[1][2] = 0.9931285991850949; + X[2][2] = 0.9639719272779138; + X[3][2] = 0.9122344282513259; + X[4][2] = 0.8391169718222188; + X[5][2] = 0.7463319064601508; + X[6][2] = 0.6360536807265150; + X[7][2] = 0.5108670019508271; + X[8][2] = 0.3737060887154196; + X[9][2] = 0.2277858511416451; + X[10][2] = 0.7652652113349733e-1; + } + + h = -dh; + k = -dk; + hk = h * k; + bvn = 0; + if (fabs (rho) < 0.925) { + hs = (h * h + k * k) / 2.0; + asr = asin (rho); + for (i = 1; i <= lg; ++i) { + sn = sin (asr * (1.0 - X[i][ng]) / 2.0); + bvn += W[i][ng] * exp ((sn * hk - hs) / (1.0 - sn * sn)); + sn = sin (asr * (1.0 + X[i][ng]) / 2.0); + bvn += W[i][ng] * exp ((sn * hk - hs) / (1.0 - sn * sn)); + } + bvn = + bvn * asr / (4.0 * num_Pi) + fdist_Normal2 (-h) * fdist_Normal2 (-k); + + } else { + if (rho < 0.0) { + k = -k; + hk = -hk; + } + if (fabs (rho) < 1.0) { + as = (1.0 - rho) * (1.0 + rho); + a = sqrt (as); + bs = (h - k) * (h - k); + c = (4.0 - hk) / 8.0; + d = (12.0 - hk) / 16.0; + asr = -(bs / as + hk) / 2.0; + if (asr > -100.0) + bvn = + a * exp (asr) * (1.0 - c * (bs - as) * (1.0 - + d * bs / 5.0) / 3.0 + c * d * as * as / 5.0); + + if (-hk < 100.0) { + b = sqrt (bs); + sp = sqrt (twopi) * fdist_Normal2 (-b / a); + bvn = bvn - exp (-hk / 2.0) * sp * b * (1.0 - c * bs * (1.0 - + d * bs / 5.0) / 3.0); + } + a = a / 2.0; + for (i = 1; i <= lg; ++i) { + for (is = -1; is <= 1; is += 2) { + xs = (a * (is * X[i][ng] + 1.0)); + xs = xs * xs; + rs = sqrt (1.0 - xs); + asr = -(bs / xs + hk) / 2.0; + if (asr > -100.0) { + sp = (1.0 + c * xs * (1.0 + d * xs)); + ep = exp (-hk * (1.0 - rs) / (2.0 * (1.0 + rs))) / rs; + bvn += a * W[i][ng] * exp (asr) * (ep - sp); + } + } + } + bvn = -bvn / twopi; + } + if (rho > 0.0) { + if (k > h) + h = k; + bvn += fdist_Normal2 (-h); + } + if (rho < 0.0) { + xs = fdist_Normal2 (-h) - fdist_Normal2 (-k); + if (xs < 0.0) + xs = 0.0; + bvn = -bvn + xs; + } + } + if (bvn <= 0.0) + return 0.0; + if (bvn >= 1.0) + return 1.0; + return bvn; +} + + +/*=========================================================================*/ + +double fdist_LogNormal (double mu, double sigma, double x) +{ + util_Assert (sigma > 0.0, "fdist_LogNormal: sigma <= 0"); + if (x <= 0.0) + return 0.0; + return fdist_Normal2 ((log (x) - mu) / sigma); +} + + +/*=========================================================================*/ + +double fdist_JohnsonSB (double alpha, double beta, double a, double b, + double x) +{ + util_Assert (beta > 0.0, "fdist_JohnsonSB: beta <= 0"); + util_Assert (b > a, "fdist_JohnsonSB: b <= a"); + if (x <= a) + return 0.0; + if (x >= b) + return 1.0; + return fdist_Normal2 (alpha + beta * log ((x - a) / (b - x))); +} + + +/*=========================================================================*/ + +double fdist_JohnsonSU (double alpha, double beta, double x) +{ + const double XLIM = 1.0e10; + double r; + lebool negative = FALSE; + util_Assert (beta > 0.0, "fdist_JohnsonSU: beta <= 0"); + if (x < 0.0) { + negative = TRUE; + x = -x; + } + /* compute r = x + sqrt (x * x + 1) */ + if (x < XLIM) + r = x + sqrt (x * x + 1.0); + else + r = 2.0 * x; + if (negative) + r = 1.0 / r; + + if (r > 0.0) + return fdist_Normal2 (alpha + beta * log (r)); + else + return 0.0; +} + + +/**************************************************************************/ + +double fdist_ChiSquare1 (long N, double x) +/* + * Returns an approximation of the Chi square cdf (N degrees of freedom) + * As in p:116 of W.J.Kennedy Jr and J.E.Gentle. Statistical computing, + * Dekker, New York, 1980. + */ +{ + const double tiers = 0.33333333333333333; + const double pt2 = 0.22222222222222222; + const double moinsdixhuit = -18.8055; + const double gam = 0.8862269254527579825931; + double H, H2, E, DemiX, Terme, Sommation, Y = 0; + long i; + + util_Assert (N > 0, "fdist_ChiSquare1: k < 1"); + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG * N) + return 1.0; + + if (N > 1000) { + if (x < 2.0) + return 0.0; + x = (pow ((x / N), tiers) - (1.0 - pt2 / N)) / sqrt (pt2 / N); + if (x > 5.0) + return 1.0; + if (x < moinsdixhuit) + return 0.0; + return fdist_Normal2 (x); + + } else { + DemiX = x / 2.0; + if (!(N & 1)) { /* even N */ + if (-DemiX < DBL_MIN_EXP * num_Ln2) + Terme = 0.0; + else + Terme = exp (-DemiX); + Sommation = Terme; + for (i = 1; i < N / 2; i++) { + Terme = Terme * DemiX / ((double) i); + Sommation += Terme; + } + Y = 1.0 - Sommation; + } else { + H2 = -1.0 + 2.0 * fdist_Normal2 (sqrt (x)); + if (N == 1) + return H2; + if (-DemiX < DBL_MIN_EXP * num_Ln2) + E = 0.0; + else + E = exp (-DemiX); + Terme = sqrt (DemiX) * E / gam; + H = H2; + for (i = 3; i < N; i += 2) { + H -= Terme; + Terme = Terme * DemiX * 2.0 / ((double) i); + } + Y = H - Terme; + } + } + if (Y < 0.0) + return 0.0; + else + return Y; +} + + +/*=========================================================================*/ + +double fdist_ChiSquare2 (long n, int d, double x) +{ + util_Assert (n > 0, "fdist_ChiSquare2: n <= 0"); + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG * n) + return 1.0; + return fdist_Gamma (n / 2.0, d, x / 2.0); +} + + +/*=========================================================================*/ + +#define Student_n1 20 +#define Student_x1 8.01 +#define Student_kmax 200 +#define Student_eps 0.5E-16 + +double fdist_Student1 (long n, double x) +{ + double a, u, b, y, z, z2, prec; + long k; + + util_Assert (n > 0, "fdist_Student1: n <= 0"); + if (n == 1) { + if (x < -0.5) + return atan(-1.0/x) / num_Pi; + return 0.5 + (atan (x)) / num_Pi; + } + + if (n == 2) { + z = 1.0 + x * x / 2.0; + if (x >= 0.) + return 0.5 + x / (2.0 * sqrt (z) * num_Rac2); + else + return 0.25 / (z * (0.5 - x /(2.0*sqrt(z)*num_Rac2))); + } + + /* first case: small n and small x */ + if (n <= Student_n1 && x <= Student_x1) { + b = 1.0 + x * x / n; + y = x / sqrt ((double) n); + z = 1.0; + for (k = n - 2; k >= 2; k -= 2) { + z = 1.0 + z * (k - 1.0) / (k * b); + } + if (n % 2 == 0) { + u = (1.0 + z * y / sqrt (b)) / 2.0; + if (u >= 0.) + return u; + else + return 0.; + } else { + if (y > -1.0) + return (0.5 + (atan (y) + z * y / b) / num_Pi); + else { + u = (atan (-1.0 / y) + z * y / b) / num_Pi; + if (u >= 0.) + return u; + else + return 0.; + } + } + + /* second case: large n and small x */ + } else if (x < Student_x1) { + a = n - 0.5; + b = 48.0 * a * a; + z2 = a * num2_log1p (x * x / n); + z = sqrt (z2); + y = (((((64.0 * z2 + 788.0) * z2 + 9801.0) * z2 + 89775.0) * z2 + + 543375.0) * z2 + 1788885.0) * z / (210.0 * b * b * b); + y -= + (((4.0 * z2 + 33.0) * z2 + 240.0) * z2 + 855.0) * z / (10.0 * b * b); + y += z + (z2 + 3.0) * z / b; + if (x >= 0.0) + return fbar_Normal1 (-y); + else + return fbar_Normal1 (y); + + /* third case: large x */ + } else { + /* Compute the Student probability density */ + b = 1.0 + x * x / n; + /* to avoid overflow with the 2 Gamma functions, use their logarithm. + However, for large n, there will be some loss of precision */ + y = num2_LnGamma ((n + 1) / 2.0) - num2_LnGamma (n / 2.0); + y = exp (y); + y *= pow (b, -(n + 1) / 2.0) / sqrt (num_Pi * n); + + y *= 2.0 * sqrt (n * b); + z = y / n; + k = 2; + z2 = prec = 10.0; + while (k < Student_kmax && prec > Student_eps) { + y *= (k - 1) / (k * b); + z += y / (n + k); + prec = fabs (z - z2); + z2 = z; + k += 2; + } + util_Warning (k >= Student_kmax, "fdist_Student1: k >= Student_kmax"); + if (x >= 0.0) + return 1.0 - z / 2.0; + else + return z / 2.0; + } +} + +/*=========================================================================*/ + +double fdist_Student2 (long n, int d, double x) +{ + util_Assert (n > 0, "fdist_Student2: n <= 0"); + util_Assert (d > 0, "fdist_Student2: d <= 0"); + util_Assert (d <= 15, "fdist_Student2: d > 15"); + if (x <= -fdist_XBIG) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + + if (x >= 0.0) + return 0.5 * (1.0 + fdist_Beta (0.5, 0.5 * n, d, x * x / (n + x * x))); + else + return 0.5 * (fdist_Beta (0.5 * n, 0.5, d, n / (n + x * x))); +} + +/*=========================================================================*/ + +double fdist_Gamma (double alpha, int d, double x) +{ + const double ALIM = 1.0e5; + const double EPS = EpsArray[d]; + + util_Assert (alpha > 0.0, "fdist_Gamma: a <= 0"); + util_Assert (d > 0, "fdist_Gamma: d <= 0"); + util_Assert (d < 16, "fdist_Gamma: d > 15"); + if (x <= 0.0) + return 0.0; + if (1.0 == alpha) + return fdist_Expon (x); + + if (alpha >= ALIM) { + double d2 = x + 1.0/3.0 - alpha - 0.02/alpha; + double S = alpha - 1.0/2.0; + double z = d2 * sqrt((1 + fdist_belog(S/x))/x); + return fdist_Normal2 (z); + } + + if (x <= 1.0 || x < alpha) { + double v, z, an, term; + v = exp (alpha * log (x) - x - num2_LnGamma (alpha)); + z = 1.0; + term = 1.0; + an = alpha; + do { + an += 1.0; + term *= x / an; + z += term; + } while (term >= EPS * z); + return z * v / alpha; + + } else + return 1.0 - fbar_Gamma (alpha, d, x); +} + + +/*=========================================================================*/ + +static double Isubx_pq_small (double p, double q, double x, int d) +/* + * Evaluates fdist_Beta (p, q, d, x) when 0 < p <= 1 and 0 < q <= 2 to a + * precision of d = -log10 (2 epsilon) decimal digits. Uses a series + * expansion in powers of x. + */ +{ + + int k = 0; + double s, u, v; + double epsilon; + util_Assert (p > 0.0 && p <= 1.0, "Isubx_pq_small: p not in (0, 1] "); + util_Assert (q > 0.0 && q <= 2.0, "Isubx_pq_small: q not in (0, 2] "); + + epsilon = EpsArray[d]; + u = pow (x, p); + s = u / p; + do { + u = (k + 1 - q) * x * u / (k + 1); + v = u / (k + 1 + p); + s += v; + k++; + } while ((fabs (v) / s) > epsilon); + + v = num2_LnGamma (p + q) - num2_LnGamma (p) - num2_LnGamma (q); + return s * exp (v); +} + +/*-------------------------------------------------------------------------*/ + +static void forward (double p, double q, double x, double I0, double I1, + int nmax, double I[]) +/* + * Given I0 = fdist_Beta (p, q, x) and I1 = fdist_Beta (p, q + 1, x), + * generates fdist_Beta (p, q + n, x) for n = 0, 1, 2, ..., nmax, and + * stores the result in I. + */ +{ + + int n; + + I[0] = I0; + if (nmax > 0) + I[1] = I1; + for (n = 1; n < nmax; n++) + I[n + 1] = (1 + (n - 1 + p + q) * (1. - x) / (n + q)) * I[n] + - (n - 1 + p + q) * (1. - x) * I[n - 1] / (n + q); +} + +/*-------------------------------------------------------------------------*/ + +static void backward (double p, double q, double x, double I0, int d, + int nmax, double I[]) +/* + * Given I0 = fdist_Beta (p, q, x), generates fdist_Beta (p + n, q, x) + * for n = 0, 1, 2,..., nmax to d significant digits, using a variant of + * J.C.P. Miller's backward recurrence algorithm. Stores the result in I. + */ +{ + + int n, nu, m, again, ntab; + double *Itemp, *Iapprox, *Rr; + double epsilon, r; + + I[0] = I0; + if (nmax == 0) + return; + + epsilon = EpsArray[d]; + nu = 2 * nmax + 5; + ntab = 64; + while (ntab <= nu) + ntab *= 2; + + Rr = (double *) util_Calloc ((size_t) ntab, sizeof (double)); + Iapprox = (double *) util_Calloc ((size_t) ntab, sizeof (double)); + Itemp = (double *) util_Calloc ((size_t) ntab, sizeof (double)); + + for (n = 1; n <= nmax; n++) + Iapprox[n] = 0.0; + for (n = 0; n <= nmax; n++) + Itemp[n] = I[n]; + + do { + n = nu; + r = 0.0; + do { + r = (n - 1 + p + q) * x / (n + p + (n - 1 + p + q) * x - (n + p) * r); + if (n <= nmax) + Rr[n - 1] = r; + n--; + } while (n >= 1); + + for (n = 0; n < nmax; n++) + Itemp[n + 1] = Rr[n] * Itemp[n]; + + again = 0; + for (n = 1; n <= nmax; n++) { + if (fabs ((Itemp[n] - Iapprox[n])/Itemp[n]) > epsilon) { + again++; + for (m = 1; m <= nmax; m++) + Iapprox[m] = Itemp[m]; + nu += 5; + if (ntab <= nu) { + ntab *= 2; + Rr = (double *) util_Realloc (Rr, ntab * sizeof (double)); + Iapprox = (double *) util_Realloc (Iapprox, ntab * sizeof (double)); + Itemp = (double *) util_Realloc (Itemp, ntab * sizeof (double)); + } + break; + } + } + } while (again); + + for (n = 0; n <= nmax; n++) + I[n] = Itemp[n]; + util_Free (Rr); + util_Free (Iapprox); + util_Free (Itemp); +} + +/*-------------------------------------------------------------------------*/ +static const double RENORM = 1.0e300; + +static void Isubx_q_fixed (double p, double q, double x, int d, int nmax, + double I[]) +/* + * Generates fdist_Beta (p + n, q, x), 0 < p <= 1, for n = 0, 1, 2,..., + * nmax to d significant digits, using procedure backward. First reduces + * q modulo 1 to q0, where 0 < q0 <= 1. + */ +{ + + int m, mmax; + double s, q0, Iq0, Iq1; + double *Iq; + + util_Assert (p > 0.0 && p <= 1.0, "Isubx_q_fixed: p not in (0, 1] "); + m = (int) q; /* integer part of q */ + s = q - m; /* fractionnal part of q */ + if (s > 0) { + q0 = s; + mmax = m; + } else { + q0 = s + 1; + mmax = m - 1; + } + Iq0 = RENORM * Isubx_pq_small (p, q0, x, d); + if (mmax > 0) + Iq1 = RENORM * Isubx_pq_small (p, q0 + 1.0, x, d); + + Iq = (double *) util_Calloc ((size_t) mmax + 1, sizeof (double)); + forward (p, q0, x, Iq0, Iq1, mmax, Iq); + backward (p, q, x, Iq[mmax], d, nmax, I); + for (m = 0; m <= nmax; m++) + I[m] /= RENORM; + util_Free (Iq); +} + +/*-------------------------------------------------------------------------*/ + +static void Isubx_p_fixed (double p, double q, double x, int d, int nmax, + double I[]) +/* + * Generates fdist_Beta (p, q + n, x), 0 < q <= 1, for n = 0, 1, 2,..., + * nmax to d significant digits, using procedure forward. + */ +{ + + int m, mmax; + double s, p0, I0, Iq0, I1, Iq1; + double *Ip; + + util_Assert (q > 0.0 && q <= 1.0, "Isubx_p_fixed: q not in (0, 1] "); + + m = (int) p; /* integer part of p */ + s = p - m; /* fractionnal part of p */ + if (s > 0) { + p0 = s; + mmax = m; + } else { + p0 = s + 1; + mmax = m - 1; + } + I0 = RENORM * Isubx_pq_small (p0, q, x, d); + I1 = RENORM * Isubx_pq_small (p0, q + 1.0, x, d); + + Ip = (double *) util_Calloc ((size_t) mmax + 1, sizeof (double)); + backward (p0, q, x, I0, d, mmax, Ip); + Iq0 = Ip[mmax]; + backward (p0, q + 1.0, x, I1, d, mmax, Ip); + Iq1 = Ip[mmax]; + forward (p, q, x, Iq0, Iq1, nmax, I); + for (m = 0; m <= nmax; m++) + I[m] /= RENORM; + util_Free (Ip); +} + +/*-------------------------------------------------------------------------*/ + +static void Beta_q_fixed (double p, double q, double x, int d, int nmax, + double I[]) +{ + int n; + util_Assert (p > 0.0 && p <= 1.0, "Beta_q_fixed: p not in (0, 1]"); + util_Assert (q > 0.0, "Beta_q_fixed: q <= 0"); + util_Assert (nmax >= 0, "Beta_q_fixed: nmax < 0"); + if (x == 0.0 || x == 1.0) { + for (n = 0; n <= nmax; n++) + I[n] = x; + return; + } + if (x <= 0.5) + Isubx_q_fixed (p, q, x, d, nmax, I); + else { + Isubx_p_fixed (q, p, 1.0 - x, d, nmax, I); + for (n = 0; n <= nmax; n++) + I[n] = 1.0 - I[n]; + } +} + +/*-------------------------------------------------------------------------*/ + +static void Beta_p_fixed (double p, double q, double x, int d, int nmax, + double I[]) +{ + int n; + util_Assert (q > 0.0 && q <= 1.0, "Beta_p_fixed: q not in (0, 1]"); + util_Assert (p > 0.0, "Beta_p_fixed: p <= 0"); + util_Assert (nmax >= 0, "Beta_p_fixed: nmax < 0"); + if (x == 0.0 || x == 1.0) { + for (n = 0; n <= nmax; n++) + I[n] = x; + return; + } + if (x <= 0.5) + Isubx_p_fixed (p, q, x, d, nmax, I); + else { + Isubx_q_fixed (q, p, 1.0 - x, d, nmax, I); + for (n = 0; n <= nmax; n++) + I[n] = 1.0 - I[n]; + } +} + + +/*-------------------------------------------------------------------------*/ +/* + * The exact section of fdist_Beta below is very slow for large parameters. + * It is an old algorithm of Gautschi of 1964. There is an algorithm + * for fdist_Beta (1994) that is recent and is supposed to be very fast + * (I MUST write the exact reference for later; I think it may have been in + * Mathematics of Computations???) + */ +double fdist_Beta (double p, double q, int d, double x) +/* + * I[j] will contain either the values of fdist_Beta (p0 + j, q, d, x), + * where 0 < p0 <= 1, for j = 0, 1, 2, ..., n, with p = p0 + n; or the + * values of fdist_Beta (p, q0 + j, d, x), where 0 < q0 <= 1, for j = 0, + * 1, 2, ..., n, with q = q0 + n. + */ +{ + + const double pqmax = 1000.0; + const double pqlim = 30.0; + int n, flag; + double p0, q0, u, temp, yd, gam, h1, h3, y; + double *I; + + util_Assert (p > 0.0, "fdist_Beta: p <= 0"); + util_Assert (q > 0.0, "fdist_Beta: q <= 0"); + util_Assert (d > 0, "fdist_Beta: d <= 0"); + util_Assert (d < 16, "fdist_Beta: d > 15"); + if (x <= 0.0) + return 0.0; + if (x >= 1.0) + return 1.0; + + if (util_Max (p, q) <= pqmax) { + if (p < q) { + n = (int) p; /* integer part of p */ + p0 = p - n; /* fractionnal part of p */ + if (p0 <= 0.0) { /* p0 == 0 not allowed */ + p0 = 1.0; + n--; + } + I = (double *) util_Calloc ((size_t) n + 1, sizeof (double)); + Beta_q_fixed (p0, q, x, d, n, I); + u = I[n]; + util_Free (I); + /* There may be numerical errors far in the tails giving very small + negative values instead of 0. */ + if (u <= 0.0) + return 0.0; + else if (u <= 1.0) + return u; + else + return 1.0; + + } else { + n = (int) q; /* integer part of q */ + q0 = q - n; /* fractionnal part of q */ + if (q0 <= 0.0) { /* q0 == 0 not allowed */ + q0 = 1.0; + n--; + } + I = (double *) util_Calloc ((size_t) n + 1, sizeof (double)); + Beta_p_fixed (p, q0, x, d, n, I); + u = I[n]; + util_Free (I); + /* There may be numerical errors far in the tails giving very small + negative values instead of 0. */ + if (u <= 0.0) + return 0.0; + else if (u <= 1.0) + return u; + else + return 1.0; + } + } + + if ((p > pqmax && q < pqlim) || (q > pqmax && p < pqlim)) { + /* Bol'shev approximation for large max(p, q) and small min(p, q) */ + if (x > 0.5) + return 1.0 - fdist_Beta (q, p, d, 1.0 - x); + + if (p < q) { + u = p; + p = q; + q = u; + flag = 0; + } else { + flag = 1; + } + u = p + 0.5 * q - 0.5; + if (!flag) + temp = x / (2.0 - x); + else + temp = (1.0 - x) / (1.0 + x); + yd = 2.0 * u * temp; + gam = + (exp (q * log (yd) - yd - num2_LnGamma (q)) * (2.0 * yd * yd - (q - + 1.0) * yd - (q * q - 1.0))) / (24.0 * u * u); + if (flag) { + yd = fbar_Gamma (q, d, yd); + return yd - gam; + } else { + yd = fdist_Gamma (q, d, yd); + return yd + gam; + } + } + + /* Normal approximation of Peizer and Pratt */ + h1 = p + q - 1.0; + y = 1.0 - x; + h3 = sqrt ((1.0 + y * fdist_belog ((p - 0.5) / (h1 * x)) + + x * fdist_belog ((q - 0.5) / (h1 * y))) + / ((h1 + 1.0 / 6.0) * x * y)) + * ((h1 + 1.0 / 3.0 + 0.02 * (1.0 / p + 1.0 / q + 1.0 / (p + q))) + * x - p + 1.0 / 3.0 - 0.02 / p - 0.01 / (p + q)); + + return fdist_Normal2 (h3); + +} + + +/*=========================================================================*/ +#define EPSILON 1.0e-15 /* Tolerance */ +#define EPSBETA 0.5e-10 /* < 0.75 sqrt(DBL_EPSILON) */ +#define ALPHALIM 100000.0 /* Limiting alpha for normal approx. */ +#define MAXJ 2000 /* Max number of terms in series */ +#define INV2PI 0.6366197723675813 /* 2 / PI */ +#define LOG4 1.38629436111989062 /* Ln(4) */ +#define OneRac2 0.70710678118654752 /* 1/sqrt(2) */ +#define SQPI_2 0.88622692545275801 /* Sqrt(Pi) / 2 */ +#define LOG_SQPI_2 -0.1207822376352453 /* Ln(Sqrt(Pi) / 2) */ + + + +/*------------------------------------------------------------------------*/ + +static double series1 (double alpha, double x) +/* + * Compute the series for F(x). + * This series is used for alpha < 1 and x close to 0. + */ +{ + int j; + double sum, term; + double poc; + poc = 1.0; + sum = 1.0 / alpha; + j = 1; + do { + poc *= x * (j - alpha) / j; + term = poc / (j + alpha); + sum += term; + ++j; + } while ((term > sum * EPSILON) && (j < MAXJ)); + + return sum * pow (x, alpha); +} + + +/*------------------------------------------------------------------------*/ + +static double series2 (double alpha, double y) +/* + * Compute the series for G(y). y = 0.5 - x. + * This series is used for alpha < 1 and x close to 1/2. + */ +{ + int j; + double term, sum; + double poc; + const double z = 4.0 * y * y; + + /* Compute the series for G(y) */ + poc = sum = 1.0; + j = 1; + do { + poc *= z * (j - alpha) / j; + term = poc / (2 * j + 1); + sum += term; + ++j; + } while ((term > sum * EPSILON) && (j < MAXJ)); + + return sum * y; +} + + +/*------------------------------------------------------------------------*/ + +static double series3 (double alpha, double x) +/* + * Compute the series for F(x). + * This series is used for alpha > 1 and x close to 0. + */ +{ + int j; + double sum, term; + const double z = -x / (1.0 - x); + + sum = term = 1.0; + j = 1; + do { + term *= z * (j - alpha) / (j + alpha); + sum += term; + ++j; + } while ((fabs (term) > sum * EPSILON) && (j < MAXJ)); + + return sum * x; +} + + +/*------------------------------------------------------------------------*/ + +static double series4 (double alpha, double y) +/* + * Compute the series for G(y). y = 0.5 - x. + * This series is used for alpha > 1 and x close to 1/2. + */ +{ + int j; + double term, sum; + const double z = 4.0 * y * y; + + term = sum = 1.0; + j = 1; + do { + term *= z * (j + alpha - 0.5) / (0.5 + j); + sum += term; + ++j; + } while ((term > sum * EPSILON) && (j < MAXJ)); + + return sum * y; +} + + +/*-------------------------------------------------------------------------*/ + +static double Peizer (double alpha, double x) +/* + * Normal approximation of Peizer and Pratt + */ +{ + const double y = 1.0 - x; + double z; + z = sqrt ((1.0 - y * fdist_belog (2.0 * x) - x * fdist_belog (2.0 * y)) + / ((2.0*alpha - 5.0 / 6.0) * x * y)) * + (2.0*x - 1.0) * (alpha - 1.0 / 3.0 + 0.025 / alpha); + + return fdist_Normal2 (z); +} + + +/*------------------------------------------------------------------------*/ + +void fdist_CalcB4 (double alpha, double *pB, double *plogB, double *pC, + double *plogC) +{ + /* Compute Beta(alpha, alpha) and Beta(alpha, alpha)*4^(alpha-1). */ + double temp; + + if (alpha <= EPSBETA) { + /* For a -> 0, B(a,a) = (2/a)*(1 - 1.645*a^2 + O(a^3)) */ + *pB = 2.0 / alpha; + *pC = *pB / (4.0*(1.0 - alpha*LOG4)); + + } else if (alpha <= 1.0) { + *plogB = 2.0 * num2_LnGamma (alpha) - num2_LnGamma (2.0*alpha); + *plogC = *plogB + (alpha - 1.0)*LOG4; + *pC = exp(*plogC); + *pB = exp(*plogB); + + } else if (alpha <= 10.0) { + *plogC = num2_LnGamma (alpha) - num2_LnGamma (0.5 + alpha) + LOG_SQPI_2; + *plogB = *plogC - (alpha - 1.0)*LOG4; + + } else if (alpha <= 200.0) { + /* Convergent series for Gamma(x + 0.5) / Gamma(x) */ + double term = 1.0; + double sum = 1.0; + int i = 1; + while (term > EPSILON*sum) { + term *= (i - 1.5)*(i - 1.5) /(i*(alpha + i - 1.5)); + sum += term; + i++; + } + temp = SQPI_2 / sqrt ((alpha - 0.5)*sum); + *plogC = log(temp); + *plogB = *plogC - (alpha - 1.0)*LOG4; + + } else { + /* Asymptotic series for Gamma(a + 0.5) / (Gamma(a) * Sqrt(a)) */ + double u = 1.0 / (8.0*alpha); + temp = 1.0 + u*(-1.0 + u*(0.5 + u*(2.5 - u*(2.625 + 49.875*u)))); + /* This is 4^(alpha - 1)*B(alpha, alpha) */ + temp = SQPI_2 / (sqrt(alpha) * temp); + *plogC = log(temp); + *plogB = *plogC - (alpha - 1.0)*LOG4; + } +} + + +/*------------------------------------------------------------------------*/ + +double fdist_BetaSymmetric (double alpha, double x) +/* + * Compute the cumulative probability of the symmetrical beta distribution. + * Returns a negative value on error, otherwise returns u in [0, 1]. + */ +{ + double temp, u, logB, logC; + int isUpper; /* True if x > 0.5 */ + double B = 0.; /* Beta(alpha, alpha) */ + double C, x0; + + if (alpha <= 0.0) { + util_Assert (1, "fdist_BetaSymmetric: p <= 0\n"); + return -1.0; + } + if (x <= 0.0) return 0.0; + if (x >= 1.0) return 1.0; + if (x == 0.5) return 0.5; + if (alpha == 1.0) return x; /* alpha = 1 is the uniform law */ + if (alpha == 0.5) /* alpha = 1/2 is the arcsin law */ + return INV2PI * asin(sqrt(x)); + + if (alpha > ALPHALIM) + return Peizer (alpha, x); + + if (x > 0.5) { + x = 1.0 - x; + isUpper = 1; + } else + isUpper = 0; + + fdist_CalcB4 (alpha, &B, &logB, &C, &logC); + + if (alpha <= 1.0) { + /* For x = x0, both series use the same number of terms to get the + required precision */ + if (x > 0.25) { + temp = -log (alpha); + if (alpha >= 1.0e-6) + x0 = 0.25 + 0.005 * temp; + else + x0 = 0.13863 + .01235 * temp; + } else + x0 = 0.25; + + if (x <= x0) + u = (series1 (alpha, x)) / B; + else + u = 0.5 - (series2 (alpha, 0.5 - x)) / C; + + } else { /* 1 < alpha < ALPHALIM */ + if (alpha < 400.0) + x0 = 0.5 - 0.45 / sqrt(alpha); + else + x0 = 0.5 - 1.0 / sqrt(alpha); + if (x0 < 0.25) + x0 = 0.25; + + if (x <= x0) { + temp = (alpha - 1.0) * log (x * (1.0 - x)) - logB; + u = series3 (alpha, x) * exp(temp) / alpha; + + } else { + const double y = 0.5 - x; + temp = num2_log1p(-4.0*y*y); + temp = alpha * temp - logC; + u = 0.5 - (series4 (alpha, y)) * exp(temp); + } + } + + if (isUpper) + return 1.0 - u; + else + return u; +} + + +/*=========================================================================*/ +#define NLIM 20 + +static double KSSpecial (long n, double x) +{ + /* For nx^2 > 18, fbar_KS(n, x) is smaller than DBL_EPSILON */ + if ((n*x*x >= 18.0) || (x >= 1.0)) + return 1.0; + + if (x <= 0.5 / n) + return 0.0; + + if (n == 1) + return 2.0 * x - 1.0; + + if (x <= 1.0 / n) { + double t = 2.0 * x - 1.0 / n; + double w; + if (n <= NLIM) { + w = num2_Factorial ((int) n); + return w * pow (t, (double) n); + } + w = num2_LnFactorial ((int) n) + n * log (t); + return exp (w); + } + + if (x >= 1.0 - 1.0 / n) { + return 1.0 - 2.0 * pow (1.0 - x, (double) n); + } + + return -1.0; +} + +#undef NLIM +/*-------------------------------------------------------------------------*/ + +static double Pelz (long n, double x) +{ + /* + Approximating the Lower Tail-Areas of the Kolmogorov-Smirnov + One-Sample Statistic, + Wolfgang Pelz and I. J. Good, + Journal of the Royal Statistical Society, Series B. + Vol. 38, No. 2 (1976), pp. 152-156 + */ + + const int JMAX = 20; + const double EPS = 1.0e-10; + const double C = 2.506628274631001; /* sqrt(2*Pi) */ + const double C2 = 1.2533141373155001; /* sqrt(Pi/2) */ + const double PI2 = num_Pi * num_Pi; + const double PI4 = PI2 * PI2; + const double RACN = sqrt((double)n); + const double z = RACN*x; + const double z2 = z * z; + const double z4 = z2 * z2; + const double z6 = z4 * z2; + const double w = PI2 / (2.0 * z*z); + double ti, term, tom; + double sum; + int j; + + term = 1; + j = 0; + sum = 0; + while (j <= JMAX && term > EPS * sum) { + ti = j + 0.5; + term = exp (-ti * ti * w); + sum += term; + j++; + } + sum *= C / z; + + term = 1; + tom = 0; + j = 0; + while (j <= JMAX && fabs(term) > EPS * fabs(tom)) { + ti = j + 0.5; + term = (PI2 * ti * ti - z2) * exp (-ti * ti * w); + tom += term; + j++; + } + sum += tom * C2 / (RACN * 3.0 * z4); + + term = 1; + tom = 0; + j = 0; + while (j <= JMAX && fabs(term) > EPS * fabs(tom)) { + ti = j + 0.5; + term = 6*z6 + 2*z4 + PI2*(2*z4 - 5*z2)*ti*ti + + PI4*(1 - 2*z2)*ti*ti*ti*ti; + term *= exp (-ti * ti * w); + tom += term; + j++; + } + sum += tom * C2 / (n * 36.0 * z * z6); + + term = 1; + tom = 0; + j = 1; + while (j <= JMAX && term > EPS * tom) { + ti = j; + term = PI2 * ti * ti * exp (-ti * ti * w); + tom += term; + j++; + } + sum -= tom * C2 / (n * 18.0 * z * z2); + + term = 1; + tom = 0; + j = 0; + while (j <= JMAX && fabs(term) > EPS * fabs(tom)) { + ti = j + 0.5; + ti = ti * ti; + term = -30*z6 -90*z6*z2 + PI2*(135*z4 - 96*z6)*ti + + PI4*(212*z4 - 60*z2)*ti*ti + PI2*PI4*ti*ti*ti*(5 - 30*z2); + term *= exp (-ti * w); + tom += term; + j++; + } + sum += tom * C2 / (RACN * n * 3240.0 * z4 * z6); + + term = 1; + tom = 0; + j = 1; + while (j <= JMAX && fabs(term) > EPS * fabs(tom)) { + ti = j*j; + term = (3*PI2 * ti * z2 - PI4*ti*ti) * exp (-ti * w); + tom += term; + j++; + } + sum += tom * C2 / (RACN * n * 108.0 * z6); + + return sum; +} + + +/*=========================================================================*/ + +static void mMultiply (double *A, double *B, double *C, int m) +{ + int i, j, k; + double s; + for (i = 0; i < m; i++) + for (j = 0; j < m; j++) { + s = 0.0; + for (k = 0; k < m; k++) + s += A[i * m + k] * B[k * m + j]; + C[i * m + j] = s; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void mPower (double *A, int eA, double *V, int *eV, int m, int n) +{ + double *B; + int eB, i; + if (n == 1) { + for (i = 0; i < m * m; i++) + V[i] = A[i]; + *eV = eA; + return; + } + mPower (A, eA, V, eV, m, n / 2); + B = (double *) malloc (m * m * sizeof (double)); + mMultiply (V, V, B, m); + eB = 2 * (*eV); + + if (n % 2 == 0) { + for (i = 0; i < m * m; i++) + V[i] = B[i]; + *eV = eB; + } else { + mMultiply (A, B, V, m); + *eV = eA + eB; + } + + if (V[(m / 2) * m + (m / 2)] > 1.0e140) { + for (i = 0; i < m * m; i++) + V[i] = V[i] * 1.0e-140; + *eV += 140; + } + free (B); +} + + +/*-------------------------------------------------------------------------*/ + +double fdist_KS2 (long N0, double x) +{ + int k, m, i, j, g, eH, eQ; + const int n = N0; + const double d = x; + double h, s, *H, *Q; + + /* OMIT NEXT 3 LINES IF YOU REQUIRE >7 DIGIT ACCURACY IN THE RIGHT TAIL */ +#if 1 + s = d * d * n; + if (s > 7.24 || (s > 3.76 && n > 99)) + return 1 - 2 * exp (-(2.000071 + 0.331 / sqrt ((double) n) + + 1.409 / n) * s); +#endif + k = (int) (n * d) + 1; + m = 2 * k - 1; + h = k - n * d; + H = (double *) malloc (m * m * sizeof (double)); + Q = (double *) malloc (m * m * sizeof (double)); + + for (i = 0; i < m; i++) + for (j = 0; j < m; j++) + if (i - j + 1 < 0) + H[i * m + j] = 0; + else + H[i * m + j] = 1; + + for (i = 0; i < m; i++) { + H[i * m] -= pow (h, (double) (i + 1)); + H[(m - 1) * m + i] -= pow (h, (double) (m - i)); + } + + H[(m - 1) * m] += (2 * h - 1 > 0 ? pow (2 * h - 1, (double) m) : 0); + + for (i = 0; i < m; i++) + for (j = 0; j < m; j++) + if (i - j + 1 > 0) + for (g = 1; g <= i - j + 1; g++) + H[i * m + j] /= g; + + eH = 0; + mPower (H, eH, Q, &eQ, m, n); + s = Q[(k - 1) * m + k - 1]; + for (i = 1; i <= n; i++) { + s = s * i / n; + if (s < 1.0e-140) { + s *= 1.0e140; + eQ -= 140; + } + } + s *= pow (10.0, (double) eQ); + free (H); + free (Q); + return s; +} + + +/*=========================================================================*/ + +static double Pomeranz (long n, double x) +{ + const double EPS = 5.0e-13; /* for floors and ceilings */ + const int ENO = 350; + const double RENO = ldexp(1.0, ENO); /* for renormalization of V */ + const double IRENO = 1.0/RENO; + int coreno; /* counter: how many renormalizations */ + const double t = n*x; + double sum, maxsum; + int i, j, k, s; + int r1, r2; /* Indices i and i-1 for V[i][] */ + int jlow, jup, klow, kup, kup0; + double w, z; + double *A; + double **V; + double **H; /* work variables = pow(w, j-k) / Factorial(j-k) */ + + A = (double*) util_Calloc ((size_t) (2*n + 3), sizeof (double)); + V = (double **) tables_CreateMatrixD (2, n + 2); + H = (double **) tables_CreateMatrixD (4, n + 1); + + A[0] = A[1] = 0; + z = t - floor(t); + w = ceil(t) - t; + if (w < z) + z = w; + A[2] = z; + A[3] = 1.0 - A[2]; + for (i = 4; i <= 2*n + 1; i++) + A[i] = A[i-2] + 1.0; + A[2*n + 2] = n; + + for (j = 1; j <= n+1; j++) + V[0][j] = 0; + for (j = 2; j <= n+1; j++) + V[1][j] = 0; + V[1][1] = RENO; + coreno = 1; + + /* Precompute H[][] = (A[j] - A[j-1]^(j-k) / (j-k)! for speed */ + H[0][0] = 1; + w = 2.0 * A[2] / n; + for (j = 1; j <= n; j++) + H[0][j] = w * H[0][j - 1] / j; + + H[1][0] = 1; + w = (1.0 - 2.0*A[2])/n; + for (j = 1; j <= n; j++) + H[1][j] = w*H[1][j-1] / j; + + H[2][0] = 1; + w = A[2]/n; + for (j = 1; j <= n; j++) + H[2][j] = w*H[2][j-1] / j; + + H[3][0] = 1; + for (j = 1; j <= n; j++) + H[3][j] = 0; + + r1 = 0; + r2 = 1; + for (i = 2; i <= 2 * n + 2; i++) { + jlow = 2 + floor (A[i] - t + EPS); + if (jlow < 1) + jlow = 1; + jup = ceil (A[i] + t - EPS); + if (jup > n + 1) + jup = n + 1; + + klow = 2 + floor (A[i - 1] - t + EPS); + if (klow < 1) + klow = 1; + kup0 = ceil (A[i - 1] + t - EPS); + + /* Find to which case it corresponds */ + w = (A[i] - A[i-1])/n; + s = -1; + for (j = 0; j < 4; j++) { + if (fabs(w - H[j][1]) <= EPS) { + s = j; + break; + } + } + util_Assert (s >= 0, "Pomeranz: s < 0"); + + maxsum = -1; + r1 = (r1 + 1) & 1; /* i - 1 */ + r2 = (r2 + 1) & 1; /* i */ + + for (j = jlow; j <= jup; j++) { + kup = kup0; + if (kup > j) + kup = j; + sum = 0; + for (k = kup; k >= klow; k--) + sum += V[r1][k] * H[s][j - k]; + V[r2][j] = sum; + if (sum > maxsum) + maxsum = sum; + } + + if (maxsum < IRENO) { + /* V is too small: renormalize to avoid underflow of prob */ + for (j = jlow; j <= jup; j++) + V[r2][j] *= RENO; + coreno++; /* keep track of log of RENO */ + } + } + + z = V[r2][n+1]; + util_Free (A); + tables_DeleteMatrixD (&H); + tables_DeleteMatrixD (&V); + + w = num2_LnFactorial(n) - coreno*ENO*num_Ln2 + log(z); + if (w >= 0.) + return 1.; + return exp(w); +} + + +/*-------------------------------------------------------------------------*/ +#define NSEP 400 +#define NSEP2 4000 +#define ZSEP 4.0 +#define ZSEP2 0.2 + +double fdist_KS1 (long n, double x) +{ + double u = KSSpecial(n, x); + if (u >= 0.0) + return u; + + if (n <= NSEP) { + if (n*x*x < ZSEP) + return Pomeranz (n, x); + else + return 1. - fbar_KS1(n, x); + } + + if (n*x*x <= ZSEP2 && n <= NSEP2) + return Pomeranz (n, x); + + return Pelz (n, x); +} + + +/*=========================================================================*/ + +double fdist_KSPlus (long N, double x) +{ + const double NxParam = 6.5; /* frontier: alternating series */ + const long NParam = 4000; /* frontier: non-alternating series */ + double q; + double Sum; + double term; + + util_Assert (N > 0, "Calling fdist_KSPlus with N < 1"); + if (x <= 0.0) + return 0.0; + if ((x >= 1.0) || (N*x*x >= 25.0)) + return 1.0; + if (N == 1) + return x; + + /*--------------------------------------------------------------*/ + /* the alternating series is stable and fast for N*x very small */ + /*--------------------------------------------------------------*/ + + if (N * x <= NxParam) { + const double Epsilon = 1.0E-300; + double LogCom = log ((double) N); + int Sign = -1; + long j; + long jmax = (long) (N * x); + Sum = 0.0; + + for (j = 1; j <= jmax; j++) { + double jreal = j; + double Njreal = N - j; + q = jreal / N - x; + /* we must avoid log(0.0) for j = jmax and N*x near an integer */ + if (-q > Epsilon) { + term = LogCom + jreal * log (-q) + (Njreal - 1.0) * num2_log1p (-q); + Sum += Sign * exp (term); + } + Sign = -Sign; + LogCom += log (Njreal / (j + 1)); + } + /* add the term j = 0 */ + Sum += exp ((N - 1) * num2_log1p (x)); + if (Sum >= 0.0) + return Sum * x; + else + return 0.0; + } + + if (N <= NParam) { + double Njreal; + double jreal; + long j; + long jmax; + double LogCom = log ((double) N); + Sum = 0.0; + jmax = (long) (N * (1.0 - x)); + if (1.0 - x - (double) jmax/N <= 0.0) + --jmax; + + for (j = 1; j <= jmax; j++) { + jreal = j; + Njreal = N - j; + q = jreal / N + x; + term = LogCom + (jreal - 1.0) * log (q) + Njreal * num2_log1p(-q); + Sum += exp (term); + LogCom += log (Njreal / (jreal + 1.0)); + } + Sum *= x; + + /* add the term j = 0; avoid log(0.0) */ + if (1.0 > x) + Sum += exp (N * num2_log1p(-x)); + Sum = 1.0 - Sum; + if (Sum >= 0.0) + return Sum; + else + return 0.0; + } + + /*---------------------------*/ + /* Use an asymptotic formula */ + /*---------------------------*/ + + term = 2.0 / 3.0; + q = x * x * N; + Sum = 1.0 - exp (-2.0 * q) * (1.0 - term * x * (1.0 - x * (1.0 - term * q) + - term / N * (0.2 - 19.0 / 15.0 * q + term * q * q))); + if (Sum >= 0.0) + return Sum; + else + return 0.0; +} + + +/*=========================================================================*/ + +double fdist_KSPlusJumpOne (long N, double a, double x) +{ + const double EpsilonLR = 1.E-15; + const double Epsilon = 1.0E-290; + const double NxaParam = 6.5; /* frontier: alternating series */ + double LogCom; + double q, p1, q1; + double Sum = 0.0; + double term; + double Njreal; + double jreal; + int Sign; + long j; + long jmax; + + util_Assert (N >= 1, "Calling fdist_KSPlusJumpOne with N < 1"); + util_Assert (a < 1.0 && a > 0.0, + "Calling fdist_KSPlusJumpOne with a outside (0, 1)"); + if (x <= 0.0) + return 0.0; + if (x + a >= 1.0) + return 1.0; + LogCom = log ((double) N); + + /*--------------------------------------------------------------------*/ + /* the alternating series is stable and fast for N*(x + a) very small */ + /*--------------------------------------------------------------------*/ + if (N * (x + a) < NxaParam && a + x < 0.5) { + jmax = (long) (N * (x + a)); + for (j = 1; j <= jmax; j++) { + jreal = j; + Njreal = N - j; + q = jreal / N - x; + if ((q < 0.0 && (j & 1)) || ((q > 1.0) && ((N - j - 1) & 1))) + Sign = -1; + else + Sign = 1; + + /* we must avoid log(0.0) */ + q1 = fabs (q); + p1 = fabs (1.0 - q); + if (q1 > Epsilon && p1 > Epsilon) { + term = LogCom + jreal * log (q1) + (Njreal - 1.0) * log (p1); + Sum += Sign * exp (term); + } + LogCom += log (Njreal / (jreal + 1.0)); + } + /* add the term j = 0 */ + Sum += exp ((N - 1) * num2_log1p(x)); + return Sum * x; + } + + /*---------------------------------------------*/ + /* For N(x + a) >= NxaParam or (a + x) > 0.5, */ + /* use the non-alternating series. */ + /*---------------------------------------------*/ + + /* EpsilonLR because the distribution has a jump */ + jmax = (long) (N * (1.0 - a - x - EpsilonLR)); + for (j = 1; j <= jmax; j++) { + jreal = j; + Njreal = N - jreal; + q = jreal / N + x; + if (1.0 - q > Epsilon) { + term = LogCom + (jreal - 1.0) * log (q) + Njreal * num2_log1p (-q); + Sum += exp (term); + } + LogCom += log (Njreal / (jreal + 1.0)); + } + Sum *= x; + + /* add the term j = 0 */ + if (1.0 - x > Epsilon) + Sum += exp (N * num2_log1p (-x)); + return 1.0 - Sum; +} + + +/*=========================================================================*/ +#if 0 +static lebool IsJump (fdist_FUNC_JUMPS * H, double xa, double xb, + double ya, double yb, int NJ) + /* Find a more precise value for the position of the jump in (xa, xb). */ + /* Return FALSE if there is no jump, TRUE if there is a jump. */ +{ + const double eps = DBL_EPSILON; + const int imax = DBL_MANT_DIG; + const double epsY = H->epsY; + double *par = H->par; + wdist_CFUNC F = H->F; + int i = 0; + double x = 1.0, y; + + /* Binary search to refine the x-coordinate of the jump */ + while ((i < imax) && (xb - xa > eps * x)) { + i++; + x = (xb + xa) / 2.0; + y = F (par, x); + if (y - ya > epsY) { + yb = y; + xb = x; + } else { + ya = y; + xa = x; + } + } + + if (yb - ya < epsY) + return FALSE; + H->xJump[NJ] = (xb + xa) / 2.0; + H->yLeftJump[NJ] = ya; + H->yRightJump[NJ] = yb; + return TRUE; +} + +/*-------------------------------------------------------------------------*/ + +void fdist_FindJumps (fdist_FUNC_JUMPS * H, int Detail) +{ + int i, NJ; + double yRight; + double yLeft; + double x; + const double epsX = H->epsX; + const double epsY = H->epsY; + double *par = H->par; + wdist_CFUNC F = H->F; + + /* Assume no more than 30 jumps initially */ + NJ = 30; + H->xJump = (double *) util_Calloc ((size_t) NJ + 1, sizeof (double)); + H->yLeftJump = (double *) util_Calloc ((size_t) NJ + 1, sizeof (double)); + H->yRightJump = (double *) util_Calloc ((size_t) NJ + 1, sizeof (double)); + + i = 0; + if (H->xa > H->xb) { + x = H->xa; + H->xa = H->xb; + H->xb = x; + } + x = H->xa; + yLeft = F (par, x); + while (x < H->xb) { + x += epsX; + yRight = F (par, x); + if (yRight - yLeft > epsY) { + /* this should be a jump */ + ++i; + if (i > NJ) { + NJ *= 2; + H->xJump = (double *) util_Realloc (H->xJump, + (NJ + 1) * sizeof (double)); + H->yLeftJump = (double *) util_Realloc (H->yLeftJump, + (NJ + 1) * sizeof (double)); + H->yRightJump = (double *) util_Realloc (H->yRightJump, + (NJ + 1) * sizeof (double)); + } + if (IsJump (H, x - epsX, x, yLeft, yRight, i) == FALSE) + i--; + } + yLeft = yRight; + } + NJ = i; + H->xJump = (double *) util_Realloc (H->xJump, (NJ + 1) * sizeof (double)); + H->yLeftJump = (double *) util_Realloc (H->yLeftJump, + (NJ + 1) * sizeof (double)); + H->yRightJump = (double *) util_Realloc (H->yRightJump, + (NJ + 1) * sizeof (double)); + H->NJumps = NJ; + + if (Detail > 0) { + printf ("\n========================================================="); + printf ("\nCalling fdist_FindJumps for function %-32s\n", H->doc); + printf ("\nInterval = (%g, %g)\n", H->xa, H->xb); + printf ("epsX = %10.5g\nepsY = %10.5g\n", epsX, epsY); + printf ("Number of jumps = %4d\n", NJ); + if (NJ == 0) + return; + printf ("Jumps of the function:\n\n"); + printf (" x yLeft yRight" + " yRight - yLeft\n\n"); + for (i = 1; i <= NJ; i++) { + printf (" %19.15g %19.15g %19.15g %19.15g\n", H->xJump[i], + H->yLeftJump[i], H->yRightJump[i], + H->yRightJump[i] - H->yLeftJump[i]); + } + printf + ("\n=========================================================\n\n"); + } +} + + +/*=========================================================================*/ + +void fdist_FreeJumps (fdist_FUNC_JUMPS * H) +{ + util_Free (H->xJump); + util_Free (H->yLeftJump); + util_Free (H->yRightJump); +} + + +/*=========================================================================*/ + +double fdist_KSMinusJumpsMany (fdist_FUNC_JUMPS * H, double dMoins) +{ + int k, j, i, jsup; + double comb, temp, y; + double *C, *B; + const int M = H->par[0]; + const int NJ = H->NJumps; + + util_Assert (M <= 64, "fdist_KSMinusJumpsMany: sample N too large"); + jsup = M * (1.0 - dMoins - EpsilonLR); + util_Assert (jsup >= 0, "fdist_KSMinusJumpsMany: jsup < 0"); + B = (double *) util_Calloc ((size_t) jsup + 1, sizeof (double)); + C = (double *) util_Calloc ((size_t) jsup + 1, sizeof (double)); + + j = 0; + while (j <= jsup) { + y = dMoins + ((double) j) / M; + i = 1; + while (i <= NJ && y > H->yRightJump[i]) + ++i; + /* I believe that Conover is wrong here, because this gives a */ + /* distribution that is continuous on the left, while probability */ + /* distributions must be continuous on the right. That could be */ + /* why these KS distributions with jumps don't seem to work. */ + /* I may also have some bugs in these functions. */ + + if (i > NJ || y < H->yLeftJump[i]) + C[j] = 1.0 - y; + else + C[j] = 1.0 - H->yRightJump[i]; + ++j; + } + + B[0] = 1.0; + for (k = 1; k <= jsup; k++) { + if (C[k] <= 0.0) + B[k] = 0.0; + else { + temp = 0.0; + comb = 1.0; + for (j = 0; j < k; j++) { + temp += comb * B[j] * pow (C[j], (double) (k - j)); + comb *= ((double) (k - j)) / (j + 1); + } + B[k] = 1.0 - temp; + } + } + temp = 0.0; + comb = 1.0; + for (j = 0; j <= jsup; j++) { + temp += comb * B[j] * pow (C[j], (double) (M - j)); + comb *= ((double) (M - j)) / (j + 1); + } + util_Warning (temp > 1.0 || temp < 0.0, + "fdist_KSMinusJumpsMany: Probabilities outside [0, 1]"); + util_Free (C); + util_Free (B); + return temp; +} + + +/*=========================================================================*/ + +double fdist_KSPlusJumpsMany (fdist_FUNC_JUMPS * H, double dPlus) +{ + int k, j, i, jsup; + double comb, temp, y; + double *F, *E; + const int M = H->par[0]; + const int NJ = H->NJumps; + + util_Assert (M <= 64, "fdist_KSPlusJumpsMany: sample N too large"); + jsup = M * (1.0 - dPlus - EpsilonLR); + util_Assert (jsup >= 0, "fdist_KSPlusJumpsMany: jsup < 0"); + E = (double *) util_Calloc ((size_t) jsup + 1, sizeof (double)); + F = (double *) util_Calloc ((size_t) jsup + 1, sizeof (double)); + + j = 0; + while (j <= jsup) { + y = (1.0 - dPlus) - ((double) j) / M; + i = 1; + while (i <= NJ && y >= H->yRightJump[i]) + ++i; + + if (i > NJ || y <= H->yLeftJump[i]) + F[j] = y; + else + F[j] = H->yLeftJump[i]; + ++j; + } + + E[0] = 1.0; + for (k = 1; k <= jsup; k++) { + if (F[k] <= 0.0) + E[k] = 0.0; + else { + temp = 0.0; + comb = 1.0; + for (j = 0; j < k; j++) { + temp += comb * E[j] * pow (F[j], (double) (k - j)); + comb *= ((double) (k - j)) / (j + 1); + } + E[k] = 1.0 - temp; + } + } + temp = 0.0; + comb = 1.0; + for (j = 0; j <= jsup; j++) { + temp += comb * E[j] * pow (F[j], (double) (M - j)); + comb *= ((double) (M - j)) / (j + 1); + } + util_Warning (temp > 1.0 || temp < 0.0, + "fdist_KSPlusJumpsMany: Probabilities outside [0, 1]"); + util_Free (E); + util_Free (F); + return temp; +} +#endif + +/*=========================================================================*/ + +double fdist_CramerMises (long N, double x) +{ + const double Epsilon = DBL_EPSILON; + const int jmax = 10; + int j; + double Cor, Res, arg; + double termX, termS, termJ; + static const double A[10] = { + 1.0, + 1.11803398875, + 1.125, + 1.12673477358, + 1.1274116945, + 1.12774323743, + 1.1279296875, + 1.12804477649, + 1.12812074678, + 1.12817350091 + }; + + util_Assert (N > 0, "fdist_CramerMises: N <= 0"); + + if (N == 1) { + if (x <= 1.0 / 12.0) + return 0.0; + if (x >= 1.0 / 3.0) + return 1.0; + return 2.0 * sqrt (x - 1.0 / 12.0); + } + + if (x <= 0.002 || x < 1.0 / (12.0*N)) + return 0.0; + if (x > 3.95 || x >= N/3.0) + return 1.0; + + termX = 0.0625 / x; /* 1 / (16x) */ + Res = 0.0; + j = 0; + do { + termJ = 4 * j + 1; + arg = termJ * termJ * termX; + termS = A[j] * exp (-arg) * num2_BesselK025 (arg); + Res += termS; + ++j; + } while (!(termS < Epsilon || j > jmax)); + + util_Warning (j > jmax, "fdist_CramerMises: iterations have not converged"); + Res /= num_Pi * sqrt (x); + + /* Empirical correction in 1/N */ + if (x < 0.0092) + Cor = 0.0; + else if (x < 0.03) + Cor = -0.0121763 + x * (2.56672 - 132.571 * x); + else if (x < 0.06) + Cor = 0.108688 + x * (-7.14677 + 58.0662 * x); + else if (x < 0.19) + Cor = -0.0539444 + x * (-2.22024 + x * (25.0407 - 64.9233 * x)); + else if (x < 0.5) + Cor = -0.251455 + x * (2.46087 + x * (-8.92836 + x * (14.0988 - + x * (5.5204 + 4.61784 * x)))); + else if (x <= 1.1) + Cor = 0.0782122 + x * (-0.519924 + x * (1.75148 + + x * (-2.72035 + x * (1.94487 - 0.524911 * x)))); + else + Cor = exp (-0.244889 - 4.26506 * x); + + Res += Cor / N; + /* This empirical correction is not very precise, so ... */ + if (Res <= 1.0) + return Res; + else + return 1.0; +} + + +/*=========================================================================*/ + +double fdist_WatsonU (long N, double x) +/* + * Only the asymptotic form has been implemented. In the trivial case + * N = 1, we simply return 0.5 + */ +{ + const int JMAX = 10; + const double xSepare = 0.15; + int j; + double v; + double terme; + double somme; + + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + + if (N == 1) /* N = 1, degenerate case */ + return 0.5; + + if (x > xSepare) + return 1.0 - fbar_WatsonU (N, x); + + /* this series converges rapidly for x <= 0.15 */ + v = exp (-(0.125 / x)); + somme = v; + j = 2; + do { + terme = pow (v, (double) (2 * j - 1) * (2 * j - 1)); + somme += terme; + ++j; + } while (!(terme < v * DBL_EPSILON || j > JMAX)); + util_Warning (j > JMAX, "fdist_WatsonU: sum2 has not converged"); + + v = 2.0 * somme / sqrt (2.0 * num_Pi * x); + if (v >= 1.0) + return 1.0; + return v; +} + + +/*=========================================================================*/ + +static double YWA[143]; /* Tables for a spline approximation */ +static double MWA[143]; /* of the WatsonG distribution */ +static double CoWA[143]; /* Empirical correction in 1/sqrt(n) */ + +static void WatsonGInit (void) +/* + * Initialization procedure for fdist_WatsonG + */ +{ + int j; + + YWA[0] = 1.8121832847E-39; YWA[1] = 2.0503176304E-32; + YWA[2] = 4.6139577764E-27; YWA[3] = 6.5869745929E-23; + YWA[4] = 1.2765816107E-19; YWA[5] = 5.6251923105E-17; + YWA[6] = 8.0747150511E-15; YWA[7] = 4.8819994144E-13; + YWA[8] = 1.4996052497E-11; YWA[9] = 2.6903519441E-10; + YWA[10] = 3.1322929018E-9; YWA[11] = 2.5659643046E-8; + YWA[12] = 1.5749759318E-7; YWA[13] = 7.6105096466E-7; + YWA[14] = 3.0113293541E-6; YWA[15] = 1.0070166837E-5; + YWA[16] = 2.9199826692E-5; YWA[17] = 7.4970409372E-5; + YWA[18] = 1.7340586581E-4; YWA[19] = 3.6654236297E-4; + YWA[20] = 7.165864865E-4; YWA[21] = 1.3087767385E-3; + YWA[22] = 2.2522044209E-3; YWA[23] = 3.6781862572E-3; + YWA[24] = 5.7361958631E-3; YWA[25] = 8.5877444706E-3; + YWA[26] = 1.23988738E-2; YWA[27] = 1.73320516E-2; + YWA[28] = 2.35382479E-2; YWA[29] = 3.11498548E-2; + YWA[30] = 4.02749297E-2; YWA[31] = 5.09930445E-2; + YWA[32] = 6.33528333E-2; YWA[33] = 7.73711747E-2; + YWA[34] = 9.30338324E-2; YWA[35] = 1.10297306E-1; + YWA[36] = 1.290916098E-1; YWA[37] = 1.493236984E-1; + YWA[38] = 1.708812741E-1; YWA[39] = 1.936367476E-1; + YWA[40] = 2.174511609E-1; YWA[41] = 2.42177928E-1; + YWA[42] = 2.676662852E-1; YWA[43] = 2.937643828E-1; + YWA[44] = 3.203219784E-1; YWA[45] = 3.471927188E-1; + YWA[46] = 3.742360163E-1; YWA[47] = 4.013185392E-1; + YWA[48] = 4.283153467E-1; YWA[49] = 4.551107027E-1; + YWA[50] = 4.815986082E-1; YWA[51] = 5.076830902E-1; + YWA[52] = 5.332782852E-1; YWA[53] = 5.583083531E-1; + YWA[54] = 5.827072528E-1; YWA[55] = 6.064184099E-1; + YWA[56] = 6.293943006E-1; YWA[57] = 6.515959739E-1; + YWA[58] = 6.729925313E-1; YWA[59] = 6.935605784E-1; + YWA[60] = 7.132836621E-1; YWA[61] = 7.321517033E-1; + YWA[62] = 7.501604333E-1; YWA[63] = 7.673108406E-1; + YWA[64] = 7.836086337E-1; YWA[65] = 7.99063723E-1; + YWA[66] = 8.136897251E-1; YWA[67] = 8.275034914E-1; + YWA[68] = 8.405246632E-1; YWA[69] = 8.527752531E-1; + YWA[70] = 8.642792535E-1; YWA[71] = 8.750622738E-1; + YWA[72] = 8.851512032E-1; YWA[73] = 8.945739017E-1; + YWA[74] = 9.033589176E-1; YWA[75] = 9.115352296E-1; + YWA[76] = 9.19132015E-1; YWA[77] = 9.261784413E-1; + YWA[78] = 9.327034806E-1; YWA[79] = 9.387357465E-1; + YWA[80] = 9.44303351E-1; YWA[81] = 9.494337813E-1; + YWA[82] = 9.541537951E-1; YWA[83] = 9.584893325E-1; + YWA[84] = 9.624654445E-1; YWA[85] = 9.661062352E-1; + YWA[86] = 9.694348183E-1; YWA[87] = 9.724732859E-1; + YWA[88] = 9.752426872E-1; YWA[89] = 9.777630186E-1; + YWA[90] = 9.800532221E-1; YWA[91] = 9.821311912E-1; + YWA[92] = 9.840137844E-1; YWA[93] = 9.85716844E-1; + YWA[94] = 9.872552203E-1; YWA[95] = 9.886428002E-1; + YWA[96] = 9.898925389E-1; YWA[97] = 9.910164946E-1; + YWA[98] = 9.920258656E-1; YWA[99] = 9.929310287E-1; + YWA[100] = 9.937415788E-1; YWA[101] = 9.944663692E-1; + YWA[102] = 9.95113552E-1; YWA[103] = 9.956906185E-1; + YWA[104] = 9.962044387E-1; YWA[105] = 9.966613009E-1; + YWA[106] = 9.970669496E-1; YWA[107] = 9.974266225E-1; + YWA[108] = 9.977450862E-1; YWA[109] = 9.980266707E-1; + YWA[110] = 9.982753021E-1; YWA[111] = 9.984945338E-1; + YWA[112] = 9.98687576E-1; YWA[113] = 9.98857324E-1; + YWA[114] = 9.990063842E-1; YWA[115] = 9.991370993E-1; + YWA[116] = 9.992515708E-1; YWA[117] = 9.99351681E-1; + YWA[118] = 9.994391129E-1; YWA[119] = 9.995153688E-1; + YWA[120] = 9.995817875E-1; YWA[121] = 9.996395602E-1; + YWA[122] = 9.996897446E-1; YWA[123] = 9.997332791E-1; + YWA[124] = 9.997709943E-1; YWA[125] = 9.998036243E-1; + YWA[126] = 9.998318172E-1; YWA[127] = 9.998561438E-1; + YWA[128] = 9.998771066E-1; YWA[129] = 9.998951466E-1; + YWA[130] = 9.999106508E-1; YWA[131] = 9.99923958E-1; + YWA[132] = 9.999353645E-1; YWA[133] = 9.999451288E-1; + YWA[134] = 9.999534765E-1; YWA[135] = 9.999606035E-1; + YWA[136] = 9.999666805E-1; YWA[137] = 9.999718553E-1; + YWA[138] = 9.999762562E-1; YWA[139] = 9.999799939E-1; + YWA[140] = 9.999831643E-1; YWA[141] = 9.999858E-1; + YWA[142] = 9.999883E-1; + + MWA[0] = 0.0; MWA[1] = 6.909E-15; + MWA[2] = 2.763E-14; MWA[3] = 1.036E-13; + MWA[4] = 3.792E-13; MWA[5] = 4.773E-12; + MWA[6] = 4.59E-10; MWA[7] = 2.649E-8; + MWA[8] = 7.353E-7; MWA[9] = 1.14E-5; + MWA[10] = 1.102E-4; MWA[11] = 7.276E-4; + MWA[12] = 3.538E-3; MWA[13] = 0.01342; + MWA[14] = 0.04157; MWA[15] = 0.1088; + MWA[16] = 0.2474; MWA[17] = 0.4999; + MWA[18] = 0.913; MWA[19] = 1.53; + MWA[20] = 2.381; MWA[21] = 3.475; + MWA[22] = 4.795; MWA[23] = 6.3; + MWA[24] = 7.928; MWA[25] = 9.602; + MWA[26] = 11.24; MWA[27] = 12.76; + MWA[28] = 14.1; MWA[29] = 15.18; + MWA[30] = 15.98; MWA[31] = 16.47; + MWA[32] = 16.64; MWA[33] = 16.49; + MWA[34] = 16.05; MWA[35] = 15.35; + MWA[36] = 14.41; MWA[37] = 13.28; + MWA[38] = 12.0; MWA[39] = 10.6; + MWA[40] = 9.13; MWA[41] = 7.618; + MWA[42] = 6.095; MWA[43] = 4.588; + MWA[44] = 3.122; MWA[45] = 1.713; + MWA[46] = 0.3782; MWA[47] = -0.8726; + MWA[48] = -2.031; MWA[49] = -3.091; + MWA[50] = -4.051; MWA[51] = -4.91; + MWA[52] = -5.668; MWA[53] = -6.327; + MWA[54] = -6.893; MWA[55] = -7.367; + MWA[56] = -7.756; MWA[57] = -8.064; + MWA[58] = -8.297; MWA[59] = -8.46; + MWA[60] = -8.56; MWA[61] = -8.602; + MWA[62] = -8.591; MWA[63] = -8.533; + MWA[64] = -8.433; MWA[65] = -8.296; + MWA[66] = -8.127; MWA[67] = -7.93; + MWA[68] = -7.709; MWA[69] = -7.469; + MWA[70] = -7.212; MWA[71] = -6.943; + MWA[72] = -6.663; MWA[73] = -6.378; + MWA[74] = -6.087; MWA[75] = -5.795; + MWA[76] = -5.503; MWA[77] = -5.213; + MWA[78] = -4.927; MWA[79] = -4.646; + MWA[80] = -4.371; MWA[81] = -4.103; + MWA[82] = -3.843; MWA[83] = -3.593; + MWA[84] = -3.352; MWA[85] = -3.12; + MWA[86] = -2.899; MWA[87] = -2.689; + MWA[88] = -2.489; MWA[89] = -2.3; + MWA[90] = -2.121; MWA[91] = -1.952; + MWA[92] = -1.794; MWA[93] = -1.645; + MWA[94] = -1.506; MWA[95] = -1.377; + MWA[96] = -1.256; MWA[97] = -1.144; + MWA[98] = -1.041; MWA[99] = -0.9449; + MWA[100] = -0.8564; MWA[101] = -0.775; + MWA[102] = -0.7001; MWA[103] = -0.6315; + MWA[104] = -0.5687; MWA[105] = -0.5113; + MWA[106] = -0.459; MWA[107] = -0.4114; + MWA[108] = -0.3681; MWA[109] = -0.3289; + MWA[110] = -0.2934; MWA[111] = -0.2614; + MWA[112] = -0.2325; MWA[113] = -0.2064; + MWA[114] = -0.183; MWA[115] = -0.1621; + MWA[116] = -0.1433; MWA[117] = -0.1265; + MWA[118] = -0.1115; MWA[119] = -9.813E-2; + MWA[120] = -8.624E-2; MWA[121] = -7.569E-2; + MWA[122] = -6.632E-2; MWA[123] = -5.803E-2; + MWA[124] = -5.071E-2; MWA[125] = -4.424E-2; + MWA[126] = -3.855E-2; MWA[127] = -3.353E-2; + MWA[128] = -2.914E-2; MWA[129] = -2.528E-2; + MWA[130] = -0.0219; MWA[131] = -1.894E-2; + MWA[132] = -1.637E-2; MWA[133] = -1.412E-2; + MWA[134] = -1.217E-2; MWA[135] = -1.046E-2; + MWA[136] = -8.988E-3; MWA[137] = -7.72E-3; + MWA[138] = -6.567E-3; MWA[139] = -5.802E-3; + MWA[140] = -0.0053; MWA[141] = -4.7E-4; + MWA[142] = -4.3E-4; + + for (j = 0; j <= 11; j++) + CoWA[j] = 0.0; + + CoWA[12] = 1.25E-5; CoWA[13] = 3.87E-5; + CoWA[14] = 1.004E-4; CoWA[15] = 2.703E-4; + CoWA[16] = 6.507E-4; CoWA[17] = 1.3985E-3; + CoWA[18] = 2.8353E-3; CoWA[19] = 5.1911E-3; + CoWA[20] = 8.9486E-3; CoWA[21] = 1.41773E-2; + CoWA[22] = 2.16551E-2; CoWA[23] = 3.1489E-2; + CoWA[24] = 4.34123E-2; CoWA[25] = 5.78719E-2; + CoWA[26] = 7.46921E-2; CoWA[27] = 9.45265E-2; + CoWA[28] = 1.165183E-1; CoWA[29] = 1.406353E-1; + CoWA[30] = 1.662849E-1; CoWA[31] = 1.929895E-1; + CoWA[32] = 2.189347E-1; CoWA[33] = 2.457772E-1; + CoWA[34] = 2.704794E-1; CoWA[35] = 2.947906E-1; + CoWA[36] = 3.169854E-1; CoWA[37] = 3.377435E-1; + CoWA[38] = 3.573555E-1; CoWA[39] = 3.751205E-1; + CoWA[40] = 3.906829E-1; CoWA[41] = 4.039806E-1; + CoWA[42] = 4.142483E-1; CoWA[43] = 4.22779E-1; + CoWA[44] = 4.288013E-1; CoWA[45] = 4.330353E-1; + CoWA[46] = 4.34452E-1; CoWA[47] = 4.338138E-1; + CoWA[48] = 4.31504E-1; CoWA[49] = 4.272541E-1; + CoWA[50] = 4.220568E-1; CoWA[51] = 4.158229E-1; + CoWA[52] = 4.083281E-1; CoWA[53] = 3.981182E-1; + CoWA[54] = 3.871678E-1; CoWA[55] = 3.755527E-1; + CoWA[56] = 3.628823E-1; CoWA[57] = 3.520135E-1; + CoWA[58] = 3.400924E-1; CoWA[59] = 3.280532E-1; + CoWA[60] = 3.139477E-1; CoWA[61] = 2.997087E-1; + CoWA[62] = 2.849179E-1; CoWA[63] = 2.710475E-1; + CoWA[64] = 2.576478E-1; CoWA[65] = 2.449155E-1; + CoWA[66] = 2.317447E-1; CoWA[67] = 2.193161E-1; + CoWA[68] = 2.072622E-1; CoWA[69] = 1.956955E-1; + CoWA[70] = 1.846514E-1; CoWA[71] = 1.734096E-1; + CoWA[72] = 1.622678E-1; CoWA[73] = 1.520447E-1; + CoWA[74] = 1.416351E-1; CoWA[75] = 1.32136E-1; + CoWA[76] = 1.231861E-1; CoWA[77] = 1.150411E-1; + CoWA[78] = 1.071536E-1; CoWA[79] = 9.9465E-2; + CoWA[80] = 9.22347E-2; CoWA[81] = 8.54394E-2; + CoWA[82] = 7.87697E-2; CoWA[83] = 7.23848E-2; + CoWA[84] = 6.6587E-2; CoWA[85] = 6.15849E-2; + CoWA[86] = 5.6573E-2; CoWA[87] = 5.17893E-2; + CoWA[88] = 4.70011E-2; CoWA[89] = 4.2886E-2; + CoWA[90] = 3.91224E-2; CoWA[91] = 3.53163E-2; + CoWA[92] = 3.20884E-2; CoWA[93] = 2.92264E-2; + CoWA[94] = 2.66058E-2; CoWA[95] = 2.37352E-2; + CoWA[96] = 2.14669E-2; CoWA[97] = 1.94848E-2; + CoWA[98] = 1.75591E-2; CoWA[99] = 1.58232E-2; + CoWA[100] = 1.40302E-2; CoWA[101] = 1.24349E-2; + CoWA[102] = 1.11856E-2; CoWA[103] = 9.9765E-3; + CoWA[104] = 8.9492E-3; CoWA[105] = 8.0063E-3; + CoWA[106] = 7.1509E-3; CoWA[107] = 6.3196E-3; + CoWA[108] = 5.6856E-3; CoWA[109] = 5.0686E-3; + CoWA[110] = 4.5085E-3; CoWA[111] = 3.9895E-3; + CoWA[112] = 3.4804E-3; CoWA[113] = 3.0447E-3; + CoWA[114] = 2.7012E-3; CoWA[115] = 2.2984E-3; + CoWA[116] = 2.0283E-3; CoWA[117] = 1.7399E-3; + CoWA[118] = 1.5032E-3; CoWA[119] = 1.3267E-3; + CoWA[120] = 1.1531E-3; CoWA[121] = 9.92E-4; + CoWA[122] = 9.211E-4; CoWA[123] = 8.296E-4; + CoWA[124] = 6.991E-4; CoWA[125] = 5.84E-4; + CoWA[126] = 5.12E-4; CoWA[127] = 4.314E-4; + CoWA[128] = 3.593E-4; CoWA[129] = 3.014E-4; + CoWA[130] = 2.401E-4; CoWA[131] = 2.004E-4; + CoWA[132] = 1.614E-4; CoWA[133] = 1.257E-4; + CoWA[134] = 1.112E-4; CoWA[135] = 9.22E-5; + CoWA[136] = 8.77E-5; CoWA[137] = 6.22E-5; + CoWA[138] = 4.93E-5; CoWA[139] = 3.92E-5; + CoWA[140] = 3.15E-5; CoWA[141] = 1.03E-5; + CoWA[142] = 9.6E-6; +} + + +/*-------------------------------------------------------------------------*/ + +double fdist_WatsonG (long n, double X) +/* + * Approximation of the cumulative distribution function of the + * fdist_WatsonG statistics by the cubic spline function. + * Y[.] - tabular value of the statistic; + * M[.] - tabular value of the first derivative; + */ +{ + static int WatsonFlag = 0; + const double MinArg = 0.15; + const double MaxArg = 1.5; + const double MinTab = 0.1; + const double Step = 0.01; + int i, j; + double Tj; + double Ti; + double R; + double P; + double H; + double Res; + + util_Assert (n > 0, "fdist_WatsonG: N <= 0"); + + if (n == 1) /* n = 1, degenerate case */ + return 0.5; + + if (!WatsonFlag) { + /* Initialization of the interpolation table */ + WatsonGInit (); + WatsonFlag = 1; + } + + if (X <= MinArg) + return 0.0; + if (X >= 10.0) + return 1.0; + if (X > MaxArg) { + R = exp (19.0 - 20.0 * X); + Res = 1.0 - R; + /* Empirical Correction in 1/sqrt(n) */ + R = exp (13.34 - 15.26 * X) / sqrt ((double) n); + Res += R; + /* The correction in 1/sqrt(n) is not always precise */ + if (Res >= 1.0) + return 1.0; + else + return Res; + } + + /* Search of the correct slot in the interpolation table */ + i = (int) ((X - MinTab) / Step) + 1; + Ti = MinTab + i * Step; + Tj = Ti - Step; + /* Approximation within the slot */ + j = i - 1; + H = X - Tj; + R = Ti - X; + P = Step * Step / 6.0; + Res = ((MWA[j] * R * R * R + MWA[i] * H * H * H) / 6.0) / Step; + Res += ((YWA[j] - MWA[j] * P) * R + (YWA[i] - MWA[i] * P) * H) / Step; + + /* Empirical correction in 1/sqrt(n) */ + Res += (CoWA[i] * H + CoWA[j] * R) / (Step * sqrt ((double) n)); + + if (Res >= 1.0) + return 1.0; + return Res; +} + + +/*=========================================================================*/ +#define AD_X0 0.38629436111989062 +#define AD_X1 37.816242111357 + +static double AD_N_1 (double x) +{ + /* The Anderson-Darling distribution for N = 1 */ + double term; + if (x <= AD_X0) + return 0.0; + if (x >= AD_X1) + return 1.0; + if (x - AD_X0 >= 1.0e-3) + term = 1.0 - 4.0 * exp (-x - 1.0); + else { + const double q = x - AD_X0; + term = q*(1.0 - q*(0.5 - q/6.0)); + } + return sqrt (term); +} + +#undef AD_X0 +#undef AD_X1 +/*=========================================================================*/ + +double fdist_AndersonDarling (long N, double x) +{ + if (1 == N) + return AD_N_1 (x); + util_Assert (N > 0, "fdist_AndersonDarling: N <= 0"); + + if (x <= 0.0) + return 0.0; + if (x >= fdist_XBIG) + return 1.0; + + if (x <= 0.2) { + /* Sinclair and Spurr lower tail approximation (3.6) */ + double q; + q = 1.784 + 0.9936*x + 0.03287/x - (2.018 + 0.2029/x)/sqrt (x); + if (q < -18.0) + return exp(q); + q = 1.0 + exp(q); + return 1.0 - 1.0 / q; + } + return 1.0 - fbar_AndersonDarling (N, x); +} + + +/*=========================================================================*/ +/* The following code is part of Marsaglia's file ADinf.c. + Very little has been changed to adapt it to ProbDist. The file was + downloaded from the site of the Journal of Statistical Software + http://www.jstatsoft.org/v09/i02/ +*/ + +/*--------------------------------------------------------------------------*/ + /* This is file ADinf.c */ +/* +A procedure for evaluating the limiting distribution of the + Anderson-Darling statistic A_n= +-n-(1/n)[ln(x_1(1-x_n)+3ln(x_2(1-x_{n-1})+5ln(x_3(1-x_{n-2})+... + +(2n-1)ln(x_n(1-x_1))] + where x_1infty} Pr[A_n 150.) + return 0.; + a = 2.22144146907918 * exp (-t) / sqrt (t); + /* initialization requires cPhi */ + /* if you have erfc(), replace 2*cPhi(sqrt(2*t)) with erfc(sqrt(t)) */ + b = 3.93740248643060 * 2. * fbar_Normal2 (sqrt (2 * t)); + + r = z * .125; + f = a + b * r; + for (i = 1; i < 200; i++) { + c = ((i - .5 - t) * b + t * a) / i; + a = b; + b = c; + r *= z / (8 * i + 8); + if (fabs (r) < 1e-40 || fabs (c) < 1.e-40) + return f; + fnew = f + c * r; + if (f == fnew) + return f; + f = fnew; + } + return f; +} + + +static double ADinf (double z) +{ + int j; + double ad, adnew, r; + if (z < .01) + return 0.; /* avoids exponent limits; ADinf(.01)=.528e-52 */ + r = 1. / z; + ad = r * ADf (z, 0); + for (j = 1; j < 100; j++) { + r *= (.5 - j) / j; + adnew = ad + (4 * j + 1) * r * ADf (z, j); + if (ad == adnew) { + return ad; + } + ad = adnew; + } + return ad; + +} + + +/*------------------------------------------------------------------------*/ +/* The following code is part of Marsaglia's file AnDarl.c. + Very little has been changed to adapt it to ProbDist. The file was + downloaded from the site of the Journal of Statistical Software + http://www.jstatsoft.org/v09/i02/ +--------------------------------------*/ + +/* + Anderson-Darling test for uniformity. Given an ordered set + x_10. */ +static double adinf (double z) +{ + if (z < 2.) + return exp (-1.2337141 / z) / sqrt (z) * (2.00012 + (.247105 - + (.0649821 - (.0347962 - (.011672 - + .00168691 * z) * z) * z) * z) * z); + /* max |error| < .000002 for z<2, (p=.90816...) */ + return + exp (-exp (1.0776 - (2.30695 - (.43424 - (.082433 - (.008056 - + .0003146 * z) * z) * z) * z) * z)); + /* max |error|<.0000008 for 4 .8) { + v = (-130.2137 + (745.2337 - (1705.091 - (1950.646 - (1116.360 - + 255.7844 * x) * x) * x) * x) * x) / n; + return x + v; + } + c = .01265 + .1757 / n; + if (x < c) { + v = x / c; + v = sqrt (v) * (1. - v) * (49 * v - 102); + return x + v * (.0037 / (n * n) + .00078 / n + .00006) / n; + } + v = (x - c) / (.8 - c); + v = -.00022633 + (6.54034 - (14.6538 - (14.458 - (8.259 - + 1.91864 * v) * v) * v) * v) * v; + return x + v * (.04213 + .01365 / n) / n; +} + +/* You must give the ADtest(int n, double *x) routine a sorted array + x[0]<=x[1]<=..<=x[n-1] + that you are testing for uniformity. + It will return the p-value associated + with the Anderson-Darling test, using + the above adinf() and errfix( , ) + Not well-suited for n<7, + (accuracy could drop to 3 digits). +*/ + + +/*=========================================================================*/ +#if 0 + +double fdist_AndersonDarling2 (long N, double x) +{ + /* This version uses the more exact limiting distribution ADinf */ + if (1 == N) + return AD_N_1 (x); + return AD (N, x, 0); +} + +#else + +double fdist_AndersonDarling2 (long N, double x) +{ + /* This version uses the approximate limiting distribution adinf */ + if (1 == N) + return AD_N_1 (x); + return AD ((int)N, x, 1); +} + +#endif +/*=========================================================================*/ + + +/***************************************\ + * + * DISCRETE DISTRIBUTIONS + * +\***************************************/ + + + + +/*=========================================================================*/ + +double fdist_Geometric (double p, long s) +{ + util_Assert (p >= 0.0 && p <= 1.0, "fdist_Geometric: p not in [0, 1]"); + if (s < 0) + return 0.0; + if (p >= 1.0) /* In fact, p == 1 */ + return 1.0; + if (p <= 0.0) /* In fact, p == 0 */ + return 0.0; + return 1.0 - pow (1.0 - p, (double) (s + 1)); +} + + +/*=========================================================================*/ + +double fdist_Poisson1 (double lam, long s) +/* + * On our machine, computing a value using fdist_Gamma is faster than the + * naive computation for lamlim > 150.0, slower for lamlim < 150.0 + */ +{ + const double lamlim = 150.0; + long i; + double term, sum; + + util_Assert (lam >= 0.0, "fdist_Poisson1: lambda < 0"); + if (lam == 0.0) + return 1.0; + if (s < 0) + return 0.0; + + /* If lam > lamlim, we use the Chi2 distribution according to the exact + relation, with 2s + 2 degrees of freedom fdist_Poisson (lam, s) = 1 - + fdist_ChiSquare (2s + 2, 2*lam) which also equals 1 - fdist_Gamma (s + + 1, lam) */ + if (lam > lamlim) + return fbar_Gamma (s + 1.0, 15, lam); + + /* Naive computation: sum all prob. from i = 0 to i = s */ + sum = term = exp (-lam); + for (i = 1; i <= s; i++) { + term *= lam / i; + sum += term; + } + return sum; +} + + +/*=========================================================================*/ + +double fdist_Poisson2 (fmass_INFO W, long s) +{ + double lam; + util_Assert (W != NULL, "fdist_Poisson2: fmass_INFO is NULL pointer"); + lam = W->paramR[0]; + + if (s < 0) + return 0.0; + if (lam == 0.0) + return 1.0; + + /* For large lam, we use the Chi2 distribution according to the exact + relation, with 2s + 2 degrees of freedom + + fdist_Poisson (lam, s) = 1 - fdist_ChiSquare (2s + 2, 2*lam) + + which equals also 1 - fdist_Gamma (s + 1, lam) */ + if (W->cdf == NULL) + return fbar_Gamma (s + 1.0, 15, lam); + + if (s >= W->smax) + return 1.0; + + if (s < W->smin) { + /* Sum RMAX dominant terms to get a few decimals in the lower tail. One + could also call fbar_Gamma (s + 1.0, 15, lam) */ + const long RMAX = 20; + long i; + double term = fmass_PoissonTerm1 (lam, s); + double Sum = term; + i = s; + while (i > 0 && i >= s - RMAX) { + term = term * i / lam; + i--; + Sum += term; + } + return Sum; + } + + if (s <= W->smed) + return W->cdf[s - W->smin]; + else + /* We keep the complementary distribution in the upper part of cdf */ + return 1.0 - W->cdf[s + 1 - W->smin]; +} + + +/*=========================================================================*/ + +double fdist_Binomial1 (long n, double p, long s) +{ + const int nlim1 = 10000; + const double varlim = 100.0; + double epsilon = fmass_Epsilon; + double y, z, q = 1.0 - p; + double sum, term, termmid; + long i, mid; + int flag = 0; + + util_Assert (p >= 0.0 && p <= 1.0, "fdist_Binomial1: p not in [0, 1]"); + util_Assert (n >= 0, "fdist_Binomial1: n < 0"); + + if (0 == n) + return 1.0; + if (s < 0) + return 0.0; + if (s >= n) + return 1.0; + if (p <= 0.0) + return 1.0; + if (p >= 1.0) + return 0.0; /* For any s < n */ + + if (n < nlim1) { /* Exact Binomial */ + /* Sum RMAX terms to get a few decimals in the lower tail */ + const long RMAX = 20; + mid = (long) ((n + 1) * p); + if (mid > s) + mid = s; + sum = term = termmid = fmass_BinomialTerm3 (n, p, mid); + + z = q / p; + i = mid; + while (term >= epsilon || i >= mid - RMAX) { + term *= z * i / (n - i + 1); + sum += term; + i--; + if (i == 0) break; + } + + z = p / q; + term = termmid; + for (i = mid; i < s; i++) { + term *= z * (n - i) / (i + 1); + if (term < epsilon) + break; + sum += term; + } + return sum; + + } else { + if ((p > 0.5) || ((p == 0.5) && (s > n / 2))) { + /* use F(p, n, s) = 1 - F(q, n, n-s-1) */ + p = q; + q = 1.0 - p; + flag = 1; + s = n - s - 1; + } + if (n * p * q > varlim) { /* Normal approximation */ + /* Uses the Camp-Paulson approximation based on the F-distribution. + Its maximum absolute error is smaller than 0.007 / sqrt (npq). + Ref: W. Molenaar; Approximations to the Poisson, Binomial,.... + QA273.6 M64, p. 93 (1970) */ + term = pow ((s + 1) * q / ((n - s) * p), 1.0 / 3.0); + y = term * (9 - 1.0 / (s + 1)) - 9 + 1.0 / (n - s); + z = 3.0 * sqrt (term * term / (s + 1) + 1.0 / (n - s)); + y /= z; + if (flag) { + return fbar_Normal1 (y); + } else { + return fdist_Normal2 (y); + } + + } else { /* Poisson approximation */ + /* Uses a Bol'shev approximation based on the Poisson distribution. + Error is O(1/n^4) as n -> infinity. Ref: W. Molenaar; + Approximations to the Poisson, Binomial,.... QA273.6 M64, p. 107, + Table 6.2, Formule lambda_9 (1970). */ + y = (2 * n - s) * p / (2.0 - p); + z = (2.0 * y * y - s * y - (double)s * s - 2 * s) / (6 * (2 * n - + (double)s) * (2 * n - s)); + z = y / (1 - z); + if (flag) { + return fbar_Poisson1 (z, s - 1); + } else { + return fdist_Poisson1 (z, s); + } + } + } +} + + +/*=========================================================================*/ + +double fdist_Binomial2 (fmass_INFO W, long s) +{ + double p; + long n; + + util_Assert (W != NULL, "fdist_Binomial2: fmass_INFO is NULL pointer"); + n = W->paramI[0]; + p = W->paramR[0]; + util_Assert (p >= 0.0 && p <= 1.0, "fdist_Binomial2: p not in [0, 1]"); + + if (0 == n) + return 1.0; + if (s < 0) + return 0.0; + if (s >= n) + return 1.0; + if (p == 0.0) + return 1.0; + if (p == 1.0) + return 0.0; + + if (W->cdf != NULL) { + if (s >= W->smax) + return 1.0; + if (s < W->smin) { + /* Sum RMAX terms to get a few decimals in the lower tail */ + const long RMAX = 20; + long i; + double term = fmass_BinomialTerm3 (n, p, s); + double Sum = term; + const double z = (1.0 - p) / p; + i = s; + while (i > 0 && i >= s - RMAX) { + term *= z * i / (n - i + 1); + i--; + Sum += term; + } + return Sum; + } + if (s <= W->smed) + return W->cdf[s - W->smin]; + else + /* We keep the complementary distribution in the upper part of cdf */ + return 1.0 - W->cdf[s + 1 - W->smin]; + + } else { + return fdist_Binomial1 (n, p, s); + } +} + + +/*=========================================================================*/ + +double fdist_NegaBin1 (long n, double p, long s) +{ + const double epsilon = fmass_Epsilon; + const long lim1 = 100000; + double sum, term, termmode; + long i, mode; + + util_Assert (p >= 0.0 && p <= 1.0, "fdist_NegaBin1: p not in [0, 1]"); + util_Assert (n > 0, "fdist_NegaBin1: n < 1"); + + if (s < 0) + return 0.0; + if (p >= 1.0) /* In fact, p == 1 */ + return 1.0; + if (p <= 0.0) /* In fact, p == 0 */ + return 0.0; + + /* Compute the maximum term */ + mode = 1 + (long) ((n * (1.0 - p) - 1.0) / p); + if (mode > s) + mode = s; + + if (mode <= lim1) { + sum = term = termmode = fmass_NegaBinTerm1 (n, p, mode); + for (i = mode; i > 0; i--) { + term *= i / ((1.0 - p) * (n + i - 1)); + if (term < epsilon) + break; + sum += term; + } + + term = termmode; + for (i = mode; i < s; i++) { + term *= (1.0 - p) * (n + i) / (i + 1); + if (term < epsilon) + break; + sum += term; + } + if (sum <= 1.0) + return sum; + else + return 1.0; + + } else { + return 1.0 - fdist_Binomial1 (s + n, p, n - 1); + } +} + + +/*=========================================================================*/ + +double fdist_NegaBin2 (fmass_INFO W, long s) +{ + double p; + long n; + + util_Assert (W != NULL, "fdist_NegaBin2: fmass_INFO is NULL pointer"); + n = W->paramI[0]; + p = W->paramR[0]; + util_Assert (p >= 0.0 && p <= 1.0, "fdist_NegaBin2: p not in [0, 1]"); + + if (s < 0) + return 0.0; + if (p >= 1.0) /* In fact, p == 1 */ + return 1.0; + if (p <= 0.0) /* In fact, p == 0 */ + return 0.0; + + if (W->cdf != NULL) { + if (s >= W->smax) + return 1.0; + if (s < W->smin) + return fdist_NegaBin1 (n, p, s); + if (s <= W->smed) + return W->cdf[s - W->smin]; + else + /* We keep the complementary distribution in the upper part of cdf */ + return 1.0 - W->cdf[s + 1 - W->smin]; + + } else { + return fdist_NegaBin1 (n, p, s); + } +} + + +/*=========================================================================*/ + +double fdist_Scan (long N, double d, long m) +{ + return 1.0 - fbar_Scan (N, d, m); +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/fmarsa.c b/cbits/testu/src/fmarsa.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fmarsa.c @@ -0,0 +1,483 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: fmarsa.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "util.h" +#include "gofs.h" +#include "num.h" + +#include "fmarsa.h" +#include "fcho.h" +#include "ffam.h" +#include "fres.h" +#include "ftab.h" +#include "smarsa.h" +#include "unif01.h" + +#include +#include +#include + +long fmarsa_Maxn = 1024 * 1024 * 32; +long fmarsa_MaxL = 1024 * 4; + + + + +/*------------------------------ Functions --------------------------------*/ + + +static void InitRes2 ( + ffam_Fam *fam, + fmarsa_Res2 *res, /* Results holder */ + int N, /* Number of replications */ + int Nr, + int j1, int j2, int jstep, + char *name1, + char *name2 +) +/* + * Initializes the fmarsa_Res2 structure + */ +{ + fres_InitCont (fam, res->GCD, N, Nr, j1, j2, jstep, name1); + fres_InitCont (fam, res->NumIter, N, Nr, j1, j2, jstep, name2); +} + + +/*-------------------------------------------------------------------------*/ + +fmarsa_Res2 * fmarsa_CreateRes2 (void) +{ + fmarsa_Res2 *res; + res = util_Malloc (sizeof (fmarsa_Res2)); + res->NumIter = fres_CreateCont (); + res->GCD = fres_CreateCont (); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void fmarsa_DeleteRes2 (fmarsa_Res2 *res) +{ + if (res == NULL) + return; + fres_DeleteCont (res->GCD); + fres_DeleteCont (res->NumIter); + util_Free (res); +} + + +/*=========================================================================*/ + +static void PrintHead (char *test, ffam_Fam * fam, + long N, long n, int r, int s, int L, int t, int p, + int Nr, int j1, int j2, int jstep) +{ + printf + ("\n\n================================================================\n"); + printf ("Family: %s\n\n", fam->name); + printf ("Test: %s\n", test); + printf (" N = %ld,", N); + if (n) + printf (" n = %ld,", n); + printf (" r = %d,", r); + if (s) + printf (" s = %d,", s); + if (L) + printf (" L = %d", L); + if (t) + printf (" t = %d,", t); + if (p) + printf (" p = %d", p); + printf ("\n Nr = %d, j1 = %d, j2 = %d, jstep = %d\n\n", + Nr, j1, j2, jstep); +} + + +/*=========================================================================*/ + +static int CheckParamMat (int prec, void *cho, + long *pn, int *pr, int *ps, long *pL, long LMin, int i, int j) +/* + * Set the values of the parameters for the test. If a parameter is < 0, + * will call a choose function to set it. Otherwise, will accept it as is. + * Returns 0 if parameters are ok for the test, returns -1 if the test + * should not be done for these parameters. + */ +{ + fcho_Cho2 *cho2 = cho; + fcho_Cho *chon; + fcho_Cho *choL; + + util_Assert (cho, "fmarsa: cho is NULL"); + chon = cho2->Chon; + choL = cho2->Chop2; + if (*pn < 0) { + util_Assert (chon, "fmarsa: n < 0 and chon is NULL"); + *pn = chon->Choose (chon->param, i, j); + + if (*pn <= 3.0 * gofs_MinExpected) { + printf ("n is too small\n\n"); + return -1; + } + if (*pn > fmarsa_Maxn) { + printf ("n > %2ld\n\n", fmarsa_Maxn); + return -1; + } + } + + *ps = fcho_Chooses (*pr, *ps, prec); + if (*ps <= 0) + return -1; + + if (*pL < 0) { + util_Assert (choL, "fmarsa: L < 0 and chop2 is NULL"); + *pL = choL->Choose (choL->param, i, j); + + if (*pL <= LMin) { + printf ("L is too small\n\n"); + return -1; + } + if (*pL > fmarsa_MaxL) { + printf ("L > %2ld\n\n", fmarsa_MaxL); + return -1; + } + } + return 0; +} + + +/*=========================================================================*/ + + +static void TabMatrixR (ffam_Fam * fam, void *res1, void *cho, + void *par1, int i, int j, int irow, int icol) +{ + int r, s; + long N, n, L; + const long *Par = par1; + fres_Cont *fres = res1; + sres_Chi2 *sres; + + N = Par[0]; + n = Par[1]; + r = Par[2]; + s = Par[3]; + L = Par[4]; + + if (CheckParamMat (fam->Resol[irow], cho, &n, &r, &s, &L, 1, i, j)) + return; + + sres = sres_CreateChi2 (); + smarsa_MatrixRank (fam->Gen[irow], sres, N, n, r, s, L, L); + fres_FillTableEntryC (fres, sres->pVal2, N, irow, icol); + sres_DeleteChi2 (sres); +} + + +/*-------------------------------------------------------------------------*/ + +void fmarsa_MatrixR1 (ffam_Fam * fam, fres_Cont * res, fcho_Cho2 * cho, + long N, long n, int r, int s, int L, int Nr, int j1, int j2, int jstep) +{ + long Par[5] = { 0 }; + lebool localRes; + + Par[0] = N; + Par[1] = n; + Par[2] = r; + Par[3] = s; + Par[4] = L; + if (res == NULL) { + localRes = TRUE; + res = fres_CreateCont (); + } else + localRes = FALSE; + + util_Assert (n < 0 || L < 0, + "fmarsa_MatrixR1: Either n or L must be < 0" ); + PrintHead ("fmarsa_MatrixR1", fam, N, n, r, s, L, 0, 0, Nr, j1, j2, + jstep); + fres_InitCont (fam, res, N, Nr, j1, j2, jstep, "fmarsa_MatrixR1"); + ftab_MakeTables (fam, res, cho, Par, TabMatrixR, Nr, j1, j2, jstep); + fres_PrintCont (res); + if (localRes) + fres_DeleteCont (res); +} + + +/*=========================================================================*/ + +static void WriteBirthEC (void *vpar, long junk1, long junk2) +{ + double *Par = vpar; + double EC = Par[2]; + printf ("Choose d such that EC = %f\n\n", EC); +} + +/*-------------------------------------------------------------------------*/ + +static double ChooseBirthEC (void *vpar, long n, long junk) +{ + double *Par = vpar; + long N = Par[0]; + int t = Par[1]; + double EC = Par[2]; + long d; + double k, dr; + double Mu; + + WriteBirthEC (vpar, 0, 0); + k = (N * (double) n * n * n) / (4.0 * EC); + if (k >= smarsa_Maxk) { + printf ("k >= %2.0f\n\n", smarsa_Maxk); + return -1.0; + } + d = dr = pow (k, 1.0 / t); + if (dr > LONG_MAX) { + printf ("d > LONG_MAX\n\n"); + return -1.0; + } + + k = pow ((double) d, (double) t); + Mu = N * (double) n * n * n / (4.0 * k); + if (8.0 * Mu > sqrt (sqrt (k))) { + printf ("8 EC > k^(1/4)\n\n"); + return -1.0; + } + return (double) d; +} + +/*-------------------------------------------------------------------------*/ + +fcho_Cho *fmarsa_CreateBirthEC (long N, int t, double EC) +{ + fcho_Cho *cho; + double *Par; + + cho = util_Malloc (sizeof (fcho_Cho)); + Par = util_Calloc (3, sizeof (double)); + Par[0] = N; + Par[1] = t; + Par[2] = EC; + cho->param = Par; + cho->Write = WriteBirthEC; + cho->Choose = ChooseBirthEC; + cho->name = util_Calloc (2, sizeof (char)); + strcpy (cho->name, "d"); + return cho; +} + +/*-------------------------------------------------------------------------*/ + +void fmarsa_DeleteBirthEC (fcho_Cho * cho) +{ + if (NULL == cho) + return; + cho->name = util_Free (cho->name); + cho->param = util_Free (cho->param); + util_Free (cho); +} + + +/*=========================================================================*/ + +static int CheckParamBirth (int prec, void *cho, + long *pn, int *pr, long *pd, int i, int j) +/* + * Set the values of the parameters for the test. + * Returns 0 if parameters are ok for the test, returns -1 if the test + * should not be done for these parameters. + */ +{ + fcho_Cho2 *cho2 = cho; + fcho_Cho *chon; + fcho_Cho *chod; + int s; + + util_Assert (cho, "fmarsa: cho is NULL"); + chon = cho2->Chon; + chod = cho2->Chop2; + util_Assert (chon, "fmarsa: chon is NULL"); + *pn = chon->Choose (chon->param, i, j); + if (*pn > fmarsa_Maxn) { + printf ("n > %2ld\n\n", fmarsa_Maxn); + return -1; + } + + util_Assert (chod, "fmarsa: chop2 is NULL"); + *pd = chod->Choose (chod->param, *pn, 0); + if (*pd <= 1.0) + return -1; + + s = num_Log2 ((double) *pd); + if (*pr + s > prec) { + printf ("r + Lg(d) > Resolution of generator\n\n"); + return -1; + } + + return 0; +} + + +/*=========================================================================*/ + +static void TabBirthdayS (ffam_Fam * fam, void *vres, void *cho, + void *vpar, int i, int j, int irow, int icol) +{ + int r, t, p; + long N, n, d; + const long *Par = vpar; + fres_Poisson *fres = vres; + sres_Poisson *sres; + + N = Par[0]; + r = Par[1]; + t = Par[2]; + p = Par[3]; + + if (CheckParamBirth (fam->Resol[irow], cho, &n, &r, &d, i, j)) + return; + + sres = sres_CreatePoisson (); + smarsa_BirthdaySpacings (fam->Gen[irow], sres, N, n, r, d, t, p); + fres_FillTableEntryPoisson (fres, sres->Mu, sres->sVal2, sres->pLeft, + sres->pRight, sres->pVal2, irow, icol); + sres_DeletePoisson (sres); +} + + +/*-------------------------------------------------------------------------*/ + +void fmarsa_BirthdayS1 (ffam_Fam * fam, fres_Poisson * res, fcho_Cho2 * cho, + long N, int r, int t, int p, int Nr, int j1, int j2, int jstep) +{ + long Par[4] = { 0 }; + lebool localRes; + + Par[0] = N; + Par[1] = r; + Par[2] = t; + Par[3] = p; + + if (res == NULL) { + localRes = TRUE; + res = fres_CreatePoisson (); + } else + localRes = FALSE; + + PrintHead ("fmarsa_BirthdayS1", + fam, N, 0, r, 0, 0, t, p, Nr, j1, j2, jstep); + fres_InitPoisson (fam, res, Nr, j1, j2, jstep, "fmarsa_BirthdayS1"); + ftab_MakeTables (fam, res, cho, Par, TabBirthdayS, Nr, j1, j2, jstep); + ftab_PrintTable2 (res->Exp, res->Obs, FALSE); + ftab_PrintTable (res->PVal2); + if (localRes) + fres_DeletePoisson (res); +} + + +/*========================================================================*/ + +void fmarsa_SerialOver1 (void) +{ + util_Error ("fmarsa_SerialOver1: use fmultin_SerialOver1 instead"); +} + +/*========================================================================*/ + +void fmarsa_CollisionOver1 (void) +{ + util_Error ("fmarsa_CollisionOver1: use fmultin_SerialOver1 instead"); +} + + +/*=========================================================================*/ + +static void TabGCD (ffam_Fam * fam, void *res1, void *cho, + void *par1, int i, int j, int irow, int icol) +{ + int r, s; + long N, n; + const long *Par = par1; + fmarsa_Res2 *fres = res1; + smarsa_Res2 *sres; + + N = Par[0]; + r = Par[1]; + s = Par[2]; + + n = fcho_ChooseParamL (cho, (long) (3.0 * gofs_MinExpected), + fmarsa_Maxn, i, j); + if (n <= 0) + return; + s = fcho_Chooses (r, s, fam->Resol[irow]); + if (s <= 0) + return; + + sres = smarsa_CreateRes2 (); + smarsa_GCD (fam->Gen[irow], sres, N, n, r, s); + fres_FillTableEntryC (fres->GCD, sres->GCD->pVal2, N, irow, icol); + fres_FillTableEntryC (fres->NumIter, sres->NumIter->pVal2, N, irow, icol); + smarsa_DeleteRes2 (sres); +} + + +/*-------------------------------------------------------------------------*/ + +void fmarsa_GCD1 (ffam_Fam *fam, fmarsa_Res2 *res, fcho_Cho *cho, + long N, int r, int s, int Nr, int j1, int j2, int jstep) +{ + long Par[3] = { 0 }; + lebool localRes; + + Par[0] = N; + Par[1] = r; + Par[2] = s; + if (res == NULL) { + localRes = TRUE; + res = fmarsa_CreateRes2 (); + } else + localRes = FALSE; + + PrintHead ("fmarsa_GCD1", fam, N, 0, r, s, 0, 0, 0, Nr, j1, j2, jstep); + InitRes2 (fam, res, N, Nr, j1, j2, jstep, + "fmarsa_GCD1, GCD", "fmarsa_GCD1, NumIter"); + ftab_MakeTables (fam, res, cho, Par, TabGCD, Nr, j1, j2, jstep); + fres_PrintCont (res->GCD); + /* fres_PrintCont (res->NumIter); */ + if (localRes) + fmarsa_DeleteRes2 (res); +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/fmass.c b/cbits/testu/src/fmass.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fmass.c @@ -0,0 +1,780 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: fmass.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "fmass.h" + +#include "util.h" +#include "num.h" +#include "num2.h" + +#include +#include +#include +#include + + +#define TRACE1(N) printf ("********* " #N " = %d\n", N); +#define TRACE2(x) printf ("********* " #x " = %g\n", x); + + +double fmass_Epsilon = 1.0e-16; + +/* When we precompute probability terms until terms are smaller than + fmass_Epsilon, the last few terms will not be very precise. Instead we + add terms as small as fmass_Epsilon * EPS_EXTRA to get a few correct digits + at the tails of the precomputed distributions. */ +static const double EPS_EXTRA = 1 / 100.0; + +double fmass_MaxLambdaPoisson = 100000.0; + +double fmass_MaxnBinomial = 100000.0; + +double fmass_MaxnNegaBin = 100000.0; + + + + +/*=========================================================================*/ + +double fmass_PoissonTerm1 (double lam, long s) +{ + const double lamlim = 20.0; + double y; + double x = s; + double Res; + + if (s < 0) + return 0.0; + + if ((lam < lamlim) && (x < 2.0 * lamlim)) { + Res = exp (-lam) * pow (lam, x) / num2_Factorial (s); + + } else { + y = x * log (lam) - num2_LnGamma (x + 1.0) - lam; + Res = exp (y); + } + + return Res; +} + +/*=========================================================================*/ + +fmass_INFO fmass_CreatePoisson (double lam) +{ + double epsilon; + long i, mid, Nmax; + long imin, imax; + double sum; + fmass_INFO W; + double *P; /* Poisson probability terms */ + double *F; /* Poisson cumulative probabilities */ + + util_Assert (lam >= 0.0, "fmass_CreatePoisson: lambda < 0"); + W = (fmass_INFO) util_Malloc (sizeof (struct fmass_INFO_T)); + W->paramI = NULL; + W->paramR = (double *) util_Malloc (sizeof (double)); + W->paramR[0] = lam; + + /* For lam > fmass_MaxLambdaPoisson, we do not use pre-computed arrays */ + if (lam > fmass_MaxLambdaPoisson) { + W->pdf = NULL; + W->cdf = NULL; + return W; + } + + /* In theory, the Poisson distribution has an infinite range. But */ + /* for i > Nmax, probabilities should be extremely small. */ + Nmax = (long) (lam + 16 * (2 + sqrt (lam))); + P = (double *) util_Calloc ((size_t) (1 + Nmax), sizeof (double)); + F = (double *) util_Calloc ((size_t) (1 + Nmax), sizeof (double)); + + mid = (long) lam; + epsilon = EPS_EXTRA * fmass_Epsilon / fmass_PoissonTerm1 (lam, mid); + /* For large lam, fmass_PoissonTerm1 will lose a few digits of precision */ + /* We shall normalize by explicitly summing all terms >= epsilon */ + sum = P[mid] = 1.0; + + /* Start from the maximum and compute terms > epsilon on each side. */ + i = mid; + while (i > 0 && P[i] > epsilon) { + P[i - 1] = P[i] * i / lam; + i--; + sum += P[i]; + } + W->smin = imin = i; + + i = mid; + while (P[i] > epsilon) { + P[i + 1] = P[i] * lam / (i + 1); + i++; + sum += P[i]; + if (i >= Nmax - 1) { + Nmax *= 2; + P = (double *) util_Realloc (P, (1 + Nmax) * sizeof (double)); + F = (double *) util_Realloc (F, (1 + Nmax) * sizeof (double)); + /* util_Warning (TRUE, "fmass_CreatePoisson: Calling Realloc"); */ + } + } + W->smax = imax = i; + + /* Renormalize the sum of probabilities to 1 */ + for (i = imin; i <= imax; i++) { + P[i] /= sum; + } + + /* Compute the cumulative probabilities until F >= 0.5, and keep them in + the lower part of array, i.e. F[s] contains all P[i] for i <= s */ + F[imin] = P[imin]; + i = imin; + while (i < imax && F[i] < 0.5) { + i++; + F[i] = P[i] + F[i - 1]; + } + /* This is the boundary between F and 1 - F in the CDF */ + W->smed = i; + + /* Compute the cumulative probabilities of the complementary distribution + and keep them in the upper part of the array. i.e. F[s] contains all + P[i] for i >= s */ + F[imax] = P[imax]; + i = imax - 1; + while (i > W->smed) { + F[i] = P[i] + F[i + 1]; + i--; + }; + + /* Reset imin because we lose too much precision for a few terms near + imin when we stop adding terms < epsilon. */ + i = imin; + while (i < W->smed && F[i] < fmass_Epsilon) + i++; + W->smin = imin = i; + + /* Same thing with imax */ + i = imax; + while (i > W->smed && F[i] < fmass_Epsilon) + i--; + W->smax = imax = i; + + W->pdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + W->cdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + for (i = imin; i <= imax; i++) { + W->pdf[i - imin] = P[i]; + W->cdf[i - imin] = F[i]; + } + util_Free (P); + util_Free (F); + return W; +} + +/*-------------------------------------------------------------------------*/ + +double fmass_PoissonTerm2 (fmass_INFO W, long s) +{ + double lam; + + util_Assert (W != NULL, + "fmass_PoissonTerm2: fmass_INFO is NULL pointer"); + lam = W->paramR[0]; + if (s < 0) + return 0.0; + if (W->pdf == NULL) + return fmass_PoissonTerm1 (lam, s); + if (s > W->smax || s < W->smin) + return fmass_PoissonTerm1 (lam, s); + return W->pdf[s - W->smin]; +} + +/*-------------------------------------------------------------------------*/ + +void fmass_DeletePoisson (fmass_INFO W) +{ + if (W == NULL) + return; + util_Free (W->paramR); + util_Free (W->pdf); + util_Free (W->cdf); + util_Free (W); +} + + +/*=========================================================================*/ + +double fmass_BinomialTerm1 (long n, double p, double q, long s) +{ + const long slim = 30; /* To avoid overflow */ + const double maxexp = (DBL_MAX_EXP - 1) * num_Ln2; /* To avoid overflow */ + const double minexp = (DBL_MIN_EXP - 1) * num_Ln2; /* To avoid underflow */ + int signe = 1; + double Res; + + util_Assert (n >= 0, "fmass_BinomialTerm1: n < 0"); + if (0 == n) + return 1.0; + if (s < 0 || s > n) + return 0.0; + + /* Combination(n, s) are symmetric between s and n-s */ + if (s > n / 2) { + s = n - s; + Res = p; + p = q; + q = Res; + } + + if (p < 0.0) { + p = -p; + if (s & 1) + signe *= -1; /* odd s */ + } + if (q < 0.0) { + q = -q; + if ((n - s) & 1) + signe *= -1; /* odd n - s */ + } + + if (n <= slim) { + Res = pow (p, (double) s) * num2_Combination (n, s) * pow (q, + (double) (n - s)); + return signe * Res; + + } else { + /* This could be calculated with more precision as there is some + cancellation because of subtraction of the large LnFactorial: the + last few digits can be lost. But we need the function lgammal in + long double precision. Another possibility would be to use an + asymptotic expansion for the binomial coefficient. */ + Res = s * log (p) + (n - s) * log (q) + num2_LnFactorial (n) + - num2_LnFactorial (n - s) - num2_LnFactorial (s); + util_Assert (Res < maxexp, "fmass_BinomialTerm1: term overflow"); + + if (Res < minexp) + return 0.0; + + return signe * exp (Res); + } +} + + +/*=========================================================================*/ + +double fmass_BinomialTerm4 (long n, double p, double p2, long s) +{ + const long slim = 30; /* To avoid overflow */ + const double maxexp = (DBL_MAX_EXP - 1) * num_Ln2; /* To avoid overflow */ + const double minexp = (DBL_MIN_EXP - 1) * num_Ln2; /* To avoid underflow */ + double Res; + + util_Assert (p >= 0.0 && p <= 1.0, "fmass_BinomialTerm4: p not in [0, 1]"); + util_Assert (p2 >= 0.0 && p2 <= 1.0, "fmass_BinomialTerm4: p2 not in [0, 1]"); + util_Assert (n >= 0, "fmass_BinomialTerm4: n < 0"); + if (0 == n) + return 1.0; + if (s < 0 || s > n) + return 0.0; + + if (n <= slim) { + if (p2 > 1.0e-1) { + Res = pow (p, (double) s) * num2_Combination (n, s) * pow (1.0 - p2, + (double) (n - s)); + } else { + double temp = (n - s)*num2_log1p (-p2); + Res = pow (p, (double) s) * num2_Combination (n, s) * exp(temp); + } + return Res; + + } else { + /* This could be calculated with more precision as there is some + cancellation because of subtraction of the large LnFactorial: the + last few digits can be lost. But we need the function lgammal in + long double precision. Another possibility would be to use an + asymptotic expansion for the binomial coefficient. */ + Res = s * log (p) + (n - s) * num2_log1p(-p2) + num2_LnFactorial (n) + - num2_LnFactorial (n - s) - num2_LnFactorial (s); + util_Assert (Res < maxexp, "fmass_BinomialTerm4: term overflow"); + + if (Res < minexp) + return 0.0; + + return exp (Res); + } +} + + +/*=========================================================================*/ + +double fmass_BinomialTerm3 (long n, double p, long s) +{ + const long slim = 50; /* To avoid overflow */ + const double maxexp = (DBL_MAX_EXP - 1) * num_Ln2; /* To avoid overflow */ + const double minexp = (DBL_MIN_EXP - 1) * num_Ln2; /* To avoid underflow */ + int signe = 1; + double Res; + double q = 1.0 - p; + + /* util_Assert (p >= 0.0 && p <= 1.0, "fmass_BinomialTerm3: p not in [0, + 1]"); */ + util_Assert (n >= 0, "fmass_BinomialTerm3: n < 0"); + if (0 == n) + return 1.0; + if (s < 0 || s > n) + return 0.0; + + /* Combination(n, s) are symmetric between s and n-s */ + if (s > n / 2) { + s = n - s; + Res = p; + p = q; + q = Res; + } + + if (p < 0.0) { + p = -p; + if (s & 1) + signe *= -1; /* odd s */ + } + if (q < 0.0) { + q = -q; + if ((n - s) & 1) + signe *= -1; /* odd n - s */ + } + + if (n <= slim) { + if (p > 1.0e-1) { + Res = pow (p, (double) s) * num2_Combination (n, s) * pow (q, + (double) (n - s)); + } else { + double temp = (n - s)*num2_log1p (-p); + Res = pow (p, (double) s) * num2_Combination (n, s) * exp(temp); + } + return signe * Res; + + } else { + /* This could be calculated with more precision as there is some + cancellation because of subtraction of the large LnFactorial: the + last few digits can be lost. But we need the function lgammal in + long double precision. Another possibility would be to use an + asymptotic expansion for the binomial coefficient. */ + Res = s * log (p) + (n - s) * num2_log1p (-p) + num2_LnFactorial (n) + - num2_LnFactorial (n - s) - num2_LnFactorial (s); + util_Assert (Res < maxexp, "fmass_BinomialTerm3: term overflow"); + + if (Res < minexp) + return 0.0; + + return signe * exp (Res); + } +} + + +/*=========================================================================*/ + +fmass_INFO fmass_CreateBinomial (long n, double p, double q) +{ +/* + * Compute all probability terms of the binomial distribution; start near + * the mean, and calculate probabilities on each side until they become + * smaller than epsilon, then stop there. + * However, this is more general than the binomial probability distribu- + * tion as this will compute the binomial terms when p + q != 1, and + * even when p or q are negative. However in this case, the cumulative + * terms are meaningless and are not computed. + */ + const double epsilon = fmass_Epsilon * EPS_EXTRA; + long i, mid; + long imin, imax; + double z = 0; + fmass_INFO W; + double *P; /* Binomial "probability" terms */ + double *F; /* Binomial cumulative "probabilities" */ + + util_Assert (n > 0, "fmass_CreateBinomial: n <= 0"); + + W = (fmass_INFO) util_Malloc (sizeof (struct fmass_INFO_T)); + W->paramI = (long *) util_Malloc (sizeof (long)); + W->paramR = (double *) util_Calloc ((size_t) 2, sizeof (double)); + W->paramI[0] = n; + W->paramR[0] = p; + W->paramR[1] = q; + + /* For n > fmass_MaxnBinomial, we shall not use pre-computed arrays */ + if (n > fmass_MaxnBinomial) { + W->pdf = NULL; + W->cdf = NULL; + return W; + } + + P = (double *) util_Calloc ((size_t) (1 + n), sizeof (double)); + F = (double *) util_Calloc ((size_t) (1 + n), sizeof (double)); + + /* the maximum term in absolute value */ + mid = (long) ((n + 1) * fabs (p) / (fabs (p) + fabs (q))); + if (mid > n) + mid = n; + P[mid] = fmass_BinomialTerm1 (n, p, q, mid); + + if (fabs(p) > 0.0) { + z = q / p; + } else { + z = 0.0; + util_Warning (1, "fmass_CreateBinomial: q / p = infinite"); + } + i = mid; + while (i > 0 && fabs (P[i]) > epsilon) { + P[i - 1] = P[i] * z * i / (n - i + 1); + i--; + } + imin = i; + + if (fabs(q) > 0.0) { + z = p / q; + } else { + z = 0.0; + util_Warning (1, "fmass_CreateBinomial: p / q = infinite"); + } + i = mid; + while (i < n && fabs (P[i]) > epsilon) { + P[i + 1] = P[i] * z * (n - i) / (i + 1); + i++; + } + imax = i; + + /* Here, we assume that we are dealing with a probability distribution. */ + /* Compute the cumulative probabilities for F and keep them in the */ + /* lower part of CDF. */ + F[imin] = P[imin]; + i = imin; + while (i < n && F[i] < 0.5) { + i++; + F[i] = F[i - 1] + P[i]; + } + + /* This is the boundary between F (i <= smed) and 1 - F (i > smed) in */ + /* the array CDF */ + W->smed = i; + + /* Compute the cumulative probabilities of the complementary */ + /* distribution and keep them in the upper part of the array */ + F[imax] = P[imax]; + i = imax - 1; + while (i > W->smed) { + F[i] = P[i] + F[i + 1]; + i--; + } + + /* Reset imin because we lose too much precision for a few terms near + imin when we stop adding terms < epsilon. */ + i = imin; + while (i < W->smed && F[i] < fmass_Epsilon) + i++; + W->smin = imin = i; + + /* Same thing with imax */ + i = imax; + while (i > W->smed && F[i] < fmass_Epsilon) + i--; + W->smax = imax = i; + + W->pdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + W->cdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + for (i = imin; i <= imax; i++) { + W->pdf[i - imin] = P[i]; + W->cdf[i - imin] = F[i]; + } + util_Free (P); + util_Free (F); + + return W; +} + +/*-------------------------------------------------------------------------*/ + +double fmass_BinomialTerm2 (fmass_INFO W, long s) +{ + long n; + double p, q; + + util_Assert (W != NULL, + "fmass_BinomialTerm2: fmass_INFO is NULL pointer"); + n = W->paramI[0]; + if (0 == n) + return 1.0; + if (s < 0 || s > n) + return 0.0; + p = W->paramR[0]; + if (p == 0.0) { + if (s > 0) + return 0.0; + else + return 1.0; + } + q = W->paramR[1]; + if (q == 0.0) { + if (s < n) + return 0.0; + else + return 1.0; + } + if (W->pdf == NULL) + return fmass_BinomialTerm1 (n, p, q, s); + + if (s > W->smax || s < W->smin) + return fmass_BinomialTerm1 (n, p, q, s); + + return W->pdf[s - W->smin]; +} + +/*-------------------------------------------------------------------------*/ + +void fmass_DeleteBinomial (fmass_INFO W) +{ + if (W == NULL) + return; + util_Free (W->paramI); + util_Free (W->paramR); + util_Free (W->pdf); + util_Free (W->cdf); + util_Free (W); +} + + +/*=========================================================================*/ + +double fmass_NegaBinTerm1 (long n, double p, long s) +{ + const long slim = 15; /* To avoid overflow */ + const double maxexp = (DBL_MAX_EXP - 1) * num_Ln2; /* To avoid overflow */ + const double minexp = (DBL_MIN_EXP - 1) * num_Ln2; /* To avoid underflow */ + double y; + + util_Assert (p >= 0.0 && p <= 1.0, + "fmass_NegaBinTerm1: p not in [0, 1]"); + util_Assert (n > 0, "fmass_NegaBinTerm1: n < 1"); + if (s < 0) + return 0.0; + if (p >= 1.0) { /* In fact, p == 1 */ + if (0 == s) + return 1.0; + else + return 0.0; + } + if (p <= 0.0) /* In fact, p == 0 */ + return 0.0; + + if (s <= slim || n <= slim) { + y = pow (p, (double) n) * num2_Combination (n + s - 1, s) * + pow (1.0 - p, (double) s); + return y; + + } else { + y = s * num2_log1p (-p) + n * log (p) + num2_LnFactorial (n + s - 1) + - num2_LnFactorial (n - 1) - num2_LnFactorial (s); + util_Assert (y < maxexp, "fmass_NegaBinTerm1: term overflow"); + if (y <= minexp) + return 0.0; + else + return exp (y); + } +} + + +/*=========================================================================*/ + +fmass_INFO fmass_CreateNegaBin (long n, double p) +/* + * Compute all probability terms of the negative binomial distribution; + * start at the mode, and calculate probabilities on each side until they + * become smaller than epsilon. Set all others to 0. + */ +{ + double epsilon; + long i, mode, Nmax; + long imin, imax; + double sum; + fmass_INFO W; + double *P; /* Negative Binomial mass probabilities */ + double *F; /* Negative Binomial cumulative + probabilities */ + + util_Assert (p >= 0.0 && p <= 1.0, + "fmass_CreateNegaBin: p not in [0, 1]"); + util_Assert (n > 0, "fmass_CreateNegaBin: n < 1"); + + W = (fmass_INFO) util_Malloc (sizeof (struct fmass_INFO_T)); + W->paramI = (long *) util_Malloc (sizeof (long)); + W->paramR = (double *) util_Malloc (sizeof (double)); + W->paramI[0] = n; + W->paramR[0] = p; + + /* Compute the mode (at the maximum term) */ + mode = (long) (1 + (n * (1.0 - p) - 1.0) / p); + + /* For mode > fmass_MaxnNegaBin, we shall not use pre-computed arrays. + mode < 0 should be impossible, unless overflow of long occur, in + which case mode will be = LONG_MIN. */ + if (mode < 0 || mode > fmass_MaxnNegaBin) { + W->pdf = NULL; + W->cdf = NULL; + return W; + } + + /* In theory, the negative binomial distribution has an infinite range. */ + /* But for i > Nmax, probabilities should be extremely small. */ + /* Nmax = Mean + 16 * Standard deviation. */ + Nmax = (long) (n * (1.0 - p) / p + 16 * sqrt (n * (1.0 - p) / (p * p))); + if (Nmax < 32) + Nmax = 32; + P = (double *) util_Calloc ((size_t) (1 + Nmax), sizeof (double)); + F = (double *) util_Calloc ((size_t) (1 + Nmax), sizeof (double)); + + epsilon = fmass_Epsilon * EPS_EXTRA / fmass_NegaBinTerm1 (n, p, mode); + + /* We shall normalize by explicitly summing all terms >= epsilon */ + sum = P[mode] = 1.0; + + /* Start from the maximum and compute terms > epsilon on each side. */ + i = mode; + while (i > 0 && P[i] >= epsilon) { + P[i - 1] = P[i] * i / ((1.0 - p) * (n + i - 1)); + i--; + sum += P[i]; + } + imin = i; + + i = mode; + while (P[i] >= epsilon) { + P[i + 1] = P[i] * (1.0 - p) * (n + i) / (i + 1); + i++; + sum += P[i]; + if (i == Nmax - 1) { + Nmax *= 2; + P = (double *) util_Realloc (P, (1 + Nmax) * sizeof (double)); + F = (double *) util_Realloc (F, (1 + Nmax) * sizeof (double)); + /* util_Warning (TRUE, "fmass_CreateNegaBin: Calling Realloc"); */ + } + } + imax = i; + + /* Renormalize the sum of probabilities to 1 */ + for (i = imin; i <= imax; i++) { + P[i] /= sum; + } + + /* Compute the cumulative probabilities for F and keep them in the */ + /* lower part of CDF. */ + F[imin] = P[imin]; + i = imin; + while (i < imax && F[i] < 0.5) { + i++; + F[i] = F[i - 1] + P[i]; + } + + /* This is the boundary between F (i <= smed) and 1 - F (i > smed) in */ + /* the array CDF */ + W->smed = i; + + /* Compute the cumulative probabilities of the complementary */ + /* distribution 1 - F and keep them in the upper part of the array */ + F[imax] = P[imax]; + i = imax - 1; + while (i > W->smed) { + F[i] = P[i] + F[i + 1]; + i--; + } + + /* Reset imin because we lose too much precision for a few terms near + imin when we stop adding terms < epsilon. */ + i = imin; + while (i < W->smed && F[i] < fmass_Epsilon) + i++; + W->smin = imin = i; + + /* Same thing with imax */ + i = imax; + while (i > W->smed && F[i] < fmass_Epsilon) + i--; + W->smax = imax = i; + + W->pdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + W->cdf = (double *) util_Calloc ((size_t) (imax + 1 - imin), sizeof (double)); + for (i = imin; i <= imax; i++) { + W->pdf[i - imin] = P[i]; + W->cdf[i - imin] = F[i]; + } + util_Free (P); + util_Free (F); + + return W; +} + +/*-------------------------------------------------------------------------*/ + +double fmass_NegaBinTerm2 (fmass_INFO W, long s) +{ + double p; + long n; + + util_Assert (W != NULL, + "fmass_NegaBinTerm2: fmass_INFO is NULL pointer"); + if (s < 0) + return 0.0; + n = W->paramI[0]; + p = W->paramR[0]; + if (p == 0.0) + return 0.0; + if (p == 1.0) { + if (s > 0) + return 0.0; + else + return 1.0; + } + + if (W->pdf == NULL) + return fmass_NegaBinTerm1 (n, p, s); + + if (s > W->smax || s < W->smin) + return fmass_NegaBinTerm1 (n, p, s); + + return W->pdf[s - W->smin]; +} + +/*-------------------------------------------------------------------------*/ + +void fmass_DeleteNegaBin (fmass_INFO W) +{ + if (W == NULL) + return; + util_Free (W->paramI); + util_Free (W->paramR); + util_Free (W->pdf); + util_Free (W->cdf); + util_Free (W); +} diff --git a/cbits/testu/src/fres.c b/cbits/testu/src/fres.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/fres.c @@ -0,0 +1,386 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: fres.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "bitset.h" +#include "fres.h" +#include "ftab.h" + +#include + +#define LEN 100 + + + + +/*=========================================================================*/ + +void fres_InitCont (ffam_Fam *fam, fres_Cont *res, int N, + int Nr, int f1, int f2, int fstep, char *nam) +{ + int i, j; + char str[LEN + 1] = {0}; + size_t len1; + char *p; + + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); + Nr = util_Min (Nr, fam->Ng); + res->Active = 0; + + for (j = 0; j < gofw_NTestTypes; j++) { + if ((gofw_Mean == j) || + (N > 1 && (bitset_TestBit (gofw_ActiveTests, j)))) { + strncpy (str, nam, (size_t) LEN); + len1 = strlen (str); + strncat (str, ": ", 3); + p = strstr (res->PVal[j]->Desc, "p-value"); + if (p) + strncat (str, p, (size_t) LEN - len1); + ftab_DeleteTable (res->PVal[j]); + res->PVal[j] = ftab_CreateTable (Nr, f1, f2, fstep, str, + ftab_pVal2, 0); + ftab_InitMatrix (res->PVal[j], -1.0); + bitset_SetBit (res->Active, j); + for (i = 0; i < Nr; i++) + res->PVal[j]->LSize[i] = fam->LSize[i]; + } + } + if (N > 1) + bitset_ClearBit (res->Active, gofw_Mean); +} + + +/*-------------------------------------------------------------------------*/ + +fres_Cont * fres_CreateCont (void) +{ + fres_Cont *res; + char str[LEN + 1]; + gofw_TestType j; + size_t m; + + res = util_Malloc (sizeof (fres_Cont)); + res->name = util_Calloc (1, sizeof (char)); + + m = strlen ("p-value for statistic "); + for (j = 0; j < gofw_NTestTypes; j++) { + if ((gofw_Mean == j) || (bitset_TestBit (gofw_ActiveTests, j))) { + strncpy (str, "p-value for ", (size_t) LEN); + if (gofw_Mean != j) + strncat (str, gofw_TestNames[j], (size_t) LEN - m); + strncat (str, " statistic", (size_t) LEN - m); + res->PVal[j] = ftab_CreateTable (1, 0, 1, 1, str, ftab_pVal2, 0); + } + } + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void fres_DeleteCont (fres_Cont *res) +{ + gofw_TestType j; + + if (res == NULL) + return; + res->name = util_Free (res->name); + + for (j = 0; j < gofw_NTestTypes; j++) { + if ((gofw_Mean == j) || (bitset_TestBit (gofw_ActiveTests, j))) { + ftab_DeleteTable (res->PVal[j]); + res->PVal[j] = NULL; + } + } + util_Free (res); +} + + +/*=========================================================================*/ + +void fres_PrintCont (fres_Cont *res) +{ + gofw_TestType j; + + for (j = 0; j <= gofw_Mean; j++) { + if (bitset_TestBit (res->Active, j)) + ftab_PrintTable (res->PVal[j]); + } +} + + +/*=========================================================================*/ + +void fres_FillTableEntryC (fres_Cont *fres, gofw_TestArray pval, + int N, int i, int j) +/* + * Writes the results of one test in the tables. + */ +{ + gofw_TestType k; + + if (N == 1) { + fres->PVal[gofw_Mean]->Mat[i][j] = pval[gofw_Mean]; + + } else { + for (k = 0; k <= gofw_Mean; k++) { + if (bitset_TestBit (gofw_ActiveTests, k)) { + fres->PVal[k]->Mat[i][j] = pval[k]; + } + } + } +} + + +/*=========================================================================*/ + +void fres_InitDisc (ffam_Fam *fam, fres_Disc *res, + int Nr, int f1, int f2, int fstep, char *nam) +{ + char str[LEN + 1] = {0}; + char str2[LEN + 1] = {0}; + size_t len1; + int i; + + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); + strncpy (str, nam, (size_t) LEN); + len1 = strlen (nam); + + Nr = util_Min (Nr, fam->Ng); + + ftab_DeleteTable (res->PVal2); + ftab_DeleteTable (res->PRight); + ftab_DeleteTable (res->PLeft); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Left p-value", (size_t) LEN - len1); + res->PLeft = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal1, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Right p-value", (size_t) LEN - len1); + res->PRight = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal1, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", p-value for discrete statistic", (size_t) LEN - len1); + res->PVal2 = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal2, 0); + + ftab_InitMatrix (res->PLeft, -1.0); + ftab_InitMatrix (res->PRight, -1.0); + ftab_InitMatrix (res->PVal2, -1.0); + + for (i = 0; i < Nr; i++) { + res->PLeft->LSize[i] = fam->LSize[i]; + res->PRight->LSize[i] = fam->LSize[i]; + res->PVal2->LSize[i] = fam->LSize[i]; + } +} + + +/*-------------------------------------------------------------------------*/ + +fres_Disc * fres_CreateDisc (void) +{ + fres_Disc *res; + + res = util_Malloc (sizeof (fres_Disc)); + res->name = util_Calloc (1, sizeof (char)); + + res->PLeft = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->PRight = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->PVal2 = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal2, 0); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void fres_DeleteDisc (fres_Disc *res) +{ + if (res == NULL) + return; + res->name = util_Free (res->name); + ftab_DeleteTable (res->PVal2); + ftab_DeleteTable (res->PRight); + ftab_DeleteTable (res->PLeft); + util_Free (res); +} + + +/*=========================================================================*/ + +void fres_PrintDisc (fres_Disc *res, lebool LR) +{ + if (LR) { + ftab_PrintTable (res->PLeft); + ftab_PrintTable (res->PRight); + } + ftab_PrintTable (res->PVal2); +} + + +/*=========================================================================*/ + +void fres_FillTableEntryD (fres_Disc *fres, + double pLeft, double pRight, double pVal2, int i, int j) +/* + * Writes the results of one test in the tables. + */ +{ + fres->PLeft->Mat[i][j] = pLeft; + fres->PRight->Mat[i][j] = pRight; + fres->PVal2->Mat[i][j] = pVal2; +} + + +/*=========================================================================*/ + +void fres_InitPoisson (ffam_Fam *fam, fres_Poisson *res, + int Nr, int f1, int f2, int fstep, char *nam) +{ + char str[LEN + 1] = {0}; + char str2[LEN + 1] = {0}; + size_t len1; + int i; + + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); + strncpy (str, nam, (size_t) LEN); + len1 = strlen (nam); + + Nr = util_Min (Nr, fam->Ng); + + ftab_DeleteTable (res->Obs); + ftab_DeleteTable (res->Exp); + ftab_DeleteTable (res->PVal2); + ftab_DeleteTable (res->PRight); + ftab_DeleteTable (res->PLeft); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Expected numbers", (size_t) LEN - len1); + res->Exp = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_Real, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Observed numbers", (size_t) LEN - len1); + res->Obs = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_Integer, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Left p-value", (size_t) LEN - len1); + res->PLeft = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal1, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", Right p-value", (size_t) LEN - len1); + res->PRight = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal1, 0); + + strncpy (str2, nam, (size_t) LEN); + strncat (str2, ", p-value for discrete statistic", (size_t) LEN - len1); + res->PVal2 = ftab_CreateTable (Nr, f1, f2, fstep, str2, ftab_pVal2, 0); + + ftab_InitMatrix (res->Exp, -1.0); + ftab_InitMatrix (res->Obs, -1.0); + ftab_InitMatrix (res->PLeft, -1.0); + ftab_InitMatrix (res->PRight, -1.0); + ftab_InitMatrix (res->PVal2, -1.0); + + for (i = 0; i < Nr; i++) { + res->PLeft->LSize[i] = fam->LSize[i]; + res->PRight->LSize[i] = fam->LSize[i]; + res->PVal2->LSize[i] = fam->LSize[i]; + res->Exp->LSize[i] = fam->LSize[i]; + res->Obs->LSize[i] = fam->LSize[i]; + } +} + + +/*-------------------------------------------------------------------------*/ + +fres_Poisson * fres_CreatePoisson (void) +{ + fres_Poisson *res; + + res = util_Malloc (sizeof (fres_Poisson)); + res->name = util_Calloc (1, sizeof (char)); + + res->Obs = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->Exp = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->PLeft = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->PRight = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal1, 0); + res->PVal2 = ftab_CreateTable (1, 0, 1, 1, "", ftab_pVal2, 0); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void fres_DeletePoisson (fres_Poisson *res) +{ + if (res == NULL) + return; + res->name = util_Free (res->name); + ftab_DeleteTable (res->PVal2); + ftab_DeleteTable (res->PRight); + ftab_DeleteTable (res->PLeft); + ftab_DeleteTable (res->Obs); + ftab_DeleteTable (res->Exp); + util_Free (res); +} + + +/*=========================================================================*/ + +void fres_PrintPoisson (fres_Poisson *res, lebool LR, lebool Ratio) +{ + ftab_PrintTable2 (res->Exp, res->Obs, Ratio); + if (LR) { + ftab_PrintTable (res->PLeft); + ftab_PrintTable (res->PRight); + } + ftab_PrintTable (res->PVal2); +} + + +/*=========================================================================*/ + +void fres_FillTableEntryPoisson (fres_Poisson *fres, double Exp, double Obs, + double pLeft, double pRight, double pVal2, int i, int j) +/* + * Writes the results of one test in the tables. + */ +{ + fres->Obs->Mat[i][j] = Obs; + fres->Exp->Mat[i][j] = Exp; + fres->PLeft->Mat[i][j] = pLeft; + fres->PRight->Mat[i][j] = pRight; + fres->PVal2->Mat[i][j] = pVal2; +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/ftab.c b/cbits/testu/src/ftab.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/ftab.c @@ -0,0 +1,625 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: ftab.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "util.h" +#include "chrono.h" +#include "num.h" +#include "tables.h" +#include "gofw.h" + +#include "ftab.h" +#include "ffam.h" +#include "swrite.h" + +#include +#include +#include +#include + + +#define MAXLEN 100 /* Max number of chars in Desc[] */ + + + +/*---------------------------- extern variables ---------------------------*/ + +ftab_StyleType ftab_Style = ftab_Plain; + +double ftab_Suspectp = 0.01; + +int ftab_SuspectLog2p = 6; + + + + +/*---------------------------- module variables ---------------------------*/ + +static double SuspectLog2pval; + + + + + +/*-------------------------------- Functions ------------------------------*/ + + +void ftab_SetDesc (ftab_Table *T, char *Desc) +{ + size_t len; + util_Assert (T != NULL, "ftab_SetDesc: ftab_Table is a NULL pointer"); + len = strlen (Desc); + if (len > MAXLEN) { + len = MAXLEN; + util_Warning (1, "ftab_Table->Desc truncated"); + } + if (T->Desc != NULL) + T->Desc = util_Free (T->Desc); + T->Desc = util_Calloc (len + 1, sizeof (char)); + strncpy (T->Desc, Desc, (size_t) len); + T->Desc[len] = '\0'; +} + + +/*=========================================================================*/ + +ftab_Table *ftab_CreateTable (int Nr, int j1, int j2, int jstep, + char *Desc, ftab_FormType Form, int Ns) +{ + ftab_Table *T; + T = util_Malloc (sizeof (ftab_Table)); + memset (T, 0, sizeof (ftab_Table)); + T->Nr = Nr; + T->j1 = j1; + T->j2 = j2; + T->jstep = jstep; + T->Nc = 1 + (j2 - j1)/jstep; + T->Mat = tables_CreateMatrixD (T->Nr, T->Nc); + T->LSize = util_Calloc ((size_t) T->Nr, sizeof (int)); + T->Desc = NULL; + ftab_SetDesc (T, Desc); + T->Form = Form; + if (Form == ftab_String) { + T->Strings = util_Calloc ((size_t) Ns, sizeof (char *)); + T->Ns = Ns; + } else + T->Strings = NULL; + return T; +} + + +/*=========================================================================*/ + +void ftab_DeleteTable (ftab_Table * T) +{ + if (T == NULL) + return; + tables_DeleteMatrixD (&T->Mat); + T->LSize = util_Free (T->LSize); + T->Desc = util_Free (T->Desc); + if (T->Form == ftab_String) + T->Strings = util_Free (T->Strings); + util_Free (T); +} + + +/*=========================================================================*/ + +void ftab_InitMatrix (ftab_Table * T, double x) +{ + int i, j; + + for (i = 0; i < T->Nr; i++) + for (j = 0; j < T->Nc; j++) + T->Mat[i][j] = x; +} + + +/*=========================================================================*/ + +void ftab_MakeTables (ffam_Fam *fam, void *res, void *cho, void *par, + ftab_CalcType Calc, int Nr, int f1, int f2, int fstep) +{ + int i, j; /* Row and column of matrices for results of one test */ + int f; + chrono_Chrono *Timer; + unif01_Gen *gen; + + SuspectLog2pval = 1.0 / (num_TwoExp[ftab_SuspectLog2p] - 1.0); + + Timer = chrono_Create (); + + Nr = util_Min (Nr, fam->Ng); + for (i = 0; i < Nr; i++) { + if (swrite_Basic) { + printf ("CPU cumulative time: "); + chrono_Write (Timer, chrono_hms); + printf ("\n\n=============================================" + "==============\n\nLSize = i = %2d\n\n", fam->LSize[i]); + } + if ((gen = fam->Gen[i])) { + f = f1; + j = 0; + while (f <= f2) { + Calc (fam, res, cho, par, fam->LSize[i], f, i, j); + f += fstep; + j++; + } + } + } + if (swrite_Basic) { + printf ("Total CPU time: "); + chrono_Write (Timer, chrono_hms); + printf + ("\n\n======================================================\n"); + } + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void PrintTexName (char *nam) +/* + * Make sure that any _ char in Latex format name is printed as \_ + */ +{ + char *p, *name = nam; + size_t len; + + if (NULL == nam) + return; + len = strlen (name) + 1; + name = util_Calloc (len, sizeof (char)); + strncpy (name, nam, (size_t) len); + + while ((p = strchr(name, '_'))) { + *p = '\0'; + printf ("%s", name); + printf ("\\_"); + name = p + 1; + } + printf ("%s", name); +} + + +/*=========================================================================*/ + +static void PrintLog2 (double d) +/* + * Prints the logarithm (rounded) of d in base 2, when d is outside the + * interval [SuspectLog2pval, 1 - SuspectLog2pval]; otherwise prints + * nothing. + */ +{ + int s; + + if (d <= gofw_Epsilonp) { + printf (" inf "); + } else if (d <= SuspectLog2pval) { + s = 0.5 - num_Log2 (d); + printf (" %2d ", s); + } else if (d >= 1.0 - gofw_Epsilonp1) { + printf (" -inf "); + } else if (d >= 1.0 - SuspectLog2pval) { + s = 0.5 - num_Log2 (1.0 - d); + if (s > 9) + printf (" "); + else + printf (" "); + printf ("-%1d ", s); + } else + printf (" "); +} + + +/*-------------------------------------------------------------------------*/ + +static void PrintLog2Tex (double d) +/* + * Similar to PrintLog2, but prints in Latex style. + */ +{ + int s; + if (d <= gofw_Epsilonp) { + printf (" & $\\infty$ "); + } else if (d <= SuspectLog2pval) { + s = 0.5 - num_Log2 (d); + printf (" & %3d ", s); + } else if (d >= 1.0 - gofw_Epsilonp1) { + printf (" & $-\\infty$ "); + } else if (d >= 1.0 - SuspectLog2pval) { + s = 0.5 - num_Log2 (1.0 - d); + if (s > 9) + printf (" & $-"); + else + printf (" & $-"); + printf ("%1d $ ", s); + } else + printf (" & "); +} + + +/*=========================================================================*/ + +static void PrintLog10 (double d) +/* + * Prints the logarithm (rounded) of d in base 10, when d is outside the + * interval [ftab_Suspectp, 1 - ftab_Suspectp]; otherwise prints + * nothing. + */ +{ + int s; + if (d <= gofw_Epsilonp) { + printf (" inf "); + } else if (d <= ftab_Suspectp) { + s = 0.5 - log10 (d); + printf (" %2d ", s); + } else if (d >= 1.0 - gofw_Epsilonp1) { + printf (" -inf "); + } else if (d >= 1.0 - ftab_Suspectp) { + s = 0.5 - log10 (1.0 - d); + if (s > 9) + printf (" "); + else + printf (" "); + printf ("-%1d ", s); + } else { + printf (" "); + } +} + + +/*-------------------------------------------------------------------------*/ + +static void PrintLog10Tex (double d) +/* + * Similar to PrintLog10, but prints in LaTex style. + */ +{ + int s; + if (d <= gofw_Epsilonp) { + printf (" & $\\infty$ "); + } else if (d <= ftab_Suspectp) { + s = 0.5 - log10 (d); + printf (" & %3d ", s); + } else if (d >= 1.0 - gofw_Epsilonp1) { + printf (" & $-\\infty$ "); + } else if (d >= 1.0 - ftab_Suspectp) { + s = 0.5 - log10 (1.0 - d); + if (s > 9) + printf (" & $-"); + else + printf (" & $-"); + printf ("%1d $ ", s); + } else { + printf (" & "); + } +} + + +/*=========================================================================*/ + +static void PrintVal (ftab_Table * T, double d, ftab_FormType Form) +/* + * Prints the value d according to format Form. + */ +{ + int s; + /* All Table tables are initialized to -1; thus the test was not done for + this pair (e, f) if d = -1. */ + if (d < -0.9) { + printf (" --- "); + } else if (Form == ftab_String) { + printf (" "); + s = 0.5 + d; + printf ("%s", T->Strings[s]); + } else if (Form == ftab_Integer) { + printf (" "); + if (d <= LONG_MAX) + printf ("%8ld", (long) d); + else + num_WriteD (d, 8, 0, 0); + } else if (Form == ftab_Real) { + printf (" "); + num_WriteD (d, 8, 2, 2); + } else if (Form == ftab_pLog2) { + PrintLog2 (d); + } else if (Form == ftab_pLog10) { + PrintLog10 (d); + } else if (d < gofw_Epsilonp) { + printf (" eps "); + } else if (d < ftab_Suspectp) { + printf (" "); + num_WriteD (d, 8, 2, 2); + } else if (d > 1.0 - gofw_Epsilonp1 && Form == ftab_pVal2) { + printf (" -eps1 "); + } else if (d > 1.0 - ftab_Suspectp && Form == ftab_pVal2) { + printf (" "); + num_WriteD (d - 1.0, 8, 2, 2); + } else if (Form == ftab_NotInit) { + util_Error ("ftab_PrintTable: Form is not initialized"); + } else { + printf (" "); + } +} + + +/*=========================================================================*/ + +static void PrintValTex (ftab_Table * T, double d, ftab_FormType Form) +/* + * Similar to PrintVal, but prints in LaTex style. + */ +{ + int s; + if (d < -0.9) { + printf (" & --- "); + } else if (Form == ftab_String) { + printf (" & "); + s = d + 0.5; + printf ("%s", T->Strings[s]); + } else if (Form == ftab_Integer) { + printf (" & "); + if (d <= LONG_MAX) + printf ("%8ld", (long) d); + else + num_WriteD (d, 8, 0, 0); + } else if (Form == ftab_Real) { + printf (" & "); + num_WriteD (d, 8, 2, 2); + } else if (Form == ftab_pLog10) { + PrintLog10Tex (d); + } else if (Form == ftab_pLog2) { + PrintLog2Tex (d); + } else if (d < gofw_Epsilonp) { + printf (" & \\eps "); + } else if (d < ftab_Suspectp) { + printf (" & "); + num_WriteD (d, 8, 2, 2); + } else if (d > 1.0 - gofw_Epsilonp1 && Form == ftab_pVal2) { + printf (" & \\epsm "); + } else if (d > 1.0 - ftab_Suspectp && Form == ftab_pVal2) { + printf (" & "); + num_WriteD (d - 1.0, 8, 2, 2); + } else if (Form == ftab_NotInit) { + util_Error ("ftab\\_PrintTable: Form is not initialized"); + } else { + printf (" & "); + } +} + + +/*=========================================================================*/ + +static void PrintTablePlain (ftab_Table * T) +/* + * Prints table T in plain text style, according to format Form. + */ +{ + int i, j; + int j1 = T->j1; + int j2 = T->j2; + int jstep = T->jstep; + double d; + ftab_FormType Form = T->Form; + + printf ("%s", T->Desc); + printf ("\n\nLSize j =%2d", j1); + j = j1 + jstep; + while (j <= j2) { + printf (" j =%2d", j); + j += jstep; + } + printf ("\n------------------------------------------------------\n"); + + for (i = 0; i < T->Nr; i++) { + printf ("%3d", T->LSize[i]); + for (j = 0; j < T->Nc; j++) { + d = T->Mat[i][j]; + PrintVal (T, d, Form); + } + printf ("\n"); + } + printf ("\n=======================================================\n"); +} + + +/*=========================================================================*/ + +static void PrintTableTex (ftab_Table * T) +/* + * Prints table T in Latex style, according to format Form. + */ +{ + int i, j; + int j1 = T->j1; + int j2 = T->j2; + int jstep = T->jstep; + ftab_FormType Form = T->Form; + + printf ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n" + "\\begin {tabular}{|c|@{\\extracolsep{10pt}}"); + j = j1; + while (j <= j2) { + printf ("c"); + j += jstep; + } + printf ("|}\n\\multicolumn{%1d", (j2 - j1) / jstep + 2); + printf ("}{l}{\\makebox[0pt][l]{"); + PrintTexName (T->Desc); + printf ("}}\\\\\n\\hline\nLSize & $ j=%2d", j1); + j = j1 + jstep; + while (j <= j2) { + printf (" $ & $ j=%2d", j); + j += jstep; + } + printf ("$ \\\\\n\\hline\n"); + + for (i = 0; i < T->Nr; i++) { + printf ("%3d ", T->LSize[i]); + for (j = 0; j < T->Nc; j++) { + PrintValTex (T, T->Mat[i][j], Form); + } + printf (" \\\\\n"); + } + printf ("\\hline\n\\end {tabular} \\\\\n\\medskip\n\n"); +} + + +/*=========================================================================*/ + +void ftab_PrintTable (ftab_Table * T) +{ + if (NULL == T) + return; + if (ftab_Style == ftab_Plain) + PrintTablePlain (T); + else + PrintTableTex (T); +} + + +/*=========================================================================*/ + +static void PrintTable2Tex (ftab_Table * T1, ftab_Table * T2, lebool Flag) +/* + * Prints tables in Latex style, T1 according to format Form1, + * T2 according to format Form2. + */ +{ + int i, j; + int j1 = T1->j1; + int j2 = T1->j2; + int jstep = T1->jstep; + double x; + ftab_FormType Form1 = T1->Form; + ftab_FormType Form2 = T2->Form; + + printf ("%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n" + "\\begin {tabular}{|c|@{\\extracolsep{10pt}}"); + j = j1; + while (j <= j2) { + printf ("rr|"); + j += jstep; + } + printf ("}\n\\multicolumn{%1d", 2 * ((j2 - j1) / jstep + 1) + 1); + printf ("}{l}{\\makebox[0pt][l]{"); + PrintTexName (T1->Desc); + printf ("---"); + PrintTexName (T2->Desc); + if (Flag) + printf (" (RATIO)"); + printf ("}}\\\\\n\\hline\n" " LSize& \\multicolumn{2}{c|}{$ j=%1d $}", j1); + j = j1 + jstep; + while (j <= j2) { + printf (" & \\multicolumn{2}{c|}{$ j=%1d $}", j); + j += jstep; + } + printf (" \\\\\n\\hline\n"); + + for (i = 0; i < T1->Nr; i++) { + printf ("%3d", T1->LSize[i]); + for (j = 0; j < T1->Nc; j++) { + PrintValTex (T1, T1->Mat[i][j], Form1); + x = T2->Mat[i][j]; + if (!Flag || x < -0.9) + PrintValTex (T2, x, Form2); + else { + x = x / T1->Mat[i][j]; + PrintValTex (T2, x, ftab_Real); + } + } + printf (" \\\\\n"); + } + printf ("\\hline\n\\end {tabular} \\\\\n\\medskip\n\n"); +} + + +/*=========================================================================*/ + +static void PrintTable2Plain (ftab_Table * T1, ftab_Table * T2, lebool Flag) +/* + * Prints tables in plain text style, T1 according to format Form1, + * T2 according to format Form2. + */ +{ + int i, j; + int j1 = T1->j1; + int j2 = T1->j2; + int jstep = T1->jstep; + double x; + ftab_FormType Form1 = T1->Form; + ftab_FormType Form2 = T2->Form; + + printf ("%s", T1->Desc); + printf ("---"); + printf ("%s", T2->Desc); + if (Flag) + printf (" (RATIO)"); + printf ("\n\n LSize j=%1d", j1); + printf (" j=%2d", j1); + j = j1 + jstep; + while (j <= j2) { + printf (" j=%2d", j); + printf (" j=%2d", j); + j += jstep; + } + printf ("\n----------------------------------------------------\n"); + + for (i = 0; i < T1->Nr; i++) { + printf ("%3d", T1->LSize[i]); + for (j = 0; j < T1->Nc; j++) { + PrintVal (T1, T1->Mat[i][j], Form1); + x = T2->Mat[i][j]; + if (!Flag || x < -0.9) + PrintVal (T2, x, Form2); + else { + x = x / T1->Mat[i][j]; + PrintVal (T2, x, ftab_Real); + } + } + printf ("\n"); + } + printf ("\n=======================================================\n"); +} + + +/*=========================================================================*/ + +void ftab_PrintTable2 (ftab_Table * T1, ftab_Table * T2, lebool Flag) +{ + if (NULL == T1 || NULL == T2) + return; + if (ftab_Style == ftab_Plain) + PrintTable2Plain (T1, T2, Flag); + else + PrintTable2Tex (T1, T2, Flag); +} diff --git a/cbits/testu/src/gdef.c b/cbits/testu/src/gdef.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/gdef.c @@ -0,0 +1,136 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: gdef.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#ifdef HAVE_CONFIG_H +#include "config.h" +#endif + +#include "gdef.h" +#ifdef HAVE_WINDOWS_H + #include +#endif + +#include +#include +#include + +#ifdef HAVE_SYS_UTSNAME_H +#include + +#else +#ifdef HAVE_UNISTD_H +#include +#endif + +#endif + + + +void gdef_GetHostName (char machine[], int n) +{ + int j; +#ifdef HAVE_SYS_UTSNAME_H + struct utsname Z; +#else + char *name; +#endif + + if (n <= 0 || machine == NULL) + return; + machine[0] = '\0'; + +#ifdef HAVE_SYS_UTSNAME_H + if (uname(&Z) != -1) { + strncpy (machine, Z.nodename, (size_t) n); + j = strlen (machine); + if (n - j > 2) + strncat (machine, ", ", (size_t) 2); + j = strlen (machine); + if (n - j > 0) + strncat (machine, Z.sysname, (size_t) (n - j)); + machine[n - 1] = '\0'; + return; + } + +#else +#ifdef HAVE_UNISTD_H + gethostname (machine, (size_t) n); + machine[n - 1] = '\0'; + return; + +#else + name = getenv ("HOST"); + if (name != NULL) { + strncpy (machine, name, (size_t) n); + j = strlen (machine); + machine[n - 1] = '\0'; + if (j < n - 3) { + machine[j++] = ','; + machine[j++] = ' '; + } + } + name = getenv ("OSTYPE"); + if (name != NULL) { + if ((int) strlen (name) < n - j) + strncat (machine, name, (size_t) n - j); + machine[n - 1] = '\0'; + } + +#endif +#endif +} + + +/*------------------------------------------------------------------------*/ +#define MAXBYTES 255 + +void gdef_WriteHostName (void) +{ + char machine[1 + MAXBYTES] = {'\0'}; + gdef_GetHostName (machine, MAXBYTES); + printf ("%s\n", machine); +} + +#if 0 +int main() +{ + struct utsname name; + + if (uname(&name) != -1) + printf(" %s\n", name.nodename); + else { + fprintf(stderr, "Can't find system name\n"); + return 1; + } + gdef_GetHostName (0, MAXBYTES); + gdef_WriteHostName (); + return 0; +} +#endif diff --git a/cbits/testu/src/gofs.c b/cbits/testu/src/gofs.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/gofs.c @@ -0,0 +1,578 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: gofs.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "tables.h" +#include "num.h" +#include "num2.h" + +#include "gofs.h" +#include "fdist.h" +#include "wdist.h" + +#include +#include +#include + + +#define TRACE0(x) printf ("*** " #x " "); +#define TRACE1(N, form) printf ("*** " #N " = %"#form " ", N); + + + +/*---------------------------- extern variables ---------------------------*/ + +double gofs_MinExpected = 10.0; + +double gofs_EpsilonAD = DBL_EPSILON / 2.0; + + + +/*---------------------------- module variables ---------------------------*/ + +/* Used in discontinuous distributions */ +static double EpsilonD = 1.0E-15; + + + + + + +/*-------------------------------- functions ------------------------------*/ + + +void gofs_ContUnifTransform (double V[], long N, wdist_CFUNC F, + double par[], double U[]) +{ + long i; + for (i = 1; i <= N; i++) + U[i] = F (par, V[i]); +} + +/*-------------------------------------------------------------------------*/ + +void gofs_DiscUnifTransform (double V[], long N, wdist_DFUNC F, + fmass_INFO W, double U[]) +{ + long i; + for (i = 1; i <= N; i++) + U[i] = F (W, (long) V[i]); +} + +/*-------------------------------------------------------------------------*/ + +void gofs_DiffD (double U[], double D[], long N1, long N2, + double a, double b) +{ + long i; + D[N1 - 1] = U[N1] - a; + for (i = N1; i < N2; i++) + D[i] = U[i + 1] - U[i]; + D[N2] = b - U[N2]; +} + +/*-------------------------------------------------------------------------*/ +#ifdef USE_LONGLONG + +void gofs_DiffLL (longlong U[], longlong D[], long N1, long N2, + longlong a, longlong b) +{ + long i; + D[N1 - 1] = U[N1] - a; + for (i = N1; i < N2; i++) + D[i] = U[i + 1] - U[i]; + D[N2] = b - U[N2]; +} + +/*-------------------------------------------------------------------------*/ + +void gofs_DiffULL (ulonglong U[], ulonglong D[], long N1, long N2, + ulonglong a, ulonglong b) +{ + long i; + D[N1 - 1] = U[N1] - a; + for (i = N1; i < N2; i++) + D[i] = U[i + 1] - U[i]; + D[N2] = b - U[N2]; +} + +#endif +/*-------------------------------------------------------------------------*/ + +void gofs_DiffL (long U[], long D[], long N1, long N2, long a, long b) +{ + long i; + D[N1 - 1] = U[N1] - a; + for (i = N1; i < N2; i++) + D[i] = U[i + 1] - U[i]; + D[N2] = b - U[N2]; +} + +/*-------------------------------------------------------------------------*/ + +void gofs_IterateSpacings (double V[], double S[], long N) +{ + long i; + tables_QuickSortD (S, 0, N); + for (i = 0; i < N; i++) + S[N - i] = (i + 1) * (S[N - i] - S[N - i - 1]); + S[0] = (N + 1) * S[0]; + V[1] = S[0]; + for (i = 2; i <= N; i++) + V[i] = V[i - 1] + S[i - 1]; +} + +/*-------------------------------------------------------------------------*/ + +void gofs_PowerRatios (double U[], long N) +{ + long i; + /* Assumes that the U[i] are already sorted in increasing order. */ + for (i = 1; i < N; i++) { + if (U[i + 1] == 0.0 || U[i + 1] == -0.0) { + /* util_Warning (1, "gofs_PowerRatios: 0 divisor"); */ + U[i] = 1.0; + } else + U[i] = pow (U[i] / U[i + 1], (double) i); + } + U[N] = pow (U[N], (double) N); + tables_QuickSortD (U, 1, N); +} + +/*-------------------------------------------------------------------------*/ + +void gofs_MergeClasses (double NbExp[], long Loc[], + long *smin, long *smax, long *NbClasses) +{ + long s0, j, s; + double somme; + + *NbClasses = 0; + s = *smin; + while (s <= *smax) { + /* Merge classes to ensure that the number expected in each class is + >= gofs_MinExpected. */ + if (NbExp[s] < gofs_MinExpected) { + s0 = s; + somme = NbExp[s]; + while (somme < gofs_MinExpected && s < *smax) { + NbExp[s] = 0.0; + ++s; + somme += NbExp[s]; + } + NbExp[s] = somme; + for (j = s0; j <= s; j++) + Loc[j] = s; + } else { + Loc[s] = s; + } + ++*NbClasses; + ++s; + } + *smin = Loc[*smin]; + + /* Special case: the last class, if NbExp < MinExpected */ + if (NbExp[*smax] < gofs_MinExpected) { + if (s0 > *smin) + --s0; + NbExp[s0] += NbExp[*smax]; + NbExp[*smax] = 0.0; + --*NbClasses; + for (j = s0 + 1; j <= *smax; j++) + Loc[j] = s0; + *smax = s0; + } + util_Warning (*NbClasses < 2, "gofs_MergeClasses: NumClasses < 2.\n" + " The chi-square test is not done."); + /* + util_Assert (*NbClasses > 1, "gofs_MergeClasses: NumClasses < 2"); + */ +} + + +/*-------------------------------------------------------------------------*/ + +void gofs_WriteClasses (double NbExp[], long Loc[], + long smin, long smax, long NbClasses) +{ + /* Writes the groupings of cells before or after a merging that has */ + /* been done by a previous call to gofs_MergeClasses. */ + long s, s0; + double somme; + const double epsilon = 5.0E-16; + + /* Before merging classes or cells */ + if (NbClasses <= 0) { + somme = 0.0; + printf ("-----------------------------------------------\n" + "Expected numbers per class before merging:\n\n" + "Class s NumExpected[s]\n"); + + /* Don't print classes for which the expected number < epsilon */ + /* Instead reset smin */ + s = smin; + while (NbExp[s] < epsilon) + s++; + if (s > smin) { + smin = s; + s--; + printf ("<= %3ld", s); + num_WriteD (NbExp[s], 18, 4, 4); + printf ("\n"); + } + /* Reset smax also */ + s0 = s = smax; + while (NbExp[s] < epsilon) + s--; + if (s < smax) + smax = s; + + /* Now print the classes with their expected numbers */ + for (s = smin; s <= smax; s++) { + somme += NbExp[s]; + printf ("%6ld", s); + num_WriteD (NbExp[s], 20, 4, 4); + printf ("\n"); + } + + if (s0 > smax) { + s = smax + 1; + printf (">= %3ld", s); + num_WriteD (NbExp[s], 18, 4, 4); + printf ("\n"); + } + + printf ("\n"); + printf ("Total No. Expected = %18.2f\n\n", somme); + return; + } + + /* NbClasses > 0: After merging classes */ + printf ("-----------------------------------------------\n" + "Expected numbers per class after merging:\n" + "Number of classes: %4ld\n\n", NbClasses); + printf ("Class s NumExpected[s]\n"); + + somme = 0.0; + for (s = smin; s <= smax; s++) { + if (Loc[s] == s) { + somme += NbExp[s]; + printf ("%4ld %18.4f\n", s, NbExp[s]); + } + } + printf ("\nTotal NumExpected = %18.2f\n\n", somme); + printf ("The groupings :\n Class s Loc[s]\n"); + for (s = smin; s <= smax; s++) { + if (s == smin) + printf ("<= "); + else if (s == smax) + printf (">= "); + else + printf (" "); + printf ("%4ld %12ld\n", s, Loc[s]); + } + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +/*******************************\ + + Computing EDF test statistics + +\*******************************/ + + +double gofs_Chi2 (double NbExp[], long Count[], long smin, long smax) +{ + double Diff, Khi; + long s; + + Khi = 0.0; + for (s = smin; s <= smax; s++) { + if (NbExp[s] <= 0.0) { + util_Assert (Count[s] == 0, + "gofs_Chi2: NbExp[s] = 0 and Count[s] > 0"); + } else { + Diff = Count[s] - NbExp[s]; + Khi += Diff * Diff / NbExp[s]; + } + } + return Khi; +} + +/*-------------------------------------------------------------------------*/ + +double gofs_Chi2Equal (double NbExp, long Count[], long smin, long smax) +{ + double Diff, Khi; + long s; + Khi = 0.0; + for (s = smin; s <= smax; s++) { + Diff = Count[s] - NbExp; + Khi += Diff * Diff; + } + return Khi / NbExp; +} + +/*-------------------------------------------------------------------------*/ + +long gofs_Scan (double U[], long N, double d) +{ + long m, j = 1, i = 0; + double High; + + High = 0.0; + m = 1; + while (j < N && High < 1.0) { + ++i; + /* Low = U[i]; */ + High = U[i] + d; + while (j <= N && U[j] < High) + ++j; + /* j is now the index of the first obs. to the right of High. */ + if (j - i > m) + m = j - i; + } + /* p-value = fbar_Scan (N, d, m); */ + return m; +} + +/*-------------------------------------------------------------------------*/ + +double gofs_CramerMises (double U[], long N) +{ + long i; + double W, W2; + + if (N <= 0) { + util_Warning (TRUE, "gofs_CramerMises: N <= 0"); + return 0.0; + } + + W2 = 1.0 / (12 * N); + for (i = 1; i <= N; i++) { + W = U[i] - (i - 0.5) / N; + W2 += W * W; + } + return W2; + /* p-value = fbar_CramerMises (N, W2); */ +} + +/*-------------------------------------------------------------------------*/ + +double gofs_WatsonG (double U[], long N) +{ + long i; + double SumZ; + double D2; + double DP, G; + double UnSurN = 1.0 / N; + + if (N <= 0) { + util_Warning (TRUE, "gofs_WatsonG: N <= 0"); + return 0.0; + } + + /* degenerate case N = 1 */ + if (N == 1) + return 0.0; + + /* We assume that U is already sorted. */ + DP = SumZ = 0.0; + for (i = 1; i <= N; i++) { + D2 = i * UnSurN - U[i]; + if (D2 > DP) + DP = D2; + SumZ += U[i]; + } + SumZ = SumZ * UnSurN - 0.5; + G = sqrt ((double) N) * (DP + SumZ); + return G; + /* p-value = fbar_WatsonG (N, G); */ +} + +/*-------------------------------------------------------------------------*/ + +double gofs_WatsonU (double U[], long N) +{ + long i; + double SumZ, W, W2, U2; + + if (N <= 0) { + util_Warning (TRUE, "gofs_WatsonU: N <= 0"); + return 0.0; + } + + /* degenerate case N = 1 */ + if (N == 1) { + return 1.0 / 12.0; + } + + SumZ = 0.0; + W2 = 1.0 / (12 * N); + for (i = 1; i <= N; i++) { + SumZ += U[i]; + W = U[i] - (i - 0.5) / N; + W2 += W * W; + } + SumZ = SumZ / N - 0.5; + U2 = W2 - SumZ * SumZ * N; + return U2; + /* p-value = fbar_WatsonU (N, U2); */ +} + +/*-------------------------------------------------------------------------*/ + +double gofs_AndersonDarling (double V[], long N) +{ + long i; + double U1; + double U, A2; + + if (N <= 0) { + util_Warning (TRUE, "gofs_AndersonDarling: N <= 0"); + return 0.0; + } + + A2 = 0.0; + for (i = 1; i <= N; i++) { + U1 = U = V[i]; + if (U <= gofs_EpsilonAD) { + U1 = U = gofs_EpsilonAD; + } else if (U >= 1 - gofs_EpsilonAD) + U1 = 1.0 - gofs_EpsilonAD; + A2 += (2 * i - 1) * log (U) + (1 + 2 * (N - i)) * num2_log1p (-U1); + } + A2 = -N - A2 / N; + return A2; + /* p-value = fbar_AndersonDarling (N, A2); */ +} + +/*-------------------------------------------------------------------------*/ + +void gofs_KSJumpOne (double U[], long N, double a, double *DP, double *DM) + /* Statistics KS+ and KS-. Case with 1 jump at a, near the lower tail of + the distribution. */ +{ + long j, i; + double D2, D1, UnSurN; + + if (N <= 0) { + *DP = *DM = 0.0; + util_Warning (TRUE, "gofs_KSJumpOne: N <= 0"); + return; + } + + *DP = 0.0; + *DM = 0.0; + UnSurN = 1.0 / N; + j = 1; + while (j < N && U[j] <= a + EpsilonD) + ++j; + for (i = j - 1; i <= N; i++) { + if (i >= 1) { + D1 = i * UnSurN - U[i]; + if (D1 > *DP) + *DP = D1; + } + if (i >= j) { + D2 = U[i] - (i - 1) * UnSurN; + if (D2 > *DM) + *DM = D2; + } + } +} + +/*-------------------------------------------------------------------------*/ + +void gofs_KS (double U[], long N, double *DP, double *DM, double *D) +{ + if (N <= 0) { + *DP = *DM = *D = 0.0; + util_Warning (TRUE, "gofs_KS: N <= 0"); + return; + } + + gofs_KSJumpOne (U, N, 0.0, DP, DM); + if (*DM > *DP) + *D = *DM; + else + *D = *DP; + /* pp = fbar_KSPlus (N, *DP); + pm = fbar_KSPlus (N, *DM); + p = fbar_KS (N, *D); */ +} + +/*-------------------------------------------------------------------------*/ +#if 0 + +void gofs_KSJumpsMany (double X[], int N, wdist_CFUNC F, double W[], + double *DP, double *DM, int Detail) +{ + int i; + double y, UnSurN, D; + + if (N <= 0) { + *DP = *DM = 0.0; + util_Warning (TRUE, "gofs_KSJumpsMany: N <= 0"); + return; + } + + util_Assert (N > 0, "gofs_KSJumpsMany: N <= 0"); + UnSurN = 1.0 / N; + *DP = 0.0; + *DM = 0.0; + + if (Detail > 0) { + printf ("-----------------------------------------------\n" + "Values of the distribution F(x+0) :\n\n"); + } + /* Assume that the X[i] are already sorted */ + for (i = 1; i <= N; i++) { + /* Compute KS+ */ + y = F (W, X[i]); + D = i * UnSurN - y; + if (D > *DP) + *DP = D; + if (Detail > 0) { + printf ("%14.6f %14.6f\n", X[i], y); + } + /* Compute KS- */ + y = F (W, X[i] - EpsilonD); + D = y - (i - 1) * UnSurN; + if (D > *DM) + *DM = D; + } + if (Detail > 0) + printf ("\n\n"); +} +#endif diff --git a/cbits/testu/src/gofw.c b/cbits/testu/src/gofw.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/gofw.c @@ -0,0 +1,706 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: gofw.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "gofw.h" +#include "gofs.h" +#include "fdist.h" +#include "wdist.h" +#include "fbar.h" + +#include "util.h" +#include "num.h" +#include "tables.h" +#include "mystr.h" +#include "bitset.h" + +#include +#include +#include +#include + + + + +/*---------------------------- extern variables ----------------------------*/ + +gofw_GraphType gofw_GraphSoft = gofw_Gnuplot; + +double gofw_Suspectp = 0.001; + +double gofw_Epsilonp = 1.0E-300; +double gofw_Epsilonp1 = 1.0E-15; + +char *gofw_TestNames[gofw_NTestTypes] = { + "KSPlus", "KSMinus", "KS", "Anderson-Darling", + "Cramer-vonMises", "Watson G", "Watson U", + "Mean", "Variance", "Correlation", "Sum" +}; + +bitset_BitSet gofw_ActiveTests = (bitset_BitSet) 0 | + (1U << gofw_KSP) | (1U << gofw_KSM) | (1U << gofw_AD); + + + +/*---------------------------- module variables ----------------------------*/ + +#define LEN1 100 +#define LEN2 10 + +static char desc[LEN1]; +static char str[LEN2]; + + + + +/*--------------------------------------------------------------------------*/ + +static void printMath2 (FILE * f, double x, double y) +{ + /* Writes the pair (x, y) in file f, in a format understood */ + /* by Mathematica */ + char S[41]; + + fprintf (f, " { "); + if ((x != 0.0) && (x < 0.1 || x > 1.0)) { + sprintf (S, "%16.7E", x); + mystr_Subst (S, "E", "*10^("); + strcat (S, ")"); + } else { + sprintf (S, "%16.8g", x); + } + fprintf (f, ", "); + + if (y != 0.0 && (y < 0.1 || y > 1.0)) { + sprintf (S, "%16.7E", y); + mystr_Subst (S, "E", "*10^("); + strcat (S, ")"); + } else { + sprintf (S, "%16.8g", y); + } + fprintf (f, " }"); +} + +/*--------------------------------------------------------------------------*/ + +void gofw_GraphDistUnif (FILE * f, double U[], long N, char Desc[]) +{ + long i; + double UnSurN = 1.0 / N; + if (f == NULL) + f = stdout; + + switch (gofw_GraphSoft) { + + case gofw_Gnuplot: + fprintf (f, "#----------------------------------\n"); + fprintf (f, "# %-70s\n\n", Desc); + fprintf (f, "%16.8g %16.8g\n", 0.0, 0.0); + for (i = 1; i <= N; i++) + fprintf (f, "%16.8g %16.8g\n", U[i], i * UnSurN); + fprintf (f, "%16.8g %16.8g\n\n", 1.0, 1.0); + break; + + case gofw_Mathematica: + fprintf (f, "(*----------------------------------*)\n"); + fprintf (f, "(* %-70s\n *)\n\npoints = { \n", Desc); + printMath2 (f, 0.0, 0.0); + fprintf (f, ",\n"); + for (i = 1; i <= N; i++) { + printMath2 (f, U[i], i * UnSurN); + fprintf (f, ",\n"); + } + printMath2 (f, 1.0, 1.0); + fprintf (f, "\n}\n\n"); + break; + + default: + util_Error ("gofw_GraphDistUnif: gofw_GraphSoft unknown"); + break; + } +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_GraphFunc (FILE *f, wdist_CFUNC F, double par[], double a, + double b, int M, int mono, char Desc[]) +{ + int i; + double yprec, y, x, h; + if (f == NULL) + f = stdout; + + switch (gofw_GraphSoft) { + + /* Il y a trop de repetition de code ici. */ + case gofw_Gnuplot: + fprintf (f, "#----------------------------------\n"); + fprintf (f, "# %-70s\n\n", Desc); + h = (b - a) / M; + if (mono == 1) + yprec = -DBL_MAX; + else if (mono == -1) + yprec = DBL_MAX; + else + yprec = 0.0; + for (i = 0; i <= M; i++) { + x = a + i * h; + y = F (par, x); + fprintf (f, "%16.8g %16.8g", x, y); + switch (mono) { + case 1: + if (y < yprec) + fprintf (f, " # DECREASING"); + break; + case -1: + if (y > yprec) + fprintf (f, " # INCREASING"); + break; + default: + break; + } + fprintf (f, "\n"); + yprec = y; + } + fprintf (f, "\n"); + break; + + case gofw_Mathematica: + fprintf (f, "(*----------------------------------*)\n"); + fprintf (f, "(* %-70s\n *)\n\npoints = { \n", Desc); + h = (b - a) / M; + if (mono == 1) + yprec = -DBL_MAX; + else if (mono == -1) + yprec = DBL_MAX; + else + yprec = 0.0; + for (i = 0; i <= M; i++) { + x = a + i * h; + y = F (par, x); + printMath2 (f, x, y); + if (i < M) + fprintf (f, ","); + + switch (mono) { + case 1: + if (y < yprec) + fprintf (f, " (* DECREASING *)"); + break; + case -1: + if (y > yprec) + fprintf (f, " (* INCREASING *)"); + break; + default: + break; + } + fprintf (f, "\n"); + yprec = y; + } + fprintf (f, "}\n\n"); + break; + + default: + util_Error ("gofw_GraphFunc: gofw_GraphSoft unknown"); + break; + } +} + + +/*--------------------------------------------------------------------------*/ + +double gofw_pDisc (double pLeft, double pRight) +{ + double p; + + if (pRight < pLeft) + p = pRight; + else if (pLeft > 0.5) + p = 0.5; + else + p = 1.0 - pLeft; + /* Note: si p est tres proche de 1, on perd toute la precision ici! */ + /* Note2: je ne pense pas que cela puisse se produire a cause des if (RS) + */ + return p; +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_Writep0 (double p) + /* Prints the significance level of a test, without a descriptor */ +{ + if ((p >= 0.01) && (p <= 0.99)) + num_WriteD (p, 8, 2, 1); + else if (p < gofw_Epsilonp) + printf (" eps "); + else if (p < 0.01) + num_WriteD (p, 8, 2, 2); + else if (p >= 1.0 - gofw_Epsilonp1) + printf (" 1 - eps1"); + else if (p < 1.0 - 1.0e-4) + printf (" %.4f", p); + else { + printf (" 1 - "); + num_WriteD (1.0 - p, 7, 2, 2); + } +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_Writep1 (double p) + /* Prints the significance level of a test, with a descriptor. */ +{ +/* printf ("Significance level of test :"); */ + printf ("p-value of test :"); + gofw_Writep0 (p); + if (p < gofw_Suspectp || p > 1.0 - gofw_Suspectp) { + printf (" *****"); + } + printf ("\n\n"); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_Writep2 (double x, double p) + /* Prints the statistic x and its significance level p. */ +{ + if ((x < 1.0e5 && x >= 0.1) || (x > -1.0e4 && x <= -0.1)) + num_WriteD (x, 8, 2, 1); + else if ((x < 0.1 && x >= 0.01) || (x > -0.1 && x <= -0.01)) + num_WriteD (x, 8, 3, 2); + else + num_WriteD (x, 8, 3, 3); + printf ("\n"); + gofw_Writep1 (p); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteKS0 (long N, double DP, double DM, double D) + /* Prints the results of a Kolmogorov-Smirnov test */ +{ + printf ("\n\nKolmogorov-Smirnov+ statistic = D+ :"); + gofw_Writep2 (DP, fbar_KSPlus (N, DP)); + printf ("Kolmogorov-Smirnov- statistic = D- :"); + gofw_Writep2 (DM, fbar_KSPlus (N, DM)); + printf ("Kolmogorov-Smirnov statistic = D :"); + gofw_Writep2 (D, fbar_KS1 (N, D)); + printf ("\n\n"); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteKS1 (double V[], long N, wdist_CFUNC F, double par[]) +{ + double *U; + double D, DM, DP; + + U = (double *) util_Calloc ((size_t) N + 1, sizeof (double)); + gofs_ContUnifTransform (V, N, F, par, U); + tables_QuickSortD (U, 1, N); + gofs_KS (U, N, &DP, &DM, &D); + gofw_WriteKS0 (N, DP, DM, D); + util_Free (U); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteKSJumpOne0 (long N, double a, double DP) +{ + double d; + + printf ("\nKolmogorov-Smirnov+ statistic = D+ :%8.2g\n", DP); + d = 1.0 - fdist_KSPlusJumpOne (N, a, DP); + gofw_Writep1 (d); + printf ("\n"); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteKSJumpOne1 (double V[], long N, wdist_CFUNC F, double par[], + double a) +{ + double *U; + double DP, DM; + + U = (double *)util_Calloc ((size_t) N + 1, sizeof (double)); + gofs_ContUnifTransform (V, N, F, par, U); + tables_QuickSortD (U, 1, N); + gofs_KSJumpOne (U, N, a, &DP, &DM); + gofw_WriteKSJumpOne0 (N, a, DP); + util_Free (U); +} + + +/*--------------------------------------------------------------------------*/ + +#if 0 + +void gofw_KSJumpsMany0 (double DP, double DM, fdist_FUNC_JUMPS * H) +{ + double d; + + printf ("\nKolmogorov-Smirnov+ statistic = D+ :%8.2g\n", DP); + d = 1.0 - fdist_KSPlusJumpsMany (H, DP); + gofw_Desc1 (d); + + printf ("\nKolmogorov-Smirnov- statistic = D- :%8.2g\n", DM); + d = 1.0 - fdist_KSMinusJumpsMany (H, DM); + gofw_Desc1 (d); + printf ("\n"); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_KSJumpsMany2 (statcoll_Collector *S, fdist_FUNC_JUMPS *H, + int Detail) +{ + double DM, DP; + double *X; + wdist_CFUNC F = H->F; + double *W = H->par; + + /* The implementation of fdist_KSPlusJumpsMany and fdist_KSMinusJumpsMany + works only for NObs <= 64: instability for larger NObs. */ + if (S->NObs > 64) { + printf ("\nKolmogorov-Smirnov, sample too large\n\n\n" + "------------------------------------------\n"); + return; + } + + X = (double *) util_Calloc (1 + (size_t) S->NObs, sizeof (double)); + tables_CopyTabD (S->St, X, 1, S->NObs); + tables_QuickSortD (X, 1, S->NObs); + statcalc_KSJumpsMany (X, S->NObs, F, W, &DP, &DM, Detail); + gofw_KSJumpsMany0 (DP, DM, H); + util_Free (X); + printf ("\n"); +} + +#endif +/*--------------------------------------------------------------------------*/ + +void gofw_InitTestArray (gofw_TestArray A, double x) +{ + int i; + for (i = 0; i < gofw_NTestTypes; i++) + A[i] = x; +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_Tests0 (double U[], long N, gofw_TestArray sVal) +{ + long i; + double A2 = 0.0, W2, DM = 0.0, DP = 0.0, W; + double U1, Ui, D2, D1; + double SumZ; + double UnSurN; + + util_Assert (N > 0, "gofw_Tests0: N <= 0"); + + /* We assume that U is already sorted. */ + if (N == 1) { + sVal[gofw_KSP] = 1.0 - U[1]; + sVal[gofw_Mean] = U[1]; + return; + } + UnSurN = 1.0 / N; + W2 = UnSurN / 12.0; + SumZ = 0.0; + for (i = 1; i <= N; i++) { + /* Statistics KS */ + D1 = U[i] - (i - 1) * UnSurN; + D2 = i * UnSurN - U[i]; + if (D1 > DM) + DM = D1; + if (D2 > DP) + DP = D2; + /* Watson U and G */ + SumZ += U[i]; + W = U[i] - (i - 0.5) * UnSurN; + W2 += W * W; + /* Anderson-Darling */ + Ui = U[i]; + U1 = 1.0 - Ui; + if (Ui < gofs_EpsilonAD) + Ui = gofs_EpsilonAD; + else if (U1 < gofs_EpsilonAD) + U1 = gofs_EpsilonAD; + A2 += (2 * i - 1) * log (Ui) + (1 + 2 * (N - i)) * log (U1); + } + if (DM > DP) + sVal[gofw_KS] = DM; + else + sVal[gofw_KS] = DP; + sVal[gofw_KSM] = DM; + sVal[gofw_KSP] = DP; + SumZ = SumZ * UnSurN - 0.5; + sVal[gofw_CM] = W2; + sVal[gofw_WG] = sqrt ((double) N) * (DP + SumZ); + sVal[gofw_WU] = W2 - SumZ * SumZ * N; + sVal[gofw_AD] = -N - A2 * UnSurN; +/* sVal[gofw_Mean] = SumZ + 0.5; */ /* Nouveau ... */ +} + +/*-------------------------------------------------------------------------*/ + +void gofw_Tests1 (double V[], long N, wdist_CFUNC F, double par[], + gofw_TestArray sVal) +{ + double *U; + util_Assert (N > 0, "gofw_Tests1: N <= 0"); + U = (double *) util_Calloc ((size_t) N + 1, sizeof (double)); + gofs_ContUnifTransform (V, N, F, par, U); + tables_QuickSortD (U, 1, N); + gofw_Tests0 (U, N, sVal); + if (N == 1) + sVal[gofw_Mean] = V[1]; /* On veut V[1], pas U[1] */ + util_Free (U); +} + +/*-------------------------------------------------------------------------*/ + +void gofw_ActiveTests0 (double U[], long N, + gofw_TestArray sVal, gofw_TestArray pVal) +{ + util_Assert (N > 0, "gofw_ActiveTests0: N <= 0"); + if (N == 1) { + sVal[gofw_Mean] = U[1]; + pVal[gofw_Mean] = 1.0 - U[1]; + sVal[gofw_KSP] = 1.0 - U[1]; + pVal[gofw_KSP] = 1.0 - U[1]; + pVal[gofw_AD] = -1.0; /* My bug detector */ + return; + } + /* We assume that U is already sorted. */ + gofw_Tests0 (U, N, sVal); + + if (bitset_TestBit (gofw_ActiveTests, gofw_KSP)) + pVal[gofw_KSP] = fbar_KSPlus (N, sVal[gofw_KSP]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_KSM)) + pVal[gofw_KSM] = fbar_KSPlus (N, sVal[gofw_KSM]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_KS)) + pVal[gofw_KS] = fbar_KS1 (N, sVal[gofw_KS]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_AD)) + pVal[gofw_AD] = fbar_AndersonDarling (N, sVal[gofw_AD]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_CM)) + pVal[gofw_CM] = fbar_CramerMises (N, sVal[gofw_CM]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_WG)) + pVal[gofw_WG] = fbar_WatsonG (N, sVal[gofw_WG]); + + if (bitset_TestBit (gofw_ActiveTests, gofw_WU)) + pVal[gofw_WU] = fbar_WatsonU (N, sVal[gofw_WU]); +} + +/*-------------------------------------------------------------------------*/ + +void gofw_ActiveTests1 (double V[], long N, wdist_CFUNC F, double par[], + gofw_TestArray sVal, gofw_TestArray pVal) +{ + double *U; + util_Assert (N > 0, "gofw_ActiveTests1: N <= 0"); + U = (double *) util_Calloc ((size_t) N + 1, sizeof (double)); + gofs_ContUnifTransform (V, N, F, par, U); + tables_QuickSortD (U, 1, N); + gofw_ActiveTests0 (U, N, sVal, pVal); + if (N == 1) + sVal[gofw_Mean] = V[1]; + util_Free (U); +} + +/*-------------------------------------------------------------------------*/ + +void gofw_ActiveTests2 (double V[], double U[], long N, wdist_CFUNC F, + double par[], gofw_TestArray sVal, gofw_TestArray pVal) +{ + util_Assert (N > 0, "gofw_ActiveTests1: N <= 0"); + tables_QuickSortD (V, 1, N); + gofs_ContUnifTransform (V, N, F, par, U); + gofw_ActiveTests0 (U, N, sVal, pVal); + if (N == 1) + sVal[gofw_Mean] = V[1]; +} + +/*-------------------------------------------------------------------------*/ + +void gofw_WriteActiveTests0 (long N, gofw_TestArray sVal, + gofw_TestArray pVal) +{ + if (N == 1) { + gofw_Writep1 (pVal[gofw_KSP]); + return; + } + printf ("\n"); + if (bitset_TestBit (gofw_ActiveTests, gofw_KSP)) { + printf ("Kolmogorov-Smirnov+ statistic = D+ :"); + gofw_Writep2 (sVal[gofw_KSP], pVal[gofw_KSP]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_KSM)) { + printf ("Kolmogorov-Smirnov- statistic = D- :"); + gofw_Writep2 (sVal[gofw_KSM], pVal[gofw_KSM]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_KS)) { + printf ("Kolmogorov-Smirnov statistic = D :"); + gofw_Writep2 (sVal[gofw_KS], pVal[gofw_KS]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_AD)) { + printf ("Anderson-Darling statistic = A2 :"); + gofw_Writep2 (sVal[gofw_AD], pVal[gofw_AD]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_CM)) { + printf ("Cramer-von Mises statistic = W2 :"); + gofw_Writep2 (sVal[gofw_CM], pVal[gofw_CM]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_WG)) { + printf ("Watson statistic = G :"); + gofw_Writep2 (sVal[gofw_WG], pVal[gofw_WG]); + } + if (bitset_TestBit (gofw_ActiveTests, gofw_WU)) { + printf ("Watson statistic = U2 :"); + gofw_Writep2 (sVal[gofw_WU], pVal[gofw_WU]); + } +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteActiveTests1 (double V[], long N, wdist_CFUNC F, double par[]) +{ + gofw_TestArray sv, pv; + + gofw_ActiveTests1 (V, N, F, par, sv, pv); + gofw_WriteActiveTests0 (N, sv, pv); +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_WriteActiveTests2 (long N, gofw_TestArray sVal, + gofw_TestArray pVal, char S[]) +{ + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + gofw_Writep2 (sVal[gofw_Mean], pVal[gofw_Mean]); + } else { + gofw_WriteActiveTests0 (N, sVal, pVal); + } +} + + +/*--------------------------------------------------------------------------*/ + +void gofw_IterSpacingsTests0 (double U[], long N, int k, + lebool printval, lebool graph, FILE * f) + /* Assumes that U is sorted. */ +{ + int j; + long i; + double *S, *UU; + gofw_TestArray sVal, pVal; + + UU = (double *) util_Calloc (1 + (size_t) N, sizeof (double)); + S = (double *) util_Calloc (1 + (size_t) N, sizeof (double)); + printf ("\n"); + for (i = 1; i <= N; i++) + UU[i] = U[i]; /* UU is a copy of U */ + for (j = 1; j <= k; j++) { + printf ("-----------------------------------\n" + "EDF Tests after \"gofw_IterateSpacings\", level :%2d\n", j); + gofs_DiffD (UU, S, 1, N, 0.0, 1.0); + gofs_IterateSpacings (UU, S, N); + tables_QuickSortD (UU, 1, N); + gofw_ActiveTests0 (UU, N, sVal, pVal); + gofw_WriteActiveTests0 (N, sVal, pVal); + strncpy (desc, "Values of Uniforms after IterateSpacings, level ", + (size_t) LEN1); + sprintf (str, "%2d", j); + strncat (desc, str, (size_t) LEN2); + if (printval > 0) + tables_WriteTabD (UU, 1, N, 5, 15, 6, 6, desc); + if (graph > 0) + gofw_GraphDistUnif (f, UU, N, desc); + } + util_Free (UU); + util_Free (S); +} + + +/*--------------------------------------------------------------------------*/ + + +void gofw_IterPowRatioTests0 (double U[], long N, int k, + lebool printval, lebool graph, FILE * f) +{ + int i; + long j; + double *UU; + gofw_TestArray sVal, pVal; + + UU = (double *) util_Calloc (1 + (size_t) N, sizeof (double)); + printf ("\n"); + for (j = 1; j <= N; j++) + UU[j] = U[j]; + for (i = 1; i <= k; i++) { + gofs_PowerRatios (UU, N); + printf ("-----------------------------------\n" + "EDF Tests after \"gofw_PowerRatios\", level :%2d\n", i); + tables_QuickSortD (UU, 1, N); + gofw_ActiveTests0 (UU, N, sVal, pVal); + gofw_WriteActiveTests0 (N, sVal, pVal); + strncpy (desc, "Values of Uniforms after PowerRatios, level ", + (size_t) LEN1); + sprintf (str, "%2d", i); + strncat (desc, str, (size_t) LEN2); + if (printval > 0) + tables_WriteTabD (UU, 1, N, 5, 15, 6, 6, desc); + if (graph > 0) + gofw_GraphDistUnif (f, UU, N, desc); + } + util_Free (UU); +} + +/*--------------------------------------------------------------------------*/ diff --git a/cbits/testu/src/mystr.c b/cbits/testu/src/mystr.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/mystr.c @@ -0,0 +1,171 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: mystr.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "mystr.h" +#include +#include +#include + + +void mystr_Delete (char S[], unsigned int index, unsigned int len) +{ + int i; + unsigned int length = strlen (S); + if (index + len > length) + S[index] = '\0'; + else + for (i = index; (unsigned int) i <= length - len; ++i) + S[i] = S[i + len]; +} + + +void mystr_Insert (char Res[], char Source[], unsigned int Pos) +{ + int i; + unsigned int ResLength = strlen (Res); + unsigned int SourceLength = strlen (Source); + if (Pos > ResLength) + util_Error ("mystr_Insert : Index out of array bound."); + for (i = ResLength; (unsigned) i >= Pos; --i) { + Res[i + SourceLength] = Res[i]; /* end of Res */ + } + for (i = Pos; (unsigned) i < Pos + SourceLength; ++i) + Res[i] = Source[i - Pos]; /* adding Source to Res */ +} + + +void mystr_ItemS (char R[], char S[], const char T[], unsigned int N) +{ + unsigned int i; + char *temp; + temp = strtok (S, T); /* first time */ + for (i = 1; i <= N; ++i) { /* 2nd to Nth time */ + if (temp == NULL) + break; + temp = strtok (NULL, T); + } + if (temp == NULL) { + strncpy (R, "\0", (size_t) 1); + return; + } + strcpy (R, temp); /* assignation */ +} + + +static int mystr_Rmatch (char s[], unsigned int i, char p[], unsigned int j) +{ + int matched; + unsigned int k; + unsigned int s_len = strlen (s); + unsigned int p_len = strlen (p); + if (p[0] == 0) + return 1; + for (;;) { + if ((i > s_len - 1 || s[i] == 0) && (j > p_len - 1 || p[j] == 0)) + return 1; + if (j > p_len - 1 || p[j] == 0) + return 0; + if (p[j] == '*') { + k = i; + if (j == p_len - 1 || p[j + 1] == 0) + return 1; + else { + for (;;) { + matched = mystr_Rmatch (s, k, p, j + 1); + if ((matched || k > s_len - 1) || s[k] == 0) + return matched; + ++k; + } + } + } + if ((p[j] == '?' && s[i]) || (toupper (p[j]) == toupper (s[i]))) { + ++i; + ++j; + } else + return 0; + } + return 0; +} + + +int mystr_Match (char Source[], char Pattern[]) +/* + returns TRUE if the string in Source matches the string in Pattern + The pattern may contain any number of the wild characters '*' and '?' + '?' matches any single character + '*' matches any sequence of charcters (including a zero length sequence) + EG '*m?t*i*' will match 'Automatic' + */ +{ + return mystr_Rmatch (Source, 0, Pattern, 0); +} + + +void mystr_Slice (char R[], char S[], unsigned int P, unsigned int L) +{ + unsigned int i; + if (P + L > strlen (S)) + util_Error ("*** ERROR : mystr_Slice Pattern longer then Source"); + for (i = 0; i < L; i++) { + R[i] = S[i + P]; + } + if (L <= strlen (R) - 1) + R[L] = 0; +} + + +void mystr_Subst (char source[], char OldPattern[], char NewPattern[]) +{ + unsigned int len; + unsigned int index; + char *PatternFound; + PatternFound = strstr (source, OldPattern); + if (PatternFound != NULL) { + len = strlen (OldPattern); + index = PatternFound - source; + mystr_Delete (source, index, len); + mystr_Insert (source, NewPattern, index); + } +} + + +void mystr_Position (char Substring[], char Source[], unsigned int at, + unsigned int *pos, int *found) +{ + char *result = strstr (Source + at, Substring); + if (at > strlen (Source)) + util_Error ("mystr_Position : Index out of array bound."); + if (result != NULL) { + *pos = result - Source; + *found = 1; + } else + *found = 0; +} diff --git a/cbits/testu/src/num.c b/cbits/testu/src/num.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/num.c @@ -0,0 +1,412 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: num.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "util.h" +#include "bitset.h" +#include "num.h" +#include +#include +#include +#include + + + + +#define Deux53 9007199254740992.0 /* 2^53 */ +#define Deux17 131072.0 /* 2^17 */ +#define UnDeux17 7.62939453125E-6 /* 1 / 2^17 */ +#define MASK32 0xffffffffUL + +double num_TwoExp[num_MaxTwoExp + 1] = { + 1.0, 2.0, 4.0, 8.0, 1.6e1, 3.2e1, + 6.4e1, 1.28e2, 2.56e2, 5.12e2, 1.024e3, + 2.048e3, 4.096e3, 8.192e3, 1.6384e4, 3.2768e4, + 6.5536e4, 1.31072e5, 2.62144e5, 5.24288e5, + 1.048576e6, 2.097152e6, 4.194304e6, 8.388608e6, + 1.6777216e7, 3.3554432e7, 6.7108864e7, + 1.34217728e8, 2.68435456e8, 5.36870912e8, + 1.073741824e9, 2.147483648e9, 4.294967296e9, + 8.589934592e9, 1.7179869184e10, 3.4359738368e10, + 6.8719476736e10, 1.37438953472e11, 2.74877906944e11, + 5.49755813888e11, 1.099511627776e12, 2.199023255552e12, + 4.398046511104e12, 8.796093022208e12, + 1.7592186044416e13, 3.5184372088832e13, + 7.0368744177664e13, 1.40737488355328e14, + 2.81474976710656e14, 5.62949953421312e14, + 1.125899906842624e15, 2.251799813685248e15, + 4.503599627370496e15, 9.007199254740992e15, + 1.8014398509481984e16, 3.6028797018963968e16, + 7.2057594037927936e16, 1.44115188075855872e17, + 2.88230376151711744e17, 5.76460752303423488e17, + 1.152921504606846976e18, 2.305843009213693952e18, + 4.611686018427387904e18, 9.223372036854775808e18, + 1.8446744073709551616e19 +}; + + +double num_TENNEGPOW[] = { + 1.0, 1.0e-1, 1.0e-2, 1.0e-3, 1.0e-4, 1.0e-5, 1.0e-6, 1.0e-7, 1.0e-8, + 1.0e-9, 1.0e-10, 1.0e-11, 1.0e-12, 1.0e-13, 1.0e-14, 1.0e-15, 1.0e-16 +}; + + + +int num_IsNumber (char S[]) +/********************************************************* + * Returns TRUE if the string S begin with a number * + * (with the possibility of spaces and a + or - sign * + * before the number). * + * e.g. * + * ' + 2' returns TRUE * + * '-+ 2' returns FALSE * + * '4hello' returns TRUE * + * 'hello' returns FALSE * + *********************************************************/ +{ + int Max; + int i; + int Sign; + Max = (int) (strlen (S) - 1); + Sign = 0; + for (i = 0; i < Max; i++) { + if (S[i] != ' ') { + if (S[i] == '+' || S[i] == '-') { + if (Sign) { + return 0; + } + /* We already saw a sign */ + Sign = 1; + } else if ((unsigned char) S[i] >= '0' && + (unsigned char) S[i] <= '9') { + return 1; + } else { + return 0; + } + } + } /* end for */ + return 0; /* There's no digit in S */ +} /* end IsNumber() */ + + +void num_IntToStrBase (long k, long b, char S[]) +{ + int Sign; /* insert a '-' if TRUE */ + long Char0; + long i; + long total; + long uppbound; + if (b < 2 || b > 10) { + util_Error ("*** Erreur: IntToStrB demande une b entre 2 et 10 ***"); + } + Char0 = 48; + if (k < 0) { + Sign = 1; + S[0] = '-'; + k = -k; + } else { + if (k == 0) { + S[0] = '0'; + S[1] = '\0'; + return; + } + Sign = 0; + } + i = k; + total = 0; + while (i > 0) { + i = (i / b); + ++total; + } + if (Sign) + uppbound = total + 1; + else + uppbound = total; + S[uppbound] = '\0'; + for (i = 0; i < total - 1; i++) { + S[(uppbound - i) - 1] = + (char) ((int) fmod ((double) k, (double) b) + Char0); + k = (long) (k / b); + } +} + + +/*=========================================================================*/ + +void num_Uint2Uchar (unsigned char *output, unsigned int *input, int L) +{ + int i, j; + + for (i = 0, j = 0; i < L; i++, j += 4) { + output[j + 3] = (unsigned char) (input[i] & 0xff); + output[j + 2] = (unsigned char) ((input[i] >> 8) & 0xff); + output[j + 1] = (unsigned char) ((input[i] >> 16) & 0xff); + output[j] = (unsigned char) ((input[i] >> 24) & 0xff); + } +} + + +/*=========================================================================*/ + +void num_WriteD (double x, int I, int J, int K) +{ + int PosEntier = 0, /* Le nombre de positions occupees par la + partie entiere de x */ + EntierSign, /* Le nombre de chiffres significatifs + avant le point */ + Neg = 0; /* Nombre n'egatif */ + char S[100]; + char *p; + + if (x == 0.0) + EntierSign = 1; + else { + EntierSign = PosEntier = floor (log10 (fabs (x)) + 1); + if (x < 0.0) + Neg = 1; + } + if (EntierSign <= 0) + PosEntier = 1; + + if ((x == 0.0) || + (((EntierSign + J) >= K) && (I >= (PosEntier + J + Neg + 1)))) + printf ("%*.*f", I, J, x); + + else { /* On doit utiliser la notation + scientifique. */ + sprintf (S, "%*.*e", I, K - 1, x); + p = strstr (S, "e+0"); + if (NULL == p) + p = strstr (S, "e-0"); + + /* remove the 0 in e-0 and in e+0 */ + if (p) { + p += 2; + while ((*p = *(p + 1))) + p++; + printf (" "); /* pour utiliser au moins I espaces */ + } + printf ("%s", S); + } +} + + +/***************************************************************************/ + +void num_WriteBits (unsigned long x, int k) +{ + int i, n = CHAR_BIT * sizeof (unsigned long); + unsigned long mask = (unsigned long) 1 << (n - 1); + int spaces; + lebool flag = FALSE; + + if (k > 0) { + spaces = k - n; + for (i = 0; i < spaces; i++) + printf (" "); + } + for (i = 0; i < n; i++) { + if (x & mask) { + printf ("1"); + flag = TRUE; + } else if (flag) + printf ("0"); + else + printf (" "); + mask >>= 1; + } + if (k < 0) { + spaces = -k - n; + for (i = 0; i < spaces; i++) + printf (" "); + } +} + + +/***************************************************************************/ + +#if LONG_MAX == 2147483647L +#define H 32768 /* = 2^d used in MultModL. */ +#else +#define H 2147483648L +#endif + +long num_MultModL (long a, long s, long c, long m) + /* Suppose que 0 < a < m et 0 < s < m. Retourne (a*s + c) % m. */ + /* Cette procedure est tiree de : */ + /* L'Ecuyer, P. et Cote, S., A Random Number Package with */ + /* Splitting Facilities, ACM TOMS, 1991. */ + /* On coupe les entiers en blocs de d bits. H doit etre egal a 2^d. */ +{ + long a0, a1, q, qh, rh, k, p; + if (a < H) { + a0 = a; + p = 0; + } else { + a1 = a / H; + a0 = a - H * a1; + qh = m / H; + rh = m - H * qh; + if (a1 >= H) { + a1 = a1 - H; + k = s / qh; + p = H * (s - k * qh) - k * rh; + if (p < 0) + p = (p + 1) % m + m - 1; + } else /* p = (A2 * s * h) % m. */ + p = 0; + if (a1 != 0) { + q = m / a1; + k = s / q; + p -= k * (m - a1 * q); + if (p > 0) + p -= m; + p += a1 * (s - k * q); + if (p < 0) + p = (p + 1) % m + m - 1; + } /* p = ((A2 * h + a1) * s) % m. */ + k = p / qh; + p = H * (p - k * qh) - k * rh; + if (p < 0) + p = (p + 1) % m + m - 1; + } /* p = ((A2 * h + a1) * h * s) % m */ + if (a0 != 0) { + q = m / a0; + k = s / q; + p -= k * (m - a0 * q); + if (p > 0) + p -= m; + p += a0 * (s - k * q); + if (p < 0) + p = (p + 1) % m + m - 1; + } + p = (p - m) + c; + if (p < 0) + p += m; + return p; +} + +/*************************************************************************/ + +double num_MultModD (double a, double s, double c, double m) +{ + double V; + long k; + V = a * s + c; + if (V >= Deux53 || -V >= Deux53) { + k = a * UnDeux17; + a -= k * Deux17; + V = k * s; + k = V / m; + V -= k * m; + V = V * Deux17 + a * s + c; + } + k = V / m; + V -= k * m; + if (V < 0) + V += m; + return V; +} + + +/**************************************************************************/ + +long num_InvEuclid (long M, long x) +/* + * Compute the inverse of x mod M by the modified Euclide + * algorithm (Knuth V2 p. 325). + */ +{ + long u1 = 0, u3 = M, v1 = 1, v3 = x; + long t1, t3, qq; + if (x == 0) return 0; + + while (v3 != 0) { + qq = u3 / v3; + t1 = u1 - v1 * qq; + t3 = u3 - v3 * qq; + u1 = v1; + v1 = t1; + u3 = v3; + v3 = t3; + } + if (u1 < 0) + u1 += M; + + if (u3 != 1) { /* In this case, the inverse does not exist! */ + fprintf (stderr, + "ERROR in num_InvEuclid: inverse does not exist: m = %ld, x = %ld\n", + M, x); + return 0; + } else + return u1; +} + + +/*------------------------------------------------------------------------*/ + +unsigned long num_InvExpon (int E, unsigned long Z) +/* + * Compute the inverse of Z modulo M = 2^E by exponentiation + */ +{ + int j; + unsigned long res = Z; + + if (Z == 0) return 0; + if (!(Z & 1)) { + fprintf (stderr, + "ERROR in num_InvExpon: inverse does not exist: E = %d, Z = %ld\n", + E, Z); + return 0; + } + for (j = 1; j <= E - 3; j++) + res = res * res * Z; + return res & bitset_MASK[E]; +} + + +/*------------------------------------------------------------------------*/ + +long num_RoundL (double x) +{ + return (x >= 0) ? (long)(x + 0.5) : (long)(x - 0.5); +} + + +double num_RoundD (double x) +{ + double z; + (x >= 0) ? modf(x + 0.5, &z) : modf(x - 0.5, &z); + return z; +} + + +/*------------------------------------------------------------------------*/ diff --git a/cbits/testu/src/num2.c b/cbits/testu/src/num2.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/num2.c @@ -0,0 +1,668 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: num2.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "num2.h" +#include "util.h" +#include "num.h" +#include +#include +#include + +#define EPSILON 1.0E-15 +#define MAXI 50 + +/* The factorials n! from n = 0 to n = 170 */ +static double Factorials[] = { + 1, + 1, + 2, + 6, + 24, + 120, + 720, + 5040, + 40320, + 362880, + 3628800, + 39916800, + 479001600, + 6227020800.0, + 87178291200.0, + 1307674368000.0, + 20922789888000.0, + 355687428096000.0, + 6402373705728000.0, + 1.21645100408832e+17, + 2.43290200817664e+18, + 5.109094217170944e+19, + 1.124000727777608e+21, + 2.585201673888498e+22, + 6.204484017332394e+23, + 1.551121004333099e+25, + 4.032914611266057e+26, + 1.088886945041835e+28, + 3.048883446117138e+29, + 8.841761993739701e+30, + 2.65252859812191e+32, + 8.222838654177922e+33, + 2.631308369336935e+35, + 8.683317618811886e+36, + 2.952327990396041e+38, + 1.033314796638614e+40, + 3.719933267899012e+41, + 1.376375309122634e+43, + 5.23022617466601e+44, + 2.039788208119744e+46, + 8.159152832478977e+47, + 3.34525266131638e+49, + 1.40500611775288e+51, + 6.041526306337383e+52, + 2.658271574788449e+54, + 1.196222208654802e+56, + 5.502622159812088e+57, + 2.586232415111682e+59, + 1.241391559253607e+61, + 6.082818640342675e+62, + 3.041409320171338e+64, + 1.551118753287382e+66, + 8.065817517094388e+67, + 4.274883284060025e+69, + 2.308436973392414e+71, + 1.269640335365828e+73, + 7.109985878048635e+74, + 4.052691950487722e+76, + 2.350561331282879e+78, + 1.386831185456899e+80, + 8.320987112741392e+81, + 5.075802138772248e+83, + 3.146997326038794e+85, + 1.98260831540444e+87, + 1.268869321858842e+89, + 8.247650592082472e+90, + 5.443449390774431e+92, + 3.647111091818868e+94, + 2.480035542436831e+96, + 1.711224524281413e+98, + 1.197857166996989e+100, + 8.504785885678622e+101, + 6.123445837688608e+103, + 4.470115461512683e+105, + 3.307885441519386e+107, + 2.480914081139539e+109, + 1.88549470166605e+111, + 1.451830920282858e+113, + 1.132428117820629e+115, + 8.946182130782973e+116, + 7.156945704626378e+118, + 5.797126020747366e+120, + 4.75364333701284e+122, + 3.945523969720657e+124, + 3.314240134565352e+126, + 2.817104114380549e+128, + 2.422709538367272e+130, + 2.107757298379527e+132, + 1.854826422573984e+134, + 1.650795516090845e+136, + 1.485715964481761e+138, + 1.352001527678402e+140, + 1.24384140546413e+142, + 1.156772507081641e+144, + 1.087366156656742e+146, + 1.032997848823905e+148, + 9.916779348709491e+149, + 9.619275968248206e+151, + 9.426890448883242e+153, + 9.33262154439441e+155, + 9.33262154439441e+157, + 9.425947759838354e+159, + 9.614466715035121e+161, + 9.902900716486175e+163, + 1.029901674514562e+166, + 1.08139675824029e+168, + 1.146280563734708e+170, + 1.226520203196137e+172, + 1.324641819451828e+174, + 1.443859583202493e+176, + 1.588245541522742e+178, + 1.762952551090244e+180, + 1.974506857221073e+182, + 2.231192748659812e+184, + 2.543559733472186e+186, + 2.925093693493014e+188, + 3.393108684451897e+190, + 3.969937160808719e+192, + 4.684525849754288e+194, + 5.574585761207603e+196, + 6.689502913449124e+198, + 8.09429852527344e+200, + 9.875044200833598e+202, + 1.214630436702532e+205, + 1.50614174151114e+207, + 1.882677176888925e+209, + 2.372173242880046e+211, + 3.012660018457658e+213, + 3.856204823625803e+215, + 4.974504222477285e+217, + 6.466855489220472e+219, + 8.471580690878817e+221, + 1.118248651196004e+224, + 1.487270706090685e+226, + 1.992942746161518e+228, + 2.69047270731805e+230, + 3.659042881952547e+232, + 5.01288874827499e+234, + 6.917786472619486e+236, + 9.615723196941086e+238, + 1.346201247571752e+241, + 1.89814375907617e+243, + 2.695364137888161e+245, + 3.854370717180071e+247, + 5.550293832739301e+249, + 8.047926057471987e+251, + 1.17499720439091e+254, + 1.727245890454638e+256, + 2.556323917872864e+258, + 3.808922637630567e+260, + 5.71338395644585e+262, + 8.627209774233235e+264, + 1.311335885683452e+267, + 2.006343905095681e+269, + 3.089769613847349e+271, + 4.789142901463391e+273, + 7.471062926282891e+275, + 1.172956879426414e+278, + 1.853271869493734e+280, + 2.946702272495037e+282, + 4.714723635992059e+284, + 7.590705053947215e+286, + 1.229694218739449e+289, + 2.004401576545302e+291, + 3.287218585534294e+293, + 5.423910666131586e+295, + 9.003691705778433e+297, + 1.503616514864998e+300, + 2.526075744973197e+302, + 4.269068009004703e+304, + 7.257415615307994e+306 +}; + + +#define MLIM 50 + +/* The natural logarithm of factorials n! from n = 0 to 50 */ +static double LnFactorials[MLIM + 1] = { + 0., + 0., + 0.6931471805599453, + 1.791759469228055, + 3.178053830347946, + 4.787491742782046, + 6.579251212010101, + 8.525161361065415, + 10.60460290274525, + 12.80182748008147, + 15.10441257307552, + 17.50230784587389, + 19.98721449566188, + 22.55216385312342, + 25.19122118273868, + 27.89927138384088, + 30.67186010608066, + 33.50507345013688, + 36.39544520803305, + 39.33988418719949, + 42.33561646075348, + 45.3801388984769, + 48.47118135183522, + 51.60667556776437, + 54.7847293981123, + 58.00360522298051, + 61.26170176100199, + 64.55753862700632, + 67.88974313718154, + 71.257038967168, + 74.65823634883016, + 78.09222355331529, + 81.55795945611503, + 85.05446701758153, + 88.58082754219767, + 92.13617560368708, + 95.7196945421432, + 99.3306124547874, + 102.9681986145138, + 106.6317602606434, + 110.3206397147574, + 114.0342117814617, + 117.7718813997451, + 121.5330815154386, + 125.3172711493569, + 129.1239336391272, + 132.9525750356163, + 136.8027226373264, + 140.6739236482343, + 144.5657439463449, + 148.477766951773 +}; + + +/*=========================================================================*/ + +double num2_Factorial (int n) +{ + util_Assert (n >= 0, "num2_Factorial: n < 0"); + if (n <= 170) + return Factorials[n]; + util_Warning (1, "num2_Factorial: n > 170: return inf"); + return 1.0 / 0.0; +} + + +/*=========================================================================*/ + +double num2_LnFactorial (int n) +{ + util_Assert (n >= 0, "num2_LnFactorial: n < 0"); + if (n <= MLIM) { + return LnFactorials[n]; + + } else { + double x = (double) (n + 1); + double y = 1.0 / (x * x); + double z = ((-(5.95238095238E-4 * y) + 7.936500793651E-4) * y - + 2.7777777777778E-3) * y + 8.3333333333333E-2; + z = ((x - 0.5) * log (x) - x) + 9.1893853320467E-1 + z / x; + return z; + } +} + + +/*=========================================================================*/ +#ifndef HAVE_LGAMMA + +/* The new standard ISO_C99 includes the lgamma function in math.h; + otherwise, we shall have to use our own. */ + +double num2_LnGamma (double x) +{ + const double xlimbig = 1.0 / DBL_EPSILON; + const double xlim1 = 18.0; + const double dk2 = 0.91893853320467274178; /* Ln (sqrt (2 Pi)) */ + const double dk1 = 0.9574186990510627; + const int N = 15; /* Degree of Chebyshev polynomial */ + double y = 0, z = 0; + int i, k; + + /* Chebyshev coefficients for lnGamma (x + 3), 0 <= x <= 1 In Yudell Luke: + The special functions and their approximations, Vol. II, Academic Press, + p. 301, 1969. There is an error in the additive constant in the formula: + (Ln (2)). */ + static const double A[] = { + 0.52854303698223459887, + 0.54987644612141411418, + 0.02073980061613665136, + -0.00056916770421543842, + 0.00002324587210400169, + -0.00000113060758570393, + 0.00000006065653098948, + -0.00000000346284357770, + 0.00000000020624998806, + -0.00000000001266351116, + 0.00000000000079531007, + -0.00000000000005082077, + 0.00000000000000329187, + -0.00000000000000021556, + 0.00000000000000001424, + -0.00000000000000000095 + }; + + util_Assert (x > 0.0, "num2_LnGamma: accepts only x > 0"); + if (x > xlim1) { + if (x > xlimbig) + y = 0.0; + else + y = 1.0 / (x * x); + z = ((-(5.95238095238E-4 * y) + 7.936500793651E-4) * y - + 2.7777777777778E-3) * y + 8.3333333333333E-2; + z = ((x - 0.5) * log (x) - x) + dk2 + z / x; + return z; + + } else if (x > 4.0) { + k = (int) x; + z = x - k; + y = 1.0; + for (i = 3; i < k; i++) + y *= z + i; + y = log (y); + + } else if (x <= 0.0) { + return DBL_MAX; + + } else if (x < 3.0) { + k = (int) x; + z = x - k; + y = 1.0; + for (i = 2; i >= k; i--) + y *= z + i; + y = -log (y); + + } else { /* 3 <= x <= 4 */ + z = x - 3.0; + y = 0.0; + } + + z = num2_EvalCheby (A, N, 2.0 * z - 1.0); + return z + dk1 + y; +} + +#endif +/*=========================================================================*/ + +#define NLIM 100 /* pour eviter les debordements */ + +double num2_Combination (int n, int s) +{ + double Res; + int i; + int Diff; + if (s == 0 || s == n) + return 1.0; + if (s < 0) { + util_Warning (1, "num2_Combination: s < 0"); + return 0.0; + } + if (s > n) { + util_Warning (1, "num2_Combination: s > n"); + return 0.0; + } + if (s > (n / 2)) + s = n - s; + if (n <= NLIM) { + Res = 1.0; + Diff = n - s; + for (i = 1; i <= s; i++) { + Res = (Res * (double) (Diff + i)) / (double) (i); + } + return Res; + } else { + Res = (num2_LnFactorial (n) - num2_LnFactorial (s)) + - num2_LnFactorial (n - s); + return exp (Res); + } +} + + +/*=========================================================================*/ +#ifndef HAVE_LOG1P + +double num2_log1p (double x) +{ + /* returns a value equivalent to log (1 + x) accurate also for small x. */ + if (fabs (x) > 0.1) { + return log (1.0 + x); + } else { + double term = x; + double sum = x; + int s = 2; + while (fabs (term) > EPSILON * fabs (sum) && s < MAXI) { + term *= -x; + sum += term / s; + s++; + } + return sum; + } +} + +#endif +/*=========================================================================*/ + +void num2_CalcMatStirling (double ***M, int m, int n) +/* Calcul des elements de la matrice MatStirling [0..m, 0..n]. */ +{ + int i, j, k; + *M = (double **) util_Calloc ((size_t) (m + 1), sizeof (double *)); + for (i = 0; i <= m; i++) + (*M)[i] = (double *) util_Calloc ((size_t) (n + 1), sizeof (double)); + + for (i = 0; i <= m; i++) { + for (j = 0; j <= n; j++) { + (*M)[i][j] = 0.0; + } + } + + (*M)[0][0] = 1.0; + for (j = 1; j <= n; j++) { + (*M)[0][j] = 0.0; + if (j <= m) { + k = j - 1; + (*M)[j][j] = 1.0; + } else + k = m; + for (i = 1; i <= k; i++) { + (*M)[i][j] = (double) (i) * (*M)[i][j - 1] + (*M)[i - 1][j - 1]; + } + } +} + + +/*=========================================================================*/ + +void num2_FreeMatStirling (double ***M, int m) +{ + int i; + for (i = 0; i <= m; i++) + free ((*M)[i]); + free (*M); + *M = NULL; +} + + +/*=========================================================================*/ + +double num2_VolumeSphere (double pLR, int k) +/* Returns volume of unit sphere in dimension k, norm p */ +{ + const double eps = 2.0 * DBL_EPSILON; + int p = pLR; + double kLR = (double) k; + double Vol; + int s; + + util_Assert (pLR >= 0.0, "num2_VolumeSphere: p < 0"); + if (fabs (pLR - p) <= eps) { + switch (p) { + case 0: + return num_TwoExp[k]; + break; + case 1: + return num_TwoExp[k] / num2_Factorial (k); + break; + case 2: + if ((k % 2) == 0) { + return pow (num_Pi, kLR / 2.0) / num2_Factorial (k / 2); + } else { + s = (k + 1) / 2; + return pow (num_Pi, (double) (s) - 1.0) * num2_Factorial (s) * + num_TwoExp[2 * s] / num2_Factorial (2 * s); + } + break; + default: + break; + } + } + Vol = kLR * (num_Ln2 + num2_LnGamma (1.0 + 1.0 / pLR)) - + num2_LnGamma (1.0 + kLR / pLR); + return exp (Vol); +} + + +/*=========================================================================*/ + +double num2_EvalCheby (const double A[], int N, double x) +{ + int j; + double xx; + double b0, b1, b2; + util_Warning (fabs (x) > 1.0, + "Chebychev polynomial evaluated at x outside [-1, 1]"); + xx = 2.0 * x; + b0 = 0.0; + b1 = 0.0; + for (j = N; j >= 0; j--) { + b2 = b1; + b1 = b0; + b0 = (xx * b1 - b2) + A[j]; + } + return (b0 - b2) / 2.0; +} + + +/*=========================================================================*/ +#define DEGREE 6 + +double num2_BesselK025 (double x) +{ + double rac; + double xx; + double temp; + double Res; + double C; + double B; + int j; + static const double c[8] = { + 32177591145.0, + 2099336339520.0, + 16281990144000.0, + 34611957596160.0, + 26640289628160.0, + 7901666082816.0, + 755914244096.0 + }; + + static const double b[8] = { + 75293843625.0, + 2891283595200.0, + 18691126272000.0, + 36807140966400.0, + 27348959232000.0, + 7972533043200.0, + 755914244096.0 + }; + + if (x < 1.E-300) + return DBL_MAX; + + /*------------------------------------------------------------------*/ + /* x > 0.6 => approximation asymptotique rationnelle dans Luke: */ + /* Yudell L.Luke "Mathematical functions and their approximations", */ + /* Academic Press Inc. New York, 1975, p.371 */ + /*------------------------------------------------------------------*/ + if (x >= 0.6) { + B = b[DEGREE]; + C = c[DEGREE]; + for (j = DEGREE; j >= 1; j--) { + B = B * x + b[j - 1]; + C = C * x + c[j - 1]; + } + Res = sqrt (num_Pi / (2.0 * x)) * exp (-x) * (C / B); + return Res; + } + + /*------------------------------------------------------------------*/ + /* x < 0.6 => la serie de K_{1/4} = Pi/Sqrt(2) [I_{-1/4} - I_{1/4}] */ + /*------------------------------------------------------------------*/ + xx = x * x; + rac = pow (x / 2.0, 0.25); + Res = (((xx / 1386.0 + 1.0 / 42.0) * xx + 1.0 / 3.0) * xx + 1.0) / + (1.225416702465177 * rac); + temp = (((xx / 3510.0 + 1.0 / 90.0) * xx + 0.2) * xx + 1.0) * rac / + 0.906402477055477; + Res = num_Pi * (Res - temp) / num_Rac2; + return Res; +} + +#undef DEGREE +/*=========================================================================*/ + +double num2_Digamma (double x) +{ + static const double C7[] = { + 1.3524999667726346383e4, 4.5285601699547289655e4, + 4.5135168469736662555e4, 1.8529011818582610168e4, + 3.3291525149406935532e3, 2.4068032474357201831e2, + 5.1577892000139084710, 6.2283506918984745826e-3 + }; + + static const double D7[] = { + 6.9389111753763444376e-7, 1.9768574263046736421e4, + 4.1255160835353832333e4, 2.9390287119932681918e4, + 9.0819666074855170271e3, 1.2447477785670856039e3, + 6.7429129516378593773e1, 1.0 + }; + + static const double C4[] = { + -2.728175751315296783e-15, -6.481571237661965099e-1, + -4.486165439180193579, -7.016772277667586642, -2.129404451310105168 + }; + + static const double D4[] = { + 7.777885485229616042, 5.461177381032150702e1, + 8.929207004818613702e1, 3.227034937911433614e1, 1.0 + }; + + double prodPj = 0.0; + double prodQj = 0.0; + double digX = 0.0; + + if (x >= 3.0) { + double x2 = 1.0 / (x * x); + int j; + for (j = 4; j >= 0; j--) { + prodPj = prodPj * x2 + C4[j]; + prodQj = prodQj * x2 + D4[j]; + } + digX = log (x) - (0.5 / x) + (prodPj / prodQj); + + } else if (x >= 0.5) { + const double X0 = 1.46163214496836234126; + int j; + for (j = 7; j >= 0; j--) { + prodPj = x * prodPj + C7[j]; + prodQj = x * prodQj + D7[j]; + } + digX = (x - X0) * (prodPj / prodQj); + + } else { + double f = (1.0 - x) - floor (1.0 - x); + digX = num2_Digamma (1.0 - x) + num_Pi / tan (num_Pi * f); + } + + return digX; +} + diff --git a/cbits/testu/src/scomp.c b/cbits/testu/src/scomp.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/scomp.c @@ -0,0 +1,642 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: scomp.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "chrono.h" +#include "num.h" +#include "tables.h" + +#include "scomp.h" +#include "sres.h" +#include "swrite.h" +#include "unif01.h" + +#include "fbar.h" +#include "wdist.h" +#include "gofw.h" +#include "gofs.h" +#include "statcoll.h" + +#include +#include +#include + + +#define LENGTH 100 + +/* Empirical Mean for Lempel-Ziv test for 2^3 <= n <= 2^28. Obtained by + simulation with N = 1000 */ +static const double LZMu[] = { + 0.0, 0.0, 0.0, 4.44, 7.64, + 12.5, 20.8, 34.8, 58.9, 101.1, + 176.0, 310.0, 551.9, 992.3, 1799., + 3286.2, 6041.5, 11171.5, 20761.8, 38760.4, + 72654., 136677., 257949., 488257., 926658., + 1762965., 3361490., 6422497., 12293930. +}; + +/* Empirical Standard Deviation for Lempel-Ziv test for 2^3 <= n <= 2^28 */ +static const double LZSigma[] = { + 0.0, 0.0, 0.0, 0.49, 0.51, + 0.62, 0.75, 0.78, 0.86, 0.94, + 1.03, 1.19, 1.43, 1.68, 2.09, + 2.46, 3.36, 4.2, 5.4, 6.8, + 9.1, 10.9, 14.7, 19.1, 25.2, + 33.5, 44.546, 58.194, 75.513 +}; + + + +/*--------------------------------- Types ---------------------------------*/ + +/* Bit trie used in Lempel-Ziv test. If left != NULL, this means a 0 bit. + If right != NULL, this means a 1 bit. The word is the sequence obtained + by following the tree until a NULL pointer is met. */ + +struct BitTrie_t { + struct BitTrie_t *left; + struct BitTrie_t *right; +}; +typedef struct BitTrie_t BitTrie_t; + + + + +/*-------------------------------- Functions ------------------------------*/ + +static void DeleteBitTrie (BitTrie_t *tree) +{ + if (tree == NULL) + return; + DeleteBitTrie (tree->left); + DeleteBitTrie (tree->right); + util_Free (tree); +} + + +/*=========================================================================*/ + + +static void InitRes ( + scomp_Res *res, /* Results holder */ + long N, /* Number of replications */ + int jmax, /* Max class index for size of jumps */ + int tmax /* Max class index for linear complexity */ +) +/* + * Initializes the scomp_Res structure + */ +{ + sres_InitBasic (res->JumpNum, N, + "scomp_LinearComp: Number of Jumps"); + sres_InitChi2 (res->JumpSize, N, jmax, + "scomp_LinearComp: Size of Jumps"); + sres_InitChi2 (res->LinComp, N, tmax, + "scomp_LinearComp: Linear Complexity"); +} + + +/*-------------------------------------------------------------------------*/ + +scomp_Res * scomp_CreateRes (void) +{ + scomp_Res *res; + res = util_Malloc (sizeof (scomp_Res)); + res->JumpNum = sres_CreateBasic (); + res->JumpSize = sres_CreateChi2 (); + res->LinComp = sres_CreateChi2 (); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void scomp_DeleteRes (scomp_Res *res) +{ + if (res == NULL) + return; + sres_DeleteBasic (res->JumpNum); + sres_DeleteChi2 (res->JumpSize); + sres_DeleteChi2 (res->LinComp); + util_Free (res); +} + + +/*=========================================================================*/ + +static void WriteDataJumps (unif01_Gen *gen, char *TestName, long N, long n, + int r, int s, double muComp, double mu, double sigma) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d\n", s); + if (swrite_Parameters) { + printf ("\n muComp = "); + num_WriteD (muComp, 12, 4, 2); + printf ("\n Mu = "); + num_WriteD (mu, 12, 4, 2); + printf ("\n Sigma = "); + num_WriteD (sigma, 12, 4, 2); + } + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static void BerlekampMassey ( + scomp_Res *res, + long n, /* Number of bits */ + double *pComp, /* Linear complexity */ + double *pNumJ, /* Number of jumps */ + int *Bits, + int *Polyb, + int *Polyc, + int *PolycOld + ) +/* + * Berlekamp-Massey algorithm to calculate the linear complexity. + */ +{ + int b; + long Loc; + long i; + long m; + long k; + long L; /* Linear complexity */ + long NumJ; /* Number of jumps */ + sres_Chi2 *resl = res->JumpSize; + + for (k = 0; k <= resl->jmax; k++) + resl->Count[k] = 0; + + Polyc[0] = 1; + Polyb[0] = 1; + L = 0; + NumJ = 0; + k = 0; + m = -1; + + while (k < n) { + /* Return the value of the current polynomial to see if it can + generate the next bit */ + b = 0; + for (i = 1; i <= L; i++) + /* b ^= Polyc[i] * Bits[k + 1 - i]; */ + b = (b + Polyc[i] * Bits[k + 1 - i]) & 1; + + if (Bits[k + 1] != b) { + /* Update c(x)_old and c(x) */ + for (i = 0; i <= L; i++) + PolycOld[i] = Polyc[i]; + + for (i = 0; i <= L; i++) { + if (Polyb[i] == 1) + Polyc[k - m + i] = (++Polyc[k - m + i]) & 1; + } + if (2 * L <= k) { + L = k + 1 - L; + NumJ++; + Loc = labs (k + 1 - 2 * L); + if (Loc <= resl->jmax) + ++resl->Count[Loc]; + else + ++resl->Count[resl->jmax]; + /* Update B */ + for (i = 0; i <= L; i++) + Polyb[i] = PolycOld[i]; + m = k; + } + } + ++k; + } + *pNumJ = NumJ; + *pComp = L; +} + + +/*=========================================================================*/ + +void scomp_LinearComp (unif01_Gen *gen, scomp_Res *res, + long N, long n, int r, int s) +{ + const double epsilon = 1.0E-10; + const int tt = 1 - 0.5 * num_Log2 (3 * epsilon); /* Dimension */ + const long K0 = n/s; + long i, Seq; + int j, k; + int M0; + double NumJ; /* Number of Jumps */ + double sigma, mu; /* Parameters of number of jumps */ + double comp; /* Linear complexity */ + double muComp; /* Mean of linear complexity */ + unsigned long Nombre; /* Random number */ + int Parite; + double *Prob; + long *Loca; + long tmin, tmax, NbClasses; + double X2; + double temp; + int *Bits; /* 4 Arrays of bits */ + int *Polyb; + int *Polyc; + int *PolycOld; + double Param[1]; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "scomp_LinearComp test"; + sres_Basic *resJN; + sres_Chi2 *resJL; + sres_Chi2 *resLC; + lebool JL_OK = TRUE; /* If TRUE do the JL test, otherwise not */ + lebool LC_OK = FALSE; /* If TRUE do the LC test, otherwise not */ + + Timer = chrono_Create (); + n = K0 * s; + Parite = n & 1; + if (n >= DBL_MAX_EXP) + temp = 0.0; + else + temp = pow (2.0, -(double) n); + + mu = n / 4.0 + (4 + Parite) / 12.0 - temp / 3.0; + sigma = n / 8.0 - (2 - Parite)/(9.0 - Parite) + n * temp / 6.0 + + (6 + Parite) * temp / 18.0 - temp * temp / 9.0; + sigma = sqrt (sigma); + muComp = n / 2.0 + (4 + Parite) / 18.0; + M0 = num_Log2 (mu / gofs_MinExpected); + if (M0 < 2) { + /* 0 degree of freedom for the chi2, do not do the test JL. */ + JL_OK = FALSE; + } + + if (swrite_Basic) + WriteDataJumps (gen, TestName, N, n, r, s, muComp, mu, sigma); + + /* util_Assert (M0 > 1, "scomp_LinearComp: n*s is too small"); */ + util_Assert (M0 <= num_MaxTwoExp, "scomp_LinearComp: M0 > num_MaxTwoExp"); + + Prob = util_Calloc (1 + (size_t) tt, sizeof (double)); + Bits = util_Calloc ((size_t) n + 1, sizeof (int)); + Polyb = util_Calloc ((size_t) n + 1, sizeof (int)); + Polyc = util_Calloc ((size_t) n + 1, sizeof (int)); + PolycOld = util_Calloc ((size_t) n + 1, sizeof (int)); + + if (res == NULL) { + localRes = TRUE; + res = scomp_CreateRes (); + } + M0 = util_Max (M0, 1); + InitRes (res, N, M0, tt); + resJN = res->JumpNum; + resJL = res->JumpSize; + resLC = res->LinComp; + Loca = resLC->Loc; + + if (N > 2.0 * gofs_MinExpected) { + /* Compute the expected probabilities for the linear complexity. */ + /* We put in Prob[k] the probabilities for i = k and i = -k of */ + /* the statistic defined in the NIST document 800-22, p. 86. */ + temp = Prob[0] = 0.5; + for (k = 1; k < tt; k++) { + Prob[k] = 1.5 * pow (4.0, -(double) k); + temp += Prob[k]; + } + Prob[tt] = 1.0 - temp; + for (k = 0; k <= tt; k++) { + resLC->Count[k] = 0; + resLC->NbExp[k] = N * Prob[k]; + } + tmin = 0; + tmax = tt; + if (swrite_Classes) { + printf ("Classes for the linear complexity:\n"); + gofs_WriteClasses (resLC->NbExp, Loca, tmin, tmax, 0); + } + gofs_MergeClasses (resLC->NbExp, Loca, &tmin, &tmax, &NbClasses); + resLC->jmax = tmax; + resLC->jmin = tmin; + resLC->degFree = NbClasses - 1; + if (NbClasses < 2) { + /* 0 degree of freedom for the chi2, do not do the test LC. */ + LC_OK = FALSE; + } else + LC_OK = TRUE; + } + + statcoll_SetDesc (resJN->sVal1, + "The number of jumps: the N statistic values (a standard normal):"); + sprintf (str, "The jumps size: the N statistic values (a ChiSquare" + " with %1d degrees of freedom):", M0 - 1); + statcoll_SetDesc (resJL->sVal1, str); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i < K0; i++) { + Nombre = unif01_StripB (gen, r, s); + for (j = s; j >= 1; j--) { + Bits[s * i + j] = Nombre & 1; + Nombre >>= 1; + } + } + + BerlekampMassey (res, n, &comp, &NumJ, Bits, Polyb, Polyc, PolycOld); + + /* Value of the statistic for the linear complexity */ + if (LC_OK) { + comp = comp - muComp; + if (Parite) + comp = -comp; + comp += 2.0 / 9.0; + /* comp is now an integer: truncate correctly and avoid off-by-1 + error because of small floating-point inaccuracies. */ + if (comp >= 0.0) + k = comp + 0.5; + else + k = comp - 0.5; + if (k < 0) + k = -k; + if (k >= tt) + ++resLC->Count[Loca[tt]]; + else + ++resLC->Count[Loca[k]]; + } + + /* Value of the normal statistic for the number of jumps */ + statcoll_AddObs (resJN->sVal1, (NumJ - mu) / sigma); + + /* Value of the statistic for the size of the jumps */ + if (JL_OK) { + for (k = 1; k < M0; k++) { + resJL->NbExp[k] = NumJ / num_TwoExp[k]; + resJL->Loc[k] = k; + } + resJL->NbExp[M0] = NumJ / num_TwoExp[M0 - 1]; + resJL->Loc[M0] = M0; + resJL->jmax = M0; + resJL->jmin = 1; + resJL->degFree = M0 - 1; + + X2 = gofs_Chi2 (resJL->NbExp, resJL->Count, 1, M0); + statcoll_AddObs (resJL->sVal1, X2); + if (swrite_Classes) { + printf ("\n\nClasses for the size of the jumps:\n"); + gofs_WriteClasses (resJL->NbExp, (long *) NULL, 1, M0, 0); + } + if (swrite_Counters) + tables_WriteTabL (resJL->Count, 1, M0, 5, 10, + "Size of the jumps: observed numbers"); + } + } + + gofw_ActiveTests2 (resJN->sVal1->V, resJN->pVal1->V, N, wdist_Normal, + (double *) NULL, resJN->sVal2, resJN->pVal2); + resJN->pVal1->NObs = N; + sres_GetNormalSumStat (resJN); + + if (JL_OK) { + Param[0] = M0 - 1; + gofw_ActiveTests2 (resJL->sVal1->V, resJL->pVal1->V, N, + wdist_ChiSquare, Param, resJL->sVal2, resJL->pVal2); + resJL->pVal1->NObs = N; + sres_GetChi2SumStat (resJL); + } + + if (LC_OK) { + X2 = gofs_Chi2 (resLC->NbExp, resLC->Count, tmin, tmax); + resLC->sVal2[gofw_Mean] = X2; + resLC->pVal2[gofw_Mean] = fbar_ChiSquare2 (NbClasses - 1, 8, X2); + } + + if (swrite_Basic) { + if (JL_OK) { + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Number of degrees of freedom : %4ld\n", + resJL->degFree); + printf ("Chi2 statistic for size of jumps :"); + gofw_Writep2 (resJL->sVal2[gofw_Mean], resJL->pVal2[gofw_Mean]); + } else { + printf ("Test results for the size of jumps:\n"); + gofw_WriteActiveTests0 (N, resJL->sVal2, resJL->pVal2); + swrite_Chi2SumTest (N, resJL); + } + if (swrite_Collectors) + statcoll_Write (resJL->sVal1, 5, 14, 4, 3); + } + + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Normal statistic for number of jumps :"); + gofw_Writep2 (resJN->sVal2[gofw_Mean], resJN->pVal2[gofw_Mean]); + } else { + printf ("Test results for the number of jumps:\n"); + gofw_WriteActiveTests0 (N, resJN->sVal2, resJN->pVal2); + swrite_NormalSumTest (N, resJN); + } + if (swrite_Collectors) + statcoll_Write (resJN->sVal1, 5, 14, 4, 3); + + if (LC_OK) { + printf ("\n-----------------------------------------------\n"); + printf ("Test results for the linear complexity:\n\n"); + printf ("Number of degrees of freedom : %4ld\n", + resLC->degFree); + printf ("Chi2 statistic on the N replications :"); + gofw_Writep2 (resLC->sVal2[gofw_Mean], resLC->pVal2[gofw_Mean]); + if (swrite_Classes) + gofs_WriteClasses (resLC->NbExp, Loca, tmin, tmax, NbClasses); + if (swrite_Counters) + tables_WriteTabL (resLC->Count, tmin, tmax, 5, 10, + "Linear Complexity: observed numbers"); + } + + printf ("\n\n"); + swrite_Final (gen, Timer); + } + + util_Free (Prob); + util_Free (Bits); + util_Free (Polyb); + util_Free (Polyc); + util_Free (PolycOld); + if (localRes) + scomp_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataLZ ( + unif01_Gen *gen, /* generator */ + char *Test, /* Test name */ + long N, /* Number of replications */ + int k, /* Sample size n = 2^k */ + int r, /* r first bits of each random number dropped */ + int s /* s bits of each random number used */ +) +{ + long n; + n = num_TwoExp[k]; + swrite_Head (gen, Test, N, n, r); + printf (", s = %4d, k = %4d\n\n", s, k); +} + + +/*-------------------------------------------------------------------------*/ + +static long LZ78 (unif01_Gen * gen, long n, int r, int s) +/* + * The parameters are the same as in scomp_LempelZiv. The trie contains + * a left (right) branch if a word with a 0 (1) bit after the prefix has + * been seen before. We descend one level in the trie with each bit until + * a leaf is met. Add a branch for a new word, and restart at root. + */ +{ + const unsigned long kMAX = 1UL << (s - 1); + unsigned long Y, k; + long i; /* Count the number of bits overall */ + long W; /* Count the number of words */ + lebool done = FALSE; /* Start a new word */ + BitTrie_t *trie, *root; + + W = i = 0; + trie = root = util_Malloc (sizeof (BitTrie_t)); + trie->left = trie->right = NULL; + Y = unif01_StripB (gen, r, s); + k = kMAX; + + while (i < n) { + /* Start a new word: match it as far as possible in the trie */ + done = FALSE; + trie = root; + while (!done) { + if ((Y & k) == 0) { /* Bit 0 */ + if (trie->left) { + /* We have seen it before: descend in branch */ + trie = trie->left; + } else { + /* A leaf: this is a new word */ + W++; + done = TRUE; + trie->left = util_Malloc (sizeof (BitTrie_t)); + trie = trie->left; + trie->left = trie->right = NULL; + } + + } else { /* Bit 1 */ + if (trie->right) { + trie = trie->right; + } else { + W++; + done = TRUE; + trie->right = util_Malloc (sizeof (BitTrie_t)); + trie = trie->right; + trie->left = trie->right = NULL; + } + } + i++; + if (i >= n) { + done = TRUE; + if ((trie->left != NULL) || (trie->right != NULL)) + W++; + break; + } + k >>= 1; + if (k == 0) { + /* Have used the s bits in the number; generate a new number */ + Y = unif01_StripB (gen, r, s); + k = kMAX; + } + } + } + DeleteBitTrie (root); + return W; +} + + +/*-------------------------------------------------------------------------*/ + +void scomp_LempelZiv (unif01_Gen *gen, sres_Basic *res, + long N, int t, int r, int s) +{ + long Seq, n; + double X; + /* const double lg_n = num_Log2 ((double) n); */ + long W; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "scomp_LempelZiv test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataLZ (gen, TestName, N, t, r, s); + util_Assert (r + s <= 32, "scomp_LempelZiv: r + s > 32"); + util_Assert (t <= 28, "scomp_LempelZiv: k > 28"); + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + n = num_TwoExp[t]; + sres_InitBasic (res, N, "scomp_LempelZiv"); + statcoll_SetDesc (res->sVal1, "sVal1: a standard normal"); + + for (Seq = 1; Seq <= N; Seq++) { + W = LZ78 (gen, n, r, s); + /* X = (W - n / lg_n) / sqrt (0.266 * n / (lg_n * lg_n * lg_n)); */ + X = (W - LZMu[t]) / LZSigma[t]; + statcoll_AddObs (res->sVal1, X); + if (swrite_Counters) { + printf ("%12ld ", W); + if (Seq % 5 == 0) + printf ("\n"); + if (Seq >= N) + printf ("\n\n"); + } + } + + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetNormalSumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 12, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} diff --git a/cbits/testu/src/sknuth.c b/cbits/testu/src/sknuth.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/sknuth.c @@ -0,0 +1,1159 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: sknuth.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "tables.h" +#include "chrono.h" +#include "num2.h" + +#include "sknuth.h" +#include "sres.h" +#include "smultin.h" +#include "wdist.h" +#include "swrite.h" +#include "unif01.h" + +#include "gofs.h" +#include "gofw.h" + +#include +#include + + +#define LENGTH 200 + + + + +/*-------------------------------- Functions ------------------------------*/ + + +static void InitRes1 ( + sknuth_Res1 *res, /* Results holder */ + long N, /* Number of replications */ + int d /* Max class index for chi2 */ +) +/* + * Initializes the sknuth_Res structure + */ +{ + sres_InitBasic (res->Bas, N, "sknuth_MaxOft: Anderson-Darling"); + sres_InitChi2 (res->Chi, N, d, "sknuth_MaxOft: Chi2"); +} + + +/*-------------------------------------------------------------------------*/ + +sknuth_Res1 * sknuth_CreateRes1 (void) +{ + sknuth_Res1 *res; + res = util_Malloc (sizeof (sknuth_Res1)); + res->Bas = sres_CreateBasic (); + res->Chi = sres_CreateChi2 (); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_DeleteRes1 (sknuth_Res1 *res) +{ + if (res == NULL) + return; + sres_DeleteBasic (res->Bas); + sres_DeleteChi2 (res->Chi); + util_Free (res); +} + + +/*=========================================================================*/ + +static void InitRes2 ( + sknuth_Res2 *res, /* Results holder */ + long N, /* Number of replications */ + double Lambda, /* Poisson mean */ + char *nam /* Test name */ +) +/* + * Initializes res + */ +{ + sres_InitBasic (res->Bas, N, nam); + sres_InitPoisson (res->Pois, N, Lambda, nam); +} + + +/*-------------------------------------------------------------------------*/ + +sknuth_Res2 * sknuth_CreateRes2 (void) +{ + sknuth_Res2 *res; + res = util_Malloc (sizeof (sknuth_Res2)); + res->Bas = sres_CreateBasic (); + res->Pois = sres_CreatePoisson (); + res->Pois->pLeft = -1.0; + res->Pois->pRight = -1.0; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_DeleteRes2 (sknuth_Res2 *res) +{ + if (res == NULL) + return; + sres_DeleteBasic (res->Bas); + sres_DeletePoisson (res->Pois); + util_Free (res); +} + + +/*=========================================================================*/ + +void sknuth_Serial (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, long d, int t) +{ + double ValDelta[] = { 1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test sknuth_Serial calling smultin_Multinomial\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, 3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, d, t, FALSE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, d, t, FALSE); + sres_InitChi2 (res, N, -1, "sknuth_Serial"); + statcoll_SetDesc (res->sVal1, "Serial sVal1"); + res->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->sVal1->V, 1, N); + tables_CopyTabD (resm->sVal2[0], res->sVal2, 0, gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->pVal2, 0, gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +void sknuth_SerialSparse (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, long d, int t) +{ + double ValDelta[] = { 1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test sknuth_SerialSparse calling smultin_Multinomial\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, 3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, d, t, TRUE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, d, t, TRUE); + sres_InitChi2 (res, N, -1, "sknuth_SerialSparse"); + statcoll_SetDesc (res->sVal1, "Serial sVal1"); + res->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->sVal1->V, 1, N); + tables_CopyTabD (resm->sVal2[0], res->sVal2, 0, gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->pVal2, 0, gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +static void WriteDataGap (unif01_Gen *gen, char *TestName, + long N, long n, int r, double Alpha, double Beta) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", Alpha = %8.6g, Beta = %8.6g\n\n", Alpha, Beta); +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_Gap (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, double Alpha, double Beta) +{ + int len; + int t; + long m; /* Number of observed Gaps */ + long Seq; /* Current replication number */ + double p; /* Probability of U01 in (Alpha, Beta) */ + double X2; + double U; + double Mult; + double V[1]; /* Number of degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_Gap test"; + + Timer = chrono_Create (); + p = Beta - Alpha; + t = log (gofs_MinExpected / n) / num2_log1p (-p); + len = 1 + log (gofs_MinExpected / (n*p)) / num2_log1p (-p); + t = util_Min(t, len); + t = util_Max(t, 0); + + Mult = p * n; + if (swrite_Basic) + WriteDataGap (gen, TestName, N, n, r, Alpha, Beta); + + util_Assert (Alpha >= 0.0 && Alpha <= 1.0, + "sknuth_Gap: Alpha outside interval [0..1]"); + util_Assert (Beta <= 1.0 && Beta > Alpha, + "sknuth_Gap: Beta outside interval (Alpha..1]"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, t, "sknuth_Gap"); + + sprintf (str, "The N statistic values (a ChiSquare with %1d degrees" + " of freedom):", t); + statcoll_SetDesc (res->sVal1, str); + res->degFree = t; + if (res->degFree < 1) { + util_Warning (TRUE, "Chi-square with 0 degree of freedom."); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); + return; + } + + /* Compute the probabilities for each gap length */ + res->NbExp[0] = Mult; + res->Loc[0] = 0; + for (len = 1; len < t; len++) { + Mult *= 1.0 - p; + res->NbExp[len] = Mult; + res->Loc[len] = len; + } + res->NbExp[t] = Mult * (1.0 - p) / p; + res->Loc[t] = t; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, res->Count, 0, t, 0); + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + for (len = 0; len <= t; len++) + res->Count[len] = 0; + for (m = 1; m <= n; m++) { + /* Process one gap */ + len = 0; + U = unif01_StripD (gen, r); + while ((U < Alpha || U >= Beta) && len < n) { + ++len; + U = unif01_StripD (gen, r); + } + if (len >= n) { + util_Warning (TRUE, + "sknuth_Gap: one gap of length > n\n********* Interrupting the test\n"); + printf ("\n\n"); + res->pVal2[gofw_Mean] = res->pVal2[gofw_AD] + = res->pVal2[gofw_KSM] = res->pVal2[gofw_KSP] = 0.0; + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); + return; + } + if (len >= t) + ++res->Count[t]; + else + ++res->Count[len]; + } + if (swrite_Counters) + tables_WriteTabL (res->Count, 0, t, 5, 10, "Observed numbers:"); + + X2 = gofs_Chi2 (res->NbExp, res->Count, 0, t); + statcoll_AddObs (res->sVal1, X2); + } + + V[0] = t; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataPoker (unif01_Gen * gen, char *TestName, + long N, long n, int r, int d, int k) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", d = %4d, k = %4d\n\n", d, k); +} + + +/*-------------------------------------------------------------------------*/ + +#define Maxkd 127 + +void sknuth_SimpPoker (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, int d, int k) +{ + long Seq; /* Replication number */ + long NbGroups; /* Number of classes */ + long jhigh; + long jlow; + long Groupe; + long L; + int Minkd; + int s, j; + double X2; + double Mult; + double *NbExp; + long *Loca; + long *Nb; + lebool Occurs[1 + Maxkd]; + double **M; + double V[1]; /* Number degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_SimpPoker test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataPoker (gen, TestName, N, n, r, d, k); + + util_Assert (d <= Maxkd, "sknuth_SimpPoker: d > 127"); + util_Assert (k <= Maxkd, "sknuth_SimpPoker: k > 127"); + util_Assert (d > 1, "sknuth_SimpPoker: d < 2"); + util_Assert (k > 1, "sknuth_SimpPoker: k < 2"); + if (k < d) + Minkd = k; + else + Minkd = d; + + num2_CalcMatStirling (&M, Minkd, k); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, Minkd, "sknuth_SimpPoker"); + NbExp = res->NbExp; + Nb = res->Count; + Loca = res->Loc; + + /* NbExp[s] = n * d * (d-1) * ... * (d-s+1) * M [s,k] / d^k. */ + Mult = n * pow ((double) d, -(double) k); + for (s = 1; s <= Minkd; s++) { + Mult *= d - s + 1; + NbExp[s] = Mult * M[s][k]; + } + jlow = 1; + jhigh = Minkd; + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, 0); + gofs_MergeClasses (NbExp, Loca, &jlow, &jhigh, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, NbGroups); + res->jmin = jlow; + res->jmax = jhigh; + res->degFree = NbGroups - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + for (Seq = 1; Seq <= N; Seq++) { + for (s = 1; s <= Minkd; s++) + Nb[s] = 0; + for (Groupe = 1; Groupe <= n; Groupe++) { + /* Draw one poker hand */ + for (j = 0; j < d; j++) + Occurs[j] = FALSE; + s = 0; /* s = number of different values */ + for (j = 1; j <= k; j++) { + L = unif01_StripL (gen, r, d); + if (!Occurs[L]) { + Occurs[L] = TRUE; + ++s; + } + } + ++Nb[Loca[s]]; + } + if (swrite_Counters) + tables_WriteTabL (Nb, jlow, jhigh, 5, 10, "Observed numbers:"); + + X2 = gofs_Chi2 (NbExp, Nb, jlow, jhigh); + statcoll_AddObs (res->sVal1, X2); + } + + V[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) { + statcoll_Write (res->sVal1, 5, 14, 4, 3); + } + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + num2_FreeMatStirling (&M, Minkd); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +#define MAXT 62 + +static void WriteDataCoupCol (unif01_Gen *gen, char *TestName, + long N, long n, int r, int d) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", d = %4d\n\n", d); +} + + +/*-------------------------------------------------------------------------*/ + +static long NRepet ( + unif01_Gen *gen, + int dInt, /* d */ + int r, + lebool Occurs[] + ) +/* + * Used by CouponCollector. Counts the number of values generated before + * each possible value of d appears at least once. + */ +{ + int u, j; + int s = 0; + + for (j = 1; j <= dInt; j++) { + do { + ++s; + if (s >= MAXT) + return MAXT; + u = unif01_StripL (gen, r, dInt); + } while (Occurs[u]); + Occurs[u] = TRUE; + } + /* j is the number of different values observed up to now */ + return s; +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_CouponCollector (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, int d) +{ + long Seq; /* Replication number */ + long Segm; + const int t = MAXT; + long tt = t; + int dInt = d; + long dd = d; + int s, k; + long NbGroups; + double Moydes; + double Mult; + double dReal = d; + double **M; + double *NbExp; + long *Loca; + long *Nb; + lebool Occurs[1 + MAXT]; + double X2; + double V[1]; /* Number degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_CouponCollector test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataCoupCol (gen, TestName, N, n, r, d); + + util_Assert (d < MAXT, "sknuth_CouponCollector: d >= 62"); + util_Assert (d > 1, "sknuth_CouponCollector: d < 2"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, MAXT, "sknuth_CouponCollector"); + NbExp = res->NbExp; + Nb = res->Count; + Loca = res->Loc; + + /* Compute the expected number of segments of each length */ + /* NbExp [s] = n * d! * Stirling (d-1, s-1) / d^s for d <= s <= t - 1 */ + /* NbExp [t] = n * (1 - d! * Stirling (d, t-1) / d^{t-1}) */ + dInt = d; + num2_CalcMatStirling (&M, d, t - 1); + Mult = n; + for (s = 1; s <= d; s++) { + Mult *= s / dReal; + } + NbExp[d] = Mult; + Moydes = d * Mult; + for (s = d + 1; s < t; s++) { + Mult /= dReal; + NbExp[s] = Mult * M[d - 1][s - 1]; + Moydes += s * NbExp[s]; + } + NbExp[t] = n - Mult * M[d][t - 1]; + Moydes += t * NbExp[t]; + Moydes /= n; + /* + if (swrite_Basic) { + printf (" Expected value of s = "); + num_WriteD (Moydes, 10, 2, 2); + printf ("\n\n"); + } + */ + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, d, t, 0); + gofs_MergeClasses (NbExp, Loca, &dd, &tt, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, dd, tt, NbGroups); + res->jmin = dd; + res->jmax = tt; + res->degFree = NbGroups - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + for (s = dInt; s <= MAXT; s++) + Nb[s] = 0; + for (Segm = 1; Segm <= n; Segm++) { + /* One collection of values. */ + for (k = 0; k < dInt; k++) + Occurs[k] = FALSE; + ++Nb[Loca[NRepet (gen, dInt, r, Occurs)]]; + } + if (swrite_Counters) + tables_WriteTabL (Nb, dd, tt, 5, 10, "Observed numbers:"); + + X2 = gofs_Chi2 (NbExp, Nb, dd, tt); + statcoll_AddObs (res->sVal1, X2); + } + + V[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) { + statcoll_Write (res->sVal1, 5, 14, 4, 3); + } + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + num2_FreeMatStirling (&M, d); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void sknuth_Permutation (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, int t) +{ + double ValDelta[] = { 1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test sknuth_Permutation calling smultin_Multinomial\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellPermut, 3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, 1, t, FALSE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, 1, t, FALSE); + sres_InitChi2 (res, N, -1, "sknuth_Permutation"); + statcoll_SetDesc (res->sVal1, "Serial sVal1"); + res->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->sVal1->V, 1, N); + tables_CopyTabD (resm->sVal2[0], res->sVal2, 0, gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->pVal2, 0, gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +static void WriteDataRun (unif01_Gen * gen, char *TestName, + long N, long n, int r, lebool Up) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", Up = %5s\n\n", Up ? "TRUE" : "FALSE"); +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_Run (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, lebool Up) +{ + long Seq; /* Replication number */ + double U; + double UPrec; /* Preceding value of U */ + double nReal = n; + double A[6][6]; + double B[6]; + double *NbExp; + long k; + int j, i; + long Longueur; /* Current length of the sequence */ + double Khi; + long *Count; + char str[LENGTH + 1]; + double V[1]; /* Number degrees of freedom for Chi2 */ + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_Run test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataRun (gen, TestName, N, n, r, Up); + + if (n < 600) + return; + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, 6, "sknuth_Run"); + NbExp = res->NbExp; + Count = res->Count; + res->jmin = 1; + res->jmax = 6; + + A[0][0] = 4529.35365; + A[0][1] = 9044.90208; + A[0][2] = 13567.9452; + A[0][3] = 18091.2672; + A[0][4] = 22614.7139; + A[0][5] = 27892.1588; + A[1][1] = 18097.0254; + A[1][2] = 27139.4552; + A[1][3] = 36186.6493; + A[1][4] = 45233.8198; + A[1][5] = 55788.8311; + A[2][2] = 40721.3320; + A[2][3] = 54281.2656; + A[2][4] = 67852.0446; + A[2][5] = 83684.5705; + A[3][3] = 72413.6082; + A[3][4] = 90470.0789; + A[3][5] = 111580.110; + A[4][4] = 113261.815; + A[4][5] = 139475.555; + A[5][5] = 172860.170; + + for (i = 2; i <= 6; i++) { + for (j = 1; j < i; j++) + A[i - 1][j - 1] = A[j - 1][i - 1]; + } + + B[0] = 1.0 / 6.0; + B[1] = 5.0 / 24.0; + B[2] = 11.0 / 120.0; + B[3] = 19.0 / 720.0; + B[4] = 29.0 / 5040.0; + B[5] = 1.0 / 840.0; + for (i = 1; i <= 6; i++) { + NbExp[i] = nReal * B[i - 1]; + res->Loc[i] = i; + } + + if (swrite_Classes) + /* gofs_Classes (NbExp, NULL, 1, 6, 0); */ + tables_WriteTabD (NbExp, 1, 6, 1, 20, 2, 1, "Expected numbers:"); + + statcoll_SetDesc (res->sVal1, + "The N statistic values (a ChiSquare with 6 degrees of freedom):"); + res->degFree = 6; + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + for (i = 1; i <= 6; i++) + Count[i] = 0; + Longueur = 1; + UPrec = unif01_StripD (gen, r); + /* Generate n numbers */ + for (k = 1; k < n; k++) { + U = unif01_StripD (gen, r); + if ((Up && U < UPrec) || (!Up && U > UPrec)) { + /* The end of a "Run" */ + ++Count[Longueur]; + Longueur = 1; + } else if (Longueur < 6) + ++Longueur; + UPrec = U; + } + ++Count[Longueur]; + + if (swrite_Counters) + tables_WriteTabL (Count, 1, 6, 5, 10, "Observed numbers:"); + + /* Compute modified Chi2 for a sequence */ + Khi = 0.0; + for (i = 1; i <= 6; i++) { + for (j = 1; j <= 6; j++) { + Khi += A[i-1][j-1]*(Count[i] - NbExp[i])*(Count[j] - NbExp[j]); + } + } + statcoll_AddObs (res->sVal1, Khi / (nReal - 6.0)); + } + + V[0] = 6; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void sknuth_RunIndep (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, lebool Up) +{ + long Seq; /* Replication number */ + double U; + double UPrec; /* Preceding value of U */ + double X2; + long Nb; + long k; + int i; + long Longueur; /* Current length of the sequence */ + long *Count; + double *NbExp; + double Prob[7]; + char str[LENGTH + 1]; + double V[1]; /* Number degrees of freedom for Chi2 */ + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_RunIndep test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataRun (gen, TestName, N, n, r, Up); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, 6, "sknuth_RunIndep"); + NbExp = res->NbExp; + Count = res->Count; + res->jmin = 1; + res->jmax = 6; + sprintf (str, "NumExpected[6] < %.1f", gofs_MinExpected); + + for (i = 1; i <= 5; i++) { + Prob[i] = 1.0 / num2_Factorial (i) - 1.0 / num2_Factorial (i + 1); + } + Prob[6] = 1.0 / num2_Factorial (6); + + statcoll_SetDesc (res->sVal1, + "The N statistic values (a ChiSquare with 5 degrees of freedom):"); + res->degFree = 5; + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 1; i <= 6; i++) + Count[i] = 0; + Longueur = 1; + UPrec = unif01_StripD (gen, r); + for (k = 1; k <= n; k++) { + U = unif01_StripD (gen, r); + if ((Up && U < UPrec) || (!Up && U > UPrec)) { + /* The end of a "Run" */ + ++Count[Longueur]; + Longueur = 1; + U = unif01_StripD (gen, r); + } else if (Longueur < 6) + ++Longueur; + UPrec = U; + } + ++Count[Longueur]; + + Nb = 0; + for (i = 1; i <= 6; i++) + Nb += Count[i]; + for (i = 1; i <= 6; i++) + NbExp[i] = Nb * Prob[i]; + + if (swrite_Counters) { + tables_WriteTabD (NbExp, 1, 6, 1, 20, 2, 1, "Expected numbers:"); + tables_WriteTabL (Count, 1, 6, 1, 17, "Observed numbers:"); + } + /* util_Warning (NbExp[6] < gofs_MinExpected, str); */ + + X2 = gofs_Chi2 (NbExp, Count, 1, 6); + statcoll_AddObs (res->sVal1, X2); + } + + V[0] = 5; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataMaxOft (unif01_Gen * gen, char *TestName, + long N, long n, int r, int d, int t, double NbExp) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", d = %4d, t = %2d\n\n", d, t); + printf (" Number of categories = %d\n", d); + printf (" Expected number per category = %.2f\n\n", NbExp); +} + + +/*-------------------------------------------------------------------------*/ + +static double FDistMax ( + double Par[], /* The parameter t = Par[0] */ + double x /* The argument */ + ) +/* + * Distribution function for the maximum of t random variables U01 = x^t + */ +{ + /* double Prod; + int j; + const int t = Par[0] + 0.5; + */ + if (x >= 1.0) + return 1.0; + if (x <= 0.0) + return 0.0; + return pow (x, Par[0]); + /* + Prod = x; + for (j = 1; j < t; j++) + Prod *= x; + return Prod; + */ +} + + +/*-------------------------------------------------------------------------*/ + +void sknuth_MaxOft (unif01_Gen * gen, sknuth_Res1 * res, + long N, long n, int r, int d, int t) +{ + long Seq; /* Replication number */ + double tReal = t; + double dReal = d; + double NbExp; /* Expected number in each class */ + double MaxU; + double U; + long Groupe; + int j, Indice; + double *P; + double Par[1]; + double X2; + double V[1]; /* Number degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sknuth_MaxOft test"; + sres_Basic *Bas; + sres_Chi2 *Chi; + + Timer = chrono_Create (); + Par[0] = t; + + NbExp = n / dReal; + if (swrite_Basic) + WriteDataMaxOft (gen, TestName, N, n, r, d, t, NbExp); + util_Assert (NbExp >= gofs_MinExpected, + "MaxOft: NbExp < gofs_MinExpected"); + if (res == NULL) { + localRes = TRUE; + res = sknuth_CreateRes1 (); + } + InitRes1 (res, N, d); + Bas = res->Bas; + Chi = res->Chi; + Chi->jmin = 0; + Chi->jmax = d - 1; + for (j = 0; j < d; j++) { + Chi->Loc[j] = j; + Chi->NbExp[j] = NbExp; + } + + sprintf (str, "The N statistic values (a ChiSquare with %1d degrees" + " of freedom):", d - 1); + statcoll_SetDesc (Chi->sVal1, str); + Chi->degFree = d - 1; + statcoll_SetDesc (Bas->sVal1, + "The N statistic values (the Anderson-Darling p-values):"); + P = util_Calloc ((size_t) n + 1, sizeof (double)); + + for (Seq = 1; Seq <= N; Seq++) { + for (Indice = 0; Indice < d; Indice++) + Chi->Count[Indice] = 0; + for (Groupe = 1; Groupe <= n; Groupe++) { + /* Generate a vector and find the max value */ + MaxU = unif01_StripD (gen, r); + for (j = 1; j < t; j++) { + U = unif01_StripD (gen, r); + if (U > MaxU) + MaxU = U; + } + /* For the chi2 */ + Indice = pow (MaxU, tReal) * dReal; + ++Chi->Count[Indice]; + + /* For the Anderson-Darling */ + P[Groupe] = MaxU; + } + if (swrite_Counters) + tables_WriteTabL (Chi->Count, 0, d - 1, 5, 10, "Observed numbers:"); + + /* Value of the chi2 statistic */ + X2 = gofs_Chi2Equal (NbExp, Chi->Count, 0, d - 1); + statcoll_AddObs (Chi->sVal1, X2); + + /* Value of the Anderson-Darling statistic */ + gofw_ActiveTests1 (P, n, FDistMax, Par, Bas->sVal2, Bas->pVal2); + statcoll_AddObs (Bas->sVal1, Bas->pVal2[gofw_AD]); + } + util_Free (P); + + V[0] = d - 1; + gofw_ActiveTests2 (Chi->sVal1->V, Chi->pVal1->V, N, wdist_ChiSquare, V, + Chi->sVal2, Chi->pVal2); + Chi->pVal1->NObs = N; + sres_GetChi2SumStat (Chi); + + gofw_ActiveTests2 (Bas->sVal1->V, Bas->pVal1->V, N, wdist_Unif, + (double *) NULL, Bas->sVal2, Bas->pVal2); + Bas->pVal1->NObs = N; + + if (swrite_Collectors) { + statcoll_Write (Chi->sVal1, 5, 14, 4, 3); + statcoll_Write (Bas->sVal1, 5, 14, 4, 3); + } + if (swrite_Basic) { + if (N == 1) { + swrite_AddStrChi (str, LENGTH, Chi->degFree); + gofw_WriteActiveTests2 (N, Chi->sVal2, Chi->pVal2, str); + } else { + printf ("\n-----------------------------------------------\n"); + printf ("Test results for chi2 with %2ld degrees of freedom:\n", + Chi->degFree); + gofw_WriteActiveTests0 (N, Chi->sVal2, Chi->pVal2); + swrite_Chi2SumTest (N, Chi); + } + + if (N == 1) { + gofw_WriteActiveTests2 (N, Bas->sVal2, Bas->pVal2, + "Anderson-Darling statistic :"); + } else { + printf ("\n-----------------------------------------------\n"); + printf ("Test results for Anderson-Darling:\n"); + gofw_WriteActiveTests0 (N, Bas->sVal2, Bas->pVal2); + } + printf ("\n"); + swrite_Final (gen, Timer); + } + if (localRes) + sknuth_DeleteRes1 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void sknuth_Collision (unif01_Gen * gen, sknuth_Res2 * res, + long N, long n, int r, long d, int t) +{ + double ValDelta[] = { -1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test sknuth_Collision calling smultin_Multinomial\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, -3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, d, t, TRUE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, d, t, TRUE); + InitRes2 (res, N, resm->Mu[0], "sknuth_Collision"); + statcoll_SetDesc (res->Bas->sVal1, "Collision sVal1"); + statcoll_SetDesc (res->Pois->sVal1, "Collision sVal1"); + res->Pois->sVal1->NObs = resm->Collector[0]->NObs; + res->Bas->sVal1->NObs = resm->Collector[0]->NObs; + res->Pois->pLeft = resm->pCollLeft; + res->Pois->pRight = resm->pCollRight; + tables_CopyTabD (resm->Collector[0]->V, res->Bas->sVal1->V, 1, N); + tables_CopyTabD (resm->Collector[0]->V, res->Pois->sVal1->V, 1, N); + res->Pois->pVal2 = resm->pColl; + res->Pois->sVal2 = resm->NbCollisions; + tables_CopyTabD (resm->sVal2[0], res->Bas->sVal2, 0, + gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->Bas->pVal2, 0, + gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +void sknuth_CollisionPermut (unif01_Gen * gen, sknuth_Res2 * res, + long N, long n, int r, int t) +{ + double ValDelta[] = { -1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test sknuth_CollisionPermut calling smultin_Multinomial\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellPermut, -3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, 0, t, TRUE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, 0, t, TRUE); + InitRes2 (res, N, resm->Mu[0], "sknuth_CollisionPermut"); + statcoll_SetDesc (res->Bas->sVal1, "CollisionPermut sVal1"); + statcoll_SetDesc (res->Pois->sVal1, "CollisionPermut sVal1"); + res->Pois->pLeft = resm->pCollLeft; + res->Pois->pRight = resm->pCollRight; + res->Pois->sVal1->NObs = resm->Collector[0]->NObs; + res->Bas->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->Bas->sVal1->V, 1, N); + tables_CopyTabD (resm->Collector[0]->V, res->Pois->sVal1->V, 1, N); + res->Pois->pVal2 = resm->pColl; + res->Pois->sVal2 = resm->NbCollisions; + tables_CopyTabD (resm->sVal2[0], res->Bas->sVal2, 0, + gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->Bas->pVal2, 0, + gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} diff --git a/cbits/testu/src/smarsa.c b/cbits/testu/src/smarsa.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/smarsa.c @@ -0,0 +1,1664 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: smarsa.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "gdef.h" +#include "util.h" +#include "tables.h" +#include "chrono.h" +#include "num.h" + +#include "smarsa.h" +#include "smultin.h" +#include "wdist.h" +#include "swrite.h" +#include "unif01.h" + +#include "vectorsF2.h" + +#include "gofs.h" +#include "gofw.h" +#include "fdist.h" +#include "fbar.h" +#include "fmass.h" +#include "statcoll.h" + +#include +#include +#include + + +#define LENGTH 200 + +/* MAXK = 2^64 */ +#define STR_MAXK "18446744073709551616" + + + +/*---------------------------- Extern variables ---------------------------*/ + +#ifdef USE_LONGLONG +double smarsa_Maxk = 18446744073709551616.0; /* 2^64 */ +#else +double smarsa_Maxk = num_MaxIntDouble; /* 2^53 */ +#endif + + + + +/*------------------------------- Functions -------------------------------*/ + +static void WriteResultsPoisson (sres_Poisson *res, long N) +{ + printf ("\n----------------------------------------------------" + "\nTotal expected number = N*Lambda : "); + num_WriteD (N * res->Lambda, 10, 2, 2); + printf ("\nTotal observed number : %7ld\n", + (long) res->sVal2); + gofw_Writep1 (res->pVal2); + printf ("\n"); +} + + +/*=========================================================================*/ + +static void InitRes ( + smarsa_Res *res, /* Results holder */ + long N, /* Number of replications */ + double Lambda, /* Poisson mean */ + char *nam /* Test name */ +) +/* + * Initializes res + */ +{ + sres_InitBasic (res->Bas, N, nam); + sres_InitPoisson (res->Pois, N, Lambda, nam); +} + + +/*-------------------------------------------------------------------------*/ + +smarsa_Res * smarsa_CreateRes (void) +{ + smarsa_Res *res; + res = util_Malloc (sizeof (smarsa_Res)); + res->Bas = sres_CreateBasic (); + res->Pois = sres_CreatePoisson (); + res->Pois->pLeft = -1.0; + res->Pois->pRight = -1.0; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_DeleteRes (smarsa_Res *res) +{ + if (res == NULL) + return; + sres_DeleteBasic (res->Bas); + sres_DeletePoisson (res->Pois); + util_Free (res); +} + + +/*=========================================================================*/ + +static void InitRes2 ( + smarsa_Res2 *res, /* Results holder */ + long N, /* Number of replications */ + int jmax, /* Max class index for GCD */ + int tmax /* Max class index for NumIter */ +) +/* + * Initializes the smarsa_Res2 structure + */ +{ + sres_InitChi2 (res->GCD, N, jmax, "smarsa_GCD: GCD"); + sres_InitChi2 (res->NumIter, N, tmax, "smarsa_GCD: NumIter"); +} + + +/*-------------------------------------------------------------------------*/ + +smarsa_Res2 *smarsa_CreateRes2 (void) +{ + smarsa_Res2 *res; + res = util_Malloc (sizeof (smarsa_Res2)); + res->GCD = sres_CreateChi2 (); + res->NumIter = sres_CreateChi2 (); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_DeleteRes2 (smarsa_Res2 *res) +{ + if (res == NULL) + return; + sres_DeleteChi2 (res->GCD); + sres_DeleteChi2 (res->NumIter); + util_Free (res); +} + + +/*=========================================================================*/ + +void smarsa_SerialOver (unif01_Gen *gen, sres_Basic *res, + long N, long n, int r, long d, int t) +{ + double ValDelta[] = { 1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test smarsa_SerialOver calling smultin_MultinomialOver\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, 0); + if (NULL == res) { + smultin_MultinomialOver (gen, par, NULL, N, n, r, d, t, FALSE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_MultinomialOver (gen, par, resm, N, n, r, d, t, FALSE); + sres_InitBasic (res, N, "smarsa_SerialOver"); + statcoll_SetDesc (res->sVal1, "SerialOver sVal1"); + res->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->sVal1->V, 1, N); + tables_CopyTabD (resm->sVal2[0], res->sVal2, 0, gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->pVal2, 0, gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +void smarsa_CollisionOver (unif01_Gen *gen, smarsa_Res *res, + long N, long n, int r, long d, int t) +{ + double ValDelta[] = { -1.0 }; + smultin_Param *par; + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test smarsa_CollisionOver calling smultin_MultinomialOver\n\n"); + + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellSerial, 3); + if (NULL == res) { + smultin_MultinomialOver (gen, par, NULL, N, n, r, d, t, TRUE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_MultinomialOver (gen, par, resm, N, n, r, d, t, TRUE); + InitRes (res, N, resm->Mu[0], "smarsa_CollisionOver"); + statcoll_SetDesc (res->Bas->sVal1, "CollisionOver sVal1"); + statcoll_SetDesc (res->Pois->sVal1, "CollisionOver sVal1"); + res->Pois->sVal1->NObs = resm->Collector[0]->NObs; + res->Bas->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->Bas->sVal1->V, 1, N); + tables_CopyTabD (resm->Collector[0]->V, res->Pois->sVal1->V, 1, N); + res->Pois->pVal2 = resm->pColl; + if (resm->CollApprox == smultin_CollPoissonSparse) + res->Pois->sVal2 = resm->NbCollisions; + else + res->Pois->sVal2 = resm->NbCells[0]; + tables_CopyTabD (resm->sVal2[0], res->Bas->sVal2, 0, + gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->Bas->pVal2, 0, + gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); +} + + +/*=========================================================================*/ + +void smarsa_Opso (unif01_Gen * gen, smarsa_Res * res, long N, int r, int p) +{ + int d; + long NBalls; + + switch (p) { + case 1: + NBalls = 2097152; + d = 1024; + break; + case 2: + NBalls = 4194304; + d = 2048; + break; + case 3: + NBalls = 8388608; + d = 2048; + break; + default: + util_Error ("smarsa_Opso: p must be in {1, 2, 3}"); + } + + if (swrite_Basic) + printf ("***********************************************************\n" + "Test smarsa_Opso calling smarsa_CollisionOver\n\n"); + smarsa_CollisionOver (gen, res, N, NBalls, r, d, 2); +} + + +/*=========================================================================*/ +/* + * The CPU time needed for BirthdaySpacings is 6 times longer when I used + * the standard function qsort of stdlib.h. Thus we use our own QuickSort. + */ + +#undef QSORT +#ifdef QSORT +static int compareD (const void *p0, const void *q0) +{ + double x = *((const double *) p0); + double y = *((const double *) q0); + return (x < y) ? -1 : (x > y) ? 1 : 0; +} +/* qsort ((void *)(DatDiff + 1), (size_t) n, sizeof (double), compareD); */ +#endif + + +/*=========================================================================*/ + +static void WriteDataBirth (unif01_Gen * gen, char *TestName, long N, long n, + int r, long d, int t, int p, double k, smultin_CellType kc, + double Lambda) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", d = %1ld, t = %1d, p = %1d\n\n", d, t, p); +#ifdef USE_LONGLONG + if (kc == 0 && d > 1) /* kc = 2^64 */ + printf ("\n Number of cells = d^t = " STR_MAXK "\n"); + else + printf ("\n Number of cells = d^t = %18" PRIuLEAST64 "\n", kc); +#else + printf ("\n Number of cells = d^t = %16.0f\n", k); +#endif + printf (" Lambda = Poisson mean = "); + num_WriteD (Lambda, 12, 4, 2); + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_BirthdaySpacings (unif01_Gen *gen, sres_Poisson *res, + long N, long n, int r, long d, int t, int Order) +{ + long Seq; /* Replication number */ + long j; + long Sum; + double Y; /* Number of collisions */ + double k; + smultin_CellType kc; + double Lambda; /* Poisson mean */ + smultin_CellType *Dates, *DatDiff; + fmass_INFO Mass; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_BirthdaySpacings test"; + + Timer = chrono_Create (); + kc = k = d; + for (j = 2; j <= t; j++) { + k *= d; + kc *= d; + } + Lambda = (double) n * n / k * (n / 4.0); + + if (swrite_Basic) + WriteDataBirth (gen, TestName, N, n, r, d, t, Order, k, kc, Lambda); + + if (d <= 1) { + util_Warning (TRUE, + "smarsa_BirthdaySpacings: d <= 1. The test is not done."); + return; + } + if (k > smarsa_Maxk) { + util_Warning (TRUE, + "smarsa_BirthdaySpacings: d^t > smarsa_Maxk. The test is not done."); + return; + } + if (8.0 * N * Lambda > sqrt (sqrt (k))) { + util_Warning (TRUE, + "smarsa_BirthdaySpacings: 8N Lambda > k^(1/4). The test is not done."); + return; + } + if (res == NULL) { + localRes = TRUE; + res = sres_CreatePoisson (); + } + sres_InitPoisson (res, N, Lambda, "smarsa_BirthdaySpacings"); + + Dates = util_Calloc (1 + (size_t) n, sizeof (smultin_CellType)); + DatDiff = util_Calloc (1 + (size_t) n, sizeof (smultin_CellType)); + + sprintf (str, "The N statistic values (a Poisson with mean %g):", Lambda); + statcoll_SetDesc (res->sVal1, str); + + Sum = 0; + for (Seq = 1; Seq <= N; Seq++) { + /* Generate and sort the "birth dates" */ + if (Order == 2) { + for (j = 1; j <= n; j++) { + Dates[j] = smultin_GenerCellSerial2 (gen, r, t, d); + } + } else { + for (j = 1; j <= n; j++) { + Dates[j] = smultin_GenerCellSerial (gen, r, t, d); + } + } +#ifdef USE_LONGLONG + tables_QuickSortULL (Dates, 1, n); + /* Compute the differences between adjacent dates */ + gofs_DiffULL (Dates, DatDiff, 1, n, 0ULL, 1ULL); + /* The last cell is a special case */ + DatDiff[n] = kc - Dates[n] + Dates[1]; + tables_QuickSortULL (DatDiff, 1, n); +#else + tables_QuickSortD (Dates, 1, n); + /* Compute the differences between adjacent dates */ + gofs_DiffD (Dates, DatDiff, 1, n, 0.0, 1.0); + /* The last cell is a special case */ + DatDiff[n] = kc - Dates[n] + Dates[1]; + tables_QuickSortD (DatDiff, 1, n); +#endif + + /* Count the number of collisions in DatDiff */ + Y = 0.0; + for (j = 2; j <= n; j++) { + if (DatDiff[j] == DatDiff[j - 1]) + Y += 1.0; + } + Sum += Y; + statcoll_AddObs (res->sVal1, Y); + if (swrite_Counters) { +#ifdef USE_LONGLONG + tables_WriteTabULL (Dates, 1, n, 3, 21, "Birthdates:"); + tables_WriteTabULL (DatDiff, 1, n, 3, 21, "Birthdate differences:"); +#else + tables_WriteTabD (Dates, 1, n, 4, 17, 0, 0, "Birthdates:"); + tables_WriteTabD (DatDiff, 1, n, 4, 17, 0, 0, + "Birthdate differences:"); +#endif + } + } + + res->sVal2 = Sum; + Mass = fmass_CreatePoisson (N * Lambda); + res->pLeft = fdist_Poisson2 (Mass, Sum); + res->pRight = fbar_Poisson2 (Mass, Sum); + fmass_DeletePoisson (Mass); + res->pVal2 = gofw_pDisc (res->pLeft, res->pRight); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 1, 1); + if (swrite_Basic) { + WriteResultsPoisson (res, N); + swrite_Final (gen, Timer); + } + util_Free (Dates); + util_Free (DatDiff); + if (localRes) + sres_DeletePoisson (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataCAT (unif01_Gen *gen, char *TestName, + long N, long n, int r, long d, int t, long S[], double Lambda) +{ + int i; + swrite_Head (gen, TestName, N, n, r); + printf (", d = %1ld, t = %1d\n\n", d, t); + for (i = 0; i < t; i++) { + printf (" S[%1d] = %1ld\n", i, S[i]); + } + printf ("\n Lambda = Poisson mean = "); + num_WriteD (Lambda, 12, 4, 2); + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static void TestCATData (long d, int t, long S1[]) +/* + * Test that the key to search for has no overlap, that is cannot be + * written as ABA, where A and B are parts of the key. + */ +{ + int i, j, s; + long k1, k2; + i = 0; + j = t - 1; + k1 = k2 = 0; + while (i < j) { + k1 = k1 * d + S1[i]; + k2 = 0; + for (s = j; s < t; s++) + k2 = k2 * d + S1[s]; + util_Assert (k1 != k2, + "CATData: target cell number of the form ABA"); + i++; + j--; + } +} + + +/*-------------------------------------------------------------------------*/ +#if 0 +static void CATGenere1 ( + unif01_Gen *gen, + long n, /* Number of points */ + int r, /* Drop the first r bits of each U01 */ + long d, /* Number of segments on the 1-dim. line */ + int t, /* Dimension */ + long Key, /* Key to search for */ + long k1, /* = d^(t-1) */ + long *Count /* Number of times Key appears */ + ) +/* + * Generate the n points in the dense case and count the number of times + * cell Key appears. This is the circular version with n points. It also + * correspond to the case of aperiodic Key. + */ +{ + int j, i; + long Indice = 0; + long Y = 0; /* Counter */ + long Premier[32]; + + util_Assert (t <= 32, "smarsa_CAT.Genere: t > 32"); + + /* Generation of the first (t - 1) elements of the first tuple */ + for (j = 1; j < t; j++) { + Premier[j] = unif01_StripL (gen, r, d); + Indice = Indice * d + Premier[j]; + } + + /* Generation of the n - (tt - 1) tuples */ + for (j = 1; j <= n - (t - 1); j++) { + /* Remove the leftmost component ... */ + Indice %= k1; + /* ... shift and get another for the rightmost one */ + Indice = Indice * d + unif01_StripL (gen, r, d); + if (Indice == Key) { + ++Y; + /* Key found: jump over the whole Indice and restart */ + Indice = 0; + for (i = 1; i < t; i++) { + Indice = Indice * d + unif01_StripL (gen, r, d); + j++; + } + } + } + + /* Generation of the last (t - 1) tuples. We use numbers in array */ + /* Premier[] so that the sequence is in fact circular */ + for (j = 1; j < t; j++) { + Indice %= k1; + Indice = Indice * d + Premier[j]; + if (Indice == Key) + ++Y; + } + + *Count = Y; +} +#endif + +/*-------------------------------------------------------------------------*/ + +static void CATGenere ( + unif01_Gen *gen, + long n, /* Number of points */ + int r, /* Drop the first r bits of each U01 */ + long d, /* Number of segments on the 1-dim. line */ + int t, /* Dimension */ + long Key, /* Key to search for */ + long k1, /* = d^(t-1) */ + long *Count /* Number of times Key appears */ + ) +/* + * Generate the n points in the dense case and count the number of times + * cell Key appears. This is the non-circular version with n - t + 1 points. + * It also correspond to the case of aperiodic Key. + */ +{ + int j, i; + long Indice; + long Y = 0; /* Counter */ + + /* Generation of the first (t - 1) elements of the first tuple */ + Indice = 0; + for (j = 1; j < t; j++) + Indice = Indice * d + unif01_StripL (gen, r, d); + + /* Generation of the n - (tt - 1) tuples */ + for (j = 1; j <= n - (t - 1); j++) { + /* Remove the leftmost component ... */ + Indice %= k1; + /* ... shift and get another for the rightmost one */ + Indice = Indice * d + unif01_StripL (gen, r, d); + if (Indice == Key) { + ++Y; + /* Key found: jump over the whole Indice and restart */ + Indice = 0; + for (i = 1; i < t; i++) { + Indice = Indice * d + unif01_StripL (gen, r, d); + j++; + } + } + } + + *Count = Y; +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_CAT (unif01_Gen *gen, sres_Poisson *res, + long N, long n, int r, long d, int t, long S[]) +{ + long Seq; + long i; + double k; + long k1; /* d^(t-1) */ + long Key; /* Cell number to search for */ + double Lambda; /* Poisson mean */ + long Sum; + long Co; + fmass_INFO Mass; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_CAT test"; + + Timer = chrono_Create (); + k1 = d; + for (i = 2; i < t; i++) + k1 *= d; + k = k1 * d; + Lambda = (n - t + 1) / k; + if (swrite_Basic) + WriteDataCAT (gen, TestName, N, n, r, d, t, S, Lambda); + util_Assert (d > 1, "smarsa_CAT: d <= 1"); + + Key = 0; + for (i = 0; i < t; i++) { + if (S[i] < 0 || S[i] >= d) { + util_Error ("smarsa_CAT: S[i] must be in [0, d - 1]"); + } + Key = Key * d + S[i]; + } + TestCATData (d, t, S); + if (res == NULL) { + localRes = TRUE; + res = sres_CreatePoisson (); + } + sres_InitPoisson (res, N, Lambda, "smarsa_CAT"); + sprintf (str, "The N statistic values (a Poisson with mean %g):", Lambda); + statcoll_SetDesc (res->sVal1, str); + + Sum = 0; + for (Seq = 1; Seq <= N; Seq++) { + CATGenere (gen, n, r, d, t, Key, k1, &Co); + statcoll_AddObs (res->sVal1, (double) Co); + Sum += Co; + } + + res->sVal2 = Sum; + Mass = fmass_CreatePoisson (res->Mu); + res->pLeft = fdist_Poisson2 (Mass, Sum); + res->pRight = fbar_Poisson2 (Mass, Sum); + fmass_DeletePoisson (Mass); + res->pVal2 = gofw_pDisc (res->pLeft, res->pRight); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 1, 1); + if (swrite_Basic) { + WriteResultsPoisson (res, N); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeletePoisson (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataCATBits (unif01_Gen *gen, char *TestName, + long N, long n, int r, int s, int L, unsigned long Key, double Lambda) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, L = %1d, Key = %lu\n\n", s, L, Key); + printf (" Lambda = Poisson mean = "); + num_WriteD (Lambda, 12, 4, 2); + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static void TestCATBitsData (int L, unsigned long Key) +/* + * Test that the key to search for has no overlap, that is cannot be + * written as ABA, where A and B are parts of the key. + */ +{ + int i; + unsigned long mask = 1, shift = L - 1; + i = 0; + while (i < L / 2) { + if ((Key & mask) == (Key >> shift)) { + bitset_WriteSet ("Key = ", Key, L); + util_Error ("CATBitsData: Key of the form ABA"); + } + i++; + shift--; + mask = num_TwoExp[i + 1] - 1.0; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void CATGenerBits (unif01_Gen *gen, long n, int r, int s, + int L, unsigned long KEY0, long *Count) +{ +/* + * Generate the bits in the CATBits test. Points are generated with + * overlapping. We have a window of size L bits, and we slide it 1 bit + * forward at each step to generate a point. We then check whether it + * equals the L bits Key. + */ + const unsigned long MASK0 = num_TwoExp[L] - 1.0; + unsigned long Mask, Key, Z0, Z; + int j0, j, k; + long i; + long co; + + util_Assert (L <= 32, "CATBits: GenerBits: L > 32"); + co = 0; + + if ((s >= L) && (L <= 16)) { + const int q = s - L; + + /* Make sure to skip the first half of the loop for the first number + since there is no previous Z */ + j0 = L; + Z = 0; + + for (i = 0; i < n / s; i++) { + Z0 = unif01_StripB (gen, r, s); + + /* The last L - j0 bits of the previous number */ + Mask = MASK0 << (L - j0); + Key = KEY0 << (L - j0); + Z |= (Z0 >> q); + j = j0; + while (j < L) { + if (Key == (Z & Mask)) { + co++; + j += L; + Mask >>= L; + Key >>= L; + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j % L; + + /* The first s - L bits of the current number */ + Z = Z0; + Mask = MASK0 << (q - j0); + Key = KEY0 << (q - j0); + j = j0; + while (j < q) { + if (Key == (Z & Mask)) { + co++; + j += L; + Mask >>= L; + Key >>= L; + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j - q; + Z = Z0 << L; + } + + } else if (s >= L) { +#ifdef USE_LONGLONG + const ulonglong MASK0 = num_TwoExp[L] - 1.0; + ulonglong Z, Z0; + ulonglong Mask, Key; + const int q = s - L; + + /* Make sure to skip the first half of the loop for the first number + since there is no previous Z */ + j0 = L; + Z = 0; + + for (i = 0; i < n / s; i++) { + Z0 = unif01_StripB (gen, r, s); + + /* The last L - j0 bits of the previous number */ + Mask = MASK0 << (L - j0); + Key = KEY0 << (L - j0); + Z |= (Z0 >> q); + j = j0; + while (j < L) { + if (Key == (Z & Mask)) { + co++; + j += L; + Mask >>= L; + Key >>= L; + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j % L; + + /* The first s - L bits of the current number */ + Z = Z0; + Mask = MASK0 << (q - j0); + Key = KEY0 << (q - j0); + j = j0; + while (j < q) { + if (Key == (Z & Mask)) { + co++; + j += L; + Mask >>= L; + Key >>= L; + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j - q; + Z = Z0 << L; + } +#else + if (L <= s) + util_Error ("CATGenerBits: L <= s and L > 16"); +#endif + + } else if ((s < L) && (L + s <= 32)) { + const int t = L / s; + util_Assert (L % s == 0, "CATBits: L > s but L % s not 0"); + + /* Generation of the first L random bits */ + Z = 0; + for (j = 0; j < t; j++) { + Z <<= s; + Z |= unif01_StripB (gen, r, s); + } + j0 = 0; + + /* Generation of the rest of the random bits */ + for (i = 0; i < (n - L) / s; i++) { + Z = (Z << s) | unif01_StripB (gen, r, s); + Mask = MASK0 << (s - j0); + Key = KEY0 << (s - j0); + j = j0; + while (j < s) { + if (Key == (Z & Mask)) { + co++; + j += L; + i += t - 1; + for (k = 1; k < t; k++) { + Z <<= s; + Z |= unif01_StripB (gen, r, s); + } + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j % s; + } + + } else { +#ifdef USE_LONGLONG + const ulonglong MASK0 = num_TwoExp[L] - 1.0; + const int t = L / s; + ulonglong Z; + ulonglong Mask, Key, Key0 = KEY0; + + if (L > s) { + util_Assert (L % s == 0, "CATBits: L > s but L % s not 0"); + } + + /* Generation of the first L random bits */ + Z = 0; + for (j = 0; j < t; j++) { + Z <<= s; + Z |= unif01_StripB (gen, r, s); + } + j0 = 0; + + /* Generation of the rest of the random bits */ + for (i = 0; i < (n - L) / s; i++) { + Z = (Z << s) | unif01_StripB (gen, r, s); + Mask = MASK0 << (s - j0); + Key = Key0 << (s - j0); + j = j0; + while (j < s) { + if (Key == (Z & Mask)) { + co++; + j += L; + i += t - 1; + for (k = 1; k < t; k++) { + Z <<= s; + Z |= unif01_StripB (gen, r, s); + } + } else { + j++; + Mask >>= 1; + Key >>= 1; + } + } + j0 = j % s; + } +#else + if (L == s) + util_Error ("CATGenereBits: L = s and s > 16"); + else + util_Error ("CATGenereBits: L > s and L + s > 32"); +#endif + } + + *Count = co; +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_CATBits (unif01_Gen *gen, sres_Poisson *res, + long N, long n, int r, int s, int L, unsigned long Key) +{ + long Seq; + double Lambda; /* Poisson mean */ + long Sum; + long Co; + fmass_INFO Mass; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_CATBits test"; + + Timer = chrono_Create (); + Lambda = (n - L + 1) / num_TwoExp[L]; + if (swrite_Basic) + WriteDataCATBits (gen, TestName, N, n, r, s, L, Key, Lambda); + util_Assert (L > 1, "smarsa_CATBits: L <= 1"); + + TestCATBitsData (L, Key); + if (res == NULL) { + localRes = TRUE; + res = sres_CreatePoisson (); + } + sres_InitPoisson (res, N, Lambda, "smarsa_CATBits"); + sprintf (str, "The N statistic values (a Poisson with mean %g):", Lambda); + statcoll_SetDesc (res->sVal1, str); + + Sum = 0; + for (Seq = 1; Seq <= N; Seq++) { + CATGenerBits (gen, n, r, s, L, Key, &Co); + statcoll_AddObs (res->sVal1, (double) Co); + Sum += Co; + } + + res->sVal2 = Sum; + Mass = fmass_CreatePoisson (res->Mu); + res->pLeft = fdist_Poisson2 (Mass, Sum); + res->pRight = fbar_Poisson2 (Mass, Sum); + fmass_DeletePoisson (Mass); + res->pVal2 = gofw_pDisc (res->pLeft, res->pRight); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 1, 1); + if (swrite_Basic) { + WriteResultsPoisson (res, N); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeletePoisson (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataMatRank (unif01_Gen * gen, char *TestName, + long N, long n, int r, int s, int L, int k) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, L = %1d, k = %1d\n\n", s, L, k); +} + + +/*-------------------------------------------------------------------------*/ +#if 0 + +static int RankOfBitMatrix (bitset_BitSet M[], int maxrow) +/* + * Calculation of the rank of the bit-matrix M + */ +{ + const int MaxBit = 31; /* number of bits in a word - 1 */ + bitset_BitSet Swap; + int rank = 0; + int i; + int CL = 1; + + while (CL <= MaxBit) { + /* All components of M shift their bits 1 position to the left */ + for (i = 0; i < maxrow; i++) + M[i] <<= 1; + + /* Search of the first M[i] with 1 as the major bit */ + i = rank; + for (;;) { + if ((bitset_TestBit (M[i], MaxBit)) || (i == maxrow - 1)) + break; + ++i; + } + /* Diagonalization of matrix M */ + if (i < maxrow - 1) { + Swap = M[rank]; + M[rank] = M[i]; + M[i] = Swap; + for (i = rank + 1; i < maxrow; i++) { + if (bitset_TestBit (M[i], MaxBit)) + M[i] ^= M[rank]; + } + ++rank; + if (rank == MaxBit) + return rank; + } + ++CL; + } + return rank; +} + + +/*-------------------------------------------------------------------------*/ + +#define lmax 64 + +void smarsa_MatrixRank (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, int s, int l, int k) +{ + long Seq; + long Rep; + int j; + int i; + long L; /* One line of bits */ + int c; /* Number-1 of U01 used to build a line */ + long d; /* Get s bits of a generated U01 */ + long a; /* Get b bits of a generated U01 */ + int b; /* Number of bits of last U01 of a line */ + int Minkl; /* Min (k, l) */ + long NbGroups; /* Number of classes for ChiSquare */ + long jhigh; /* Index of the highest class */ + long jlow; /* Index of the lowest class */ + int Rank; /* Rank of matrix */ + double X2; + double Prod; + long *Loca; /* Redirections in merging Chi2 classes */ + long *Count; /* Observed numbers */ + double *NbExp; /* Expected numbers */ + bitset_BitSet M[lmax]; /* Matrix */ + double V[1]; /* Number of degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_MatrixRank test"; + + Timer = chrono_Create (); + /* We shall need c + 1 random numbers to build a line of the matrix */ + c = k / s; + b = k % s; + a = num_TwoExp[b]; + d = num_TwoExp[s]; + if (swrite_Basic) + WriteDataMatRank (gen, TestName, N, n, r, s, l, k); + if (k <= l) + Minkl = k; + else + Minkl = l; + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, Minkl, "smarsa_MatrixRank"); + NbExp = res->NbExp; + Count = res->Count; + Loca = res->Loc; + + Prod = n * pow (2.0, -(double) (l * k)); + NbExp[0] = Prod; + for (j = 1; j <= Minkl; j++) { + Prod = Prod * pow (2.0, (double) (l + k - 2*j + 1)) * + (1.0 - 1.0 / num_TwoExp[l - j + 1]) * + (1.0 - 1.0 / num_TwoExp[k - j + 1]) / + (1.0 - 1.0 / num_TwoExp[j]); + NbExp[j] = Prod; + } + + jlow = 0; + jhigh = Minkl; + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, 0); + gofs_MergeClasses (NbExp, Loca, &jlow, &jhigh, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, NbGroups); + res->jmin = jlow; + res->jmax = jhigh; + res->degFree = NbGroups - 1; + + util_Assert (n > 2.0 * gofs_MinExpected, + "smarsa_MatrixRank: n <= 2*gofs_MinExpected"); + util_Assert (k <= 31, "smarsa_MatrixRank: k > 31"); + util_Assert (l <= lmax, "smarsa_MatrixRank: L > 64"); + util_Assert (l * k <= 1020, "smarsa_MatrixRank: L*k > 1020"); + util_Assert (NbGroups > 1, + "smarsa_MatrixRank: number of classes = 1." + " Increase n or decrease |L - k|"); + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = jlow; i <= jhigh; i++) + Count[i] = 0; + for (Rep = 1; Rep <= n; Rep++) { + /* Generate the l x k matrix and compute its rank */ + for (i = 0; i < l; i++) { + /* Build one line of bits L */ + L = 0; + for (j = 1; j <= c; j++) + /* Generate s bits */ + L = d * L + unif01_StripB (gen, r, s); + /* The last b bits of a line of the matrix */ + if (a > 1) + L = a * L + unif01_StripB (gen, r, b); + M[i] = L; + } + /* Set all remaining lines to 0 */ + for (i = l; i < lmax; i++) + M[i] = 0; + + Rank = RankOfBitMatrix (M, lmax); + ++Count[Loca[Rank]]; + } + + X2 = gofs_Chi2 (NbExp, Count, jlow, jhigh); + statcoll_AddObs (res->sVal1, X2); + if (swrite_Counters) + tables_WriteTabL (Count, jlow, jhigh, 5, 12, "Observed Numbers"); + } + + V[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + /* !!!! Attention, this Write must use the right pVal */ + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH + 1, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + +#endif + +/*=========================================================================*/ +#if 0 +static void ZeroMat (Matrix * M) +{ + int i; + + for (i = 0; i < M->nblignes; i++) + PutBVToZero (&(M->lignes[i][0])); +} +#endif + +/*-------------------------------------------------------------------------*/ + +void smarsa_MatrixRank (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, int s, int l, int k) +{ + long Seq; + long Rep; + int j; + int i; + int c; /* Number-1 of U01 used to build a line */ + int b; /* Number of bits of last U01 of a line */ + unsigned long bmask; /* b bits mask */ + unsigned long smask; /* s bits mask */ + int Minkl; /* Min (k, l) */ + long NbGroups; /* Number of classes for ChiSquare */ + long jhigh; /* Index of the highest class */ + long jlow; /* Index of the lowest class */ + int Rank; /* Rank of matrix */ + double X2; + double temp; + long *Loca; /* Redirections in merging Chi2 classes */ + long *Count; /* Observed numbers */ + double *NbExp; /* Expected numbers */ + double Par[1]; /* Number of degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_MatrixRank test"; + Matrix *M; + BitVect *V; + + Timer = chrono_Create (); + /* We shall need ceiling(c) random numbers to build a line of the matrix */ + c = k / s; + b = k % s; + bmask = num_TwoExp[b] - 1.0; + /* The b most significant bits are set */ + bmask <<= vectorsF2_WL - b; + smask = num_TwoExp[s] - 1.0; + /* The s most significant bits are set */ + smask <<= vectorsF2_WL - s; + + if (swrite_Basic) + WriteDataMatRank (gen, TestName, N, n, r, s, l, k); + Minkl = util_Min (k, l); + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, Minkl, "smarsa_MatrixRank"); + NbExp = res->NbExp; + Count = res->Count; + Loca = res->Loc; + + temp = num_Log2((double) n) - l * k; + NbExp[0] = pow (2.0, temp); + for (j = 1; j <= Minkl; j++) { + temp += l + k - 2*j + 1 + + num_Log2(1.0 - pow (2.0, -(double) (l - j + 1))) + + num_Log2(1.0 - pow (2.0, -(double) (k - j + 1))) - + num_Log2(1.0 - pow (2.0, -(double) j)); + NbExp[j] = pow (2.0, temp); + } + + jlow = 0; + jhigh = Minkl; + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, 0); + gofs_MergeClasses (NbExp, Loca, &jlow, &jhigh, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, NbGroups); + res->jmin = jlow; + res->jmax = jhigh; + res->degFree = NbGroups - 1; + + util_Warning (NbGroups <= 1, + "smarsa_MatrixRank: number of Chi2 classes = 1.\n" + " Increase n or decrease |L - k|."); + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + util_Assert (n >= 2.0 * gofs_MinExpected, + "smarsa_MatrixRank: n <= 2*gofs_MinExpected"); + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + M = util_Malloc (sizeof (Matrix)); + AllocMat (M, l, k, 1); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = jlow; i <= jhigh; i++) + Count[i] = 0; + + for (Rep = 1; Rep <= n; Rep++) { + /* Generate the l x k matrix and compute its rank */ + for (i = 0; i < l; i++) { + V = &(M->lignes[i][0]); + /* Build one line of bits */ + for (j = 0; j < c; j++) { + /* Shift by s and generate s new bits */ + BVRShiftSelf (V, s); + V->vect[0] |= (smask & + (gen->GetBits (gen->param, gen->state) << r)); + } + /* The last b bits of a line of the matrix */ + if (b > 0) { + BVRShiftSelf (V, b); + V->vect[0] |= (bmask & + (gen->GetBits (gen->param, gen->state) << r)); + } + } + Rank = GaussianElimination (M, l, k, 1); + ++Count[Loca[Rank]]; + } + + X2 = gofs_Chi2 (NbExp, Count, jlow, jhigh); + statcoll_AddObs (res->sVal1, X2); + if (swrite_Counters) + tables_WriteTabL (Count, jlow, jhigh, 5, 12, "Observed Numbers"); + } + + FreeMat (M); + util_Free (M); + + Par[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, Par, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + /* !!!! Attention, this Write must use the right pVal */ + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataSavir2 (unif01_Gen * gen, char *TestName, + long N, long n, int r, long m, int t) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", m = %1ld, t = %1d\n\n", m, t); +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_Savir2 (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, long m, int t) +{ + const double eps = 1.0E-15; + long I; + long msup; /* Dimension - 1 of arrays */ + long Seq; + long Rep; + long j; + int i; + long NbGroups; /* Number of classes for ChiSquare */ + long jhigh; /* Index of the highest class */ + long jlow; /* Index of the lowest class */ + double X2; /* ChiSquare Statistic */ + double UnSurm = 1.0 / m; + double *Prob; /* Probabilities */ + long *Loca; + double V[1]; /* Number degrees of freedom for Chi2 */ + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_Savir2 test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataSavir2 (gen, TestName, N, n, r, m, t); + + Prob = util_Calloc ((size_t) m + 2, sizeof (double)); + Prob[m + 1] = 0.0; + for (j = 1; j <= m; j++) + Prob[j] = UnSurm; + for (i = 2; i <= t; i++) { + for (j = m; j >= 1; j--) + Prob[j] = Prob[j + 1] + Prob[j] / j; + } + j = 1; + while (Prob[j] > eps) + ++j; + msup = j - 1; + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, msup, "smarsa_Savir2"); + + for (j = 1; j <= msup; j++) + res->NbExp[j] = Prob[j] * n; + util_Free (Prob); + Loca = res->Loc; + + jlow = 1; + jhigh = msup; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loca, jlow, jhigh, 0); + gofs_MergeClasses (res->NbExp, Loca, &jlow, &jhigh, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loca, jlow, jhigh, NbGroups); + res->jmin = jlow; + res->jmax = jhigh; + res->degFree = NbGroups - 1; + + util_Warning (NbGroups < 2, + "smarsa_Savir2: Number of classes = 1.\n Decrease t or increase n."); + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + util_Assert (n >= 2.0 * gofs_MinExpected, + "smarsa_Savir2: n <= 2*gofs_MinExpected"); + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + res->sVal1 = statcoll_Create (N, str); + + for (Seq = 1; Seq <= N; Seq++) { + for (j = jlow; j <= jhigh; j++) + res->Count[j] = 0; + for (Rep = 1; Rep <= n; Rep++) { + I = m; + for (i = 1; i <= t; i++) + I = 1 + unif01_StripD (gen, r) * I; + if (I > msup) + ++res->Count[Loca[msup]]; + else + ++res->Count[Loca[I]]; + } + + if (swrite_Counters) + tables_WriteTabL (res->Count, jlow, jhigh, 5, 12, + "Observed Numbers"); + + X2 = gofs_Chi2 (res->NbExp, res->Count, jlow, jhigh); + statcoll_AddObs (res->sVal1, X2); + } + + V[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataGCD (unif01_Gen * gen, char *TestName, + long N, long n, int r, int s) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d\n\n", s); +} + + +/*-------------------------------------------------------------------------*/ + +void smarsa_GCD (unif01_Gen *gen, smarsa_Res2 *res, + long N, long n, int r, int s) +{ + /* + The theoretical distribution for the number of iterations is unknown. + The binomial is a very rough approximation: thus the printing of the + results is commented out. + */ + const double C1 = 6 / (num_Pi * num_Pi); + const double P1 = 0.376; + const int KMAX = 50; + unsigned long U, V, temp; + double X; + double Param[1]; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "smarsa_GCD test"; + sres_Chi2 *GCD; + sres_Chi2 *NumIter; + int jmax, j, k; + long Seq, i; + double *NbExp; + long *Loc; + long NbClasses; + fmass_INFO Q; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataGCD (gen, TestName, N, n, r, s); + if (n < 30) { + util_Warning (TRUE, "n < 30"); + return; + } + if (n > pow (2.0, 1.5*s)) { + util_Warning (TRUE, "n > 2^(1.5s)"); + return; + } + if (res == NULL) { + localRes = TRUE; + res = smarsa_CreateRes2 (); + } + jmax = 1 + sqrt (C1 * n / gofs_MinExpected); + util_Assert (jmax > 1, "smarsa_GCD: jmax < 2"); + InitRes2 (res, N, jmax, KMAX); + + GCD = res->GCD; + GCD->jmin = 1; + GCD->jmax = jmax; + GCD->degFree = jmax - 1; + sprintf (str, "GCD; the N statistic values (a ChiSquare with %1d degrees" + " of freedom):", jmax - 1); + statcoll_SetDesc (GCD->sVal1, str); + + /* Compute the probabilities for the GCD values */ + NbExp = GCD->NbExp; + Loc = GCD->Loc; + X = 0.0; + for (j = 1; j < jmax; j++) { + NbExp[j] = n * C1 / ((double) j * j); + X += NbExp[j]; + Loc[j] = j; + } + NbExp[jmax] = n - X; + + if (swrite_Classes) { + printf ("Classes for the GCD values:\n"); + gofs_WriteClasses (GCD->NbExp, GCD->Count, 1, jmax, 0); + } + + NumIter = res->NumIter; + /* Compute expected numbers for number of iterations */ + Q = fmass_CreateBinomial (KMAX, P1, 1.0 - P1); + for (i = 0; i <= KMAX; i++) + NumIter->NbExp[i] = n * fmass_BinomialTerm2 (Q, i); + fmass_DeleteBinomial (Q); + + NumIter->jmin = 0; + NumIter->jmax = KMAX; + if (swrite_Classes) { + printf ("\nClasses for the number of iterations:\n"); + gofs_WriteClasses (NumIter->NbExp, NumIter->Loc, NumIter->jmin, + NumIter->jmax, 0); + } + gofs_MergeClasses (NumIter->NbExp, NumIter->Loc, &NumIter->jmin, + &NumIter->jmax, &NbClasses); + + if (swrite_Classes) + gofs_WriteClasses (NumIter->NbExp, NumIter->Loc, NumIter->jmin, + NumIter->jmax, NbClasses); + + sprintf (str, "NumIter; the N statistic values (a ChiSquare with %1ld" + " degrees of freedom):", NbClasses - 1); + statcoll_SetDesc (NumIter->sVal1, str); + NumIter->degFree = NbClasses - 1; + util_Assert (NumIter->degFree >= 1, "NumIter->degFree < 1"); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i <= KMAX; i++) + NumIter->Count[i] = 0; + for (i = 0; i <= GCD->jmax; i++) + GCD->Count[i] = 0; + for (i = 1; i <= n; i++) { + k = 0; + do { + U = unif01_StripB (gen, r, s); + V = unif01_StripB (gen, r, s); + } while (0 == U || 0 == V); + do { + temp = U % V; + U = V; + V = temp; + k++; + } while (V > 0); + if ((long) U > GCD->jmax) + U = GCD->jmax; + (GCD->Count[U])++; + if (k > KMAX) + k = KMAX; + (NumIter->Count[NumIter->Loc[k]])++; + } + if (swrite_Counters) { + tables_WriteTabL (GCD->Count, GCD->jmin, GCD->jmax, 5, 10, + "Observed numbers for GCD values:"); + /* tables_WriteTabL (NumIter->Count, NumIter->jmin, NumIter->jmax, 5, + 10, "Observed numbers for number of iterations:"); + */ + } + + X = gofs_Chi2 (GCD->NbExp, GCD->Count, GCD->jmin, GCD->jmax); + statcoll_AddObs (GCD->sVal1, X); + X = gofs_Chi2 (NumIter->NbExp, NumIter->Count, NumIter->jmin, + NumIter->jmax); + statcoll_AddObs (NumIter->sVal1, X); + } + + Param[0] = GCD->degFree; + gofw_ActiveTests2 (GCD->sVal1->V, GCD->pVal1->V, N, wdist_ChiSquare, + Param, GCD->sVal2, GCD->pVal2); + GCD->pVal1->NObs = N; + sres_GetChi2SumStat (GCD); +/* + Param[0] = NumIter->degFree; + gofw_ActiveTests2 (NumIter->sVal1->V, NumIter->pVal1->V, N, + wdist_ChiSquare, Param, NumIter->sVal2, NumIter->pVal2); + NumIter->pVal1->NObs = N; +*/ + + if (swrite_Basic) { + if (swrite_Collectors) + statcoll_Write (GCD->sVal1, 5, 14, 4, 3); + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Number of degrees of freedom : %4ld\n", + GCD->degFree); + printf ("Chi2 statistic for GCD values :"); + gofw_Writep2 (GCD->sVal2[gofw_Mean], GCD->pVal2[gofw_Mean]); + } else { + printf ("Test results for GCD values:\n"); + gofw_WriteActiveTests0 (N, GCD->sVal2, GCD->pVal2); + swrite_Chi2SumTest (N, GCD); + } + /* + if (swrite_Collectors) + statcoll_Write (NumIter->sVal1, 5, 14, 4, 3); + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Number of degrees of freedom : %4ld\n", + NumIter->degFree); + printf ("Chi2 statistic for NumIter :"); + gofw_Writep2 (NumIter->sVal2[gofw_Mean], NumIter->pVal2[gofw_Mean]); + } else { + printf ("Test results for NumIter:\n"); + gofw_WriteActiveTests0 (N, NumIter->sVal2, NumIter->pVal2); + swrite_SumTest (N, NumIter->sVal2[gofw_Sum], NumIter->pVal2[gofw_Sum], + N*NumIter->degFree); + } + */ + printf ("\n\n"); + swrite_Final (gen, Timer); + } + + if (localRes) + smarsa_DeleteRes2 (res); + chrono_Delete (Timer); + +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/smultin.c b/cbits/testu/src/smultin.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/smultin.c @@ -0,0 +1,3674 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: smultin.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "util.h" +#include "chrono.h" +#include "num.h" +#include "num2.h" +#include "tables.h" + +#include "smultin.h" +#include "wdist.h" +#include "swrite.h" +#include "unif01.h" + +#include "statcoll.h" +#include "gofw.h" +#include "fmass.h" +#include "fdist.h" +#include "fbar.h" + +#include +#include +#include +#include + + + + + + +/*============================= constants ===============================*/ + +/* Max string length */ +#define LENGTH 100 + +/* Max dimension t */ +#define MAX_DIM 64 + +/* Used for secondary hashing */ +#define HACHE2 41 + +/* Upper Limit of precomputed tables of 2nI, when SPARSE = TRUE */ +static const long LIM_SPARSE = 64; + +/* LIM_DENSE*n/k = upper limit of the precomputed tables for 2nI, when */ +/* SPARSE = FALSE and 6n/k < k */ +static const double LIM_DENSE = 6.0; + +/* Precision with which we measure specific values of ValDelta */ +static const double EPS_LAM = 1.0E-14; + +#ifdef USE_LONGLONG +#define MAXK 9223372036854775808.0 /* 2^63 */ +#else +#define MAXK 9007199254740992.0 /* 2^53 */ +#endif + +/* Our gamma distribution is not good for parameters larger than this. */ +#define EMPTYLIM 200000000000000.0 + +#define MASK64 0x8000000000000000ULL /* 2^63: set bit 64 to 1 */ + +#define TRACE(N) printf ("********* "#N"%13ld\n", N); + + + +/*=============================== Types =================================*/ + +/* Index for the different values of ValDelta */ +typedef int DeltaIndex; + + + + +/*========================= Extern variables ============================*/ + +smultin_Envir smultin_env = { + MAXK, + 1024 * 1024, /* SeuilHash */ + 0.75, /* HashLoad */ + 5.0E+6, /* SeuilEColl */ + + 12.0, /* SeuilCOverDense */ + 5.0, /* SeuilCOverNorSup */ + 1.999, /* SeuilCOverNorInf */ + 1.0001 /* SeuilCOverSparse */ +}; + + +/* The stable parameters values used by default */ +smultin_Param smultin_ParamDefault = { + 2, /* NbDelta */ + {-1, 1}, /* ValDelta */ + smultin_GenerCellSerial, /* GenerCell */ + -3 /* bmax */ +}; + + + +/*============================== Functions ==============================*/ + + +smultin_Param *smultin_CreateParam (int NbDelta, double ValDelta[], + smultin_GenerCellType GenerCell, int bmax) +{ + smultin_Param *par; + int j; + + par = util_Malloc (sizeof (smultin_Param)); + par->NbDelta = NbDelta; + for (j = 0; j < NbDelta; j++) { + util_Assert (ValDelta[j] >= -1.0, + "smultin_CreateParam: ValDelta[j] < -1"); + par->ValDelta[j] = ValDelta[j]; + } + util_Assert (bmax <= smultin_MAXB, + "smultin_CreateParam: bmax > smultin_MAXB"); + par->bmax = bmax; + par->GenerCell = GenerCell; + return par; +} + +/*-------------------------------------------------------------------------*/ + +void smultin_DeleteParam (smultin_Param *par) +{ + if (par == NULL) + return; + util_Free (par); +} + + +/*=========================================================================*/ + +static void CleanPD (smultin_Res *res) +{ + DeltaIndex s; + + if (res == NULL) + return; + + for (s = 0; s < res->NbDeltaOld; s++) { + res->TabFj[s] = util_Free (res->TabFj[s]); + } + + res->Count = util_Free (res->Count); + res->Count1 = util_Free (res->Count1); + res->Cell = util_Free (res->Cell); + res->Cell1 = util_Free (res->Cell1); + res->Nb = util_Free (res->Nb); + res->Nb1 = util_Free (res->Nb1); +} + + +/*=========================================================================*/ + +static void InitRes ( + smultin_Param *par, + smultin_Res *res, /* Results holder */ + long N /* Number of replications */ +) +/* + * Initializes the smultin_Res structure. The old NbDelta is in res, the + * new NbDelta is in par. Delete the unused collectors if old NbDelta > new + * NbDelta, and create the needed collectors if old NbDelta < new NbDelta. + */ +{ + DeltaIndex s; + + if (par == NULL) + par = &smultin_ParamDefault; + CleanPD (res); + + for (s = par->NbDelta; s < res->NbDeltaOld; s++) + res->Collector[s] = statcoll_Delete (res->Collector[s]); + + for (s = res->NbDeltaOld; s < par->NbDelta; s++) + res->Collector[s] = statcoll_Create (N, ""); + + for (s = 0; s < par->NbDelta; s++) { + statcoll_Init (res->Collector[s], N); + gofw_InitTestArray (res->sVal2[s], -1.0); + gofw_InitTestArray (res->pVal2[s], -1.0); + } + + res->NbDeltaOld = par->NbDelta; + res->flagTab = FALSE; + res->nLimit = 1; + res->pColl = res->pEmpty = -1.0; + res->pCollLeft = -1.0; + res->pCollRight = -1.0; +} + + +/*-------------------------------------------------------------------------*/ + +smultin_Res * smultin_CreateRes (smultin_Param *par) +{ + smultin_Res *res; + DeltaIndex s; + + res = util_Malloc (sizeof (smultin_Res)); + memset (res, 0, sizeof (smultin_Res)); + + if (par == NULL) + par = &smultin_ParamDefault; + + for (s = 0; s < par->NbDelta; s++) { + res->Collector[s] = statcoll_Create (1, ""); + res->TabFj[s] = NULL; + } + + res->Count = NULL; + res->Count1 = NULL; + res->Cell = NULL; + res->Cell1 = NULL; + res->NbDeltaOld = 0; + res->Nb = NULL; + res->Nb1 = NULL; + + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void smultin_DeleteRes (smultin_Res * res) +{ + DeltaIndex s; + + if (res == NULL) + return; + + for (s = 0; s < res->NbDeltaOld; s++) + res->Collector[s] = statcoll_Delete (res->Collector[s]); + + CleanPD (res); + util_Free (res); +} + + +/*=========================================================================*/ + +double smultin_MNTermeKhi2 (double junk, double NbEsp, long j) +/* + * One term of Chi2 = 2nI1; there are j balls in this urn. + */ +{ + double Diff; + Diff = j - NbEsp; + return Diff * Diff / NbEsp; +} + + +/*=======================================================================*/ + +double smultin_MNTermePowDiv (double Delta, double NbEsp, long j) +/* + * One term of Power Divergence = 2nI; there are j balls in this urn. + */ +{ + double y; + if (j == 0) + return 0.0; + y = pow (j / NbEsp, Delta) - 1.0; + return (2.0 * j * y) / (Delta * (Delta + 1.0)); +} + + +/*=======================================================================*/ + +double smultin_MNTermeLogLikhood (double junk, double NbEsp, long j) +/* + * One term of loglikelihood ratio = 2nI0; there are j balls in this urn + */ +{ + if (j == 0) + return 0.0; + return 2.0 * j * log (j / NbEsp); +} + + +/*=======================================================================*/ + +double smultin_MNTermeColl (double junk1, double junk2, long j) +/* + * Number of collisions when there are j balls in this urn + */ +{ + if (j <= 1) + return 0.0; + return (double) (j - 1); +} + + +/*=======================================================================*/ + +static void MNCalcMuSigma ( + double V[], /* Contains the terms of the statistic */ + long nlim, /* Limit on the non negligible terms */ + long n, /* Number of balls */ + double k, /* Number of urns */ + double *Mu, /* Mean */ + double *Sigma /* Standard deviation */ + ) +/* + * Compute the mean Mu and the standard deviation Sigma. For some values + * of n and k, some of the terms to be subtracted will be huge and loss + * of precision may give negative variance. We shall then stop the tests + * and exit in WriteDataPowDiv. + */ +{ + const double Epsilon = 1.0E-100; /* To avoid division by 0 */ + const double Eps = 1.0E-18; + long i, j, Mid; + double cond2, cond1, temp; + double Sum3, Sum2, Sum1; + double muk, Var; + double km; + double Terme2, TermeMid, Terme1; + double x, nr = n; + + util_Assert (nlim <= n, "MNCalcMuSigma; nlim > n"); + Mid = n / k; + while (Mid < nlim && fabs (V[Mid]) < Eps) + ++Mid; + util_Assert (Mid <= nlim, "MNCalcMuSigma; Mid > nlim"); + + /******* Compute Mean x = *Mu */ + TermeMid = fmass_BinomialTerm3 (n, 1.0 / k, Mid) * k; + x = V[Mid] * TermeMid; + Terme1 = x; + i = Mid; + km = k - 1; + while (i < n && fabs (Terme1 / x) > Eps) { + util_Assert (i < nlim, "MNCalcMuSigma: nlim too small --> Espion001"); + Terme1 *= V[i + 1] * (n - i) / (V[i] * (i + 1) * km); + x += Terme1; + ++i; + } + Terme1 = V[Mid] * TermeMid; + i = Mid; + while (i > 0 && fabs (Terme1) / x > Eps) { + Terme1 *= V[i - 1] * i * km / (V[i] * (n - i + 1)); + x += Terme1; + --i; + } + /* The cases when |Terme[i]| < Eps, but |Terme[i-1]| > Eps */ + /* these terms must be included also. */ + --i; + if (i >= 0) { + Terme1 = V[i] * fmass_BinomialTerm3 (n, 1.0 / k, i) * k; + x += Terme1; + while (i > 0 && fabs (Terme1 / x) > Eps) { + Terme1 = Terme1 * V[i - 1] * i * km / (V[i] * (n - i + 1)); + x += Terme1; + --i; + } + } + + /****** Calculate variance: first series of terms */ + muk = x / k; + Terme1 = (V[Mid] - muk) * (V[Mid] - muk) * TermeMid; + cond2 = TermeMid * V[Mid] * V[Mid]; + Sum1 = Terme1; + Terme2 = Terme1; + i = Mid; + km = k - 1; + while (i < n && fabs (cond2 / Sum1) + fabs (Terme2 / Sum1) > Eps) { + util_Assert (i < nlim, "MNCalcMuSigma: nlim too small --> Espion002"); + temp = V[i + 1] / (V[i] + Epsilon); + cond2 *= temp * temp * (n - i) / ((i + 1) * km); + temp = (V[i + 1] - muk) / (V[i] - muk); + Terme2 *= temp * temp * (n - i) / ((i + 1) * km); + Sum1 += Terme2; + ++i; + } + Terme2 = Terme1; + cond2 = TermeMid * V[Mid] * V[Mid]; + i = Mid; + while (i > 0 && fabs (cond2 / Sum1) + fabs (Terme2 / Sum1) > Eps) { + temp = V[i - 1] / (V[i] + Epsilon); + cond2 *= temp * temp * i * km / (n - i + 1); + temp = (V[i - 1] - muk) / (V[i] - muk); + Terme2 *= temp * temp * i * km / (n - i + 1); + Sum1 += Terme2; + --i; + } + + /****** Calculate variance: terms i = j */ + temp = fmass_BinomialTerm4 (n - Mid, 1.0 / k, 2.0 / k, Mid) * + fmass_BinomialTerm4 (n, 1.0 / k, 0.0, Mid) * k * (k - 1); + TermeMid = temp * (V[Mid] - muk) * (V[Mid] - muk); + cond1 = TermeMid * V[Mid] * V[Mid] + / ((V[Mid] - muk) * (V[Mid] - muk) + Epsilon); + Terme1 = TermeMid; + Sum2 = Terme1; + i = Mid; + km = k - 2; + while ((i < n / 2) + && fabs (cond1 / Sum2) + fabs (Terme1 / Sum2) > Eps) { + util_Assert (i < nlim, "MNCalcMuSigma: nlim too small --> Espion003"); + temp = V[i + 1] / ((V[i] + Epsilon) * (i + 1) * km); + cond1 *= (nr - 2 * i) * (nr - 2 * i - 1) * temp * temp; + temp = (V[i + 1] - muk) / ((V[i] - muk) * (i + 1) * km); + Terme1 *= (nr - 2 * i) * (nr - 2 * i - 1) * temp * temp; + Sum2 += Terme1; + ++i; + } + i = Mid; + Terme1 = TermeMid; + cond1 = TermeMid * V[Mid] * V[Mid] / ((V[Mid] - muk) * (V[Mid] - muk)); + while (i > 0 && fabs (cond1 / Sum2) + fabs (Terme1 / Sum2) > Eps) { + temp = (V[i - 1] * i * km) / (V[i] + Epsilon); + cond1 *= temp * temp / ((nr - 2 * i + 2) * (nr - 2 * i + 1) + Epsilon); + temp = (V[i - 1] - muk) * i * km / (V[i] - muk); + Terme1 *= temp * temp / ((nr - 2 * i + 2) * (nr - 2 * i + 1) + Epsilon); + Sum2 += Terme1; + --i; + } + /****** Calculate variance: terms i <> j */ + i = Mid + 1; + Sum3 = 1.0E-40; + cond1 = 1.0; + Terme1 = 1.0; + while (i <= n && fabs (cond1 / Sum3) + fabs (Terme1 / Sum3) > Eps) { + util_Assert (i <= nlim, "MNCalcMuSigma: nlim too small --> Espion004"); + j = Mid; + if (j > n - i) + j = n - i; + temp = fmass_BinomialTerm4 (n, 1.0 / k, 0.0, i) * + fmass_BinomialTerm4 (n - i, 1.0 / k, 2.0 / k, j); + Terme1 = temp * (V[i] - muk) * (V[j] - muk) * k * (k - 1); + cond1 = Terme1 * V[i] * V[j] / ((V[i] - muk) * (V[j] - muk)); + Sum3 += Terme1; + Terme2 = Terme1; + cond2 = cond1; + while (j > 0 && fabs (cond2 / Sum3) + fabs (Terme2 / Sum3) > Eps) { + cond2 *= V[j - 1] * j * km / (V[j] * (n - i - j + 1) + Epsilon); + Terme2 *= (V[j - 1] - muk) * j * km / + ((V[j] - muk) * (n - i - j + 1) + Epsilon); + Sum3 += Terme2; + --j; + } + Terme2 = Terme1; + cond2 = cond1; + j = Mid; + while ((j < i - 1 && i + j < n) + && fabs (cond2 / Sum3) + fabs (Terme2 / Sum3) > Eps) { + util_Assert (j < nlim, "MNCalcMuSigma: nlim too small --> Espion005"); + cond2 *= V[j + 1] * (n - i - j) / (V[j] * (j + 1) * km + Epsilon); + Terme2 *= (V[j + 1] - muk) * (n - i - j) + / ((V[j] - muk) * (j + 1) * km + Epsilon); + Sum3 += Terme2; + ++j; + } + ++i; + } + i = Mid; + cond1 = Sum3 + 1.0; + Terme1 = 1.0; + while (i > 0 && fabs (cond1 / Sum3) + fabs (Terme1 / Sum3) > Eps) { + j = i - 1; + temp = fmass_BinomialTerm4 (n, 1.0 / k, 0.0, i) * + fmass_BinomialTerm4 (n - i, 1.0 / k, 2.0 / k, j); + Terme1 = temp * (V[i] - muk) * (V[j] - muk) * k * (k - 1.0); + cond1 = (Terme1 * V[i] * V[j]) / ((V[i] - muk) * (V[j] - muk)); + Sum3 += Terme1; + Terme2 = Terme1; + cond2 = cond1; + while (j > 0 && fabs (cond2 / Sum3) + fabs (Terme2 / Sum3) > Eps) { + cond2 *= V[j - 1] * j * km / (V[j] * (n - i - j + 1) + Epsilon); + Terme2 *= (V[j - 1] - muk) * j * km / + ((V[j] - muk) * (n - i - j + 1) + Epsilon); + Sum3 += Terme2; + --j; + } + --i; + } + Var = Sum1 + Sum2 + 2.0 * Sum3; + util_Warning (Var < 0.0, "MNCalcMuSigma: negative variance"); + if (Var >= 0.0) + *Sigma = sqrt (Var); + else + *Sigma = -1.0; + *Mu = x; +} + + +/*=======================================================================*/ + +void smultin_MultinomMuSigma ( + long n, /* Number of balls */ + double k, /* Number of urns */ + double Theta1, /* First parameter of the term F */ + double Theta2, /* Second parameter of the term F */ + smultin_MNTermeType F, /* One term of the statistic */ + double *Mu, /* Mean */ + double *Sigma /* Standard deviation */ + ) +/* + * Compute the mean Mu and the standard deviation Sigma + */ +{ + + /* For densities n/k < 8, only the ~ 25 first terms will contribute */ + /* significantly to the normal approximation; thus we precompute only */ + /* elements [0..LIM_SPARSE] of the tables in the case Sparse = TRUE */ + + long nlim; + long j; + double densite; + double *PV; + + /* We may choose n >>> nlim because the probabilities will be concen- */ + /* trated near j = 0 for low densites ( < 8). Large values of j will */ + /* practically never occur. It is not necessary to compute all the */ + /* PV[0..n]. For high densities n/k, nlim will have to be increased. */ + + densite = n / (double) k; + nlim = 8 * densite; + if (nlim < LIM_SPARSE) + nlim = LIM_SPARSE; /* Sparse = TRUE */ + if (nlim > n) + nlim = n; /* Sparse = FALSE */ + PV = util_Calloc ((size_t) nlim + 2, sizeof (double)); + for (j = 0; j <= nlim; j++) + PV[j] = F (Theta1, Theta2, j); + MNCalcMuSigma (PV, nlim, n, k, Mu, Sigma); + util_Free (PV); +} + + +/*=======================================================================*/ + +static void CalcTabFj ( + smultin_Param *par, + smultin_Res *res, + lebool Sparse, + double k, /* Number of cells or urns */ + double NbExp /* Expected number per cell */ + ) +/* + * May pre-calculate all terms. Will then calculate all non negligible + * terms for all values of s, and keep them in tables TabFj[s][]. + */ +{ + long i; + DeltaIndex s; + double delta; + double c; + double temp; + double *F; + + if (!Sparse && LIM_DENSE * NbExp > k) { + /* Do not precompute tables when Sparse = FALSE and we have a very */ + /* small number k of cells */ + res->flagTab = FALSE; + return; + } + + /* Precompute the values and keep them in arrays */ + res->flagTab = TRUE; + if (Sparse) + res->nLimit = LIM_SPARSE; + else { + res->nLimit = LIM_DENSE * NbExp; + if (res->nLimit < 1) + res->nLimit = 2; + } + + for (s = 0; s < par->NbDelta; s++) { + res->TabFj[s] = util_Calloc (2 + (size_t) res->nLimit, sizeof (double)); + delta = par->ValDelta[s]; + util_Assert (delta >= -1.0 - EPS_LAM, + "CalcTabFj: par->ValDelta[s] < -1"); + F = res->TabFj[s]; + F[0] = 0.0; + + if (fabs (delta - 1.0) < EPS_LAM) { + /* ChiSquare */ + for (i = 0; i <= res->nLimit; i++) { + temp = i - NbExp; + F[i] = temp * temp / NbExp; + } + + } else if (fabs (delta) < EPS_LAM) { + /* LogLikelyhood */ + for (i = 1; i <= res->nLimit; i++) { + temp = i; + F[i] = 2.0 * temp * log (temp / NbExp); + } + + } else if (fabs (delta + 1.0) < EPS_LAM) { + /* Collision */ + for (i = 1; i <= res->nLimit; i++) { + F[i] = i - 1; + } + + } else { + /* PowerDivergence, delta > -1 */ + c = 2.0 / (delta * (delta + 1.0)); + for (i = 1; i <= res->nLimit; i++) { + temp = i; + F[i] = c * temp * (pow (temp / NbExp, delta) - 1.0); + } + } + } +} + + +/*=======================================================================*/ + +static void ReCalcTabFj ( + smultin_Param *par, + smultin_Res *res, + double NbExp /* Expected number per cell */ + ) +/* + * Update tables TabFj when one of the Count becomes larger than res->nLimit + */ +{ + long i; + DeltaIndex s; + double delta; + double c; + double temp; + double *F; + long i0 = res->nLimit; + res->nLimit *= 2; + + for (s = 0; s < par->NbDelta; s++) { + delta = par->ValDelta[s]; + res->TabFj[s] = util_Realloc (res->TabFj[s], + (res->nLimit + 1) * sizeof (double)); + F = res->TabFj[s]; + + if (fabs (delta - 1.0) < EPS_LAM) { + /* ChiSquare */ + for (i = i0 + 1; i <= res->nLimit; i++) { + temp = i - NbExp; + F[i] = temp * temp / NbExp; + } + + } else if (fabs (delta) < EPS_LAM) { + /* LogLikelyhood */ + for (i = i0 + 1; i <= res->nLimit; i++) { + temp = i; + F[i] = 2.0 * temp * log (temp / NbExp); + } + + } else if (fabs (delta + 1.0) < EPS_LAM) { + /* Collision Test */ + for (i = i0 + 1; i <= res->nLimit; i++) { + F[i] = i - 1; + } + + } else { + c = 2.0 / (delta * (delta + 1.0)); + for (i = i0 + 1; i <= res->nLimit; i++) { + temp = i; + F[i] = c * temp * (pow (temp / NbExp, delta) - 1.0); + } + } + } +} + + +/*=======================================================================*/ + +void smultin_PowDivMomCorChi ( + double Delta, + long n, /* Number of balls */ + double k, /* Number of urns */ + double *MuC, /* Corrected mean */ + double *SigmaC /* Corrected standard deviation */ + ) +/* + * Compute the corrected mean and standard deviation in the dense case + * for the ChiSquare approximation. (See Read and Cressie) + */ +{ + double t = k * k; + double temp; + if (Delta < EPS_LAM - 1.0) { + *MuC = -1.0; + *SigmaC = -1.0; + return; + } + temp = (8.0 - 12.0 * k - 2.0 * k * k + 6.0 * t + + (Delta - 1.0) * (4.0 - 6.0 * k - 3.0 * k * k + 5.0 * t) / 3.0 + + 2.0 * (Delta - 2.0) * (1.0 - 2.0 * k + t)); + *SigmaC = 2.0 - 2.0 * k - (double) k * k + t + (Delta - 1.0) * temp; + *SigmaC = sqrt (1.0 + *SigmaC / (2.0 * n * (k - 1.0))); + temp = (2.0 - 3.0 * k + t) / 3.0 + + (Delta - 2.0) * (1.0 - 2.0 * k + t) / 4.0; + *MuC = (k - 1.0) * (1.0 - *SigmaC) + (Delta - 1.0) * temp / n; +} + + +/*=======================================================================*/ + +void smultin_PowDivMom ( + double Delta, /* Which Power Divergence */ + long n, /* Number of balls */ + double k, /* Number of urns */ + double NbExp, /* Expected number per urn */ + double *Mu, /* Mean */ + double *Sigma /* Standard deviation */ + ) +/* + * Compute the mean and standard deviation in the sparse case + */ +{ + + if ((double) n / k > 8.0) { + printf ("************* Call of smultin_PowDivMom with n/k > 8\n"); + *Mu = -1.0; + *Sigma = -1.0; + return; + } + if (k <= 2) { + printf ("************* Call of smultin_PowDivMom with k <= 2\n"); + *Mu = -1.0; + *Sigma = -1.0; + return; + } + + util_Assert ((double) n / k <= 8.0, + "smultin: Call of PowDivMom with n/k > 8"); + util_Assert (k > 2, "smultin: Call of PowDivMom with k <= 2"); + + if (fabs (Delta - 1.0) < EPS_LAM) { + /* ChiSquare test */ + *Mu = k - 1; + *Sigma = sqrt (2.0 * (k - 1) * (n - 1.0) / n); + + } else if (fabs (Delta + 1.0) < EPS_LAM) { + /* Collision test */ + smultin_MultinomMuSigma (n, k, 0.0, 0.0, smultin_MNTermeColl, Mu, Sigma); + + } else if (fabs (Delta) < EPS_LAM) { + /* Delta = 0, LogLikelyhood */ + smultin_MultinomMuSigma (n, k, 0.0, NbExp, smultin_MNTermeLogLikhood, + Mu, Sigma); + + } else if (Delta > -1.0) { + smultin_MultinomMuSigma (n, k, Delta, NbExp, smultin_MNTermePowDiv, + Mu, Sigma); + + } else + util_Error ("smultin_PowDivMom: Delta < -1.0"); +} + + +/*=======================================================================*/ +#if 0 + +static void CalcPowDiv (double Delta, double NbExp[], long Count[], + long smin, long smax, double *X) +/* + * Compute the statistic $2n I^\delta$ defined in (\ref{powdiv}), + * for $\delta = {\tt Delta}$, and return its value in $X$. + * We assume that the expected values $n p_i$ in cell $i$ are in + * {\tt NbExp[smin..smax]}, the observed values $X_i$ are in + * {\tt Count[smin..smax]}, {\tt smin} and {\tt smax} are the indices + * of the first and the last cell, + * and the number of cells is $k = {\tt smax} - {\tt smin} + 1$. + * The $p_i$ are not necessarily equal. + */ +{ + double temp; + long s; + *X = 0.0; + + if (fabs (Delta - 1.0) < EPS_LAM) { + /* ChiSquare */ + for (s = smin; s <= smax; s++) { + temp = Count[s] - NbExp[s]; + *X += (temp * temp) / NbExp[s]; + } + + } else if (fabs (Delta) < EPS_LAM) { + /* Loglikelihood */ + for (s = smin; s <= smax; s++) { + if (Count[s] > 0) { + temp = Count[s]; + *X += temp * log (temp / NbExp[s]); + } + } + *X *= 2.0; + + } else if (Delta <= EPS_LAM - 1.0) { + util_Error ("smultin_CalcPowDiv: Delta <= -1.0"); + /* We do the collisions test only when probabilities are equal. See + smultin_CalcPowDivEqual. */ + + } else { + /* Other values of Delta. */ + for (s = smin; s <= smax; s++) { + if (Count[s] > 0) { + temp = Count[s]; + *X += temp * (pow (temp / NbExp[s], Delta) - 1.0); + } + } + *X = 2.0 * *X / (Delta * (Delta + 1.0)); + } +} + +#endif + +/*=======================================================================*/ + +static void CalcPowDivEqual ( + smultin_Param *par, + smultin_Res *res, + DeltaIndex s, + double NbExp, /* Expected number per cell */ + long Count[], /* Counters */ + long jmin, /* First cell */ + long jmax, /* Last cell */ + lebool flagTab, /* TRUE: use precomputed table */ + double *X /* Computed statistic */ + ) +/* + * This function is called only when we do not use hashing. + * + * As in CalcPowDiv, except that the values of np_i are all equal to + * np = NbExp. The lebool flagTab indicates if the values of + * $2 i ln (i/np)$ and + * $ {2\over \delta(1+\delta)} + * i \left[\left(i/np\right)^\delta -1\right]$ have already been + * pre-computed and kept in the arrays + * F (it is so if {\tt flagTab = TRUE}). + */ +{ + double temp; + double *F = res->TabFj[s]; /* The precomputed table */ + double Delta = par->ValDelta[s]; + long j; + *X = 0.0; + + if (flagTab) { + /* For low densities, we use precomputed tables since the observed */ + /* values will all be very small. We shall thus need only a few */ + /* terms (expensive to compute) of the statistics. */ + util_Assert (res->nLimit > 0, + "smultin_CalcPowDivEqual BUG: res->nLimit <= 0"); + + for (j = jmin; j <= jmax; j++) { + /* A larger than expected counter needs terms that have not been */ + /* precomputed: Recompute missing terms. */ + while (Count[j] > res->nLimit) { + ReCalcTabFj (par, res, NbExp); + F = res->TabFj[s]; + } + *X += F[Count[j]]; + } + return; + } + + /* High densities: no precomputed tables */ + if (fabs (Delta - 1.0) < EPS_LAM) { + /* ChiSquare: Delta = 1 */ + for (j = jmin; j <= jmax; j++) { + temp = Count[j] - NbExp; + *X += temp * temp; + } + *X /= NbExp; + + } else if (fabs (Delta) < EPS_LAM) { + /* Loglikelihood ratio */ + for (j = jmin; j <= jmax; j++) { + if (Count[j] > 0) { + temp = Count[j]; + *X += temp * log (temp / NbExp); + } + } + *X *= 2.0; + + } else if (fabs (Delta + 1.0) < EPS_LAM) { + /* Collision test */ + for (j = jmin; j <= jmax; j++) { + if (Count[j] > 1) + *X += Count[j] - 1; + } + + } else if (Delta > (-1.0)) { + for (j = jmin; j <= jmax; j++) { + if (Count[j] > 0) { + temp = Count[j]; + *X += temp * (pow (temp / NbExp, Delta) - 1.0); + } + } + *X = (2.0 * *X) / (Delta * (Delta + 1.0)); + + } else + util_Error ("smultin_CalcPowDivEqual: Delta < -1"); +} + + +/*=======================================================================*/ + +static void CalcPoDiEqHache ( + smultin_Param *par, + smultin_Res *res, + DeltaIndex i, + double NbExp, /* Expected number per cell */ + smultin_CellType Nb[], /* Number of cells with s balls */ + long CountMax, /* Max number of balls in any cell */ + lebool flagTab, /* TRUE if use precomputed table */ + double *X /* Computed statistic */ + ) +/* + * Compute the Power Divergence statistic or the number of collisions in + * the sparse case. We use a hashing table of smultin_CellType. + */ +{ + double temp; + double *F = res->TabFj[i]; /* The precomputed table */ + double Delta = par->ValDelta[i]; + long s; + *X = 0.0; + + if (flagTab) { + /* For low densities, we use precomputed tables since the observed */ + /* values will all be very small. We shall thus need only a few */ + /* terms (expensive to compute) of the statistics. */ + util_Assert (res->nLimit > 0, "CalcPoDiEqHache BUG: res->nLimit <= 0"); + + /* A larger than expected counter needs terms that have not been */ + /* precomputed: Recompute missing terms. */ + while (CountMax > res->nLimit) { + ReCalcTabFj (par, res, NbExp); + F = res->TabFj[i]; + } + + for (s = 0; s <= CountMax; s++) { + *X += F[s] * Nb[s]; + } + return; + } + + /* High densities: no precomputed tables */ + if (fabs (Delta - 1.0) < EPS_LAM) { + /* ChiSquare: Delta = 1 */ + for (s = 1; s <= CountMax; s++) { + temp = s - NbExp; + *X += temp * temp * Nb[s]; + } + *X = *X / NbExp + NbExp * Nb[0]; + + } else if (fabs (Delta) < EPS_LAM) { + /* Delta = 0: Loglikelihood ratio */ + for (s = 1; s <= CountMax; s++) { + temp = s; + *X += temp * log (temp / NbExp) * Nb[s]; + } + *X *= 2.0; + + } else if (fabs (Delta + 1.0) < EPS_LAM) { + /* Collision test */ + for (s = 2; s <= CountMax; s++) { + *X += (s - 1.0) * Nb[s]; + } + + } else if (Delta > -1.0) { + for (s = 1; s <= CountMax; s++) { + temp = s; + *X += temp * (pow (temp / NbExp, Delta) - 1.0) * Nb[s]; + } + *X = 2.0 * *X / (Delta * (Delta + 1.0)); + + } else + util_Error ("CalcPoDiEqHache: Delta < -1"); +} + + +/*=======================================================================*/ + +static void CalcNbCells ( + smultin_Param *par, + smultin_Res *res, + long jmin, /* First cell */ + long jmax, /* Last cell */ + long CoMax /* Maximum number of balls in any cell */ + ) +/* + * Compute the number of cells containing j balls or more. + */ +{ + + long j; + smultin_CellType wb[smultin_MAXB + 1]; + long *Count = res->Count; /* Counters */ + smultin_CellType *Nb = res->Nb; /* Nb[j] = number of cells with j balls */ + + util_Assert (par->bmax <= smultin_MAXB, + "CalcNbCells: smultin_MAXB is too small"); + + for (j = 0; j <= smultin_MAXB; j++) + wb[j] = 0; + + if (res->Hashing) { + for (j = smultin_MAXB; j <= CoMax; j++) + wb[smultin_MAXB] += Nb[j]; + for (j = smultin_MAXB - 1; j >= 0; j--) + wb[j] = wb[j + 1] + Nb[j]; + + } else { + Nb[0] = 0; + for (j = jmin; j <= jmax; j++) { + if (Count[j] > smultin_MAXB) { + wb[smultin_MAXB] += 1; + } else + Nb[Count[j]] += 1; + } + wb[smultin_MAXB] += Nb[smultin_MAXB]; + for (j = smultin_MAXB - 1; j >= 0; j--) + wb[j] = wb[j + 1] + Nb[j]; + } + + /* the local array wb is necessary in the case N > 1 and Poisson since */ + /* then, the statistic used is the sum of the N Poisson statistics; */ + /* we are here summing the numbers for the N replications of the test. */ + + for (j = 0; j <= smultin_MAXB; j++) { + res->WbCells[j] += wb[j]; + res->NbCells[j] += Nb[j]; + } +} + + +/*=======================================================================*/ + +smultin_CellType smultin_GenerCellSerial (unif01_Gen *gen, + int r, int t, long d) +{ + int j; + smultin_CellType dr = d; + smultin_CellType Cell; + + Cell = unif01_StripL (gen, r, d); + for (j = 2; j <= t; j++) + Cell = Cell * dr + unif01_StripL (gen, r, d); + return Cell; +} + + +/*=======================================================================*/ + +smultin_CellType smultin_GenerCellSerial2 (unif01_Gen *gen, + int r, int t, long d) +{ + int j; + smultin_CellType dr = d; + smultin_CellType Cell; + + Cell = unif01_StripL (gen, r, d); + for (j = 2; j <= t; j++) { + Cell += dr * unif01_StripL (gen, r, d); + dr *= d; + } + return Cell; +} + + +/*=======================================================================*/ + +smultin_CellType smultin_GenerCellPermut (unif01_Gen *gen, + int r, int t, long junk) +{ + int s, i, j; + smultin_CellType Cell = 0; + double U[64]; + + for (j = 1; j <= t; j++) + U[j] = unif01_StripD (gen, r); + + for (i = t; i >= 2; i--) { + /* Find the U[s] = max (U[1],...,U[i]) */ + s = 1; + for (j = 2; j <= i; j++) { + if (U[j] > U[s]) + s = j; + } + Cell = Cell * i + (s - 1); + U[s] = U[i]; + } + return Cell; +} + + +/*=======================================================================*/ + +smultin_CellType smultin_GenerCellMax (unif01_Gen *gen, + int r, int t, long junk) +{ + int i, MaxI; + double U, MaxU = -1.0; + + /* Don't forget that cells are numbered from 0 to k - 1 */ + for (i = 0; i < t; i++) { + U = unif01_StripD (gen, r); + if (U > MaxU) { + MaxU = U; + MaxI = i; + } + } + return (smultin_CellType) MaxI; +} + + +/*=======================================================================*/ + +smultin_CellType smultin_GenerCellSerialBits (unif01_Gen * gen, + int r, int s, long L) +{ + const int t = L / s; + const smultin_CellType dr = num_TwoExp[s]; + smultin_CellType Cell; + int j; + + Cell = unif01_StripB (gen, r, s); + for (j = 2; j <= t; j++) + Cell = Cell * dr + unif01_StripB (gen, r, s); + return Cell; +} + + +/*=======================================================================*/ + +fmass_INFO smultin_CreateCollisions (long n, smultin_CellType k) +{ + const long nLim = 100000; + const int MaxIter = 32; + const double Epsilon = DBL_EPSILON; + const double DensityLim = 1.0001; + long J1, J0, j, i, Dim; + double terme, v, u, mu, sigma, x; + double kinv = 1.0 / k; + double *A; + fmass_INFO W; + + util_Assert (k > 0, "smultin_CreateCollisions: k <= 0"); + util_Assert (n > 0, "smultin_CreateCollisions: n <= 0"); + + /* Poisson Approximation */ + if ((n > nLim) && ((double) n / k <= DensityLim)) { + if ((double) n / k <= 0.1) { + int jj; + /* To avoid loss of precision when n/k --> 0, we expand the */ + /* formula below in a MacLaurin series */ + + jj = 3; + u = n - 1; + v = 2.0; + terme = (n * u) / (2.0 * k * k); + mu = terme; + while (fabs (terme / mu) > Epsilon && jj < MaxIter) { + u -= 1.0; + v += 1.0; + terme = -terme * u / (k * v); + mu += terme; + ++jj; + } + util_Assert (jj < MaxIter, + "smultin_CreateCollisions: limit MaxIter hit"); + + } else if (n <= 100) { + mu = ((double) n / k - 1.0) + pow (1.0 - 1.0 / k, (double) n); + + } else { + const int ITER = 10; + int i; + terme = kinv; + mu = terme; + + /* Compute the log of pow(1 - 1/k, n) by Maclaurin series */ + for (i = 2; i < ITER; i++) { + terme *= kinv; + mu += terme / i; + } + mu = ((double) n / k - 1.0) + exp (-n * mu); + } + + mu *= k; + W = fmass_CreatePoisson (mu); + /* W->paramR[0] now contains the Poisson parameter mu */ + W->paramR = util_Realloc (W->paramR, 3 * sizeof (double)); + W->paramR[1] = n; + W->paramR[2] = k; + W->paramI = util_Malloc (sizeof (long)); + W->paramI[0] = smultin_CollPoissonSparse; + return W; + } + + W = util_Malloc (sizeof (struct fmass_INFO_T)); + W->paramI = util_Malloc (sizeof (long)); + W->paramR = util_Calloc (5, sizeof (double)); + W->paramR[1] = n; + W->paramR[2] = k; + + + /* Normal Approximation */ + if (n > nLim) { + smultin_MultinomMuSigma (n, (double) k, 0.0, 0.0, smultin_MNTermeColl, + &mu, &sigma); + W->paramR[3] = mu; + W->paramR[4] = sigma; + W->paramI[0] = smultin_CollNormal; + W->pdf = NULL; + W->cdf = NULL; + W->smin = -1; + W->smax = -1; + return W; + } + + + /* Exact Distribution */ + A = util_Calloc ((size_t) n + 2, sizeof (double)); + for (j = 0; j <= n; j++) + A[j] = 0.0; + A[1] = 1.0; + J1 = J0 = 1; + for (j = 1; j <= n - 1; j++) { + ++J1; + i = J1; + while (i >= J0) { + x = i * kinv; + A[i] = x * A[i] + (1.0 + kinv - x) * A[i - 1]; + if (A[i] <= Epsilon) { + A[i] = 0.0; + if (i == J1) + --J1; + else if (i == J0) + ++J0; + } + --i; + } + } + Dim = n - J0 + 1; + W->pdf = util_Calloc ((size_t) Dim + 1, sizeof (double)); + W->cdf = util_Calloc ((size_t) Dim + 1, sizeof (double)); + + W->pdf[0] = A[n]; + W->cdf[0] = A[n]; + j = 0; + while (j < Dim && W->cdf[j] < 1.0) { + ++j; + W->pdf[j] = A[n - j]; + W->cdf[j] = W->pdf[j] + W->cdf[j - 1]; + } + while (j <= Dim) { + W->pdf[j] = A[n - j]; + W->cdf[j] = 1.0; + ++j; + } + util_Free (A); + W->paramI[0] = smultin_CollExact; + W->smin = 0; + W->smax = Dim; + return W; +} + + +/*-------------------------------------------------------------------------*/ + +void smultin_DeleteCollisions (fmass_INFO W) +{ + if (W == NULL) + return; + util_Free (W->paramI); + util_Free (W->paramR); + util_Free (W->pdf); + util_Free (W->cdf); + util_Free (W); +} + + +/*-------------------------------------------------------------------------*/ + +double smultin_CollisionsTerm (fmass_INFO W, long s) +{ + int par; + double z; + double Mu; + double Sigma; + + util_Assert (W != NULL, + "smultin_CollisionsTerm: fmass_INFO is NULL pointer"); + if (s < 0) + return 0.0; + par = W->paramI[0]; + + switch (par) { + case smultin_CollPoissonSparse: + return fmass_PoissonTerm2 (W, s); + case smultin_CollNormal: + Mu = W->paramR[3]; + Sigma = W->paramR[4]; + z = fdist_Normal2 ((s - Mu) / Sigma) - + fdist_Normal2 ((s - 1 - Mu) / Sigma); + return z; + case smultin_CollExact: + if (s > W->smax) + return 0.0; + return W->pdf[s]; + default: + util_Error ("smultin_CollisionsTerm: Not initialized"); + return 0.0; + } +} + + +/*-------------------------------------------------------------------------*/ + +double smultin_FDistCollisions (fmass_INFO W, long s) +{ + int par; + + util_Assert (W != NULL, + "smultin_FDistCollisions: fmass_INFO is NULL pointer"); + if (s < 0) + return 0.0; + par = W->paramI[0]; + + switch (par) { + case smultin_CollPoissonSparse: + return fdist_Poisson2 (W, s); + case smultin_CollNormal: + /* W->paramR[3] = Mu, W->paramR[4] = Sigma */ + return fdist_Normal2 ((s - W->paramR[3]) / W->paramR[4]); + case smultin_CollExact: + if (s > W->smax) + return 1.0; + return W->cdf[s]; + default: + util_Error ("smultin_FDistCollisions: Not initialized"); + return 0.0; + } +} + + +/*-------------------------------------------------------------------------*/ + +double smultin_FBarCollisions (fmass_INFO W, long s) +{ + return 1.0 - smultin_FDistCollisions (W, s - 1); +} + + +/*=======================================================================*/ + +static void InitPowDiv ( + smultin_Param *par, + smultin_Res *res, + long N, /* Number of replications */ + lebool Sparse, + long n, /* Number of balls */ + smultin_CellType z /* Number of urns (not quite for PowDivOver) */ + ) +/* + * Initialize the multinomial tests + */ +{ + + DeltaIndex s; + long j; + double NbExp; + char chaine[LENGTH + 1]; + char Str[LENGTH + 1]; + double Mu; /* Mean */ + double Sigma; /* Standard Deviation */ + + NbExp = (double) n / z; + if (z >= smultin_env.SeuilHash && NbExp < 1.0) + res->Hashing = TRUE; + else + res->Hashing = FALSE; + + res->EsCells[0] = N * (double) z * exp (-NbExp); + res->EsEmpty = res->EsCells[0]; + res->NbCells[0] = 0; + res->WbCells[0] = 0; + + util_Assert (par->NbDelta <= smultin_MAX_DELTA, + "par->NbDelta > smultin_MAX_DELTA"); + for (s = 0; s < par->NbDelta; s++) { + + if (Sparse) { + smultin_PowDivMom (par->ValDelta[s], n, (double) z, (double) n / z, + &Mu, &Sigma); + + } else if (fabs (par->ValDelta[s] + 1.0) > EPS_LAM) { + /* Non collision tests */ + smultin_PowDivMomCorChi (par->ValDelta[s], n, (double) z, &Mu, + &Sigma); + + } else { + /* Meaningless values as flags */ + Mu = -1.0; + Sigma = -1.0; + } + res->Mu[s] = Mu; + res->Sigma[s] = Sigma; + + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + /* Collision test */ + strncpy (Str, "The N statistic values for Collision:", (size_t) 64); + res->NbCollisions = 0.0; + for (j = 1; j <= smultin_MAXB; j++) { + res->NbCells[j] = 0; + res->WbCells[j] = 0; + } + /* The exact expected numbers (from Knuth) + temp = n * log ((z - 1.0)/z); + res->EsCells[0] = z * exp (temp); + res->EsCells[1] = n * res->EsCells[0] / (z - 1.0); + res->EsCells[2] = (n - 1.0) * res->EsCells[1] / (2.0*(z - 1.0)); + res->EsCells[>=3] = z - res->EsCells[0] - res->EsCells[1] - + res->EsCells[2]; + */ + + /* Expected numbers of urns with exactly j balls in the Poisson */ + /* approximation */ + for (j = 1; j <= smultin_MAXB; j++) { + res->EsCells[j] = (res->EsEmpty * pow (NbExp, (double) j)) + / num2_Factorial (j); + } + /* Expected numbers of urns with >= j balls */ + for (j = smultin_MAXB - 1; j >= 0; j--) { + res->EsCells[j] += res->EsCells[j + 1]; + } + + } else { + /* Non Collision tests */ + strncpy (Str, "The N statistic values for Delta = ", (size_t) 64); + sprintf (chaine, "%4.2f:", par->ValDelta[s]); + strncat (Str, chaine, (size_t) 10); + } + + statcoll_SetDesc (res->Collector[s], Str); + } +} + + +/*=======================================================================*/ + +static void WriteDataPowDiv ( + unif01_Gen *gen, + smultin_Param *par, + smultin_Res *res, + char *TestName, + long N, /* Number of replications */ + long n, /* Number of balls */ + int r, /* Drop r bits from each random number */ + long d, /* Number of segments on 1-dimensional line */ + int t, /* Dimension */ + lebool Sparse, + smultin_CellType k /* Number of urns */ +) +/* + * Write the parameters of the test + */ +{ + double EC; + double NbExp; + DeltaIndex s; + + swrite_Head (gen, TestName, N, n, r); + + if (par->GenerCell == smultin_GenerCellSerial) { + printf (", d = %4ld, t = %2d,\n Sparse = ", d, t); + util_WriteBool (Sparse, 6); + printf ("\n\n"); + printf (" GenerCell = smultin_GenerCellSerial\n"); + printf (" Number of cells = d^t = "); + } else if (par->GenerCell == smultin_GenerCellSerial2) { + printf (", d = %4ld, t = %2d,\n Sparse = ", d, t); + util_WriteBool (Sparse, 6); + printf ("\n\n"); + printf (" GenerCell = smultin_GenerCellSerial2\n"); + printf (" Number of cells = d^t = "); + } else if (par->GenerCell == smultin_GenerCellPermut) { + printf (", t = %2d,\n Sparse = ", t); + util_WriteBool (Sparse, 6); + printf ("\n\n"); + printf (" GenerCell = smultin_GenerCellPermut\n"); + util_Assert (!res->Over, + "MultinomialOver: non implemented for smultin_GenerCasePermut"); + printf (" Number of cells = t! = "); + } else if (par->GenerCell == smultin_GenerCellMax) { + printf (", k = %2d,\n Sparse = ", t); + util_WriteBool (Sparse, 6); + printf ("\n\n"); + printf (" GenerCell = smultin_GenerCellMax\n"); + printf (" Number of cells = k = "); + } + +#ifdef USE_LONGLONG + printf ("%18" PRIuLEAST64 "\n", k); +#else + printf ("%18.0f\n", k); +#endif + + util_Assert (k <= smultin_env.Maxk, "Multinomial: k is too large"); + printf (" Expected number per cell = "); + NbExp = (double) n / k; + if (NbExp < 1.0) + printf ("1 / %10.8g\n", 1.0 / NbExp); + else + printf ("%10.8g\n", NbExp); + + EC = (double) n * n / (2.0 * k); + if (Sparse) + printf (" EColl = n^2 / (2k) = %12.10g\n", EC); + printf (" Hashing = "); + util_WriteBool (res->Hashing, 6); + printf ("\n\n"); + if (par->NbDelta == 1 && par->ValDelta[0] == -1) + ; + else { + if (Sparse) { + printf (" For Delta > -1, we use the normal approximation\n"); + printf (" Mean and standard deviation: \n"); + } else { + printf (" For Delta > -1, we use the ChiSquare approximation\n"); + printf (" Correction factor of the ChiSquare: \n"); + } + } + + for (s = 0; s < par->NbDelta; s++) { + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + if ((Sparse == FALSE) && (res->Over == FALSE)) { + /* The collision test is meaningless when Sparse = FALSE */ + continue; + } + printf (" Collision test"); + } else { + printf (" Delta = %5.2g", par->ValDelta[s]); + } + if (!res->Over || fabs (par->ValDelta[s] + 1.0) > EPS_LAM) { + printf (", Mu = %14.8g", res->Mu[s]); + printf (", Sigma = %10.6g", res->Sigma[s]); + util_Assert (res->Sigma[s] > 0.0, "Negative Variance"); + } + printf ("\n"); + } + printf ("\n"); +} + + +/*=======================================================================*/ + +static void WriteDataMNBits ( + unif01_Gen *gen, + smultin_Param *par, + smultin_Res *res, + char *TestName, + long N, /* Number of replications */ + long n, /* Number of balls */ + int r, /* Drop r bits from each random number */ + long L, /* Number of bits for a cell */ + int s, /* Number of bits taken from each rand. num. */ + lebool Sparse, + smultin_CellType k, /* Number of cells = 2^L */ + lebool Over /* Overlapping case = TRUE */ +) +/* + * Write the parameters of the test + */ +{ + + double EC; + double NbExp; + DeltaIndex j; + + swrite_Head (gen, TestName, N, n, r); + + printf (", s = %2d, L = %4ld,\n Sparse = ", s, L); + util_WriteBool (Sparse, 6); + if (Over) + printf ("\n\n Number of bits = n = %1ld\n", n); + else + printf ("\n\n Number of bits = n*L = %1ld\n", L * n); + + /* printf (" GenerCell = smultin_GenerCellSerialBits\n"); */ + +#ifdef USE_LONGLONG + printf (" Number of cells = 2^L = %18" PRIuLEAST64 "\n", k); +#else + printf (" Number of cells = 2^L = %18.0f\n", k); +#endif + util_Assert (k <= smultin_env.Maxk, "Multinom: k is too large"); + + printf (" Expected number per cell = "); + NbExp = (double) n / k; + if (NbExp < 1.0) + printf ("1 / %10.8g\n", 1.0 / NbExp); + else + printf ("%10.8g\n", NbExp); + + EC = (double) n * n / (2.0 * k); + if (Sparse) + printf (" EColl = n^2 / (2k) = %12.10g\n", EC); + printf (" Hashing = "); + util_WriteBool (res->Hashing, 6); + printf ("\n\n"); + if (par->NbDelta == 1 && par->ValDelta[0] == -1) + ; + else { + if (Sparse) { + printf (" For Delta > -1, we use the normal approximation\n"); + printf (" Mean and standard deviation: \n"); + } else { + printf (" For Delta > -1, we use the ChiSquare approximation\n"); + printf (" Correction factor of the ChiSquare: \n"); + } + } + + for (j = 0; j < par->NbDelta; j++) { + if (fabs (par->ValDelta[j] + 1.0) < EPS_LAM) { + if ((Sparse == FALSE) && (res->Over == FALSE)) { + /* The collision test is meaningless when Sparse = FALSE */ + continue; + } + printf (" Collision test"); + } else { + printf (" Delta = %5.2g", par->ValDelta[j]); + } + if (!res->Over || fabs (par->ValDelta[j] + 1.0) > EPS_LAM) { + printf (", Mu = %14.8g", res->Mu[j]); + printf (", Sigma = %10.6g\n", res->Sigma[j]); + util_Assert (res->Sigma[j] > 0.0, "Negative Variance"); + } + } + printf ("\n"); +} + + +/*=======================================================================*/ + +static void CalcResultsPowDiv ( + smultin_Param *par, + smultin_Res *res, + DeltaIndex s, /* Which statistic */ + long n, /* Number of balls */ + lebool Sparse, + smultin_CellType DegreLib, /* Number of degrees of freedom */ + double Mu, /* Mean */ + double SumX[], + double SumX2[] + ) +{ + + double pR, pL; + double pCollLeft; /* Left p-value of Collision test */ + double pCollRight; /* Right p-value of Collision test */ + int j; + statcoll_Collector *SC = res->Collector[s]; + fmass_INFO Mass1, Mass2; + double V[1]; + long N = SC->NObs; + double racN; + + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + /* Collision Test */ + if (!Sparse) { + res->pColl = -1.0; + res->pCollLeft = -1.0; + res->pCollRight = -1.0; + return; + } + /* The total number of collisions of N replications is NbCollisions */ + Mass1 = smultin_CreateCollisions (n, DegreLib + 1); + if (N == 1) { + pCollLeft = smultin_FDistCollisions (Mass1, (long) res->NbCollisions); + pCollRight = smultin_FBarCollisions (Mass1, (long) res->NbCollisions); + res->pCollLeft = pCollLeft; + res->pCollRight = pCollRight; + res->sVal2[s][gofw_Mean] = SumX[s]; + res->pVal2[s][gofw_Mean] = fbar_Normal1 (res->sVal2[s][gofw_Mean]); + } else { + if (Mu < smultin_env.SeuilEColl) { + Mass2 = fmass_CreatePoisson (N * Mu); + pCollLeft = fdist_Poisson2 (Mass2, (long) res->NbCollisions); + pCollRight = fbar_Poisson2 (Mass2, (long) res->NbCollisions); + fmass_DeletePoisson (Mass2); + } + } + smultin_DeleteCollisions (Mass1); + res->pColl = gofw_pDisc (pCollLeft, pCollRight); + + /* Total number of empty urns of the N replications: res->NbCells[0] + Mass2 = fmass_CreatePoisson (res->EsEmpty); + pL = fdist_Poisson2 (Mass2, res->NbCells[0]); + pR = fbar_Poisson2 (Mass2, res->NbCells[0]); + fmass_DeletePoisson (Mass2); + res->pEmpty = gofw_pDisc (pL, pR); */ + + /* Since we can have very large values of res->EsEmpty (2^63), we + compute the Poisson pL, pR by calling the Gamma distribution, since + our Poisson takes a long argument */ + + if (res->NbCells[0] <= EMPTYLIM && res->EsEmpty <= EMPTYLIM) { + pL = fbar_Gamma (res->NbCells[0] + 1.0, 12, res->EsEmpty); + if ((res->NbCells[0] <= 0) || (res->NbCells[0] > res->NbCellsTotal)) + pR = 1.0; + else + pR = fdist_Gamma ((double) (res->NbCells[0]), 12, res->EsEmpty); + res->pEmpty = gofw_pDisc (pL, pR); + } + /* The total number of urns containing >= j balls */ + for (j = 2; j <= par->bmax; j++) { + Mass2 = fmass_CreatePoisson ((double) (res->EsCells[j])); + pL = fdist_Poisson2 (Mass2, (long) res->WbCells[j]); + pR = fbar_Poisson2 (Mass2, (long) res->WbCells[j]); + fmass_DeletePoisson (Mass2); + res->pWb[j] = gofw_pDisc (pL, pR); + } + + } else if (Sparse) { + /* Tests other than Collision test */ + gofw_ActiveTests1 (SC->V, N, wdist_Normal, (double *) NULL, + res->sVal2[s], res->pVal2[s]); + + } else { + V[0] = DegreLib; + gofw_ActiveTests1 (SC->V, N, wdist_ChiSquare, V, + res->sVal2[s], res->pVal2[s]); + } + + /* Now compute the mean and the correlation with their p-values. */ + if (N > 1) { + racN = sqrt ((double) N); + res->sVal2[s][gofw_Mean] = SumX[s] / racN; + res->pVal2[s][gofw_Mean] = fbar_Normal1 (res->sVal2[s][gofw_Mean]); + res->sVal2[s][gofw_Cor] = racN * SumX2[s] / (N - 1); + res->pVal2[s][gofw_Cor] = fbar_Normal1 (res->sVal2[s][gofw_Cor]); + } +} + + +/*=======================================================================*/ + +static void WriteResultsPowDiv ( + smultin_Param *par, + smultin_Res *res, + DeltaIndex s, + long N, + double EColl, /* Approximate expected number of collisions */ + smultin_CellType DegreLib, /* Number of degrees of freedom */ + lebool Sparse, + double Mu /* Exact expected mean */ + ) +{ + long j; + printf ("-----------------------------------------------\n"); + printf ("Test Results for "); + + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) + printf ("Collisions\n\n"); + else { + printf ("Delta = %8.4f\n\n", par->ValDelta[s]); + if (N == 1) { + if (!Sparse) { +#ifdef USE_LONGLONG + printf ("Number of degrees of freedom : %4" PRIuLEAST64 + "\n", DegreLib); +#else + printf ("Number of degrees of freedom : %4.0f\n", + DegreLib); +#endif + + } + printf ("Value of the statistic :"); + gofw_Writep2 (res->sVal2[s][gofw_Mean], res->pVal2[s][gofw_Mean]); + + } else { + gofw_WriteActiveTests0 (N, res->sVal2[s], res->pVal2[s]); + printf ("For the sum of the N observations, we use\n"); + printf (" the Normal approximation:\n"); + printf ("Standardized empirical mean :"); + gofw_Writep2 (res->sVal2[s][gofw_Mean], res->pVal2[s][gofw_Mean]); + printf ("Standardized empirical correlation :"); + gofw_Writep2 (res->sVal2[s][gofw_Cor], res->pVal2[s][gofw_Cor]); + } + } + + if (swrite_Collectors) { + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) + statcoll_Write (res->Collector[s], 5, 14, 0, 0); + else + statcoll_Write (res->Collector[s], 5, 14, 4, 3); + } + + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + if (N > 1 && Mu < smultin_env.SeuilEColl) { + printf ("For the total number of collisions, we use\n" + " the Poisson approximation:\n"); + /* "Value of N * EColl : "); num_WriteD(N * EColl, 11, 2, 2); */ + printf ("Expected number of collisions = N*Mu : "); + num_WriteD (N * Mu, 11, 2, 2); + printf ("\nObserved number of collisions : %8ld\n", + (long) res->NbCollisions); + gofw_Writep1 (res->pColl); + printf ("\n"); + } + if (N == 1) { + /* printf ("Value of EColl : "); + num_WriteD(EColl, 11, 2, 2);*/ + printf ("Expected number of collisions = Mu : "); + num_WriteD (Mu, 11, 2, 2); + printf ("\nObserved number of collisions : %8ld\n", + (long) res->NbCollisions); + gofw_Writep1 (res->pColl); + } + printf ("-----------------------------\n"); + printf ("Total number of cells containing j balls\n\n"); + for (j = 0; j <= smultin_MAXB / 2; j++) { + printf (" j = %2ld", j); + +#ifdef USE_LONGLONG + printf (" : %16" PRIuLEAST64 "\n", + res->NbCells[j]); +#else + printf (" : %16.0f\n", res->NbCells[j]); +#endif + } + + if (par->bmax >= 0 && res->NbCells[0] <= EMPTYLIM && + res->EsEmpty <= EMPTYLIM) { + printf ("\n-----------------------------\n" + "Results for the number of empty cells\n\n" + "Expected number : "); + num_WriteD (res->EsEmpty, 19, 2, 2); + printf ("\nObserved number :"); +#ifdef USE_LONGLONG + printf (" %16" PRIuLEAST64 "\n", res->NbCells[0]); +#else + printf (" %16.0f\n", res->NbCells[0]); +#endif + gofw_Writep1 (res->pEmpty); + } + if (par->bmax >= 1) { + printf ("\n-----------------------------\n"); + printf ("Results for the number of cells containing at least" + " j balls\n\n"); + for (j = 2; j <= par->bmax; j++) { + printf (" j = %2ld\n", j); + printf ("Expected number : %11.2f\n", + (double) (res->EsCells[j])); + printf ("Observed number : %8.0f\n", + (double) (res->WbCells[j])); + gofw_Writep1 (res->pWb[j]); + } + } + } + printf ("\n"); +} + + +/*=======================================================================*/ + +static void UpdateCountHash ( + smultin_Res *res, + smultin_CellType Ind, + long Hache, + double UnSurHache, + long *CoMax, + lebool DimFlag /* TRUE for t-1 dimension, FALSE for t dim. */ + ) +/* + * We use hashing. A ball falls in cell Ind: update counters + * Speed is essential here. + */ +{ + long *Count; + smultin_CellType *Cell; + smultin_CellType *Nb; + long Decal, Pos, Tem; + + if (DimFlag == FALSE) { + Count = res->Count; /* Counters in t dimensions */ + Cell = res->Cell; /* Cell numbers in t dimensions */ + Nb = res->Nb; + } else { + Count = res->Count1; /* Counters in t - 1 dimensions */ + Cell = res->Cell1; /* Cell numbers in t - 1 dimensions */ + Nb = res->Nb1; + } + +#ifdef USE_LONGLONG + Pos = Ind % Hache; +#else + Tem = Ind * UnSurHache; + Pos = Ind - (double) Hache * Tem; +#endif + + Decal = HACHE2 + Pos % HACHE2; + + /* Insert in hashing table; if sign bit is 1, cell is empty. */ + for (;;) { +#ifdef USE_LONGLONG + if (Cell[Pos] & MASK64) { +#else + if (Cell[Pos] < 0.0) { +#endif + Cell[Pos] = Ind; + break; + } + if (Cell[Pos] == Ind) + break; + Pos = (Pos + Decal) % Hache; + } + + Nb[Count[Pos]] -= 1; + ++(Count[Pos]); + if (Count[Pos] > *CoMax) + ++(*CoMax); + if (DimFlag == FALSE) { + if (*CoMax > res->NbSize) { + int i; + res->NbSize *= 2; + res->Nb = util_Realloc (res->Nb, + (res->NbSize + 1) * sizeof (smultin_CellType)); + Nb = res->Nb; + for (i = res->NbSize / 2 + 1; i <= res->NbSize; i++) + Nb[i] = 0; + } + } else { + if (*CoMax > res->Nb1Size) { + int i; + res->Nb1Size *= 2; + res->Nb1 = util_Realloc (res->Nb1, + (res->Nb1Size + 1) * sizeof (smultin_CellType)); + Nb = res->Nb1; + for (i = res->Nb1Size / 2 + 1; i <= res->Nb1Size; i++) + Nb[i] = 0; + } + } + Nb[Count[Pos]] += 1; +} + + +/*=======================================================================*/ + +static void GenerAllPointsHash (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long n, int r, long d, int t, long *pCoMax, + long Hache, double UnSurHache) +/* + * Generate all n points in hashing case + */ +{ + smultin_CellType Indice; /* Cell number */ + long i; + + for (i = 0; i <= Hache; i++) +#ifdef USE_LONGLONG + res->Cell[i] = MASK64; /* Empty cells */ +#else + res->Cell[i] = -1.0; /* Empty cells */ +#endif + *pCoMax = 0; + for (i = 1; i <= n; i++) { + Indice = par->GenerCell (gen, r, t, d); + UpdateCountHash (res, Indice, Hache, UnSurHache, pCoMax, FALSE); + } +} + + +/*=======================================================================*/ + +static void GenerAllPoints2 (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long n, int r, long d, int t) +/* + * Generate all n points; no hashing + */ +{ + smultin_CellType Indice; /* Cell number */ + long i; + for (i = 1; i <= n; i++) { + Indice = par->GenerCell (gen, r, t, d); + ++res->Count[(long) Indice]; + } +} + + +/*=======================================================================*/ + +static void GenerAllPointsHashBits (unif01_Gen *gen, smultin_Res *res, + long n, int r, long L, int s, long *pCoMax, long Hache, + double UnSurHache) +/* + * Generate all n points of L bits each in hashing case + */ +{ + smultin_CellType Indice; /* Cell number */ + long i; + int j; + unsigned long Z; + const int t = s / L; /* Number of points in a U01 */ + const long Last = n % t; + const unsigned long MASK = num_TwoExp[L] - 1.0; + + for (i = 0; i <= Hache; i++) +#ifdef USE_LONGLONG + res->Cell[i] = MASK64; /* Empty cells */ +#else + res->Cell[i] = -1.0; /* Empty cells */ +#endif + *pCoMax = 0; + + for (i = 1; i <= n / t; i++) { + Z = unif01_StripB (gen, r, s); + for (j = 1; j <= t; j++) { + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache, UnSurHache, pCoMax, FALSE); + Z >>= L; + } + } + /* The last points */ + if (Last > 0) { + Z = unif01_StripB (gen, r, s); + /* The most significant bits make the points */ + for (j = 1; j <= t - Last; j++) + Z >>= L; + for (j = 1; j <= Last; j++) { + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache, UnSurHache, pCoMax, FALSE); + Z >>= L; + } + } +} + + +/*=======================================================================*/ + +static void GenerAllPoints2Bits (unif01_Gen * gen, smultin_Res * res, + long n, int r, long L, int s) +/* + * Generate all n points of L bits each; no hashing + */ +{ + long i; + int j; + unsigned long Z; + const int t = s / L; + const long Last = n % t; + const unsigned long MASK = num_TwoExp[L] - 1.0; + + for (i = 1; i <= n / t; i++) { + Z = unif01_StripB (gen, r, s); + for (j = 1; j <= t; j++) { + ++res->Count[Z & MASK]; + Z >>= L; + } + } + /* The last points */ + if (Last > 0) { + Z = unif01_StripB (gen, r, s); + /* The most significant bits make the points */ + for (j = 1; j <= t - Last; j++) + Z >>= L; + for (j = 1; j <= Last; j++) { + ++res->Count[Z & MASK]; + Z >>= L; + } + } +} + + +/*=======================================================================*/ + +static void Multinom (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long N, long n, int r, long d, int t, lebool Sparse, + smultin_CellType k, char *TestName, chrono_Chrono * Timer, lebool BitFlag) +/* + * If BitFlag = TRUE, this procedure was called from smultin_MultinomialBits, + * otherwise from smultin_Multinomial. + * In the case BitFlag = TRUE, t stand for s, d for L. Otherwise, all + * parameters are as in smultin_Multinomial. + * + * Sparse: normal approximation for Delta != -1. + * Non sparse: chi-square approximation. + * Collisions test meaningfull only in Sparse case. + */ +{ + long Seq; /* Replication number */ + double NbExp; /* Expected number per cell */ + double EColl; /* Approx. expected number of collisions */ + long Hache; /* Hashing module */ + double UnSurHache; + double HacheLR; /* Dimension of hashing table */ + long i; + long CoMax; /* Maximum number of balls in any cell */ + double X0, X; /* Statistics */ + DeltaIndex j; /* Which power divergence case */ + double SumX2[smultin_MAX_DELTA]; + double SumX[smultin_MAX_DELTA]; + double X0Pre[smultin_MAX_DELTA]; /* For empirical mean and correlation */ + lebool localRes = FALSE; + + NbExp = (double) n / k; + EColl = (double) n / (2.0 * k) * n; + + if (par == NULL) + par = &smultin_ParamDefault; + if (res == NULL) { + localRes = TRUE; + res = smultin_CreateRes (par); + } else + /* Clean memory from a previous call */ + CleanPD (res); + + InitRes (par, res, N); + res->NbCellsTotal = k; + res->Over = FALSE; + InitPowDiv (par, res, N, Sparse, n, k); + + if (swrite_Basic) { + if (BitFlag) + /* Here t stand for s, d for L */ + WriteDataMNBits (gen, par, res, TestName, N, n, r, d, t, Sparse, k, + FALSE); + else + WriteDataPowDiv (gen, par, res, TestName, N, n, r, d, t, Sparse, k); + } + /* Initialize the hashing constants and tables */ + CalcTabFj (par, res, Sparse, (double) k, NbExp); + for (j = 0; j < par->NbDelta; j++) { + SumX[j] = 0.0; + SumX2[j] = 0.0; + X0Pre[j] = 0.0; + } + if (res->Hashing) + Hache = tables_HashPrime (n, smultin_env.HashLoad); + else + Hache = k; + HacheLR = Hache; + UnSurHache = 1.0 / HacheLR; + res->CountSize = Hache; + res->Count = util_Calloc ((size_t) Hache + 2, sizeof (long)); + res->Cell = util_Calloc ((size_t) Hache + 2, sizeof (smultin_CellType)); + res->NbSize = 8000; + res->Nb = util_Calloc ((size_t) res->NbSize + 2, sizeof (smultin_CellType)); + + /* Generate the points or balls */ + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i <= Hache; i++) + res->Count[i] = 0; + res->Nb[0] = k; + for (i = 1; i <= res->NbSize; i++) + res->Nb[i] = 0; + + if (BitFlag) { + /* Here, d stands for L, and t for s */ + if (res->Hashing) + GenerAllPointsHashBits (gen, res, n, r, d, t, &CoMax, Hache, + UnSurHache); + else + GenerAllPoints2Bits (gen, res, n, r, d, t); + } else { + if (res->Hashing) + GenerAllPointsHash (gen, par, res, n, r, d, t, &CoMax, Hache, + UnSurHache); + else + GenerAllPoints2 (gen, par, res, n, r, d, t); + } + + if (swrite_Counters) { + if (res->Hashing) +#ifdef USE_LONGLONG + tables_WriteTabULL (res->Nb, 0, CoMax, 5, 12, + "Observed numbers in res->Nb"); +#else + tables_WriteTabD (res->Nb, 0, CoMax, 5, 12, 0, 0, + "Observed numbers in res->Nb"); +#endif + else if (!Sparse) + tables_WriteTabL (res->Count, 0, res->CountSize - 1, 5, 10, + "Observed numbers in res->Count"); + } + + /* The points have been generated; now compute the statistics */ + /* if (par->bmax >= 0) */ + CalcNbCells (par, res, 0, Hache - 1, CoMax); + + for (j = 0; j < par->NbDelta; j++) { + if (res->Hashing) { + CalcPoDiEqHache (par, res, j, NbExp, res->Nb, CoMax, TRUE, &X); + } else if (res->flagTab) { + CalcPowDivEqual (par, res, j, NbExp, res->Count, + 0, (long) k - 1, TRUE, &X); + } else { + CalcPowDivEqual (par, res, j, NbExp, res->Count, + 0, (long) k - 1, FALSE, &X); + } + X0 = (X - res->Mu[j]) / res->Sigma[j]; + if (fabs (par->ValDelta[j] + 1.0) < EPS_LAM) { + res->Nb[0] = k + X - n; + res->NbCollisions += X; + statcoll_AddObs (res->Collector[j], X); + } else { + statcoll_AddObs (res->Collector[j], X0); + if (!Sparse) + X0 = (X0 - k + 1.0) / sqrt (2.0 * k - 2.0); + } + /* Now, X0 is standardized, with mean 0 and variance 1. */ + /* The following is to compute the mean and correlation. */ + SumX[j] += X0; + SumX2[j] += X0 * X0Pre[j]; + X0Pre[j] = X0; + } + } + + for (j = 0; j < par->NbDelta; j++) { + if ((Sparse == FALSE) && (fabs (par->ValDelta[j] + 1.0) < EPS_LAM)) + continue; + CalcResultsPowDiv (par, res, j, n, Sparse, k - 1, res->Mu[j], + SumX, SumX2); + } + + if (swrite_Basic) { + for (j = 0; j < par->NbDelta; j++) { + if ((Sparse == FALSE) && (fabs (par->ValDelta[j] + 1.0) < EPS_LAM)) { + util_Warning (TRUE, + "The collision test is meaningless when Sparse = FALSE"); + continue; + } + WriteResultsPowDiv (par, res, j, N, EColl, k - 1, Sparse, res->Mu[j]); + } + swrite_Final (gen, Timer); + } + if (localRes) + smultin_DeleteRes (res); +} + + +/*=======================================================================*/ + +void smultin_Multinomial (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long N, long n, int r, long d, int t, lebool Sparse) +/* + * Sparse: normal approximation for Delta != -1. + * Non sparse: chi-square approximation. + * Collisions test meaningfull only in Sparse case. + */ +{ + smultin_CellType k; /* Number of cells */ + int i; + chrono_Chrono *Timer; + char *TestName = "smultin_Multinomial test"; + + Timer = chrono_Create (); + if (NULL == par) + par = &smultin_ParamDefault; + + if (par->GenerCell == smultin_GenerCellSerial || + par->GenerCell == smultin_GenerCellSerial2) { + util_Assert (d > 1, "smultin_Multinomial: d <= 1"); + util_Assert (t > 0, "smultin_Multinomial: t < 1"); + k = d; + for (i = 2; i <= t; i++) + k *= d; + + } else if (par->GenerCell == smultin_GenerCellPermut) { + util_Assert (t > 1, "Permutation... smultin_Multinomial: t < 2"); +#ifdef USE_LONGLONG + /* longlong has more bits of precision than double */ + util_Assert (t <= 20, "smultin_GenerCellPermut: t > 20"); + if (t == 20) { + k = num2_Factorial (18) * 19 * 20; + } else if (t == 19) { + k = num2_Factorial (18) * 19; + } else + k = num2_Factorial (t); +#else + util_Assert (t <= 18, "smultin_GenerCellPermut: t > 18"); + k = num2_Factorial (t); +#endif + + } else if (par->GenerCell == smultin_GenerCellMax) { + util_Assert (t > 1, "GenerCellMax... smultin_Multinomial: t < 2"); + k = t; + + } else + util_Error ("smultin_Multinomial: par->GenerCell not initialized"); + + util_Assert (k <= smultin_env.Maxk, + "smultin_Multinomial: k > smultin_env.Maxk"); + util_Assert (n > 4, "smultin_Multinomial: n <= 4"); +#ifndef USE_LONGLONG + util_Assert ((double) n / k > 1.0 / num_TwoExp[31], + "smultin_Multinomial: NbExp <= 1/2^31"); +#endif + Multinom (gen, par, res, N, n, r, d, t, Sparse, k, TestName, Timer, FALSE); + chrono_Delete (Timer); +} + + +/*=======================================================================*/ + +static void InitCollOver ( + smultin_Res *res, + long n, /* Number of balls */ + smultin_CellType k, /* Number of cells = d^t */ + long d, /* One-dim. segment */ + int t, /* dimension */ + double *Esperance, /* Expectation value */ + double *StandDev /* Standard deviation */ + ) +/* + * Initialize the collisionOver test + */ +{ + const double Epsilon = 1.0E-20; + const int MaxIter = 32; + long j; + double terme; + double v; + double COverDelta; + + res->NbCollisions = 0.0; + res->NbCells[0] = 0; + res->CollApprox = smultin_CollNotInit; + *Esperance = -1.0; + *StandDev = -1.0; + COverDelta = (double) (n - t + 1)/ k; + + if (COverDelta > smultin_env.SeuilCOverNorSup && + COverDelta < smultin_env.SeuilCOverDense) { + res->CollApprox = smultin_CollPoissonDense; + *Esperance = k * exp (-COverDelta); + + } else if (COverDelta >= smultin_env.SeuilCOverNorInf && + COverDelta <= smultin_env.SeuilCOverNorSup) { + res->CollApprox = smultin_CollNormal; + *Esperance = k * (COverDelta - 1.0 + exp (-COverDelta)); + terme = k * exp (-COverDelta) * (1.0 - (1.0 + COverDelta) * + exp (-COverDelta)); + /* The general formula given by Marsaglia is not very good; the above + formula used Rukhin's correction. The following values were obtained + by Marsaglia by simulation for the special cases: */ + if (n == 2097152 && k == 1048576) { + if ((d == 32) && (t == 4)) { + terme = 295.0 * 295.0; /* OQSO test */ + } + if ((d == 4) && (t == 10)) { + terme = 339.0 * 339.0; /* DNA test */ + } + } + if (terme < 0.0) { + util_Warning (TRUE, "***** InitCollOver ******* VARIANCE < 0 !!"); + *Esperance = -1.0; + *StandDev = -1.0; + } else + *StandDev = sqrt (terme); + + } else if (COverDelta < smultin_env.SeuilCOverSparse) { + res->CollApprox = smultin_CollPoissonSparse; + if (COverDelta < 0.1) { + /* Avoid loss of precision when COverDelta --> 0 */ + j = 3; + v = 2.0; + terme = COverDelta * COverDelta / 2.0; + *Esperance = terme; + while (fabs (terme / *Esperance) > Epsilon && j < MaxIter) { + v += 1.0; + terme = -terme * COverDelta / v; + *Esperance += terme; + ++j; + } + *Esperance *= k; + } else + *Esperance = k * (COverDelta - 1.0 + exp (-COverDelta)); + } +} + + +/*=======================================================================*/ + +static void WriteDataCollOver ( + smultin_Res *res, + long n, /* Number of balls */ + smultin_CellType k, /* Number of cells */ + double Esperance, /* Expectation value */ + double StandDev /* Standard deviation */ + ) +{ + double COverDelta = (double) (n) / k; + printf (" CollisionOver: density = n / k = "); + if (COverDelta >= 1.0) + num_WriteD (COverDelta, 10, 2, 2); + else { + printf (" 1 / "); + num_WriteD (1.0 / COverDelta, 10, 2, 1); + } + printf ("\n"); + if (res->CollApprox == smultin_CollPoissonDense) { + printf (" Expected number of empty cells = Mu = "); + num_WriteD (Esperance, 10, 2, 2); + printf ("\n"); + } else if (res->CollApprox == smultin_CollNormal) { + printf (" Expected number of collisions = "); + num_WriteD (Esperance, 10, 2, 2); + printf ("\n"); + printf (" Expected standard deviation = "); + num_WriteD (StandDev, 10, 2, 2); + } else if (res->CollApprox == smultin_CollPoissonSparse) { + printf (" Expected number of collisions = Mu = "); + num_WriteD (Esperance, 10, 2, 2); + } else { + printf (" NO TEST FOR THIS DENSITY n/k"); + } + printf ("\n\n"); +} + + +/*=======================================================================*/ + +static void CalcResCollOver ( + smultin_Res *res, + DeltaIndex s, + long N, /* Number of replications */ + double Esperance, /* Expectation value */ + double SumX, + double SumX2 + ) +/* + * Compute results for CollisionOver test + */ +{ + double pCollLeft; /* Left p-value of Collision test */ + double pCollRight; /* Right p-value of Collision test */ + double racN; + fmass_INFO W; + statcoll_Collector *Q = res->Collector[s]; + + res->Mu[s] = Esperance; + if (Esperance < 0.0) { + res->pVal2[s][gofw_KSP] = -1.0; + res->pVal2[s][gofw_Mean] = -1.0; + res->pColl = -1.0; + return; + } + + switch (res->CollApprox) { + + case smultin_CollNormal: + gofw_ActiveTests1 (Q->V, Q->NObs, wdist_Normal, (double *) NULL, + res->sVal2[s], res->pVal2[s]); + /* This line is necessary for the array pd from module tmultin */ + res->pColl = res->pVal2[s][gofw_Mean]; + if (N > 1) { + racN = sqrt ((double) N); + /* Calculate the mean, the correlation and their p-values */ + res->sVal2[s][gofw_Mean] = SumX / racN; + res->pVal2[s][gofw_Mean] = fbar_Normal1 (res->sVal2[s][gofw_Mean]); + res->sVal2[s][gofw_Cor] = racN * SumX2 / (N - 1); + res->pVal2[s][gofw_Cor] = fbar_Normal1 (res->sVal2[s][gofw_Cor]); + /* This line is necessary for the array pd from module tmultin */ + res->pColl = res->pVal2[s][gofw_KSP]; + } + break; + + case smultin_CollPoissonSparse: + /* The sum of N Poisson obeys also a Poisson law */ + W = fmass_CreatePoisson (N * Esperance); + pCollLeft = fdist_Poisson2 (W, (long) res->NbCollisions); + pCollRight = fbar_Poisson2 (W, (long) res->NbCollisions); + res->pColl = gofw_pDisc (pCollLeft, pCollRight); + fmass_DeletePoisson (W); + break; + + case smultin_CollPoissonDense: + /* The sum of N Poisson obeys also a Poisson law */ +#if 0 + W = fmass_CreatePoisson (N * Esperance); + pCollLeft = fdist_Poisson2 (W, res->NbCells[0]); + pCollRight = fbar_Poisson2 (W, res->NbCells[0]); + res->pColl = res->pEmpty = gofw_pDisc (pCollLeft, pCollRight); + fmass_DeletePoisson (W); +#endif + /* Since we can have very large values of res->NbCells[0]) (2^52), we + compute the Poisson pCollLeft, pCollRight by calling the Gamma + distribution, since our Poisson takes a long (31 bits) argument. */ + + if (res->NbCells[0] <= EMPTYLIM && N * Esperance <= EMPTYLIM) { + pCollLeft = fbar_Gamma (res->NbCells[0] + 1.0, 15, N * Esperance); + if ((res->NbCells[0] <= 0) || (res->NbCells[0] > res->NbCellsTotal)) + pCollRight = 1.0; + else + pCollRight = fdist_Gamma ((double) (res->NbCells[0]), 15, + N * Esperance); + res->pEmpty = res->pColl = gofw_pDisc (pCollLeft, pCollRight); + } + break; + + default: + util_Error ("res->CollApprox: Impossible case"); + } +} + + +/*=======================================================================*/ + +static void WriteResCollOver ( + smultin_Param *par, + smultin_Res *res, + DeltaIndex s, + long N, /* Number of replications */ + double EColl, + double Esperance + ) +/* + * Write results for CollisionOver test + */ +{ + int j; + printf ("\n-----------------------------------------------\n" + "Results of CollisionOver test:\n\n"); + if (Esperance < 0.0) { + util_Warning (TRUE, "TEST NON IMPLEMENTED FOR THESE PARAMETERS"); + return; + } + + switch (res->CollApprox) { + + case smultin_CollNormal: + printf ("NORMAL approximation:\n"); + if (N == 1) { + printf ("Value of the standardized statistic :"); + gofw_Writep2 (res->sVal2[s][gofw_Mean], res->pVal2[s][gofw_Mean]); + } else { + gofw_WriteActiveTests0 (N, res->sVal2[s], res->pVal2[s]); + printf ("Standardized empirical mean :"); + gofw_Writep2 (res->sVal2[s][gofw_Mean], res->pVal2[s][gofw_Mean]); + printf ("Standardized empirical correlation :"); + gofw_Writep2 (res->sVal2[s][gofw_Cor], res->pVal2[s][gofw_Cor]); + } + break; + + case smultin_CollPoissonSparse: + /* The sum of N Poisson random variables is also a Poisson r. v. */ + printf ("POISSON approximation :\n"); + /* "Value of N * EColl : "); num_WriteD (N * EColl, 11, 2, 2); */ + printf ("Expected number of collisions = N*Mu : "); + num_WriteD (N * Esperance, 11, 2, 2); + printf ("\nObserved number of collisions : %8ld\n", + (long) res->NbCollisions); + gofw_Writep1 (res->pColl); + break; + + case smultin_CollPoissonDense: + /* The sum of N Poisson random variables is also a Poisson r. v. */ + printf ("POISSON approximation :\n" + "Expected number of empty cells = N*Mu : "); + num_WriteD (N * Esperance, 18, 2, 2); +#ifdef USE_LONGLONG + printf ("\nObserved number of empty cells : %15" PRIuLEAST64 "\n", + res->NbCells[0]); +#else + printf ("\nObserved number of empty cells : %15.0f\n", + res->NbCells[0]); +#endif + gofw_Writep1 (res->pColl); + break; + + default:; + util_Error ("smultin_WriteResCollOver: IMPOSSIBLE CASE"); + break; + } + + + if (swrite_Collectors) + statcoll_Write (res->Collector[s], 5, 14, 2, 1); + + printf ("-----------------------------\n" + "Total number of cells containing j balls\n\n"); + for (j = 0; j <= smultin_MAXB / 2; j++) { + printf (" j = %2d", j); +#ifdef USE_LONGLONG + printf (" : %16" PRIuLEAST64 "\n", + res->NbCells[j]); +#else + printf (" : %16.0f\n", res->NbCells[j]); +#endif + } + printf ("\n"); +} + + +/*=======================================================================*/ + +static void OverDenseGenere ( + unif01_Gen *gen, + smultin_Res *res, + long n, /* Number of balls */ + int r, + long d, /* Division of 1-dim interval */ + int t, /* Dimension */ + long k, /* Number of urns in t dimensions */ + long k1 /* Number of urns in t - 1 dimensions */ + ) +/* + * Generate the n balls for smultin_MultinomialOver in the dense + * case, and fill the counters Count and Count1 + */ +{ + long element; + long Indice; + long j; + long Premier[MAX_DIM]; + long *Count = res->Count; /* Counters in t dimensions */ + long *Count1 = res->Count1; /* Counters in t - 1 dimensions */ + smultin_CellType *Nb = res->Nb; + + util_Assert (t < MAX_DIM, "OverDenseGenere: t > 64"); + for (j = 1; j <= res->NbSize; j++) + Nb[j] = 0; + Nb[0] = k; + for (j = 0; j <= k; j++) + Count[j] = 0; + for (j = 0; j <= k1; j++) + Count1[j] = 0; + + /* Generation of the first (t - 1) random numbers for the first tuple. */ + /* We shall keep them in the array Premier[] since the sequence of */ + /* generated numbers must be circular. They will be used to build the */ + /* last t - 1 tuples. Here, tuples are balls or points. */ + Indice = 0; + for (j = 1; j < t; j++) { + element = unif01_StripL (gen, r, d); + Premier[j] = element; + /* Shift tuple by s bits and insert new element */ + Indice = Indice * d + element; + } + + /* Generation of the first n - (t - 1) tuples */ + for (j = 1; j <= n - (t - 1); j++) { + Indice %= k1; + ++Count1[Indice]; + Indice = Indice * d + unif01_StripL (gen, r, d); + ++Count[Indice]; + } + + /* Generation of the last (t - 1) tuples. Use the elements of Premier */ + for (j = 1; j < t; j++) { + Indice %= k1; + ++Count1[Indice]; + Indice = Indice * d + Premier[j]; + ++Count[Indice]; + } +} + + +/*=======================================================================*/ + +static void OverHashGenere ( + unif01_Gen *gen, + smultin_Res *res, + long n, /* Number of balls */ + int r, + smultin_CellType dLR, /* Parameter d */ + int t, /* Dimension */ + long Hache1, /* Size of hashing table in t dimensions */ + long Hache11, /* Size of hashing table in t - 1 dimensions */ + smultin_CellType k, /* Number of urns in t dimensions */ + smultin_CellType k1, /* Number of urns in t - 1 dimensions */ + long *CoMax, /* Max number of balls in any cell in t dim. */ + long *CoMax1 /* Max number of balls in any cell in t-1 dim. */ + ) +/* + * Generate the n balls for smultin_MultinomialOver in the sparse + * case, and fill the counters. We use hashing. + */ +{ + long j, tem; + long d = dLR; + smultin_CellType Indice; + smultin_CellType element; + double UnSurHache1; + double UnSurHache11; + double UnSurk1; + smultin_CellType Premier[MAX_DIM]; + long *Count = res->Count; /* Counters in t dimensions */ + long *Count1 = res->Count1; /* Counters in t - 1 dimensions */ + smultin_CellType *Cell = res->Cell; /* Cell numbers in t dimensions */ + smultin_CellType *Cell1 = res->Cell1; /* Cell numbers in t - 1 dimensions */ + smultin_CellType *Nb = res->Nb; + smultin_CellType *Nb1 = res->Nb1; + + util_Assert (t < MAX_DIM, "OverHashGenere: t > 64"); + UnSurk1 = 1.0 / k1; + UnSurHache1 = 1.0 / Hache1; + UnSurHache11 = 1.0 / Hache11; + + for (j = 0; j <= Hache1; j++) { + Count[j] = 0; +#ifdef USE_LONGLONG + Cell[j] = MASK64; /* Empty cells */ +#else + Cell[j] = -1.0; /* Empty cells */ +#endif + } + for (j = 0; j <= Hache11; j++) { + Count1[j] = 0; +#ifdef USE_LONGLONG + Cell1[j] = MASK64; /* Empty cells */ +#else + Cell1[j] = -1.0; /* Empty cells */ +#endif + } + for (j = 1; j <= res->NbSize; j++) + Nb[j] = 0; + for (j = 1; j <= res->Nb1Size; j++) + Nb1[j] = 0; + Nb[0] = k; + Nb1[0] = k1; + *CoMax = 0; + *CoMax1 = 0; + + /* Generation of the first (t - 1) elements of the first tuple. We shall + keep them in array Premier[] since the sequence of generated numbers + must be circular. They will be used to obtain the last t - 1 tuples. + When we generate a random number, we keep s bits and they become the + least significant element of the tuple. We then shift the elements so + that the most significant element is dropped. The tuples are balls. */ + + /* Generate the first (t - 1) components of the first tuple (ball) */ + Indice = 0; + for (j = 1; j < t; j++) { + element = unif01_StripL (gen, r, d); + Premier[j] = element; + /* Shift tuple by s bits and insert new element */ + Indice = Indice * dLR + element; + } + + /* Generation of the first n - (t - 1) tuples */ + for (j = 1; j <= n - (t - 1); j++) { + /* Operation % k1 */ +#ifdef USE_LONGLONG + Indice %= k1; +#else + tem = Indice * UnSurk1; + Indice -= k1 * tem; +#endif + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Indice * dLR + unif01_StripL (gen, r, d); + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + } + + /* Generate the last (t - 1) tuples. We use the elements of Premier[] */ + for (j = 1; j < t; j++) { +#ifdef USE_LONGLONG + Indice %= k1; +#else + tem = Indice * UnSurk1; + Indice -= k1 * tem; +#endif + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Indice * dLR + Premier[j]; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + } +} + + +/*=======================================================================*/ + +static void OverDenseGenereBits ( + unif01_Gen *gen, + smultin_Res *res, + long n, /* Number of balls */ + int r, /* Drop first r bits of each random number */ + int L, /* Cells numbered with L bits */ + int s, /* Take s bits of each random number */ + long k, /* Number of urns in L dimensions */ + long k1 /* Number of urns in L - 1 dimensions */ + ) +/* + * Generate the n balls for smultin_MultinomialBitsOver in the dense + * case, and fill the counters Count and Count1 + */ +{ + int j; + long i; + unsigned long Premier[MAX_DIM]; + long *Count = res->Count; /* Counters in L dimensions */ + long *Count1 = res->Count1; /* Counters in L - 1 dimensions */ + smultin_CellType *Nb = res->Nb; + + util_Assert (L < MAX_DIM, "OverDenseGenereBits: L > 64"); + for (i = 1; i <= res->NbSize; i++) + Nb[i] = 0; + Nb[0] = k; + for (i = 0; i <= k; i++) + Count[i] = 0; + for (i = 0; i <= k1; i++) + Count1[i] = 0; + + if (L + s <= 32) { + const unsigned long MASK = num_TwoExp[L] - 1.0; + const unsigned long MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + unsigned long Z, Z0; + int b; + + /* Generation of the first t*s random bits for the first tuple. */ + /* We shall keep them in Premier since the sequence of generated */ + /* bits will be circular. */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of other bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Z = Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + for (j = 0; j < s; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + b = n % s; + if (b) + Z0 >>= (s - b); + else + b = s; + + Z = Z0; + for (j = 0; j < b; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Z = Z0 = (Z0 << s) | Premier[i]; + for (j = 0; j < s; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + return; + } + +#ifndef USE_LONGLONG + util_Error ("OverDenseGenereBits: L + s > 32"); +#else + + /* ---------------------------------------------------------- */ + if (L + s <= 64) { + const ulonglong MASK = num_TwoExp[L] - 1.0; + const ulonglong MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + ulonglong Z, Z0; + int b; + + /* Generation of the first t*s random bits */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of the other random bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Z = Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + for (j = 0; j < s; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + b = n % s; + if (b) + Z0 >>= s - b; + else + b = s; + + Z = Z0; + for (j = 0; j < b; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Z = Z0 = (Z0 << s) | Premier[i]; + for (j = 0; j < s; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + return; + + /* ---------------------------------------------------------- */ + } else { /* L + s > 64 */ + + const ulonglong MASK = num_TwoExp[L] - 1.0; + const ulonglong MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + const int q1 = 64 - L; + const int q2 = s % q1; + const int t2 = s / q1; + ulonglong Z, Z0; + unsigned long Bloc; + int k, b; + + /* Generation of the first t*s random bits */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Bloc = unif01_StripB (gen, r, s); + + /* Since L + s overflows a ulonglong, process a s-bit block in */ + /* t2 subblocks of q1 bits and one last subblock of q2 bits. */ + for (k = 1; k <= t2; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q2 + (t2 - k) * q1)); + for (j = 0; j < q1; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + Z = Z0 = (Z0 << q2) | Bloc; + for (j = 0; j < q2; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + Bloc = unif01_StripB (gen, r, s); + b = n % s; + if (0 == b) + b = s; + Bloc >>= s - b; + { + const int q3 = b % q1; + const int t3 = b / q1; + for (k = 1; k <= t3; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q3 + (t3 - k) * q1)); + for (j = 0; j < q1; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + Z = Z0 = (Z0 << q3) | Bloc; + for (j = 0; j < q3; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Bloc = Premier[i]; + for (k = 1; k <= t2; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q2 + (t2 - k) * q1)); + for (j = 0; j < q1; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + Z = Z0 = (Z0 << q2) | Bloc; + for (j = 0; j < q2; j++) { + ++Count1[Z & MASK1]; + ++Count[Z & MASK]; + Z >>= 1; + } + } + return; + } +#endif +} + + +/*=======================================================================*/ + +static void OverHashGenereBits ( + unif01_Gen *gen, + smultin_Res *res, + long n, /* Number of balls */ + int r, + int L, /* Dimension */ + int s, + long Hache1, /* Size of hashing table in t dimensions */ + long Hache11, /* Size of hashing table in t - 1 dimensions */ + smultin_CellType k, /* Number of urns in t dimensions */ + smultin_CellType k1, /* Number of urns in t - 1 dimensions */ + long *CoMax, /* Max number of balls in any cell in t dim. */ + long *CoMax1 /* Max number of balls in any cell in t-1 dim. */ + ) +/* + * Generate the n balls for smultin_MultinomialOver in the sparse + * case, and fill the counters. We use hashing. + */ +{ + int j; + long i; + unsigned long Premier[MAX_DIM]; + smultin_CellType Indice; + double UnSurHache1; + double UnSurHache11; + + util_Assert (L < MAX_DIM, "OverHashGenereBits: L > 64"); + UnSurHache1 = 1.0 / Hache1; + UnSurHache11 = 1.0 / Hache11; + + for (j = 0; j <= Hache1; j++) { + res->Count[j] = 0; +#ifdef USE_LONGLONG + res->Cell[j] = MASK64; /* Empty cells */ +#else + res->Cell[j] = -1.0; /* Empty cells */ +#endif + } + for (j = 0; j <= Hache11; j++) { + res->Count1[j] = 0; +#ifdef USE_LONGLONG + res->Cell1[j] = MASK64; /* Empty cells */ +#else + res->Cell1[j] = -1.0; /* Empty cells */ +#endif + } + for (j = 1; j <= res->NbSize; j++) + res->Nb[j] = 0; + for (j = 1; j <= res->Nb1Size; j++) + res->Nb1[j] = 0; + res->Nb[0] = k; + res->Nb1[0] = k1; + *CoMax = 0; + *CoMax1 = 0; + + if (L + s <= 32) { + const unsigned long MASK = num_TwoExp[L] - 1.0; + const unsigned long MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + unsigned long Z, Z0, b; + + /* Generation of the first t*s random bits for the first tuple. */ + /* We shall keep them in Premier since the sequence of */ + /* generated bits will be circular. */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of all other bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Z = Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + for (j = 0; j < s; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + b = n % s; + if (b) + Z0 >>= (s - b); + else + b = s; + + Z = Z0; + for (j = 0; j < (int) b; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Z = Z0 = (Z0 << s) | Premier[i]; + for (j = 0; j < s; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + return; + } + + /* ---------------------------------------------------------- */ +#ifndef USE_LONGLONG + util_Error ("OverHashGenereBits: L + s > 32"); +#else + + if (L + s <= 64) { + const ulonglong MASK = num_TwoExp[L] - 1.0; + const ulonglong MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + ulonglong Z, Z0, b; + + /* Generation of the first t*s random bits */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of the other random bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Z = Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + for (j = 0; j < s; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + Z0 = (Z0 << s) | unif01_StripB (gen, r, s); + b = n % s; + if (b) + Z0 >>= (s - b); + else + b = s; + + Z = Z0; + for (j = 0; j < (int) b; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Z = Z0 = (Z0 << s) | Premier[i]; + for (j = 0; j < s; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + return; + + /* ---------------------------------------------------------- */ + } else { /* L + s > 64 */ + + const ulonglong MASK = num_TwoExp[L] - 1.0; + const ulonglong MASK1 = num_TwoExp[L - 1] - 1.0; + const int t = (L - 1) / s + 1; + const int q1 = 64 - L; + const int t2 = s / q1; + const int q2 = s % q1; + ulonglong Z, Z0; + unsigned long Bloc; + int k, b; + + /* Generation of the first t*s random bits */ + Z0 = 0; + for (j = 0; j < t; j++) { + Z0 <<= s; + Premier[j] = unif01_StripB (gen, r, s); + Z0 |= Premier[j]; + } + + /* Generation of the other random bits: main loop */ + for (i = 0; i < (n - t * s - 1) / s; i++) { + Bloc = unif01_StripB (gen, r, s); + + /* Since L + s overflows a ulonglong, process a s-bit block in */ + /* t2 subblocks of q1 bits and one last subblock of q2 bits. */ + for (k = 1; k <= t2; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q2 + (t2 - k) * q1)); + for (j = 0; j < q1; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, + CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, + FALSE); + Z >>= 1; + } + } + Z = Z0 = (Z0 << q2) | Bloc; + for (j = 0; j < q2; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + + /* Generation of the last b random bits */ + b = n % s; + Bloc = unif01_StripB (gen, r, s); + if (0 == b) + b = s; + Bloc >>= s - b; + + { + const int q3 = b % q1; + const int t3 = b / q1; + for (k = 1; k <= t3; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q3 + (t3 - k) * q1)); + for (j = 0; j < q1; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, + CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, + CoMax, FALSE); + Z >>= 1; + } + } + Z = Z0 = (Z0 << q3) | Bloc; + for (j = 0; j < q3; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + + /* Must do last few bits using circular overlap with Premier */ + for (i = 0; i < t; i++) { + Bloc = Premier[i]; + for (k = 1; k <= t2; k++) { + Z = Z0 = (Z0 << q1) | (Bloc >> (q2 + (t2 - k) * q1)); + for (j = 0; j < q1; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, + CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, + CoMax, FALSE); + Z >>= 1; + } + } + Z = Z0 = (Z0 << q2) | Bloc; + for (j = 0; j < q2; j++) { + Indice = Z & MASK1; + UpdateCountHash (res, Indice, Hache11, UnSurHache11, CoMax1, TRUE); + Indice = Z & MASK; + UpdateCountHash (res, Indice, Hache1, UnSurHache1, CoMax, FALSE); + Z >>= 1; + } + } + return; + } +#endif +} + + +/*=======================================================================*/ + +static void MultinomOver (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long N, long n, int r, long d, int t, lebool Sparse, + smultin_CellType k, smultin_CellType k1, char *TestName, + chrono_Chrono *Timer, lebool BitFlag) +{ + long Seq; + smultin_CellType dLR = d; + double nLR = n; + double NbExp; /* Expected number per cell in t dimensions */ + double NbExp1; /* Expected number per cell in t - 1 dim. */ + double EColl; /* Approx. expected number of collisions */ + DeltaIndex s; + long Hache1, Hache11; /* Hashing modules */ + long CoMax1; /* Max number of balls in any cell: t-1 dim. */ + long CoMax; /* Max number of balls in any cell: t dim. */ + double X, X0, X1; /* Statistics */ + double Esperance; /* Expected value of number of collisions */ + double StandDev; /* Standard deviation of number of collisions */ + double V[1]; /* Number of degrees of freedom for ChiSquare */ + double SumX2[smultin_MAX_DELTA]; + double SumX[smultin_MAX_DELTA]; + double X0Pre[smultin_MAX_DELTA]; + lebool localRes = FALSE; + + NbExp = (double) n / k; + NbExp1 = (double) n / k1; + EColl = nLR * nLR / (2.0 * k); + if (par == NULL) + par = &smultin_ParamDefault; + if (res == NULL) { + localRes = TRUE; + res = smultin_CreateRes (par); + } else + /* Clean memory from a previous call */ + CleanPD (res); + + res->NbCellsTotal = k; + res->Over = TRUE; + InitRes (par, res, N); + InitPowDiv (par, res, N, Sparse, n, k - k1); + if (swrite_Basic) { + if (BitFlag) + /* Here t stand for s, d for L */ + WriteDataMNBits (gen, par, res, TestName, N, n, r, d, t, Sparse, k, + TRUE); + else + WriteDataPowDiv (gen, par, res, TestName, N, n, r, d, t, Sparse, k); + } + for (s = 0; s < par->NbDelta; s++) { + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + /* CollisionOver test */ + InitCollOver (res, n, k, d, t, &Esperance, &StandDev); + if (swrite_Basic) + WriteDataCollOver (res, n, k, Esperance, StandDev); + } + } + for (s = 0; s < par->NbDelta; s++) { + SumX[s] = 0.0; + SumX2[s] = 0.0; + X0Pre[s] = 0.0; + } + CalcTabFj (par, res, Sparse, (double) k, NbExp); + if (res->Hashing) { + Hache1 = tables_HashPrime (n, smultin_env.HashLoad); + if ((unsigned) Hache1 > k1) + Hache11 = k1; + else + Hache11 = Hache1; + res->Cell = util_Calloc ((size_t) Hache1 + 2, sizeof (smultin_CellType)); + res->Cell1 = util_Calloc ((size_t) Hache11 + 2, + sizeof (smultin_CellType)); + } else { + Hache1 = k; + Hache11 = k1; + } + res->CountSize = Hache1; + res->Count1Size = Hache11; + res->Count = util_Calloc ((size_t) Hache1 + 2, sizeof (long)); + res->Count1 = util_Calloc ((size_t) Hache11 + 2, sizeof (long)); + res->NbSize = res->Nb1Size = 8000; + res->Nb = util_Calloc ((size_t) res->NbSize + 2, sizeof (smultin_CellType)); + res->Nb1 = util_Calloc ((size_t) res->Nb1Size + 2, + sizeof (smultin_CellType)); + + /* Generate the points or balls */ + for (Seq = 1; Seq <= N; Seq++) { + if (BitFlag) { + /* Here, d stands for L, and t for s */ + if (res->Hashing) { + OverHashGenereBits (gen, res, n, r, d, t, Hache1, Hache11, k, k1, + &CoMax, &CoMax1); + } else { + OverDenseGenereBits (gen, res, n, r, d, t, Hache1, Hache11); + } + } else { + if (res->Hashing) { + OverHashGenere (gen, res, n, r, dLR, t, Hache1, Hache11, k, k1, + &CoMax, &CoMax1); + } else { + OverDenseGenere (gen, res, n, r, d, t, Hache1, Hache11); + } + } + + if (swrite_Counters) { + if (res->Hashing) { +#ifdef USE_LONGLONG + tables_WriteTabULL (res->Nb, 0, CoMax, 5, 12, + "Observed numbers in res->Nb"); + tables_WriteTabULL (res->Nb1, 0, CoMax1, 5, 12, + "Observed numbers in res->Nb1"); +#else + tables_WriteTabD (res->Nb, 0, CoMax, 5, 12, 0, 0, + "Observed numbers in res->Nb"); + tables_WriteTabD (res->Nb1, 0, CoMax1, 5, 12, 0, 0, + "Observed numbers in res->Nb1"); +#endif + } else if (!Sparse) { + tables_WriteTabL (res->Count, 0, res->CountSize - 1, 5, + 10, "Observed numbers in res->Count"); + tables_WriteTabL (res->Count1, 0, res->Count1Size - 1, 5, + 10, "Observed numbers in res->Count1"); + } + } + + /* The balls have been generated; now compute the statistics */ + for (s = 0; s < par->NbDelta; s++) { + /* Compute the stat. X */ + if (res->Hashing) { + CalcPoDiEqHache (par, res, s, NbExp, res->Nb, CoMax, TRUE, &X); + + } else if (res->flagTab) { + CalcPowDivEqual (par, res, s, NbExp, + res->Count, 0, Hache1 - 1, TRUE, &X); + + } else { + CalcPowDivEqual (par, res, s, NbExp, + res->Count, 0, Hache1 - 1, FALSE, &X); + } + + if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM && Esperance >= 0.0) { + /* CollisionOver test */ + switch ((unsigned) res->CollApprox) { + case smultin_CollPoissonDense: /* Number of empty cells */ + X0 = k + X - nLR; + break; + case smultin_CollPoissonSparse: /* Number of collisions */ + X0 = X; + break; + case smultin_CollNormal: /* Standardized number of collisions */ + X0 = (X - Esperance) / StandDev; + break; + default: + util_Error + ("smultin_MultinomialOver: Computing X0 with CollNotInit"); + break; + } + res->NbCollisions += X; + res->Nb[0] = k + X - nLR; + statcoll_AddObs (res->Collector[s], X0); + CalcNbCells (par, res, 0, Hache1 - 1, CoMax); + + } else { + /* In the case delta = 1, X-X1 is approx. a chi-square with + k - k1 degrees of freedom, or a normal in the sparse case */ + /* Compute X1 */ + if (res->Hashing) { + CalcPoDiEqHache (par, res, s, NbExp1, res->Nb1, + CoMax1, FALSE, &X1); + } else { + CalcPowDivEqual (par, res, s, NbExp1, + res->Count1, 0, Hache11 - 1, FALSE, &X1); + } + X0 = (X - X1 - res->Mu[s]) / res->Sigma[s]; + statcoll_AddObs (res->Collector[s], X0); + if (!Sparse) + X0 = (X0 - k + k1) / sqrt (2.0 * (k - k1)); + /* Now, X0 is standardized, with mean 0 and variance 1. */ + } + + /* The following is to compute the mean and correlation */ + SumX[s] += X0; + SumX2[s] += X0 * X0Pre[s]; + X0Pre[s] = X0; + } + } + + /* For now, we understand only the cases delta = 1 and Collision */ + for (s = 0; s < par->NbDelta; s++) { + statcoll_Collector *Q = res->Collector[s]; + double racN = sqrt ((double) N); + + if (par->ValDelta[s] > -1.0 + EPS_LAM) { + /* Not Collisions test */ + if (Sparse) { + util_Warning (fabs (par->ValDelta[s] - 1.0) > EPS_LAM, + "The theoretical distribution for the overlapping case\nis known only for Delta = 1"); + gofw_ActiveTests1 (Q->V, Q->NObs, wdist_Normal, + (double *) NULL, res->sVal2[s], res->pVal2[s]); + } else { + V[0] = k - k1; + gofw_ActiveTests1 (Q->V, Q->NObs, wdist_ChiSquare, V, + res->sVal2[s], res->pVal2[s]); + } + /* Compute the mean, the correlation, and their p-values */ + if (Q->NObs > 1) { + res->sVal2[s][gofw_Mean] = SumX[s] / racN; + res->pVal2[s][gofw_Mean] = fbar_Normal1 (res->sVal2[s][gofw_Mean]); + res->sVal2[s][gofw_Cor] = racN * SumX2[s] / (N - 1); + res->pVal2[s][gofw_Cor] = fbar_Normal1 (res->sVal2[s][gofw_Cor]); + } + if (swrite_Basic) { + WriteResultsPowDiv (par, res, s, N, EColl, k - k1, Sparse, + res->Mu[s]); + } + + } else if (fabs (par->ValDelta[s] + 1.0) < EPS_LAM) { + /* Collisions test */ + CalcResCollOver (res, s, N, Esperance, SumX[s], SumX2[s]); + if (swrite_Basic) { + WriteResCollOver (par, res, s, N, EColl, Esperance); + } + } + } + if (swrite_Basic) + swrite_Final (gen, Timer); + + if (localRes) + smultin_DeleteRes (res); +} + + +/*=======================================================================*/ + +void smultin_MultinomialOver (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long N, long n, int r, long d, int t, lebool Sparse) +{ + int i; + smultin_CellType k1; /* Number of urns in t - 1 dimensions */ + smultin_CellType k; /* Number of urns in t dimensions */ + double NbExp; /* Expected number per cell in t dimensions */ + chrono_Chrono *Timer; + char *TestName = "smultin_MultinomialOver test"; + + Timer = chrono_Create (); + if (NULL == par) + par = &smultin_ParamDefault; + k1 = 1; + for (i = 1; i < t; i++) + k1 *= d; + k = k1 * d; + NbExp = (double) n / k; + util_Assert (n > 4, "smultin_MultinomialOver: n <= 4"); + util_Assert (t > 1, "smultin_MultinomialOver: t < 2"); + if (par->GenerCell != smultin_GenerCellPermut) + util_Assert (d > 1, "smultin_MultinomialOver: d <= 1"); + util_Assert (k <= smultin_env.Maxk, + "smultin_MultinomialOver: d^t > Maxk"); +#ifndef USE_LONGLONG + util_Assert (NbExp > 1.0 / num_TwoExp[31], + "smultin_MultinomialOver: NbExp <= 1/2^31"); +#endif + MultinomOver (gen, par, res, N, n, r, d, t, Sparse, k, k1, + TestName, Timer, FALSE); + chrono_Delete (Timer); +} + + +/*=======================================================================*/ + +void smultin_MultinomialBits (unif01_Gen *gen, smultin_Param *par, + smultin_Res *res, long N, long n, int r, int s, int L, lebool Sparse) +{ +/* + * Sparse: normal approximation for Delta != -1. + * Non sparse: chi-square approximation. + * Collisions test meaningfull only in Sparse case. + */ + smultin_CellType k; /* Number of cells */ + chrono_Chrono *Timer; + char *TestName = "smultin_MultinomialBits test"; + + Timer = chrono_Create (); + k = num_TwoExp[L]; + if (NULL == par) + par = &smultin_ParamDefault; + if (L >= s) { + long d = num_TwoExp[s]; + int t = L / s; + if (swrite_Basic) { + printf + ("***********************************************************\n" + "Test smultin_MultinomialBits calling smultin_Multinomial\n\n"); + printf (" N = %2ld, n = %2ld, r = %1d", N, n, r); + printf (", s = %2d, L = %2d, Sparse = ", s, L); + util_WriteBool (Sparse, 5); + printf ("\n\n Number of bits = n*L = %.0f\n\n\n", (double) n * L); + } + if ((t == 1) && (s > 30)) { + util_Warning (TRUE, "smultin_MultinomialBits: L = s and s > 30"); + return; + } + util_Assert (L % s == 0, "smultin_MultinomialBits: L Mod s > 0"); + par->GenerCell = smultin_GenerCellSerial; + smultin_Multinomial (gen, par, res, N, n, r, d, t, Sparse); + return; + } + + util_Assert (s % L == 0, "smultin_MultinomialBits: s Mod L > 0"); + util_Assert (k <= smultin_env.Maxk, + "smultin_MultinomialBits: k > Maxk"); + util_Assert (n > 4, "smultin_MultinomialBits: n <= 4"); +#ifndef USE_LONGLONG + util_Assert ((double) n / k > 1.0 / num_TwoExp[31], + "smultin_MultinomialBits: NbExp <= 1/2^31"); +#endif + Multinom (gen, par, res, N, n, r, L, s, Sparse, k, TestName, Timer, TRUE); + chrono_Delete (Timer); +} + + +/*=======================================================================*/ + +void smultin_MultinomialBitsOver (unif01_Gen * gen, smultin_Param * par, + smultin_Res * res, long N, long n, int r, int s, int L, lebool Sparse) +{ + smultin_CellType k1; /* Number of urns in L - 1 dimensions */ + smultin_CellType k; /* Number of urns in L dimensions */ + double NbExp; /* Expected number per cell in L dimensions */ + chrono_Chrono *Timer; + char *TestName = "smultin_MultinomialBitsOver test"; + + Timer = chrono_Create (); + if (NULL == par) + par = &smultin_ParamDefault; + util_Assert (L <= 64, "smultin_MultinomialBitsOver: L > 64"); + k1 = num_TwoExp[L - 1]; + k = num_TwoExp[L]; + NbExp = (double) n / k; + util_Assert (n > 4, "smultin_MultinomialBitsOver: n <= 4"); + util_Assert (L > 1, "smultin_MultinomialBitsOver: L < 2"); + util_Assert (s > 0, "smultin_MultinomialBitsOver: s < 1"); + util_Assert (k <= smultin_env.Maxk, + "smultin_MultinomialBitsOver: L too large"); +#ifndef USE_LONGLONG + util_Assert (NbExp > 1.0 / num_TwoExp[31], + "smultin_MultinomialBitsOver: NbExp <= 1/2^31"); +#endif + MultinomOver (gen, par, res, N, n, r, L, s, Sparse, k, k1, + TestName, Timer, TRUE); + + chrono_Delete (Timer); +} diff --git a/cbits/testu/src/snpair.c b/cbits/testu/src/snpair.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/snpair.c @@ -0,0 +1,2635 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: snpair.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "util.h" +#include "tables.h" +#include "chrono.h" +#include "num.h" +#include "num2.h" + +#include "snpair.h" +#include "swrite.h" +#include "unif01.h" + +#include "statcoll.h" +#include "fdist.h" +#include "fbar.h" +#include "fmass.h" +#include "gofs.h" +#include "gofw.h" + +#include +#include +#include +#include +#include + +#undef DEBUG +#ifdef DEBUG + +#include +/* Prints all the points */ +#define TRACEP(n, name) { \ + FILE *f; \ + long i, j; \ + f = util_Fopen (name, "w"); \ + fprintf (f, "------------------------\n"); \ + for (i = 1; i <= n; i++) { \ + for (j = 1; j <= kk; j++) \ + fprintf (f, "%f ", res->Points[1][i][j]); \ + fprintf (f, "\n"); \ + } \ +} +#endif + + + + +/*---------------------------- extern variables ---------------------------*/ + +snpair_Envir snpair_env = { + 20, 30, 30, 1000 +}; + +/* For now, we do not use it. Is used in the t modules */ +long snpair_MaxNumPoints = LONG_MAX; + +lebool snpair_TimeBB = FALSE; +lebool snpair_mNP2S_Flag = TRUE; + + + + +/*---------------------------- static variables ---------------------------*/ + +typedef struct { + + int L1; /* Change coordinate at each L1 recur- */ + /* sion level in FindClosePairs */ + int L2; /* Same thing for CheckBoundary */ + int kk; /* = k = Dimension */ + int pp; /* = p (L_p norm); p = 0 is sup norm */ + int mm; /* = m = (number of kept distances) */ + int mcd; /* Dimension of CloseDist[] */ + double dlim1; /* (m \mu2)^{1/k} */ + double dlim1p; /* dlim1^p (when p > 0) */ + double dlim; /* = max (dlim1, CloseDist[m]); search */ + /* for points at distance < dlim */ + double dlimp; /* = dlim^p (when p > 0) */ + double pLR; /* = p */ + double Invp; /* 1/p; ( = 1 if p = 0) */ + int Maxnp; /* Max level of recursion */ + lebool Torus; /* TRUE if in Torus; FALSE if in cube */ + lebool BBFlag; /* TRUE if BickelBreimann test */ + wdist_CFUNC FDistBB; /* BickelBreimann CDF */ + +/* The largest distance for snpair_DistanceCPBitM: the largest number of + equal bits for all components of a pair of points (all components of + the pair have at least YLim identical bits) amongst all pairs. */ + int YLim; + +} WorkType; + + +/*------------------ Module variables for G+, G-, H+, H- -----------------*/ +/* + * To compute the jumps in FDistGPlus, FDistGMinus, FDistHPlus, FDistHMinus + */ + + +#if 0 +static double t0; + +#define xinf 1.0e50 + +static lebool GPlusFlag = FALSE; +static lebool GMinusFlag = FALSE; +static lebool HPlusFlag = FALSE; +static lebool HMinusFlag = FALSE; + +static double GPlust0 = -xinf; /* = t0 for GPlus */ +static double GMinust0 = -xinf; /* = t0 for GMinus */ +static double HPlust0 = -xinf; /* = t0 for HPlus */ +static double HMinust0 = -xinf; /* = t0 for HMinus */ +static double GPlust1 = -xinf; /* = t1 for GPlus */ +static double GMinust1 = -xinf; /* = t1 for GMinus */ +static double HPlust1 = -xinf; /* = t1 for HPlus */ +static double HMinust1 = -xinf; /* = t1 for HMinus */ + +static double *GPlusJumpX; /* Position x of the jumps of G+ */ +static double *GPlusJumpYBottom; /* Value y left of the jumps of G+ */ +static double *GPlusJumpYTop; /* Value y right of the jumps of G+ */ + +static double *GMinusJumpX; /* Similarly for G- */ +static double *GMinusJumpYBottom; +static double *GMinusJumpYTop; + +static double *HPlusJumpX; /* Similarly for H+ */ +static double *HPlusJumpYBottom; +static double *HPlusJumpYTop; + +static double *HMinusJumpX; /* Similarly for H- */ +static double *HMinusJumpYBottom; +static double *HMinusJumpYTop; + +static int GPlusNJump; /* The number of jumps of G+ */ +static int GMinusNJump; /* The number of jumps of G- */ +static int HPlusNJump; /* The number of jumps of H+ */ +static int HMinusNJump; /* The number of jumps of H- */ + +#endif + +/*------------------ Module variables for Bickel-Breiman test ------------*/ + +static double BB2[132]; +static double BB3[132]; +static double BB4[43]; +static double BB5[22]; + + + + + + +/*-------------------------------- functions ------------------------------*/ + +static void CopyPoints (snpair_PointType A[], snpair_PointType B[], long r, + long s) +/* + * Copies A[r..s] into B[r..s] + */ +{ + long i; + for (i = r; i <= s; i++) + B[i] = A[i]; +} + + +/*=========================================================================*/ + +void snpair_QuickSort (snpair_PointType A[], long l, long r, int c) +/* + * Sort points of indices l to r using coordinate c as key. Exchange + * pointers instead of points. + */ +{ + long j; + long i; + double pivot; + snpair_PointType vec; + i = l; + j = r; + pivot = A[(l + r) / 2][c]; + do { + while (A[i][c] < pivot) + ++i; + while (pivot < A[j][c]) + --j; + if (i <= j) { + vec = A[i]; + A[i] = A[j]; + A[j] = vec; + ++i; + --j; + } + } while (i <= j); + if (l < j) + snpair_QuickSort (A, l, j, c); + if (i < r) + snpair_QuickSort (A, i, r, c); +} + + +/*=========================================================================*/ + +void snpair_DistanceCP (snpair_Res * res, snpair_PointType P1, + snpair_PointType P2) +/* + * For ClosePairs, checks if the distance between P1 and P2 is < dlim. + * If so, updates dlim, dlimp, and adds the new distance in the list + * of shortest distances. + */ +{ + int i; + double temp; + double dist; + double distp = 0.0; + WorkType *work = res->work; + + for (i = 1; i <= work->kk; i++) { + temp = P1[i] - P2[i]; + if (temp < 0.0) + temp = -temp; + if (work->Torus && temp > 0.5) + temp = 1.0 - temp; + if (work->pp == 0) { + if (temp > distp) + distp = temp; + } else if (work->pp == 1) + distp += temp; + else if (work->pp == 2) + distp += temp * temp; + else + distp += pow (temp, work->pLR); + if (distp >= work->dlimp) + return; + } + +#define NUM_JUMPS_LIM 50000 +/* I put this arbitrary limit on the size of res->CloseDist because for bad + generators, there will be many pairs of points with 0 distances between + them, and res->CloseDist will otherwise eat up the whole memory. + If the parameters N and m in ClosePairs should be such that + N*m > NUM_JUMPS_LIM, then this limit will have to be increased. (RS) */ + + if (distp < work->dlimp) { + if (work->pp <= 1) + dist = distp; + else if (work->pp == 2) + dist = sqrt (distp); + else + dist = pow (distp, work->Invp); + if ((res->NumClose < work->mm || + res->CloseDist[res->NumClose] < work->dlim1) && + (res->NumClose < NUM_JUMPS_LIM)) { + ++res->NumClose; /* Complete the list of close pairs */ + if (res->NumClose >= work->mcd) { + double *A; + work->mcd *= 2; + A = util_Realloc (res->CloseDist, (work->mcd + 1)*sizeof (double)); + if (A == NULL) { + util_Warning (1, "Cannot realloc res->CloseDist"); + } else + res->CloseDist = A; + } + util_Warning ((res->NumClose >= NUM_JUMPS_LIM) && swrite_Basic, + "res->NumClose > 50000"); + } + + /* Insert the new distance in the sorted list */ + i = res->NumClose; + while (i > 1 && dist < res->CloseDist[i - 1]) { + --i; + res->CloseDist[i + 1] = res->CloseDist[i]; + } + res->CloseDist[i] = dist; + + if (res->NumClose == work->mm && res->CloseDist[work->mm] < work->dlim + && work->dlim1 < work->dlim) { + work->dlim = res->CloseDist[work->mm]; + if (work->dlim < work->dlim1) { + work->dlim = work->dlim1; + work->dlimp = work->dlim1p; + } else if (work->pp <= 1) + work->dlimp = work->dlim; + else if (work->pp == 2) + work->dlimp = work->dlim * work->dlim; + else + work->dlimp = pow (work->dlim, work->pLR); + } + } +} + + +/*=========================================================================*/ + +void snpair_DistanceBB (snpair_Res * res, snpair_PointType P1, + snpair_PointType P2) +/* + * For Bickel-Breiman, checks whether the distance between P1 and P2, to the + * power p, is less than P1[0] or P2[0]. If so, updates these values. + */ +{ + int i; + double bound; + double temp; + double distp; + WorkType *work = res->work; + + if (P2[0] > P1[0]) + bound = P2[0]; + else + bound = P1[0]; + + distp = 0.0; + for (i = 1; i <= work->kk; i++) { + temp = P1[i] - P2[i]; + if (temp < 0.0) + temp = -temp; + if (work->Torus && temp > 0.5) + temp = 1.0 - temp; + if (work->pp == 1) + distp += temp; + else if (work->pp == 2) + distp += temp * temp; + else if (work->pp == 0) { + if (temp > distp) + distp = temp; + } else + distp += pow (temp, work->pLR); + if (distp >= bound) + return; + } + + if (distp < P1[0]) + P1[0] = distp; + if (distp < P2[0]) + P2[0] = distp; +} + + +/*=========================================================================*/ + +void snpair_VerifPairs0 (snpair_Res * res, snpair_PointType A[], long r, + long s, int junk1, int junk2) +/* + * Compute the distance between all pairs of points with indices in the + * interval [r..s] for the array A; updates the distances for BB. We assume + * the points are sorted with respect to coordinate c. + */ +{ + long i, j; + for (i = r; i < s; i++) { + for (j = i + 1; j <= s; j++) { + res->Distance (res, A[i], A[j]); + } + } +} + + +/*=========================================================================*/ + +void snpair_VerifPairs1 (snpair_Res * res, snpair_PointType A[], long r, + long s, int np, int c) +/* + * Compute the distance between all pairs of points with indices in the + * interval [r..s] for the array A; updates dlim and dlimp if necessary. + * We assume the points are sorted with respect to coordinate c. + */ +{ + long i, j; + double high; + WorkType *work = res->work; + + util_Assert (np <= work->Maxnp, + "Calling snpair_VerifPairs1 with np > Maxnp"); + for (i = r; i <= s; i++) { + /* util_Assert (r <= s, "Calling snpair_VerifPairs1 with r > s"); */ + + /* Consider only points at distance <= dlim from A[i] with respect to + coordinate c */ + high = A[i][c] + work->dlim; + j = i + 1; + while (j <= s && A[j][c] < high) { + res->Distance (res, A[i], A[j]); + ++j; + } + if (j > s && work->Torus && np <= work->kk) { + high -= 1.0; + j = r; + while (j < i && A[j][c] < high) { + /* util_Assert (i != j, "Calling distance with i=j in + snpair_VerifPairs1"); */ + res->Distance (res, A[i], A[j]); + ++j; + } + } + } +} + + +/*=========================================================================*/ + +static void dlimSlice ( + snpair_Res *res, + snpair_PointType A[], + long *r, + long *imed, + long *jmed, + long *s, + int c, + lebool Tor + ) +/* + * Let E1 = A [*r..*imed] and E2 = A [*jmed..*s] be two sets of points sorted + * with respect to the c-th coordinate. + * If Torus = FALSE, will reduce E1 to a slice of width dlim (in the direction + * c) of the leftmost point of E2; and similarly for E2 with respect to the + * rightmost point of E1 (always with respect to the c-th coordinate). + * There will be thus a slice on each side of the boundary line. + * If Torus = TRUE, we consider rather the points to the left of + * (E1 + 1.0) as being close to those to the right of E2. This procedure + * tries to decrease imed and to increase jmed. + */ +{ + long i; + double temp; + WorkType *work = res->work; + + if (*r > *imed || *jmed > *s) + return; + +#ifdef DEBUG + printf ("ENTER dlimslice "); + num_WriteD (work->dlim, 10, 5, 1); + printf (" %5ld %5ld %5ld %5ld %3d ", *r, *imed, *jmed, *s, c); + util_WriteBool (Tor, 5); + printf ("\n"); +#endif + + if (Tor) { + temp = A[*s][c] - 1.0; + i = *r; + while (i <= *imed && A[i][c] - temp < work->dlim) + ++i; + *imed = i - 1; + temp = A[*r][c] + 1.0; + i = *s; + while (i >= *jmed && temp - A[i][c] < work->dlim) + --i; + *jmed = i + 1; + + } else { + temp = A[*jmed][c]; + i = *imed; + while (i >= *r && temp - A[i][c] < work->dlim) + --i; + *r = i + 1; + temp = A[*imed][c]; + i = *jmed; + while (i <= *s && A[i][c] - temp < work->dlim) + ++i; + *s = i - 1; + } + +#ifdef DEBUG + printf ("EXIT dlimslice "); + printf (" %5ld %5ld %5ld %5ld\n", *r, *imed, *jmed, *s); +#endif +} + + +/*=========================================================================*/ + +void snpair_MiniProc0 (snpair_Res * res, snpair_PointType T[], long r, + long s, long u, long v, int junk1, int junk2) +/* + * Call "res->Distance" for each point of T[r..s] with each point + * of T[u..v]. + */ +{ + long i, j; + + for (i = r; i <= s; i++) + for (j = u; j <= v; j++) + res->Distance (res, T[i], T[j]); +} + + +/*=========================================================================*/ + +void snpair_MiniProc1 (snpair_Res * res, snpair_PointType T[], long r, + long s, long u, long v, int np, int c) +/* + * Compute the distance between each point of the set E1 = T[r..s] and + * those of E2 = T[u..v]. We consider only the pairs for which the + * differences between the c-th coordinate is <= dlim. + * Assume that the points of E1 and those of E2 are sorted with respect to + * coordinate c. If we have the case of snpair_DistanceCP, updates dlim and + * dlimp whenever a shorter value is found. + */ +{ + long inf; + long l, k, j, i; + double high, low; + WorkType *work = res->work; + +#ifdef DEBUG + printf ("ENTER MiniProc1 "); + num_WriteD (work->dlim, 10, 5, 1); + printf (" %5ld %5ld %5ld %5ld %3d\n", r, s, u, v, np); + if (v < r) + printf ("MiniProc1 with v < r !!!\n"); + util_Assert (np <= work->Maxnp, "MiniProc1: np > Maxnp"); + util_Assert ((s < u) || (v < r), + "MiniProc1: Overlap of E1 and E2 dans MiniProc"); +#endif + + if (s < r || v < u) + return; + inf = u; + /* sup = v; */ + +#ifdef DEBUG + for (i = r; i < s; i++) + util_Assert (T[i][c] <= T[i + 1][c], "Wrong order in MiniProc1"); + for (i = u; i < v; i++) + util_Assert (T[i][c] <= T[i + 1][c], "Wrong order in MiniProc1"); +#endif + + + for (i = r; i <= s; i++) { + low = T[i][c] - work->dlim; + high = low + 2.0 * work->dlim; + /* consider only points at distance <= dlim of T[i] w.r. to coord. c */ + while (inf <= v && T[inf][c] <= low) + ++inf; + j = inf; + while (j <= v && T[j][c] < high) { + res->Distance (res, T[i], T[j]); + ++j; + } + if (work->Torus) { /* AND (np <= kk): does not work with this + cond. */ + + /* Search for close points in the torus */ + low += 1.0; + high -= 1.0; + k = u; + l = v; + while (k <= v && T[k][c] < high) { + res->Distance (res, T[i], T[k]); + ++k; + } + while (l >= u && T[l][c] > low) { + res->Distance (res, T[i], T[l]); + --l; + } + } + } +} + + +/*=========================================================================*/ + +void snpair_CheckBoundary (snpair_Res * res, long r, long s, long u, long v, + int nr, int nrb, int np, int c) +/* + * Compute the minimal distance between the points of the sets E1 = A[r..s] + * and E2 = A[u..v]. + * nrb is the recursion level of the calls of snpair_CheckBoundary. + * A always stands for Points[np], sorted with respect to coordinate c. + */ +{ + long jmed2, imed2; + long jmed, imed; + long nextc; + lebool newc; + snpair_PointTableType B, A; + WorkType *work = res->work; + +#ifdef DEBUG + printf ("CheckBoundary: "); + printf (" %8ld %8ld %8ld %8ld %3d %3d %3d %3d\n", + r, s, u, v, nr, nrb, np, c); +#endif + + if (r > s || u > v) + return; + + util_Assert (np <= work->Maxnp, "np > Maxnp in snpair_CheckBoundary"); + A = res->Points[np]; + newc = ((nrb - 1) % work->L2) == 0; + if (newc && np < work->Maxnp) { + B = res->Points[np + 1]; + ++np; + if (c < work->kk) + nextc = c + 1; + else + nextc = 1; + + /* Copy the remaining points in the table of level np+1, then */ + /* sort with respect to coordinate nextc. */ + CopyPoints (A, B, r, s); + CopyPoints (A, B, u, v); + snpair_QuickSort (B, r, s, nextc); + snpair_QuickSort (B, u, v, nextc); + + } else { + nextc = c; + B = A; + } + + if ((nrb >= work->kk || s - r < snpair_env.Seuil2) + || v - u < snpair_env.Seuil2) { + /* Max recursion or small sets of points */ + res->MiniProc (res, B, r, s, u, v, np, nextc); + return; + } + + /* We halve each set of points, and we check each half on one side */ + /* with each half of the other side. */ + imed = (r + s) / 2; + jmed = (u + v) / 2; + + /* Check the halves which are face to face */ + snpair_CheckBoundary (res, r, imed, u, jmed, nr + 1, nrb + 1, np, nextc); + snpair_CheckBoundary (res, imed + 1, s, jmed + 1, v, nr + 1, nrb + 1, np, + nextc); + + /* Check the other (crossed) halves */ + if ((work->Torus && np <= work->kk) && newc) { + imed2 = imed; + jmed2 = jmed + 1; + dlimSlice (res, B, &r, &imed2, &jmed2, &v, nextc, TRUE); + snpair_CheckBoundary (res, r, imed2, jmed2, v, nr + 1, nrb + 1, np, + nextc); + + imed2 = imed + 1; + jmed2 = jmed; + dlimSlice (res, B, &u, &jmed2, &imed2, &s, nextc, TRUE); + snpair_CheckBoundary (res, u, jmed2, imed2, s, nr + 1, nrb + 1, np, + nextc); + } + + jmed2 = jmed + 1; + imed2 = imed + 1; + if (newc) + dlimSlice (res, B, &r, &imed, &jmed2, &v, nextc, FALSE); + snpair_CheckBoundary (res, r, imed, jmed + 1, v, nr + 1, nrb + 1, np, + nextc); + if (newc) + dlimSlice (res, B, &u, &jmed, &imed2, &s, nextc, FALSE); + snpair_CheckBoundary (res, u, jmed, imed + 1, s, nr + 1, nrb + 1, np, + nextc); +} + + +/*=========================================================================*/ + +static void Setdlim (snpair_Res *res, snpair_PointType A[], long r, long s) +/* + * Used in snpair_BickelBreiman to update dlim + */ +{ + long i; + WorkType *work = res->work; + + work->dlimp = 0.0; + for (i = r; i <= s; i++) { + if (A[i][0] > work->dlimp) + work->dlimp = A[i][0]; + } + if (work->pp == 0 || work->pp == 1) + work->dlim = work->dlimp; + else if (work->pp == 2) + work->dlim = sqrt (work->dlimp); + else + work->dlim = pow (work->dlimp, work->Invp); + +#ifdef DEBUG + printf ("Setdlim: "); + num_WriteD (work->dlim, 10, 5, 1); + printf ("\n"); +#endif +} + + +/*=========================================================================*/ + +void snpair_FindClosePairs (snpair_Res * res, long r, long s, + int nr, int np, int c) +/* + * Checks whether the minimal distance between the 2 nearest points, + * amongst those with indices [r..s] in the table of level np, is < dlim. + * If so, updates dlim and dlimp. A and B are always Points [np] and + * Points [np+1]. + * Assume that A = Point [np] is sorted with respect to coordinate c. + */ +{ + long jmed2; + long imed2; + long imed; + long nextc; /* Next coordinate to be used */ + snpair_PointTableType B; + snpair_PointTableType A; + WorkType *work = res->work; + + /* IF (((nr-1) MOD L) = 0) THEN newc := TRUE ELSE newc := FALSE END; */ +#ifdef DEBUG + printf ("FindClosePairs: "); + printf (" %8ld %8ld %3d %3d %3d\n", r, s, nr, np, c); +#endif + + util_Assert (np <= work->Maxnp, "np > Maxnp in snpair_FindClosePairs"); + A = res->Points[np]; + if (s - r < snpair_env.Seuil1) { + res->VerifPairs (res, A, r, s, np, c); + /* Here we are finished */ + return; + } + + /* We divide the points in 2 approximately equal sets E1 and E2; */ + /* then recursions upon the sets E1 and E2. */ + imed = (r + s) / 2; + if (nr % work->L1 == 0 && np < work->Maxnp && np < work->kk) { + /****** Condition np < kk is temporary... ********/ + util_Assert (np == 1 + (nr - 1) / work->L1, + "Bad np in snpair_FindClosePairs"); + /* IF np >= Maxnp THEN VerifPairs (A^, r, s, nr, c); RETURN END; */ + + /* We shall now increase np and switch coordinate. */ + /* Copy the points in a new table for the next level. */ + B = res->Points[np + 1]; + CopyPoints (A, B, r, s); + if (c < work->kk) + nextc = c + 1; + else + nextc = 1; + util_Assert (nextc == 1 + (np % work->kk), + "Bad nextc dans snpair_FindClosePairs"); + snpair_QuickSort (B, r, imed, nextc); + snpair_QuickSort (B, imed + 1, s, nextc); + snpair_FindClosePairs (res, r, imed, nr + 1, np + 1, nextc); + snpair_FindClosePairs (res, imed + 1, s, nr + 1, np + 1, nextc); + + } else { + snpair_FindClosePairs (res, r, imed, nr + 1, np, c); + snpair_FindClosePairs (res, imed + 1, s, nr + 1, np, c); + } + + /* It remains to check the boundary between E1 and E2. */ + if (work->kk == 1) { + res->Distance (res, A[imed], A[imed + 1]); + if (work->Torus) + res->Distance (res, A[r], A[s]); + return; + } + + /* Bring m and n closer in order to sqeeze only the points which could */ + /* be at a distance less than dlim from the median. */ + if (work->BBFlag) + Setdlim (res, A, r, s); + if (work->Torus && np <= work->kk && (nr - 1) % work->L1 == 0) { + imed2 = imed; + jmed2 = imed + 1; + dlimSlice (res, A, &r, &imed2, &jmed2, &s, c, TRUE); + snpair_CheckBoundary (res, r, imed2, jmed2, s, nr, 1, np, c); + } + + jmed2 = imed + 1; + dlimSlice (res, A, &r, &imed, &jmed2, &s, c, FALSE); + snpair_CheckBoundary (res, r, imed, jmed2, s, nr, 1, np, c); +} + + +/*=========================================================================*/ + +#if 0 +#define Epsilon 1.0e-10 + +static double Probsup (double b, double c, double x) +{ + int jsup; + int msup; + int m; + int j; + double comb; + double mLR; + double jLR; + double mFact; + double Sum2; + double Sum; + double Previous; + + if (x < 0.0) + return 0.0; + + Sum = 0.0; + mFact = 1.0; + if (x <= 0.0) { + msup = c * b; + if (msup > 100) { + msup = 100; + util_Warning (TRUE, "Probsup: msup > 100. Reset to 100"); + } + for (m = 1; m <= msup; m++) { + mLR = m; + mFact *= mLR; + Sum += (pow (b, mLR) / mFact) * (1.0 - mLR / (c * b)); + } + if (msup >= 0) + Sum += 1.0; + return Sum * exp (-b); + } + + Previous = -1.0; + m = 1; + msup = c * b + x; + if (msup > 100) { + msup = 100; + util_Warning (TRUE, "Probsup: msup > 100. Reset to 100"); + } + while (m <= msup && Sum - Previous > Epsilon) { + Previous = Sum; + Sum2 = 0.0; + mLR = m; + mFact *= mLR; + jsup = x; + if (jsup > m) { + jsup = m; + util_Warning (TRUE, "Probsup: jsup > m. Reset to m"); + } + comb = 1.0; + for (j = 0; j <= jsup; j++) { + jLR = j; + Sum2 += comb * pow (jLR - x, jLR) * + pow (c * b + x - jLR, mLR - jLR - 1.0); + comb *= (mLR - jLR) / (jLR + 1.0); + } + Sum += (c * b + x - mLR) / (mFact * pow (c, mLR)) * Sum2; + ++m; + } + if (msup >= 0) + Sum += 1.0; + return Sum * exp (-b); +} + + +/*=========================================================================*/ + +static double Probinf (double b, double c, double x) +{ + int msup; + int m; + double mLR; + double mFact; + double Sum; + + if (x >= 0.0) + return 1.0; + + msup = c * b + x; + if (msup > 100) { + msup = 100; + util_Warning (TRUE, "Probinf: msup > 100. Reset to 100"); + } + Sum = 0.0; + mFact = 1.0; + for (m = 1; m <= msup; m++) { + mLR = m; + mFact *= mLR; + Sum += exp (-(mLR - x) / c) * + (pow (mLR - x, mLR - 1.0) / (pow (c, mLR) * mFact)); + } + if (msup >= 0) + Sum = -(x * Sum) + exp (x / c); + return Sum; +} + + +/*=========================================================================*/ + +static double FDistGPlus (double Bidon, double c) +/* + * Obsolete. This discontinuous distribution uses a complicated statistic + * and did not seem sensitive. We don't use it anymore. + + * See the reference + * P. L'Ecuyer, J.-F. Cordeau, and R. Simard, "Close-Point Spatial Tests + * and their Application to Random Number Generators", + * Operations Research, 48, 2 (2000), 308--317 + * + */ +{ + int lSup; + int l; + double lLR; + double lFact; + double Previous; + double Sum; + + if ((!GPlusFlag || GPlust0 != t0) || GPlust1 != t1) { + GPlust0 = t0; + GPlust1 = t1; + GPlusFlag = TRUE; + /* + fdist_FindJumps (W, Detail); + + FindJumpsKnown (Bidon, FDistGPlus, GPlust0, 20.0, 0.00001, &GPlusNJump, + &GPlusJumpX, &GPlusJumpYBottom, &GPlusJumpYTop);*/ + } + + if (c < 0.0) + return 0.0; + l = 1; + Sum = 0.0; + Previous = -1.0; + lFact = 1.0; + lSup = GPlust0 * c; + while (l <= lSup && Sum - Previous > Epsilon) { + Previous = Sum; + lLR = l; + lFact *= lLR; + Sum += pow (GPlust0, lLR) / lFact * + Probsup (GPlust1 - GPlust0, c, GPlust0 * c - lLR); + ++l; + } + Sum += Probsup (GPlust1 - GPlust0, c, GPlust0 * c); + return Sum * exp (-GPlust0); +} + + +/*=========================================================================*/ + +static double FDistGMinus (double Bidon, double c) +/* + * Obsolete. This discontinuous distribution uses a complicated statistic + * and did not seem sensitive. We don't use it anymore. + + * See the reference + * P. L'Ecuyer, J.-F. Cordeau, and R. Simard, "Close-Point Spatial Tests + * and their Application to Random Number Generators", + * Operations Research, 48, 2 (2000), 308--317 + * + */ +{ + int l; + double lLR; + double lFact; + double Previous; + double Sum; + + if ((!GMinusFlag || GMinust0 != t0) || GMinust1 != t1) { + GMinust0 = t0; + GMinust1 = t1; + GMinusFlag = TRUE; + /* + FindJumpsKnown (Bidon, FDistGMinus, GMinust1, 20.0, 0.00001, + &GMinusNJump, &GMinusJumpX, &GMinusJumpYBottom, &GMinusJumpYTop); + */ + } + + if (c < 0.0) + return 0.0; + l = 1; + Sum = 0.0; + Previous = -1.0; + lFact = 1.0; + while (Sum - Previous > Epsilon) { + Previous = Sum; + lLR = l; + lFact *= lLR; + Sum += pow (GMinust0, lLR) / lFact * + Probinf (GMinust1 - GMinust0, c, GMinust0 * c - lLR); + ++l; + } + Sum += Probinf (GMinust1 - GMinust0, c, GMinust0 * c); + return Sum * exp (-GMinust0); +} + + +/*=========================================================================*/ + +static double FDistHPlus (double b, double x) +/* + * Obsolete. This discontinuous distribution uses a complicated statistic + * and did not seem sensitive. We don't use it anymore. + + * See the reference + * P. L'Ecuyer, J.-F. Cordeau, and R. Simard, "Close-Point Spatial Tests + * and their Application to Random Number Generators", + * Operations Research, 48, 2 (2000), 308--317 + * + */ +{ + int msup; + int jsup; + int m; + int j; + double comb; + double mLR; + double jLR; + double mFact; + double Sum2; + double Sum; + double Previous; + + if ((!HPlusFlag || HPlust0 != t0) || HPlust1 != t1) { + /* this function has a single jump at x = 0 */ + HPlust0 = t0; + HPlust1 = t1; + HPlusFlag = TRUE;/* + FindJumpsKnown (b, FDistHPlus, 1.0, 0.00001, 1.E-6, &HPlusNJump, + &HPlusJumpX, &HPlusJumpYBottom, &HPlusJumpYTop);*/ + } + + if (x < 0.0) + return 0.0; + + Sum = 0.0; + mFact = 1.0; + if (x <= 0.0) { + msup = b; + if (msup > 100) + msup = 100; + for (m = 1; m <= msup; m++) { + mLR = m; + mFact *= mLR; + Sum += pow (b, mLR) / mFact * (1.0 - mLR / b); + } + if (msup >= 0) + Sum += 1.0; + return Sum * exp (-b); + } + + Previous = -1.0; + m = 1; + msup = b + x; + if (msup > 100) + msup = 100; + while (m <= msup && Sum - Previous > Epsilon) { + Previous = Sum; + Sum2 = 0.0; + mLR = m; + mFact *= mLR; + jsup = x; + if (jsup > m) + jsup = m; + comb = 1.0; + for (j = 0; j <= jsup; j++) { + jLR = j; + Sum2 += comb*pow (jLR - x, jLR)*pow (b + x - jLR, mLR - jLR - 1.0); + comb *= (mLR - jLR) / (jLR + 1.0); + } + Sum += (b + x - mLR) / mFact * Sum2; + ++m; + } + if (msup >= 0) + Sum += 1.0; + return Sum * exp (-b); +} + + +/*=========================================================================*/ + +static double FDistHMinus (double b, double x) +/* + * Obsolete. This discontinuous distribution uses a complicated statistic + * and did not seem sensitive. We don't use it anymore. + + * See the reference + * P. L'Ecuyer, J.-F. Cordeau, and R. Simard, "Close-Point Spatial Tests + * and their Application to Random Number Generators", + * Operations Research, 48, 2 (2000), 308--317 + * + */ +{ + int msup; + int m; + double mLR; + double mFact; + double Sum; + + if ((!HMinusFlag || HMinust0 != t0) || HMinust1 != t1) { + HMinust0 = t0; + HMinust1 = t1; + HMinusFlag = TRUE; + /* + FindJumpsKnown (b, FDistHMinus, -b, 0.0001, 0.00001, &HMinusNJump, + &HMinusJumpX, &HMinusJumpYBottom, &HMinusJumpYTop); */ + } + + if (x >= 0.0) + return 1.0; + + msup = b + x; + if (msup > 100) + msup = 100; + Sum = 0.0; + mFact = 1.0; + for (m = 1; m <= msup; m++) { + mLR = m; + mFact *= mLR; + Sum += exp (-(mLR - x)) * (pow (mLR - x, mLR - 1.0) / mFact); + } + + if (msup >= 0) + Sum = -(x * Sum) + exp (x); + return Sum; +} + +#endif + +/*=========================================================================*/ + +static void snpair_AllocPoints (snpair_Res *res, long n) +{ + long i; + WorkType *work = res->work; + + if (n <= 0) + return; + /* Allocates Maxnp tables of pointers to the points; one for each level + of recursion */ + for (i = 1; i <= work->Maxnp; i++) + res->Points[i] = + util_Calloc ((size_t) (n + 1), sizeof (snpair_PointType)); + + /* Allocates memory for the points; initially, only the first table + of pointers, i = 1, points to the points. */ + for (i = 0; i <= n; i++) + res->Points[1][i] = util_Calloc ((size_t) (work->kk + 1), + sizeof (double)); + + res->CloseDist = util_Calloc ((size_t) work->mcd + 1, sizeof (double)); +} + + +/*=========================================================================*/ + +static void snpair_DeletePoints (snpair_Res * res) +/* + * To clean up after the test. + */ +{ + long i; + long n = res->n; + WorkType *work = res->work; + + if (n <= 0) + return; + res->CloseDist = util_Free (res->CloseDist); + + for (i = 0; i <= n; i++) + util_Free (res->Points[1][i]); + + for (i = 1; i <= work->Maxnp; i++) + res->Points[i] = util_Free (res->Points[i]); +} + + +/*=========================================================================*/ + +static void AllocClosePairs ( + snpair_Res *res, /* Results holder */ + long N, + long n, + int m + ) +{ + snpair_AllocPoints (res, n); + res->Yn = statcoll_Create (m, "Yn: The m jumps of Y"); + res->Y = statcoll_Create (N * m + 100, + "Y: All the jumps of Y, superposed"); + res->U = statcoll_Create (N * m, + "U: The jumps of Y transformed into uniforms"); + res->V = statcoll_Create (N * m + 100, "V: A copy of the uniforms"); + res->S = statcoll_Create (N * m + 100, "S: Spacings"); + res->TheWn = statcoll_Create (N, "The N values of the W_n"); + res->TheWni = statcoll_Create (N * m, "The Nm values of the W_{n,i}"); + res->ThepValAD = statcoll_Create (N, "The p-values of A2"); + res->BitMax = statcoll_Create (N, "Largest bit distances"); +} + + +/*=========================================================================*/ + +static void CleanClosePairs (snpair_Res * res) +{ + int i; + res->Yn = statcoll_Delete (res->Yn); + res->Y = statcoll_Delete (res->Y); + res->U = statcoll_Delete (res->U); + res->V = statcoll_Delete (res->V); + res->S = statcoll_Delete (res->S); + res->TheWn = statcoll_Delete (res->TheWn); + res->TheWni = statcoll_Delete (res->TheWni); + res->ThepValAD = statcoll_Delete (res->ThepValAD); + res->BitMax = statcoll_Delete (res->BitMax); + snpair_DeletePoints (res); + for (i = 0; i < snpair_StatType_N; i++) { + res->sVal[i] = -1.0; + res->pVal[i] = -1.0; + } +} + + +/*=========================================================================*/ + +static void InitRes ( + snpair_Res *res, /* Results holder */ + long N, /* Number of replications */ + long n, /* Number of points */ + int m /* Number of closest distances kept */ + ) +/* + * Initializes the res structure + */ +{ + if (res->CleanFlag) + CleanClosePairs (res); + AllocClosePairs (res, N, n, m); + res->n = n; + res->CleanFlag = TRUE; +} + + +/*-------------------------------------------------------------------------*/ + +snpair_Res *snpair_CreateRes (void) +{ + snpair_Res *res; + res = util_Malloc (sizeof (snpair_Res)); + memset (res, 0, sizeof (snpair_Res)); + res->work = util_Malloc (sizeof (WorkType)); + res->CleanFlag = FALSE; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void snpair_DeleteRes (snpair_Res * res) +{ + if (res == NULL) + return; + if (res->CleanFlag) + CleanClosePairs (res); + res->work = util_Free (res->work); + util_Free (res); +} + + +/*=========================================================================*/ + +static void WriteSeuils (WorkType * work, lebool flag, double mu2, + double nLR, double kLR) +{ + printf ("\n Seuil1 = %2d\n Seuil2 = %2d\n " + "Seuil3 = %2d\n Seuil4 = %2d\n" + " L1 = %2d\n L2 = %2d\n s1 = ", snpair_env.Seuil1, + snpair_env.Seuil2, snpair_env.Seuil3, snpair_env.Seuil4, work->L1, + work->L2); + + /* s1 = n / 2^{kL1} */ + num_WriteD (nLR * pow (2.0, -kLR * work->L1), 9, 2, 2); + printf ("\n s2 = "); + /* s2 = n / 2^{kL2} */ + num_WriteD (nLR * pow (2.0, -kLR * work->L2), 9, 2, 2); + printf ("\n\n"); + + if (flag) { + printf (" The minimal distance, to the power k, should be" + " approximately\n exponential with mean mu2 = "); + num_WriteD (mu2, 12, 4, 2); + printf ("\n\n dlim1 = "); + num_WriteD (work->dlim1, 15, 5, 3); + printf ("\n dlim1p = "); + num_WriteD (work->dlim1p, 15, 5, 3); + printf ("\n\n"); + } +} + + +/*=========================================================================*/ + +static void CalcSeuils (WorkType * work, long k, long m, lebool flag, + double mu2, double nLR, double kLR) +{ + work->L1 = 1 + num_Log2 (nLR / snpair_env.Seuil3) / k; + work->L2 = 1 + num_Log2 (nLR / snpair_env.Seuil4) / k; + if (work->L1 < 1) + work->L1 = 1; + if (work->L2 < 1) + work->L2 = 1; + if (k < 6 && work->L1 < 2) + work->L1 = 2; + if (k < 6 && work->L2 < 2) + work->L2 = 2; + work->dlim1 = pow (m * mu2, 1.0 / k); + work->dlim1p = pow (work->dlim1, work->pLR); + if (swrite_Parameters) + WriteSeuils (work, flag, mu2, nLR, kLR); +} + + +/*=========================================================================*/ + +void snpair_WriteDataCP (unif01_Gen * gen, char *TestName, + long N, long n, int r, int t, int p, int m, lebool Torus) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", t = %1d,", t); + if (p >= 0) + printf (" p = %1d,", p); + printf (" m = %1d, Torus = ", m); + util_WriteBool (Torus, 5); + printf ("\n\n"); +} + + +/*=========================================================================*/ +#define SPACINGS_9 +/* + * La constante SPACINGS permet l'inclusion des 4 tests de ClosePairs suivants + * qui sont mis en commentaire sinon: NP-S, NP-PR, mNP1-S, mNP2-S. + */ + +void snpair_WriteResultsCP (unif01_Gen * gen, chrono_Chrono * Timer, + snpair_Res * res, long N, long m) +{ + printf ("\n---------------------------------------\n"); + printf ("Test based on the 2 nearest points (NP):\n\n"); + + if (N == 1) { + printf ("The closest distance : "); + num_WriteD (res->CloseDist[1], 7, 2, 2); + printf ("\n"); + gofw_Writep1 (res->pVal[snpair_NP]); + } else { + printf ("Stat. AD on the N values (NP) :"); + gofw_Writep2 (res->sVal[snpair_NP], res->pVal[snpair_NP]); +#ifdef SPACINGS + printf ("Stat. AD after spacings (NP-S) :"); + gofw_Writep2 (res->sVal[snpair_NPS], res->pVal[snpair_NPS]); + printf ("Stat. AD after power ratio (NP-PR) :"); + gofw_Writep2 (res->sVal[snpair_NPPR], res->pVal[snpair_NPPR]); +#endif + } + + if (m > 1) { + printf ("\nA2 test based on the spacings between the\n" + " successive jump times of process Y_n(t):\n\n"); + printf ("A2 test on the values of A2 (m-NP) :"); + gofw_Writep2 (res->sVal[snpair_mNP], res->pVal[snpair_mNP]); + + if (N > 1) { + printf ("Test on the Nm values of W_{n,i}(mNP1):"); + gofw_Writep2 (res->sVal[snpair_mNP1], res->pVal[snpair_mNP1]); +#ifdef SPACINGS + printf ("Stat. AD after spacings (mNP1-S) :"); + gofw_Writep2 (res->sVal[snpair_mNP1S], res->pVal[snpair_mNP1S]); +#endif + printf ("Test on the jump times of Y\n (superposition of Yn):\n\n"); + printf ("Expected number of jumps of Y = mN : %7ld\n", m*N); + printf ("Number of jumps of Y "); + if (res->sVal[snpair_NJumps] >= N*NUM_JUMPS_LIM) + printf ("> %6.0f *****\n", res->sVal[snpair_NJumps]); + else + printf (": %7.0f\n", res->sVal[snpair_NJumps]); + gofw_Writep1 (res->pVal[snpair_NJumps]); + + if (res->Y->NObs > 0) { + printf ("Stat. AD (mNP2) :"); + gofw_Writep2 (res->sVal[snpair_mNP2], res->pVal[snpair_mNP2]); +#if 1 + if (snpair_mNP2S_Flag) { + printf ("Stat. AD after spacings (mNP2-S) :"); + gofw_Writep2 (res->sVal[snpair_mNP2S], res->pVal[snpair_mNP2S]); + } +#endif + } + } + } + swrite_Final (gen, Timer); +} + + +/*=========================================================================*/ + +void snpair_ClosePairs (unif01_Gen * gen, snpair_Res * res, + long N, long n, int r, int k, int p, int m) +/* + * Looks at the m closest pairs in the torus and the first m jumps of the + * process Y_n(t). A simplified version of snpair_ClosePairs. + */ +{ + long j; + long i; + long Seq; + double Wn; + double t1; + snpair_PointType T; + double x; + double NextJump; + double Jump; + double mu2; /* Expected minimum distance */ + double A2; + double Vol; /* Volume of unit sphere in k dimension */ + double mLR, nLR, kLR; + fmass_INFO Mass; + double pLeft, pRight; + statcoll_Collector *Q; + WorkType *work; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "snpair_ClosePairs test"; + + Timer = chrono_Create (); + if (swrite_Basic) + snpair_WriteDataCP (gen, TestName, N, n, r, k, p, m, TRUE); + + /* util_Assert (k <= snpair_MaxDim, "snpair_ClosePairs: k > + snpair_MaxDim"); + util_Assert (n <= snpair_MaxNumPoints, + "snpair_ClosePairs: n > snpair_MaxNumPoints"); */ + util_Assert (m > 0, "snpair_ClosePairs: m <= 0"); + util_Assert (m <= snpair_MAXM, "snpair_ClosePairs: m > snpair_MAXM"); + if (res == NULL) { + localRes = TRUE; + res = snpair_CreateRes (); + } + work = res->work; + work->Torus = TRUE; + work->kk = k; + work->pp = p; + work->mm = m; + kLR = k; + nLR = n; + mLR = m; + work->mcd = 2 * m; + if (p == 0) + work->pLR = 1.0; + else + work->pLR = p; + work->Invp = 1.0 / work->pLR; + if (k < snpair_MAXREC) + work->Maxnp = k; + else + work->Maxnp = snpair_MAXREC; + work->BBFlag = FALSE; /* Bickel-Breiman Flag */ + + Vol = num2_VolumeSphere ((double) p, k); + mu2 = 2.0 / (nLR * (nLR - 1.0) * Vol); + t1 = mLR; + + CalcSeuils (work, k, m, TRUE, mu2, nLR, kLR); + InitRes (res, N, n, m); + res->Distance = snpair_DistanceCP; + res->VerifPairs = snpair_VerifPairs1; + res->MiniProc = snpair_MiniProc1; + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + + for (i = 1; i <= n; i++) { + /* Generate n points in dimension k */ + T = res->Points[1][i]; + for (j = 1; j <= k; j++) + T[j] = unif01_StripD (gen, r); + } + res->NumClose = 0; + work->dlimp = work->dlim = kLR; /* Initial upper bounds */ + snpair_QuickSort (res->Points[1], 1, n, 1); + snpair_FindClosePairs (res, 1, n, 1, 1, 1); + Wn = 1.0 - exp (-pow (res->CloseDist[1], kLR) / mu2); + statcoll_AddObs (res->TheWn, Wn); + statcoll_Init (res->Yn, m); + statcoll_Init (res->U, m); + if (m > 1) { + /* Calculate the spacings Delta_{n,i} between the jumps of Y_n, */ + /* then the W^*_{n(i)}, which are in principle i.i.d. U(0,1). */ + Jump = 0.0; + for (i = 1; i <= m; i++) { + NextJump = pow (res->CloseDist[i], kLR) / mu2; + statcoll_AddObs (res->Yn, NextJump); + x = 1.0 - exp (-(NextJump - Jump)); + statcoll_AddObs (res->U, x); + statcoll_AddObs (res->TheWni, x); + Jump = NextJump; + } + + tables_QuickSortD (res->U->V, 1, m); + /* res->U should now contain m random var. i.i.d U(0,1), sorted */ + if (swrite_Collectors) { + statcoll_Write (res->Yn, 5, 14, 4, 3); + statcoll_Write (res->U, 5, 14, 4, 3); + } + A2 = gofs_AndersonDarling (res->U->V, m); + x = fbar_AndersonDarling (m, A2); + statcoll_AddObs (res->ThepValAD, x); + + if (N > 1) { + /* Put in res->Y all the jumps between 0 and t1 */ + for (i = 1; i <= res->NumClose; i++) { + NextJump = pow (res->CloseDist[i], kLR) / mu2; + if (NextJump <= t1) + statcoll_AddObs (res->Y, NextJump); + } + } + } + } + + if (N == 1) + res->pVal[snpair_NP] = 1.0 - Wn; + else { + Q = res->TheWn; + tables_QuickSortD (Q->V, 1, N); + /* Test NP at level 1 */ + res->sVal[snpair_NP] = gofs_AndersonDarling (Q->V, N); + res->pVal[snpair_NP] = fbar_AndersonDarling (N, res->sVal[snpair_NP]); + +#ifdef SPACINGS + /* Test NP with the spacings */ + tables_CopyTabD (Q->V, res->V->V, 1, N); + gofs_DiffD (res->V->V, res->S->V, 1, N, 0.0, 1.0); + gofs_IterateSpacings (res->V->V, res->S->V, N); + tables_QuickSortD (res->V->V, 1, N); + res->sVal[snpair_NPS] = gofs_AndersonDarling (res->V->V, N); + res->pVal[snpair_NPS] = + fbar_AndersonDarling (N, res->sVal[snpair_NPS]); + /* Test NP with power ratio */ + tables_CopyTabD (Q->V, res->V->V, 1, N); + gofs_PowerRatios (res->V->V, N); + tables_QuickSortD (res->V->V, 1, N); + res->sVal[snpair_NPPR] = gofs_AndersonDarling (res->V->V, N); + res->pVal[snpair_NPPR] = + fbar_AndersonDarling (N, res->sVal[snpair_NPPR]); +#endif + } + + if (m > 1) { + if (N == 1) { + res->sVal[snpair_mNP] = A2; + res->pVal[snpair_mNP] = res->ThepValAD->V[1]; + } else { + tables_CopyTabD (res->ThepValAD->V, res->V->V, 1, N); + tables_QuickSortD (res->V->V, 1, N); + res->sVal[snpair_mNP] = gofs_AndersonDarling (res->V->V, N); + res->pVal[snpair_mNP] = + fbar_AndersonDarling (N, res->sVal[snpair_mNP]); + Q = res->TheWni; + tables_QuickSortD (Q->V, 1, Q->NObs); + /* Here, Q->NObs = N*m */ + res->sVal[snpair_mNP1] = gofs_AndersonDarling (Q->V, Q->NObs); + res->pVal[snpair_mNP1] = + fbar_AndersonDarling (Q->NObs, res->sVal[snpair_mNP1]); +#ifdef SPACINGS + /* Test NP with the spacings */ + tables_CopyTabD (Q->V, res->V->V, 1, Q->NObs); + gofs_DiffD (res->V->V, res->S->V, 1, Q->NObs, 0.0, 1.0); + gofs_IterateSpacings (res->V->V, res->S->V, Q->NObs); + tables_QuickSortD (res->V->V, 1, Q->NObs); + res->sVal[snpair_mNP1S] = gofs_AndersonDarling (res->V->V, Q->NObs); + res->pVal[snpair_mNP1S] = + fbar_AndersonDarling (Q->NObs, res->sVal[snpair_mNP1S]); +#endif + /* Superposition process of all the jumps of Y_n in [0, t1]. + Conditionnally on TotJumps = res->Y^.NObs, these jumps should be + uniformly distributed in [0, t1]. */ + + Q = res->Y; + for (i = 1; i <= Q->NObs; i++) + Q->V[i] /= t1; + if (Q->NObs > 0) { + tables_QuickSortD (Q->V, 1, Q->NObs); + /* res->Y must now contain random var. i.i.d U(0,1), sorted */ + res->sVal[snpair_mNP2] = gofs_AndersonDarling (Q->V, Q->NObs); + res->pVal[snpair_mNP2] = + fbar_AndersonDarling (Q->NObs, res->sVal[snpair_mNP2]); + } + + Mass = fmass_CreatePoisson (N * m); + pLeft = fdist_Poisson2 (Mass, res->Y->NObs); + pRight = fbar_Poisson2 (Mass, res->Y->NObs); + fmass_DeletePoisson (Mass); + res->sVal[snpair_NJumps] = res->Y->NObs; + res->pVal[snpair_NJumps] = gofw_pDisc (pLeft, pRight); + +#if 1 + /* Test on res->Y with the spacings */ + statcoll_Init (res->V, Q->Dim); + statcoll_Init (res->S, Q->Dim); + tables_CopyTabD (Q->V, res->V->V, 1, Q->NObs); + gofs_DiffD (res->V->V, res->S->V, 1, Q->NObs, 0.0, 1.0); + gofs_IterateSpacings (res->V->V, res->S->V, Q->NObs); + tables_QuickSortD (res->V->V, 1, Q->NObs); + res->sVal[snpair_mNP2S] = gofs_AndersonDarling (res->V->V, Q->NObs); + res->pVal[snpair_mNP2S] = + fbar_AndersonDarling (Q->NObs, res->sVal[snpair_mNP2S]); +#endif + } + } + + if (swrite_Collectors) { + if (N > 1) + statcoll_Write (res->Y, 5, 14, 4, 3); + statcoll_Write (res->TheWn, 5, 14, 4, 3); + statcoll_Write (res->TheWni, 5, 14, 4, 3); + statcoll_Write (res->ThepValAD, 5, 14, 4, 3); + } + + if (swrite_Basic) + snpair_WriteResultsCP (gen, Timer, res, N, m); + if (localRes) + snpair_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ +#if 0 + +void snpair_ReTestY (long N, long n, int m, double tt0, double tt1) +/* + * Make more (experimental) tests on Y after a call to ClosePairs1 + * (To do?? We should renormalize the Y[i] by multiplying them by nM) + + ***************************************** + This procedure is not used anymore. It makes use of discontinuous + distribution functions and the associated statistics are very + complicated and did not seem sensitive. + **************************************** + */ +{ + long i; + double Bidon; + double x; + double iLR; + double Fact; + double HM; + double HP; + double GM; + double GP; + statcoll_Collector *Q = res->Y; + fdist_FUNC_JUMPS *GPJumps; /* All info on the jumps of G+ */ + fdist_FUNC_JUMPS *GMJumps; /* All info on the jumps of G- */ + fdist_FUNC_JUMPS *HPJumps; /* All info on the jumps of H+ */ + fdist_FUNC_JUMPS *HMJumps; /* All info on the jumps of H- */ + + /* Calculate statistics G+, G-, H+, H- */ + util_Assert (!swrite_AutoClean, + "snpair_ReTestY: swrite_AutoClean must be FALSE"); + util_Assert (res->Y != NULL, + "snpair_ReTestY: res->Y is a NULL pointer"); + + Fact = N * m; + for (i = 1; i <= Q->NObs; i++) + Q->V[i] *= Fact; + HP = 0.0; + HM = 0.0; + i = 1; + while (Q->V[i] <= tt0 && i <= Q->NObs) + ++i; + GP = (i - 1) / tt0; + while (Q->V[i] <= tt1 && i <= Q->NObs) + ++i; + GM = (i - 1) / tt1; + if (i - 1 - tt1 < 0.0) + HM = i - 1 - tt1; + + for (i = 1; i <= Q->NObs; i++) { + if (Q->V[i] <= tt1) { + x = Q->V[i]; + iLR = i; + if (iLR - 1.0 - x < HM) + HM = iLR - 1.0 - x; + if (iLR - x > HP) + HP = iLR - x; + if (Q->V[i] >= tt0) { + if (iLR / x > GP) + GP = iLR / x; + if ((iLR - 1.0) / x < GM) + GM = (iLR - 1.0) / x; + } + } + } + + res->pVal[snpair_GPlus] = 1.0 - FDistGPlus (Bidon, GP); + res->sVal[snpair_GPlus] = GP; + res->pVal[snpair_GMinus] = 1.0 - FDistGMinus (Bidon, GM); + res->sVal[snpair_GMinus] = GM; + res->pVal[snpair_HPlus] = 1.0 - FDistHPlus (Bidon, HP); + res->sVal[snpair_HPlus] = HP; + res->pVal[snpair_HMinus] = 1.0 - FDistHMinus (Bidon, HM); + res->sVal[snpair_HMinus] = HM; + + if (swrite_Basic) { + printf ("Test on the statistic G+ :"); + gofw_Writep2 (GP, res->pVal[snpair_GPlus]); + printf ("\nTest on the statistic G- :"); + gofw_Writep2 (GM, res->pVal[snpair_GMinus]); + printf ("\nTest on the statistic H+ :"); + gofw_Writep2 (HP, res->pVal[snpair_HPlus]); + printf ("\nTest on the statistic H- :"); + gofw_Writep2 (HM, res->pVal[snpair_HMinus]); + printf ("\n"); + } +} + +#endif + +/*=========================================================================*/ + +static void InitBBp0k2 (void) +/* + * Initialize Bickel-Breiman distribution with p = 0, k = 2 + */ +{ + BB2[0] = 0.0; + BB2[1] = 6.6022859e-5; + BB2[2] = 2.111e-3; + BB2[3] = 1.10679e-2; + BB2[4] = 2.99898e-2; + BB2[5] = 5.80398e-2; + BB2[6] = 9.31672e-2; + BB2[7] = 1.326804e-1; + BB2[8] = 1.743017e-1; + BB2[9] = 2.168632e-1; + BB2[10] = 2.589057e-1; + BB2[11] = 2.996407e-1; + BB2[12] = 3.387514e-1; + BB2[13] = 3.758668e-1; + BB2[14] = 4.108985e-1; + BB2[15] = 4.442291e-1; + BB2[16] = 4.757295e-1; + BB2[17] = 5.053408e-1; + BB2[18] = 5.330166e-1; + BB2[19] = 5.589979e-1; + BB2[20] = 0.58358; + BB2[21] = 6.067753e-1; + BB2[22] = 6.281726e-1; + BB2[23] = 6.483016e-1; + BB2[24] = 6.670896e-1; + BB2[25] = 6.848204e-1; + BB2[26] = 7.016251e-1; + BB2[27] = 7.17358e-1; + BB2[28] = 7.319895e-1; + BB2[29] = 7.458925e-1; + BB2[30] = 7.589198e-1; + BB2[31] = 7.712947e-1; + BB2[32] = 7.82992e-1; + BB2[33] = 7.939033e-1; + BB2[34] = 8.044324e-1; + BB2[35] = 8.14079e-1; + BB2[36] = 8.233257e-1; + BB2[37] = 8.319796e-1; + BB2[38] = 8.402721e-1; + BB2[39] = 0.84794; + BB2[40] = 8.55173e-1; + BB2[41] = 8.621625e-1; + BB2[42] = 8.686291e-1; + BB2[43] = 8.748893e-1; + BB2[44] = 8.809175e-1; + BB2[45] = 8.864606e-1; + BB2[46] = 8.918151e-1; + BB2[47] = 8.968588e-1; + BB2[48] = 9.016258e-1; + BB2[49] = 9.061704e-1; + BB2[50] = 9.104084e-1; + BB2[51] = 9.143753e-1; + BB2[52] = 9.182571e-1; + BB2[53] = 9.219001e-1; + BB2[54] = 9.254505e-1; + BB2[55] = 9.28772e-1; + BB2[56] = 9.320133e-1; + BB2[57] = 9.351203e-1; + BB2[58] = 9.380936e-1; + BB2[59] = 9.408087e-1; + BB2[60] = 9.434704e-1; + BB2[61] = 9.459541e-1; + BB2[62] = 9.483018e-1; + BB2[63] = 0.95057; + BB2[64] = 9.526812e-1; + BB2[65] = 9.547303e-1; + BB2[66] = 9.566821e-1; + BB2[67] = 9.585939e-1; + BB2[68] = 9.603836e-1; + BB2[69] = 9.62073e-1; + BB2[70] = 9.637419e-1; + BB2[71] = 9.652689e-1; + BB2[72] = 9.666498e-1; + BB2[73] = 9.680299e-1; + BB2[74] = 9.693984e-1; + BB2[75] = 9.707229e-1; + BB2[76] = 9.720219e-1; + BB2[77] = 9.731801e-1; + BB2[78] = 9.742979e-1; + BB2[79] = 9.753166e-1; + BB2[80] = 9.763355e-1; + BB2[81] = 9.773626e-1; + BB2[82] = 9.782835e-1; + BB2[83] = 9.792146e-1; + BB2[84] = 9.800791e-1; + BB2[85] = 9.808841e-1; + BB2[86] = 9.816958e-1; + BB2[87] = 9.824477e-1; + BB2[88] = 9.831492e-1; + BB2[89] = 9.838786e-1; + BB2[90] = 9.845241e-1; + BB2[91] = 9.851295e-1; + BB2[92] = 9.857702e-1; + BB2[93] = 9.863849e-1; + BB2[94] = 9.869562e-1; + BB2[95] = 9.875006e-1; + BB2[96] = 9.879895e-1; + BB2[97] = 9.88473e-1; + BB2[98] = 9.889793e-1; + BB2[99] = 9.894184e-1; + BB2[100] = 9.898547e-1; + BB2[101] = 9.902526e-1; + BB2[102] = 9.906462e-1; + BB2[103] = 9.910496e-1; + BB2[104] = 9.914303e-1; + BB2[105] = 9.918174e-1; + BB2[106] = 9.921392e-1; + BB2[107] = 9.924491e-1; + BB2[108] = 9.92784e-1; + BB2[109] = 9.930638e-1; + BB2[110] = 9.933363e-1; + BB2[111] = 9.936298e-1; + BB2[112] = 9.93886e-1; + BB2[113] = 9.941112e-1; + BB2[114] = 9.943411e-1; + BB2[115] = 9.945669e-1; + BB2[116] = 9.947672e-1; + BB2[117] = 9.94994e-1; + BB2[118] = 9.951802e-1; + BB2[119] = 9.953648e-1; + BB2[120] = 9.955457e-1; + BB2[121] = 9.957099e-1; + BB2[122] = 9.959196e-1; + BB2[123] = 9.961046e-1; + BB2[124] = 9.962811e-1; + BB2[125] = 9.964261e-1; + BB2[126] = 9.965653e-1; + BB2[127] = 9.967088e-1; + BB2[128] = 0.99684; + BB2[129] = 9.969537e-1; + BB2[130] = 9.970835e-1; + BB2[131] = 9.972087e-1; +} + + +/*-------------------------------------------------------------------------*/ + +static void InitBBp2k2 (void) +/* + * Initialize Bickel-Breiman distribution with p = 2, k = 2 + */ +{ + BB4[0] = -8.2912955e-1; + BB4[1] = -9.4432194e-1; + BB4[2] = -1.0567132; + BB4[3] = -1.1679847; + BB4[4] = -1.2776563; + BB4[5] = -1.384483; + BB4[6] = -1.4916059; + BB4[7] = -1.5956447; + BB4[8] = -1.6994536; + BB4[9] = -1.8012517; + BB4[10] = -1.9014279; + BB4[11] = -2.0006153; + BB4[12] = -2.0997178; + BB4[13] = -2.1987994; + BB4[14] = -2.2959638; + BB4[15] = -2.391997; + BB4[16] = -2.4867876; + BB4[17] = -2.5815698; + BB4[18] = -2.6761017; + BB4[19] = -2.7658218; + BB4[20] = -2.8582757; + BB4[21] = -2.9522569; + BB4[22] = -3.0406141; + BB4[23] = -3.1311066; + BB4[24] = -3.2179075; + BB4[25] = -3.3057192; + BB4[26] = -3.3933087; + BB4[27] = -3.4815725; + BB4[28] = -3.5719191; + BB4[29] = -3.6592077; + BB4[30] = -3.7437809; + BB4[31] = -3.8274559; + BB4[32] = -3.9149689; + BB4[33] = -4.000307; + BB4[34] = -4.0874655; + BB4[35] = -4.1724253; + BB4[36] = -4.2619679; + BB4[37] = -4.3498336; + BB4[38] = -4.4349335; + BB4[39] = -4.5214761; + BB4[40] = -4.607099; + BB4[41] = -4.6921565; + BB4[42] = -4.7799781; + + BB5[0] = -4.5909e-3; + BB5[1] = -3.666e-4; + BB5[2] = 7.508e-5; + BB5[3] = 2.15483e-3; + BB5[4] = 1.115755e-2; + BB5[5] = 3.033271e-2; + BB5[6] = 5.881422e-2; + BB5[7] = 9.422896e-2; + BB5[8] = 1.3423286e-1; + BB5[9] = 1.7618124e-1; + BB5[10] = 2.1865118e-1; + BB5[11] = 2.6082507e-1; + BB5[12] = 3.0215075e-1; + BB5[13] = 3.4140313e-1; + BB5[14] = 3.7898955e-1; + BB5[15] = 4.1454877e-1; + BB5[16] = 4.4830003e-1; + BB5[17] = 4.7980029e-1; + BB5[18] = 5.093375e-1; + BB5[19] = 5.3717465e-1; + BB5[20] = 5.6357091e-1; + BB5[21] = 5.8817876e-1; +} + + +/*-------------------------------------------------------------------------*/ + +static void InitBBp0k15 (void) +/* + * Initialize Bickel-Breiman distribution with p = 0, k = 15 + */ +{ + BB3[0] = 0.0; + BB3[1] = 1.6778e-4; + BB3[2] = 2.6967455e-3; + BB3[3] = 1.28187e-2; + BB3[4] = 3.25519e-2; + BB3[5] = 0.06001; + BB3[6] = 9.28778e-2; + BB3[7] = 1.292254e-1; + BB3[8] = 1.674211e-1; + BB3[9] = 2.066797e-1; + BB3[10] = 2.439418e-1; + BB3[11] = 2.805974e-1; + BB3[12] = 3.156376e-1; + BB3[13] = 3.487236e-1; + BB3[14] = 3.804003e-1; + BB3[15] = 4.103833e-1; + BB3[16] = 4.394161e-1; + BB3[17] = 4.673735e-1; + BB3[18] = 4.935018e-1; + BB3[19] = 5.181638e-1; + BB3[20] = 5.403617e-1; + BB3[21] = 5.609553e-1; + BB3[22] = 5.813387e-1; + BB3[23] = 6.003938e-1; + BB3[24] = 6.188892e-1; + BB3[25] = 6.353537e-1; + BB3[26] = 6.509678e-1; + BB3[27] = 6.658608e-1; + BB3[28] = 6.797704e-1; + BB3[29] = 6.93198e-1; + BB3[30] = 7.059891e-1; + BB3[31] = 7.185495e-1; + BB3[32] = 7.306549e-1; + BB3[33] = 7.413516e-1; + BB3[34] = 7.517439e-1; + BB3[35] = 7.617069e-1; + BB3[36] = 7.709877e-1; + BB3[37] = 7.804121e-1; + BB3[38] = 7.898275e-1; + BB3[39] = 7.984594e-1; + BB3[40] = 8.058125e-1; + BB3[41] = 8.129582e-1; + BB3[42] = 8.199078e-1; + BB3[43] = 8.26626e-1; + BB3[44] = 8.332602e-1; + BB3[45] = 8.393936e-1; + BB3[46] = 8.452292e-1; + BB3[47] = 8.510694e-1; + BB3[48] = 8.569731e-1; + BB3[49] = 8.621826e-1; + BB3[50] = 8.671328e-1; + BB3[51] = 8.723293e-1; + BB3[52] = 8.770461e-1; + BB3[53] = 8.814338e-1; + BB3[54] = 8.853624e-1; + BB3[55] = 8.897322e-1; + BB3[56] = 8.937578e-1; + BB3[57] = 8.97254e-1; + BB3[58] = 9.008031e-1; + BB3[59] = 9.042233e-1; + BB3[60] = 9.076829e-1; + BB3[61] = 9.11218e-1; + BB3[62] = 9.139078e-1; + BB3[63] = 9.170002e-1; + BB3[64] = 9.199191e-1; + BB3[65] = 9.226127e-1; + BB3[66] = 9.250731e-1; + BB3[67] = 9.277341e-1; + BB3[68] = 9.301693e-1; + BB3[69] = 9.324761e-1; + BB3[70] = 9.347405e-1; + BB3[71] = 9.370394e-1; + BB3[72] = 9.390614e-1; + BB3[73] = 9.41111e-1; + BB3[74] = 9.429319e-1; + BB3[75] = 9.448513e-1; + BB3[76] = 9.466235e-1; + BB3[77] = 9.483763e-1; + BB3[78] = 9.500882e-1; + BB3[79] = 9.517579e-1; + BB3[80] = 9.531616e-1; + BB3[81] = 9.546471e-1; + BB3[82] = 9.561263e-1; + BB3[83] = 9.576014e-1; + BB3[84] = 9.592471e-1; + BB3[85] = 9.605977e-1; + BB3[86] = 9.618122e-1; + BB3[87] = 9.632723e-1; + BB3[88] = 9.644877e-1; + BB3[89] = 9.654043e-1; + BB3[90] = 9.666469e-1; + BB3[91] = 9.676583e-1; + BB3[92] = 9.687529e-1; + BB3[93] = 9.697718e-1; + BB3[94] = 9.708359e-1; + BB3[95] = 9.716986e-1; + BB3[96] = 9.726066e-1; + BB3[97] = 9.734057e-1; + BB3[98] = 9.743224e-1; + BB3[99] = 9.751716e-1; + BB3[100] = 9.759489e-1; + BB3[101] = 9.766958e-1; + BB3[102] = 9.774256e-1; + BB3[103] = 9.783317e-1; + BB3[104] = 9.789422e-1; + BB3[105] = 9.795293e-1; + BB3[106] = 9.801187e-1; + BB3[107] = 9.807522e-1; + BB3[108] = 9.812972e-1; + BB3[109] = 9.818664e-1; + BB3[110] = 9.825167e-1; + BB3[111] = 9.831091e-1; + BB3[112] = 9.835873e-1; + BB3[113] = 9.840919e-1; + BB3[114] = 9.845122e-1; + BB3[115] = 9.850374e-1; + BB3[116] = 9.854874e-1; + BB3[117] = 9.859857e-1; + BB3[118] = 9.865129e-1; + BB3[119] = 9.869294e-1; + BB3[120] = 9.873618e-1; + BB3[121] = 9.877482e-1; + BB3[122] = 9.880475e-1; +} + + +/*-------------------------------------------------------------------------*/ + +static double FDistBBp0k2 (double junk[], double x) +/* + * Bickel-Breiman distribution obtained by simulation with + * N = 1000000, n = 1000, r = 0, k = 2, p = 0, Torus = TRUE + * + * We first interpolated the empirical distribution on the points xs = j/100 + * (integer j) by building a parabola using a least-square fit with all + * the points in [xs - 0.005, xs + 0.005], and then by computing ys(xs) on + * the parabola, in order to reduce the noise. + * We use a Newton cubic interpolation with the 4 points closest to x to + * compute the distribution y(x). + */ +{ + static lebool BBp0k2Flag = FALSE; + int j; + double q; + double y; + if (x >= 6.0) + return 1.0; + if (x >= 1.3) + return 1.0 - exp (-5.94558e-1 - 3.99672 * x); + if (x <= 0.014) + return 0.0; + if (x <= 0.02) { + return -2.66337e-3 + x * (5.12234e-1 + x * (-32.8023 + 701.167 * x)); + } + + if (FALSE == BBp0k2Flag) { + InitBBp0k2 (); + BBp0k2Flag = TRUE; + } + + j = 100.0 * x + 2; /* x is in [P(j-2), P(j-1)] */ + q = 100.0 * x - j; + + /* Newton backward cubic interpolation */ + y = BB2[j - 1] + (BB2[j - 1] - BB2[j - 2]) * q + (((BB2[j - 3] + - 2.0 * BB2[j - 2]) + BB2[j - 1]) * q * (q + 1.0)) / 2.0 + + ((((-BB2[j - 4] + 3.0 * BB2[j - 3]) - + 3.0 * BB2[j - 2]) + BB2[j - 1]) * q * (q + 1.0) * (q + + 2.0)) / 6.0; + + return y; +} + + +/*-------------------------------------------------------------------------*/ + +static double FDistBBp0k15 (double junk[], double x) +/* + * Bickel-Breiman distribution obtained by simulation with + * N = 100000, n = 1000, r = 0, k = 15, p = 0, Torus = TRUE + * + * We first interpolated the empirical distribution on the points xs = j/100 + * (integer j) by building a parabola using a least-square fit with all + * the points in [xs - 0.005, xs + 0.005], and then by computing ys(xs) on + * the parabola, in order to reduce the noise. + * We use a Newton cubic interpolation with the 4 points closest to x to + * compute the distribution y(x). + */ +{ + static lebool BBp0k15Flag = FALSE; + int j; + double q; + double y; + if (x <= 0.015) + return 0.0; + if (x <= 0.02) + return (6.1123 * x - 0.18384) * x + 1.3984e-3; + if (x >= 6.0) + return 1.0; + if (x >= 1.2) + return 1.0 - exp (-3.15786 * x - 5.41639e-1); + + if (FALSE == BBp0k15Flag) { + InitBBp0k15 (); + BBp0k15Flag = TRUE; + } + + j = 100.0 * x + 2; /* x is in [P(j-2), P(j-1)] */ + q = 100.0 * x - j; + + /* Newton backward cubic interpolation */ + y = (BB3[j - 1] - BB3[j - 2]) * q + BB3[j - 1] + + (BB3[j - 3] - 2.0 * BB3[j - 2] + BB3[j - 1]) * q * (q + 1.0) / 2.0 + + (-BB3[j - 4] + 3.0 * BB3[j - 3] - 3.0 * BB3[j - 2] + + BB3[j - 1]) * q * (q + 1.0) * (q + 2.0) / 6.0; + + return y; +} + + +/*-------------------------------------------------------------------------*/ + +static double FDistBBp2k2 (double junk[], double x) +/* + * Bickel-Breiman distribution obtained by simulation with + * N = 1000000, n = 1000, r = 0, k = 2, p = 2, Torus = TRUE + */ +{ + static lebool BBp2k2Flag = FALSE; + int j; + double q; + double y; + if (x < 0.016) + return 0.0; + if (x >= 6.0) + return 1.0; + if (x >= 1.0) + return 1.0 - exp ((0.1408724 * x - 4.485674) * x - 0.264116); + + if (FALSE == BBp2k2Flag) { + InitBBp2k2 (); + BBp2k2Flag = TRUE; + } + + if (x >= 0.2) { + /* Newton quadratic interpolation based on the points 0.02*j */ + /* in the interval [0.2, 1.0] */ + j = x * 50.0; + q = x * 50.0 - j; + y = BB4[j - 10] + q * (BB4[j - 9] - BB4[j - 10]) + + (q * (q - 1.0) * ((BB4[j - 8] - 2.0 * BB4[j - 9]) + BB4[j - + 10])) / 2.0; + + return 1.0 - exp (y); + } + + /* Newton backward cubic interpolation based on the points */ + /* 0.01*j in the interval [0, 0.2] */ + j = 100.0 * x + 2; /* x is in [P(j-2), P(j-1)] */ + q = 100.0 * x - j; + + y = (BB5[j] - BB5[j - 1]) * q + BB5[j] + + (((BB5[j - 2] - 2.0 * BB5[j - 1]) + BB5[j]) + * q * (q + 1.0)) / 2.0 + + ((((-BB5[j - 3] + 3.0 * BB5[j - 2]) - 3.0 * BB5[j - 1]) + + BB5[j]) * q * (q + 1.0) * (q + 2.0)) / 6.0; + + return y; +} + + +/*-------------------------------------------------------------------------*/ + +void snpair_WriteDataBB (unif01_Gen * gen, char *TestName, + long N, long n, int r, int k, int p, lebool Torus, int L1, int L2) +{ + double z; + + swrite_Head (gen, TestName, N, n, r); + printf (", k = %1d, p = %1d, Torus = ", k, p); + util_WriteBool (Torus, 5); + printf ("\n"); + + if (swrite_Parameters) { + printf ("\n Seuil1 = %5d\n Seuil2 = %5d\n Seuil3 = %5d\n" + " Seuil4 = %5d\n L1 = %2d\n L2 = %2d\n", + snpair_env.Seuil1, snpair_env.Seuil2, snpair_env.Seuil3, + snpair_env.Seuil4, L1, L2); + + z = n * pow (2.0, -L1 * (double) k); + printf (" s1 = "); /* n / 2^{k L1} = "); */ + num_WriteD (z, 9, 2, 2); + printf ("\n s2 = "); /* n / 2^{k L2} = "); */ + z = n * pow (2.0, -L2 * (double) k); + num_WriteD (z, 9, 2, 2); + } + printf ("\n\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +void snpair_WriteResultsBB (unif01_Gen * gen, chrono_Chrono * Timer, + snpair_Res * res, long N) +{ + + printf ("-----------------------------------------------\n"); + if (N == 1) { + printf ("Value of the BB statistic :"); + gofw_Writep2 (res->sVal[snpair_BB], res->pVal[snpair_BB]); + } else { + printf ("AD Statistic on the N p-values of BB :"); + gofw_Writep2 (res->sVal[snpair_BB], res->pVal[snpair_BB]); + } + swrite_Final (gen, Timer); +} + + +/*=========================================================================*/ + +void snpair_BickelBreiman (unif01_Gen * gen, snpair_Res * res, + long N, long n, int r, int k, int p, lebool Torus) +{ + int j; + long i; + long Seq; + snpair_PointType T; + double mu1; /* -n * Vol */ + double ksurp; /* k / p */ + double Wni; + double SumBB; + double Vol; /* Volume of unit sphere in k dimension */ + double x, nLR, kLR; + WorkType *work; + lebool localRes = FALSE; + chrono_Chrono *Timer, *Time1; + char *TestName = "snpair_BickelBreiman test"; + + Timer = chrono_Create (); + + if (res == NULL) { + localRes = TRUE; + res = snpair_CreateRes (); + } + work = res->work; + work->Torus = Torus; + work->kk = k; + kLR = k; + nLR = n; + work->pp = p; + work->mm = 1; + work->mcd = 2; + if (p == 0) + work->pLR = 1.0; + else + work->pLR = p; + work->Invp = 1.0 / work->pLR; + ksurp = kLR / work->pLR; + + work->L1 = 1 + num_Log2 (nLR / snpair_env.Seuil3) / (sqrt (kLR)); + if (work->L1 < 2) + work->L1 = 2; + work->L2 = 1 + num_Log2 (nLR / snpair_env.Seuil4) / (sqrt (kLR)); + if (work->L2 < 2) + work->L2 = 2; + if (k < snpair_MAXREC) + work->Maxnp = k; + else + work->Maxnp = snpair_MAXREC; + Vol = num2_VolumeSphere ((double) p, k); + mu1 = -nLR * Vol; + work->BBFlag = TRUE; + if (swrite_Basic) + snpair_WriteDataBB (gen, TestName, N, n, r, k, p, Torus, + work->L1, work->L2); + + /* util_Assert (n <= snpair_MaxNumPoints, + "snpair_BickelBreiman: n is too large"); */ + util_Assert (p == 2 || p == 0, + "snpair_BickelBreiman implemented only for p = 2 and p = 0"); + util_Assert (k == 2 || k == 15, + "snpair_BickelBreiman implemented only for k = 2 and k = 15"); + util_Assert (p != 2 || k != 15, + "snpair_BickelBreiman: case p = 2, k = 15 not implemented"); + if (p == 0) { + if (k == 2) + work->FDistBB = FDistBBp0k2; + else + work->FDistBB = FDistBBp0k15; + } else + work->FDistBB = FDistBBp2k2; + + InitRes (res, N, n, 1); + res->Distance = snpair_DistanceBB; + res->VerifPairs = snpair_VerifPairs0; + res->MiniProc = snpair_MiniProc1; + statcoll_SetDesc (res->ThepValAD, "The N p-values of BickelBreiman"); + + /* Test begins */ + for (Seq = 1; Seq <= N; Seq++) { + + for (i = 1; i <= n; i++) { + /* Generate n points in dimension k */ + T = res->Points[1][i]; + /* Initialize nearest distance */ + T[0] = kLR; + for (j = 1; j <= k; j++) + T[j] = unif01_StripD (gen, r); + } + + /* Find the closest points */ + work->dlim = kLR; /* Initial upper bounds */ + work->dlimp = work->dlim; + if (snpair_TimeBB) + Time1 = chrono_Create (); + snpair_QuickSort (res->Points[1], 1, n, 1); + snpair_FindClosePairs (res, 1, n, 1, 1, 1); + + /* For each point, coordinate 0 now contains the distance to */ + /* the nearest point raised to power p (for p > 0) */ + snpair_QuickSort (res->Points[1], 1, n, 0); + + /* Compute the BB statistic, etc... */ + SumBB = 0.0; + for (i = 1; i <= n; i++) { + Wni = 1.0 - exp (mu1 * pow (res->Points[1][i][0], ksurp)); + x = Wni - i / nLR; + SumBB += x * x; + } + if (snpair_TimeBB) { + printf (" Time to compute the BB statistic: "); + chrono_Write (Time1, chrono_sec); + printf ("\n"); + chrono_Delete (Time1); + } + statcoll_AddObs (res->ThepValAD, + 1.0 - work->FDistBB ((double *) NULL, SumBB)); + } + + if (swrite_Collectors) + statcoll_Write (res->ThepValAD, 5, 14, 4, 3); + + if (N == 1) { + res->sVal[snpair_BB] = SumBB; + res->pVal[snpair_BB] = res->ThepValAD->V[1]; + } else { + tables_QuickSortD (res->ThepValAD->V, 1, N); + res->sVal[snpair_BB] = gofs_AndersonDarling (res->ThepValAD->V, N); + res->pVal[snpair_BB] = fbar_AndersonDarling (N, res->sVal[snpair_BB]); + } + + if (swrite_Basic) + snpair_WriteResultsBB (gen, Timer, res, N); + + if (localRes) + snpair_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void snpair_DistanceCPBitM (snpair_Res * res, snpair_PointType P1, + snpair_PointType P2) +/* + * Similar to snpair_DistanceCP, but for snpair_ClosePairsBitMatch. We take + * at most two groups of SizeUL bits for each coordinate of two points and + * find how many equal bits (= Y) they have before the first different bit, + * starting with the most significant. That is the distance in 1 dimension. + * We do that for each coordinate and the minimum of these is the distance + * between the two points (all components of the pair have at least Y + * identical bits). + */ +{ + const int NBitsUL = CHAR_BIT * sizeof (unsigned long); + const double Mul = num_TwoExp[NBitsUL]; + unsigned long x1, x2, z; + int i, j; + int Y = INT_MAX; /* Distance between the 2 points */ + WorkType *work = res->work; + + for (i = 1; i <= work->kk; i++) { + /* Take the first NBitsUL bits of each coordinates of the 2 points */ + x1 = Mul * P1[i]; + x2 = Mul * P2[i]; + /* Find the position - 1 of the first (left) bit where they differ */ + z = x1 ^ x2; + j = 0; + if (z) { + while (z < 2 * z) { + j++; + z <<= 1; + if (j >= Y) + continue; + } + } else { + /* The first NBitsUL bits are equal, consider the NBitsUL next bits + */ + x1 = Mul * (Mul * P1[i] - x1); + x2 = Mul * (Mul * P2[i] - x2); + z = x1 ^ x2; + if (z) { + j = NBitsUL; + while (z < 2 * z) { + j++; + z <<= 1; + if (j >= Y) + continue; + } + } else { + j = 2 * NBitsUL; + } + } + if (j < Y) + Y = j; + if (Y <= work->YLim) + /* We want the maximum (amongst all pairs of points) of the */ + /* minimum Y over all coordinates of a pair. This pair cannot */ + /* give a larger YLim. */ + return; + } + + /* A larger YLim has been found. From it, we define an inverse distance */ + /* so that the largest YLim gives the smallest new distance. This is */ + /* necessary if we want to use the fast but complicated algorithm for */ + /* finding the nearest pair. */ + if (Y > work->YLim) { + work->YLim = Y; + if (work->YLim <= num_MaxTwoExp) + work->dlim = 1.0 / num_TwoExp[work->YLim]; + else + work->dlim = pow (2.0, -(double) work->YLim); + res->CloseDist[1] = work->dlim; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteDataBM (unif01_Gen * gen, char *TestName, + long N, long n, int r, int k) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", t = %1d\n\n", k); +} + + +/*=========================================================================*/ + +void snpair_ClosePairsBitMatch (unif01_Gen * gen, snpair_Res * res, + long N, long n, int r, int k) +/* + * Similar to ClosePairs, but uses the BitMatch distance. + */ +{ + long Seq; + double z1, nLR; + snpair_PointType T; + int m; + int MaxY; /* Max of all bit distances */ + int j; + long i; + double pLeft, pRight; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "snpair_ClosePairsBitMatch test"; + WorkType *work; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataBM (gen, TestName, N, n, r, k); + + /* util_Assert (n <= snpair_MaxNumPoints, + "snpair_ClosePairsBitMatch: n > snpair_MaxNumPoints"); */ + util_Assert (n > 1, "snpair_ClosePairsBitMatch: n < 2"); + if (res == NULL) { + localRes = TRUE; + res = snpair_CreateRes (); + } + work = res->work; + work->Torus = FALSE; + work->kk = k; + work->mm = m = 1; + work->mcd = 2 * m; + nLR = n; + work->Invp = work->pLR = work->pp = 1; + + if (k < snpair_MAXREC) + work->Maxnp = k; + else + work->Maxnp = snpair_MAXREC; + work->BBFlag = FALSE; /* Bickel-Breiman Flag */ + + CalcSeuils (work, k, m, FALSE, 0.0, nLR, (double) k); + + InitRes (res, N, n, m); + res->Distance = snpair_DistanceCPBitM; + res->VerifPairs = snpair_VerifPairs1; + res->MiniProc = snpair_MiniProc1; + + MaxY = 0; + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + + for (i = 1; i <= n; i++) { + /* Generate n points in dimension k */ + T = res->Points[1][i]; + for (j = 1; j <= k; j++) + T[j] = unif01_StripD (gen, r); + } + res->NumClose = 0; + work->YLim = 0; /* Initial lower bound */ + work->dlim = 1.0; /* Initial upper bound */ + snpair_QuickSort (res->Points[1], 1, n, 1); + snpair_FindClosePairs (res, 1, n, 1, 1, 1); + +#if 0 + /* Check by computing distances between all pairs; very slow. */ + printf ("%12d", work->YLim); + if (Seq % 5 == 0) + printf ("\n"); + swrite_Collectors = TRUE; + work->YLim = 0; + snpair_VerifPairs0 (res->Points[1], 1, n, 0, 0); +#endif + + statcoll_AddObs (res->BitMax, (double) work->YLim); + MaxY = util_Max (work->YLim, MaxY); + } + + if (swrite_Collectors) + statcoll_Write (res->BitMax, 5, 14, 4, 3); + + /* z1 = Probability [Min {k geometric (0.5)} >= MaxY] */ + if (k * (MaxY + 1) <= num_MaxTwoExp) + z1 = 1.0 / num_TwoExp[k * (MaxY + 1)]; + else + z1 = pow (2.0, -(double) k * (MaxY + 1)); + + /* There are n*(n - 1)/2 pairs of points and we replicate that basic test + N times, so we compute pLeft = the Probability [Max {N*n*(n - 1)/2 of + above random var.} <= MaxY] */ + if (z1 > DBL_EPSILON) { + pLeft = 1.0 - z1; + z1 = log (pLeft) * N * n * (n - 1) / 2; + pLeft = exp (z1); + pRight = 1.0 - pLeft; + } else { + /* Use approximation log (1 - z) = -z to avoid loss of precision */ + pRight = z1 * N * n * (n - 1) / 2; + pLeft = 1.0 - pRight; + } + res->pVal[snpair_BM] = gofw_pDisc (pLeft, pRight); + res->sVal[snpair_BM] = MaxY; + + if (swrite_Basic) { + printf ("\n-----------------------------------------------\n"); + printf ("Max of all bit distances :"); + gofw_Writep2 ((double) MaxY, res->pVal[snpair_BM]); + swrite_Final (gen, Timer); + } + + if (localRes) + snpair_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ diff --git a/cbits/testu/src/sres.c b/cbits/testu/src/sres.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/sres.c @@ -0,0 +1,273 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: sres.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "sres.h" +#include "fbar.h" + +#include +#include + + + + +/*-------------------------------- Functions ------------------------------*/ + + + +void sres_InitChi2 (sres_Chi2 *res, long N, long jmax, char *nam) +{ + statcoll_Init (res->sVal1, N); + statcoll_Init (res->pVal1, N); + + if (jmax < 0) { + if (res->jmax > 0) { + res->NbExp = util_Free (res->NbExp); + res->Count = util_Free (res->Count); + res->Loc = util_Free (res->Loc); + } + } else { + if (res->jmax < 0) { + res->NbExp = util_Calloc ((size_t) (jmax + 1), sizeof (double)); + res->Count = util_Calloc ((size_t) (jmax + 1), sizeof (long)); + res->Loc = util_Calloc ((size_t) (jmax + 1), sizeof (long)); + } else { + int j; + res->NbExp = + util_Realloc (res->NbExp, (jmax + 1) * sizeof (double)); + res->Count = util_Realloc (res->Count, (jmax + 1) * sizeof (long)); + res->Loc = util_Realloc (res->Loc, (jmax + 1) * sizeof (long)); + for (j = 0; j <= jmax; j++) { + res->NbExp[j] = 0.0; + res->Count[j] = 0; + res->Loc[j] = 0; + } + } + } + res->degFree = 0; + res->jmin = 0; + res->jmax = jmax; + gofw_InitTestArray (res->sVal2, -1.0); + gofw_InitTestArray (res->pVal2, -1.0); + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); +} + + +/*-------------------------------------------------------------------------*/ + +sres_Chi2 *sres_CreateChi2 (void) +{ + sres_Chi2 *res; + res = util_Malloc (sizeof (sres_Chi2)); + memset (res, 0, sizeof (sres_Chi2)); + res->sVal1 = statcoll_Create (1, ""); + res->pVal1 = statcoll_Create (1, ""); + res->name = util_Calloc (1, sizeof (char)); + res->jmin = 0; + res->jmax = -1; + res->NbExp = NULL; + res->Count = NULL; + res->Loc = NULL; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sres_DeleteChi2 (sres_Chi2 * res) +{ + if (res == NULL) + return; + statcoll_Delete (res->sVal1); + statcoll_Delete (res->pVal1); + util_Free (res->NbExp); + util_Free (res->Count); + util_Free (res->Loc); + util_Free (res->name); + util_Free (res); +} + + +/*-------------------------------------------------------------------------*/ + +void sres_GetChi2SumStat (sres_Chi2 *res) +{ + const long N = res->sVal1->NObs; + double sum = N * statcoll_Average (res->sVal1); + res->sVal2[gofw_Sum] = sum; + if (N <= 1) { + res->pVal2[gofw_Sum] = res->sVal1->V[1]; + res->sVal2[gofw_Var] = 0; + return; + } + res->pVal2[gofw_Sum] = fbar_ChiSquare2 (N*res->degFree, 12, sum); +} + + +/*=========================================================================*/ + +void sres_InitBasic (sres_Basic *res, long N, char *nam) +{ + statcoll_Init (res->sVal1, N); + statcoll_Init (res->pVal1, N); + gofw_InitTestArray (res->sVal2, -1.0); + gofw_InitTestArray (res->pVal2, -1.0); + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); +} + + +/*-------------------------------------------------------------------------*/ + +sres_Basic *sres_CreateBasic (void) +{ + sres_Basic *res; + res = util_Malloc (sizeof (sres_Basic)); + memset (res, 0, sizeof (sres_Basic)); + res->sVal1 = statcoll_Create (1, ""); + res->pVal1 = statcoll_Create (1, ""); + res->name = util_Calloc (1, sizeof (char)); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sres_DeleteBasic (sres_Basic * res) +{ + if (res == NULL) + return; + statcoll_Delete (res->sVal1); + statcoll_Delete (res->pVal1); + util_Free (res->name); + util_Free (res); +} + + +/*-------------------------------------------------------------------------*/ + +void sres_GetNormalSumStat (sres_Basic *res) +{ + const long N = res->sVal1->NObs; + double sum = N * statcoll_Average (res->sVal1); + res->sVal2[gofw_Sum] = sum; + if (N <= 1) { + res->pVal2[gofw_Sum] = res->sVal1->V[1]; + res->sVal2[gofw_Var] = 0; + return; + } + res->pVal2[gofw_Sum] = fbar_Normal1 (sum/sqrt((double)N)); + sum = statcoll_Variance (res->sVal1); + res->sVal2[gofw_Var] = sum; + res->pVal2[gofw_Var] = fbar_ChiSquare2 (N - 1, 12, (N - 1)*sum); +} + + +/*=========================================================================*/ + +void sres_InitPoisson (sres_Poisson *res, long N, double Lambda, char *nam) +{ + statcoll_Init (res->sVal1, N); + res->Lambda = Lambda; + res->Mu = N * Lambda; + res->sVal2 = -1.0; + res->pLeft = -1.0; + res->pRight = -1.0; + res->pVal2 = -1.0; + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); + +} + + +/*-------------------------------------------------------------------------*/ + +sres_Poisson * sres_CreatePoisson (void) +{ + sres_Poisson *res; + res = util_Malloc (sizeof (sres_Poisson)); + memset (res, 0, sizeof (sres_Poisson)); + res->sVal1 = statcoll_Create (1, ""); + res->name = util_Calloc (1, sizeof (char)); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sres_DeletePoisson (sres_Poisson *res) +{ + if (res == NULL) + return; + statcoll_Delete (res->sVal1); + util_Free (res->name); + util_Free (res); +} + + +/*=========================================================================*/ + +void sres_InitDisc (sres_Disc *res, long N, char *nam) +{ + statcoll_Init (res->sVal1, N); + res->sVal2 = -1.0; + res->pLeft = -1.0; + res->pRight = -1.0; + res->pVal2 = -1.0; + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); + +} + + +/*-------------------------------------------------------------------------*/ + +sres_Disc * sres_CreateDisc (void) +{ + sres_Disc *res; + res = util_Malloc (sizeof (sres_Disc)); + memset (res, 0, sizeof (sres_Disc)); + res->sVal1 = statcoll_Create (1, ""); + res->name = util_Calloc (1, sizeof (char)); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sres_DeleteDisc (sres_Disc *res) +{ + if (res == NULL) + return; + statcoll_Delete (res->sVal1); + util_Free (res->name); + util_Free (res); +} diff --git a/cbits/testu/src/sspectral.c b/cbits/testu/src/sspectral.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/sspectral.c @@ -0,0 +1,423 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: sspectral.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "num.h" +#include "chrono.h" +#include "tables.h" + +#include "sspectral.h" +#include "swrite.h" +#include "wdist.h" +#include "unif01.h" + +#include "gofw.h" +#include "statcoll.h" + +#include "fftc.c" + +#include +#include +#include + + + + + + +/*-------------------------------- Functions ------------------------------*/ + + +static void InitRes ( + sspectral_Res *res, + long N, + long jmin, + long jmax, + char *nam +) +/* + * Initializes the sspectral_Res structure + */ +{ + long j; + sres_InitBasic (res->Bas, N, nam); + if (jmax > res->jmax) + res->Coef = util_Realloc (res->Coef, (jmax + 200) * sizeof (double)); + for (j = 0; j <= jmax; j++) + res->Coef[j] = 0.0; + res->jmin = jmin; + res->jmax = jmax; + res->Bas->name = util_Realloc (res->Bas->name, + 1 + strlen (nam) * sizeof (char)); + strcpy (res->Bas->name, nam); +} + + +/*-------------------------------------------------------------------------*/ + +sspectral_Res * sspectral_CreateRes (void) +{ + sspectral_Res *res; + res = util_Malloc (sizeof (sspectral_Res)); + res->Bas = sres_CreateBasic (); + res->Coef = util_Calloc (1, sizeof (double)); + res->jmax = 0; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sspectral_DeleteRes (sspectral_Res *res) +{ + if (res == NULL) + return; + sres_DeleteBasic (res->Bas); + util_Free (res->Coef); + util_Free (res); +} + + +/*=========================================================================*/ + +static void WriteDataFour ( + unif01_Gen *gen, /* generator */ + char *Test, /* Test name */ + long N, /* Number of replications */ + int k, /* Sample size n = 2^k */ + int r, /* r first bits of each random number dropped */ + int s /* s bits of each random number used */ +) +{ + long n; + n = num_TwoExp[k]; + swrite_Head (gen, Test, N, n, r); + printf (", s = %4d, k = %4d\n\n", s, k); +} + + +/*-------------------------------------------------------------------------*/ + +void sspectral_Fourier1 (unif01_Gen *gen, sspectral_Res *res, + long N, int t, int r, int s) +{ + const unsigned long SBIT = 1UL << (s - 1); + unsigned long jBit; + unsigned long Z; + long k, KALL, Seq, n, i; + double x, NbExp, h, per; + long co; + double *A; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sspectral_Fourier1 test"; + + Timer = chrono_Create (); + util_Assert (t <= 20, "sspectral_Fourier1: k > 20"); + util_Assert (t > 1, "sspectral_Fourier1: k < 2"); + if (swrite_Basic) + WriteDataFour (gen, TestName, N, t, r, s); + if (res == NULL) { + localRes = TRUE; + res = sspectral_CreateRes (); + } + n = num_TwoExp[t]; + KALL = n / s; + if (n % s > 0) + KALL++; + per = 0.95; + NbExp = per * (n / 2 + 1); +/* h = 3.0 * n; */ + h = 2.995732274 * n; + InitRes (res, N, 0, n, "sspectral_Fourier1"); + statcoll_SetDesc (res->Bas->sVal1, "sVal1: a standard normal"); + A = res->Coef; + + for (Seq = 1; Seq <= N; Seq++) { + /* Fill array A: 1 for bit 1, -1 for bit 0 */ + i = 0; + for (k = 0; k < KALL; k++) { + Z = unif01_StripB (gen, r, s); + jBit = SBIT; + while (jBit) { + if (jBit & Z) + A[i] = 1.0; + else + A[i] = -1.0; + jBit >>= 1; + i++; + } + } + /* + * Compute the Fourier transform of A and return the result in A. The + * first half of the array, (from 0 to n/2) is filled with the real + * components of the FFT. The second half of the array (from n/2+1 to + * n-1) is filled with the imaginary components of the FFT. + * The n new elements of A are thus: + * [Re(0), Re(1), ...., Re(n/2), Im(n/2-1), ..., Im(1)] + * The procedure is due to H.V. Sorensen, University of Pennsylvania + * and is found in file fftc.c. + */ + rsrfft (A, t); + + /* Count the number of Fourier coefficients smaller than h */ + co = 0; + for (i = 1; i < n / 2; i++) { + x = A[i] * A[i] + A[n - i] * A[n - i]; + if (x < h) + co++; + } + if (A[0] * A[0] < h) + co++; + + /* Compute the NIST statistic */ + x = (co - NbExp) / sqrt (NbExp * (1.0 - per)); + statcoll_AddObs (res->Bas->sVal1, x); + + if (swrite_Counters) { + tables_WriteTabD (res->Coef, 0, n - 1, 5, 14, 5, 5, + "Fourier coefficients"); + } + } + + gofw_ActiveTests2 (res->Bas->sVal1->V, res->Bas->pVal1->V, N, wdist_Normal, + (double *) NULL, res->Bas->sVal2, res->Bas->pVal2); + res->Bas->pVal1->NObs = N; + sres_GetNormalSumStat (res->Bas); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->Bas->sVal2, res->Bas->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res->Bas); + if (swrite_Collectors) + statcoll_Write (res->Bas->sVal1, 5, 14, 4, 3); + swrite_Final (gen, Timer); + } + if (localRes) + sspectral_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void sspectral_Fourier3 (unif01_Gen *gen, sspectral_Res *res, + long N, int t, int r, int s) +{ + const unsigned long SBIT = 1UL << (s - 1); + unsigned long jBit; + unsigned long Z; + long k, KALL, Seq, n, i; + double *A, *B; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sspectral_Fourier3 test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataFour (gen, TestName, N, t, r, s); + util_Assert (r + s <= 32, "sspectral_Fourier3: r + s > 32"); + util_Assert (t <= 26, "sspectral_Fourier3: k > 26"); + util_Assert (t >= 2, "sspectral_Fourier3: k < 2"); + if (res == NULL) { + localRes = TRUE; + res = sspectral_CreateRes (); + } + n = num_TwoExp[t]; + KALL = n / s + 1; + InitRes (res, n/4 + 1, 0, n, "sspectral_Fourier3"); + statcoll_SetDesc (res->Bas->sVal1, "sVal1: a standard normal"); + B = res->Bas->sVal1->V; + A = res->Coef; + for (i = 0; i <= n / 4; i++) + B[i] = 0.0; + + for (Seq = 1; Seq <= N; Seq++) { + /* Fill array A: 1 for bit 1, -1 for bit 0 */ + i = 0; + for (k = 0; k < KALL; k++) { + Z = unif01_StripB (gen, r, s); + jBit = SBIT; + while (jBit) { + if (jBit & Z) + A[i] = 1.0; + else + A[i] = -1.0; + jBit >>= 1; + i++; + } + } + /* + * Compute the Fourier transform of A and return the result in A. The + * first half of the array, (from 0 to n/2) is filled with the real + * components of the FFT. The second half of the array (from n/2+1 to + * n-1) is filled with the imaginary components of the FFT. + * The n new elements of A are thus: + * [Re(0), Re(1), ...., Re(n/2), Im(n/2-1), ..., Im(1)] + * The procedure is due to H.V. Sorensen, University of Pennsylvania + * and is found in file fftc.c. + */ + rsrfft (A, t); + + /* Add the squares of the Fourier coefficients over the N replications + for each i = [1, ..., n/4], and keep them in B[i] */ + for (i = 1; i <= n / 4; i++) + B[i] += A[i] * A[i] + A[n - i] * A[n - i]; + + if (0 && swrite_Counters) + tables_WriteTabD (B, 1, n / 4, 5, 14, 5, 5, + "Sums of square of Fourier coefficients"); + } + + /* There is an extra sqrt (n) factor between the Fourier coefficients + of Sorensen and those of Erdmann */ + for (i = 1; i <= n / 4; i++) + B[i] /= n; + + /* The N random variables have been added for each i and kept in B[i]. + Their mean (1) and variance (~1) is known from Diane Erdmann. Now + consider the B[i] as n/4 normal random variables. */ + for (i = 1; i <= n / 4; i++) { + B[i] = (B[i] - N) / sqrt (N * (1.0 - 2.0 / n)); + statcoll_AddObs (res->Bas->sVal1, B[i]); + } + + gofw_ActiveTests2 (res->Bas->sVal1->V, res->Bas->pVal1->V, n/4, wdist_Normal, + (double *) NULL, res->Bas->sVal2, res->Bas->pVal2); + res->Bas->pVal1->NObs = n/4; + + if (swrite_Basic) { + gofw_WriteActiveTests2 (n/4, res->Bas->sVal2, res->Bas->pVal2, + "Normal statistic :"); + if (swrite_Collectors) + statcoll_Write (res->Bas->sVal1, 5, 14, 4, 3); + swrite_Final (gen, Timer); + } + if (localRes) + sspectral_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void sspectral_Fourier2 (unif01_Gen *gen, sspectral_Res *res, + long N, int t, int r, int s) +{ + const unsigned long SBIT = 1UL << (s - 1); + unsigned long jBit; + unsigned long Z; + long k, KALL, Seq, n, i; + double *A; + double x, sum; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sspectral_Fourier2 test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataFour (gen, TestName, N, t, r, s); + util_Assert (r + s <= 32, "sspectral_Fourier2: r + s > 32"); + util_Assert (t <= 26, "sspectral_Fourier2: k > 26"); + util_Assert (t >= 2, "sspectral_Fourier2: k < 2"); + if (res == NULL) { + localRes = TRUE; + res = sspectral_CreateRes (); + } + n = num_TwoExp[t]; + KALL = n / s + 1; + InitRes (res, N, 0, n, "sspectral_Fourier2"); + statcoll_SetDesc (res->Bas->sVal1, "sVal1: a standard normal"); + A = res->Coef; + + for (Seq = 1; Seq <= N; Seq++) { + /* Fill array A: 1 for bit 1, -1 for bit 0 */ + i = 0; + for (k = 0; k < KALL; k++) { + Z = unif01_StripB (gen, r, s); + jBit = SBIT; + while (jBit) { + if (jBit & Z) + A[i] = 1.0; + else + A[i] = -1.0; + jBit >>= 1; + i++; + } + } + /* + * Compute the Fourier transform of A and return the result in A. The + * first half of the array, (from 0 to n/2) is filled with the real + * components of the FFT. The second half of the array (from n/2+1 to + * n-1) is filled with the imaginary components of the FFT. + * The n new elements of A are thus: + * [Re(0), Re(1), ...., Re(n/2), Im(n/2-1), ..., Im(1)] + * The procedure is due to H.V. Sorensen, University of Pennsylvania + * and is found in file fftc.c. + */ + rsrfft (A, t); + + /* Sum the square of the Fourier coefficients (only half of them) */ + sum = 0.0; + for (i = 1; i <= n / 4; i++) + sum += A[i] * A[i] + A[n - i] * A[n - i]; + + /* There is an extra sqrt (n) factor between the Fourier coefficients + of Sorensen and those of Erdmann */ + sum /= n; + + /* Standardize the statistic */ + x = 2.0*(sum - n / 4.0) / sqrt (n - 2.0); + statcoll_AddObs (res->Bas->sVal1, x); + + if (swrite_Counters) { + tables_WriteTabD (res->Coef, 0, n - 1, 5, 14, 5, 5, + "Fourier coefficients"); + } + } + + gofw_ActiveTests2 (res->Bas->sVal1->V, res->Bas->pVal1->V, N, wdist_Normal, + (double *) NULL, res->Bas->sVal2, res->Bas->pVal2); + res->Bas->pVal1->NObs = N; + sres_GetNormalSumStat (res->Bas); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->Bas->sVal2, res->Bas->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res->Bas); + if (swrite_Collectors) + statcoll_Write (res->Bas->sVal1, 5, 14, 4, 3); + swrite_Final (gen, Timer); + } + if (localRes) + sspectral_DeleteRes (res); + chrono_Delete (Timer); +} + diff --git a/cbits/testu/src/sstring.c b/cbits/testu/src/sstring.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/sstring.c @@ -0,0 +1,2268 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: sstring.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "chrono.h" +#include "num.h" +#include "tables.h" +#include "bitset.h" + +#include "sstring.h" +#include "unif01.h" +#include "wdist.h" +#include "swrite.h" +#include "sres.h" + +#include "gofs.h" +#include "gofw.h" +#include "fbar.h" +#include "statcoll.h" + +#include +#include +#include +#include +#include + + + + + +/*------------------------------ Constants --------------------------------*/ + +/* Minimal length (number of bits) of a sequence for LongestHeadRun */ +#define LMIN 1000 + +/* Max string length for the correlations in PeriodsInStrings */ +#define MAX_CORR 31 + +/* Max dimension of arrays */ +#define DIM 1000 + +/* Max string lengths */ +#define LEN1 200 +#define LEN2 200 + + + + + +/*-------------------------------- Types ----------------------------------*/ + +typedef struct InfoListC *ListC; /* A correlation list */ + +struct InfoListC { + long Nb; /* Number of bits of a correlation in + the initial computations; then + number of occurences */ + bitset_BitSet C; /* A correlation */ + long Pop; /* Population related to C (and c) */ + ListC Ext; /* The smallest extension of C */ + ListC Ext0; /* The smallest extension of D longer + than C, if C is an extension of D. + Initially NULL */ + ListC Next; /* Next correlation of same length */ +}; + +/* Corr contains the lists of correlations of each length for s in [0..smax] + */ +typedef struct { + ListC Corr[MAX_CORR + 1]; + int smax; +} sstring_Corr; + + +/*----------------------------- Variables --------------------------------*/ + +lebool sstring_CorrFlag = FALSE; +lebool sstring_Counters = FALSE; + + + + +/*----------------------------- Functions --------------------------------*/ + +static void InitRes3 ( + sstring_Res3 *res, /* Results holder */ + long N, /* Number of replications */ + int jmax /* Max class index for chi2 */ +) +/* + * Initializes the sstring_Res3 structure + */ +{ + sres_InitBasic (res->NBits, N, "sstring_Run: Number of Bits"); + sres_InitChi2 (res->NRuns, N, jmax, "sstring_Run: Number of Runs"); + res->Count0 = util_Realloc (res->Count0, (jmax + 1) * sizeof (long)); + res->Count1 = util_Realloc (res->Count1, (jmax + 1) * sizeof (long)); + res->NRuns->jmin = 1; + res->NRuns->degFree = jmax - 1; +} + + +/*-------------------------------------------------------------------------*/ + +sstring_Res3 * sstring_CreateRes3 (void) +{ + sstring_Res3 *res; + res = util_Malloc (sizeof (sstring_Res3)); + res->NBits = sres_CreateBasic (); + res->NRuns = sres_CreateChi2 (); + res->Count0 = util_Calloc (1, sizeof (long)); + res->Count1 = util_Calloc (1, sizeof (long)); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_DeleteRes3 (sstring_Res3 *res) +{ + if (res == NULL) + return; + res->Count0 = util_Free (res->Count0); + res->Count1 = util_Free (res->Count1); + sres_DeleteBasic (res->NBits); + sres_DeleteChi2 (res->NRuns); + util_Free (res); +} + + +/*=========================================================================*/ + +static void InitRes2 ( + sstring_Res2 *res, /* Results holder */ + long N, /* Number of replications */ + int jhigh /* Max class index for chi2 */ +) +/* + * Initializes the sstring_Res2 structure + */ +{ + sres_InitDisc (res->Disc, N, + "sstring_LongestHeadRun: Global longest run of 1's"); + sres_InitChi2 (res->Chi, N, jhigh, + "sstring_LongestHeadRun: Block longest runs of 1's"); +} + + +/*-------------------------------------------------------------------------*/ + +sstring_Res2 * sstring_CreateRes2 (void) +{ + sstring_Res2 *res; + res = util_Malloc (sizeof (sstring_Res2)); + res->Chi = sres_CreateChi2 (); + res->Disc = sres_CreateDisc (); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_DeleteRes2 (sstring_Res2 *res) +{ + if (res == NULL) + return; + sres_DeleteChi2 (res->Chi); + sres_DeleteDisc (res->Disc); + util_Free (res); +} + + +/*=========================================================================*/ + +static void InitRes ( + sstring_Res *res, /* Results holder */ + long N, /* Number of replications */ + int L, /* Size of blocks (number of bits) */ + int d, /* Parameter for sub-matrices */ + char *nam +) +/* + * Initializes res + */ +{ + int i; + sres_InitBasic (res->Bas, N, nam); + + if (res->L > 0) { + tables_DeleteMatrixL (&res->Counters); + tables_DeleteMatrixD (&res->ZCounters); + } + res->Counters = tables_CreateMatrixL (L + 2, L + 1); + res->ZCounters = tables_CreateMatrixD (L + 2, L + 1); + + if (d < 0) + d = 0; + for (i = d + 1; i <= res->d; i++) + sres_DeleteBasic (res->Block[i]); + + for (i = res->d + 1; i <= d; i++) + res->Block[i] = sres_CreateBasic (); + + for (i = 1; i <= d; i++) + sres_InitBasic (res->Block[i], N, nam); + + res->L = L; + res->d = d; +} + + +/*-------------------------------------------------------------------------*/ + +sstring_Res * sstring_CreateRes (void) +{ + sstring_Res *res; + res = util_Malloc (sizeof (sstring_Res)); + memset (res, 0, sizeof (sstring_Res)); + res->Bas = sres_CreateBasic (); + res->Style = tables_Plain; + res->L = -1; + res->d = 0; + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_DeleteRes (sstring_Res *res) +{ + if (res == NULL) + return; + + if (res->d > 0) { + int i; + for (i = 1; i <= res->d; i++) { + sres_DeleteBasic (res->Block[i]); + } + } + if (res->L > 0) { + tables_DeleteMatrixD (&res->ZCounters); + tables_DeleteMatrixL (&res->Counters); + } + sres_DeleteBasic (res->Bas); + util_Free (res); +} + + +/*=========================================================================*/ + +static long Psi ( + bitset_BitSet C, /* Correlation making up tail of correlation k */ + long j, /* Length of correlation C */ + long k /* Correlation made up of 1 followed by 0's + until C, i.e. k = 100...000C */ +) +{ + /* j <=> c & k <=> k in the article */ + if (k > j) + return 0; + if (k <= 0) + return (long) num_TwoExp[-k]; + if (bitset_TestBit (C, j - k)) + return 1; + else + return 0; +} + + +/*-------------------------------------------------------------------------*/ + +static void DeleteCorr (sstring_Corr *corr) +/* + * Delete all correlations. + */ +{ + ListC Ci, OldCi; + int i; + + if (corr == NULL) + return; + for (i = 0; i <= corr->smax; i++) { + Ci = corr->Corr[i]; + while (Ci) { + OldCi = Ci; + Ci = Ci->Next; + util_Free (OldCi); + } + } + util_Free (corr); +} + + +/*-------------------------------------------------------------------------*/ + +static sstring_Corr * CreateCorr (int s) +/* + * Compute all possible correlations for strings of length s + */ +{ + ListC CjE, Cj, Ci, OldCi, XS; + sstring_Corr *corr; + int j, i, k, Tmax; + long p; + + corr = util_Malloc (sizeof (sstring_Corr)); + memset (corr, 0, sizeof (sstring_Corr)); + + corr->smax = s; + + XS = corr->Corr[0] = util_Malloc (sizeof (struct InfoListC)); + XS->Nb = 0; + XS->Pop = 1; + XS->Ext = NULL; + XS->Ext0 = NULL; + XS->Next = NULL; + + XS = corr->Corr[1] = util_Malloc (sizeof (struct InfoListC)); + XS->Nb = 1; + bitset_SetBit (XS->C, 0); + XS->Pop = 2; + XS->Ext = NULL; + XS->Ext0 = NULL; + XS->Next = NULL; + + for (i = 2; i <= s; i++) { /* i is the string length */ + /* Count and build the list of correlations of length i. */ + Ci = corr->Corr[i] = util_Malloc (sizeof (struct InfoListC)); + + for (j = 0; j <= i - 2; j++) { + /* j is the length of correlation C in 100...00C */ + Cj = corr->Corr[j]; + + while (Cj) { + /* Compute the number of strings of length i and with corre- */ + /* lation "10...0C", and if > 0, add this corr. to Corr[i] */ + p = Cj->Pop * Psi (Cj->C, j, 2*j - i); + /* Check if 1C may be a correlation. Possible only if + C = 111....1, i.e. the last of the list */ + if (Cj->Next == NULL) + p -= 2 * Psi (Cj->C, j, 2*j + 2 - i); + CjE = Cj->Ext; + /* Note: j <= j-2, i.e. j+1 <= (i+j) / 2 */ + Tmax = (i + j) / 2; + while (CjE && CjE->Nb <= Tmax) { + p -= CjE->Pop * Psi (Cj->C, j, 2*CjE->Nb - i); + CjE = CjE->Ext0; + } + /* p = number of strings looked for */ + if (p > 0) { + /* Put this correlation in Ci */ + Ci->Nb = i; + Ci->Pop = p; + Ci->Ext = NULL; + Ci->Ext0 = NULL; + /* Ci->C becomes Cj->C shifted right by i-j */ + /* positions, with a 1 in first position. */ + Ci->C = 0; + bitset_SetBit (Ci->C, 0); + if (j > 0) { + for (k = 0; k < j; k++) { + if (bitset_TestBit (Cj->C, k)) { + bitset_SetBit (Ci->C, k + i - j); + } + } + } + if (Cj->Ext == NULL) + Cj->Ext = Ci; + else { + CjE = Cj->Ext; + while (CjE->Ext0) + CjE = CjE->Ext0; + CjE->Ext0 = Ci; + } + OldCi = Ci; + Ci = util_Malloc (sizeof (struct InfoListC)); + OldCi->Next = Ci; + } + Cj = Cj->Next; + } + } + /* For j = i-1, we have the correlation "11...1" */ + Ci->C = 0; + for (k = 0; k < i; k++) { + bitset_SetBit (Ci->C, k); + } + Ci->Nb = i; + Ci->Pop = 2; + Ci->Ext = NULL; + Ci->Ext0 = NULL; + Ci->Next = NULL; + } + return corr; +} + + +/*=========================================================================*/ + +static void sstring_WriteCorr (sstring_Corr *corr, int s) +{ + ListC Cs; + int k; + char str [LEN1 + 1]; + + if (corr == NULL) { + util_Warning (TRUE, + "sstring_WriteCorr: corr is a NULL pointer"); + return; + } + + if (corr->smax < s) { + sprintf (str, "sstring_WriteCorr: invalid s = %d", s); + util_Error (str); + } + + Cs = corr->Corr[s]; + if (Cs == NULL) + return; + printf ("\n-----------------------------------------------------\n" + "List of correlations of length %d and their population\n\n", s); + while (Cs) { + for (k = 0; k < s; k++) { + if (bitset_TestBit (Cs->C, k)) + printf ("1"); + else + printf ("0"); + } + printf ("%12ld\n", Cs->Pop); + Cs = Cs->Next; + } + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static bitset_BitSet GenerateC ( + unif01_Gen *gen, /* Generator */ + int r, /* Drop first r bits of each random number */ + int s /* Keep next s bits of each random number */ +) +/* + * Generate a string of s bits and return its correlation. To determine the + * correlation of a bit string, compare strings g and d (initially equal). + * For each iteration: + * 1) drop leftmost bit of string g + * 2) drop rightmost bit of string d + * 3) if g = d, bit k of the correlation c is 1, otherwise 0. + */ +{ + int k; + unsigned long g, d, lbit = s - 1; + bitset_BitSet c = 0; + + /* Generate a random number; drop r most significant bits; keep s next + bits */ + g = d = unif01_StripB (gen, r, s); + + /* Initialization of correlation, trivial case */ + bitset_SetBit (c, 0); + for (k = 1; k < s; k++) { + /* drop leftmost bit of string g */ + bitset_ClearBit (g, lbit); + /* drop rightmost bit of string d */ + d >>= 1; + /* if g = d, bit k of the correlation c is 1, otherwise 0 */ + if (g == d) + bitset_SetBit (c, k); + lbit--; + } + return c; +} + + +/*=========================================================================*/ + +static void WriteDataPeriod ( + unif01_Gen *gen, /* generator */ + char *Test, /* Test name */ + long N, /* Number of replications */ + long n, /* Sample size */ + int r, /* r first bits of each random number dropped */ + int s /* s bits of each random number used */ +) +{ + swrite_Head (gen, Test, N, n, r); + printf (", s = %4d\n\n", s); +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_PeriodsInStrings (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, int s) +{ + ListC XS, Ci; + sstring_Corr *corr; + long jhigh, /* Highest class for ChiSquare */ + jlow, /* Lowest class for ChiSquare */ + NbGroups; /* Number of classes for ChiSquare */ + long j, i; + long Seq; /* One replication of the test */ + double Fraction, X2; + bitset_BitSet D; /* A correlation */ + double V[1]; /* Number of ChiSquare degrees of freedom */ + char str [LEN1 + 1]; + double NbExp [DIM + 1]; + long Loca [DIM + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_PeriodsInStrings test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataPeriod (gen, TestName, N, n, r, s); + + util_Assert (r >= 0, "sstring_PeriodsInStrings: r < 0"); + util_Assert (r <= 31, "sstring_PeriodsInStrings: r > 31"); + util_Assert (r + s <= 31, "sstring_PeriodsInStrings: r + s > 31"); + util_Assert (s <= 31, "sstring_PeriodsInStrings: s > 31"); + util_Assert (s >= 2, "sstring_PeriodsInStrings: s < 2"); + /* util_Assert (n > 2.0 * gofs_MinExpected, + "sstring_PeriodsInStrings: n <= 2*gofs_MinExpected"); */ + + Fraction = n / num_TwoExp[s]; + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + corr = CreateCorr (s); + if (sstring_CorrFlag) + sstring_WriteCorr (corr, s); + + /* Get the expected numbers of the population count */ + XS = Ci = corr->Corr[s]; + j = 1; + while (Ci) { + NbExp[j] = Fraction * Ci->Pop; + Ci = Ci->Next; + ++j; + util_Assert (j <= DIM, "sstring_PeriodsInStrings: DIM too small"); + } + jlow = 1; + jhigh = j - 1; + + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, 0); + + /* Merge classes for the chi-square test */ + gofs_MergeClasses (NbExp, Loca, &jlow, &jhigh, &NbGroups); + + if (swrite_Classes) + gofs_WriteClasses (NbExp, Loca, jlow, jhigh, NbGroups); + + res->degFree = NbGroups - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + sres_InitChi2 (res, N, jhigh, "sstring_PeriodsInStrings"); + res->jmin = jlow; + tables_CopyTabD (NbExp, res->NbExp, jlow, jhigh); + tables_CopyTabL (Loca, res->Loc, jlow, jhigh); + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + /* Test begins */ + for (Seq = 1; Seq <= N; Seq++) { + /* Zero the population counters */ + Ci = XS; + while (Ci) { + Ci->Nb = 0; + Ci = Ci->Next; + } + for (i = 1; i <= n; i++) { + D = GenerateC (gen, r, s); + /* Find the correlation */ + Ci = XS; + while (Ci->C != D) + Ci = Ci->Next; + ++Ci->Nb; + } + + /* Keep the observed numbers in sstring_Count */ + for (j = jlow; j <= jhigh; j++) + res->Count[j] = 0; + Ci = XS; + j = 1; + while (Ci) { + if (j >= res->jmax) + res->Count[res->jmax] += Ci->Nb; + else + res->Count[Loca[j]] += Ci->Nb; + Ci = Ci->Next; + ++j; + } + + X2 = gofs_Chi2 (res->NbExp, res->Count, jlow, jhigh); + statcoll_AddObs (res->sVal1, X2); + if (swrite_Counters) + tables_WriteTabL (res->Count, jlow, jhigh, 5, 10, + "Observed population counts"); + } + + res->degFree = V[0] = NbGroups - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + if (swrite_Basic) { + swrite_AddStrChi (str, LEN1, NbGroups - 1); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + DeleteCorr (corr); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static double ProbabiliteLHR (long j, double Lnl) +/* + * Returns the probability that the longest series of successive 1 has + * length = j. + */ +{ + double x, temp; + temp = (j + 1) * num_Ln2 - Lnl; + x = exp (-exp (-temp)); + temp += num_Ln2; + x = exp (-exp (-temp)) - x; + return x; +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteDataLongHead (unif01_Gen *gen, char *Test, + long N, long n, int r, int s, long L) +{ + swrite_Head (gen, Test, N, n, r); + printf (", s = %1d, L = %1ld\n\n", s, L); +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_LongestHeadRun (unif01_Gen *gen, sstring_Res2 *res, + long N, long n, int r, int s, long L) +{ + const double eps = DBL_EPSILON; + const long K = L/s; /* Number of iterations */ + long Rep; /* Current replication number */ + long Seq; /* Current sequence number */ + long i; + double LnLen; /* log (L) or log (NnL) */ + double X2, temp; + int j; + long longest; /* Longest serie of 1 in a block */ + long longest2; /* Longest serie of 1 over all blocks */ + long longest3; /* Longest serie of 1 over all Replic. */ + long longueur; /* Run length in a block */ + long longueur2; /* Run length in a sequence */ + long longueur3; /* Run length in a replication */ + long jhigh; /* Highest class for Chi2 */ + long jhigh2; /* Highest index for CDF[j] */ + long NbGroups; /* Number of classes for Chi2 */ + bitset_BitSet ensemble; /* Chosen bits in each generated number */ + double V[1]; /* Number degrees of freedom for Chi2 */ + char str [LEN1 + 1]; + double NbExp [DIM + 1]; /* Expected numbers */ + double CDF [DIM + 1]; /* Cumulative probabilities */ + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_LongestHeadRun test"; + sres_Chi2 *Chi; + sres_Disc *Disc; + + Timer = chrono_Create (); + L = K * s; + if (swrite_Basic) + WriteDataLongHead (gen, TestName, N, n, r, s, L); + util_Assert (L >= LMIN, "sstring_LongestHeadRun: L < 1000"); + if (res == NULL) { + localRes = TRUE; + res = sstring_CreateRes2 (); + } + jhigh = DIM; + + /* Get the expected numbers for the chi-square for blocks of L bits */ + LnLen = log ((double) L); + CDF[0] = ProbabiliteLHR (0, LnLen); + NbExp[0] = n * CDF[0]; + for (j = 1; j < DIM; j++) { + temp = ProbabiliteLHR (j, LnLen); + NbExp[j] = n * temp; + CDF[j] = temp + CDF[j-1]; + if ((temp <= eps) && (CDF[j] > 0.5)) { + jhigh = j; + break; + } + } + util_Assert (jhigh > 0, "sstring_LongestHeadRun: jhigh = 0"); + NbExp[jhigh] = n * (1.0 - CDF[jhigh - 1]); + + /* Get the probabilities for the global run over the N*n*L bits */ + LnLen = log (N * (double) n * (double) L); /* Avoid overflow of long */ + CDF[0] = ProbabiliteLHR (0, LnLen); + for (j = 1; j < DIM; j++) { + temp = ProbabiliteLHR (j, LnLen); + CDF[j] = temp + CDF[j-1]; + if ((temp <= eps) && (CDF[j] > 0.5)) { + jhigh2 = j; + break; + } + } + + InitRes2 (res, N, jhigh); + Disc = res->Disc; + Chi = res->Chi; + tables_CopyTabD (NbExp, Chi->NbExp, 0, jhigh); + + if (swrite_Classes) + gofs_WriteClasses (Chi->NbExp, Chi->Loc, 0, jhigh, 0); + gofs_MergeClasses (Chi->NbExp, Chi->Loc, &Chi->jmin, &Chi->jmax, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (Chi->NbExp, Chi->Loc, Chi->jmin, Chi->jmax, NbGroups); + Chi->degFree = NbGroups - 1; + if (Chi->degFree <= 0) { + util_Assert (1, "sstring_LongestHeadRun: Chi->degFree = 0"); + if (localRes) + sstring_DeleteRes2 (res); + return; + } + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", Chi->degFree); + statcoll_SetDesc (Chi->sVal1, str); + statcoll_SetDesc (Disc->sVal1, + "The longest run of 1 for each replication "); + + /* Beginning of test */ + longest3 = longueur3 = 0; + for (Rep = 1; Rep <= N; Rep++) { + for (i = Chi->jmin; i <= Chi->jmax; i++) + Chi->Count[i] = 0; + + longest2 = -1; /* -1 at the beginning of a new replication */ + longueur2 = 0; + for (Seq = 1; Seq <= n; Seq++) { + longest = -1; /* -1 at the beginning of a new sequence */ + longueur = 0; + for (i = 1; i <= K; i++) { + /* Now build a block of L bits */ + ensemble = unif01_StripB (gen, r, s); + /* Examine each bit of a number */ + for (j = s - 1; j >= 0; j--) { + if (bitset_TestBit (ensemble, j)) + ++longueur; + else { + /* Beginning of a sequence: merge last block of 1's of */ + /* last sequence with first block of 1's of new sequence */ + if (longest < 0) { + /* Beginning of a replication: merge last sequence of */ + /* 1's of last replication with first sequence of 1's */ + /* of new replication */ + if (longest2 < 0) { + longueur3 += longueur; + if (longueur3 > longest3) + longest3 = longueur3; + } + longueur2 += longueur; + if (longueur2 > longest2) + longest2 = longueur2; + } + if (longueur > longest) + longest = longueur; + longueur = 0; + } + } + } + if (longueur > longest) + longest = longueur; + if (longest >= Chi->jmax) + ++Chi->Count[Chi->jmax]; + else if (longest <= Chi->jmin) + ++Chi->Count[Chi->jmin]; + else + ++Chi->Count[Chi->Loc[longest]]; + if (longest > longest2) + longest2 = longest; + longueur3 = longueur2 = longueur; + } + + X2 = gofs_Chi2 (Chi->NbExp, Chi->Count, Chi->jmin, Chi->jmax); + statcoll_AddObs (Chi->sVal1, X2); + statcoll_AddObs (Disc->sVal1, (double) longest2); + if (longest2 > longest3) + longest3 = longest2; + if (swrite_Counters) + tables_WriteTabL (Chi->Count, Chi->jmin, Chi->jmax, 5, 10, + "Observed numbers"); + longueur = 0; + for (j = Chi->jmin; j <= Chi->jmax; j++) + longueur += Chi->Count[j]; + util_Warning (longueur != n, "Total Count != n"); + } + Disc->sVal2 = longest3; + if (longest3 > jhigh2) { + Disc->pLeft = 1.0; + Disc->pRight = 0.0; + } else { + Disc->pLeft = CDF[longest3]; + if (longest3 > 0) + Disc->pRight = 1.0 - CDF[longest3 - 1]; + else + Disc->pRight = 1.0; + } + Disc->pVal2 = gofw_pDisc (Disc->pLeft, Disc->pRight); + + V[0] = Chi->degFree; + gofw_ActiveTests2 (Chi->sVal1->V, Chi->pVal1->V, N, wdist_ChiSquare, V, + Chi->sVal2, Chi->pVal2); + Chi->pVal1->NObs = N; + sres_GetChi2SumStat (Chi); + + if (swrite_Collectors) { + statcoll_Write (Chi->sVal1, 5, 14, 4, 3); + statcoll_Write (Disc->sVal1, 5, 14, 0, 0); + } + if (swrite_Basic) { + swrite_AddStrChi (str, LEN1, Chi->degFree); + gofw_WriteActiveTests2 (N, Chi->sVal2, Chi->pVal2, str); + swrite_Chi2SumTest (N, Chi); + printf ("-----------------------------------------------\n"); + printf ("Global longest run of 1 :"); + gofw_Writep2 (Disc->sVal2, Disc->pVal2); + printf ("\n\n"); + swrite_Final (gen, Timer); + } + if (localRes) + sstring_DeleteRes2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void HammingWeight2_L (unif01_Gen * gen, sres_Basic * res, + long N, int r, int s, long L, long K) +/* + * Generate all the n bits for the HammingWeight2 test in the case L > s. + * For the last number generated in a block of L bits, we keep its first + * LMods bits and discard the other bits. + */ +{ + const int LDivs = L / s; /* A block uses LDivs numbers ... */ + const int LMods = L % s; /* + 1 if LMods > 0 */ + const double L2 = L / 2.0; + int co, j; + long i, Seq; + unsigned long Z; + double X2; + + for (Seq = 1; Seq <= N; Seq++) { + X2 = 0.0; + for (i = 0; i < K; i++) { + /* Generate a block of L bits */ + co = 0; + for (j = 0; j < LDivs; j++) { + Z = unif01_StripB (gen, r, s); + while (Z > 0) { /* Count the number of 1 bits */ + Z &= Z - 1; /* Clear lowest 1 bit */ + ++co; + } + } + /* The last bits of the block */ + if (LMods > 0) { + Z = unif01_StripB (gen, r, LMods); + while (Z > 0) { + Z &= Z - 1; + ++co; + } + } + X2 += (co - L2)*(co - L2); + } + X2 *= 4.0 / L; + statcoll_AddObs (res->sVal1, X2); + } +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingWeight2_S (unif01_Gen * gen, sres_Basic * res, + long N, int r, int s, long L, long K) +/* + * Generate all the n bits for the HammingWeight2 test in the case L <= s. + * A number generates sDivL blocks. If s % L == 0, we use all s bits of the + * number. + */ +{ + const int sDivL = s / L; /* A number generates sDivL blocks */ + const long Q = K / sDivL + (K % sDivL > 0); + const unsigned long MASK = num_TwoExp[L] - 1.0; + const double L2 = L / 2.0; + int co, j; + long i, Seq; + unsigned long Z, Y; + double X2; + + for (Seq = 1; Seq <= N; Seq++) { + X2 = 0.0; + for (i = 0; i < Q; i++) { + Z = unif01_StripB (gen, r, s); + + /* Generate sDivL blocks of L bits */ + for (j = 0; j < sDivL; j++) { + co = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++co; + } + X2 += (co - L2)*(co - L2); + Z >>= L; + } + } + X2 *= 4.0 / L; + statcoll_AddObs (res->sVal1, X2); + } +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_HammingWeight2 (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r, int s, long L) +{ + const long K = n / L; + double sum; + double V[1]; /* Number of Chi2 degrees of freedom */ + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1] = ""; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_HammingWeight2 test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataLongHead (gen, TestName, N, n, r, s, L); + util_Assert (r + s <= 32, "sstring_HammingWeight2: r + s > 32"); + util_Assert (L <= n, "sstring_HammingWeight2: L > n"); + util_Assert (L >= 2, "sstring_HammingWeight2: L < 2"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "sstring_HammingWeight2"); + strncpy (chaine, "sVal1: a chi-square with ", (size_t) LEN1); + sprintf (str, "%ld", K); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->sVal1, chaine); + + if (L >= s) + HammingWeight2_L (gen, res, N, r, s, L, K); + else + HammingWeight2_S (gen, res, N, r, s, L, K); + + V[0] = K; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sum = N * statcoll_Average (res->sVal1); + res->sVal2[gofw_Sum] = sum; + res->pVal2[gofw_Sum] = fbar_ChiSquare2 (N*K, 12, sum); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 2, 1); + if (swrite_Basic) { + swrite_AddStrChi (str, LEN2, K); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTestb (N, res->sVal2[gofw_Sum], res->pVal2[gofw_Sum], K); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void HammingWeight_L (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, int s, long L) +/* + * Generate all the n*L bits for the HammingWeight test in the case L > s. + * For the last number generated in a block of L bits, we keep its first + * LMods bits and discard the other bits. + */ +{ + const int LDivs = L / s; /* A block uses LDivs numbers ... */ + const int LMods = L % s; /* + 1 if LMods > 0 */ + int co, j; + long i, Seq; + unsigned long Z; + double X2; + + for (Seq = 1; Seq <= N; Seq++) { + for (i = res->jmin; i <= res->jmax; i++) + res->Count[i] = 0; + + for (i = 0; i < n; i++) { + /* Generate a block of L bits */ + co = 0; + for (j = 0; j < LDivs; j++) { + Z = unif01_StripB (gen, r, s); + while (Z > 0) { /* Count the number of 1 bits */ + Z &= Z - 1; /* Clear lowest 1 bit */ + ++co; + } + } + /* The last bits of the block */ + if (LMods > 0) { + Z = unif01_StripB (gen, r, LMods); + while (Z > 0) { + Z &= Z - 1; + ++co; + } + } + ++res->Count[res->Loc[co]]; + } + + X2 = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X2); + if (swrite_Counters) + tables_WriteTabL (res->Count, res->jmin, res->jmax, 5, 10, + "Observed numbers of blocks"); + } +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingWeight_S (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, int s, long L) +/* + * Generate all the n*L bits for the HammingWeight test in the case L <= s. + * A number generates sDivL blocks. If s % L == 0, we use all s bits of the + * number. + */ +{ + const int sDivL = s / L; /* A number generates sDivL blocks */ + const int s1 = s - s % L; + const long Q = n / sDivL; + const int Q2 = n % sDivL; + const unsigned long MASK = num_TwoExp[L] - 1.0; + int co, j; + long i, Seq; + unsigned long Z, Y; + double X2; + + for (Seq = 1; Seq <= N; Seq++) { + for (i = res->jmin; i <= res->jmax; i++) + res->Count[i] = 0; + + for (i = 0; i < Q; i++) { + Z = unif01_StripB (gen, r, s1); + + /* Generate sDivL blocks of L bits */ + for (j = 0; j < sDivL; j++) { + co = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++co; + } + ++res->Count[res->Loc[co]]; + Z >>= L; + } + } + + /* The last bits */ + if (Q2 > 0) { + Z = unif01_StripB (gen, r, Q2 * L); + for (j = 0; j < Q2; j++) { + co = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++co; + } + ++res->Count[res->Loc[co]]; + Z >>= L; + } + } + + X2 = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X2); + if (swrite_Counters) + tables_WriteTabL (res->Count, res->jmin, res->jmax, 5, 10, + "Observed numbers of blocks"); + } +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_HammingWeight (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, int s, long L) +{ + long i; + double V[1]; /* Number of Chi2 degrees of freedom */ + char str[LEN1 + 1] = ""; + fmass_INFO Q; + lebool localRes = FALSE; + chrono_Chrono *Timer; + long jlow, jhigh; + long NbGroups; /* Number of classes */ + char *TestName = "sstring_HammingWeight test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataLongHead (gen, TestName, N, n, r, s, L); + util_Assert (r + s <= 32, "sstring_HammingWeight: r + s > 32"); + util_Assert (L >= 2, "sstring_HammingWeight: L < 2"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, L, "sstring_HammingWeight"); + + Q = fmass_CreateBinomial (L, 0.5, 0.5); + for (i = 0; i <= L; i++) + res->NbExp[i] = n * fmass_BinomialTerm2 (Q, i); + fmass_DeleteBinomial (Q); + + jlow = 0; + jhigh = L; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, res->Loc, jlow, jhigh, 0); + gofs_MergeClasses (res->NbExp, res->Loc, &jlow, &jhigh, &NbGroups); + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, res->Loc, jlow, jhigh, NbGroups); + res->jmin = jlow; + res->jmax = jhigh; + res->degFree = NbGroups - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbGroups - 1); + statcoll_SetDesc (res->sVal1, str); + + if (L >= s) + HammingWeight_L (gen, res, N, n, r, s, L); + else + HammingWeight_S (gen, res, N, n, r, s, L); + + V[0] = res->degFree; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 2, 1); + if (swrite_Basic) { + swrite_AddStrChi (str, LEN1, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +#if 0 +void sstring_Run0 (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r, int s) +{ + const long K = n / s; /* If n % s != 0, a string will contain + K * s bits instead of n */ + const unsigned long SBIT = 1UL << (s - 1); + unsigned long jBit; /* Position of current bit in Z */ + int pBit; /* Previous bit */ + long i, Seq; + long co1; /* Counter for number of 1 */ + long cor; /* Counter for number of runs */ + unsigned long Z; + double X, f1; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_Run test"; + + Timer = chrono_Create (); + n = K * s; + if (swrite_Basic) + WriteDataPeriod (gen, TestName, N, n, r, s); + + util_Assert (r + s <= 32, "sstring_Run: r + s > 32"); + /* util_Assert (100 <= n, "sstring_Run: n < 100"); */ + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "sstring_Run"); + statcoll_SetDesc (res->sVal1, "sVal1: a standard normal"); + + for (Seq = 1; Seq <= N; Seq++) { + co1 = cor = 0; + /* Be sure to count the first run with pBit != {0, 1} */ + pBit = 2; + for (i = 0; i < K; i++) { + Z = unif01_StripB (gen, r, s); + jBit = SBIT; + + /* Add the number of 1 bit and number of runs in Z */ + while (jBit > 0) { + if (Z & jBit) { /* bit 1 */ + co1++; + if (pBit != 1) + cor++; + pBit = 1; + } else { /* bit 0 */ + if (pBit != 0) + cor++; + pBit = 0; + } + jBit >>= 1; + } + } + f1 = (double) co1 / (K * s); + X = (cor - n * 2.0 * f1 * (1.0 - f1)) / + (2.0 * sqrt ((double) n) * f1 * (1.0 - f1)); + statcoll_AddObs (res->sVal1, X); + } + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Normal statistic :"); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteBasic(res); + chrono_Delete (Timer); +} +#endif + + +/*=========================================================================*/ + +void sstring_Run (unif01_Gen * gen, sstring_Res3 *res, + long N, long n, int r, int s) +{ + const unsigned long SBIT = 1UL << (s - 1); + const double sr = s; + unsigned long jBit; /* Position of current bit in Z */ + int pBit; /* Previous bit */ + int k, j; + long Seq; + double cob; /* Counter for number of bits */ + long cor; /* Counter for number of 1 runs */ + int len; /* Length of current run */ + unsigned long Z; + double X2, X, temp; + char str[LEN1 + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_Run test"; + sres_Basic *NBits; + sres_Chi2 *NRuns; + long *Count0, *Count1; + double *Prob, *NbExp; + double Param[1]; + + Timer = chrono_Create (); + k = 1 + num_Log2 (n / gofs_MinExpected); + if (swrite_Basic) + WriteDataPeriod (gen, TestName, N, n, r, s); + util_Assert (r + s <= 32, "sstring_Run: r + s > 32"); + /* util_Assert (100 <= n, "sstring_Run: n < 100"); */ + + if (res == NULL) { + localRes = TRUE; + res = sstring_CreateRes3 (); + } + InitRes3 (res, N, k); + NBits = res->NBits; + NRuns = res->NRuns; + Count0 = res->Count0; + Count1 = res->Count1; + + statcoll_SetDesc (NBits->sVal1, + "The N statistic values (a standard normal):"); + sprintf (str, "The N statistic values (a ChiSquare with %1d degrees" + " of freedom):", 2*(k - 1)); + statcoll_SetDesc (NRuns->sVal1, str); + + Prob = util_Calloc (1 + (size_t) k, sizeof (double)); + Prob[0] = 1.0; + for (j = 1; j < k; j++) { + Prob[j] = Prob[j - 1] / 2.0; + NRuns->NbExp[j] = n * Prob[j]; + } + Prob[k] = Prob[k - 1]; + NRuns->NbExp[k] = n * Prob[k]; + util_Assert (NRuns->NbExp[k] >= gofs_MinExpected, + "sstring_Run: NRuns->NbExp[k] < gofs_MinExpected"); + + if (swrite_Classes) + gofs_WriteClasses (NRuns->NbExp, NRuns->Loc, 1, k, 0); + NRuns->jmax = k; + NRuns->jmin = 1; + NRuns->degFree = 2*(k - 1); + if (NRuns->degFree < 1) { + util_Warning (TRUE, "Chi-square with 0 degree of freedom."); + if (localRes) + sstring_DeleteRes3 (res); + return; + } + + for (Seq = 1; Seq <= N; Seq++) { + cob = cor = len = 0; + for (j = 1; j <= k; j++) { + Count0[j] = 0; + Count1[j] = 0; + } + + /* Make sure to count the first run; set pBit != {0, 1} */ + pBit = 2; + while (cor < n) { + Z = unif01_StripB (gen, r, s); + jBit = SBIT; + cob += sr; + if (len >= n) { + util_Warning (TRUE, "sstring_Run: all bits are 0 !"); + util_Free (Prob); + if (localRes) + sstring_DeleteRes3 (res); + return; + } + + /* Add the number of runs in Z */ + while (jBit > 0) { + if (Z & jBit) { /* bit 1 */ + if (pBit != 1) { + cor++; + if (len < k) + (Count0[len])++; + else + (Count0[k])++; + len = 1; + } else { + len++; + } + pBit = 1; + } else { /* bit 0 */ + if (pBit != 0) { + if (len < k) + (Count1[len])++; + else + (Count1[k])++; + len = 1; + } else { + len++; + } + pBit = 0; + } + jBit >>= 1; + } + } + + X2 = 0.0; + NbExp = NRuns->NbExp; + for (j = NRuns->jmin; j <= NRuns->jmax; j++) { + temp = Count0[j] - NbExp[j]; + X2 += temp * temp / (NbExp[j] * (1.0 - Prob[j])); + } + X = X2; + X2 = 0.0; + for (j = NRuns->jmin; j <= NRuns->jmax; j++) { + temp = Count1[j] - NbExp[j]; + X2 += temp * temp / (NbExp[j] * (1.0 - Prob[j])); + } + statcoll_AddObs (NRuns->sVal1, X2 + X); + + if (swrite_Counters) { + tables_WriteTabL (Count0, 1, k, 5, 10, + "Observed number of runs of 0"); + tables_WriteTabL (Count1, 1, k, 5, 10, + "Observed number of runs of 1"); + } + + X = (cob - 4.0 * n) / sqrt (8.0 * n); + statcoll_AddObs (NBits->sVal1, X); + } + + Param[0] = 2*(k - 1); + gofw_ActiveTests2 (NRuns->sVal1->V, NRuns->pVal1->V, N, wdist_ChiSquare, + Param, NRuns->sVal2, NRuns->pVal2); + NRuns->pVal1->NObs = N; + sres_GetChi2SumStat (NRuns); + + gofw_ActiveTests2 (NBits->sVal1->V, NBits->pVal1->V, N, wdist_Normal, + (double *) NULL, NBits->sVal2, NBits->pVal2); + NBits->pVal1->NObs = N; + sres_GetNormalSumStat (NBits); + + + if (swrite_Basic) { + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Total number of 1 runs: %1ld\n\n", cor); + printf ("Number of degrees of freedom : %4ld\n", + NRuns->degFree); + printf ("Chi2 statistic for number of runs :"); + gofw_Writep2 (NRuns->sVal2[gofw_Mean], NRuns->pVal2[gofw_Mean]); + } else { + printf ("Test results for the number of runs:\n"); + gofw_WriteActiveTests0 (N, NRuns->sVal2, NRuns->pVal2); + swrite_Chi2SumTest (N, NRuns); + } + if (swrite_Collectors) + statcoll_Write (NRuns->sVal1, 5, 14, 4, 3); + + printf ("\n-----------------------------------------------\n"); + if (N == 1) { + printf ("Total number of bits: %.0f\n\n", cob); + printf ("Normal statistic for number of bits :"); + gofw_Writep2 (NBits->sVal2[gofw_Mean], NBits->pVal2[gofw_Mean]); + } else { + printf ("Test results for the number of bits:\n"); + gofw_WriteActiveTests0 (N, NBits->sVal2, NBits->pVal2); + swrite_NormalSumTest (N, NBits); + } + if (swrite_Collectors) + statcoll_Write (NBits->sVal1, 5, 14, 4, 3); + + printf ("\n\n"); + swrite_Final (gen, Timer); + } + util_Free (Prob); + if (localRes) + sstring_DeleteRes3 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataAutoCor (unif01_Gen *gen, char *Test, + long N, long n, int r, int s, int d) +{ + swrite_Head (gen, Test, N, n, r); + printf (", s = %1d, d = %1d\n\n", s, d); +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_AutoCor (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r, int s, int d) +{ + const long K = (n - d) / s; + const long M = d / s + 2; + unsigned long *Y; /* Circular buffer for random numbers */ + unsigned long A; /* Correlation */ + unsigned long Z, s1, s2; + unsigned long mask1, mask2; /* Masks of s1, s2 least sig. bits */ + double X; + long i, Seq; + int j1, j2; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_AutoCor test"; + + Timer = chrono_Create (); + /* There are a few bits less than n */ + n -= (n - d) % s; + if (swrite_Basic) + WriteDataAutoCor (gen, TestName, N, n, r, s, d); + + util_Assert (r + s <= 32, "sstring_AutoCor: r + s > 32"); + util_Assert (d <= n / 2, "sstring_AutoCor: d > n/2"); + util_Assert (d > 0, "sstring_AutoCor: d < 1"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "sstring_AutoCor"); + Y = util_Calloc ((size_t) M, sizeof (unsigned long)); + statcoll_SetDesc (res->sVal1, "sVal1: a standard normal"); + s1 = d % s; + s2 = s - s1; + mask1 = num_TwoExp[s1] - 1.0; + mask2 = num_TwoExp[s2] - 1.0; + + for (Seq = 1; Seq <= N; Seq++) { + /* Fill circular buffer with first random numbers */ + for (i = 0; i < M-1; i++) + Y[i] = unif01_StripB (gen, r, s); + + A = 0; + j1 = M - 1; + j2 = M - 2; + for (i = 0; i < K; i++) { + Y[j1] = unif01_StripB (gen, r, s); + j1 = (j1 + 1) % M; + Z = ((Y[j1] >> s1) ^ Y[j2]) & mask2; + while (Z > 0) { /* Count the number of 1 bits in Z */ + Z &= Z - 1; /* Clear lowest 1 bit */ + ++A; + } + j2 = (j2 + 1) % M; + + Z = ((Y[j2] >> s2) ^ Y[j1]) & mask1; + while (Z > 0) { + Z &= Z - 1; + ++A; + } + } + + X = 2.0 * (A - (n - d) / 2.0) / sqrt ((double) (n - d)); + statcoll_AddObs (res->sVal1, X); + } + + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetNormalSumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res); + swrite_Final (gen, Timer); + } + util_Free (Y); + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataHammingCorr (unif01_Gen *gen, char *TestName, + long N, long n, int r, int s, int L) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, L = %1d\n\n\n", s, L); +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingCorr_L (unif01_Gen *gen, sstring_Res * res, + long n, int r, int s, int L) +/* + * Generate all the n bits for the HammingCorr test in the case L > s. + * For the last number generated in a block of L bits, we keep its first + * LMods bits and discard the other bits. + */ +{ + const int LMods = L % s; + const int LDivs = L / s; + int Pre, X; + int j; + long k; + unsigned long Z; + + /* Junk value to avoid a test "if (k == 1)" for every generated + number; it will not be counted. */ + Pre = L + 1; + for (k = 1; k <= n; k++) { + /* Generate a sequence of L bits */ + X = 0; + for (j = 1; j <= LDivs; j++) { + Z = unif01_StripB (gen, r, s); + /* Count the number of 1 bits */ + while (Z > 0) { + Z &= Z - 1; /* Clear lowest 1 bit */ + ++X; + } + } + /* The last bits of the sequence */ + if (LMods > 0) { + Z = unif01_StripB (gen, r, LMods); + while (Z > 0) { + Z &= Z - 1; + ++X; + } + } + ++res->Counters[Pre][X]; + Pre = X; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingCorr_S (unif01_Gen *gen, sstring_Res * res, + long n, int r, int s, int L) +/* + * Generate all the n bits for the HammingCorr test in the case L <= s. + * A number generates sDivL blocks. If s % L == 0, we use all s bits of the + * number. + */ +{ + const int sDivL = s / L; /* A number generates sDivL blocks */ + const long Q = n / sDivL; + const long Q1 = n % sDivL; + const unsigned long MASK = num_TwoExp[L] - 1.0; + int Pre, X; + int j; + long k; + unsigned long Z, Y; + + /* Junk value to avoid a test "if (k == 1)" for every generated + number; it will not be counted. */ + Pre = L + 1; + for (k = 0; k < Q; k++) { + Z = unif01_StripB (gen, r, s); + + for (j = 0; j < sDivL; j++) { + X = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++X; + } + ++res->Counters[Pre][X]; + Pre = X; + Z >>= L; + } + } + + /* The last Q1 blocks */ + if (Q1 > 0) { + Z = unif01_StripB (gen, r, s); + for (j = 0; j < Q1; j++) { + X = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++X; + } + ++res->Counters[Pre][X]; + Pre = X; + Z >>= L; + } + } +} + + +/*-------------------------------------------------------------------------*/ + +void sstring_HammingCorr (unif01_Gen * gen, sstring_Res * res, + long N, long n, int r, int s, int L) +{ + int i, j; + long Seq; + double Sum; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_HammingCorr test"; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataHammingCorr (gen, TestName, N, n, r, s, L); + + util_Assert (s <= num_MaxTwoExp, "sstring_HammingCorr: s too large"); + util_Assert ((unsigned) s <= CHAR_BIT * sizeof (unsigned long), + "sstring_HammingCorr: s too large"); + + if (res == NULL) { + localRes = TRUE; + res = sstring_CreateRes (); + } + InitRes (res, N, L, -1, "sstring_HammingCorr"); + statcoll_SetDesc (res->Bas->sVal1, "HammingCorr sVal1: standard normal"); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i <= L; i++) { + for (j = 0; j <= L; j++) + res->Counters[i][j] = 0; + } + if (L >= s) + HammingCorr_L (gen, res, n, r, s, L); + else + HammingCorr_S (gen, res, n, r, s, L); + + if (swrite_Counters) + /* Print the matrix of counters */ + tables_WriteMatrixL (res->Counters, 0, L, 0, L, 8, + res->Style, "Number of pairs [0..L, 0..L]"); + + /* Calculate statistic */ + Sum = 0.0; + for (i = 0; i <= L; i++) { + for (j = 0; j <= L; j++) + Sum += res->Counters[i][j] * (i - L / 2.0) * (j - L / 2.0); + } + Sum = Sum * 4.0 / (L * sqrt (n - 1.0)); + statcoll_AddObs (res->Bas->sVal1, Sum); + } + + gofw_ActiveTests2 (res->Bas->sVal1->V, res->Bas->pVal1->V, N, + wdist_Normal, (double *) NULL, res->Bas->sVal2, res->Bas->pVal2); + res->Bas->pVal1->NObs = N; + sres_GetNormalSumStat (res->Bas); + + if (swrite_Collectors) + statcoll_Write (res->Bas->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->Bas->sVal2, res->Bas->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res->Bas); + swrite_Final (gen, Timer); + } + if (localRes) + sstring_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataHammingIndep (unif01_Gen * gen, char *TestName, + long N, long n, int r, int s, int L, int d) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, L = %1d, d = %1d\n\n\n", s, L, d); +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingIndep_L (unif01_Gen *gen, sstring_Res * res, + long n, int r, int s, int L) +/* + * Generate all the n bits for the HammingIndep test in the case L > s. + * For the last number generated in a block of L bits, we keep its first + * LMods bits and discard the other bits. + */ +{ + int Pre; /* Previous value of X */ + int X; + const int LMods = L % s; + const int LDivs = L / s; + int j; + unsigned long U; + unsigned long TwonUL; + unsigned long ic; + + /* For the test with n >= 2^30 */ + TwonUL = 2 * (unsigned long) n; + + Pre = 0; /* Eliminate a warning from compiler */ + for (ic = 1; ic <= TwonUL; ic++) { + /* Generate 1 block of L bits */ + X = 0; + for (j = 1; j <= LDivs; j++) { + U = unif01_StripB (gen, r, s); + /* Count the number of 1 bits */ + while (U > 0) { + U &= U - 1; /* Clear lowest 1 bit */ + ++X; + } + } + /* The last bits of the block */ + if (LMods > 0) { + U = unif01_StripB (gen, r, LMods); + while (U > 0) { + U &= U - 1; + ++X; + } + } + /* Non-overlapping pairs; count only when ic % 2 == 0 */ + if (!(ic & 1)) + ++res->Counters[Pre][X]; + Pre = X; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void HammingIndep_S (unif01_Gen *gen, sstring_Res * res, + long n, int r, int s, int L) +/* + * Generate all the n bits for the HammingIndep test in the case L <= s. + * A number generates sDivL blocks. If s % L == 0, we use all s bits of the + * number. + */ +{ + const int sDivL = s / L; /* A number generates sDivL blocks */ + const unsigned long MASK = num_TwoExp[L] - 1.0; + int Pre; /* Previous value of X */ + int X; + int j; + unsigned long Q, Q1, i; + unsigned long Z, Y; + unsigned long TwonUL; + unsigned long bloc = 0; + + /* For the test with n >= 2^30 */ + TwonUL = 2 * (unsigned long) n; + Q = TwonUL / sDivL; + Q1 = TwonUL % sDivL; + + Pre = 0; /* Eliminate a warning from compiler */ + for (i = 0; i < Q; i++) { + Z = unif01_StripB (gen, r, s); + + for (j = 0; j < sDivL; j++) { + X = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++X; + } + /* Non-overlapping pairs; count only when bloc % 2 == 0 */ + if (!(++bloc & 1)) + ++res->Counters[Pre][X]; + Pre = X; + Z >>= L; + } + } + + /* The last Q1 blocks */ + if (Q1 > 0) + Z = unif01_StripB (gen, r, s); + for (i = 0; i < Q1; i++) { + X = 0; + Y = Z & MASK; + while (Y > 0) { /* Count the number of 1 bits */ + Y &= Y - 1; /* Clear lowest 1 bit */ + ++X; + } + if (!(++bloc & 1)) + ++res->Counters[Pre][X]; + Pre = X; + Z >>= L; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void CountBlocks ( + sstring_Res *res, + int L, /* Length of blocks (num bits) */ + int d /* Rank of rows-columns counted */ + +) +/* + * Add the diagonal blocks for the matrix res->Counters, i.e. count the + * number of values in the 4 corners of the matrix with the center removed. + * We count only rows-columns of rank >= d starting from the center of + * the matrix. We eliminate 2d - 1 rows and columns at the center of the + * matrix when L is even. When L is odd, we eliminate 2d - 2 rows and + * columns at the center (except when d = 1, where we keep all the rows + * and columns). + */ +{ + int L2, L1, k, j, i; + + L2 = L1 = L / 2; + if ((L & 1)) + ++L1; + + for (k = 1; k <= d; k++) { + res->XD[k][0] = 0; + res->XD[k][1] = 0; + + /* Block ++ */ + for (i = 0; i <= L1 - k; i++) { + for (j = 0; j <= L1 - k; j++) { + res->XD[k][0] += res->Counters[i][j]; + } + } + /* Block -- */ + for (i = L2 + k; i <= L; i++) { + for (j = L2 + k; j <= L; j++) { + res->XD[k][0] += res->Counters[i][j]; + } + } + /* Block +- */ + for (i = 0; i <= L1 - k; i++) { + for (j = L2 + k; j <= L; j++) { + res->XD[k][1] += res->Counters[i][j]; + } + } + /* Block -+ */ + for (i = L2 + k; i <= L; i++) { + for (j = 0; j <= L1 - k; j++) { + res->XD[k][1] += res->Counters[i][j]; + } + } + } +} + +/*-------------------------------------------------------------------------*/ + +static void WriteBlocs ( + sstring_Res *res, + int d /* Rank of rows-columns */ + ) +/* + * Print the sum of counters in the diagonal blocks for different d + */ +{ + int i; + printf ("--------------------------------------------------\n"); + + for (i = 1; i <= d; i++) { + printf ("The number of blocks ++, -- with d >= %1d is %10ld\n", + i, res->XD[i][0]); + printf ("The number of blocks +-, -+ with d >= %1d is %10ld\n\n", + i, res->XD[i][1]); + } + printf ("\n"); +} + +/*-------------------------------------------------------------------------*/ + +void sstring_HammingIndep (unif01_Gen * gen, sstring_Res * res, + long N, long n, int r, int s, int L, int d) +{ + int Liber = 0; /* Num of degrees of freedom for main test */ + int Liberte; /* Num of degrees of freedom for block tests */ + int X; + int i, j; + long Seq; + double NbEsp; + double Var; + double NbMoyen; + double X2; + double Sum; + const double nLR = n; + double Z; + double *Prob; + double *NbEsp5; + long *Count5; + double V[1]; + fmass_INFO Q; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "sstring_HammingIndep test"; + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1]; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataHammingIndep (gen, TestName, N, n, r, s, L, d); + + if (n < 2.0 * gofs_MinExpected) { + util_Warning (TRUE, "sstring_HammingIndep: n < 20"); + return; + } + /* util_Assert (n >= 30, "sstring_HammingIndep: n < 30"); */ + util_Assert (d <= sstring_MAXD, "sstring_HammingIndep: d > sstring_MAXD"); + util_Assert (((L + 1) / 2) >= d, "sstring_HammingIndep: d > (L + 1) / 2"); + util_Assert (s <= num_MaxTwoExp, "sstring_HammingIndep: s too large"); + util_Assert ((unsigned) s <= CHAR_BIT * sizeof (unsigned long), + "sstring_HammingIndep: s too large"); + + if (res == NULL) { + localRes = TRUE; + res = sstring_CreateRes (); + } + InitRes (res, N, L, d, "sstring_HammingIndep"); + + for (i = 1; i <= d; i++) { + strncpy (chaine, "HammingIndep Block[", (size_t) LEN1); + sprintf (str, "%1d", i); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, "]", (size_t) 2); + statcoll_SetDesc (res->Block[i]->sVal1, chaine); + } + strncpy (chaine, "\nCounters with expected numbers >= ", (size_t) LEN1); + sprintf (str, "%g", gofs_MinExpected); + strncat (chaine, str, (size_t) LEN2); + statcoll_SetDesc (res->Bas->sVal1, chaine); + + Prob = util_Calloc ((size_t) L + 1, sizeof (double)); + NbEsp5 = util_Calloc ((size_t) (L + 1)*(L + 1) + 1, sizeof (double)); + Count5 = util_Calloc ((size_t) (L + 1)*(L + 1) + 1, sizeof (long)); + + Q = fmass_CreateBinomial (L, 0.5, 0.5); + for (i = 0; i <= L; i++) + Prob[i] = fmass_BinomialTerm2 (Q, i); + fmass_DeleteBinomial (Q); + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i <= L; i++) { + for (j = 0; j <= L; j++) { + res->Counters[i][j] = 0; + } + } + if (L >= s) + HammingIndep_L (gen, res, n, r, s, L); + else + HammingIndep_S (gen, res, n, r, s, L); + + /* The cells for which the expected number >= gofs_MinExpected will */ + /* correspond to one class each. Merge all other cells such that */ + /* their expected number is < gofs_MinExpected into 1 big class: Z */ + /* will contain the sum of all their expected numbers, and the */ + /* counter X will contain the sum of all their observed numbers. We */ + /* shall apply a chi-square test with Liber degrees of freedom. We */ + /* have (Liber + 1) classes. */ + Liber = 0; + Z = 0.0; + X = 0; + for (i = 0; i <= L; i++) { + for (j = 0; j <= L; j++) { + res->ZCounters[i][j] = nLR * Prob[i] * Prob[j]; + if (res->ZCounters[i][j] >= gofs_MinExpected) { + NbEsp5[Liber] = res->ZCounters[i][j]; + Count5[Liber] = res->Counters[i][j]; + ++Liber; + } else { + Z += res->ZCounters[i][j]; + X += res->Counters[i][j]; + } + } + } + if (Z >= gofs_MinExpected) { + /* We have one more class */ + /* if (swrite_Classes && Seq == 1) { + printf ("All cells with NbExp < "); + printf ("%s", str); + printf (" are merged into one big class with NbExp = %f\n\n", Z); + } */ + NbEsp5[Liber] = Z; + Count5[Liber] = X; + } else if (Liber > 0) { + /* We add them to the last class instead */ + --Liber; + NbEsp5[Liber] += Z; + Count5[Liber] += X; + } + + /* Everything has been put in a single class; separate all in two + classes */ + if (Liber == 0) { + Z = 0.0; + X = 0; + for (i = 0; i <= L; i++) { + for (j = 0; j <= L / 2; j++) { + res->ZCounters[i][j] = nLR * Prob[i] * Prob[j]; + Z += res->ZCounters[i][j]; + X += res->Counters[i][j]; + } + } + NbEsp5[0] = Z; + Count5[0] = X; + Z = 0.0; + X = 0; + for (i = 0; i <= L; i++) { + for (j = 1 + L / 2; j <= L; j++) { + res->ZCounters[i][j] = nLR * Prob[i] * Prob[j]; + Z += res->ZCounters[i][j]; + X += res->Counters[i][j]; + } + } + NbEsp5[1] = Z; + Count5[1] = X; + Liber = 1; + } + if (Liber > 0) { + X2 = gofs_Chi2 (NbEsp5, Count5, 0, Liber); + statcoll_AddObs (res->Bas->sVal1, X2); + } + + /* Compute the normalized observed number for each pair */ + for (i = 0; i <= L; i++) { + for (j = 0; j <= L; j++) { + NbEsp = nLR * Prob[i] * Prob[j]; + Var = NbEsp * (1.0 - Prob[i] * Prob[j]); + if (Var <= 0.0) { + /* This case will occur when NbEsp = 0; if so, fail the test */ + /* when res->Counters[i][j] != 0 */ + res->ZCounters[i][j] = (res->Counters[i][j] - NbEsp) * 1.E100; + } else { + res->ZCounters[i][j] = (res->Counters[i][j] - NbEsp) / + sqrt (Var); + } + } + } + if (sstring_Counters) + /* Print the matrix of counters */ + tables_WriteMatrixL (res->Counters, 0, L, 0, L, 8, res->Style, + "res->Counters, the number of pairs [0..L, 0..L]"); + if (swrite_Counters) + /* Print the matrix of normalized counters */ + tables_WriteMatrixD (res->ZCounters, 0, L, 0, L, 12, 4, + res->Style, "res->ZCounters, the normalized counters"); + + /* These blocks are sub-matrices symmetrically placed with respect to */ + /* the diagonals in the matrix of the number of pairs [Xi, X(i+1)]. */ + /* For those, we shall apply a chi-square test for the total number */ + /* in the diagonal sub-matrices. */ + CountBlocks (res, L, d); + + if (swrite_Counters) + WriteBlocs (res, d); + + for (i = 1; i <= d; i++) { + double NumExp[3]; + long Count[3]; + Sum = 0.0; + for (j = 0; j <= (L + 1) / 2 - i; j++) + Sum += Prob[j]; + /* Probability of a sub-matrix block */ + Sum *= Sum; + /* Average number for each of the 2 blocks */ + NbMoyen = Sum * nLR * 2.0; + NumExp[0] = NumExp[1] = NbMoyen; + if (2.0*NbMoyen < gofs_MinExpected) + printf ("******* sample too small for chi-square for d = %d\n", i); + NumExp[2] = nLR - 2.0*NbMoyen; + Count[0] = res->XD[i][0]; + Count[1] = res->XD[i][1]; + Count[2] = n - Count[0] - Count[1]; + X2 = gofs_Chi2 (NumExp, Count, 0, 2); + statcoll_AddObs (res->Block[i]->sVal1, X2); + } + } + + for (i = 1; i <= d; i++) { + /* Degrees of freedom */ + if ((L & 1) && i == 1) + Liberte = 1; + else + Liberte = 2; + + V[0] = Liberte; + gofw_ActiveTests2 (res->Block[i]->sVal1->V, res->Block[i]->pVal1->V, N, + wdist_ChiSquare, V, res->Block[i]->sVal2, res->Block[i]->pVal2); + res->Block[i]->pVal1->NObs = N; + Sum = N * statcoll_Average (res->Block[i]->sVal1); + res->Block[i]->sVal2[gofw_Sum] = Sum; + res->Block[i]->pVal2[gofw_Sum] = fbar_ChiSquare2 (N*Liberte, 12, Sum); + + if (swrite_Basic) { + printf ("\nDiagonal blocks with d = %2d", i); + swrite_AddStrChi (str, LEN2, Liberte); + gofw_WriteActiveTests2 (N, res->Block[i]->sVal2, + res->Block[i]->pVal2, str); + swrite_Chi2SumTestb (N, res->Block[i]->sVal2[gofw_Sum], + res->Block[i]->pVal2[gofw_Sum], Liberte); + if (swrite_Collectors) { + strncpy (chaine, res->Block[i]->sVal1->Desc, (size_t) LEN1); + strncat (chaine, ": a chi2 with ", (size_t) LEN1); + sprintf (str, "%1d", Liberte); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->Block[i]->sVal1, chaine); + statcoll_Write (res->Block[i]->sVal1, 5, 14, 4, 3); + } + } + } + + if (Liber > 0) { + V[0] = Liber; + gofw_ActiveTests2 (res->Bas->sVal1->V, res->Bas->pVal1->V, N, + wdist_ChiSquare, V, res->Bas->sVal2, res->Bas->pVal2); + res->Bas->pVal1->NObs = N; + Sum = N * statcoll_Average (res->Bas->sVal1); + res->Bas->sVal2[gofw_Sum] = Sum; + res->Bas->pVal2[gofw_Sum] = fbar_ChiSquare2 (N*Liber, 12, Sum); + + if (swrite_Basic) { + printf ("%s", res->Bas->sVal1->Desc); + swrite_AddStrChi (str, LEN2, Liber); + gofw_WriteActiveTests2 (N, res->Bas->sVal2, res->Bas->pVal2, str); + swrite_Chi2SumTestb (N, res->Bas->sVal2[gofw_Sum], + res->Bas->pVal2[gofw_Sum], Liber); + if (swrite_Collectors) { + strncpy (chaine, res->Bas->sVal1->Desc, (size_t) LEN1); + strncat (chaine, ": a ChiSquare with ", (size_t) LEN1); + sprintf (str, "%1d", Liber); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->Bas->sVal1, chaine); + statcoll_Write (res->Bas->sVal1, 5, 14, 4, 3); + } + } + } else { + /* for the module tvaria */ + res->Bas->pVal2[gofw_Mean] = -1.0; + if (d < 1) + util_Warning (1, + "n is too small: ChiSquare with 0 degree of freedom"); + } + + if (swrite_Basic) + swrite_Final (gen, Timer); + + util_Free (Prob); + util_Free (NbEsp5); + util_Free (Count5); + if (localRes) + sstring_DeleteRes (res); + chrono_Delete (Timer); +} diff --git a/cbits/testu/src/statcoll.c b/cbits/testu/src/statcoll.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/statcoll.c @@ -0,0 +1,219 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: statcoll.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "statcoll.h" + +#include "util.h" +#include "tables.h" + +#include +#include + + +#define MAXLEN 127 /* Max number of chars in Desc field of a + collector */ + + + +/*=========================================================================*/ + +void statcoll_SetDesc (statcoll_Collector * S, const char name[]) +{ + size_t len; + util_Assert (S != NULL, + "statcoll_SetDesc: statcoll_Collector is a NULL pointer"); + if (S->Desc != NULL) + S->Desc = (char *) util_Free (S->Desc); + if (name == NULL) + return; + len = strlen (name); + if (len > MAXLEN) { + len = MAXLEN; + util_Warning (1, "statcoll_Collector->Desc truncated to 127 chars"); + } + S->Desc = (char *) util_Calloc (len + 1, sizeof (char)); + strncpy (S->Desc, name, (size_t) len); + S->Desc[len] = '\0'; +} + + +/*=========================================================================*/ + +statcoll_Collector *statcoll_Create (long N, const char name[]) +{ + statcoll_Collector *S; + + util_Warning (N == 0, + "statcoll_Create: statcoll_Collector created with N = 0"); + S = (statcoll_Collector *) util_Malloc (sizeof (statcoll_Collector)); + /* We create an array V with N+1 elements, but will keep the N + observations in elements [1..N]. */ + S->V = (double *) util_Calloc ((size_t) N + 1, sizeof (double)); + S->Dim = N; + S->NObs = 0; + S->Desc = NULL; + statcoll_SetDesc (S, name); + return S; +} + + +/*=========================================================================*/ + +statcoll_Collector *statcoll_Delete (statcoll_Collector * S) +{ + if (S == NULL) { + util_Warning (S == NULL, + "statcoll_Delete: statcoll_Collector is a NULL pointer"); + return NULL; + } + S->V = (double *) util_Free (S->V); + S->Desc = (char *) util_Free (S->Desc); + util_Free (S); + return NULL; +} + + +/*=========================================================================*/ + +void statcoll_Init (statcoll_Collector * S, long N) +{ + util_Assert (S != NULL, + "statcoll_Init: statcoll_Collector is a NULL pointer"); + if (N > S->Dim) { + S->V = (double *) util_Realloc (S->V, (N + 1) * sizeof (double)); + S->Dim = N; + } + S->NObs = 0; +} + + +/*=========================================================================*/ + +void statcoll_AddObs (statcoll_Collector * S, double x) +{ + util_Assert (S != NULL, + "statcoll_AddObs: statcoll_Collector is a NULL pointer"); + if (S->NObs >= S->Dim) { + if (S->Dim > 0) + S->Dim *= 2; + else + S->Dim = 8; + S->V = (double *) util_Realloc (S->V, (S->Dim + 1) * sizeof (double)); + } + ++S->NObs; + S->V[S->NObs] = x; +} + + +/*=========================================================================*/ + +void statcoll_Write (statcoll_Collector * S, int k, int p1, int p2, int p3) +{ + tables_WriteTabD (S->V, 1, S->NObs, k, p1, p2, p3, S->Desc); +} + + +/*=========================================================================*/ + +double statcoll_Average (statcoll_Collector * S) +{ + long i; + double Sum; + util_Assert (S != NULL, + "statcoll_Average: statcoll_Collector is a NULL pointer"); + Sum = 0.0; + if (S->NObs == 0) { + util_Warning (1, "statcoll_Average: NObs = 0"); + return 1.0; + } + for (i = 1; i <= S->NObs; i++) + Sum += S->V[i]; + return Sum / S->NObs; +} + + +/*=========================================================================*/ + +double statcoll_Variance (statcoll_Collector * S) +{ + long i; + double Av, Sum2, Diff; + util_Assert (S != NULL, + "statcoll_Variance: statcoll_Collector is a NULL pointer"); + util_Assert (S->NObs > 1, "statcoll_Variance: NObs <= 1"); + Av = statcoll_Average (S); + Sum2 = 0.0; + for (i = 1; i <= S->NObs; i++) { + Diff = S->V[i] - Av; + Sum2 += Diff * Diff; + } + return Sum2 / (S->NObs - 1); +} + + +/*=========================================================================*/ + +double statcoll_AutoCovar (statcoll_Collector * S, int k) +{ + long i; + double Av2, Sum2; + util_Assert (S != NULL, + "statcoll_AutoCovar: statcoll_Collector is a NULL pointer"); + util_Assert (k < S->NObs, "statcoll_AutoCovar: k >= NObs"); + Av2 = statcoll_Average (S); + Av2 = Av2 * Av2; + Sum2 = 0.0; + for (i = 1; i <= S->NObs - k; i++) { + Sum2 += S->V[i] * S->V[i + k] - Av2; + } + return Sum2 / (S->NObs - k); +} + + +/*=========================================================================*/ + +double statcoll_Covar (statcoll_Collector * S1, statcoll_Collector * S2) +{ + long i; + double Av1Av2, Sum; + util_Assert (S1 != NULL, + "statcoll_Covar: statcoll_Collector S1 is a NULL pointer"); + util_Assert (S2 != NULL, + "statcoll_Covar: statcoll_Collector S2 is a NULL pointer"); + util_Assert (S1->NObs == S2->NObs, + "statcoll_Covar: S1->NObs != S2->NObs"); + util_Assert (S1->NObs > 1, "statcoll_Covar: NObs <= 1"); + Av1Av2 = statcoll_Average (S1) * statcoll_Average (S2); + Sum = 0.0; + for (i = 1; i <= S1->NObs; i++) { + Sum += S1->V[i] * S2->V[i] - Av1Av2; + } + return Sum / (S1->NObs - 1); +} diff --git a/cbits/testu/src/svaria.c b/cbits/testu/src/svaria.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/svaria.c @@ -0,0 +1,1230 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: svaria.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "gdef.h" +#include "util.h" +#include "tables.h" +#include "chrono.h" +#include "num.h" +#include "num2.h" + +#include "svaria.h" +#include "unif01.h" +#include "sres.h" +#include "wdist.h" +#include "swrite.h" +#include "smultin.h" + +#include "fmass.h" +#include "gofs.h" +#include "gofw.h" + +#include +#include +#include +#include +#include + + + + +lebool svaria_Timer = FALSE; + + + + +/*-------------------------------- Constants ------------------------------*/ + +/* Max string lengths */ +#define LEN1 100 +#define LEN2 200 + +/* Sample limit for normal approximation in svaria_SampleMean */ +#define SAM_LIM 60 + +/* Arrays dimension in svaria_AppearanceSpacings */ +#define AS_DIM 32 + +/* The Meschach package for matrix computations */ +#undef MESCHACH + + + + + +/*-------------------------------- Functions ------------------------------*/ + + +static void InitFDistMeans (int n, double Coef[]) +/* + * Initializes the distribution for svaria_SampleMean by computing the + * coefficients. We shall keep the value of n in element Coef[SAM_LIM], + * since we shall need it to get the value of the distribution at x. + */ +{ + int s; + double z; + fmass_INFO Q; + + z = num2_Factorial (n); + /* This uses the binomial formulae, but is not the binomial probability + distribution since p + q != 1 */ + Q = fmass_CreateBinomial (n, -1.0, 1.0); + for (s = 0; s <= n; s++) + Coef[s] = fmass_BinomialTerm2 (Q, s) / z; + fmass_DeleteBinomial (Q); + Coef[SAM_LIM] = n; + + if (swrite_Classes) { + printf ("---------------------------------------\n"); + for (s = 0; s <= n; s++) { + printf (" Coeff[%2d] = %14.6g\n", s, Coef[s]); + } + printf ("\n"); + } +} + +/*-------------------------------------------------------------------------*/ + +static double FDistMeans ( + double C[], /* Coefficients and sample size n */ + double x /* Argument */ + ) +/* + * Distribution function of sample mean as in Stephens (1966), p.235. + * This function is not very precise: the normal approximation is poor + * for small x, and the computation of the exact function is numerically + * unstable for large n. This will be used only for n < SAM_LIM. The + * value of n is in C[SAM_LIM]. + */ +{ + double Sum; + int M; + int i; + double nLR = C[SAM_LIM]; + int n = nLR; + + if (x <= 0.0) + return 0.0; + if (x >= n) + return 1.0; + + M = x; + Sum = 0.0; + if (x < n / 2.0) { + for (i = 0; i <= M; i++) { + Sum += C[i] * pow (x, nLR); + x -= 1.0; + } + } else { + x = -x + nLR; + for (i = n; i >= M + 1; i--) { + Sum += C[i] * pow (x, nLR); + x -= 1.0; + } + if (!(n & 1)) + Sum = -Sum; + Sum += 1.0; + } + return Sum; +} + +/*-------------------------------------------------------------------------*/ + +void svaria_SampleMean (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r) +{ + long i; + long Seq; + double Sum; + double Coef[SAM_LIM + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_SampleMean test"; + + Timer = chrono_Create (); + if (swrite_Basic) { + swrite_Head (gen, TestName, N, n, r); + printf ("\n\n"); + } + util_Assert (n > 1, "svaria_SampleMean: n < 2"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "svaria_SampleMean"); + if (n < SAM_LIM) + InitFDistMeans (n, Coef); + + if (n < SAM_LIM) + statcoll_SetDesc (res->sVal1, "SampleMean sVal1: n*"); + else + statcoll_SetDesc (res->sVal1, "SampleMean sVal1: standard normal"); + + for (Seq = 1; Seq <= N; Seq++) { + Sum = 0.0; + for (i = 1; i <= n; i++) + Sum += unif01_StripD (gen, r); + + if (n < SAM_LIM) + statcoll_AddObs (res->sVal1, Sum); + else + statcoll_AddObs (res->sVal1, sqrt (12.0 / n) * (Sum - 0.5 * n)); + } + + if (n < SAM_LIM) { + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, FDistMeans, Coef, + res->sVal2, res->pVal2); + } else { + /* Normal approximation */ + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + } + res->pVal1->NObs = N; + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Statistic value :"); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void svaria_SampleCorr (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r, int k) +{ + long i; + long Seq; + double U; + double Sum; + double *Pre; /* Previous k generated numbers */ + int pos; /* Circular index to element at lag k */ + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_SampleCorr test"; + + Timer = chrono_Create (); + if (swrite_Basic) { + swrite_Head (gen, TestName, N, n, r); + printf (", k = %d\n\n", k); + } + util_Assert (n > 2, "svaria_SampleCorr: n <= 2"); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "svaria_SampleCorr"); + statcoll_SetDesc (res->sVal1, + "SampleCorr sVal1: asymptotic standard normal"); + + Pre = util_Calloc ((size_t) (k + 1), sizeof (double)); + + for (Seq = 1; Seq <= N; Seq++) { + /* Generate first k numbers U and keep them in Pre */ + for (i = 0; i < k; i++) + Pre[i] = unif01_StripD (gen, r); + + Sum = 0.0; + pos = 0; + /* Element Pre[pos] is at lag k from U */ + for (i = k; i < n; i++) { + U = unif01_StripD (gen, r); + Sum += Pre[pos] * U - 0.25; + Pre[pos] = U; + pos++; + pos %= k; + } + /* Save standardized correlation */ + statcoll_AddObs (res->sVal1, Sum * sqrt (12.0 / (n - k))); + } + + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetNormalSumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res); + swrite_Final (gen, Timer); + } + util_Free (Pre); + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static double FDistProd ( + double Par[], /* The parameter t = Par[0] */ + double x /* The argument */ + ) +/* + * Compute the distribution function F for the product of t random variables + * U[0, 1], where + * t - 1 + * __ j + * F[u1*u2*...ut <= x] = x \ (-ln(x)) + * /__ ----------- + * j = 0 j! + * + */ +{ + double vlog, jterm, vterm, Sum; + int j, t; + + if (x >= 1.0) + return 1.0; + if (x <= 0.0) + return 0.0; + + vlog = log (x); + t = Par[0]; + Sum = 1.0; + vterm = 1.0; + jterm = 1.0; + for (j = 1; j < t; j++) { + vterm *= vlog; + jterm *= -j; + Sum += vterm / jterm; + if (vterm / jterm < DBL_EPSILON) + break; + } + return x * Sum; +} + + +/*-------------------------------------------------------------------------*/ + +void svaria_SampleProd (unif01_Gen * gen, sres_Basic * res, + long N, long n, int r, int t) +{ + long i; + int j; + long Seq; + double *P; + double temp; + double Par[1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_SampleProd test"; + + Timer = chrono_Create (); + if (swrite_Basic) { + swrite_Head (gen, TestName, N, n, r); + printf (", t = %d\n\n", t); + } + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "svaria_SampleProd"); + + P = util_Calloc ((size_t) n + 1, sizeof (double)); + statcoll_SetDesc (res->sVal1, "SampleProd sVal1: Uniform [0, 1]"); + Par[0] = t; + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 1; i <= n; i++) { + temp = unif01_StripD (gen, r); + for (j = 2; j <= t; j++) + temp *= unif01_StripD (gen, r); + P[i] = temp; + } + gofw_ActiveTests1 (P, n, FDistProd, Par, res->sVal2, res->pVal2); + statcoll_AddObs (res->sVal1, res->pVal2[gofw_AD]); + } + + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Unif, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Anderson-Darling statistic :"); + swrite_Final (gen, Timer); + } + util_Free (P); + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +void svaria_SumLogs (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r) +{ + const double Eps = DBL_EPSILON / 2.0; /* To avoid log(0) */ + const double Epsilon = 1.E-100; /* To avoid underflow */ + long i; + long Seq; + double u; + double Prod; + double Sum; + double V[1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_SumLogs test"; + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1]; + + Timer = chrono_Create (); + if (swrite_Basic) { + swrite_Head (gen, TestName, N, n, r); + printf ("\n\n"); + } + util_Assert (n < LONG_MAX/2, "2n > LONG_MAX"); + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, -1, "svaria_SumLogs"); + + strncpy (chaine, "SumLogs sVal1: chi2 with ", (size_t) LEN1); + sprintf (str, "%ld", 2 * n); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->sVal1, chaine); + res->degFree = 2 * n; + if (res->degFree < 1) { + util_Warning (TRUE, "Chi-square with 0 degree of freedom."); + if (localRes) + sres_DeleteChi2 (res); + return; + } + + for (Seq = 1; Seq <= N; Seq++) { + Prod = 1.0; + Sum = 0.0; + for (i = 1; i <= n; i++) { + u = unif01_StripD (gen, r); + if (u < Eps) + u = Eps; + Prod *= u; + if (Prod < Epsilon) { + Sum += log (Prod); + Prod = 1.0; + } + } + statcoll_AddObs (res->sVal1, -2.0 * (Sum + log (Prod))); + + } + V[0] = 2 * n; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LEN2, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataWeight (unif01_Gen * gen, char *TestName, + long N, long n, int r, long k, double Alpha, double Beta) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", k = %1ld, Alpha = %6.4g, Beta = %6.4g\n\n", + k, Alpha, Beta); +} + + +/*-------------------------------------------------------------------------*/ + +void svaria_WeightDistrib (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, long k, double Alpha, double Beta) +{ + long W; + long j; + long i; + long Seq; + double X; + double U; + double p; + double nLR = n; + double V[1]; + long NbClasses; + long *Loc; + fmass_INFO Q; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_WeightDistrib test"; + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1]; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataWeight (gen, TestName, N, n, r, k, Alpha, Beta); + + /* util_Assert (n >= 3.0 * gofs_MinExpected, + "svaria_WeightDistrib: n is too small"); */ + util_Assert (Alpha <= 1.0 && Alpha >= 0.0, + "svaria_WeightDistrib: Alpha must be in [0, 1]"); + util_Assert (Beta <= 1.0 && Beta >= 0.0, + "svaria_WeightDistrib: Beta must be in [0, 1]"); + p = Beta - Alpha; + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, k, "svaria_WeightDistrib"); + Loc = res->Loc; + + /* Compute binomial probabilities and multiply by n */ + Q = fmass_CreateBinomial (k, p, 1.0 - p); + for (i = 0; i <= k; i++) + res->NbExp[i] = nLR * fmass_BinomialTerm2 (Q, i); + fmass_DeleteBinomial (Q); + + res->jmin = 0; + res->jmax = k; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, 0); + + /* Merge classes for the chi-square */ + gofs_MergeClasses (res->NbExp, Loc, &res->jmin, &res->jmax, &NbClasses); + + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, NbClasses); + + strncpy (chaine, "WeightDistrib sVal1: chi2 with ", (size_t) LEN1); + sprintf (str, "%ld", NbClasses - 1); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->sVal1, chaine); + res->degFree = NbClasses - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i <= k; i++) + res->Count[i] = 0; + for (i = 1; i <= n; i++) { + W = 0; + for (j = 1; j <= k; j++) { + U = unif01_StripD (gen, r); + if (U >= Alpha && U < Beta) + ++W; + } + if (W > res->jmax) + ++res->Count[res->jmax]; + else + ++res->Count[Loc[W]]; + } + if (swrite_Counters) + tables_WriteTabL (res->Count, res->jmin, res->jmax, 5, 10, + "Observed numbers:"); + + X = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X); + } + + V[0] = NbClasses - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LEN2, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataArgMax (unif01_Gen * gen, char *TestName, + long N, long n, int r, long k, long m) +{ + double x; + + swrite_Head (gen, TestName, N, n, r); + printf (", k = %1ld, m = %1ld\n\n", k, m); + printf (" Number of balls = n = %1ld\n", n); + printf (" Number of urns = k = %1ld\n", k); + + x = n; + x = x * x / (2 * k); + printf (" Number (approx) of collisions = n^2 / 2k = %g\n\n\n", x); +} + +/*-------------------------------------------------------------------------*/ + +static int svaria_CollisionArgMax_00 (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, long k, long m) +/* + * Return 0 if no error, otherwise return != 0. + */ +{ + double X; + double U; + double Max; + long NbColl; + long Indice = -1; + long j; + long i; + long Rep; + long Seq; + long NbClasses; + long *Loc; + int *Urne; + double V[1]; + fmass_INFO Q; + lebool localRes = FALSE; + chrono_Chrono *chro, *Timer; + char *TestName = "svaria_CollisionArgMax test"; + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1]; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataArgMax (gen, TestName, N, n, r, k, m); + + util_Assert (n <= 4 * k, "svaria_CollisionArgMax: n > 4k"); + /* util_Assert (m > 2.0 * gofs_MinExpected, + "svaria_CollisionArgMax: m <= 2*gofs_MinExpected"); */ + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, n, "svaria_CollisionArgMax"); + Loc = res->Loc; + Urne = util_Calloc ((size_t) k + 1, sizeof (int)); + + if (svaria_Timer) { + printf ("-----------------------------------------------"); + printf ("\nCPU time to initialize the collision distribution: "); + chro = chrono_Create (); + } + Q = smultin_CreateCollisions (n, (smultin_CellType) k); + if (svaria_Timer) { + chrono_Write (chro, chrono_hms); + printf ("\n\n"); + } + + /* Compute the expected numbers of collisions: m*P(j) */ + for (j = 0; j <= n; j++) + res->NbExp[j] = m * smultin_CollisionsTerm (Q, j); + smultin_DeleteCollisions (Q); + + res->jmin = 0; + res->jmax = n; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, 0); + + gofs_MergeClasses (res->NbExp, Loc, &res->jmin, &res->jmax, &NbClasses); + + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, NbClasses); + + strncpy (chaine, "CollisionArgMax sVal1: chi2 with ", (size_t) LEN1); + sprintf (str, "%ld", NbClasses - 1); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->sVal1, chaine); + res->degFree = NbClasses - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return 1; + } + + if (svaria_Timer) + chrono_Init (chro); + + for (Seq = 1; Seq <= N; Seq++) { + for (j = 0; j <= n; j++) + res->Count[j] = 0; + + for (Rep = 1; Rep <= m; Rep++) { + for (j = 0; j <= k; j++) + Urne[j] = -1; + + NbColl = 0; + for (j = 1; j <= n; j++) { + Max = -1.0; + for (i = 1; i <= k; i++) { + U = unif01_StripD (gen, r); + if (U > Max) { + Max = U; + Indice = i; + } + } + if (Urne[Indice] < 0) + Urne[Indice] = 1; + else + ++NbColl; + } + if (NbColl > res->jmax) + ++res->Count[res->jmax]; + else + ++res->Count[Loc[NbColl]]; + } + if (swrite_Counters) + tables_WriteTabL (res->Count, res->jmin, res->jmax, 5, 10, + "Observed numbers:"); + X = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X); + } + + if (svaria_Timer) { + printf ("\n----------------------------------------------\n" + "CPU time for the test : "); + chrono_Write (chro, chrono_hms); + printf ("\n\n"); + chrono_Delete (chro); + } + + V[0] = NbClasses - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LEN2, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + util_Free (Urne); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); + return 0; +} + + +/*-------------------------------------------------------------------------*/ + +void svaria_CollisionArgMax (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, long k, long m) +{ + if (m > 1) { + svaria_CollisionArgMax_00 (gen, res, N, n, r, k, m); + + } else if (m == 1) { + double ValDelta[] = { -1.0 }; + smultin_Param *par; + + if (swrite_Basic) { + printf ( + "***********************************************************\n" + "Test svaria_CollisionArgMax calling smultin_Multinomial\n\n"); + } + par = smultin_CreateParam (1, ValDelta, smultin_GenerCellMax, -3); + if (NULL == res) { + smultin_Multinomial (gen, par, NULL, N, n, r, 0, k, TRUE); + } else { + smultin_Res *resm; + resm = smultin_CreateRes (par); + smultin_Multinomial (gen, par, resm, N, n, r, 0, k, TRUE); + sres_InitChi2 (res, N, -1, "svaria_CollisionArgMax"); + statcoll_SetDesc (res->sVal1, "CollisionArgMax sVal1"); + res->sVal1->NObs = resm->Collector[0]->NObs; + tables_CopyTabD (resm->Collector[0]->V, res->sVal1->V, 1, N); + tables_CopyTabD (resm->sVal2[0], res->sVal2, 0, gofw_NTestTypes - 1); + tables_CopyTabD (resm->pVal2[0], res->pVal2, 0, gofw_NTestTypes - 1); + smultin_DeleteRes (resm); + } + smultin_DeleteParam (par); + } else { + util_Warning (m <= 0, "svaria_CollisionArgMax: m <= 0"); + } +} + + +/*=========================================================================*/ + +static void WriteDataSumColl (unif01_Gen * gen, char *TestName, + long N, long n, int r, double g) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", g = %g\n\n", g); +} + +/*-------------------------------------------------------------------------*/ + +static double ProbabiliteG (int jmin, int j, double g) +/* + * Returns the probability that the minimum number of random U(0,1) whose + * sum is larger than g is j+1. g cannot be too large because the + * calculation here becomes numerically unstable. + */ +{ + int s; + double temp; + const double jLR = j; + double signe; /* +1 or -1 */ + double somme; + + signe = 1.0; + somme = 0.0; + for (s = 0; s <= jmin; s++) { + temp = signe * num2_Combination (j + 1, s); + temp *= pow (g - s, jLR); + somme += temp; + signe = -signe; + } + somme = (jLR + 1.0 - g) * somme / num2_Factorial (j + 1); + return somme; +} + + +/*-------------------------------------------------------------------------*/ + +void svaria_SumCollector (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, double g) +{ + const double gmax = 10.0; /* Maximal value of g */ + const int jmax = 50; /* Maximal number of classes */ + int j; /* Class index */ + long Seq; + long i; + double X; + double Y; + double Sum; + long NbClasses; + long *Loc; + double V[1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "svaria_SumCollector test"; + char chaine[LEN1 + 1] = ""; + char str[LEN2 + 1]; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataSumColl (gen, TestName, N, n, r, g); + + if (g < 1.0 || g > gmax) { + util_Error ("svaria_SumCollector: g < 1.0 or g > 10.0"); + } + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, jmax, "svaria_SumCollector"); + Loc = res->Loc; + + res->jmin = g; + res->jmax = jmax; + Sum = 0.0; + for (j = res->jmin; j < jmax; j++) { + res->NbExp[j] = n * ProbabiliteG (res->jmin, j, g); + Sum += res->NbExp[j]; + } + res->NbExp[jmax] = util_Max (0.0, n - Sum); + + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, 0); + gofs_MergeClasses (res->NbExp, Loc, &res->jmin, &res->jmax, &NbClasses); + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, Loc, res->jmin, res->jmax, NbClasses); + + strncpy (chaine, "SumCollector sVal1: chi2 with ", (size_t) LEN1); + sprintf (str, "%ld", NbClasses - 1); + strncat (chaine, str, (size_t) LEN2); + strncat (chaine, " degrees of freedom", (size_t) LEN1); + statcoll_SetDesc (res->sVal1, chaine); + res->degFree = NbClasses - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + + for (Seq = 1; Seq <= N; Seq++) { + for (j = 1; j <= jmax; j++) + res->Count[j] = 0; + + for (i = 1; i <= n; i++) { + X = 0.0; + j = 0; + do { + X += unif01_StripD (gen, r); + ++j; + } + while (X <= g); + if (j > res->jmax) + ++res->Count[res->jmax]; + else + ++res->Count[Loc[j - 1]]; + } + if (swrite_Counters) + tables_WriteTabL (res->Count, res->jmin, res->jmax, 5, 10, + "Observed numbers:"); + Y = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, Y); + } + + V[0] = NbClasses - 1; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LEN2, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void InitAppear (int r, int s, int L, long Q, double E[], double KV[]) +{ + util_Assert (r >= 0, "svaria_AppearanceSpacings: r < 0"); + util_Assert (s > 0, "svaria_AppearanceSpacings: s <= 0"); + /* if (L >= s && L % s) { + util_Error ("svaria_AppearanceSpacings: L mod s != 0"); + }*/ + if (L < s && s % L) { + util_Error ("svaria_AppearanceSpacings: s mod L != 0"); + } + util_Warning (Q < 10.0 * num_TwoExp[L], + "svaria_AppearanceSpacings: Q < 10 * 2^L"); + + /* Theoretical mean E and variance KV for different L given by Maurer */ + if (L > 16) { + /* For L > 16 and near 16, the 6-th decimal of E[L] could be + erroneous. For KV [L], the 4-th decimal. */ + E[L] = L - 8.32746E-1; + KV[L] = 3.423715; + } else { + E [1] = 0.73264948; KV[1] = 0.68977; + E [2] = 1.53743829; KV[2] = 1.33774; + E [3] = 2.40160681; KV[3] = 1.90133; + E [4] = 3.31122472; KV[4] = 2.35774; + E [5] = 4.25342659; KV[5] = 2.70455; + E [6] = 5.21770525; KV[6] = 2.95403; + E [7] = 6.19625065; KV[7] = 3.12539; + E [8] = 7.18366555; KV[8] = 3.23866; + E [9] = 8.17642476; KV[9] = 3.31120; + E [10] = 9.17232431; KV[10] = 3.35646; + E [11] = 10.1700323; KV[11] = 3.38409; + E [12] = 11.1687649; KV[12] = 3.40065; + E [13] = 12.1680703; KV[13] = 3.41043; + E [14] = 13.1676926; KV[14] = 3.41614; + E [15] = 14.1674884; KV[15] = 3.41943; + E [16] = 15.1673788; KV[16] = 3.42130; + } +} + +/*-------------------------------------------------------------------------*/ + +static double CalcSigma (int L, long K, double KV[]) +/* + * Compute the standard deviation for the svaria_AppearanceSpacings test. + */ +{ + double dCor[AS_DIM + 1]; /* Coron-Naccache factor d */ + double eCor[AS_DIM + 1]; /* Coron-Naccache factor e */ + double temp; + /* double c; */ + +#if 0 /* No correction */ + return sqrt (KV[L] / K); + +#elif 0 /* Maurer's correction c(L, K) */ + temp = 3.0 / L * num_Log2 ((double) K); + if (temp >= DBL_MAX_EXP - 1) + temp = 0.0; + else + temp = pow (2.0, -temp); + c = 0.7 - 0.8/L + (4.0 + 32.0/L) * temp / 15.0; + if (L < 3 || L > 16) + c = 1.0; + return c * sqrt (KV[L] / K); + +#else /* based on Coron and Naccache exact calculation */ + dCor [3] = 0.2732725; eCor [3] = 0.4890883; + dCor [4] = 0.3045101; eCor [4] = 0.4435381; + dCor [5] = 0.3296587; eCor [5] = 0.4137196; + dCor [6] = 0.3489769; eCor [6] = 0.3941338; + dCor [7] = 0.3631815; eCor [7] = 0.3813210; + dCor [8] = 0.3732189; eCor [8] = 0.3730195; + dCor [9] = 0.3800637; eCor [9] = 0.3677118; + dCor [10] = 0.3845867; eCor [10] = 0.3643695; + dCor [11] = 0.3874942; eCor [11] = 0.3622979; + dCor [12] = 0.3893189; eCor [12] = 0.3610336; + dCor [13] = 0.3904405; eCor [13] = 0.3602731; + dCor [14] = 0.3911178; eCor [14] = 0.3598216; + dCor [15] = 0.3915202; eCor [15] = 0.3595571; + dCor [16] = 0.3917561; eCor [16] = 0.3594040; + /* L = infinite */ + dCor [0] = 0.3920729; eCor [0] = 0.3592016; + + if (L < 3) + return sqrt (KV[L] / K); + if (L > 16) + temp = dCor[0] + eCor [0] * num_TwoExp[L] / K; + else + temp = dCor[L] + eCor [L] * num_TwoExp[L] / K; + return sqrt (temp * KV[L] / K); + +#endif +} + +/*-------------------------------------------------------------------------*/ + +static void WriteDataAppear (unif01_Gen * gen, + long N, int r, int s, int L, long Q, long K, double n) +{ + printf ("***********************************************************\n"); + printf ("HOST = "); + if (swrite_Host) { + gdef_WriteHostName (); + printf ("\n"); + } else + printf ("\n\n"); + unif01_WriteNameGen (gen); + printf ("\n"); + if (swrite_ExperimentName && strcmp (swrite_ExperimentName, "")) { + printf ("%s", swrite_ExperimentName); + printf (":\n\n"); + } + + printf ("svaria_AppearanceSpacings test:\n" + "-----------------------------------------------\n"); + + printf (" N = %2ld, Q = %1ld, K = %1ld, r = %1d, s = %1d," + " L = %1d\n\n", N, Q, K, r, s, L); + printf (" Sequences of n = (K + Q)L = %12.0f bits\n", n); + printf (" Q = %4ld initialization blocks\n", Q); + printf (" K = %4ld blocks for the test\n", K); + printf (" the blocks have L = %2d bits\n\n\n", L); +} + + +/*-------------------------------------------------------------------------*/ + +void svaria_AppearanceSpacings (unif01_Gen * gen, sres_Basic * res, + long N, long Q, long K, int r, int s, int L) +{ + double E[AS_DIM + 1]; /* Theoretical mean of the log (Base2) of + the most recent occurrence of a block */ + double KV[AS_DIM + 1]; /* K times the theoretical variance of the + same */ + long Seq; + long block; + long Nblocks; /* 2^L = total number of distinct blocks */ + long K2; + long Q2; + long i; + long sBits; /* Numerical value of the s given bits */ + long d; /* 2^s */ + const int SdivL = s / L; + const int LdivS = L / s; + const int LmodS = L % s; + long sd; /* 2^LmodS */ + long rang; + double n; /* Total number of bits in a sequence */ + double sigma; /* Standard deviation = sqrt (Variance) */ + double somme; + double ARang; /* Most recent occurrence of block */ + long *Count; /* Index of most recent occurrence of + block */ + double FactMoy; + lebool localRes = FALSE; + chrono_Chrono *Timer; + + Timer = chrono_Create (); + n = ((double) K + (double) Q) * L; + if (swrite_Basic) + WriteDataAppear (gen, N, r, s, L, Q, K, n); + util_Assert (s < 32, "svaria_AppearanceSpacings: s >= 32"); + InitAppear (r, s, L, Q, E, KV); + sigma = CalcSigma (L, K, KV); + d = num_TwoExp[s]; + Nblocks = num_TwoExp[L]; + FactMoy = 1.0 / (num_Ln2 * K); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateBasic (); + } + sres_InitBasic (res, N, "svaria_AppearanceSpacings"); + Count = util_Calloc ((size_t) Nblocks + 2, sizeof (long)); + + statcoll_SetDesc (res->sVal1, + "AppearanceSpacings sVal1: standard normal"); + + if (LdivS > 0) { + sd = num_TwoExp[LmodS]; + + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i < Nblocks; i++) + Count[i] = 0; + + /* Initialization with Q blocks */ + for (rang = 0; rang < Q; rang++) { + block = 0; + for (i = 1; i <= LdivS; i++) { + sBits = unif01_StripB (gen, r, s); + block = block * d + sBits; + } + if (LmodS > 0) { + sBits = unif01_StripB (gen, r, LmodS); + block = block * sd + sBits; + } + Count[block] = rang; + } + + /* Test proper with K blocks */ + somme = 0.0; + for (rang = Q; rang < Q + K; rang++) { + block = 0; + for (i = 1; i <= LdivS; i++) { + sBits = unif01_StripB (gen, r, s); + block = block * d + sBits; + } + if (LmodS > 0) { + sBits = unif01_StripB (gen, r, LmodS); + block = block * sd + sBits; + } + ARang = rang - Count[block]; + somme += log (ARang); + Count[block] = rang; + } + statcoll_AddObs (res->sVal1, (somme * FactMoy - E[L]) / sigma); + } + + } else { /* s > L */ + Q2 = Q / SdivL; + K2 = K / SdivL; + for (Seq = 1; Seq <= N; Seq++) { + for (i = 0; i < Nblocks; i++) + Count[i] = 0; + + /* Initialization: Q blocks */ + for (rang = 0; rang < Q2; rang++) { + sBits = unif01_StripB (gen, r, s); + for (i = 0; i < SdivL; i++) { + block = sBits % Nblocks; + Count[block] = SdivL * rang + i; + sBits /= Nblocks; + } + } + /* Test proper with K blocks */ + somme = 0.0; + for (rang = Q2; rang < Q2 + K2; rang++) { + sBits = unif01_StripB (gen, r, s); + for (i = 0; i < SdivL; i++) { + block = sBits % Nblocks; + ARang = SdivL * rang + i - Count[block]; + somme += log (ARang); + Count[block] = SdivL * rang + i; + sBits /= Nblocks; + } + } + statcoll_AddObs (res->sVal1, (somme * FactMoy - E[L]) / sigma); + } + } + + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_Normal, + (double *) NULL, res->sVal2, res->pVal2); + res->pVal1->NObs = N; + sres_GetNormalSumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 12, 4, 3); + + if (swrite_Basic) { + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, + "Normal statistic :"); + swrite_NormalSumTest (N, res); + swrite_Final (gen, Timer); + } + util_Free (Count); + if (localRes) + sres_DeleteBasic (res); + chrono_Delete (Timer); +} diff --git a/cbits/testu/src/swalk.c b/cbits/testu/src/swalk.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/swalk.c @@ -0,0 +1,1250 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: swalk.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" +#include "chrono.h" +#include "num.h" +#include "num2.h" +#include "bitset.h" + +#include "swalk.h" +#include "wdist.h" +#include "swrite.h" +#include "unif01.h" + +#include "fmass.h" +#include "fbar.h" +#include "gofw.h" +#include "gofs.h" + +#include +#include +#include + + + + +/*------------------------------- Constants -------------------------------*/ + +#define PREC 52 /* Max number of bits in a number */ +#define LENGTH 200 /* Max length of strings */ + + +typedef enum { + swalk_rwH, /* H statistic */ + swalk_rwM, /* M statistic */ + swalk_rwJ, /* J statistic */ + swalk_rwR, /* R statistic */ + swalk_rwC, /* C statistic */ + swalk_rw_N /* Total number of statistics here */ +} swalk_rwType; + +/* The name of each type of statistic in swalk_rwType (predefined). */ +static const char *swalk_rwName[swalk_rw_N] = { + "Statistic H", + "Statistic M", + "Statistic J", + "Statistic R", + "Statistic C" +}; + + +/*--------------------------------- Types ---------------------------------*/ + +typedef struct { + long X; + long S; + long S_2; + long M; + long R; + long J; + long C; +} WorkType; + + +/* Type of algorithm used in swalk_VarGeo */ +typedef enum { + swalk_AlgoP, + swalk_AlgoN + } swalk_AlgoType; + + + + +/*-------------------------------- functions ------------------------------*/ + +static void CalcNbExp ( + long n, /* Sample size */ + long L0, + long k, + swalk_Res *res + ) +/* + ************ IMPORTANT: we assume that L is even ************ + * Compute the expected numbers for the different statistics in the + * swalk_RandomWalk1 and swalk_RandomWalk1a tests. We start from the + * maximum term and compute on each side all terms larger than epsilon. + * We set all others to 0. + */ +{ + const double epsilon = 1.0E-16; + double *NbExp; + long L1, L2; + const long L = L0 + k; + long i; + double nLR = n; + double epsn; + + util_Assert (!(L & 1), "CalcNbExp: L is odd"); + L2 = L / 2; + epsn = epsilon * nLR; + + /*----------- statistic H -----------*/ + NbExp = res->H[k]->NbExp; + for (i = 0; i <= L; i++) + NbExp[i] = 0.0; + + NbExp[L2] = nLR * fmass_BinomialTerm1 (L, 0.5, 0.5, L2); + i = L2; + while (i > 0 && NbExp[i] > epsn) { + NbExp[i - 1] = NbExp[i] * i / (L - i + 1); + --i; + } + i = L2; + while (i < L && NbExp[i] > epsn) { + NbExp[i + 1] = NbExp[i] * (L - i) / (i + 1); + ++i; + } + + /*----------- statistic M -----------*/ + NbExp = res->M[k]->NbExp; + for (i = 0; i <= L; i++) + NbExp[i] = 0.0; + + NbExp[0] = res->H[k]->NbExp[L2]; + i = 0; + while (i < L && NbExp[i] > epsn) { + NbExp[i + 1] = NbExp[i] * ((L - i) / 2) / ((L + i) / 2 + 1); + NbExp[i + 2] = NbExp[i + 1]; + i += 2; + } + + /*----------- statistic J -----------*/ + NbExp = res->J[k]->NbExp; + for (i = 0; i <= L; i++) + NbExp[i] = 0.0; + + NbExp[0] = res->M[k]->NbExp[0]; + NbExp[L] = NbExp[0]; + i = 0; + while (i < L2 && NbExp[i] > epsn) { + NbExp[i + 2] = NbExp[i] * ((L - i) / 2) * + (1 + i) / ((double)(i / 2 + 1) * (L - i - 1)); + NbExp[L - i - 2] = NbExp[i + 2]; + i += 2; + } + + /*----------- statistic R -----------*/ + NbExp = res->R[k]->NbExp; + for (i = 0; i <= L; i++) + NbExp[i] = 0.0; + + NbExp[0] = res->J[k]->NbExp[0]; + i = 0; + while (i < L2 && NbExp[i] > epsn) { + NbExp[i + 1] = NbExp[i] * (L - 2 * i) / (L - i); + ++i; + } + + /*----------- statistic C -----------*/ + NbExp = res->C[k]->NbExp; + for (i = 0; i <= L; i++) + NbExp[i] = 0.0; + + NbExp[0] = 2.0 * nLR * fmass_BinomialTerm1 (L - 1, 0.5, 0.5, L2); + i = 0; + L1 = L2 - 1; + while (i < L1 && NbExp[i] > epsn) { + NbExp[i + 1] = NbExp[i] * (L2 - i - 1) / (L2 + i + 1); + ++i; + } +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteTabWalk ( + swalk_Res *res, + long N /* Number of replications */ + ) +/* + * Write the values of the statistics and their p-values in a table + * for all values of the walk length L from L0 to L1. These values have + * all been written before, but it is nice to have them all together. + * When L0 = L1, it is not useful. When the number of replications N > 1, it + * is not called either because there would be so many statistics to write. + */ +{ + swalk_rwType m; + long k; + double p; + long L0 = res->L0; /* Shortest walk length considered */ + long L1 = res->L1; /* Longest walk length considered */ + + if (L1 == L0) + return; + if (N > 1) + return; + printf ("\n\n***********************************************" + "\nTABLES FOR THE RESULTS ABOVE"); + for (m = 0; m < swalk_rw_N; m++) { + printf ("\n\n===============================================\n"); + printf ("Test on the values of the "); + printf ("%s", swalk_rwName[m]); + printf ("\n\n Walk length Chi-square p-value\n\n"); + + for (k = 0; k <= L1 - L0; k += 2) { + printf ("%8ld", L0 + k); + switch (m) { + case swalk_rwH: + num_WriteD (res->H[k]->sVal2[gofw_Mean], 18, 3, 2); + p = res->H[k]->pVal2[gofw_Mean]; + break; + case swalk_rwM: + num_WriteD (res->M[k]->sVal2[gofw_Mean], 18, 3, 2); + p = res->M[k]->pVal2[gofw_Mean]; + break; + case swalk_rwJ: + num_WriteD (res->J[k]->sVal2[gofw_Mean], 18, 3, 2); + p = res->J[k]->pVal2[gofw_Mean]; + break; + case swalk_rwR: + num_WriteD (res->R[k]->sVal2[gofw_Mean], 18, 3, 2); + p = res->R[k]->pVal2[gofw_Mean]; + break; + case swalk_rwC: + num_WriteD (res->C[k]->sVal2[gofw_Mean], 18, 3, 2); + p = res->C[k]->pVal2[gofw_Mean]; + break; + default: + util_Error ("swalk: WriteTabWalk: no such case"); + } + num_WriteD (p, 18, 3, 2); + if (p < gofw_Suspectp || p > 1.0 - gofw_Suspectp) { + printf (" *****"); + } + printf ("\n"); + } + } + printf ("\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteResultWalk ( + swalk_Res *res, + long N /* Number of replications */ + ) +/* + * Write the basic results of the swalk_RandomWalk1 and swalk_RandomWalk1a + * tests for all walks of length L between L0 and L1. May write the + * statistical collectors too. + */ +{ + swalk_rwType m; + long L0 = res->L0; /* Shortest walk length considered */ + long L1 = res->L1; /* Longest walk length considered */ + long k; + sres_Chi2 *Q; + + printf ("\n"); + for (k = 0; k <= L1 - L0; k += 2) { + if (L1 > L0) { + printf ("\n\n===============================================" + "\nWALK OF %3ld STEPS\n", L0 + k); + } + for (m = 0; m < swalk_rw_N; m++) { + printf ("-----------------------------------------------\n" + "Test on the values of the "); + printf ("%s", swalk_rwName[m]); + printf ("\n\n"); + switch (m) { + case swalk_rwH: + Q = res->H[k]; + break; + case swalk_rwM: + Q = res->M[k]; + break; + case swalk_rwJ: + Q = res->J[k]; + break; + case swalk_rwR: + Q = res->R[k]; + break; + case swalk_rwC: + Q = res->C[k]; + break; + default: + util_Error ("swalk: WriteResultWalk: no such case"); + } + if (N == 1) { + printf ("Number of degrees of freedom : %4ld\n", + Q->degFree); + printf ("ChiSquare statistic :"); + gofw_Writep2 (Q->sVal2[gofw_Mean], Q->pVal2[gofw_Mean]); + } else { + gofw_WriteActiveTests0 (N, Q->sVal2, Q->pVal2); + swrite_Chi2SumTest (N, Q); + } + printf ("\n"); + if (swrite_Collectors) + statcoll_Write (Q->sVal1, 5, 14, 4, 3); + } + } + WriteTabWalk (res, N); +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteDetailsWalk ( + swalk_Res *res, + long k, /* Walk length L = k + L0 */ + long n /* sample size */ + ) +/* + * Write detailed results for the different statistics of a walk of length + * L = k + L0: the expected numbers, the observed numbers (the counters), + * and the normalized values. If the normalized value is outside the interval + * [-3, 3], we indicate it explicitly. + + */ +{ + swalk_rwType m; + long i; + double iObs; /* Weighted sum of the observed numbers */ + double Obs; /* Observed numbers */ + double iEsp; /* Weighted sum of the expected numbers */ + double Esp; /* Expected numbers */ + double Z; /* Normalized value */ + double Var; /* Variance */ + long L0 = res->L0; /* Shortest length of walks considered */ + double nLR = n; + sres_Chi2 *Q; + + printf ("================================================\n"); + printf ("Walk of %3ld steps\n", L0 + k); + + for (m = 0; m < swalk_rw_N; m++) { + printf ("------------------------------------------------\n" + "Counters of the "); + printf ("%s", swalk_rwName[m]); + printf + ("\n\n i Expected num. Observed num. (Exp. - Obs.)/sigma\n\n"); + iEsp = 0.0; + iObs = 0.0; + switch (m) { + case swalk_rwH: + Q = res->H[k]; + break; + case swalk_rwM: + Q = res->M[k]; + break; + case swalk_rwJ: + Q = res->J[k]; + break; + case swalk_rwR: + Q = res->R[k]; + break; + case swalk_rwC: + Q = res->C[k]; + break; + default: + util_Error ("swalk: WriteDetailsWalk: no such case"); + } + i = Q->jmin - 1; + do { + i = Q->Loc[i + 1]; + Esp = Q->NbExp[i]; + Obs = Q->Count[i]; + iEsp = iEsp + Esp * i; /* Expected value of the statistic */ + iObs = iObs + Obs * i; /* Observed mean of the statistic */ + + /* If Esp = 0, this is a class that has been redirected to another + for the ChiSquare test; we shall not print it since the counters + have been redirected also: they are necessarily 0. */ + if (Esp > 0.0) { + printf ("%4ld", i); + num_WriteD (Esp, 14, 2, 0); + num_WriteD (Obs, 12, 0, 0); + Var = Esp * (1.0 - Esp / nLR); + if (Var <= 0.0) + Z = (Obs - Esp) * 1.E100; + else + Z = (Obs - Esp) / sqrt (Var); + num_WriteD (Z, 18, 4, 3); + if (Z > 3.0 || Z < -3.0) + printf (" *****"); + printf ("\n"); + } + } while (i != Q->jmax); + + printf ("\nExpected mean = "); + num_WriteD (iEsp / nLR, 10, 2, 0); + printf ("\nEmpirical mean = "); + num_WriteD (iObs / nLR, 10, 2, 0); + printf ("\n\n"); + } + printf ("\n"); +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteDataWalk1 (unif01_Gen *gen, char *TestName, + long N, long n, int r, int s, long L0, long L1) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, L0 = %4ld, L1 = %4ld\n\n\n", s, L0, L1); +} + + +/*=========================================================================*/ + +swalk_Res * swalk_CreateRes (void) +{ + swalk_Res *res; + + res = util_Malloc (sizeof (swalk_Res)); + memset (res, 0, sizeof (swalk_Res)); + res->H = util_Calloc (1, sizeof (sres_Chi2 *)); + res->M = util_Calloc (1, sizeof (sres_Chi2 *)); + res->J = util_Calloc (1, sizeof (sres_Chi2 *)); + res->R = util_Calloc (1, sizeof (sres_Chi2 *)); + res->C = util_Calloc (1, sizeof (sres_Chi2 *)); + res->H[0] = sres_CreateChi2 (); + res->M[0] = sres_CreateChi2 (); + res->J[0] = sres_CreateChi2 (); + res->R[0] = sres_CreateChi2 (); + res->C[0] = sres_CreateChi2 (); + res->imax = 0; + res->name = util_Calloc (1, sizeof (char)); + return res; +} + + +/*-------------------------------------------------------------------------*/ + +void swalk_DeleteRes (swalk_Res *res) +{ + long i; + + if (res == NULL) + return; + util_Free (res->name); + for (i = 0; i <= res->imax; i += 2) { + sres_DeleteChi2 (res->H[i]); + sres_DeleteChi2 (res->M[i]); + sres_DeleteChi2 (res->R[i]); + sres_DeleteChi2 (res->J[i]); + sres_DeleteChi2 (res->C[i]); + } + util_Free (res->H); + util_Free (res->R); + util_Free (res->M); + util_Free (res->J); + util_Free (res->C); + util_Free (res); +} + + +/*-------------------------------------------------------------------------*/ + +static void InitRes ( + swalk_Res *res, + WorkType *work, + long N, /* Number of replications */ + long L0, /* Shortest walk length considered */ + long L1, /* Longest walk length considered */ + char *nam +) +/* + * Allocates memory for arrays to be used in the swalk_RandomWalk1a and + * swalk_RandomWalk1 tests. Arrays for walk length L will be indexed + * by i = L - L0. + */ +{ + long i, imax, L; + + util_Assert (!(L0 & 1), "InitRes: L0 is odd"); + if (L1 & 1) + L1--; + util_Assert (L1 >= L0, "InitRes: L1 < L0"); + imax = L1 - L0; + + for (i = imax + 2; i <= res->imax; i += 2) { + sres_DeleteChi2 (res->H[i]); + sres_DeleteChi2 (res->M[i]); + sres_DeleteChi2 (res->R[i]); + sres_DeleteChi2 (res->J[i]); + sres_DeleteChi2 (res->C[i]); + } + res->H = util_Realloc (res->H, ((size_t) imax + 1) * sizeof(sres_Chi2 *)); + res->R = util_Realloc (res->R, ((size_t) imax + 1) * sizeof(sres_Chi2 *)); + res->M = util_Realloc (res->M, ((size_t) imax + 1) * sizeof(sres_Chi2 *)); + res->J = util_Realloc (res->J, ((size_t) imax + 1) * sizeof(sres_Chi2 *)); + res->C = util_Realloc (res->C, ((size_t) imax + 1) * sizeof(sres_Chi2 *)); + + for (i = res->imax + 2; i <= imax; i += 2) { + res->H[i] = sres_CreateChi2 (); + res->M[i] = sres_CreateChi2 (); + res->J[i] = sres_CreateChi2 (); + res->R[i] = sres_CreateChi2 (); + res->C[i] = sres_CreateChi2 (); + } + + for (i = 0; i <= imax; i += 2) { + L = i + L0; + sres_InitChi2 (res->H[i], N, L, ""); + sres_InitChi2 (res->M[i], N, L, ""); + sres_InitChi2 (res->R[i], N, L, ""); + sres_InitChi2 (res->J[i], N, L, ""); + sres_InitChi2 (res->C[i], N, L, ""); + res->R[i]->jmax = L / 2; + res->C[i]->jmax = L / 2; + } + res->L1 = L1; + res->L0 = L0; + res->imax = imax; + res->work = work; + res->name = util_Realloc (res->name, 1 + strlen (nam) * sizeof (char)); + strcpy (res->name, nam); +} + + +/*-------------------------------------------------------------------------*/ + +static void Steps ( + unif01_Gen *gen, + swalk_Res *res, + long j, /* will generate j-th random number */ + int r, /* drop the first r bits of each random number */ + int s /* keep only s bits of each random number */ + ) +/* + * Generates a random number Z; each of the s bits of Z kept is a step of + * the random walk. Updates all statistics for these s steps. + */ +{ + int i; + long k; + unsigned long Z, iBit; + const unsigned long SBIT = 1UL << (s - 1); + WorkType *work = res->work; + + Z = unif01_StripB (gen, r, s); + iBit = SBIT; + + for (i = s - 1; i >= 0; i--) { + ++res->L; + if (Z & iBit) /* If i bit of Z is 1 */ + work->X = 1; + else + work->X = -1; + work->S += work->X; + if (work->S > work->M) + work->M = work->S; + if (work->S == 0) + ++work->R; + if ((s * j - i) & 1) { + if (work->S > 0) + ++work->J; + if (work->S * work->S_2 < 0) + ++work->C; + work->S_2 = work->S; + } + + if ((res->L >= res->L0) && !(res->L & 1)) { + k = res->L - res->L0; + ++res->H[k]->Count[res->H[k]->Loc[(res->L + work->S) / 2]]; + ++res->M[k]->Count[res->M[k]->Loc[work->M]]; + ++res->J[k]->Count[res->J[k]->Loc[2 * work->J]]; + ++res->R[k]->Count[res->R[k]->Loc[work->R]]; + ++res->C[k]->Count[res->C[k]->Loc[work->C]]; + } + iBit >>= 1; + } +} + + +/*-------------------------------------------------------------------------*/ + +void swalk_RandomWalk1 (unif01_Gen *gen, swalk_Res *res, + long N, long n, int r, int s, long L0, long L1) +{ + swalk_rwType m; + long DeltaL; + int LMS; + long LDS; + long i, j, k, Rep, Seq; + double khi; + double V[1]; /* Number degrees of freedom for ChiSquare */ + long NbClasses; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "swalk_RandomWalk1 test"; + WorkType work; + sres_Chi2 *Q; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataWalk1 (gen, TestName, N, n, r, s, L0, L1); + + util_Assert (L0 > 0, "swalk_RandomWalk1: L0 <= 0"); + util_Assert (!(L0 & 1), "swalk_RandomWalk1: L0 must be even"); + util_Assert (!(L1 & 1), "swalk_RandomWalk1: L1 must be even"); + util_Assert (L1 >= L0, "swalk_RandomWalk1: L0 > L1"); + util_Assert (r + s <= PREC, "swalk_RandomWalk1: r + s > 32"); + if (n < 3.0 * gofs_MinExpected) { + util_Warning (TRUE, "swalk_RandomWalk1: n < 3*gofs_MinExpected"); + return; + } + + DeltaL = L1 - L0; + LDS = L1 / s; + LMS = L1 % s; + if (res == NULL) { + localRes = TRUE; + res = swalk_CreateRes (); + } + InitRes (res, &work, N, L0, L1, "swalk_RandomWalk1"); + + /* Compute the expected numbers and merge classes for the ChiSquare */ + for (k = 0; k <= DeltaL; k += 2) { + CalcNbExp (n, L0, k, res); + + for (m = 0; m < swalk_rw_N; m++) { + switch (m) { + case swalk_rwH: + Q = res->H[k]; + break; + case swalk_rwM: + Q = res->M[k]; + break; + case swalk_rwJ: + Q = res->J[k]; + break; + case swalk_rwR: + Q = res->R[k]; + break; + case swalk_rwC: + Q = res->C[k]; + break; + default: + util_Error ("swalk_RandomWalk1: no such case"); + } + if (swrite_Classes) { + if (L1 > L0) { + printf ("===============================================\n"); + printf ("Walk of %3ld steps\n", L0 + k); + } + printf ("===============================================\nThe "); + printf ("%s", swalk_rwName[m]); + printf ("\n"); + gofs_WriteClasses (Q->NbExp, Q->Loc, Q->jmin, Q->jmax, 0); + } + gofs_MergeClasses (Q->NbExp, Q->Loc, &(Q->jmin), &(Q->jmax), + &NbClasses); + + if (swrite_Classes) { + gofs_WriteClasses (Q->NbExp, Q->Loc, Q->jmin, Q->jmax, NbClasses); + } + + /* Set description for second level statistical collectors */ + sprintf (str, "The N statistic values (a ChiSquare with %ld degrees" + " of freedom) ", NbClasses - 1); + statcoll_SetDesc (Q->sVal1, str); + Q->degFree = NbClasses - 1; + } + } + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + + /* Reset counters to zero for each sequence */ + for (k = 0; k <= DeltaL; k += 2) { + for (i = res->H[k]->jmin; i <= res->H[k]->jmax; i++) + res->H[k]->Count[i] = 0; + for (i = res->R[k]->jmin; i <= res->R[k]->jmax; i++) + res->R[k]->Count[i] = 0; + for (i = res->J[k]->jmin; i <= res->J[k]->jmax; i++) + res->J[k]->Count[i] = 0; + for (i = res->M[k]->jmin; i <= res->M[k]->jmax; i++) + res->M[k]->Count[i] = 0; + for (i = res->C[k]->jmin; i <= res->C[k]->jmax; i++) + res->C[k]->Count[i] = 0; + } + + /* A ChiSquare sample of size n */ + for (Rep = 1; Rep <= n; Rep++) { + work.S = 0; + work.S_2 = 0; + work.M = 0; + work.R = 0; + work.J = 0; + work.C = 0; + res->L = 0; + + /* One random walk of length L */ + for (j = 1; j <= LDS; j++) + Steps (gen, res, j, r, s); + /* the last LMS steps of L */ + if (LMS > 0) + Steps (gen, res, LDS + 1, r, LMS); + } + + for (k = 0; k <= DeltaL; k += 2) { + khi = gofs_Chi2 (res->H[k]->NbExp, res->H[k]->Count, res->H[k]->jmin, + res->H[k]->jmax); + statcoll_AddObs (res->H[k]->sVal1, khi); + khi = gofs_Chi2 (res->M[k]->NbExp, res->M[k]->Count, res->M[k]->jmin, + res->M[k]->jmax); + statcoll_AddObs (res->M[k]->sVal1, khi); + khi = gofs_Chi2 (res->R[k]->NbExp, res->R[k]->Count, res->R[k]->jmin, + res->R[k]->jmax); + statcoll_AddObs (res->R[k]->sVal1, khi); + khi = gofs_Chi2 (res->J[k]->NbExp, res->J[k]->Count, res->J[k]->jmin, + res->J[k]->jmax); + statcoll_AddObs (res->J[k]->sVal1, khi); + khi = gofs_Chi2 (res->C[k]->NbExp, res->C[k]->Count, res->C[k]->jmin, + res->C[k]->jmax); + statcoll_AddObs (res->C[k]->sVal1, khi); + if (swrite_Counters) + WriteDetailsWalk (res, k, n); + } + } + + for (k = 0; k <= DeltaL; k += 2) { + for (m = 0; m < swalk_rw_N; m++) { + switch (m) { + case swalk_rwH: + Q = res->H[k]; + break; + case swalk_rwM: + Q = res->M[k]; + break; + case swalk_rwJ: + Q = res->J[k]; + break; + case swalk_rwR: + Q = res->R[k]; + break; + case swalk_rwC: + Q = res->C[k]; + break; + default: + util_Error ("swalk_RandomWalk1: no such case2"); + } + V[0] = Q->degFree; + Q->pVal1->NObs = Q->sVal1->NObs; + gofw_ActiveTests2 (Q->sVal1->V, Q->pVal1->V, N, wdist_ChiSquare, + V, Q->sVal2, Q->pVal2); + sres_GetChi2SumStat (Q); + } + } + + if (swrite_Basic) { + WriteResultWalk (res, N); + swrite_Final (gen, Timer); + } + if (localRes) + swalk_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataWalk1a (unif01_Gen *gen, char *TestName, + long N, long n, int r, int s, int t, long L, bitset_BitSet maskc) +{ + int i; + + swrite_Head (gen, TestName, N, n, r); + printf (", s = %1d, t = %1d, L = %1ld\n\n", s, t, L); + printf (" C = { "); + + util_Assert (t <= 31, "swalk_RandomWalk1a: t > 31"); + for (i = 0; i < t; i++) { + if (bitset_TestBit (maskc, i)) { + printf ("%1d", i); + if (i < t - 1) + printf (", "); + } + } + printf (" }\n\n\n"); +} + + +/*-------------------------------------------------------------------------*/ + +void swalk_RandomWalk1a (unif01_Gen *gen, swalk_Res *res, + long N, long n, int r, int s, int t, long L, bitset_BitSet maskc) +{ + swalk_rwType m; + long z2, z1, y; + long C, J, R, M, S_2, S, X; /* Statistics */ + long i, j, pas, Rep, Seq; /* Indices */ + bitset_BitSet ens; + double khi; /* ChiSquare value */ + double V[1]; /* Number deg. of freedom for ChiSquare */ + long NbClasses; + char str[LENGTH + 1]; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "swalk_RandomWalk1a test"; + sres_Chi2 *Q; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataWalk1a (gen, TestName, N, n, r, s, t, L, maskc); + + util_Assert (!(L & 1), "swalk_RandomWalk1a: L is odd"); + util_Assert (L > 0, "swalk_RandomWalk1a: L <= 0"); + util_Assert (r + s <= PREC, "swalk_RandomWalk1a: r + s > 32"); + util_Assert (s <= PREC, "swalk_RandomWalk1a: s > 32"); + if (n < 3.0 * gofs_MinExpected) { + util_Warning (TRUE, "swalk_RandomWalk1a: n < 3*gofs_MinExpected"); + return; + } + if (res == NULL) { + localRes = TRUE; + res = swalk_CreateRes (); + } + InitRes (res, NULL, N, L, L, "swalk_RandomWalk1a"); + + /* Compute the expected numbers */ + CalcNbExp (n, L, 0, res); + + /* Merge classes for the ChiSquare */ + for (m = 0; m < swalk_rw_N; m++) { + switch (m) { + case swalk_rwH: + Q = res->H[0]; + break; + case swalk_rwM: + Q = res->M[0]; + break; + case swalk_rwJ: + Q = res->J[0]; + break; + case swalk_rwR: + Q = res->R[0]; + break; + case swalk_rwC: + Q = res->C[0]; + break; + default: + util_Error ("swalk_RandomWalk1a: no such case"); + } + if (swrite_Classes) { + printf ("===============================================\nThe "); + printf ("%s", swalk_rwName[m]); + printf ("\n"); + gofs_WriteClasses (Q->NbExp, Q->Loc, Q->jmin, Q->jmax, 0); + } + gofs_MergeClasses (Q->NbExp, Q->Loc, &(Q->jmin), &(Q->jmax), &NbClasses); + + if (swrite_Classes) + gofs_WriteClasses (Q->NbExp, Q->Loc, Q->jmin, Q->jmax, NbClasses); + + /* Set description for second level statistical collectors */ + sprintf (str, "The N statistic values (a ChiSquare with %ld degrees of" + " freedom) ", NbClasses - 1); + statcoll_SetDesc (Q->sVal1, str); + Q->degFree = NbClasses - 1; + } + + /* Generate the first t bits */ + z1 = 0; + for (i = 0; i <= (t - 1) / s; i++) { + z2 = unif01_StripB (gen, r, s); + for (j = 1; j <= s; j++) { + z1 = 2 * z1 + (z2 & 1); + z2 /= 2; + } + } + j = 0; + z2 = unif01_StripB (gen, r, s); + + /* Beginning of test */ + for (Seq = 1; Seq <= N; Seq++) { + + /* Reset counters to zero for each sequence */ + for (i = res->H[0]->jmin; i <= res->H[0]->jmax; i++) + res->H[0]->Count[i] = 0; + for (i = res->R[0]->jmin; i <= res->R[0]->jmax; i++) + res->R[0]->Count[i] = 0; + for (i = res->J[0]->jmin; i <= res->J[0]->jmax; i++) + res->J[0]->Count[i] = 0; + for (i = res->M[0]->jmin; i <= res->M[0]->jmax; i++) + res->M[0]->Count[i] = 0; + for (i = res->C[0]->jmin; i <= res->C[0]->jmax; i++) + res->C[0]->Count[i] = 0; + + for (Rep = 1; Rep <= n; Rep++) { + C = J = R = M = S_2 = S = 0; + pas = 0; + + /* Generate a random walk of L steps */ + do { + do { + ++pas; + ++j; + z1 = 2 * z1 + (z2 & 1); + z2 /= 2; + ens = maskc & z1; + y = 0; + for (i = 0; i < t; i++) { + if (bitset_TestBit (ens, i)) + ++y; + } + if (y & 1) + X = 1; + else + X = -1; + S += X; + if (S > M) + M = S; + if (S == 0) + ++R; + if (pas & 1) { + if (S > 0) + ++J; + if (S * S_2 < 0) + ++C; + S_2 = S; + } + } while (!(j == s || pas == L)); + if (j == s) { + j = 0; + z2 = unif01_StripB (gen, r, s); + } + } while (pas != L); + + /* Update counters */ + ++res->H[0]->Count[res->H[0]->Loc[(L + S) / 2]]; + ++res->M[0]->Count[res->M[0]->Loc[M]]; + ++res->J[0]->Count[res->J[0]->Loc[2 * J]]; + ++res->R[0]->Count[res->R[0]->Loc[R]]; + ++res->C[0]->Count[res->C[0]->Loc[C]]; + } + + khi = gofs_Chi2 (res->H[0]->NbExp, res->H[0]->Count, res->H[0]->jmin, + res->H[0]->jmax); + statcoll_AddObs (res->H[0]->sVal1, khi); + khi = gofs_Chi2 (res->M[0]->NbExp, res->M[0]->Count, res->M[0]->jmin, + res->M[0]->jmax); + statcoll_AddObs (res->M[0]->sVal1, khi); + khi = gofs_Chi2 (res->R[0]->NbExp, res->R[0]->Count, res->R[0]->jmin, + res->R[0]->jmax); + statcoll_AddObs (res->R[0]->sVal1, khi); + khi = gofs_Chi2 (res->J[0]->NbExp, res->J[0]->Count, res->J[0]->jmin, + res->J[0]->jmax); + statcoll_AddObs (res->J[0]->sVal1, khi); + khi = gofs_Chi2 (res->C[0]->NbExp, res->C[0]->Count, res->C[0]->jmin, + res->C[0]->jmax); + statcoll_AddObs (res->C[0]->sVal1, khi); + + if (swrite_Counters) + WriteDetailsWalk (res, 0, n); + } + + for (m = 0; m < swalk_rw_N; m++) { + switch (m) { + case swalk_rwH: + Q = res->H[0]; + break; + case swalk_rwM: + Q = res->M[0]; + break; + case swalk_rwJ: + Q = res->J[0]; + break; + case swalk_rwR: + Q = res->R[0]; + break; + case swalk_rwC: + Q = res->C[0]; + break; + default: + util_Error ("swalk_RandomWalk1a: no such case2"); + } + V[0] = Q->degFree; + Q->pVal1->NObs = Q->sVal1->NObs; + gofw_ActiveTests2 (Q->sVal1->V, Q->pVal1->V, N, wdist_ChiSquare, V, + Q->sVal2, Q->pVal2); + sres_GetChi2SumStat (Q); + } + + if (swrite_Basic) { + WriteResultWalk (res, N); + swrite_Final (gen, Timer); + } + if (localRes) + swalk_DeleteRes (res); + chrono_Delete (Timer); +} + + +/*=========================================================================*/ + +static void WriteDataGeo (unif01_Gen *gen, char *TestName, + long N, long n, int r, double Mu, swalk_AlgoType Algo) +{ + swrite_Head (gen, TestName, N, n, r); + printf (", Mu = %10.8f, Algo = ", Mu); + if (Algo == swalk_AlgoP) + printf ("AlgoP\n\n"); + else + printf ("AlgoN\n\n"); + printf (" Expected length of a walk = %14.2f\n\n\n", 1.0 / (1.0 - Mu)); +} + + +/*-------------------------------------------------------------------------*/ + +static void WriteNbExpCount (sres_Chi2 *res, double Prob[]) +/* + * Writes the expected numbers, the observed numbers, and the normalized + * values in swalk_VarGeo. + */ +{ + long L; + double Ecart; + double y; + + printf ("--------------------------------------------------\n" + "Length NumExpected NumObserved Normalized value\n\n"); + for (L = res->jmin; L < res->jmax; L = res->Loc[L + 1]) { + printf ("%4ld %14.2f %10ld ", L, res->NbExp[L], res->Count[L]); + Ecart = sqrt (res->NbExp[L] * (1.0 - Prob[L])); + y = (res->Count[L] - res->NbExp[L]) / Ecart; + printf ("%14.2f\n", y); + } + L = res->jmax; + printf ("%4ld %14.2f %10ld ", L, res->NbExp[L], res->Count[L]); + Ecart = sqrt (res->NbExp[L] * (1.0 - Prob[L])); + y = (res->Count[L] - res->NbExp[L]) / Ecart; + printf ("%14.2f\n\n\n", y); +} + + +/*-------------------------------------------------------------------------*/ + +static void AlgorithmP (unif01_Gen *gen, sres_Chi2 *res, double Prob[], + long N, long n, int r, double Mu) +{ + long j; + long L; + long Seq; + double X; + double U; + + for (Seq = 1; Seq <= N; Seq++) { + for (L = res->jmin; L <= res->jmax; L++) + res->Count[L] = 0; + + for (j = 1; j <= n; j++) { + L = 1; + U = unif01_StripD (gen, r); + while (U < Mu) { + ++L; + U = unif01_StripD (gen, r); + } + if (L >= res->jmax) + ++res->Count[res->Loc[res->jmax]]; + else + ++res->Count[res->Loc[L]]; + } + if (swrite_Counters) + WriteNbExpCount (res, Prob); + + X = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X); + } +} + + +/*-------------------------------------------------------------------------*/ + +static void AlgorithmN (unif01_Gen *gen, sres_Chi2 *res, double Prob[], + long N, long n, int r, double Mu) +{ + long j; + long L; + long Seq; + double X; + double U; + + Mu = 1.0 - Mu; + for (Seq = 1; Seq <= N; Seq++) { + for (L = res->jmin; L <= res->jmax; L++) + res->Count[L] = 0; + + for (j = 1; j <= n; j++) { + L = 1; + U = unif01_StripD (gen, r); + while (U >= Mu) { + ++L; + U = unif01_StripD (gen, r); + } + if (L >= res->jmax) + ++res->Count[res->Loc[res->jmax]]; + else + ++res->Count[res->Loc[L]]; + } + if (swrite_Counters) + WriteNbExpCount (res, Prob); + + X = gofs_Chi2 (res->NbExp, res->Count, res->jmin, res->jmax); + statcoll_AddObs (res->sVal1, X); + } +} + + +/*-------------------------------------------------------------------------*/ + +static void swalk_VarGeo (unif01_Gen *gen, sres_Chi2 *res, + long N, long n, int r, double Mu, swalk_AlgoType Algo) +{ + const double epsilon = 1.0E-10; + long L; + double nLR = n; + double V[1]; /* Number degrees of freedom for ChiSquare */ + char str[LENGTH + 1]; + long tt; + long NbClasses; + lebool localRes = FALSE; + chrono_Chrono *Timer; + char *TestName = "swalk_VarGeo test"; + double *Prob; + + Timer = chrono_Create (); + if (swrite_Basic) + WriteDataGeo (gen, TestName, N, n, r, Mu, Algo); + + util_Assert (r < PREC, "swalk_VarGeo: r > 52"); + util_Assert (Mu > 0.0 && Mu < 1.0, "swalk_VarGeo: Mu not in (0,1)"); + + /* We consider only the terms of the geometric law with */ + /* probability > epsilon */ + tt = 1 + (log (epsilon) - num2_log1p (-Mu)) / log (Mu); + Prob = util_Calloc (1 + (size_t) tt, sizeof (double)); + + /* The probabilities and the expected numbers: NbExp = n*Prob */ + Prob[1] = 1.0 - Mu; + for (L = 1; L <= tt - 2; L++) + Prob[L + 1] = Mu * Prob[L]; + Prob[tt] = fbar_Geometric (1.0 - Mu, tt); + + if (res == NULL) { + localRes = TRUE; + res = sres_CreateChi2 (); + } + sres_InitChi2 (res, N, tt, "swalk_VarGeo"); + + for (L = 1; L <= tt; L++) + res->NbExp[L] = nLR * Prob[L]; + + res->jmin = 1; + res->jmax = tt; + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, res->Loc, res->jmin, res->jmax, 0); + gofs_MergeClasses (res->NbExp, res->Loc, &res->jmin, &res->jmax, + &NbClasses); + if (swrite_Classes) + gofs_WriteClasses (res->NbExp, res->Loc, res->jmin, res->jmax, + NbClasses); + + sprintf (str, "The N statistic values (a ChiSquare with %1ld degrees" + " of freedom):", NbClasses - 1); + statcoll_SetDesc (res->sVal1, str); + res->degFree = NbClasses - 1; + if (res->degFree < 1) { + if (localRes) + sres_DeleteChi2 (res); + return; + } + + if (Algo == swalk_AlgoP) + AlgorithmP (gen, res, Prob, N, n, r, Mu); + else + AlgorithmN (gen, res, Prob, N, n, r, Mu); + + V[0] = res->degFree; + res->pVal1->NObs = N; + gofw_ActiveTests2 (res->sVal1->V, res->pVal1->V, N, wdist_ChiSquare, V, + res->sVal2, res->pVal2); + sres_GetChi2SumStat (res); + + if (swrite_Collectors) + statcoll_Write (res->sVal1, 5, 14, 4, 3); + + if (swrite_Basic) { + swrite_AddStrChi (str, LENGTH, res->degFree); + gofw_WriteActiveTests2 (N, res->sVal2, res->pVal2, str); + swrite_Chi2SumTest (N, res); + swrite_Final (gen, Timer); + } + util_Free (Prob); + if (localRes) + sres_DeleteChi2 (res); + chrono_Delete (Timer); +} + + +/*-------------------------------------------------------------------------*/ + +void swalk_VarGeoP (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, double Mu) +{ + swalk_VarGeo (gen, res, N, n, r, Mu, swalk_AlgoP); +} + +/*-------------------------------------------------------------------------*/ + +void swalk_VarGeoN (unif01_Gen * gen, sres_Chi2 * res, + long N, long n, int r, double Mu) +{ + swalk_VarGeo (gen, res, N, n, r, Mu, swalk_AlgoN); +} diff --git a/cbits/testu/src/swrite.c b/cbits/testu/src/swrite.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/swrite.c @@ -0,0 +1,167 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: swrite.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "gdef.h" +#include "util.h" +#include "chrono.h" + +#include "swrite.h" +#include "unif01.h" +#include "gofw.h" + +#include +#include +#include + + + +#define LEN 100 + + +lebool swrite_Basic = TRUE; +lebool swrite_Parameters = FALSE; +lebool swrite_Collectors = FALSE; +lebool swrite_Counters = FALSE; +lebool swrite_Classes = FALSE; +lebool swrite_Others = FALSE; + +lebool swrite_Host = TRUE; + +char swrite_ExperimentName[LEN + 1] = ""; + + + +/*=========================================================================*/ + +void swrite_SetExperimentName (char Name[]) +{ + strncpy (swrite_ExperimentName, Name, (size_t) LEN); +} + + +/*=========================================================================*/ + +void swrite_Head (unif01_Gen *gen, char *TestName, long N, long n, int r) +{ + printf ("***********************************************************\n"); + printf ("HOST = "); + if (swrite_Host) { + gdef_WriteHostName (); + printf ("\n"); + } else + printf ("\n\n"); + util_Assert (gen != NULL, "No generator has been created"); + unif01_WriteNameGen (gen); + printf ("\n"); + if (swrite_ExperimentName && strcmp (swrite_ExperimentName, "")) { + printf ("%s", swrite_ExperimentName); + printf (":\n\n"); + } + printf ("%s", TestName); + printf (":\n-----------------------------------------------\n"); + printf (" N = %2ld, n = %2ld, r = %2d", N, n, r); + util_Assert (N > 0, " N <= 0"); + util_Assert (n > 0, " n <= 0"); + util_Assert (r >= 0, " r < 0"); +} + + +/*=========================================================================*/ + +void swrite_Final (unif01_Gen *gen, chrono_Chrono *Timer) +{ + printf ("-----------------------------------------------\n"); + printf ("CPU time used : "); + chrono_Write (Timer, chrono_hms); + printf ("\n"); + unif01_WriteState (gen); + printf ("\n\n\n"); +} + + +/*=========================================================================*/ + +void swrite_AddStrChi (char S[], int len, long d) +{ + char str[31]; + int j; + strncpy (S, "Number of degrees of freedom : ", len); + j = strlen (S); + util_Assert (len > j, "swrite_AddStrChi: len <= j"); + sprintf (str, "%4ld", d); + strncat (S, str, len - j); + j = strlen (S); + util_Assert (len > j, "swrite_AddStrChi *: len <= j"); + strncat (S, "\nChi-square statistic :", len - j); + S[len - 1] = '\0'; +} + + +/*=========================================================================*/ + +void swrite_NormalSumTest (long N, sres_Basic *res) +{ + if (N <= 1) + return; + printf ("Tests on the sum of all N observations\n"); + printf ("Standardized normal statistic :"); + gofw_Writep2 (res->sVal2[gofw_Sum]/sqrt((double)N), res->pVal2[gofw_Sum]); + printf ("Sample variance :"); + gofw_Writep2 (res->sVal2[gofw_Var], res->pVal2[gofw_Var]); +} + + +/*=========================================================================*/ +#define LENGTH 200 + +void swrite_Chi2SumTest (long N, sres_Chi2 *res) +{ + char str[LENGTH + 1]; + if (N <= 1) + return; + printf ("Test on the sum of all N observations\n"); + swrite_AddStrChi (str, LENGTH, N*res->degFree); + gofw_Writep2 (res->sVal2[gofw_Sum], res->pVal2[gofw_Sum]); +} + + +/*=========================================================================*/ + +void swrite_Chi2SumTestb (long N, double sval, double pval, long degFree) +{ + char str[LENGTH + 1]; + if (N <= 1) + return; + printf ("Test on the sum of all N observations\n"); + swrite_AddStrChi (str, LENGTH, N*degFree); + gofw_Writep2 (sval, pval); +} + diff --git a/cbits/testu/src/tables.c b/cbits/testu/src/tables.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/tables.c @@ -0,0 +1,504 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: tables.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + + +#include "tables.h" +#include "util.h" +#include "mystr.h" +#include "num.h" + +#include +#include +#include +#include + + + + + + +tables_StyleType Style = tables_Plain; + +static char OuvrantMat = ' '; /* Matrix delimitors */ +static char FermantMat = ' '; + +static char OuvrantVec = ' '; /* Vector delimitors */ +static char FermantVec = ' '; + +static char SepareVec = ' '; /* Element separators */ +static char SepareElem = ' '; + +#define MaxInd 60 +static long HacheTab[MaxInd + 1] = { + 8191, 12109, 16381, 24373, 32749, 48871, 65521, 97777, 131071, 195659, + 262139, 393203, 524287, 786407, 1048573, 1572803, 2097143, 2500097, + 3145711, 3600097, 4194301, 5300003, 6291403, 7300003, 8388593, 9500021, + 10500013, 11500003, 12582917, 13500007, 14500001, 15500011, 16777213, + 17500013, 18500017, 19500101, 20500097, 21300101, 22200001, + 23200097, 24200101, 25165807, 28000097, 30000001, 33554393, 39000001, + 45000097, 50331653, 55000013, 61000001, 67108859, 76000091, 85000007, + 94906247, 134217689, 189812501, 268435399, 379625003, 2147483647, -1 +}; + + +long **tables_CreateMatrixL (int N, int M) +{ + int i; + long **T1; + /* Note: the memory must be allocated in a contiguous way for the matrix + to be later used properly, without problems. Source: comp.lang.c - + Answers to Frequently Asked Questions + http://www.faqs.org/faqs/C-faq/faq/ Questions 6.18, 6.19, 6.20 */ + + T1 = (long **) util_Malloc (N * sizeof (long *)); + T1[0] = (long *) util_Malloc (N * M * sizeof (long)); + for (i = 1; i < N; i++) + T1[i] = T1[0] + i * M; + return T1; +} + + +unsigned long **tables_CreateMatrixUL (int N, int M) +{ + int i; + unsigned long **T3; + + T3 = (unsigned long **) util_Malloc (N * sizeof (unsigned long *)); + T3[0] = (unsigned long *) util_Malloc (N * M * sizeof (unsigned long)); + for (i = 1; i < N; i++) + T3[i] = T3[0] + i * M; + return T3; +} + + +double **tables_CreateMatrixD (int N, int M) +{ + int i; + double **T2; + + T2 = (double **) util_Malloc (N * sizeof (double *)); + T2[0] = (double *) util_Malloc (N * M * sizeof (double)); + for (i = 1; i < N; i++) + T2[i] = T2[0] + i * M; + return T2; +} + + +void tables_DeleteMatrixL (long ***T) +{ + free ((*T)[0]); + free (*T); + *T = NULL; +} + +void tables_DeleteMatrixUL (unsigned long ***T) +{ + free ((*T)[0]); + free (*T); + *T = NULL; +} + +void tables_DeleteMatrixD (double ***T) +{ + free ((*T)[0]); + free (*T); + *T = NULL; +} + + +void tables_CopyTabD (double T1[], double T2[], int n1, int n2) +{ + int i; + for (i = n1; i <= n2; i++) { + T2[i] = T1[i]; + } +} + +void tables_CopyTabL (long T1[], long T2[], int n1, int n2) +{ + int i; + for (i = n1; i <= n2; i++) { + T2[i] = T1[i]; + } +} + +void tables_QuickSortD (double T[], int l, int r) + /* On trie le tableau des observations T[l..r]. */ +{ + int j; /* Indices dans le tableau Tab. */ + int i; + double w; + double x; + i = l; + j = r; + x = T[(l + r) / 2]; + do { + while (T[i] < x) + ++i; + while (x < T[j]) + --j; + if (i <= j) { + w = T[i]; + T[i] = T[j]; + T[j] = w; + ++i; + --j; + } + } while (i <= j); + if (l < j) + tables_QuickSortD (T, l, j); + if (i < r) + tables_QuickSortD (T, i, r); +} + + +void tables_QuickSortL (long T[], int l, int r) + /* On trie le tableau des observations T[l..r]. */ +{ + int j; /* Indices dans le tableau Tab. */ + int i; + long w; + long x; + i = l; + j = r; + x = T[(l + r) / 2]; + do { + while (T[i] < x) + ++i; + while (x < T[j]) + --j; + if (i <= j) { + w = T[i]; + T[i] = T[j]; + T[j] = w; + ++i; + --j; + } + } while (i <= j); + if (l < j) + tables_QuickSortL (T, l, j); + if (i < r) + tables_QuickSortL (T, i, r); +} + + +/*=======================================================================*/ +#ifdef USE_LONGLONG + +void tables_QuickSortLL (longlong T[], int l, int r) +{ + int j; + int i; + longlong w; + longlong x; + i = l; + j = r; + x = T[(l + r) / 2]; + do { + while (T[i] < x) + ++i; + while (x < T[j]) + --j; + if (i <= j) { + w = T[i]; + T[i] = T[j]; + T[j] = w; + ++i; + --j; + } + } while (i <= j); + if (l < j) + tables_QuickSortLL (T, l, j); + if (i < r) + tables_QuickSortLL (T, i, r); +} + +void tables_QuickSortULL (ulonglong T[], int l, int r) +{ + int j; + int i; + ulonglong w; + ulonglong x; + i = l; + j = r; + x = T[(l + r) / 2]; + do { + while (T[i] < x) + ++i; + while (x < T[j]) + --j; + if (i <= j) { + w = T[i]; + T[i] = T[j]; + T[j] = w; + ++i; + --j; + } + } while (i <= j); + if (l < j) + tables_QuickSortULL (T, l, j); + if (i < r) + tables_QuickSortULL (T, i, r); +} + +#endif +/*=======================================================================*/ + +void tables_WriteTabL (long V[], int n1, int n2, int k, int p, char Desc[]) +{ + int i; + printf ("---------------------------------------\n"); + printf ("%s\n", Desc); + if (k > 1) { + printf ("Elements %d to %d\n\n", n1, n2); + for (i = n1; i <= n2; i++) { + printf ("%*ld ", p, V[i]); + if (((i + 1 - n1) % k) == 0) + printf ("\n"); + } + printf ("\n"); + } else { + printf ("\n Index Element\n"); + for (i = n1; i <= n2; i++) + printf ("%6d %12ld\n", i, V[i]); + } + printf ("\n"); +} + + +void tables_WriteTabD (double V[], int n1, int n2, int k, int p1, + int p2, int p3, char Desc[]) +{ + int i; + printf ("---------------------------------------\n"); + printf ("%s\n", Desc); + if (k > 1) { + printf ("Elements %d to %d\n\n", n1, n2); + for (i = n1; i <= n2; i++) { + /* printf ("%*.*G", p1, p2, V[i]); */ + num_WriteD (V[i], p1, p2, p3); + if (((i + 1 - n1) % k) == 0) + printf ("\n"); + } + printf ("\n"); + } else { + printf ("\n Index Element\n"); + for (i = n1; i <= n2; i++) { + printf ("%6d", i); + num_WriteD (V[i], p1, p2, p3); + printf ("\n"); + } + } + printf ("\n"); +} + + +/*=========================================================================*/ +#ifdef USE_LONGLONG + +void tables_WriteTabLL (longlong V[], int n1, int n2, int k, int p, + char Desc[]) +{ + int i; + printf ("---------------------------------------\n"); + printf ("%s\n", Desc); + if (k > 1) { + printf ("Elements %d to %d\n\n", n1, n2); + for (i = n1; i <= n2; i++) { + printf (" %*" PRIdLEAST64, p, V[i]); + if (((i + 1 - n1) % k) == 0) + printf ("\n"); + } + printf ("\n"); + } else { + printf ("\n Index Element\n"); + for (i = n1; i <= n2; i++) + printf ("%6d %12" PRIdLEAST64 "\n", i, V[i]); + } + printf ("\n"); +} + +void tables_WriteTabULL (ulonglong V[], int n1, int n2, int k, int p, + char Desc[]) +{ + int i; + printf ("---------------------------------------\n"); + printf ("%s\n", Desc); + if (k > 1) { + printf ("Elements %d to %d\n\n", n1, n2); + for (i = n1; i <= n2; i++) { + printf (" %*" PRIuLEAST64, p, V[i]); + if (((i + 1 - n1) % k) == 0) + printf ("\n"); + } + printf ("\n"); + } else { + printf ("\n Index Element\n"); + for (i = n1; i <= n2; i++) + printf ("%6d %12" PRIuLEAST64 "\n", i, V[i]); + } + printf ("\n"); +} + +#endif +/*=========================================================================*/ + + +static void FixeDelim (tables_StyleType style) +{ + /* Fixe les delimiteurs pour imprimer une matrice selon un format + approprie */ + Style = style; + switch (style) { + case tables_Mathematica: + OuvrantMat = '{'; + FermantMat = '}'; + OuvrantVec = '{'; + FermantVec = '}'; + SepareVec = ','; + SepareElem = ','; + break; + case tables_Matlab: + OuvrantMat = '['; + FermantMat = ']'; + OuvrantVec = ' '; + FermantVec = ' '; + SepareVec = ' '; + SepareElem = ' '; + break; + default: + OuvrantMat = ' '; + FermantMat = ' '; + OuvrantVec = ' '; + FermantVec = ' '; + SepareVec = ' '; + SepareElem = ' '; + break; + } +} + + +void tables_WriteMatrixL (long **Mat, int i1, int i2, int j1, int j2, + int w, tables_StyleType style, char Nom[]) +{ + int i; + int j; + + FixeDelim (style); + if (strlen (Nom) > 0) { + printf ("%s = ", Nom); + } + printf ("%c\n", OuvrantMat); + for (i = i1; i <= i2; i++) { + printf ("%c", OuvrantVec); + for (j = j1; j <= j2; j++) { + printf ("%*ld", (int) w, Mat[i][j]); + if (j < j2) + printf ("%c", SepareElem); + } + printf ("%c", FermantVec); + if (i < i2) + printf ("%c\n", SepareVec); + } + printf ("%c\n\n", FermantMat); +} + + +void tables_WriteMatrixD (double **Mat, int i1, int i2, int j1, int j2, + int w, int p, tables_StyleType style, char Nom[]) +{ + int k; + int m; + int j; + int i; + unsigned int bidon; + double prec; + double x; + int trouve; + char S[32]; + + FixeDelim (style); + if (strlen (Nom) > 0) { + printf ("%s = ", Nom); + } + prec = pow (10.0, (double) p); + printf ("%c\n", OuvrantMat); + for (i = i1; i <= i2; i++) { + printf ("%c", OuvrantVec); + for (j = j1; j <= j2; j++) { + printf (" "); + switch (style) { + case tables_Mathematica: + x = Mat[i][j]; + if (((x != 0.0) && (fabs (x) < 0.1)) || (fabs (x) > prec)) { + sprintf (S, "%.*G", (int) p, x); + /* automatique avec %G ... : myst_Subst(S, "e", "E"); */ + mystr_Position ("E", S, 0, &bidon, &trouve); + if (trouve) { + mystr_Subst (S, "E", "*10^("); + strncat (S, ")", (size_t) 2); + } + } else + sprintf (S, "%.*f", (int) p, x); + m = (int) strlen (S); + for (k = 1; k <= w - m; k++) { + printf (" "); + } + printf ("%s", S); + break; + default: + /* tables_Matlab, Default */ + printf ("%*.*G", (int) w, (int) p, Mat[i][j]); + break; + } + if (j < j2) + printf ("%c", SepareElem); + } + printf ("%c", FermantVec); + if (i < i2) + printf ("%c\n", SepareVec); + } + printf ("%c\n\n", FermantMat); +} + +long tables_HashPrime (long n, double load) +{ + int i; + double nD; + util_Assert (n > 0, "tables_HashPrime : n <= 0"); + nD = (double) n; + i = 1; + while (i < MaxInd && HacheTab[i] < n) + ++i; + while (i < MaxInd && load * (double) (HacheTab[i]) < nD) + ++i; + util_Assert (HacheTab[i] > 0, "tables_HashPrime failed"); + return HacheTab[i]; +} diff --git a/cbits/testu/src/ufile.c b/cbits/testu/src/ufile.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/ufile.c @@ -0,0 +1,371 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: ufile.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "gdef.h" +#include "util.h" +#include "ufile.h" +#include "unif01.h" + +#include +#include +#include + +/* Length of strings */ +#define LEN 200 + +#define NORM32 2.3283064365386962E-10 /* 1 / 2^32 */ + +#define ARRAYDIM 1048576 /* = 2^20 */ + + + + +/*========================== module variables ============================*/ + +static char S[LEN + 1]; + +static FILE *f1, *f2; + +static int co1 = 0, co2 = 0; /* Counters */ + +/* X1 will contain the numbers read from a text input file */ +static double *X1 = NULL; + +/* X2 will keep the bytes read from a binary input file */ +static unsigned char *X2 = NULL; + +static unsigned long n1, n2, /* Current index of tables */ + MaxBin, MaxText, /* Maximal index in the tables */ + Dim1, Dim2; /* Dimension of tables */ + +static double NBin, NText; /* Number of calls to the generator */ + + + +/*========================================================================*/ + +static void WrReadText (void *junk) +{ + printf (" %.0f numbers have been read\n", NText); +} + +/*-----------------------------------------------------------------------*/ + +static void FillTextArray (void) +/* + * Read numbers (double's) until end of file or until Dim1 (dimension of + * array X1) numbers have been read. + */ +/* + * The standard function setvbuf could be used here to increase the + * speed of reading. Right now, we use default system buffering. + */ +{ + unsigned long i; + + MaxText = Dim1; + i = 0; + while ((i < Dim1) && (fscanf (f1, " %lf", (X1 + i)) == 1)) + ++i; + + if (i < MaxText) + /* The numbers do not fill the whole array: EOF or Error */ + MaxText = i; + + n1 = 0; +} + +/*-----------------------------------------------------------------------*/ + +static double ReadText_U01 (void *junk1, void *junk2) +/* + * Return the n-th element of the array. If at end of array, call + * FillTextArray to fill the array once again, and then return the + * first element. + */ +{ + if (n1 < MaxText) { + NText += 1.0; + return X1[n1++]; + + } else if (MaxText == Dim1) { + FillTextArray (); + NText += 1.0; + return X1[n1++]; + + } else { + X1 = util_Free (X1); + util_Fclose (f1); + sprintf (S, "%.0f numbers have been read.\n", NText); + strncat (S, "End-of-file detected.\n", (size_t) 25); + strncat (S, "Not enough numbers in file for these test parameters.", + (size_t) 60); + util_Error (S); + return -1.0; + } +} + +/*-----------------------------------------------------------------------*/ + +static unsigned long ReadText_Bits (void *vpar, void *vsta) +{ + return (unsigned long) (ReadText_U01 (vpar, vsta) * unif01_NORM32); +} + +/*-----------------------------------------------------------------------*/ + +unif01_Gen * ufile_CreateReadText (char *A, long dim) +{ + unif01_Gen *gen; + size_t leng; + char name[LEN + 1]; + + util_Assert (dim > 0, "ufile_CreateReadText: nbuf <= 0."); + util_Assert (co1 == 0, + "ufile_CreateReadText: only 1 generator at a time can be in use"); + co1++; + + gen = util_Malloc (sizeof (unif01_Gen)); + + strncpy (name, "ufile_CreateReadText: ", (size_t) LEN); + strncat (name, A, (size_t) (LEN - 30)); + leng = strlen (name); + gen->name = util_Calloc (leng + 1, sizeof (char)); + strncpy (gen->name, name, leng); + + f1 = util_Fopen (A, "r"); + Dim1 = util_Min (ARRAYDIM, dim); + MaxText = Dim1; + X1 = util_Calloc ((size_t) Dim1, sizeof (double)); + gen->GetBits = &ReadText_Bits; + gen->GetU01 = &ReadText_U01; + gen->Write = &WrReadText; + gen->param = NULL; + gen->state = NULL; + FillTextArray (); + NText = 0; + return gen; +} + +/*-----------------------------------------------------------------------*/ + +void ufile_DeleteReadText (unif01_Gen *gen) +{ + X1 = util_Free (X1); + util_Fclose (f1); + gen->name = util_Free (gen->name); + util_Free (gen); + co1--; +} + + +/*-----------------------------------------------------------------------*/ + +void ufile_InitReadText (void) +{ + int j = 0; + util_Assert (NULL != f1, "ufile_InitReadText: unable to read from file"); + if (NText > Dim1) { + j = fseek (f1, 0L, SEEK_SET); + util_Assert (0 == j, "ufile_InitReadText: file rewind failed"); + FillTextArray (); + } + NText = n1 = 0; +} + + +/*========================================================================*/ + +static void FillBinArray (void) +/* + * Read bits, at most Dim2 bytes. + */ +{ + MaxBin = fread (X2, (size_t) 1, (size_t) Dim2, f2); + n2 = 0; +} + +/*-----------------------------------------------------------------------*/ + +static unsigned long ReadBin_Bits (void *vpar, void *vsta) +/* + * Return the n-th element of the array. If at end of the array, call + * FillBinArray to fill the array once again, and then return the first + * element. Each number uses 32 bits in big-endian form: the first byte + * makes the most significant bits, and the fourth one makes the least + * significant. + */ +{ + unsigned long u; + + if (n2 < MaxBin) { + u = (unsigned long) X2[n2++] << 24; + u |= (unsigned long) X2[n2++] << 16; + u |= (unsigned long) X2[n2++] << 8; + u |= (unsigned long) X2[n2++]; + NBin += 1.0; + return u; + + } else if (MaxBin == Dim2) { + FillBinArray (); + return ReadBin_Bits (vpar, vsta); + + } else { + X2 = util_Free (X2); + util_Fclose (f2); + f2 = NULL; + sprintf (S, "%.0f bits have been read.\n", NBin * 32.0); + strncat (S, "End-of-file detected.\n", (size_t) 25); + strncat (S, "Not enough bits in file for these test parameters.", + (size_t) 53); + util_Error (S); + return 0; + } +} + +/*-----------------------------------------------------------------------*/ + +static double ReadBin_U01 (void *vpar, void *vsta) +{ + return ReadBin_Bits (vpar, vsta) * NORM32; +} + +/*-----------------------------------------------------------------------*/ + +static void WrReadBin (void *junk) +{ + printf (" %.0f bits have been read.\n", NBin * 32.0); +} + +/*-----------------------------------------------------------------------*/ + +unif01_Gen * ufile_CreateReadBin (char *A, long dim) +{ + unif01_Gen *gen; + size_t leng; + char name[LEN + 1]; + + util_Assert (dim > 0, "ufile_CreateReadBin: nbuf <= 0."); + util_Assert (co2 == 0, + "ufile_CreateReadBin: only 1 generator at a time can be in use"); + co2++; + + gen = util_Malloc (sizeof (unif01_Gen)); + + strncpy (name, "ufile_CreateReadBin: ", (size_t) LEN); + strncat (name, A, (size_t) LEN - 30); + leng = strlen (name); + gen->name = util_Calloc (leng + 1, sizeof (char)); + strncpy (gen->name, name, leng); + + f2 = util_Fopen (A, "rb"); + + /* Each random number will be built of 32 bits = 4 bytes */ + Dim2 = util_Min (ARRAYDIM, 4*dim); + X2 = util_Calloc ((size_t) Dim2, sizeof (unsigned char)); + FillBinArray (); + NBin = 0; + + gen->GetBits = &ReadBin_Bits; + gen->GetU01 = &ReadBin_U01; + gen->Write = &WrReadBin; + gen->param = NULL; + gen->state = NULL; + return gen; +} + +/*-----------------------------------------------------------------------*/ + +void ufile_DeleteReadBin (unif01_Gen *gen) +{ + X2 = util_Free (X2); + util_Fclose (f2); + gen->name = util_Free (gen->name); + util_Free (gen); + co2--; +} + + +/*-----------------------------------------------------------------------*/ + +void ufile_InitReadBin (void) +{ + int j = 0; + util_Assert (NULL != f2, "ufile_InitReadBin: unable to read from file"); + if (NBin >= Dim2 / 4) { + j = fseek (f2, 0L, SEEK_SET); + util_Assert (0 == j, "ufile_InitReadBin: file rewind failed"); + FillBinArray (); + } + NBin = n2 = 0; +} + + +/*========================================================================*/ + +void ufile_Gen2Bin (unif01_Gen *gen, char *fname, double nbits, + int r, int s) +{ + unsigned long Z; + unsigned long i, n; + unsigned char buffer[4]; + FILE *f; + int k; + const int KMAX = s / 8; + int status; + + util_Assert (nbits > 0.0, "ufile_Gen2Bin: nbits <= 0"); + util_Assert (r >= 0, "ufile_Gen2Bin: r < 0"); + util_Assert (s % 8 == 0, + "ufile_Gen2Bin: s must be in { 8, 16, 24, 32 }"); + util_Assert (nbits / s <= ULONG_MAX, + "ufile_Gen2Bin: nbits is too large"); + + n = 0.5 + nbits / s; + if (n * (double) s < nbits) + n++; + f = util_Fopen (fname, "wb"); + + for (i = 0; i < n; i++) { + Z = unif01_StripB (gen, r, s); + for (k = KMAX - 1; k >= 0; k--) { + buffer[k] = Z & 0xFF; + Z >>= 8; + } + status = fwrite (buffer, (size_t) 1, (size_t) KMAX, f); + if (status != KMAX) { + perror ("ufile_Gen2Bin: fwrite"); + exit (EXIT_FAILURE); + } + } + + util_Fclose (f); +} + diff --git a/cbits/testu/src/unif01.c b/cbits/testu/src/unif01.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/unif01.c @@ -0,0 +1,1472 @@ +/*************************************************************************\ + * + * Package: TestU01 + * File: unif01.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "gdef.h" +#include "util.h" +#include "num.h" +#include "chrono.h" +#include "swrite.h" +#include "unif01.h" + +#include +#include +#include +#include + + +#define LEN0 500 /* Length of strings */ +#define LEN1 100 /* Length of strings */ + +#define MASK32 0xffffffffUL /* 2^32 - 1 */ + + + + +/*------------------------- extern variables ------------------------------*/ + +lebool unif01_WrLongStateFlag = FALSE; + + + + + +/* ========================== functions ================================== */ + +void unif01_WriteNameGen (unif01_Gen *gen) +{ + if (gen->name) + printf ("%s\n\n", gen->name); +} + +void unif01_WriteState (unif01_Gen *gen) +{ + printf ("\nGenerator state:\n"); + gen->Write (gen->state); + printf ("\n"); +} + +void unif01_WrLongStateDef (void) +{ + printf (" Not shown here ... takes too much space\n"); +} + + +/**************************************************************************/ + +double unif01_StripD (unif01_Gen *gen, int r) +{ + if (r == 0) { + return (gen->GetU01) (gen->param, gen->state); + } else { + double u = num_TwoExp[r] * (gen->GetU01) (gen->param, gen->state); + return (u - (long) u); + } +} + +long unif01_StripL (unif01_Gen *gen, int r, long d) +{ + if (r == 0) + return (long) (d * gen->GetU01 (gen->param, gen->state)); + else { + double u = num_TwoExp[r] * (gen->GetU01) (gen->param, gen->state); + return (long) (d * (u - (long) u)); + } +} + +unsigned long unif01_StripB (unif01_Gen *gen, int r, int s) +{ + if (r == 0) { + return gen->GetBits (gen->param, gen->state) >> (32 - s); + } else { + unsigned long u = gen->GetBits (gen->param, gen->state); + return ((u << r) & MASK32) >> (32 - s); + } +} + + +/*************************************************************************/ + +/* Dummy generator, always return 0. */ + +static double DummyGen_U01 (void *param, void *state) +{ + return 0.0; +} + +static unsigned long DummyGen_Bits (void *param, void *state) +{ + return 0; +} + +static void WrDummyGen (void *junk) +{ + printf (" Empty Generator (no state)\n"); +} + +unif01_Gen * unif01_CreateDummyGen (void) +{ + unif01_Gen *gen; + size_t len; + + gen = util_Malloc (sizeof (unif01_Gen)); + len = strlen ("Dummy generator that always returns 0"); + gen->name = util_Calloc (len + 1, sizeof (char)); + strncpy (gen->name, "Dummy generator that always returns 0", len); + gen->param = NULL; + gen->state = NULL; + gen->Write = &WrDummyGen; + gen->GetBits = &DummyGen_Bits; + gen->GetU01 = &DummyGen_U01; + return gen; +} + +void unif01_DeleteDummyGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->name = util_Free (gen->name); + util_Free (gen); +} + +void unif01_DeleteGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->state = util_Free (gen->state); + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/**************************************************************************/ +/* + * The original generator is gen0. The position of the bit at which the + * increased precision is applied is s, counting from the most significant + * bit; v = 1 / 2^s. + */ +typedef struct { + unif01_Gen *gen0; + double v; + int s; +} DoubleGen_param; + + +static double DoubleGen_U01 (void *vpar, void *junk) +{ + double U; + DoubleGen_param *paramD = vpar; + unif01_Gen *gen = paramD->gen0; + + U = gen->GetU01 (gen->param, gen->state); + U += paramD->v * gen->GetU01 (gen->param, gen->state); + if (U < 1.0) + return U; + else + return U - 1.0; +} + +static unsigned long DoubleGen_Bits (void *vpar, void *junk) +{ + return (unsigned long) (unif01_NORM32 * DoubleGen_U01 (vpar, junk)); +} + + +unif01_Gen * unif01_CreateDoubleGen2 (unif01_Gen *gen, double v) +{ + unif01_Gen *genD; + DoubleGen_param *paramD; + char *name; + char str[20]; + size_t len, len2, len3; + + util_Assert (v > 0.0, "unif01_CreateDoubleGen2: h <= 0"); + util_Assert (v < 1.0, "unif01_CreateDoubleGen2: h >= 1"); + genD = util_Malloc (sizeof (unif01_Gen)); + paramD = util_Malloc (sizeof (DoubleGen_param)); + paramD->s = -num_Log2(v); + paramD->v = v; + paramD->gen0 = gen; + + len = strlen (gen->name); + len2 = strlen ("\nunif01_CreateDoubleGen2 with h = "); + len += len2; + sprintf (str, "%-g", v); + len3 = strlen (str); + len += len3; + name = util_Calloc (len + 1, sizeof (char)); + strncpy (name, gen->name, len); + strncat (name, "\nunif01_CreateDoubleGen2 with h = ", len2); + strncat (name, str, len3); + + /* The state of the double generator is simply the state of the original + generator */ + genD->name = name; + genD->param = paramD; + genD->state = gen->state; + genD->Write = gen->Write; + genD->GetBits = &DoubleGen_Bits; + genD->GetU01 = &DoubleGen_U01; + return genD; +} + +unif01_Gen * unif01_CreateDoubleGen (unif01_Gen *gen, int s) +{ + unif01_Gen *genD; + DoubleGen_param *paramD; + char *name; + char str[8]; + size_t len, len2, len3; + + util_Assert (s > 0, "unif01_CreateDoubleGen: s <= 0"); + genD = unif01_CreateDoubleGen2 (gen, 1.0 / num_TwoExp[s]); + paramD = genD->param; + paramD->s = s; + + len = strlen (gen->name); + len2 = strlen ("\nunif01_CreateDoubleGen with s = "); + len += len2; + sprintf (str, "%-d", paramD->s); + len3 = strlen (str); + len += len3; + name = util_Calloc (len + 1, sizeof (char)); + strncpy (name, gen->name, len); + strncat (name, "\nunif01_CreateDoubleGen with s = ", len2); + strncat (name, str, len3); + genD->name = name; + return genD; +} + +void unif01_DeleteDoubleGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/**************************************************************************/ + +typedef struct { + unif01_Gen *gen0; /* Original generator */ + long *ILac; /* Table of lacunary indices */ + int k; /* Size of ILac */ + int cur; /* Current index in the table */ + long n; +} LacGen_param; + +static double LacGen_U01 (void *vpar, void *junk) +{ + LacGen_param *paramL = vpar; + unif01_Gen *gen = paramL->gen0; + int cur = paramL->cur; + long *ILac = paramL->ILac; + long j; +#if 1 + if (cur > 0) { + for (j = 2; j <= ILac[cur] - ILac[cur - 1]; j++) + gen->GetU01 (gen->param, gen->state); + } else { + for (j = 0; j < ILac[0]; j++) + gen->GetU01 (gen->param, gen->state); + } + cur++; + if (cur >= paramL->k) + cur = 0; + paramL->cur = cur; + +#else + /* For debugging: write the lacunary indices of the random numbers outputted */ + if (cur > 0) { + for (j = 2; j <= ILac[cur] - ILac[cur - 1]; j++) { + gen->GetU01 (gen->param, gen->state); + paramL->n++; + } + } else { + for (j = 0; j < ILac[0]; j++) { + gen->GetU01 (gen->param, gen->state); + paramL->n++; + } + } + cur++; + if (cur >= paramL->k) + cur = 0; + paramL->cur = cur; + printf ("Lac = %ld\n", paramL->n); + paramL->n++; +#endif + + return gen->GetU01 (gen->param, gen->state); +} + +static unsigned long LacGen_Bits (void *vpar, void *junk) +{ + LacGen_param *paramL = vpar; + unif01_Gen *gen = paramL->gen0; + int cur = paramL->cur; + long *ILac = paramL->ILac; + long j; + + if (cur > 0) { + for (j = 2; j <= ILac[cur] - ILac[cur - 1]; j++) + gen->GetBits (gen->param, gen->state); + } else { + for (j = 0; j < ILac[0]; j++) + gen->GetBits (gen->param, gen->state); + } + cur++; + if (cur >= paramL->k) + cur = 0; + paramL->cur = cur; + return gen->GetBits (gen->param, gen->state); +} + +unif01_Gen * unif01_CreateLacGen (unif01_Gen *gen, int k, long I[]) +{ + unif01_Gen *genL; + LacGen_param *paramL; + char name[LEN0 + 1] = ""; + char str[16]; + size_t len, len2; + int j; + + genL = util_Malloc (sizeof (unif01_Gen)); + paramL = util_Malloc (sizeof (LacGen_param)); + paramL->gen0 = gen; + paramL->k = k; + paramL->cur = 0; + paramL->n = 0; + paramL->ILac = util_Calloc ((size_t) k, sizeof (long)); + for (j = 0; j < k; j++) + paramL->ILac[j] = I[j]; + + len = strlen (gen->name); + strncpy (name, gen->name, len); + len2 = strlen ("\nunif01_CreateLacGen with k = "); + len += len2; + strncat (name, "\nunif01_CreateLacGen with k = ", len2); + sprintf (str, "%-d", k); + strncat (name, str, 16); + strncat (name, ", I = (", 8); + + for (j = 0; j < k; j++) { + sprintf (str, "%-ld", I[j]); + strncat (name, str, 16); + if (j < k - 1) + strncat (name, ", ", 2); + else + strncat (name, ")", 1); + } + + len = strlen (name); + genL->name = util_Calloc (1 + len, sizeof (char)); + strncpy (genL->name, name, len); + + /* The state of the lacunary generator is simply the state of the original + generator */ + genL->param = paramL; + genL->state = gen->state; + genL->Write = gen->Write; + genL->GetBits = &LacGen_Bits; + genL->GetU01 = &LacGen_U01; + return genL; +} + +void unif01_DeleteLacGen (unif01_Gen *gen) +{ + LacGen_param *param; + if (NULL == gen) return; + param = gen->param; + param->ILac = util_Free (param->ILac); + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/**************************************************************************/ + +typedef struct { + unif01_Gen *gen0; /* The original generator */ + double R; /* Total probability over [0, a) */ + double S; /* (R - a) / (1 - a) */ + double invp; /* Inverse of probability density over [0, a) */ + double invq; /* Inverse of probability density over [a, 1) */ +} BiasGen_param; + + +static double BiasGen_U01 (void *vpar, void *junk) +{ + double U; + BiasGen_param *paramB = vpar; + unif01_Gen *gen = paramB->gen0; + + U = gen->GetU01 (gen->param, gen->state); + if (U < paramB->R) + return (U * paramB->invp); + else + return (U - paramB->S) * paramB->invq; +} + + +static unsigned long BiasGen_Bits (void *vpar, void *junk) +{ + return (unsigned long) (unif01_NORM32 * BiasGen_U01 (vpar, junk)); +} + + +unif01_Gen * unif01_CreateBiasGen (unif01_Gen *gen, double a, double R) +{ + const double Epsilon = 2.0E-16; + unif01_Gen *genB; + BiasGen_param *paramB; + double p; /* probability density over [0, a) */ + double q; /* probability density over [a, 1) */ + char name[LEN0 + 1] = ""; + char str[16]; + size_t len; + + util_Assert (R >= 0.0 && R <= 1.0, + "unif01_CreateBiasGen: P must be in [0, 1]"); + util_Assert (a > 0.0 && a < 1.0, + "unif01_CreateBiasGen: a must be in (0, 1)"); + + genB = util_Malloc (sizeof (unif01_Gen)); + paramB = util_Malloc (sizeof (BiasGen_param)); + paramB->gen0 = gen; + + p = R / a; + q = (1.0 - R) / (1.0 - a); + if (p < Epsilon) + paramB->invp = 0.0; + else + paramB->invp = 1.0 / p; + if (q < Epsilon) + paramB->invq = 0.0; + else + paramB->invq = 1.0 / q; + paramB->R = R; + paramB->S = (p - q) * a; + + strncpy (name, gen->name, LEN0); + len = strlen ("\nunif01_CreateBiasGen with P = "); + strncat (name, "\nunif01_CreateBiasGen with P = ", len); + sprintf (str, "%.4f", R); + len = strlen (str); + strncat (name, str, len); + strncat (name, ", a = ", 8); + sprintf (str, "%.4f", a); + len = strlen (str); + strncat (name, str, len); + + len = strlen (name); + genB->name = util_Calloc (1 + len, sizeof (char)); + strncpy (genB->name, name, len); + + /* The state of the bias generator is simply the state of the original + generator */ + genB->param = paramB; + genB->state = gen->state; + genB->Write = gen->Write; + genB->GetBits = &BiasGen_Bits; + genB->GetU01 = &BiasGen_U01; + return genB; +} + +void unif01_DeleteBiasGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/*************************************************************************/ +typedef struct { + unif01_Gen *gen0; /* The original generator */ + int k; /* keep k numbers */ + int s; /* skip s numbers */ + int n; /* state */ +} LuxGen_param; + + +static unsigned long LuxGen_Bits (void *vpar, void *junk) +{ + LuxGen_param *paramL = vpar; + unif01_Gen *gen = paramL->gen0; + if (0 == paramL->n) { + int i; + for (i = paramL->s; i > 0; --i) + gen->GetBits (gen->param, gen->state); + paramL->n = paramL->k; + } + --paramL->n; + return gen->GetBits (gen->param, gen->state); +} + + +static double LuxGen_U01 (void *vpar, void *junk) +{ + LuxGen_param *paramL = vpar; + unif01_Gen *gen = paramL->gen0; + if (0 == paramL->n) { + int i; + for (i = paramL->s; i > 0; --i) + gen->GetU01 (gen->param, gen->state); + paramL->n = paramL->k; + } + --paramL->n; + return gen->GetU01 (gen->param, gen->state); +} + + +unif01_Gen * unif01_CreateLuxGen (unif01_Gen *gen, int k, int L) +{ + unif01_Gen *genL; + LuxGen_param *paramL; + char name[LEN0 + 1] = ""; + char str[26]; + size_t len; + const int s = L - k; + + util_Assert (k > 0, "unif01_CreateLuxGen: k <= 0"); + util_Assert (k <= L, "unif01_CreateLuxGen: L < k"); + + genL = util_Malloc (sizeof (unif01_Gen)); + paramL = util_Malloc (sizeof (LuxGen_param)); + paramL->gen0 = gen; + paramL->s = s; + paramL->k = k; + paramL->n = k; + + strncpy (name, gen->name, LEN0); + len = strlen ("\nunif01_CreateLuxGen: k = "); + strncat (name, "\nunif01_CreateLuxGen: k = ", len); + sprintf (str, "%-d, L = %-d", k, L); + len = strlen (str); + strncat (name, str, len); + len = strlen (name); + genL->name = util_Calloc (1 + len, sizeof (char)); + strncpy (genL->name, name, len); + + genL->param = paramL; + genL->state = gen->state; + genL->Write = gen->Write; + genL->GetBits = &LuxGen_Bits; + genL->GetU01 = &LuxGen_U01; + return genL; +} + + +void unif01_DeleteLuxGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/*************************************************************************/ +typedef struct { + unif01_Gen *gen0; /* The original generator */ + unsigned long mask; /* s most significant bits */ +} TruncGen_param; + + +static unsigned long TruncGen_Bits (void *vpar, void *junk) +{ + TruncGen_param *paramT = vpar; + unif01_Gen *gen = paramT->gen0; + + return paramT->mask & gen->GetBits (gen->param, gen->state); +} + +static double TruncGen_U01 (void *vpar, void *vsta) +{ + return TruncGen_Bits (vpar, vsta) * unif01_INV32; +} + +unif01_Gen * unif01_CreateTruncGen (unif01_Gen *gen, int b) +{ + unif01_Gen *genT; + TruncGen_param *paramT; + char name[LEN0 + 1] = ""; + char str[16]; + size_t len; + + if (b < 0) + util_Error ("unif01_CreateTruncGen: s < 0"); + if (b > 32) + util_Error ("unif01_CreateTruncGen: s > 32"); + + genT = util_Malloc (sizeof (unif01_Gen)); + paramT = util_Malloc (sizeof (TruncGen_param)); + paramT->gen0 = gen; + if (b >= 32) + paramT->mask = 0xffffffffU; + else + paramT->mask = (0xffffffffU >> (32 - b)) << (32 - b); + + strncpy (name, gen->name, LEN0); + len = strlen ("\nunif01_CreateTruncGen with b = "); + strncat (name, "\nunif01_CreateTruncGen with b = ", len); + sprintf (str, "%-d", b); + len = strlen (str); + strncat (name, str, len); + strncat (name, " bits:", 8); + + len = strlen (name); + genT->name = util_Calloc (1 + len, sizeof (char)); + strncpy (genT->name, name, len); + + /* The state of the trunc generator is simply the state of the original + generator */ + genT->param = paramT; + genT->state = gen->state; + genT->Write = gen->Write; + genT->GetBits = &TruncGen_Bits; + genT->GetU01 = &TruncGen_U01; + return genT; +} + +void unif01_DeleteTruncGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/************************************************************************/ +/* + * The original generator is gen0. The r most significant bits of each random + * number are dropped, and the s following bits are kept. + */ +typedef struct { + unif01_Gen *gen0; + int nrows; /* Number of integers used in making a new random number */ + int B; /* Number of blocks in 1 s-bits group */ + int w; /* Number of bits in a block */ + unsigned long maskw; /* Mask of w bits = 2^w - 1 */ + int r; + int s; +} BitBlock_param; + + +typedef struct { + unsigned long *Z; + int n; /* Build n random numbers at a time, n <= 32 */ + BitBlock_param *param; +} BitBlock_state; + + +static unsigned long BitBlock_Bits (void *vpar, void *vsta) +{ + BitBlock_state *state = vsta; + + if (state->n <= 0) { + BitBlock_param *param = vpar; + unsigned long X; + int i, j; + + /* Generate B random integers Z from the bits of nrows random integers + X from the original gen0 */ + for (j = 0; j < param->B; j++) + state->Z[j] = 0; + for (i = 0; i < param->nrows; i++) { + /* Get a random integer X of s bits */ + X = unif01_StripB (param->gen0, param->r, param->s); + /* Take w of the s bits of X to make bits of Z[j] */ + for (j = 0; j < param->B; j++) { + state->Z[j] <<= param->w; + state->Z[j] |= X & param->maskw; + X >>= param->w; + } + } + state->n = param->B; + } + return state->Z[--state->n]; +} + + +static double BitBlock_U01 (void *vpar, void *vsta) +{ + return BitBlock_Bits (vpar, vsta) * unif01_INV32; +} + + +static void WrBitBlock (void *vsta) +{ + BitBlock_state *state = vsta; + state->param->gen0->Write (state->param->gen0->state); +} + + +unif01_Gen * unif01_CreateBitBlockGen (unif01_Gen *gen, int r, int s, int w) +{ + unif01_Gen *genV; + BitBlock_param *paramV; + BitBlock_state *stateV; + char *name; + char str[64]; + size_t len, len2, len3; + + util_Assert (s > 0, "unif01_CreateBitBlockGen: s <= 0"); + util_Assert (r >= 0, "unif01_CreateBitBlockGen: r < 0"); + util_Assert (r + s <= 32, "unif01_CreateBitBlockGen: r + s > 32"); + util_Assert (w > 0, "unif01_CreateBitBlockGen: w < 1"); + util_Assert (32 % w == 0, "unif01_CreateBitBlockGen: w must divide 32"); + + genV = util_Malloc (sizeof (unif01_Gen)); + paramV = util_Malloc (sizeof (BitBlock_param)); + stateV = util_Malloc (sizeof (BitBlock_state)); + paramV->gen0 = gen; + paramV->s = s; + paramV->r = r; + paramV->w = w; + paramV->B = s / w; + paramV->maskw = num_TwoExp[paramV->w] - 1.0; + paramV->nrows = 32 / w; + stateV->param = paramV; + stateV->n = 0; + stateV->Z = util_Calloc ((size_t) paramV->B, sizeof (unsigned long)); + + len = strlen (gen->name); + len2 = strlen ("\nunif01_CreateBitBlockGen: "); + len += len2; + sprintf (str, "r = %1d, s = %1d, w = %1d", r, s, w); + len3 = strlen (str); + len += len3; + name = util_Calloc (len + 1, sizeof (char)); + strncpy (name, gen->name, len); + strncat (name, "\nunif01_CreateBitBlockGen: ", len2); + strncat (name, str, len3); + genV->name = name; + genV->param = paramV; + genV->state = stateV; + genV->Write = &WrBitBlock; + genV->GetBits = &BitBlock_Bits; + genV->GetU01 = &BitBlock_U01; + return genV; +} + + +void unif01_DeleteBitBlockGen (unif01_Gen *gen) +{ + BitBlock_state *state; + if (NULL == gen) return; + state = gen->state; + state->Z = util_Free (state->Z); + gen->param = util_Free (gen->param); + gen->state = util_Free (gen->state); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/************************************************************************/ + +static double CombGen2_U01_Add (void *vpar, void *junk) +{ + unif01_Comb2_Param *g = vpar; + unif01_Gen *gen1 = g->gen1; + unif01_Gen *gen2 = g->gen2; + double U; + + U = gen1->GetU01 (gen1->param, gen1->state) + + gen2->GetU01 (gen2->param, gen2->state); + if (U >= 1.0) + return (U - 1.0); + else + return U; +} + + +static unsigned long CombGen2_Bits_Add (void *vpar, void *junk) +{ + return (unsigned long) (unif01_NORM32 * CombGen2_U01_Add (vpar, junk)); +} + + +static unsigned long CombGen2_Bits_Xor (void *vpar, void *junk) +{ + unif01_Comb2_Param *g = vpar; + unif01_Gen *gen1 = g->gen1; + unif01_Gen *gen2 = g->gen2; + + return gen1->GetBits (gen1->param, gen1->state) ^ + gen2->GetBits (gen2->param, gen2->state); +} + + +static double CombGen2_U01_Xor (void *vpar, void *junk) +{ + return CombGen2_Bits_Xor (vpar, junk) * unif01_INV32; +} + + +static void WrCombGen2 (void *vsta) +{ + unif01_Comb2_Param *g = vsta; + printf ("2 Combined Generators:\n"); + g->gen1->Write (g->gen1->state); + g->gen2->Write (g->gen2->state); +} + + +static unif01_Gen * CreateCombGen2 (unif01_Gen *g1, unif01_Gen *g2, + char *mess, char *name) +{ + unif01_Gen *gen; + unif01_Comb2_Param *paramC; + size_t len, L; + + gen = util_Malloc (sizeof (unif01_Gen)); + paramC = util_Malloc (sizeof (unif01_Comb2_Param)); + paramC->gen1 = g1; + paramC->gen2 = g2; + + len = strlen (g1->name) + strlen (g2->name) + strlen (name) + strlen (mess); + len += 5; + gen->name = util_Calloc (len + 1, sizeof (char)); + L = strlen (mess); + if (L > 0) { + strncpy (gen->name, mess, len); + if (mess[L - 1] != ':') + strncat (gen->name, ":", 3); + strncat (gen->name, "\n", 3); + } + strncat (gen->name, g1->name, len); + strncat (gen->name, "\n", 3); + strncat (gen->name, g2->name, len); + strncat (gen->name, name, len); + + gen->param = paramC; + gen->state = paramC; + gen->Write = &WrCombGen2; + return gen; +} + + +unif01_Gen * unif01_CreateCombAdd2 (unif01_Gen *g1, unif01_Gen *g2, char *Mess) +{ + unif01_Gen *gen; + gen = CreateCombGen2 (g1, g2, Mess, "\nunif01_CreateCombAdd2"); + gen->GetU01 = &CombGen2_U01_Add; + gen->GetBits = &CombGen2_Bits_Add; + return gen; +} + + +unif01_Gen * unif01_CreateCombXor2 (unif01_Gen *g1, unif01_Gen *g2, + char *Mess) +{ + unif01_Gen *gen; + gen = CreateCombGen2 (g1, g2, Mess, "\nunif01_CreateCombXor2"); + gen->GetU01 = &CombGen2_U01_Xor; + gen->GetBits = &CombGen2_Bits_Xor; + return gen; +} + +void unif01_DeleteCombGen (unif01_Gen *gen) +{ + if (NULL == gen) return; + gen->param = util_Free (gen->param); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/************************************************************************/ + +typedef struct { + unif01_Gen *gen1; + unif01_Gen *gen2; + unif01_Gen *gen3; +} Comb3_Param; + + +static double CombGen3_U01_Add (void *vpar, void *junk) +{ + Comb3_Param *g = vpar; + unif01_Gen *gen1 = g->gen1; + unif01_Gen *gen2 = g->gen2; + unif01_Gen *gen3 = g->gen3; + double U; + + /* + When the combined generator is used to generate random integers, in rare + cases, an integer may differ by 1 unit depending on the order of + addition of the 3 terms (one from each component). This is due + to the last bit (bit 53) of the value returned which may be affected by + floating-point numerical errors. Furthermore, the result + may be different if the addition is done without function calls + (as in the pre-programmed version of Wichmann-Hill for example in + {\tt ulcg\_CreateCombWH3}), in which case, the 2 extra guard bits + required by the IEEE-754 standard in floating-point arithmetic + operations may give a more precise result. + */ + U = gen1->GetU01 (gen1->param, gen1->state) + + gen2->GetU01 (gen2->param, gen2->state) + + gen3->GetU01 (gen3->param, gen3->state); + + if (U < 1.0) + return U; + if (U < 2.0) + return (U - 1.0); + return U - 2.0; +} + + +static unsigned long CombGen3_Bits_Add (void *vpar, void *junk) +{ + return (unsigned long) (CombGen3_U01_Add (vpar, junk) * unif01_NORM32); +} + + +static unsigned long CombGen3_Bits_Xor (void *vpar, void *junk) +{ + Comb3_Param *g = vpar; + unif01_Gen *gen1 = g->gen1; + unif01_Gen *gen2 = g->gen2; + unif01_Gen *gen3 = g->gen3; + + return gen1->GetBits (gen1->param, gen1->state) ^ + gen2->GetBits (gen2->param, gen2->state) ^ + gen3->GetBits (gen3->param, gen3->state); +} + + +static double CombGen3_U01_Xor (void *vpar, void *junk) +{ + return CombGen3_Bits_Xor (vpar, junk) * unif01_INV32; +} + + +static void WrCombGen3 (void *vsta ) +{ + Comb3_Param *g = vsta; + printf ("3 Combined Generators:\n"); + g->gen1->Write (g->gen1->state); + g->gen2->Write (g->gen2->state); + g->gen3->Write (g->gen3->state); +} + + +static unif01_Gen * CreateCombGen3 (unif01_Gen *g1, unif01_Gen *g2, + unif01_Gen *g3, const char *mess, const char *name) +{ + unif01_Gen *gen; + Comb3_Param *paramC; + size_t len, L; + + gen = util_Malloc (sizeof (unif01_Gen)); + paramC = util_Malloc (sizeof (Comb3_Param)); + paramC->gen1 = g1; + paramC->gen2 = g2; + paramC->gen3 = g3; + + len = strlen (g1->name) + strlen (g2->name) + strlen (g3->name) + + strlen (name) + strlen (mess); + len += 5; + gen->name = util_Calloc (len + 1, sizeof (char)); + L = strlen (mess); + if (L > 0) { + strncpy (gen->name, mess, len); + if (mess[L - 1] != ':') + strncat (gen->name, ":", 3); + strncat (gen->name, "\n", 3); + } + strncat (gen->name, g1->name, len); + strncat (gen->name, "\n", 3); + strncat (gen->name, g2->name, len); + strncat (gen->name, "\n", 3); + strncat (gen->name, g3->name, len); + strncat (gen->name, name, len); + + gen->param = paramC; + gen->state = paramC; + gen->Write = &WrCombGen3; + return gen; +} + + +unif01_Gen * unif01_CreateCombAdd3 (unif01_Gen *g1, unif01_Gen *g2, + unif01_Gen *g3, char *mess) +{ + unif01_Gen *gen; + gen = CreateCombGen3 (g1, g2, g3, mess, "\nunif01_CreateCombAdd3"); + gen->GetU01 = &CombGen3_U01_Add; + gen->GetBits = &CombGen3_Bits_Add; + return gen; +} + + +unif01_Gen * unif01_CreateCombXor3 (unif01_Gen *g1, unif01_Gen *g2, + unif01_Gen *g3, char *mess) +{ + unif01_Gen *gen; + gen = CreateCombGen3 (g1, g2, g3, mess, "\nunif01_CreateCombXor3"); + gen->GetU01 = &CombGen3_U01_Xor; + gen->GetBits = &CombGen3_Bits_Xor; + return gen; +} + + +/*=========================================================================*/ + +typedef struct { + int j; /* Which random number */ + int i; /* Which generator */ + int L; + int k; /* Number of parallel generators */ + unif01_Gen **agen; /* Parallel generators */ +} ParallelGen_state; + + +static double ParallelGen_U01 (void *junk, void *vsta) +{ + ParallelGen_state *stateP = vsta; + unif01_Gen *g; + + if (++stateP->j >= stateP->L) { + stateP->j = 0; + if (++stateP->i >= stateP->k) + stateP->i = 0; + } + g = stateP->agen[stateP->i]; + return g->GetU01 (g->param, g->state); +} + + +static unsigned long ParallelGen_Bits (void *junk, void *vsta) +{ + ParallelGen_state *stateP = vsta; + unif01_Gen *g; + + if (++stateP->j >= stateP->L) { + stateP->j = 0; + if (++stateP->i >= stateP->k) + stateP->i = 0; + } + g = stateP->agen[stateP->i]; + return g->GetBits (g->param, g->state); +} + + +static void WrParallelGen (void *vsta) +{ + int i; + ParallelGen_state *state = vsta; + printf (" i = %d, j = %d\n\nParallel Generators:\n", state->i, state->j); + for (i = 0; i < state->k; ++i) + unif01_WriteNameGen(state->agen[i]); +} + + +unif01_Gen * unif01_CreateParallelGen (int k, unif01_Gen *gen[], int L) +{ +#define NCAT 16 + unif01_Gen *genP; + ParallelGen_state *stateP; + char name[LEN0 + 1] = {0}; + char str[NCAT + 1]; + size_t len; + int j; + + genP = util_Malloc (sizeof (unif01_Gen)); + stateP = util_Malloc (sizeof (ParallelGen_state)); + stateP->k = k; + stateP->L = L; + stateP->i = k; + stateP->j = L; + stateP->agen = util_Calloc ((size_t) k, sizeof (unif01_Gen *)); + for (j = 0; j < k; j++) + stateP->agen[j] = gen[j]; + + len = strlen ("unif01_CreateParallelGen: k = "); + strncpy (name, "unif01_CreateParallelGen: k = ", len); + sprintf (str, "%-d", k); + strncat (name, str, NCAT); + strncat (name, ", L = ", NCAT); + sprintf (str, "%-d", L); + strncat (name, str, NCAT); + len = strlen (name); + genP->name = util_Calloc (1 + len, sizeof (char)); + strncpy (genP->name, name, len); + + genP->state = stateP; + genP->Write = &WrParallelGen; + genP->GetBits = &ParallelGen_Bits; + genP->GetU01 = &ParallelGen_U01; + return genP; +#undef NCAT +} + + +void unif01_DeleteParallelGen (unif01_Gen *gen) +{ + ParallelGen_state *state; + if (NULL == gen) return; + state = gen->state; + state->agen = util_Free (state->agen); + gen->state = util_Free (gen->state); + gen->name = util_Free (gen->name); + util_Free (gen); +} + + +/*=========================================================================*/ + +static double (*externGen_U01)(void); /* The external generator U01 */ +static int coGU = 0; /* Counter for GU_U01 */ + + +static double GU_U01 (void *param, void *state) +{ + return externGen_U01 (); +} + + +static unsigned long GU_Bits (void *param, void *state) +{ + return (unsigned long) (externGen_U01 () * unif01_NORM32); +} + + +static void WrExternGen (void *state) +{ +} + + +unif01_Gen *unif01_CreateExternGen01 (char *name, double (*f_U01)(void)) +{ + unif01_Gen *gen; + size_t leng; + + util_Assert (coGU == 0, + "unif01_CreateExternGen01: only 1 such generator can be in use"); + coGU++; + gen = util_Malloc (sizeof (unif01_Gen)); + gen->state = NULL; + gen->param = NULL; + gen->Write = WrExternGen; + externGen_U01 = f_U01; + gen->GetU01 = GU_U01; + gen->GetBits = GU_Bits; + + if (name) { + leng = strlen (name); + gen->name = util_Calloc (leng + 2, sizeof (char)); + strncpy (gen->name, name, leng); + } else { + gen->name = util_Calloc (1, sizeof (char)); + gen->name[0] = '\0'; + } + return gen; +} + + +void unif01_DeleteExternGen01 (unif01_Gen * gen) +{ + if (NULL == gen) + return; + gen->name = util_Free (gen->name); + util_Free (gen); + coGU--; +} + + +/*=========================================================================*/ + +static void (*externGen_Bits)(const unsigned int, unsigned int*); +static int coGB = 0; /* Counter for GB_U01 */ + +static const int RANDOM_BATCH_SIZE = 1000; + +static void set_param (void* param, unsigned int value) { + *((unsigned int*) param) = value; +} + +static unsigned int get_param(void* param) { + return *((unsigned int*) param); +} + +static void reset_param (void* param) { + set_param(param, 0); +} + +static void increment_param (void* param) { + set_param(param, get_param(param) + 1); +} + +static int has_run_out_of_randoms (void* param) { + return get_param(param) == RANDOM_BATCH_SIZE; +} + +static unsigned int next_param_increment (void* param) { + unsigned int result = get_param(param); + increment_param(param); + return result; +} + +static unsigned int get_next_value (void* param, void* state) { + unsigned int index = next_param_increment(param); + return ((unsigned int*) state)[index]; +} + +static void produce_new_batch(void* state) { + externGen_Bits (RANDOM_BATCH_SIZE, state); +} + +static unsigned int generate_next_bits (void* param, void* state) { + if (has_run_out_of_randoms(param)) { + produce_new_batch(state); + reset_param(param); + } + return get_next_value(param, state); +} + + +static double GB_U01 (void *param, void *state) +{ + return generate_next_bits(param, state) / unif01_NORM32; +} + + +static unsigned long GB_Bits (void *param, void *state) +{ + return generate_next_bits(param, state); +} + + +unif01_Gen* unif01_CreateExternGenBits (void (*f_Bits)(const unsigned int, + unsigned int*)) +{ + unif01_Gen *gen; + size_t leng; + + util_Assert (coGB == 0, + "unif01_CreateExternGenBits: only 1 such generator can be in use"); + coGB++; + gen = util_Malloc (sizeof (unif01_Gen)); + gen->state = util_Malloc (sizeof (unsigned int) * RANDOM_BATCH_SIZE); + gen->param = util_Malloc (sizeof (unsigned int)); + gen->Write = WrExternGen; + externGen_Bits = f_Bits; + gen->GetU01 = GB_U01; + gen->GetBits = GB_Bits; + produce_new_batch(gen->state); + reset_param(gen->param); + + gen->name = util_Calloc (1, sizeof (char)); + gen->name[0] = '\0'; + return gen; +} + + +void unif01_DeleteExternGenBits (unif01_Gen * gen) +{ + if (NULL == gen) + return; + gen->name = util_Free (gen->name); + util_Free (gen->state); + util_Free (gen->param); + util_Free (gen); + coGB--; +} + + +/*=========================================================================*/ + +static unsigned long (*externGenLong_Bits)(void); +static int coGBL = 0; /* Counter for GBLong_U01 */ + +static double GBLong_U01 (void *param, void *state) +{ + return externGenLong_Bits () / unif01_NORM32; +} + +static unsigned long GBLong_Bits (void *param, void *state) +{ + return externGenLong_Bits (); +} + + +unif01_Gen *unif01_CreateExternGenBitsL (char *name, + unsigned long (*f_Bits)(void)) +{ + unif01_Gen *gen; + size_t leng; + + util_Assert (coGBL == 0, + "unif01_CreateExternGenBitsL: only 1 such generator can be in use"); + coGBL++; + gen = util_Malloc (sizeof (unif01_Gen)); + gen->state = NULL; + gen->param = NULL; + gen->Write = WrExternGen; + externGenLong_Bits = f_Bits; + gen->GetU01 = GBLong_U01; + gen->GetBits = GBLong_Bits; + + if (name) { + leng = strlen (name); + gen->name = util_Calloc (leng + 2, sizeof (char)); + strncpy (gen->name, name, leng); + } else { + gen->name = util_Calloc (1, sizeof (char)); + gen->name[0] = '\0'; + } + return gen; +} + + +void unif01_DeleteExternGenBitsL (unif01_Gen * gen) +{ + if (NULL == gen) + return; + gen->name = util_Free (gen->name); + util_Free (gen); + coGBL--; +} + + +/**************************************************************************/ + +void unif01_TimerGen (unif01_Gen *gen, unif01_TimerRec * pt, long n, + lebool fU01) +{ + chrono_Chrono *C1; + double U; + unsigned long V; + long i; + + C1 = chrono_Create (); + if (fU01) + for (i = 0; i < n; i++) + U = gen->GetU01 (gen->param, gen->state); + else + for (i = 0; i < n; i++) + V = gen->GetBits (gen->param, gen->state); + pt->time = chrono_Val (C1, chrono_sec); + pt->mean = 0.0; + pt->n = n; + pt->fU01 = fU01; + pt->gen = gen; + chrono_Delete (C1); +} + +void unif01_TimerSumGen (unif01_Gen *gen, unif01_TimerRec * pt, long n, + lebool fU01) +{ + chrono_Chrono *C1; + double Sum = 0.0; + unsigned long Y = 0; + long i; + + C1 = chrono_Create (); + if (fU01) + for (i = 0; i < n; i++) + Sum += gen->GetU01 (gen->param, gen->state); + else + for (i = 0; i < n; i++) + Y += gen->GetBits (gen->param, gen->state); + pt->time = chrono_Val (C1, chrono_sec); + if (fU01) + pt->mean = Sum / n; + else + pt->mean = (double) Y / n; + pt->n = n; + pt->gen = gen; + pt->fU01 = fU01; + chrono_Delete (C1); +} + +void unif01_WriteTimerRec (unif01_TimerRec *R) +{ + unif01_Gen *gen = R->gen; + char stri [LEN1 + 1] = ""; + char *p; + size_t len; + + printf ("\n------------- Results of speed test ---------------"); + printf ("\n\n Host: "); + if (swrite_Host) + gdef_WriteHostName (); + else + printf ("\n"); + + /* Print only the generator name, without the parameters or seeds. */ + /* The parameters start after the first blank; name ends with ':' */ + printf (" Generator: "); + len = strcspn (gen->name, ":"); + strncpy (stri, gen->name, len); + stri [len] = '\0'; + printf ("%s", stri); + p = strstr (gen->name, "unif01"); + while (p != NULL) { + /* For Filters or Combined generators */ + len = strcspn (p, " \0"); + strncpy (stri, p, len); + stri [len] = '\0'; + printf (", %s", stri); + p += len; + p = strstr (p, "unif01"); + } + if (R->fU01) { + printf ("\n Method: GetU01"); + if (R->mean > 0.0) + printf ("\n Mean = %.15f", R->mean); + } else { + printf ("\n Method: GetBits"); + if (R->mean > 0.0) + printf ("\n Mean = %.16g", R->mean); + } + printf ("\n Number of calls: %ld", R->n); + printf ("\n Total CPU time: "); + printf ("%6.2f sec\n\n", R->time); +} + +void unif01_TimerGenWr (unif01_Gen *gen, long n, lebool fU01) +{ + unif01_TimerRec timer; + unif01_TimerGen (gen, &timer, n, fU01); + unif01_WriteTimerRec (&timer); +} + +void unif01_TimerSumGenWr (unif01_Gen *gen, long n, lebool fU01) +{ + unif01_TimerRec timer; + unif01_TimerSumGen (gen, &timer, n, fU01); + unif01_WriteTimerRec (&timer); +} diff --git a/cbits/testu/src/util.c b/cbits/testu/src/util.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/util.c @@ -0,0 +1,179 @@ +/*************************************************************************\ + * + * Package: MyLib + * File: util.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "util.h" + +#include +#include +#include +#include + + +#define MAXCAR 256 /* Max length of a line of data */ + + + +/************************************************************************/ + +FILE *util_Fopen (const char *path, const char *mode) +{ + FILE *f; + errno = 0; + f = fopen (path, mode); + if (f == NULL) { + fprintf (stdout, "\nOpening of %s failed: %s\n\n", + path, strerror (errno)); + exit (EXIT_FAILURE); + return NULL; /* to eliminate a warning from the compiler */ + } else + return f; +} + +int util_Fclose (FILE * f) +{ + int s; + if (f == NULL) + return 0; + errno = 0; + s = fclose (f); + if (s != 0) + fprintf (stdout, "\nClosing of file failed: %s\n\n", strerror (errno)); + return s; +} + + +/************************************************************************/ + +void *util_Malloc (size_t size) +{ + void *p; + errno = 0; + p = malloc (size); + if (p == NULL) { + fprintf (stdout, "\nmalloc failed: %s\n\n", strerror (errno)); + exit (EXIT_FAILURE); + return NULL; /* to eliminate a warning from the compiler */ + } else + return p; +} + +void *util_Calloc (size_t count, size_t esize) +{ + void *p; + errno = 0; + p = calloc (count, esize); + if (p == NULL) { + fprintf (stdout, "\ncalloc failed: %s\n\n", strerror (errno)); + exit (EXIT_FAILURE); + return NULL; /* to eliminate a warning from the compiler */ + } else + return p; +} + +void *util_Realloc (void *ptr, size_t size) +{ + void *p; + errno = 0; + p = realloc (ptr, size); + if ((p == NULL) && (size != 0)) { + fprintf (stdout, "\nrealloc failed: %s\n\n", strerror (errno)); + exit (EXIT_FAILURE); + return ptr; /* to eliminate a warning from the compiler */ + } else + return p; + +} + +void *util_Free (void *p) +{ + free (p); + return NULL; +} + + +/************************************************************************/ + +void util_WriteBool (lebool b, int d) +{ + if (b) + printf ("%*s", d, "TRUE"); + else + printf ("%*s", d, "FALSE"); +} + + +void util_ReadBool (char S[], lebool *x) +{ + int j; + char B[6]; + j = sscanf (S, " %6s", B); + util_Assert (j > 0, "util_ReadBool: on reading lebool"); + if (!strncmp (B, "TRUE", (size_t) 5)) + *x = TRUE; + else if (!strncmp (B, "FALSE", (size_t) 6)) + *x = FALSE; + else { + util_Error ("util_ReadBool: lebool values must be TRUE or FALSE"); + } +} + + +/************************************************************************/ + +int util_GetLine (FILE *infile, char *Line, char c) +{ + size_t j; + + while (NULL != fgets (Line, MAXCAR, infile)) { /* Not EOF and no error */ + /* Find first non-white character in Line */ + j = strspn (Line, " \t\r\f\v"); + /* Discard blank lines and lines whose first non-white character is c */ + if (Line[j] == '\n' || Line[j] == c) + continue; + else { + char *p; + /* If the character c appears, delete the rest of the line*/ + if ((p = strchr (Line, c))) + *p = '\0'; + + else { + /* Remove the \n char at the end of line */ + j = strlen (Line); + if (Line[j - 1] == '\n') + Line[j - 1] = '\0'; + } + return 0; + } + } + + util_Fclose (infile); + return -1; + /* util_Error ("GetLine: an error has occurred on reading"); */ +} diff --git a/cbits/testu/src/vectorsF2.c b/cbits/testu/src/vectorsF2.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/vectorsF2.c @@ -0,0 +1,1089 @@ +#include "vectorsF2.h" +#include +#include + +#define WL vectorsF2_WL + +#define MC 0x80000000UL /* permet de diagonaliser la matrice dans Diag() */ + +unsigned long MMC[WL] = + { MC, MC >> 1, MC >> 2, MC >> 3, MC >> 4, MC >> 5, MC >> 6, MC >> 7, + MC >> 8, MC >> 9, MC >> 10, + MC >> 11, MC >> 12, MC >> 13, MC >> 14, MC >> 15, MC >> 16, MC >> 17, + MC >> 18, MC >> 19, MC >> 20, + MC >> 21, MC >> 22, MC >> 23, MC >> 24, MC >> 25, MC >> 26, MC >> 27, + MC >> 28, MC >> 29, MC >> 30, MC >> 31 +}; + +lebool InverseMatrix (Matrix * InvM, Matrix * M) +{ + + Matrix Temp; + int j, rang; + if (M->nblignes != M->l) { + printf ("Matrix M is not square!\n"); + exit (1); + } + AllocMat (&Temp, M->nblignes, M->l, 2); + for (j = 0; j < M->l; j++) + CopyBV (&(Temp.lignes[j][0]), &(M->lignes[j][0])); + for (j = 0; j < M->l; j++) { + BVCanonic (&(Temp.lignes[j][1]), j); + } + /* DispMat(&Temp,2,M->l,M->nblignes,0); */ + rang = CompleteElimination (&Temp, M->nblignes, M->l, 2); + /* DispMat(&Temp,2,M->l,M->nblignes,0); */ + /* printf("rang=%d",rang); */ + for (j = 0; j < M->l; j++) + CopyBV (&(InvM->lignes[j][0]), &(Temp.lignes[j][1])); + return (rang == M->l); + FreeMat (&Temp); +} + + +/* ********************************************************************** */ +/* lebool Diag( Matrix m, int kg, */ +/* int t, int l, int *gr ) */ +/* Evalue si la matrice de travail m sur kg lignes est de plein rang en */ +/* la diagonalisant. On procede sur t BitVect en considerant les l */ +/* premiers bits de chacun. La fonction retourne TRUE si la matrice m */ +/* est de plein rang t*l et *gr est inchange. La fonction retourne */ +/* FALSE sinon et *gr prend pour valeur le numero du BitVect ou il y a */ +/* eu echec moins un ( = dimension pour laquelle on a resolution l ). */ +/* ********************************************************************** */ +lebool Diag (Matrix * m, int kg, int t, int l, int *gr) +{ + int i, j, cl, rang; + + rang = 0; + + /* On diagonalise la matrice des entrees (i,j) sur l bits */ + /* avec 0 <= i < kg et 0 <= j < t . */ + + for (j = 0; j < t; j++) { + cl = 1; + while (cl <= l) { + /* On cherche dans la j-eme colonne, commencant a la */ + /* rang-eme ligne, la premiere entree dont le bit le plus */ + /* significatif est non nul. Bref, on cherche un pivot. */ + i = rang; + + while ((i < kg) + && (m->lignes[i][j].vect[(cl - 1) / WL] < MMC[(cl - 1) % WL])) + i++; + if (i < kg) { /* pivot trouve ... */ + ExchangeVect (m, rang, i); + for (i = rang + 1; i < kg; i++) { + if (m->lignes[i][j].vect[(cl - 1) / WL] & MMC[(cl - 1) % WL]) + XorVect (m, i, rang, j, m->t); + } + rang++; + } else { /* pas de pivot trouve ... ==> pas de plein + rang ... */ + + *gr = j; /* no de groupe ou il y a echec moins un */ + return FALSE; /* c'est j car on indexe a partir de 0 . */ + } + cl++; + } + } + return TRUE; /* on a trouve tous les pivots ==> plein + rang ! */ +} + + +int CompleteElimination (Matrix * m, int nblignes, int l, int t) +{ + int i, j, cl, rang; + + rang = 0; + + j = 0; + while (j < t) { + cl = 0; + while (cl < l) { + /* On cherche dans la j-eme colonne, commencant a la */ + /* rang-eme ligne, la premiere entree dont le bit le plus */ + /* significatif est non nul. Bref, on cherche un pivot. */ + i = rang; + while ((i < nblignes) + && ((((m->lignes)[i])[j]).vect[(cl) / WL] < MMC[(cl) % WL])) + i++; + if (i < nblignes) { /* pivot trouve ... */ + ExchangeVect (m, rang, i); + for (i = 0; i < nblignes; i++) + if (i != rang) + if ((((m->lignes)[i])[j]).vect[(cl) / WL] & MMC[(cl) % WL]) + XorVect (m, i, rang, 0, m->t); + + rang++; + if (rang == nblignes) + return rang; + } else + return rang; + cl++; + } + j++; + } + return rang; +} + + +int GaussianElimination (Matrix * m, int nblignes, int l, int t) +{ + int i, j, cl, rang; + + rang = 0; + + j = 0; + while (j < t) { + cl = 0; + while (cl < l) { + /* On cherche dans la j-eme colonne, commencant a la */ + /* rang-eme ligne, la premiere entree dont le bit le plus */ + /* significatif est non nul. Bref, on cherche un pivot. */ + i = rang; + while ((i < nblignes) + && ((((m->lignes)[i])[j]).vect[(cl) / WL] < MMC[(cl) % WL])) + i++; + if (i < nblignes) { /* pivot trouve ... */ + ExchangeVect (m, rang, i); + for (i = rang + 1; i < nblignes; i++) + if ((((m->lignes)[i])[j]).vect[(cl) / WL] & MMC[(cl) % WL]) + XorVect (m, i, rang, 0, m->t); + + rang++; + if (rang == nblignes) + return rang; + } + cl++; + } + j++; + } + return rang; +} + + +int SpecialGaussianElimination (Matrix * m, int nblignes, int l, int t, + int *indices) +{ + int i, j, cl, rang; + + rang = 0; + + j = 0; + while (j < t) { + cl = 0; + while (cl < l) { + /* On cherche dans la j-eme colonne, commencant a la */ + /* rang-eme ligne, la premiere entree dont le bit le plus */ + /* significatif est non nul. Bref, on cherche un pivot. */ + i = rang; + while ((i < nblignes) + && ((((m->lignes)[i])[indices[j]]).vect[(cl) / WL] < + MMC[(cl) % WL])) + i++; + if (i < nblignes) { /* pivot trouve ... */ + ExchangeVect (m, rang, i); + for (i = rang + 1; i < nblignes; i++) + if ((((m->lignes)[i])[indices[j]]).vect[(cl) / + WL] & MMC[(cl) % WL]) + XorVect (m, i, rang, 0, m->t); + + rang++; + if (rang == nblignes) + return rang; + } + cl++; + } + j++; + } + return rang; +} + + +void MultMatrixByBV (BitVect * A, Matrix * M, BitVect * B) +{ + int i, j, res; + if (M->l < B->n * WL) { + printf ("Error in MultMatrixByBV(): sizes do not match\n"); + exit (1); + } + if (A->n * WL < M->nblignes) { + printf ("Error in MultMatrixByBV(): sizes do not match\n"); + exit (1); + } + if (M->t != 1) { + printf ("Error in MultMatrixByBV(): Not implemented for M->t > 1\n"); + exit (1); + } + PutBVToZero (A); + for (i = 0; i < M->nblignes; i++) { + res = 0; + for (j = 0; j < M->l; j++) + res += ValBitBV (&(M->lignes[i][0]), j) * ValBitBV (B, j); + res %= 2; + PutBitBV (A, i, res); + } +} + + +/* ********************************************************************** */ +/* int GetBitBV (BitVect A, int noBit) */ +/* Fonction qui permet de prendre la valeur du noBit-ieme bit */ +/* (l'indexation commence au bit 0) */ +/* ********************************************************************** */ +int ValBitBV (BitVect * A, int noBit) +{ + int k; + unsigned long mask; + k = noBit / WL; + mask = 0x80000000UL >> (noBit - k * WL); + if (A->vect[k] & mask) + return 1; + else + return 0; +} + + +/* ********************************************************************** */ +/* void SetBitBV (BitVect A, int noBit, int valBit) */ +/* Fonction qui permet de rendre la valeur du noBit-ieme bit `a valBit */ +/* (l'indexation commence au bit 0) (valBit=1 ou valBit=0) */ +/* ********************************************************************** */ +void PutBitBV (BitVect * A, int noBit, int valBit) +{ + int k; + unsigned long mask; + + k = noBit / WL; + if (valBit == 1) { + mask = 0x80000000UL >> (noBit - k * WL); + A->vect[k] |= mask; + } else { + mask = 0xffffffffUL ^ (0x80000000UL >> (noBit - k * WL)); + A->vect[k] &= mask; + } +} + + +/* ********************************************************************** */ +/* SetBVToZero( BitVect A) */ +/* Initialise le vecteur de bit a zero */ +/* ********************************************************************** */ +void PutBVToZero (BitVect * A) +{ + int i; + for (i = 0; i < A->n; i++) + A->vect[i] = 0UL; +} + + +/* ********************************************************************** */ +/* void CopyBV(BitVect A, BitVect B) */ +/* Copie le contenu de B dans A (A=B) */ +/* ********************************************************************** */ +void CopyBV (BitVect * A, BitVect * B) +{ + int i; + + if (A->n != B->n) { + printf + ("Error in CopyBV(): vectors of different dimensions! (%d and %d bits)\n", + A->n * WL, B->n * WL); + exit (1); + } + + if (B->n == 0) { + printf ("Nothing to copy!\n"); + exit (1); + } + for (i = 0; i < B->n; i++) + A->vect[i] = B->vect[i]; +} +void CopyBVPart (BitVect * A, BitVect * B, int l) +{ + + int i, n; + + n = (l - 1) / WL + 1; + + if (A->n < n) { + printf ("Error in CopyBVPart() : The vector A is not large enough!\n"); + exit (1); + } + if (B->n == 0) { + printf ("Nothing to copy!\n"); + exit (1); + } + + for (i = 0; i < n; i++) + A->vect[i] = B->vect[i]; + + if (l % WL) { + BitVect m; + AllocBV (&m, A->n * WL); + Mask (&m, l); + ANDBVSelf (A, &m); + FreeBV (&m); + } +} + + +/* ********************************************************************** */ +/* void EgalBV(BitVect A, BitVect B) */ +/* Compare le contenu de B avec celui de A. Retourne TRUE si les deux */ +/* contiennent la meme information. */ +/* ********************************************************************** */ +lebool CompareBV (BitVect * A, BitVect * B) +{ + + int i; + + if (A->n != B->n) { + printf ("Error in EgalBV(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < A->n; i++) + if (A->vect[i] != B->vect[i]) + return FALSE; + return TRUE; +} + + +lebool BVisZero (BitVect * A) +{ + int j = 0; + while (j < A->n) + if (A->vect[j++] != 0UL) + return FALSE; + return TRUE; +} + + +/* ********************************************************************** */ +/* void XORBV(BitVect A, BitVect B, BitVect C) */ +/* Cette fonction effectue A = B ^ C */ +/* ********************************************************************** */ +void XORBV (BitVect * A, BitVect * B, BitVect * C) +{ + + int i; + + if ((A->n != B->n) || (B->n != C->n)) { + printf ("Error in XORBV(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < B->n; i++) + A->vect[i] = B->vect[i] ^ C->vect[i]; +} + + +/* ********************************************************************** */ +/* void XOR2BV(BitVect A, BitVect B, BitVect C, BitVect D) */ +/* Cette fonction effectue A = B ^ C ^ D */ +/* ********************************************************************** */ +void XOR2BV (BitVect * A, BitVect * B, BitVect * C, BitVect * D) +{ + + int i; + + if ((A->n != B->n) || (B->n != C->n) || (C->n != D->n)) { + printf ("Error in XOR2BV(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < B->n; i++) + A->vect[i] = B->vect[i] ^ C->vect[i] ^ D->vect[i]; +} + + +/* ********************************************************************** */ +/* void ANDBV(BitVect A, BitVect B, BitVect C) */ +/* Cette fonction effectue A = B & C */ +/* ********************************************************************** */ +void ANDBV (BitVect * A, BitVect * B, BitVect * C) +{ + + int i; + + if ((A->n != B->n) || (B->n != C->n)) { + printf ("Error in ANDBV(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < B->n; i++) + A->vect[i] = B->vect[i] & C->vect[i]; +} + + +void ANDBVMask (BitVect * A, BitVect * B, int t) +{ + int n, m, j; + if (A->n != B->n) { + printf ("Error in ANDBVMask(): Vectors of different sizes\n"); + exit (1); + } + + if (t > B->n * WL) + CopyBV (A, B); + else if (t == 0) + PutBVToZero (A); + else { + n = t / WL; + m = t - n * WL; + for (j = 0; j < n; j++) { + A->vect[j] = B->vect[j]; + + } + if (m != 0) { + A->vect[j] = B->vect[j] & (0xffffffffUL << (WL - m)); + j++; + } + /* printf("n=%d j=%d %d m=%d ",n,j,A->n,m); */ + for (; j < A->n; j++) { + A->vect[j] = 0UL; + } + } +} + + +void ANDBVInvMask (BitVect * A, BitVect * B, int t) +{ + int n, m, j; + if (A->n != B->n) { + printf ("Error in ANDBV(): Vectors of different sizes\n"); + exit (1); + } + if (t > B->n * WL) + PutBVToZero (A); + else if (t == 0) + CopyBV (A, B); + else { + n = t / WL; + m = t - n * WL; + for (j = 0; j < n; j++) + A->vect[j] = 0UL; + if (m == 0) + A->vect[j] = B->vect[j]; + else { + A->vect[j] = B->vect[j] & (0xffffffffUL >> m); + + } + j++; + for (; j < A->n; j++) + A->vect[j] = B->vect[j]; + } +} + + + + +/* ********************************************************************** */ +/* void ANDBVSelf(BitVect A, BitVect B) */ +/* Cette fonction effectue A &=B */ +/* ********************************************************************** */ +void ANDBVSelf (BitVect * A, BitVect * B) +{ + int i; + + if ((A->n != B->n)) { + printf ("Error in ANDBVSelf(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < B->n; i++) + A->vect[i] &= B->vect[i]; +} + + +/* ********************************************************************** */ +/* void XORBVSelf(BitVect A, BitVect B) */ +/* Cette fonction effectue A ^=B */ +/* ********************************************************************** */ +void XORBVSelf (BitVect * A, BitVect * B) +{ + int i; + + if ((A->n != B->n)) { + printf ("Error in XORBVSelf(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < B->n; i++) + A->vect[i] ^= B->vect[i]; +} + + +/* ********************************************************************** */ +/* void BVLShift( BitVect R, BitVect A, int n ) */ +/* Effectue : R = A << n ; */ +/* ********************************************************************** */ +void BVLShift (BitVect * R, BitVect * A, int n) +{ + int i; + int WLmn; + unsigned long temp; + + if ((R->n != A->n)) { + printf ("Error in BVLShift(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < A->n; i++) + R->vect[i] = A->vect[i]; + while (n >= 32) { + for (i = 1; i < A->n; i++) + R->vect[i - 1] = R->vect[i]; + R->vect[A->n - 1] = 0UL; + n -= 32; + } + if (n > 0) { + WLmn = WL - n; + R->vect[0] <<= n; + for (i = 1; i < A->n; i++) { + temp = R->vect[i] >> WLmn; + R->vect[i - 1] |= temp; + R->vect[i] <<= n; + } + } + +} + + +/* ********************************************************************** */ +/* void BVRShift( BitVect R, BitVect A, int n ) */ +/* Effectue : R = A >> n ; */ +/* ********************************************************************** */ +void BVRShift (BitVect * R, BitVect * A, int n) +{ + int i; + int WLmn; + unsigned long temp; + if ((R->n != A->n)) { + printf ("Error in BVRShift(): Vectors of different sizes\n"); + exit (1); + } + + for (i = 0; i < A->n; i++) + R->vect[i] = A->vect[i]; + while (n >= 32) { + for (i = A->n; i > 1; i--) + R->vect[i - 1] = R->vect[i - 2]; + R->vect[0] = 0UL; + n -= 32; + } + if (n > 0) { + WLmn = WL - n; + R->vect[A->n - 1] >>= n; + for (i = A->n - 2; i >= 0; i--) { + temp = R->vect[i] << WLmn; + R->vect[i + 1] |= temp; + R->vect[i] >>= n; + } + } +} + + +/* ********************************************************************** */ +/* void BVLShiftSelf( BitVect R, int n ) */ +/* Effectue : R <<= n ; */ +/* ********************************************************************** */ +void BVLShiftSelf (BitVect * R, int n) +{ + int i; + int WLmn; + unsigned long temp; + + while (n >= 32) { + for (i = 1; i < R->n; i++) + R->vect[i - 1] = R->vect[i]; + R->vect[R->n - 1] = 0UL; + n -= 32; + } + if (n > 0) { + WLmn = WL - n; + R->vect[0] <<= n; + for (i = 1; i < R->n; i++) { + temp = R->vect[i] >> WLmn; + R->vect[i - 1] |= temp; + R->vect[i] <<= n; + } + } +} + + +/* ********************************************************************** */ +/* void BVLS1Self( BitVect R ) */ +/* Effectue : R <<= 1 ; */ +/* Version specialisee de BVLShiftSelf pour utilisation frequente. */ +/* ********************************************************************** */ +void BVLS1Self (BitVect * R) +{ + int i; + R->vect[0] <<= 1; + for (i = 1; i < R->n; i++) { + if (R->vect[i] & MC) + R->vect[i - 1] |= 0x1UL; + R->vect[i] <<= 1; + } +} + + +/* ********************************************************************** */ +/* void BVRShiftSelf( BitVect R, int n ) */ +/* Effectue : R >>= n ; */ +/* ********************************************************************** */ +void BVRShiftSelf (BitVect * R, int n) +{ + int i; + int WLmn; + unsigned long temp; + + while (n >= 32) { + for (i = R->n - 1; i > 0; i--) + R->vect[i] = R->vect[i - 1]; + R->vect[0] = 0UL; + n -= 32; + } + if (n > 0) { + WLmn = WL - n; + R->vect[R->n - 1] >>= n; + for (i = R->n - 2; i >= 0; i--) { + temp = R->vect[i] << WLmn; + R->vect[i + 1] |= temp; + R->vect[i] >>= n; + } + } +} + + +/* ********************************************************************** */ +/* void invertBV(Bitvect A) */ +/* fait A ~=A */ +/* ********************************************************************** */ +void InverseBV (BitVect * A) +{ + int i; + for (i = 0; i < A->n; i++) + A->vect[i] = ~A->vect[i]; +} + + +/* ********************************************************************** */ +/* lebool CheckCD( BitVect ds1, BitVect ds2 ) */ +/* Verifie si les ensembles ds1 et ds2 ont des bits communs. */ +/* ********************************************************************** */ +lebool VerifBitsCommuns (BitVect * ds1, BitVect * ds2) +{ + int i; + unsigned long temp = 0UL; + if ((ds1->n != ds2->n)) { + printf ("Error in VerifBitsCommuns(): Vectors of different sizes\n"); + exit (1); + } + for (i = 0; i < ds1->n; i++) + temp |= (ds1->vect[i] & ds2->vect[i]); + if (temp) + return TRUE; + else + return FALSE; +} + + +/* -------------------------------------------- */ +/* Fonctions pour la manipulation des matrices. */ +/* -------------------------------------------- */ +void BVCanonic (BitVect * A, int l) +{ + int n; + PutBVToZero (A); + n = l / WL; + if (n > A->n) { + printf + ("Error in BVCanonic(): vector A is not long enough to store BVCanonic[%d].\n", + l); + exit (1); + } + A->vect[n] = 0x80000000UL >> (l - n * WL); +} + +void Mask (BitVect * A, int l) +{ + + InvMask (A, l); + InverseBV (A); +} + +void InvMask (BitVect * A, int l) +{ + AllOnes (A); + BVRShiftSelf (A, l); +} + +void AllOnes (BitVect * A) +{ + int i; + for (i = 0; i < A->n; i++) + A->vect[i] = 0xffffffffUL; +} + +void AllocBV (BitVect * A, int l) +{ + int n; + n = (l - 1) / WL + 1; + A->vect = (unsigned long *) calloc ((size_t) n, sizeof (unsigned long)); + A->n = n; +} + +void FreeBV (BitVect * A) +{ + if (A->vect != NULL) { + free (A->vect); + } + A->n = 0; +} + +void AllocMat (Matrix * m, int nblines, int l, int t) +{ + int i, j; + m->lignes = (BitVect **) calloc ((size_t) nblines, sizeof (BitVect *)); + for (i = 0; i < nblines; i++) { + if (!(m->lignes[i] = (BitVect *) calloc ((size_t) t, sizeof (BitVect)))) { + printf ("\n*** Memoire insuffisante pour AllocMat() ! nl=%d***\n", + nblines); + exit (1); + } + for (j = 0; j < t; j++) + AllocBV (&(m->lignes[i][j]), l); + + } + m->nblignes = nblines; + m->t = t; + m->l = l; + +} + + +/* ********************************************************************** */ +/* void FreeSpace( Matrix m, int nl ) */ +/* Libere l'espace des nl vecteurs de la matrice m. */ +/* ********************************************************************** */ +void FreeMat (Matrix * m) +{ + int i, j; + for (i = 0; i < m->nblignes; i++) { + for (j = 0; j < m->t; j++) + FreeBV (&(m->lignes[i][j])); + free (m->lignes[i]); + } + free (m->lignes); + m->nblignes = 0; + m->l = 0; + m->t = 0; + +} + + +/* ********************************************************************** */ +/* void CopyMat( Matrix m, Matrix ms, int nl, int t ) */ +/* Cette procedure sert a copier les t premiers BitVect des nl premieres */ +/* lignes de la matrice ms dans la matrice de travail m. */ +/* ********************************************************************** */ +void CopyMat (Matrix * m, Matrix * ms, int nl, int t) +{ + int i, j; + if (m == NULL) { + AllocMat (m, ms->nblignes, ms->l, ms->t); + } else if ((ms->nblignes < nl) || (ms->t < t)) { + printf ("Error in CopyMat(): source matrix too small %d\n", + ms->nblignes / ms->t); + exit (1); + } else if ((m->nblignes < nl) || (m->t < t)) { + printf ("Error in CopyMat(): destination matrix too small\n"); + exit (1); + } + for (i = 0; i < nl; i++) + for (j = 0; j < t; j++) { + CopyBV (&(m->lignes[i][j]), &(ms->lignes[i][j])); + } +} + + +/* ********************************************************************** */ +/* void CopyNTupleMat( Matrix m, Matrix ms, int nl, */ +/* int *colonnes, int t ) */ +/* Cette procedure sert a copier les t-1 BitVect indiqu'es par le vecteur */ +/* *colonnes plus la colonne 0 des nl premieres lignes de la matrice ms */ +/* dans la matrice de travail m. */ +/* ********************************************************************** */ +void CopyNTupleMat (Matrix * m, Matrix * ms, int nl, int *colonnes, int t) +{ + + int i, j, k, n; + + if (m == NULL) + AllocMat (m, ms->nblignes, ms->l, t); + else { + if ((ms->nblignes != m->nblignes) || (ms->l != m->l)) + printf ("Error in CopieNTupleMat(): matrices of different sizes\n"); + } + n = (ms->l - 1) / WL; + for (i = 0; i < nl; i++) { + for (k = 0; k <= n; k++) + (m->lignes[i])[0].vect[k] = (ms->lignes[i])[0].vect[k]; + for (j = 1; j < t; j++) + for (k = 0; k <= n; k++) + (m->lignes[i])[j].vect[k] = + (ms->lignes[i])[colonnes[j - 1]].vect[k]; + + } +} + + +/* ********************************************************************** */ +/* void SwapVect( Matrix m, int i, int j ) */ +/* Pour interchanger les lignes i et j de la matrice de travail m. */ +/* ********************************************************************** */ +void ExchangeVect (Matrix * m, int i, int j) +{ + BitVect *p; + if (i != j) { + p = m->lignes[i]; + m->lignes[i] = m->lignes[j]; + m->lignes[j] = p; + } +} + + +void TransposeMatrices (Matrix * T, Matrix * M, int mmax, int smax, int L) +{ + + int s, l, m; + + for (s = 0; s < smax; s++) + for (l = 0; l < L; l++) { + PutBVToZero (&T->lignes[l][s]); + for (m = 0; m < mmax; m++) { + /* printf("m=%d l=%d s=%d\n",m,l,s);fflush(stdout); */ + if (M->lignes[m][s].vect[0] & (0x80000000UL >> l)) { + T->lignes[l][s].vect[0] |= (0x80000000UL >> m); + } + } + } +} + + +/* ********************************************************************** */ +/* void XorVect( Matrix m, */ +/* int r, int s, int min, int max ) */ +/* Effectue un Xor entre la s-eme et la r-eme ligne de la matrice de */ +/* travail m pour les colonnes (BitVect) min a max-1 seulement. */ +/* Le resultat est mis dans la r-eme ligne. ( m[r] ^= m[s] ) */ +/* ********************************************************************** */ +void XorVect (Matrix * m, int r, int s, int min, int max) +{ + int j; + for (j = min; j < max; j++) + XORBVSelf (&(m->lignes[r][j]), &(m->lignes[s][j])); +} + + +/* ********************************************************************** */ +/* void displaymat(Matrix m, int t, int l, int kg) */ +/* Affiche la matrice m sur kg lignes par t x l colonnes */ +/* ********************************************************************** */ +void DispMat (Matrix * m, int t, int l, int kg, lebool mathematica) +{ + int i, j; + + i = kg; + + printf ("\n"); + if (mathematica) + printf ("{"); + for (i = 0; i < kg; i++) { + if (!mathematica) + printf ("["); + for (j = 0; j < t; j++) { + DispBitVect (&(m->lignes[i][j]), l, mathematica); + } + if (mathematica) { + if (i != kg - 1) + printf (",\n"); + else + printf ("}\n"); + } else + printf ("]\n"); + } + printf ("\n\n"); + +} + + +/* ********************************************************************** */ +/* void displaybitvect(BitVect A, int l) */ +/* Affiche le BitVect A sur l bits seulement */ +/* ********************************************************************** */ +void DispBitVect (BitVect * A, int l, int mathematica) +{ + int j; + unsigned Un; + Un = 1UL; + j = 0; + if (mathematica) { + printf ("{"); + while (j < l - 1) { + printf ("%ld,", + (A->vect[j / WL] >> (((WL * A->n) - j - 1) % WL)) & Un); + j++; + } + printf ("%ld}", (A->vect[j / WL] >> (((WL * A->n) - j - 1) % WL)) & Un); + } else + while (j < l) { + printf ("%ld", + (A->vect[j / WL] >> (((WL * A->n) - j - 1) % WL)) & Un); + j++; + } +} + + +/* ********************************************************************** */ +/* MultMatrixByMatrix ( Matrix *A, Matrix *B, Matrix *C) */ +/* Fait la multiplication matricielle A = B x C */ +/* ********************************************************************** */ + +void MultMatrixByMatrix (Matrix * A, Matrix * B, Matrix * C) +{ + int i, j; + if (B->l != C->nblignes) { + printf ("Tailles de matrices non-compatibles, kaput.\n"); + exit (1); + } + + if (A->nblignes != B->nblignes || A->l != C->l) { + printf ("Matrice preallouee de mauvaise taille.\n"); + exit (1); + } + + for (i = 0; i < A->nblignes; i++) + PutBVToZero (A->lignes[i]); + + for (i = 0; i < B->nblignes; i++) + for (j = 0; j < B->l; j++) { + if (ValBitBV (B->lignes[i], j)) + XORBVSelf (A->lignes[i], C->lignes[j]); + } +} + + +/* ********************************************************************** */ +/* MatrixTwoPow ( Matrix *A, Matrix *B, unsigned int e) */ +/* Fait l'exponentiation : A = B^(2^e) */ +/* ********************************************************************** */ + +void MatrixTwoPow (Matrix * A, Matrix * B, unsigned int e) +{ + unsigned int i; + Matrix tempMatrix; + Matrix *AA = &tempMatrix; + + if (B->nblignes != B->l) { + printf ("Matrice non carree.\n"); + exit (1); + } + if (A->nblignes != B->nblignes || A->l != B->l) { + printf ("Matrice preallouee de mauvaise taille.\n"); + exit (1); + } + + AllocMat (AA, B->nblignes, B->l, 1); + + if (e == 0) { + CopyMat (A, B, B->nblignes, 1); + return; + } + /* A = B^(2^1) */ + MultMatrixByMatrix (A, B, B); + + for (i = 1; i < e - 1; i += 2) { + /* AA = A * A */ + MultMatrixByMatrix (AA, A, A); + + /* A = AA * AA */ + MultMatrixByMatrix (A, AA, AA); + } + + if (i == e - 1) { + /* AA = A * A */ + MultMatrixByMatrix (AA, A, A); + CopyMat (A, AA, AA->nblignes, 1); + } + + FreeMat (AA); +} + +/* ********************************************************************** */ +/* MatrixPow ( Matrix *A, Matrix *B, unsigned int e) */ +/* Fait l'exponentiation : A = B^e */ +/* ********************************************************************** */ + +#ifdef USE_LONGLONG +void MatrixPow (Matrix * A, Matrix * B, longlong e) +#else +void MatrixPow (Matrix * A, Matrix * B, long e) +#endif +{ + int i; + Matrix C; + Matrix D; + + if (B->nblignes != B->l) { + printf ("Matrice non carree.\n"); + exit (1); + } + + if (A->nblignes != B->nblignes || A->l != B->l) { + printf ("Matrice preallouee de mauvaise taille.\n"); + exit (1); + } + + AllocMat (&C, B->nblignes, B->l, 1); + + if (e < 0) { + InverseMatrix (&C, B); + MatrixPow (A, &C, -e); + FreeMat (&C); + return; + } + AllocMat (&D, B->nblignes, B->l, 1); + + /* A = I */ + for (i = 0; i < A->nblignes; i++) + BVCanonic (A->lignes[i], i); + + /* C = B^1 */ + CopyMat (&C, B, B->nblignes, 1); + + while (e) { + if (e & 1) { + CopyMat (&D, A, B->nblignes, 1); + MultMatrixByMatrix (A, &D, &C); + } + + e >>= 1; + + if (e) { + CopyMat (&D, &C, B->nblignes, 1); + MultMatrixByMatrix (&C, &D, &D); + } + } + + FreeMat (&C); + FreeMat (&D); +} + + +/* FIN vectorsF2.c */ diff --git a/cbits/testu/src/wdist.c b/cbits/testu/src/wdist.c new file mode 100644 --- /dev/null +++ b/cbits/testu/src/wdist.c @@ -0,0 +1,55 @@ +/*************************************************************************\ + * + * Package: ProbDist + * File: wdist.c + * Environment: ANSI C + * + * Copyright (c) 2002 Pierre L'Ecuyer, DIRO, Université de Montréal. + * e-mail: lecuyer@iro.umontreal.ca + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted without a fee for private, research, + * academic, or other non-commercial purposes. + * Any use of this software in a commercial environment requires a + * written licence from the copyright owner. + * + * Any changes made to this package must be clearly identified as such. + * + * In scientific publications which used this software, a reference to it + * would be appreciated. + * + * Redistributions of source code must retain this copyright notice + * and the following disclaimer. + * + * THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED + * WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + * +\*************************************************************************/ + +#include "wdist.h" +#include "fdist.h" + + + +/*=========================================================================*/ + +double wdist_Normal (double Junk[], double x) +{ + return fdist_Normal2 (x); +} + + +double wdist_ChiSquare (double W[], double x) +{ + long N = (long) W[0]; + return fdist_ChiSquare2 (N, 12, x); +} + + +double wdist_Unif (double Junk[], double x) +{ + return fdist_Unif (x); +} + diff --git a/htestu.cabal b/htestu.cabal new file mode 100644 --- /dev/null +++ b/htestu.cabal @@ -0,0 +1,44 @@ +-- Initial htestu.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: htestu +version: 0.1.0.0 +synopsis: A library for testing correctness of pseudo random number generators in Haskell. +description: + HTestU is a library for testing correctness of presudo random number generators (PRNGs) written in Haskell. + HTestU uses a library TestU01 based on a paper "TestU01: A C Library for Empirical Testing of Random Number Generators" by P. L'Ecuyer and R. Simard. + Basically HTestU performs a wrapping of a member of the RandomGen typeclass (any reasonable PRNG can be made a member of it) and + feeds a wrapped generator into a C library which calls the wrapped generator to fill the buffer with pseudo random numbers and then + perform tests on the generated numbers. + + HTestU offers three batteries: smallCrush, crush and bigCrush (as they were specified in TestU01 paper) and a number of + streaming functions which allow one to wrap the PRNG differently for the purpose of testing different patterns of PRNG usage. + +homepage: https://github.com/nkartashov/htestu +license: MIT +license-file: LICENSE +author: Nikita Kartashov +maintainer: snailandmail@gmail.com +category: System +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/idontgetoutmuch/htestu + +library + exposed-modules: Test.HTestU, + Test.HTestU.Streaming, + Test.HTestU.BatteryResult, + Test.HTestU.Wrapping + other-extensions: ForeignFunctionInterface, CPP + build-depends: base >=4.7 && < 4.10, + random + + hs-source-dirs: src + build-tools: gcc, hsc2hs + default-language: Haskell2010 + include-dirs: cbits/testu/include + c-sources: cbits/testu/src/util.c cbits/testu/src/chrono.c cbits/testu/src/bitset.c cbits/testu/src/num.c cbits/testu/src/num2.c cbits/testu/src/mystr.c cbits/testu/src/tables.c cbits/testu/src/statcoll.c cbits/testu/src/gofs.c cbits/testu/src/gofw.c cbits/testu/src/gdef.c cbits/testu/src/vectorsF2.c cbits/testu/src/swrite.c cbits/testu/src/wdist.c cbits/testu/src/smultin.c cbits/testu/src/svaria.c cbits/testu/src/swalk.c cbits/testu/src/sstring.c cbits/testu/src/sspectral.c cbits/testu/src/sres.c cbits/testu/src/snpair.c cbits/testu/src/smarsa.c cbits/testu/src/sknuth.c cbits/testu/src/scomp.c cbits/testu/src/ftab.c cbits/testu/src/fres.c cbits/testu/src/fmass.c cbits/testu/src/fdist.c cbits/testu/src/fcho.c cbits/testu/src/fbar.c cbits/testu/src/fmarsa.c cbits/testu/src/ufile.c cbits/testu/src/unif01.c cbits/testu/src/bbattery.c + ghc-options: -O2 diff --git a/src/Test/HTestU.hs b/src/Test/HTestU.hs new file mode 100644 --- /dev/null +++ b/src/Test/HTestU.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Test.HTestU + ( TestResult + , runBattery + , toResults + , runBatteryToResults + , c_smallCrush + , c_crush + , c_bigCrush + ) where + +import System.Random (RandomGen) + +import Foreign.Marshal.Alloc (free) +import Foreign.Marshal.Array (peekArray) +import Foreign.Storable (peek) +import Foreign.Ptr (freeHaskellFunPtr) + +import System.IO.Unsafe (unsafePerformIO) + +import Test.HTestU.Wrapping (Battery, genToWrappedCallback, c_createGenerator, c_deleteGenerator) +import Test.HTestU.BatteryResult (BatteryResultStruct(..)) +import Test.HTestU.Streaming (RandomStream) + +-- | Type for presenting a result of a test, instead of a p-value +data TestResult = Fail | Suspect | OK deriving (Eq, Show) + +-- | P-value serving as a border for a failure in TestU01, greater => failure or suspicious value +failurePvalue :: Double +failurePvalue = 0.0000000001 -- 10^(-10) + +-- | P-value serving as a border for a suspicious value in TestU01, greater => failure +suspectPvalue :: Double +suspectPvalue = 0.001 -- 10^(-3) + +-- | Prettifying a p-value to a test result +pValueToResult :: Double -> TestResult +pValueToResult pvalue | pvalue < failurePvalue || pvalue > 1.0 - failurePvalue = Fail + | pvalue < suspectPvalue || pvalue > 1.0 - suspectPvalue = Suspect + | otherwise = OK + +-- | Prettifying a list of result p-values +toResults :: [Double] -> [TestResult] +toResults = map pValueToResult + +-- | Run a given battery and present pretty results +runBatteryToResults :: RandomGen g => (g -> RandomStream) -> g -> Battery -> [TestResult] +runBatteryToResults = ((toResults .) .) . runBattery + +-- | Run a given battery and present resulting p-values +-- NOTE: returns [Double] instead of IO [Double], because it is transparent (for the same gen result should be the same) +runBattery :: RandomGen g => (g -> RandomStream) -> g -> Battery -> [Double] +runBattery streamer gen crush = unsafePerformIO $ do + callback <- genToWrappedCallback streamer gen + generatorPtr <- c_createGenerator callback + batteryResult <- crush generatorPtr + (BR ps tests) <- peek batteryResult + c_deleteGenerator generatorPtr + freeHaskellFunPtr callback + free batteryResult + cDoublePvalues <- peekArray (fromIntegral tests) ps + return $ map realToFrac cDoublePvalues +{-# NOINLINE runBattery #-} + +-- | Runs SmallCrush battery, 10 tests +foreign import ccall safe "bbattery_SmallCrush" c_smallCrush :: Battery + +-- | Runs Crush battery, 96 tests +foreign import ccall safe "bbattery_Crush" c_crush :: Battery + +-- | Runs BigCrush Battery, 106 tests +foreign import ccall safe "bbattery_BigCrush" c_bigCrush :: Battery diff --git a/src/Test/HTestU/BatteryResult.hsc b/src/Test/HTestU/BatteryResult.hsc new file mode 100644 --- /dev/null +++ b/src/Test/HTestU/BatteryResult.hsc @@ -0,0 +1,34 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP #-} + +module Test.HTestU.BatteryResult +( BatteryResultStruct(..) +) where + +import Foreign.C.Types (CInt(..), CDouble(..)) +import Foreign.Ptr (Ptr) +import Foreign.Storable + +#include "bbattery.h" + +-- | Structure holding an array of p-values after performing the testing +-- and their number +data BatteryResultStruct = BR { + pValues :: Ptr CDouble, + testNumber :: CInt + } deriving (Eq, Show) + +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) + +instance Storable BatteryResultStruct where + sizeOf _ = (#size BatteryResult) + alignment _ = #{alignment BatteryResult} + peek ptr = do + pValues <- (#peek BatteryResult, pValues) ptr + testNumber <- (#peek BatteryResult, testNumber) ptr + return $ BR pValues testNumber + + poke ptr (BR pValues testNumber) = do + #{poke BatteryResult, pValues} ptr pValues + #{poke BatteryResult, testNumber} ptr testNumber + diff --git a/src/Test/HTestU/Streaming.hs b/src/Test/HTestU/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Test/HTestU/Streaming.hs @@ -0,0 +1,58 @@ +module Test.HTestU.Streaming + ( RandomStream + , nextStreamFromGen + , splitNextStreamFromGen + , leftSplitStreamFromGen + , rightSplitStreamFromGen + ) where + +import System.Random (RandomGen, next, split) +import Data.Tuple (swap) + +-- | Synonym for an infinite stream of random numbers +type RandomStream = [Int] + +-- | Endomorphic wrapper for 'next' function +wrappedNext :: RandomGen g => (Int, g) -> (Int, g) +wrappedNext (_, newGen) = next newGen + +-- | Generates a stream from a PRNG by using a repeated 'next' application +nextStreamFromGen :: RandomGen g => g -> RandomStream +nextStreamFromGen gen = map fst $ iterate wrappedNext firstStreamElement + where firstStreamElement = next gen + +-- | Generates a stream from a PRNG by using 'split' and a provided choose function +splitStreamFromGen :: RandomGen g => ((g, g) -> (g, g)) -> g -> RandomStream +splitStreamFromGen choose gen = let (old, new) = choose $ split gen + (value, _) = next old + in value : splitStreamFromGen choose new + +-- | Does nothing to the provided pair of generators +goLeft :: (g, g) -> (g, g) +goLeft = id + +-- | Swaps the generators so they change roles +goRight :: (g, g) -> (g, g) +goRight = swap + +-- | Generates a stream from a PRNG by using 'split' and a left generator to +-- produce a next random number +leftSplitStreamFromGen :: RandomGen g => g -> RandomStream +leftSplitStreamFromGen = splitStreamFromGen goLeft + +-- | Generates a stream from a PRNG by using 'split' and a right generator to +-- produce a next random number +rightSplitStreamFromGen :: RandomGen g => g -> RandomStream +rightSplitStreamFromGen = splitStreamFromGen goRight + +-- | Splits a provided generator and intertwines the generated random streams +splitNextStreamFromGen :: RandomGen g => g -> RandomStream +splitNextStreamFromGen gen = intertwineStreams (nextStreamFromGen leftGen) $ nextStreamFromGen rightGen + where (leftGen, rightGen) = split gen + +-- | Returns a new stream of elements in which elements from two given streams +-- alternate +intertwineStreams :: [a] -> [a] -> [a] +intertwineStreams [] ys = ys +intertwineStreams xs [] = xs +intertwineStreams (x : xs) (y : ys) = x : y : intertwineStreams xs ys diff --git a/src/Test/HTestU/Wrapping.hs b/src/Test/HTestU/Wrapping.hs new file mode 100644 --- /dev/null +++ b/src/Test/HTestU/Wrapping.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Test.HTestU.Wrapping + ( Battery + , WrappedCallback + , c_createGenerator + , c_deleteGenerator + , genToWrappedCallback + , streamToWrappedCallback + , randomStreamActionToWrappedCallback + ) where + +import System.Random (RandomGen) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.C.Types (CUInt(..)) +import Foreign.Marshal.Array (pokeArray) + +import Test.HTestU.Streaming (RandomStream) +import Test.HTestU.BatteryResult (BatteryResultStruct(..)) + +-- | A token type of a C structure of a PRNG, is not used directly +data UniformGenerator + +-- | Result of running a battery - IO action giving the caller a C struct with +-- resulting p-values describing the results of run tests +type BatteryResult = IO (Ptr BatteryResultStruct) + +-- | Battery takes a wrapped generator and produces p-values as a result of its testing +type Battery = Ptr UniformGenerator -> BatteryResult + +-- | Function which fills the array with numbers +-- given size and a pointer to it +type Callback = CUInt -> Ptr CUInt -> IO () + +-- | Wrapped 'Callback' function for calling from C +type WrappedCallback = FunPtr Callback + +-- | C function allocating a PRNG on C side, given a callback wrapping it +foreign import ccall safe "unif01_CreateExternGenBits" c_createGenerator :: WrappedCallback -> IO (Ptr UniformGenerator) + +-- | Complimentary deallocating function to 'c_createGenerator' +foreign import ccall unsafe "unif01_DeleteExternGenBits" c_deleteGenerator :: Ptr UniformGenerator -> IO () + +-- | Wrapper function for porting callback to C +foreign import ccall unsafe "wrapper" mkCallback :: Callback -> IO WrappedCallback + +-- | Wraps the given RandomGen into a C callback +genToWrappedCallback :: RandomGen g => (g -> RandomStream) -> g -> IO WrappedCallback +genToWrappedCallback streamer gen = streamToWrappedCallback $ streamer gen + +-- | Wraps an stream of numbers into a C callback +streamToWrappedCallback :: RandomStream -> IO WrappedCallback +streamToWrappedCallback stream = newIORef stream >>= mkCallback . nextIntFromStreamRef + +-- | Wraps an stream of numbers produced by a stream of numbers into a C callback +randomStreamActionToWrappedCallback :: IO RandomStream -> IO WrappedCallback +randomStreamActionToWrappedCallback action = action >>= streamToWrappedCallback + +-- | Takes an allocated reference to a stream of numbers produces a Callback +-- for passing to C code +nextIntFromStreamRef :: IORef RandomStream -> Callback +nextIntFromStreamRef streamRef (CUInt values) arrayPtr = do + randomNumbers <- readIORef streamRef + let (toDump, rest) = splitAt (fromIntegral values) randomNumbers + writeIORef streamRef rest + pokeArray arrayPtr $ map fromIntegral toDump