void evaluate_formula (int *queue, int *queue_length, struct pcp_vars *pcp)
{
register int *y = y_address;
register int lastg = pcp->lastg;
register int i;
int nmr_entries;
int *weight;
int total;
int nmr;
total = 6 * lastg + 6;
if (is_space_exhausted (total, pcp))
return;
/* fudge the value of submlg because of possible call to power */
pcp->submlg -= total;
read_value (TRUE, "Input number of components of formula: ",
&nmr_entries, 1);
weight = allocate_vector (nmr_entries, 1, FALSE);
first = allocate_vector (nmr_entries + 1, 0, FALSE);
last = allocate_vector (nmr_entries + 1, 0, FALSE);
list = allocate_vector (nmr_entries + 1, 0, FALSE);
printf ("Input weight of each component of formula: ");
for (i = 1; i < nmr_entries; ++i) {
read_value (FALSE, "", &weight[i], 1);
}
read_value (TRUE, "", &weight[i], 1);
read_value (TRUE, "Input power of individual component: ",
&power_of_entry, 1);
read_value (TRUE, "Input power of word: ", &exponent, 1);
for (i = 1; i <= nmr_entries; ++i) {
first[i] = y[pcp->clend + weight[i] - 1] + 1;
last[i] = y[pcp->clend + weight[i]];
}
/* generate the list of words; evaluate each, echelonise it
and build up the queue of redundant generators */
nmr = 0;
loop (queue, queue_length, nmr_entries, list, &nmr,
first[nmr_entries], last[nmr_entries], pcp);
/* reset value of submlg */
pcp->submlg += total;
free_vector (weight, 1);
free_vector (first, 0);
free_vector (last, 0);
free_vector (list, 0);
}
void jacobi(int c, int b, int a, int ptr, struct pcp_vars *pcp)
{
register int *y = y_address;
register int i;
register int k;
register int p1;
register int cp1;
register int cp2;
register int unc;
register int address;
register int ycol;
register int commba;
register int count;
register int count2;
register int offset;
register int lastg = pcp->lastg;
register int prime = pcp->p;
register int pm1 = pcp->pm1;
register int p_power = pcp->ppower;
register int p_pcomm = pcp->ppcomm;
#include "access.h"
#if defined(GROUP)
if (is_space_exhausted(2 * lastg + 3, pcp))
return;
#endif
/* cp1 and cp2 are the base addresses for the collected
part of the lhs and of the rhs, respectively */
cp1 = pcp->lused;
cp2 = cp1 + lastg;
unc = cp2 + lastg + 1;
for (i = 1; i <= lastg; i++)
y[cp1 + i] = y[cp2 + i] = 0;
/* calculate the class pcp->cc part of the jacobi relation
(b^p) a = b^(p - 1) (ba) */
if (c == b) {
ycol = y[p_power + b];
collect(ycol, cp1, pcp);
collect(a, cp1, pcp);
if (b != a) {
y[cp2 + b] = pm1;
p1 = y[p_pcomm + b];
commba = y[p1 + a];
collect(a, cp2, pcp);
collect(b, cp2, pcp);
collect(commba, cp2, pcp);
} else {
/* we are processing (a^p) a = a (a^p) */
ycol = y[p_power + a];
y[cp2 + a] = 1;
collect(ycol, cp2, pcp);
}
} else {
if (b - a > 0) {
#if defined(GROUP)
/* calculate the class pcp->cc part of the jacobi relation
(cb) a = c (ba); set up a as the collected part for lhs */
y[cp1 + c] = 1;
collect(b, cp1, pcp);
collect(a, cp1, pcp);
y[cp2 + c] = 1;
collect(a, cp2, pcp);
collect(b, cp2, pcp);
p1 = y[p_pcomm + b];
commba = y[p1 + a];
collect(commba, cp2, pcp);
#endif
} else {
/* calculate the class pcp->cc part of the jacobi relation
(ca) a^(p - 1) = c (a^p); first collect rhs */
ycol = y[p_power + a];
y[cp2 + c] = 1;
collect(ycol, cp2, pcp);
/* collect lhs; set up c as collected part */
y[cp1 + c] = 1;
collect(a, cp1, pcp);
y[unc] = 1;
y[unc + 1] = PACK2(pm1, a);
collect(-unc + 1, cp1, pcp);
}
}
/* the jacobi collections are completed */
if ((p1 = ptr) > 0) {
/* we are filling in the tail on y[p1]; convert the class pcp->cc
part to string form in y[cp1 + 2 + 1] to y[cp1 + 2 + count]
where count is the string length */
count = 0;
for (i = pcp->ccbeg; i <= lastg; i++) {
k = y[cp1 + i] - y[cp2 + i];
if (k != 0) {
if (k < 0)
k += prime;
++count;
y[cp1 + 2 + count] = PACK2(k, i);
}
}
if (count > 0) {
/* y[p1] was trivial to class pcp->cc - 1 so create a new entry */
if (y[p1] >= 0) {
y[p1] = -(cp1 + 1);
y[cp1 + 1] = p1;
y[cp1 + 2] = count;
pcp->lused += count + 2;
} else {
/* the class pcp->cc part is nontrivial so make room for
lower class terms */
address = -y[p1];
count2 = y[address + 1];
/* move class pcp->cc part up */
offset = cp1 + count + 3;
for (i = 1; i <= count; i++)
y[offset + count2 - i] = y[offset - i];
/* copy in lower class terms */
for (i = 1; i <= count2; i++)
y[cp1 + 2 + i] = y[address + i + 1];
/* create new header block */
y[cp1 + 1] = y[address];
y[cp1 + 2] = count + count2;
/* deallocate old entry */
y[address] = 0;
/* set up pointer to new entry */
y[p1] = -(cp1 + 1);
pcp->lused += count + count2 + 2;
}
}
} else {
/* we are checking consistency equations */
echelon(pcp);
if ((pcp->fullop && pcp->eliminate_flag) || pcp->diagn)
text(9, c, b, a, 0);
}
}
void collect_relations (struct pcp_vars *pcp)
{
register int *y = y_address;
register int i;
register int j;
register int k;
register int p1;
register int length;
register int cp, cp1, cp2;
register int relp = pcp->relp;
register int ndrel = pcp->ndrel;
register int lastg = pcp->lastg;
for (i = 1; i <= ndrel; ++i) {
/* space is required for two collected parts set up here
and possibly for 5 * pcp->lastg in collect_def_comm */
if (is_space_exhausted (7 * lastg + 7, pcp))
return;
cp1 = pcp->lused;
cp2 = cp1 + lastg;
/* original zero out -- bug reported by John Cannon October 1998 */
/*
for (j = 1; j <= lastg; ++j)
y[cp1 + j] = y[cp2 + j] = 0;
*/
for (j = 1; j <= 2; ++j) {
p1 = y[++relp];
if (p1 != 0) {
cp = (j == 1) ? cp1 : cp2;
/* bug fix */
for (k = 1; k <= lastg; ++k)
y[cp + k] = 0;
length = y[p1];
/* is the relation a word or a commutator? */
if (length > 0)
collect_gen_word (p1, length, cp, pcp);
else if (length < 0) {
/* we may need to update pcp->lused, as space immediately
above it is used in commutator routines */
if (j == 2) pcp->lused += lastg;
collect_def_comm (p1, cp, pcp);
if (j == 2) pcp->lused -= lastg;
}
if (!pcp->valid)
return;
}
}
echelon (pcp);
if ((pcp->fullop && pcp->eliminate_flag) || pcp->diagn)
text (1, i, 0, 0, 0);
if (pcp->overflow || pcp->complete != 0)
return;
}
}
void complete_echelon(Logical trivial, int redgen, struct pcp_vars *pcp)
{
register int *y = y_address;
int k;
int i, j, jj, exp;
int p1;
int factor;
int count, count1, count2;
int predg;
int offset;
int temp;
int value;
int bound;
int l;
int p = pcp->p;
#include "access.h"
if (trivial) {
/* delete all occurrences of redgen from other equations */
for (k = redgen + 1, bound = pcp->lastg; k <= bound; k++) {
if (y[pcp->structure + k] >= 0)
continue;
p1 = -y[pcp->structure + k];
count = y[p1 + 1];
for (j = 1; j <= count; j++)
if ((temp = FIELD2(y[p1 + j + 1])) >= redgen)
break;
if (j > count || temp > redgen)
continue;
/* redgen occurs in this relation, so eliminate it;
is redgen in the last word? */
count1 = count - 1;
if (j < count) {
/* no, so pack up relation */
for (jj = j; jj <= count1; jj++)
y[p1 + jj + 1] = y[p1 + jj + 2];
}
if (j < count || (j >= count && count1 > 0)) {
/* deallocate last word and fix count in header block */
y[p1 + count + 1] = -1;
y[p1 + 1] = count1;
continue;
}
/* old relation is to be eliminated (it was 1 word long) */
y[p1] = 0;
y[pcp->structure + k] = 0;
}
} else {
p1 = -y[pcp->structure + redgen];
count = y[p1 + 1];
/* eliminate all occurrences of redgen from the other relations
by substituting its value */
for (k = redgen + 1, bound = pcp->lastg; k <= bound; k++) {
if (y[pcp->structure + k] >= 0)
continue;
if (is_space_exhausted(pcp->lastg + 1, pcp))
return;
p1 = -y[pcp->structure + k];
count1 = y[p1 + 1];
for (j = 1; j <= count1; j++)
if ((temp = FIELD2(y[p1 + j + 1])) >= redgen)
break;
if (j > count1 || temp > redgen)
continue;
/* redgen occurs in this relation, so eliminate it */
factor = FIELD1(y[p1 + j + 1]);
predg = -y[pcp->structure + redgen];
/* merge old relation with factor * (new relation), deleting redgen;
old relation is longer than new relation since it contains redgen */
/* commence merge */
count2 = 0;
offset = pcp->lused + 2;
for (i = 1, l = 1;;) {
temp = FIELD2(y[p1 + i + 1]) - FIELD2(y[predg + l + 1]);
if (temp < 0) {
count2++;
y[offset + count2] = y[p1 + i + 1];
i++;
} else if (temp > 0) {
count2++;
/* integer overflow can occur here; see comments in collect */
value = y[predg + l + 1];
y[offset + count2] =
PACK2((factor * FIELD1(value)) % p, FIELD2(value));
if (++l > count)
break;
} else {
/* integer overflow can occur here; see comments in collect */
value = y[p1 + i + 1];
exp = (FIELD1(value) + factor * FIELD1(y[predg + l + 1])) % p;
if (exp > 0) {
count2++;
y[offset + count2] = PACK2(exp, FIELD2(value));
}
i++;
if (++l > count)
break;
}
}
/* all of the value of redgen has been merged in;
copy in the remainder of the old relation with redgen deleted */
offset = pcp->lused + 2;
for (jj = i; jj <= count1; jj++)
if (jj != j) {
count2++;
y[offset + count2] = y[p1 + jj + 1];
}
/* new relation is now in y[lused + 2 + 1] to y[lused + 2 + count2] */
/* new relation indicates generator k is trivial; deallocate old */
if (count2 <= 0) {
y[p1] = 0;
y[pcp->structure + k] = 0;
continue;
}
/* new relation is nontrivial */
if (count2 < count1) {
/* new relation is shorter than old; copy in new relation */
for (i = 1; i <= count2; i++)
y[p1 + i + 1] = y[pcp->lused + 2 + i];
/* reset count field for new relation */
y[p1 + 1] = count2;
/* deallocate rest of old relation */
if (count1 == count2 + 1)
y[p1 + count2 + 2] = -1;
else {
y[p1 + count2 + 2] = 0;
y[p1 + count2 + 3] = count1 - count2 - 2;
}
} else if (count1 == count2) {
/* new relation has same length as old; overwrite old relation */
offset = pcp->lused + 2;
for (i = 1; i <= count2; i++)
y[p1 + i + 1] = y[offset + i];
} else {
/* new relation is longer than old; deallocate old relation */
y[p1] = 0;
/* set up pointer to new relation and header block */
y[pcp->structure + k] = -(pcp->lused + 1);
y[pcp->lused + 1] = pcp->structure + k;
y[pcp->lused + 2] = count2;
pcp->lused += count2 + 2;
}
}
}
}
