SEXP d2q(SEXP foo)
{
if (! isReal(foo))
error("argument must be real");
int n = LENGTH(foo);
int i;
for (i = 0; i < n; i++)
if (! R_finite(REAL(foo)[i]))
error("argument not finite-valued");
SEXP bar, bark;
PROTECT(bar = allocVector(STRSXP, n));
PROTECT(bark = ATTRIB(foo));
if (bark != R_NilValue)
SET_ATTRIB(bar, duplicate(bark));
UNPROTECT(1);
mpq_t value;
mpq_init(value);
int k;
for (k = 0; k < n; k++) {
double z = REAL(foo)[k];
mpq_set_d(value, z);
char *zstr = NULL;
zstr = mpq_get_str(zstr, 10, value);
SET_STRING_ELT(bar, k, mkChar(zstr));
free(zstr);
}
mpq_clear(value);
UNPROTECT(1);
return(bar);
}
void
check_random (int argc, char **argv)
{
double d, d2, nd, dd;
mpq_t q;
mp_limb_t rp[LIMBS_PER_DOUBLE + 1];
int test, reps = 100000;
int i;
if (argc == 2)
reps = 100 * atoi (argv[1]);
mpq_init (q);
for (test = 0; test < reps; test++)
{
mpn_random2 (rp, LIMBS_PER_DOUBLE + 1);
d = 0.0;
for (i = LIMBS_PER_DOUBLE - 1; i >= 0; i--)
d = d * MP_BASE_AS_DOUBLE + rp[i];
d = my_ldexp (d, (int) (rp[LIMBS_PER_DOUBLE] % (2 * MAXEXP)) - MAXEXP);
mpq_set_d (q, d);
nd = mpz_get_d (mpq_numref (q));
dd = mpz_get_d (mpq_denref (q));
d2 = nd / dd;
if (d != d2)
{
printf ("ERROR (check_random test %d): bad mpq_set_d results\n", test);
printf ("%.16g\n", d);
printf ("%.16g\n", d2);
abort ();
}
}
mpq_clear (q);
}
static void
set_mpq_t_from_double(mpq_t q, double d) {
if (check_results)
set_d_eps(q, d);
else
mpq_set_d(q, d);
}
int
promoteToMPQNumber(number *n)
{ switch(n->type)
{ case V_INTEGER:
promoteToMPZNumber(n);
/*FALLTHOURGH*/
case V_MPZ:
{ n->value.mpq->_mp_num = n->value.mpz[0];
mpz_init_set_ui(mpq_denref(n->value.mpq), 1L);
n->type = V_MPQ;
break;
}
case V_MPQ:
break;
case V_FLOAT:
{ double v = n->value.f;
n->type = V_MPQ;
mpq_init(n->value.mpq);
mpq_set_d(n->value.mpq, v);
break;
}
}
return TRUE;
}
/* Function to generate the hypergeometric pdf */
void hypergeometricpdf(mpfr_t *out,mpz_t mu, mpz_t d,unsigned int mi,unsigned int conns,unsigned int phi, mpz_t bc_b_ai[], mpz_t mu_bc[])
{
unsigned int dini=(unsigned int)conns;
unsigned int dmax=(unsigned int)conns;
mpz_t bcm_b_ai;
mpz_init(bcm_b_ai);
mpq_t quotient;
mpq_init(quotient);
unsigned int odex=0;
unsigned int di;
// unsigned int phi;
unsigned int bi;
unsigned int ai_cnt;
//loop over d, phi and beta
for(di=dini;di<=dmax;di=di++)
{
//for(phi=1;phi<=di;phi++)
//{
for(bi=0;bi<=mi;bi++)
{
for(ai_cnt=phi;ai_cnt<=di;ai_cnt++)
{
if((mi-bi)<=0) //Then the number of successful picks is the number of draws with probability 1
{
if(ai_cnt==di)
mpq_set_d(quotient,1);
else
mpq_set_d(quotient,0);
}
else
{
mpz_mul(bcm_b_ai,bc_b_ai[bi*(dmax+1)+(ai_cnt)],bc_b_ai[(mi-bi)*(dmax+1)+(di-ai_cnt)]);
mpq_set_num(quotient, bcm_b_ai);
mpq_set_den(quotient, mu_bc[di-1]);
mpq_canonicalize(quotient);
}
mpfr_set_q(*(out+odex),quotient,MPFR_RNDN);
odex++; //Address array with simple counter increment;
}
}
//}
}
mpz_clear(bcm_b_ai);
mpq_clear(quotient);
}
Rational::Rational(const int precision, const double num)
{
mpq_init(number);
mpq_set_d(number, num);
#ifdef TRACE_OUTPUT
UpdateNumberStr();
#endif
}
static void from_double(mpq_t n, double f, int level)
{
double fa;
int nfa;
mpq_t ni, nn;
bool neg;
//fprintf(stderr, "from_double: %.14g\n", f);
if (level >= 10)
goto __DEFAULT;
fa = fabs(f);
if (fa >= 1E8 || fa <= 1E-8)
goto __DEFAULT;
neg = (f < 0);
nfa = (int)fa;
if (nfa >= 1)
fa -= nfa;
//fprintf(stderr, "fa = %.14g %.14g\n", fa, (fa*1E8) - (int)(fa*1E8));
if (nfa && fa < 1E-8)
{
mpq_set_si(n, 0, 1);
}
else if (((fa*1E8) - (int)(fa*1E8)) < 1E-8)
{
mpq_set_si(n, (int)(fa*1E8), 100000000);
}
else
{
mpq_init(ni);
from_double(ni, 1 / fa, level + 1);
mpq_inv(n, ni);
mpq_clear(ni);
}
mpq_init(nn);
mpq_set_si(nn, nfa, 1);
mpq_add(n, n, nn);
mpq_clear(nn);
if (neg)
mpq_neg(n, n);
mpq_canonicalize(n);
return;
__DEFAULT:
mpq_set_d(n, f);
}
int mpq_mat_is_reduced(mpq_mat_t mu, mpq_mat_t GS, double delta, double eta){
//want to return 1 if this data could come from a reduced matrix 0 otherwise
mpq_mat_t gs_len;
mpq_mat_init( gs_len, 1, GS->c);
mpq_t temp, temp1, temp2;
mpq_init(temp);
mpq_init(temp1);
mpq_init(temp2);
long i, j;
int result = 1;
for (i = 0; (i < GS->r) && (result == 1); i++){
mpq_mat_row_inner_product(gs_len->entries[i], GS, i, GS, i);
if (i > 0){
mpq_div(temp, gs_len->entries[i], gs_len->entries[i-1]);
mpq_mul(temp1, mu->entries[i*mu->r + i-1], mu->entries[i*mu->r + i-1]);
mpq_add(temp, temp, temp1);
mpq_set_d(temp1, delta - eta*eta);
if (mpq_cmp(temp, temp1) < 0){
result = 0;
}
else{
mpq_set_d(temp2, eta);
for( j = 0 ; (j < i) && (result == 1); j++)
if ( mpq_cmp( mu->entries[i*mu->r + j], temp2) >= 0){
result = 0;
}
}
// if temp < (3/4 or 1/(delta - eta^2))==temp1 then not reduced...
}
}
mpq_clear(temp);
mpq_clear(temp1);
mpq_clear(temp2);
mpq_mat_clear(gs_len);
return result;
}
void
check_random (int argc, char **argv)
{
gmp_randstate_ptr rands = RANDS;
double d;
mpq_t q;
mpz_t a, t;
int exp;
int test, reps = 100000;
if (argc == 2)
reps = 100 * atoi (argv[1]);
mpq_init (q);
mpz_init (a);
mpz_init (t);
for (test = 0; test < reps; test++)
{
mpz_rrandomb (a, rands, 53);
mpz_urandomb (t, rands, 32);
exp = mpz_get_ui (t) % (2*MAXEXP) - MAXEXP;
d = my_ldexp (mpz_get_d (a), exp);
mpq_set_d (q, d);
/* Check that n/d = a * 2^exp, or
d*a 2^{exp} = n */
mpz_mul (t, a, mpq_denref (q));
if (exp > 0)
mpz_mul_2exp (t, t, exp);
else
{
if (!mpz_divisible_2exp_p (t, -exp))
goto fail;
mpz_div_2exp (t, t, -exp);
}
if (mpz_cmp (t, mpq_numref (q)) != 0)
{
fail:
printf ("ERROR (check_random test %d): bad mpq_set_d results\n", test);
printf ("%.16g\n", d);
gmp_printf ("%Qd\n", q);
abort ();
}
}
mpq_clear (q);
mpz_clear (t);
mpz_clear (a);
}
APLRAT PrimFnMonDownStileRisR
(APLRAT aplRatRht,
LPPRIMSPEC lpPrimSpec)
{
APLRAT mpqRes = {0},
mpqFloor = {0},
mpqCeil = {0},
mpqTmp1 = {0},
mpqTmp2 = {0},
mpqNear = {0};
// Check for PoM infinity
if (IsMpqInfinity (&aplRatRht))
// Copy to the result
mpq_init_set (&mpqRes, &aplRatRht);
else
{
// Initialize the temps
mpq_init (&mpqRes);
mpq_init (&mpqFloor);
mpq_init (&mpqCeil );
mpq_init (&mpqTmp1);
mpq_init (&mpqTmp2);
mpq_init (&mpqNear);
// Get the exact floor and ceiling
mpq_floor (&mpqFloor, &aplRatRht);
mpq_ceil (&mpqCeil , &aplRatRht);
// Calculate the integer nearest the right arg
mpq_sub (&mpqTmp1, &aplRatRht, &mpqFloor);
mpq_sub (&mpqTmp2, &mpqCeil , &aplRatRht);
// Split cases based upon the signum of the difference between
// (the number and its floor) and (the ceiling and the number)
switch (signumint (mpq_cmp (&mpqTmp1, &mpqTmp2)))
{
case 1:
mpq_set (&mpqNear, &mpqCeil);
break;
case 0:
mpq_abs (&mpqTmp1, &mpqFloor);
mpq_abs (&mpqTmp2, &mpqFloor);
// They are equal, so use the one with the larger absolute value
mpq_set (&mpqNear, ((mpq_cmp (&mpqTmp1, &mpqTmp2) > 0) ? &mpqFloor
: &mpqCeil));
break;
case -1:
mpq_set (&mpqNear, &mpqFloor);
break;
defstop
break;
} // End SWITCH
// If Near is < Rht, return Near
if (mpq_cmp (&mpqNear, &aplRatRht) < 0)
mpq_set (&mpqRes, &mpqNear);
else
{
// If Near is non-zero, and
// Rht is tolerantly-equal to Near,
// return Near; otherwise, return Near - 1
if (mpq_sgn (&mpqNear) NE 0)
{
mpq_set (&mpqRes, &mpqNear);
if (!PrimFnDydEqualBisRvR (aplRatRht,
mpqNear,
NULL))
mpq_sub_ui (&mpqRes, &mpqRes, 1, 1);
} else
{
// mpfNear is zero
// Get -[]CT as a VFP
mpq_set_d (&mpqTmp1, -GetQuadCT ());
// If Rht is between (-[]CT) and 0 (inclusive),
// return 0; otherwise, return -1
if (mpq_cmp (&mpqTmp1, &aplRatRht) <= 0
&& mpq_sgn (&aplRatRht) <= 0)
mpq_set_si (&mpqRes, 0, 1);
else
mpq_set_si (&mpqRes, -1, 1);
} // End IF/ELSE
} // End IF/ELSE
// We no longer need this storage
Myq_clear (&mpqNear);
Myq_clear (&mpqTmp2);
Myq_clear (&mpqTmp1);
Myq_clear (&mpqCeil);
Myq_clear (&mpqFloor);
} // End IF/ELSE
return mpqRes;
} // End PrimFnMonDownStileRisR
void AB_Value_SetValueFromDouble(AB_VALUE *v, double i) {
assert(v);
mpq_set_d(v->value, i);
}
void
check_monotonic (int argc, char **argv)
{
mpq_t a;
mp_size_t size;
int reps = 100;
int i, j;
double last_d, new_d;
mpq_t qlast_d, qnew_d;
mpq_t eps;
if (argc == 2)
reps = atoi (argv[1]);
/* The idea here is to test the monotonousness of mpq_get_d by adding
numbers to the numerator and denominator. */
mpq_init (a);
mpq_init (eps);
mpq_init (qlast_d);
mpq_init (qnew_d);
for (i = 0; i < reps; i++)
{
size = urandom () % SIZE - SIZE/2;
mpz_random2 (mpq_numref (a), size);
do
{
size = urandom () % SIZE - SIZE/2;
mpz_random2 (mpq_denref (a), size);
}
while (mpz_cmp_ui (mpq_denref (a), 0) == 0);
mpq_canonicalize (a);
last_d = mpq_get_d (a);
mpq_set_d (qlast_d, last_d);
for (j = 0; j < 10; j++)
{
size = urandom () % EPSIZE + 1;
mpz_random2 (mpq_numref (eps), size);
size = urandom () % EPSIZE + 1;
mpz_random2 (mpq_denref (eps), size);
mpq_canonicalize (eps);
mpq_add (a, a, eps);
mpq_canonicalize (a);
new_d = mpq_get_d (a);
if (last_d > new_d)
{
printf ("\nERROR (test %d/%d): bad mpq_get_d results\n", i, j);
printf ("last: %.16g\n", last_d);
printf (" new: %.16g\n", new_d); dump (a);
abort ();
}
mpq_set_d (qnew_d, new_d);
MPQ_CHECK_FORMAT (qnew_d);
if (mpq_cmp (qlast_d, qnew_d) > 0)
{
printf ("ERROR (test %d/%d): bad mpq_set_d results\n", i, j);
printf ("last: %.16g\n", last_d); dump (qlast_d);
printf (" new: %.16g\n", new_d); dump (qnew_d);
abort ();
}
last_d = new_d;
mpq_set (qlast_d, qnew_d);
}
}
mpq_clear (a);
mpq_clear (eps);
mpq_clear (qlast_d);
mpq_clear (qnew_d);
}
void Lib_Mpq_Set_D(MpqPtr x, double d)
{
mpq_set_d ((mpq_ptr)x, d);
}
Rational::Rational(double val)
{
mpq_init(number);
mpq_set_d(number, val);
mpq_canonicalize(number);
}
