value value_drop(value op, value n)
{
if (op.type == VALUE_NIL) {
return value_init_nil();
} else if (op.type == VALUE_ARY) {
if (n.type == VALUE_MPZ) {
value length = value_set_long(op.core.u_a.length);
value res = value_range(op, n, length);
value_clear(&length);
return res;
}
} else if (op.type == VALUE_LST) {
if (n.type == VALUE_MPZ) {
if (value_lt(n, value_zero)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (>= 0 expected).", n);
return value_init_error();
} else if (value_gt(n, value_int_max)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (<= %s expected).", n, value_int_max);
return value_init_error();
}
size_t i, max = value_get_long(n);
value ptr = op;
for (i = 0; i < max && ptr.type == VALUE_LST; ++i) {
ptr = ptr.core.u_l[1];
}
return value_set(ptr);
}
} else if (op.type == VALUE_PAR) {
if (n.type == VALUE_MPZ) {
if (value_lt(n, value_zero)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (>= 0 expected).", n);
return value_init_error();
} else if (value_gt(n, value_int_max)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (<= %s expected).", n, value_int_max);
return value_init_error();
}
size_t i, max = value_get_long(n);
value ptr = op;
for (i = 0; i < max && ptr.type == VALUE_PAR; ++i) {
ptr = ptr.core.u_p->tail;
}
return value_set(ptr);
}
} else {
value_error(1, "Type Error: drop() is undefined where op1 is %ts (array or list expected).", op);
if (n.type == VALUE_MPZ)
return value_init_error();
}
value_error(1, "Type Error: drop() is undefined where op2 is %ts (integer expected).", n);
return value_init_error();
}
/*
* Return the component of 'p' with minimum non-zero absolute value. 'index'
* points to the component index that has the minimum value. If no such value
* and index is found, Value 1 is returned.
*/
void Vector_Min_Not_Zero(Value *p,unsigned length,int *index,Value *min)
{
Value aux;
int i;
i = First_Non_Zero(p, length);
if (i == -1) {
value_set_si(*min,1);
return;
}
*index = i;
value_absolute(*min, p[i]);
value_init(aux);
for (i = i+1; i < length; i++) {
if (value_zero_p(p[i]))
continue;
value_absolute(aux, p[i]);
if (value_lt(aux,*min)) {
value_assign(*min,aux);
*index = i;
}
}
value_clear(aux);
} /* Vector_Min_Not_Zero */
/*
* Find the longest sum of consecutive primes that add up to a prime number
* below one million.
*/
int consecutive_primes()
{
value primes = value_init(VALUE_ARY);
value i, million = value_set_long(1000000);
for (i = value_set_long(0); value_lt(i, million); value_inc_now(&i))
if (value_probab_prime_p(i))
value_append_now(&primes, i);
return 0;
}
/*---------------------------------------------------------------------*/
static int exist_points(int pos,Polyhedron *Pol,Value *context) {
Value LB, UB, k,tmp;
value_init(LB); value_init(UB);
value_init(k); value_init(tmp);
value_set_si(LB,0);
value_set_si(UB,0);
/* Problem if UB or LB is INFINITY */
if (lower_upper_bounds(pos,Pol,context,&LB,&UB) !=0) {
errormsg1("exist_points", "infdom", "infinite domain");
value_clear(LB);
value_clear(UB);
value_clear(k);
value_clear(tmp);
return -1;
}
value_set_si(context[pos],0);
if(value_lt(UB,LB)) {
value_clear(LB);
value_clear(UB);
value_clear(k);
value_clear(tmp);
return 0;
}
if (!Pol->next) {
value_subtract(tmp,UB,LB);
value_increment(tmp,tmp);
value_clear(UB);
value_clear(LB);
value_clear(k);
return (value_pos_p(tmp));
}
for (value_assign(k,LB);value_le(k,UB);value_increment(k,k)) {
/* insert k in context */
value_assign(context[pos],k);
if (exist_points(pos+1,Pol->next,context) > 0 ) {
value_clear(LB); value_clear(UB);
value_clear(k); value_clear(tmp);
return 1;
}
}
/* Reset context */
value_set_si(context[pos],0);
value_clear(UB); value_clear(LB);
value_clear(k); value_clear(tmp);
return 0;
}
enum lp_result PL_polyhedron_opt(Polyhedron *P, Value *obj, Value denom,
enum lp_dir dir, Value *opt)
{
int i;
int first = 1;
Value val, d;
enum lp_result res = lp_empty;
POL_ENSURE_VERTICES(P);
if (emptyQ(P))
return res;
value_init(val);
value_init(d);
for (i = 0; i < P->NbRays; ++ i) {
Inner_Product(P->Ray[i]+1, obj, P->Dimension+1, &val);
if (value_zero_p(P->Ray[i][0]) && value_notzero_p(val)) {
res = lp_unbounded;
break;
}
if (value_zero_p(P->Ray[i][1+P->Dimension])) {
if ((dir == lp_min && value_neg_p(val)) ||
(dir == lp_max && value_pos_p(val))) {
res = lp_unbounded;
break;
}
} else {
res = lp_ok;
value_multiply(d, denom, P->Ray[i][1+P->Dimension]);
if (dir == lp_min)
mpz_cdiv_q(val, val, d);
else
mpz_fdiv_q(val, val, d);
if (first || (dir == lp_min ? value_lt(val, *opt) :
value_gt(val, *opt)))
value_assign(*opt, val);
first = 0;
}
}
value_clear(d);
value_clear(val);
return res;
}
/*
* Basic hermite engine
*/
static int hermite(Matrix *H,Matrix *U,Matrix *Q) {
int nc, nr, i, j, k, rank, reduced, pivotrow;
Value pivot,x,aux;
Value *temp1, *temp2;
/* T -1 T */
/* Computes form: A = Q H and U A = H and U = Q */
if (!H) {
errormsg1("Domlib", "nullH", "hermite: ? Null H");
return -1;
}
nc = H->NbColumns;
nr = H->NbRows;
temp1 = (Value *) malloc(nc * sizeof(Value));
temp2 = (Value *) malloc(nr * sizeof(Value));
if (!temp1 ||!temp2) {
errormsg1("Domlib", "outofmem", "out of memory space");
return -1;
}
/* Initialize all the 'Value' variables */
value_init(pivot); value_init(x);
value_init(aux);
for(i=0;i<nc;i++)
value_init(temp1[i]);
for(i=0;i<nr;i++)
value_init(temp2[i]);
#ifdef DEBUG
fprintf(stderr,"Start -----------\n");
Matrix_Print(stderr,0,H);
#endif
for (k=0, rank=0; k<nc && rank<nr; k=k+1) {
reduced = 1; /* go through loop the first time */
#ifdef DEBUG
fprintf(stderr, "Working on col %d. Rank=%d ----------\n", k+1, rank+1);
#endif
while (reduced) {
reduced=0;
/* 1. find pivot row */
value_absolute(pivot,H->p[rank][k]);
/* the kth-diagonal element */
pivotrow = rank;
/* find the row i>rank with smallest nonzero element in col k */
for (i=rank+1; i<nr; i++) {
value_absolute(x,H->p[i][k]);
if (value_notzero_p(x) &&
(value_lt(x,pivot) || value_zero_p(pivot))) {
value_assign(pivot,x);
pivotrow = i;
}
}
/* 2. Bring pivot to diagonal (exchange rows pivotrow and rank) */
if (pivotrow != rank) {
Vector_Exchange(H->p[pivotrow],H->p[rank],nc);
if (U)
Vector_Exchange(U->p[pivotrow],U->p[rank],nr);
if (Q)
Vector_Exchange(Q->p[pivotrow],Q->p[rank],nr);
#ifdef DEBUG
fprintf(stderr,"Exchange rows %d and %d -----------\n", rank+1, pivotrow+1);
Matrix_Print(stderr,0,H);
#endif
}
value_assign(pivot,H->p[rank][k]); /* actual ( no abs() ) pivot */
/* 3. Invert the row 'rank' if pivot is negative */
if (value_neg_p(pivot)) {
value_oppose(pivot,pivot); /* pivot = -pivot */
for (j=0; j<nc; j++)
value_oppose(H->p[rank][j],H->p[rank][j]);
/* H->p[rank][j] = -(H->p[rank][j]); */
if (U)
for (j=0; j<nr; j++)
value_oppose(U->p[rank][j],U->p[rank][j]);
/* U->p[rank][j] = -(U->p[rank][j]); */
if (Q)
for (j=0; j<nr; j++)
value_oppose(Q->p[rank][j],Q->p[rank][j]);
/* Q->p[rank][j] = -(Q->p[rank][j]); */
#ifdef DEBUG
fprintf(stderr,"Negate row %d -----------\n", rank+1);
Matrix_Print(stderr,0,H);
#endif
}
if (value_notzero_p(pivot)) {
/* 4. Reduce the column modulo the pivot */
/* This eventually zeros out everything below the */
/* diagonal and produces an upper triangular matrix */
for (i=rank+1;i<nr;i++) {
value_assign(x,H->p[i][k]);
if (value_notzero_p(x)) {
value_modulus(aux,x,pivot);
/* floor[integer division] (corrected for neg x) */
if (value_neg_p(x) && value_notzero_p(aux)) {
/* x=(x/pivot)-1; */
value_division(x,x,pivot);
value_decrement(x,x);
}
else
value_division(x,x,pivot);
for (j=0; j<nc; j++) {
value_multiply(aux,x,H->p[rank][j]);
value_subtract(H->p[i][j],H->p[i][j],aux);
}
/* U->p[i][j] -= (x * U->p[rank][j]); */
if (U)
for (j=0; j<nr; j++) {
value_multiply(aux,x,U->p[rank][j]);
value_subtract(U->p[i][j],U->p[i][j],aux);
}
/* Q->p[rank][j] += (x * Q->p[i][j]); */
if (Q)
for(j=0;j<nr;j++) {
value_addmul(Q->p[rank][j], x, Q->p[i][j]);
}
reduced = 1;
#ifdef DEBUG
fprintf(stderr,
"row %d = row %d - %d row %d -----------\n", i+1, i+1, x, rank+1);
Matrix_Print(stderr,0,H);
#endif
} /* if (x) */
} /* for (i) */
} /* if (pivot != 0) */
} /* while (reduced) */
/* Last finish up this column */
/* 5. Make pivot column positive (above pivot row) */
/* x should be zero for i>k */
if (value_notzero_p(pivot)) {
for (i=0; i<rank; i++) {
value_assign(x,H->p[i][k]);
if (value_notzero_p(x)) {
value_modulus(aux,x,pivot);
/* floor[integer division] (corrected for neg x) */
if (value_neg_p(x) && value_notzero_p(aux)) {
value_division(x,x,pivot);
value_decrement(x,x);
/* x=(x/pivot)-1; */
}
else
value_division(x,x,pivot);
/* H->p[i][j] -= x * H->p[rank][j]; */
for (j=0; j<nc; j++) {
value_multiply(aux,x,H->p[rank][j]);
value_subtract(H->p[i][j],H->p[i][j],aux);
}
/* U->p[i][j] -= x * U->p[rank][j]; */
if (U)
for (j=0; j<nr; j++) {
value_multiply(aux,x,U->p[rank][j]);
value_subtract(U->p[i][j],U->p[i][j],aux);
}
/* Q->p[rank][j] += x * Q->p[i][j]; */
if (Q)
for (j=0; j<nr; j++) {
value_addmul(Q->p[rank][j], x, Q->p[i][j]);
}
#ifdef DEBUG
fprintf(stderr,
"row %d = row %d - %d row %d -----------\n", i+1, i+1, x, rank+1);
Matrix_Print(stderr,0,H);
#endif
} /* if (x) */
} /* for (i) */
rank++;
} /* if (pivot!=0) */
} /* for (k) */
/* Clear all the 'Value' variables */
value_clear(pivot); value_clear(x);
value_clear(aux);
for(i=0;i<nc;i++)
value_clear(temp1[i]);
for(i=0;i<nr;i++)
value_clear(temp2[i]);
free(temp2);
free(temp1);
return rank;
} /* Hermite */
value value_take(value op, value n)
{
if (op.type == VALUE_NIL) {
return value_init_nil();
} else if (op.type == VALUE_ARY) {
if (n.type == VALUE_MPZ) {
value start = value_set_long(0);
value res = value_range(op, start, n);
value_clear(&start);
return res;
}
} else if (op.type == VALUE_LST) {
if (n.type == VALUE_MPZ) {
if (value_lt(n, value_zero)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (>= 0 expected).", n);
return value_init_error();
} else if (value_gt(n, value_int_max)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (<= %s expected).", n, value_int_max);
return value_init_error();
}
value res = value_init_nil();
size_t i, max = value_get_long(n);
value ptr = op;
for (i = 0; i < max && ptr.type == VALUE_LST; ++i) {
value_cons_now(ptr.core.u_l[0], &res);
ptr = ptr.core.u_l[1];
}
value_reverse_now(&res);
return res;
}
} else if (op.type == VALUE_PAR) {
if (n.type == VALUE_MPZ) {
if (value_lt(n, value_zero)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (>= 0 expected).", n);
return value_init_error();
} else if (value_gt(n, value_int_max)) {
value_error(1, "Domain Error: drop() is undefined where n is %s (<= %s expected).", n, value_int_max);
return value_init_error();
}
value res = value_init_nil();
size_t i, max = value_get_long(n);
value ptr = op;
for (i = 0; i < max && ptr.type == VALUE_PAR; ++i) {
value_cons_now(ptr.core.u_p->tail, &res);
ptr = ptr.core.u_p->tail;
}
value_reverse_now(&res);
return res;
}
} else {
value_error(1, "Type Error: take() is undefined where op is %ts (array or list expected).", op);
if (n.type == VALUE_MPZ)
return value_init_error();
}
value_error(1, "Type Error: drop() is undefined where n is %ts (integer expected).", n);
return value_init_error();
}
/*
* Sort the components of a Vector 'vector' using Heap Sort.
*/
void Vector_Sort(Value *vector,unsigned n) {
int i, j;
Value temp;
Value *current_node=(Value *)0;
Value *left_son,*right_son;
value_init(temp);
for (i=(n-1)/2;i>=0;i--) {
/* Phase 1 : build the heap */
j=i;
value_assign(temp,*(vector+i));
/* While not a leaf */
while (j<=(n-1)/2) {
current_node = vector+j;
left_son = vector+(j<<1)+1;
/* If only one son */
if ((j<<1)+2>=n) {
if (value_lt(temp,*left_son)) {
value_assign(*current_node,*left_son);
j=(j<<1)+1;
}
else
break;
}
else {
/* If two sons */
right_son=left_son+1;
if (value_lt(*right_son,*left_son)) {
if (value_lt(temp,*left_son)) {
value_assign(*current_node,*left_son);
j=(j<<1)+1;
}
else
break;
}
else {
if (value_lt(temp,*right_son)) {
value_assign(*current_node,*right_son );
j=(j<<1)+2;
}
else
break;
}
}
}
value_assign(*current_node,temp);
}
for(i=n-1;i>0;i--) {
/* Phase 2 : sort the heap */
value_assign(temp, *(vector+i));
value_assign(*(vector+i),*vector);
j=0;
/* While not a leaf */
while (j<i/2) {
current_node=vector+j;
left_son=vector+(j<<1)+1;
/* If only one son */
if ((j<<1)+2>=i) {
if (value_lt(temp,*left_son)) {
value_assign(*current_node,*left_son);
j=(j<<1)+1;
}
else
break;
}
else {
/* If two sons */
right_son=left_son+1;
if (value_lt(*right_son,*left_son)) {
if (value_lt(temp,*left_son)) {
value_assign(*current_node,*left_son);
j=(j<<1)+1;
}
else
break;
}
else {
if (value_lt(temp,*right_son)) {
value_assign(*current_node,*right_son );
j=(j<<1)+2;
}
else
break;
}
}
}
value_assign(*current_node,temp);
}
value_clear(temp);
return;
} /* Vector_Sort */
