Word C1DTOEDGELIST(Word cl, Word cm, Word cr)
{
Word E,L,i,Ll,Lr,l,a,b,t;
Step1: /* Initialize. */
E = NIL;
Step2: /* Get adjacencies for (cl,cm) and (cr,cm). */
L = FIRST(ADJ_2D_PART(cm,cl,cr,P,J));
i = LAST(LELTI(cm,INDX));
Ll = NIL; Lr = NIL;
while(L != NIL) {
ADV(L,&l,&L);
FIRST2(l,&a,&b);
if (FIRST(a) == i) {
t = a; a = b; b = t; }
if (FIRST(a) < i)
Ll = COMP(LIST2(a,b),Ll);
else
Lr = COMP(LIST2(a,b),Lr); }
Step3: /* Get edges from adjacency info. */
E = CONC(ADJ2DITOEL(Ll,cl,cm),E);
E = CONC(ADJ2DITOEL(Lr,cr,cm),E);
Return: /* Prepare to return. */
return E;
}
Word HAP3(Word U, Word w_l, Word B)
{
Word Sol,u,I,w_u,r,c1,c2;
Step1: /* Initialization. */
if (U == NIL) {
Sol = LIST1(NIL);
goto Return;
}
ADV(U,&u,&U);
FIRST2(u,&I,&r);
Sol = LIST1(LIST2(I,LIST2(B,AD2D_Infy)));
while(U != NIL) {
ADV(U,&u,&U);
FIRST2(u,&I,&w_u);
r = VECTOR_SUM(r,w_u);
Sol = COMP(LIST2(I,LIST2(B,AD2D_Infy)),Sol);
}
while(r != NIL) {
ADV(r,&c1,&r);
ADV(w_l,&c2,&w_l);
if (c1 != 0 && c2 == 0) {
Sol = AD2D_FAIL;
goto Return;
}
}
Sol = LIST1(Sol);
Return: /* Prepare to return. */
return Sol;
}
Word IUPSOPOR(Word A, Word B, Word i1, Word i2)
{
Word L,Bp,Lp,J,j1,j2,t,j,tp,s;
Step1: /* */
L = IPRRISI(A,LIST2(i1,i2));
Bp = IPPGSD(1,B);
Step2: /* */
Lp = NIL;
while(L != NIL) {
ADV(L,&J,&L);
FIRST2(J,&j1,&j2);
t = LBRNSIGN(IUPLBREVAL(A,j2));
if (t != 0) {
while(IUPVSI(Bp,LIST2(j1,j2)) != 0) {
j = LSIM(j1,j2);
tp = LBRNSIGN(IUPLBREVAL(A,j));
if (tp == t)
j2 = j;
else
j1 = j;
}
}
s = LBRNSIGN(IUPLBREVAL(B,LSIM(j1,j2)));
Lp = COMP(LIST2(s,LIST2(j1,j2)),Lp);
}
return INV(Lp);
}
Word FMAAFPIRN(Word i, Word j, Word k)
{
Word L,op;
L = NIL;
for(op = 1; op <= 6; op++) {
L = COMP(LIST2(LIST2(i,j),op),L);
L = COMP(LIST2(LIST2(i,j),LIST2(op,k)),L); }
return L;
}
void FMAATOMREAD(Word Q, Word V, Word *F_, Word *t_)
{
Word F,P,P1,P2,R,a,r,s,t,k,pi;
char c;
/* hide r,s,t; */
Step1: /* Read the left polynomial. */
t = 1; r = LENGTH(V);
IPEXPREAD(r,V,&P1,&t); if (t == 0) goto Return;
Step2: /* Read the relational operator. */
RLOPRDR(&R,&t); if (t == 0) goto Return;
Step2p: /* Read Root expression (if it's there). */
k = 0;
do {
c = CREAD();
} while (c == ' ' || c == '\n');
if (c == '_')
if (CREAD() == 'r' && CREAD() == 'o' && CREAD() == 'o'
&& CREAD() == 't' && CREAD() == '_')
k = IREAD();
else {
t = 0; goto Return; }
else
BKSP();
Step3: /* Read the right polynomial. */
IPEXPREAD(r,V,&P2,&t); if (t == 0) goto Return;
Setp4: /* Tarski Atom. */
if (k == 0) {
if (P2 != 0) { t = 0; goto Return; }
pi = POLYINDEX(Q,P1,r,&t);
F = LIST2(pi,R);
goto Return; }
Step5: /* Extended Atom. */
pi = POLYINDEX(Q,P2,r,&t);
/* should do an error check here! */
F = LIST2(pi,LIST2(R,k));
goto Return;
Step6: /* Error exit. */
DIELOC(); t = 0; goto Return;
Return: /* Prepare for return. */
*F_ = F;
*t_ = t;
return;
}
Word HAC_CONS(Word c, Word P)
{
Word r,P_r,n,i,M,L,k,m,T,p,cp,I;
Step1: /* Construct empty multiplicity vector. */
r = LELTI(c,LEVEL);
P_r = LELTI(P,r);
n = LENGTH(P_r);
for(i = 0, M = NIL; i < n; i++)
M = COMP(0,M);
Step2: /* Set non-zero entries from cells multiplicity list. */
for(L = LELTI(c,MULSUB); L != NIL; L = RED(L)) {
FIRST2(FIRST(L),&k,&m);
/*-- Find p, the p.f. with index k. --*/
for(T = P_r, i = 1; T != NIL; T = RED(T),i++) {
p = FIRST(T);
if (k == THIRD(LELTI(p,PO_LABEL)))
break; }
/*-- Proj.fac. with index k has been removed from the set. --*/
if (T == NIL) continue;
SLELTI(M,i,m); }
Return: /* Construct cp and return. */
I = LELTI(c,INDX);
cp = LIST2(I,M);
return cp;
}
Word ADJ_2D1(Word c, Word c_l, Word P, Word J)
{
Word U,V,v_l,Sol,S,A,Ap,a,b;
/*
init();
sa_send("[");
*/
Step1: /* Initialization. */
v_l = LDCOEFMASK(c,P,J);
U = AD2DS_CONS(c_l,P);
V = AD2DS_CONS(c,P);
Step2: /* Get Adjacencies. */
/* Sol = ADJ_2D1_SIMPLE(U,V,v_l,FIRST(LELTI(c,INDX))); */
Sol = ADJ_2D1P1(U,V,v_l,FIRST(LELTI(c,INDX)));
Step3: /* If c_l is to the right of c, reverse order of pairs. */
if (FIRST(LELTI(c,INDX)) < FIRST(LELTI(c_l,INDX))) {
for(S = NIL; Sol != NIL; Sol = RED(Sol)) {
for(A = NIL, Ap = FIRST(Sol); Ap != NIL; Ap = RED(Ap)) {
FIRST2(FIRST(Ap),&a,&b);
A = COMP(LIST2(b,a),A); }
S = COMP(A,S); }
Sol = S; }
Return: /* Prepare to return. */
/*
sa_send("]\n");
uninit();
*/
return Sol;
}
Word STACKMULT(Word c)
{
Word d,i,m,p,M,S;
Step1: /* Get the stack over c. */
S = LELTI(c,CHILD);
Step2: /* Construct the stack multiplicity list. */
M = NIL;
if (S == NIL)
goto Return;
S = RED(S);
if (S == NIL)
goto Return;
i = 2;
while (S != NIL) {
d = FIRST(S);
m = LELTI(d,MULSUB);
p = LIST2(i,m);
M = COMP(p,M);
i = i + 2;
S = RED2(S); }
M = INV(M);
Return: /* Return M. */
return (M);
}
/* Projection point equal */
BDigit PRJPNTEQUAL(Word A, Word B)
{
if (LENGTH(A) != LENGTH(B))
return 0;
/* Both primitive */
Word a = FIRST(A), b = FIRST(B);
if (ISPRIMIT(a) && ISPRIMIT(b)) {
Word aC,aK,ac,bC,bK,bc;
FIRST3(a,&aC,&aK,&ac);
FIRST3(b,&bC,&bK,&bc);
if (!EQUAL(aC,bC)) return 0;
if (EQUAL(FIRST(aK),SECOND(aK)) && EQUAL(aK,bK)) return 1;
if (EQUAL(FIRST(aK),SECOND(aK)) && EQUAL(FIRST(bK),SECOND(bK)) && !EQUAL(aK,bK)) return 0;
if (RNCOMP(SECOND(aK),FIRST(bK)) <= 0 || RNCOMP(FIRST(aK),SECOND(bK)) >= 0) return 0;
return EQUAL(ac,bc);
}
/* Both Not Primitive */
if (!ISPRIMIT(a) && !ISPRIMIT(b)) {
if (!PRJPNTEQUAL(LIST1(SECOND(A)),LIST1(SECOND(B)))) return 0;
Word aC,aK,aM,aI,ac,bC,bK,G,Af,Bf;
FIRST5(a,&aC,&aK,&aM,&aI,&ac);
FIRST2(b,&bC,&bK);
if (EQUAL(FIRST(aK),SECOND(aK)) && EQUAL(FIRST(bK),SECOND(bK)) && !EQUAL(aK,bK)) return 0;
if (RNCOMP(SECOND(aK),FIRST(bK)) <= 0 || RNCOMP(FIRST(aK),SECOND(bK)) >= 0) return 0;
if (EQUAL(aC,bC)) return 1;
AFUPGC(aM,aC,bC,&G,&Af,&Bf);
if (PDEG(G) < 1) return 0;
Word KL = LIST2(FIRST(aK),LIST2(1,1));
Word KR = LIST2(SECOND(aK),LIST2(1,1));
Word sL = AFSIGN(aM,aI,AFPEMV(1,aM,G,KL));
Word sR = AFSIGN(aM,aI,AFPEMV(1,aM,G,KR));
return EQUAL(KL,KR) && sL == 0 || sL == 1 && sR == -1 || sL == -1 && sR == 1;
}
/* One primitive, the other not */
if (ISPRIMIT(a) != ISPRIMIT(b)) {
SWRITE("This condition not implemented in PRJPNTEQUAL!\n");
FAIL("PRJPNTEQUAL","Incomplete Implementation Error!");
}
return -1;
}
Word HAP2(Word U, Word V, Word w_l, Word B)
{
Word Sol,S,v,J,w_v,u,w_u,I,Solp,t,f;
Sol = NIL;
S = NIL;
Step1: /* Base case: V is empty. */
if (V == NIL) {
Solp = HAP3(U,w_l,B);
if (Solp != AD2D_FAIL)
Sol = CCONC(ADD_2_SOL(S,Solp),Sol);
goto Return; }
/* Non base case: v = (J,w_v) is the first element of V */
ADV(V,&v,&V);
FIRST2(v,&J,&w_v);
Step2: /* Try assigning no section adjacent to v. */
if (! VECTOR_ODD_E(w_v)) {
Solp = HAP2(U,V,w_l,B);
if (Solp != AD2D_FAIL)
Sol = CCONC(ADD_2_SOL(S,Solp),Sol); }
Step3: /* Try all assignments of section adjacencies to v. */
do {
/* Loop while some muliplicities of v are odd. */
do {
/* u = (I,w_u) is first section in U if U's not empty. */
if (U == NIL) goto Return;
ADV(U,&u,&U);
FIRST2(u,&I,&w_u);
/* Try assigning u adjacent to v. */
S = COMP(LIST2(I,J),S);
w_v = VECTOR_DIF_S(w_v,w_u,&f);
if (f == 0)
goto Step1; /* Multiplicities of v are filled by assignment. */
if (f == 3)
goto Return;/* Multiplicites of v are over-filled by assignment. */
} while (f == 2);
/* All multiplicities of v are even ... move on to next section in V. */
Solp = HAP2(U,V,w_l,B);
if (Solp != AD2D_FAIL)
Sol = CCONC(ADD_2_SOL(S,Solp),Sol);
}while(1);
Return: /* Prepare to return. */
if (Sol == NIL)
Sol = AD2D_FAIL;
return Sol;
}
Word FMAOPCOMBINE(Word F)
{
Word L,M,Fp,f,a,b,Lp,Mp,Lb;
switch(FIRST(F)) {
case OROP:
/* Set L to a list of all top level atomic formulas. */
L = NIL; M = NIL;
for(Fp = RED(F); Fp != NIL; Fp = RED(Fp)) {
f = FIRST(Fp);
if (ISLIST(FIRST(f)))
L = COMP(f,L);
else
M = COMP(f,M); }
/* Create Lp from L */
Lp = NIL;
while(L != NIL) {
a = FIRST(L);
if (FMAQEXTAF(a)) { Lp = COMP(a,Lp); L = RED(L); continue; }
Lb = RED(L);
for(L = NIL; Lb != NIL; Lb = RED(Lb)) {
b = FIRST(Lb);
if (FMAQEXTAF(b) || ! EQUAL(FIRST(b),FIRST(a)))
L = COMP(b,L);
else
a = LIST2(FIRST(a),SECOND(a) | SECOND(b)); }
if (SECOND(a) > 6)
Lp = COMP(LIST1(TRUE),Lp);
else
Lp = COMP(a,Lp); }
/* Create Mp from M. */
for(Mp = NIL; M != NIL; M = RED(M))
Mp = COMP(FMAOPCOMBINE(FIRST(M)),Mp);
Fp = COMP(OROP,CCONC(Lp,Mp));
break;
case ANDOP:
Fp = NIL;
for(L = CINV(RED(F)); L != NIL; L = RED(L))
Fp = COMP(FMAOPCOMBINE(FIRST(L)),Fp);
Fp = COMP(ANDOP,Fp);
break;
default:
Fp = F;
}
return Fp;
}
/*
Polynomial list of extended Tarski atoms. (modified to only include
atoms involving >= and <=, i.e. the one's you'd need for full-dim cells only)
p : a QEPCAD polynomial
B : a bound on the number of roots (need not be a valid bound)
t : a flag
*/
static Word PLISTOETAmod(Word p, Word B, Word t)
{
Word L,I,i;
L = NIL;
I = RED(LELTI(p,PO_LABEL));
if (t) {
for(i = B; i > 0; i--) {
L = COMP(LIST2(I,LIST2(LEOP,i)),L);
L = COMP(LIST2(I,LIST2(LEOP,-i)),L);
L = COMP(LIST2(I,LIST2(GEOP,i)),L);
L = COMP(LIST2(I,LIST2(GEOP,-i)),L); }
}
L = COMP(LIST2(I,LEOP),L);
L = COMP(LIST2(I,GEOP),L);
return L;
}
Word IUPSOPOR(Word A, Word B, Word i1, Word i2)
{
Word L,Bp,Lp,J,j1,j2,t,j,tp,s;
Step1: /* Initialize. */
L = IPRRILBRI(A,LIST2(i1,i2));
Bp = IPPGSD(1,B);
Step2: /* Loop over each interval in L. */
Lp = NIL;
while(L != NIL) {
ADV(L,&J,&L);
FIRST2(J,&j1,&j2);
t = LBRNSIGN(IUPLBREVAL(A,j2));
if (t != 0) {
Step3: /* Refine (j1,j2) until Bp has no zeros. */
do {
j = LSIM(j1,j2);
tp = LBRNSIGN(IUPLBREVAL(A,j));
if (tp == t)
j2 = j;
else
j1 = j;
}while(IUPVSI(Bp,LIST2(LBRNRN(j1),LBRNRN(j2))) != 0); /* Is there a lbrn equivalent? */
}
Step4: /* Compute the sign of B in (j1,j2) and add to Lp. */
s = LBRNSIGN(IUPLBREVAL(B,LSIM(j1,j2)));
Lp = COMP(LIST2(s,LIST2(j1,j2)),Lp);
}
Return: /* Prepare to return; */
L = INV(Lp);
return L;
}
Word QepcadCls::INITPCAD()
{
Word D, tv;
Step0: /* Determine truth value! */
if (GVNA == FALSE || GVNA != NIL && LELTI(GVNA,1) == NEOP && LELTI(GVNA,2) == 0) tv = NA;
else if (LELTI(GVNQFF,1) == NEOP && LELTI(GVNQFF,2) == 0) tv = FALSE;
else if (LELTI(GVNQFF,1) == EQOP && LELTI(GVNQFF,2) == 0) tv = TRUE;
else tv = UNDET;
Step1: /* Make one and initialize it. */
D = MCELL(0,NIL,FALSE,tv,LIST3(0,LIST2(0,0),NIL),NIL,NIL,0,NIL,NIL);
Return: /* Prepare for return. */
return(D);
}
static void
xml_start_element_handler(void *userData, const XML_Char *name, const XML_Char *atts[])
{
uim_xml_userdata *data = (uim_xml_userdata *)userData;
if (data && data->start_) {
uim_lisp atts_;
atts_ = (uim_lisp)uim_scm_call_with_gc_ready_stack((uim_gc_gate_func_ptr)xml_start_element_handler_internal,
(void *)atts);
atts_ = uim_scm_callf("reverse", "o", atts_);
uim_scm_call(data->start_, LIST2(MAKE_STR(name), atts_));
}
}
Word SSILRCRI(Word a_, Word b_)
{
Word s,a,b,p,c,a1,a2,b1,b2,n,t,m,B,C,r;
Step0: /* Reflect interval if neccesary. */
if (RNSIGN(a_) == -1) {
s = 1; a = RNNEG(b_); b = RNNEG(a_); }
else {
s = 0; a = a_; b = b_; }
Step1: /* Initialize loop. */
RNFCL2(RNDIF(b,a),&p,&c);
if (p == c) p--;
FIRST2(b,&b1,&b2);
if (a == 0)
n = 0;
else {
FIRST2(a,&a1,&a2);
n = IQ(ITRUNC(a1,p),a2); }
Step2: /* Loop until n is even, then increment p and divide n by 2. */
do {
if (ISATOM(n)) t = ODD(n);
else t = ODD(FIRST(n));
p++;
n = IDP2(n,1);
}while(t);
m = ISUM(n,1);
Step3: /* If p is smallest possible, i.e. p = c, check (m+1)2^p > b. */
if (p == c) {
if (p >= 0) {
B = b1;
C = IMP2(IPROD(b2,m),p); }
else {
B = IMP2(b1,-p);
C = IPROD(b2,m); }
if (ICOMP(B,C) >= 1)
goto Step2; }
Return: /* Return, reflecting the output interval if needed. */
if (s) { r = n; n = -m; m = -r; }
return (LIST2(LBRNFIE(n,p),LBRNFIE(m,p)));
}
Word ADJ_2D1(Word c, Word c_l, Word P, Word J)
{
Word U,V,v_l,Sol,S,A,Ap,a,b;
Word t,i,I = 1000;
Step1: /* Initialization. */
printf("\n");
t = ACLOCK();
for(i = 0; i < I; i++)
v_l = LDCOEFMASK(c,P,J);
t = ACLOCK() - t;
printf("LDCOEFMASK: %6.3f\n",t/(float)I);
t = ACLOCK();
for(i = 0; i < I; i++)
U = AD2DS_CONS(c_l,P);
t = ACLOCK()-t;
printf("AD2DS_CONS open: %6.3f\n",t/(float)I);
t = ACLOCK();
for(i = 0; i < I; i++)
V = AD2DS_CONS(c,P);
t = ACLOCK()-t;
printf("AD2DS_CONS closed: %6.3f\n",t/(float)I);
Step2: /* Get Adjacencies. */
t = ACLOCK();
for(i = 0; i < I; i++)
Sol = ADJ_2D1P1(U,V,v_l,FIRST(LELTI(c,INDX)));
t = ACLOCK()-t;
printf("ADJ_2D1P1: %6.3f\n",t/(float)I);
printf("\n");
Step3: /* If c_l is to the right of c, reverse order of pairs. */
if (FIRST(LELTI(c,INDX)) < FIRST(LELTI(c_l,INDX))) {
for(S = NIL; Sol != NIL; Sol = RED(Sol)) {
for(A = NIL, Ap = FIRST(Sol); Ap != NIL; Ap = RED(Ap)) {
FIRST2(FIRST(Ap),&a,&b);
A = COMP(LIST2(b,a),A); }
S = COMP(A,S); }
Sol = S; }
Return: /* Prepare to return. */
return Sol;
}
Word NORMAETF(Word A)
{
Word X,T,j,P,r,I,s,c,L,Lr,Fs,Fa,L_i,e_i,P_i,rk_i,Pk_i,F;
Step1: /* Get the components. */
FIRST6(A,&X,&T,&j,&P,&r,&I);
Step2: /* Factor \v{P}. */
if (!ISLIST(FIRST(P)))
IPFACDB(r,P,&s,&c,&L);
else {
Word Lp = NIL;
for(; P != NIL; P = RED(P))
Lp = COMP(LIST2(1,FIRST(P)),Lp);
L = CINV(Lp);
}
Step3: /* Sign of content is irrelevant in _root_ expressions! */
Step4: /* Simplify the representation of the polys in \v{L}. */
Lr = NIL; /* r-level factors */
Fs = NIL; /* factors of level less than r can't be zero! */
while (L != NIL)
{
ADV(L,&L_i,&L);
FIRST2(L_i,&e_i,&P_i);
PSIMREP(r,P_i,&rk_i,&Pk_i);
if (rk_i < r)
Fs = COMP(LIST4(NEOP,Pk_i,rk_i,NIL),Fs);
else
Lr = COMP(Pk_i,Lr);
}
Lr = INV(Lr);
Step5: /* Create formula */
Fa = LIST6(IROOT,T,j,Lr,r,NIL);
F = COMP(Fa,Fs);
F = COMP(ANDOP,CINV(F));
Return: /* Prepare for return. */
return(F);
}
Word RNREAD()
{
Word C,R,R1,R2;
/* hide C,R; */
Step1: /* Read. */
R1 = IREAD();
C = CREAD();
if (C == '/')
R2 = IREAD();
else
{
R2 = 1;
BKSP();
}
if (R1 == 0)
R = 0;
else
R = LIST2(R1,R2);
Return: /* Prepare for return. */
return(R);
}
int sacMain()
{
Word V,B,t,Vx,M,L,Lp,i,k = 20;
Word wii, p, J, *I , *Bp;
/* Read bivariate polynomial */
V = LIST2(LFS("x"),LFS("y"));
SWRITE("Enter B, a polynomial in x and y : ");
IPEXPREADR(2,V,&B,&t);
if (!t) {
SWRITE("Polynomial read unsuccessfull!\n");
return 1; }
else {
SWRITE("Polynomial read in is: ");
IPDWRITE(2,B,V);
SWRITE("\n"); }
/* Get precision */
SWRITE("Enter precision: ");
p = IREAD();
SWRITE("Precision read is: ");
IWRITE(p);
SWRITE("\n");
/* Read Interval */
SWRITE("Enter binary rational interval: ");
J = LBRIREAD();
/* Sub! */
Bp = GETARRAY(1 + (PDEG(B) + 1)*2*(p + 3));
IBPELBRISIPR(B,J,p,Bp);
SWRITE("Evaluation result is : ");
SIPWRITE(Bp,p,k);
SWRITE("\n");
return 0;
}
Word NORMAF(Word A)
{
Word F,I,L,L_i,Lh,Lh_i,P,P_i,Ph_i,T,c,e_i,r,rh_i,s;
/* hide rh_i,s; */
Step1: /* Get the components. */
if (FIRST(A) == IROOT)
{
F = NORMAETF(A);
goto Return;
}
FIRST4(A,&T,&P,&r,&I);
Step2: /* \v{P} = 0. */
if (P != 0) goto Step3;
switch (T)
{
case EQOP:
F = LIST4(EQOP,0,0,NIL);
break;
case GEOP:
F = LIST4(EQOP,0,0,NIL);
break;
case LEOP:
F = LIST4(EQOP,0,0,NIL);
break;
case GTOP:
F = LIST4(NEOP,0,0,NIL);
break;
case LTOP:
F = LIST4(NEOP,0,0,NIL);
break;
case NEOP:
F = LIST4(NEOP,0,0,NIL);
break;
}
goto Return;
Step3: /* Factor \v{P}. */
IPFACDB(r,P,&s,&c,&L);
Step4: /* Adjust \v{T}. */
if (s < 0) T = NEGRLOP(T);
Step5: /* \v{P} is an integer. */
if (L != NIL) goto Step6;
switch (T)
{
case NEOP:
F = LIST4(EQOP,0,0,NIL);
break;
case GTOP:
F = LIST4(EQOP,0,0,NIL);
break;
case GEOP:
F = LIST4(EQOP,0,0,NIL);
break;
case EQOP:
F = LIST4(NEOP,0,0,NIL);
break;
case LTOP:
F = LIST4(NEOP,0,0,NIL);
break;
case LEOP:
F = LIST4(NEOP,0,0,NIL);
break;
}
goto Return;
Step6: /* Simplify the representation of the polys in \v{L}. */
Lh = NIL;
while (L != NIL)
{
ADV(L,&L_i,&L);
FIRST2(L_i,&e_i,&P_i);
PSIMREP(r,P_i,&rh_i,&Ph_i);
Lh_i = LIST3(e_i,rh_i,Ph_i);
Lh = COMP(Lh_i,Lh);
}
Lh = INV(Lh);
Step7: /* Expand. */
switch (T)
{
case EQOP:
F = EXPAFEQ(Lh);
break;
case GTOP:
F = EXPAFGT(Lh);
break;
case LTOP:
F = EXPAFLT(Lh);
break;
case NEOP:
F = LIST2(NOTOP,EXPAFEQ(Lh));
break;
case LEOP:
F = LIST2(NOTOP,EXPAFGT(Lh));
break;
case GEOP:
F = LIST2(NOTOP,EXPAFLT(Lh));
break;
}
goto Return;
Return: /* Prepare for return. */
return(F);
}
Word RIIFACMA(Word I, Word A, Word t, Word P, Word J, Word K)
{
Word i1,i2,b1,b2,p,i,s;
FIRST2(I,&i1,&i2);
b1 = FIRST(J);
if (K != 0)
b2 = SECOND(K);
else
b2 = SECOND(J);
p = IPLBREVAL(2,P,b1);
while(TSVSLI(p,LIST2(i1,i2)) != 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
while(IUPLBREVAL(p,i1) == 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
while(IUPLBREVAL(p,i2) == 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
p = IPLBREVAL(2,P,b2);
while(TSVSLI(p,LIST2(i1,i2)) != 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
while(IUPLBREVAL(p,i1) == 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
while(IUPLBREVAL(p,i2) == 0)
{i = LSIM(i1,i2);
s = LBRNSIGN(IUPLBREVAL(A,i));
if (s == 0) {
i1 = LSIM(i1,i);
i2 = LSIM(i,i2); }
else if (s == t)
i2 = i;
else
i1 = i; }
return LIST2(i1,i2);
}
Word RMCAFS(Word F)
{
Word F1,F2,Fb,Fp,Fp1,Fp2,T,t,t1,t2;
/* hide t,t1,t2; */
Step1: /* Classify the formula F. */
T = FIRST(F);
if (T == ANDOP) goto Step3;
if (T == OROP) goto Step4;
if (T == NOTOP) goto Step5;
if (T == RIGHTOP) goto Step6;
if (T == LEFTOP) goto Step7;
if (T == EQUIOP) goto Step8;
Step2: /* Atomic Formula. */
t = TYPEAF(F);
if (t == TRUE) {
Fp = LIST4(EQOP,0,0,NIL);
goto Return;
}
if (t == FALSE) {
Fp = LIST4(NEOP,0,0,NIL);
goto Return;
}
Fp = F;
goto Return;
Step3: /* Conjunction. */
Fb = RED(F);
Fp = LIST1(ANDOP);
while (Fb != NIL)
{
ADV(Fb,&F1,&Fb);
Fp1 = RMCAFS(F1);
t = TYPEQFF(Fp1);
if (t == FALSE) {
Fp = LIST4(NEOP,0,0,NIL);
goto Return;
}
if (t == UNDET) Fp = COMP(Fp1,Fp);
}
if (LENGTH(Fp) == 1) {
Fp = LIST4(EQOP,0,0,NIL);
goto Return;
}
if (LENGTH(Fp) == 2) {
Fp = FIRST(Fp);
goto Return;
}
Fp = INV(Fp);
goto Return;
Step4: /* Disjunction. */
Fb = RED(F);
Fp = LIST1(OROP);
while (Fb != NIL)
{
ADV(Fb,&F1,&Fb);
Fp1 = RMCAFS(F1);
t = TYPEQFF(Fp1);
if (t == TRUE) {
Fp = LIST4(EQOP,0,0,NIL);
goto Return;
}
if (t == UNDET) Fp = COMP(Fp1,Fp);
}
if (LENGTH(Fp) == 1) {
Fp = LIST4(NEOP,0,0,NIL);
goto Return;
}
if (LENGTH(Fp) == 2) {
Fp = FIRST(Fp);
goto Return;
}
Fp = INV(Fp);
goto Return;
Step5: /* Negation. */
F1 = SECOND(F);
Fp1 = RMCAFS(F1);
t = TYPEQFF(Fp1);
if (t == TRUE) Fp = LIST4(NEOP,0,0,NIL);
else if (t == FALSE) Fp = LIST4(EQOP,0,0,NIL);
else Fp = LIST2(NOTOP,Fp1);
goto Return;
Step6: /* $\Rightarrow$. */
F1 = SECOND(F);
Fp1 = RMCAFS(F1);
t1 = TYPEQFF(Fp1);
F2 = THIRD(F);
Fp2 = RMCAFS(F2);
t2 = TYPEQFF(Fp2);
if (t1 == TRUE) Fp = Fp2;
else if (t1 == FALSE) Fp = LIST4(EQOP,0,0,NIL);
else if (t2 == TRUE) Fp = LIST4(EQOP,0,0,NIL);
else if (t2 == FALSE) Fp = LIST2(NOTOP,Fp1);
else Fp = LIST3(RIGHTOP,Fp1,Fp2);
goto Return;
Step7: /* $\Leftarrow$. */
F1 = THIRD(F);
Fp1 = RMCAFS(F1);
t1 = TYPEQFF(Fp1);
F2 = SECOND(F);
Fp2 = RMCAFS(F2);
t2 = TYPEQFF(Fp2);
if (t1 == TRUE) Fp = Fp2;
else if (t1 == FALSE) Fp = LIST4(EQOP,0,0,NIL);
else if (t2 == TRUE) Fp = LIST4(EQOP,0,0,NIL);
else if (t2 == FALSE) Fp = LIST2(NOTOP,Fp1);
else Fp = LIST3(LEFTOP,Fp2,Fp1);
goto Return;
Step8: /* $\Leftrightarrow$. */
F1 = SECOND(F);
Fp1 = RMCAFS(F1);
t1 = TYPEQFF(Fp1);
F2 = THIRD(F);
Fp2 = RMCAFS(F2);
t2 = TYPEQFF(Fp2);
if (t1 == TRUE) Fp = Fp2;
else if (t2 == TRUE) Fp = Fp1;
else if (t1 == FALSE && t2 == FALSE) Fp = LIST4(EQOP,0,0,NIL);
else if (t1 == FALSE) Fp = LIST2(NOTOP,Fp2);
else if (t2 == FALSE) Fp = LIST2(NOTOP,Fp1);
else Fp = LIST3(EQUIOP,Fp1,Fp2);
goto Return;
Return: /* Prepare for return. */
return(Fp);
}
void ADJ_2D_TEST(Word D, Word P, Word J)
{
Word t,S,c_l,c,c_r,L,k;
Word i,I = 100, t1, t2, L1, L2, f1, f2;
float T,TT;
/**** 3 Stack method! ****/
S = LELTI(D,CHILD);
k = 0;
TT = 0.0;
SWRITE("\n3-Stack method");
SWRITE("\n---------------------");
for(ADV(S,&c_l,&S); S != NIL; c_l = c_r) {
k++;
ADV2(S,&c,&c_r,&S);
if (LELTI(c,CHILD) == NIL ||
(LELTI(c_l,CHILD) == NIL && LELTI(c_r,CHILD) == NIL) )
continue;
printf("\n Stack%3d ",2*k);
if (LELTI(c_l,CHILD) == NIL || LELTI(c_r,CHILD) == NIL) {
t = 0;
L = LIST2(0,0); }
else {
t = ACLOCK();
for(i = 0; i < I; i++)
L = ADJ_2D(c,c_l,c_r,P,J);
t = ACLOCK() - t;
T = t / (float)I;
printf("%8.3fms",T);
TT += T; }
if (LENGTH(L) > 1) printf(" [Failure]");
else printf(" [Success]"); }
SWRITE("\n---------------------");
printf("\n Total %11.3fms",TT);
/**** 2 Stack method! ****/
S = LELTI(D,CHILD);
k = 0;
TT = 0.0;
SWRITE("\n\n2-Stack method");
SWRITE("\n---------------------");
for(ADV(S,&c_l,&S); S != NIL; c_l = c_r) {
k++;
ADV2(S,&c,&c_r,&S);
if (LELTI(c,CHILD) == NIL ||
(LELTI(c_l,CHILD) == NIL && LELTI(c_r,CHILD) == NIL) )
continue;
printf("\n Stack%3d ",2*k);
if (LELTI(c_l,CHILD) == NIL) {
f1 = 1;
t1 = 0; }
else {
t1 = ACLOCK();
for(i = 0; i < I; i++)
L1 = ADJ_2D1(c,c_l,P,J);
t1 = ACLOCK() - t1;
f1 = LENGTH(L1) > 1 ? 1 : 0; }
if (LELTI(c_r,CHILD) == NIL) {
f2 = 1;
t2 = 0; }
else {
t2 = ACLOCK();
for(i = 0; i < I; i++)
L2 = ADJ_2D1(c,c_r,P,J);
t2 = ACLOCK() - t2;
f2 = LENGTH(L2) > 1 ? 1 : 0; }
printf("%8.3fms",(t1 + t2) / (float)I);
printf(" left %8.3fms",t1 / (float)I);
if (f1) printf(" [Failure]");
else printf(" [Success]");
printf(" right %8.3fms",t2 / (float)I);
if (f2) printf(" [Failure]");
else printf(" [Success]");
TT += (t1 + t2) / (float) I; }
SWRITE("\n---------------------");
printf("\n Total %11.3fms",TT);
/**** ACM method! ****/
S = LELTI(D,CHILD);
k = 0;
TT = 0.0;
SWRITE("\n\nACM method");
SWRITE("\n---------------------");
for(ADV(S,&c_l,&S); S != NIL; c_l = c_r) {
k++;
ADV2(S,&c,&c_r,&S);
if (LELTI(c,CHILD) == NIL ||
(LELTI(c_l,CHILD) == NIL && LELTI(c_r,CHILD) == NIL) )
continue;
printf("\n Stack%3d ",2*k);
t = ACLOCK();
for(i = 0; i < I; i++)
L = ACMADJ2D(c,c_l,c_r,P);
t = ACLOCK() - t;
T = t / (float)I;
printf("%8.3fms",T);
TT += T; }
SWRITE("\n---------------------");
printf("\n Total %11.3fms",TT);
SWRITE("\n\n");
return;
}
Word CFLCELLLIST(Word L_D)
{
Word C,r,C_r,L,Lp,T,F,U,c,t,f,u,Fp,Up,h,Cb,Cp,Q;
/* Time */ Word tm;
Step1: /* Initialize. */
C = NIL;
Step2: /* Get the children of L_D. */
L = NIL;
for(Q = L_D; Q != NIL; Q = RED(Q)) {
L = CCONC(LELTI(FIRST(Q),CHILD),L); }
Step3: /* Sort by signiture. */
L = GISL(L,comp);
Step4: /* Loop over each block of cells with same signiture. */
while (L != NIL) {
Lp = NIL;
do {
Lp = COMP(FIRST(L),Lp);
L = RED(L);
} while (L != NIL && comp(FIRST(Lp),FIRST(L)) == 0);
Step5: /* Separate into lists of TRUE, FALSE, and UNDET cells. */
T = NIL; F = NIL; U = NIL; C_r = NIL;
while (Lp != NIL) {
ADV(Lp,&c,&Lp);
switch (LELTI(c,TRUTH)) {
case (TRUE) : T = COMP(c,T); break;
case (FALSE) : F = COMP(c,F); break;
case (UNDET) : U = COMP(c,U); break; } }
Step6: /* TRUE/FALSE & TRUE/UNDET combinations. */
for(; T != NIL; T = RED(T)) {
t = FIRST(T);
for(Fp = F; Fp != NIL; Fp = RED(Fp)) {
f = FIRST(Fp); C_r = COMP(LIST2(t,f),C_r); }
for(Up = U; Up != NIL; Up = RED(Up)) {
u = FIRST(Up);
h = CATV(u);
if (h == FALSE || h == UNDET)
C_r = COMP(LIST2(t,u),C_r); } }
Step7: /* FALSE/UNDET combinations. */
for(; F != NIL; F = RED(F)) {
f = FIRST(F);
for(Up = U; Up != NIL; Up = RED(Up)) {
u = FIRST(Up);
h = CATV(u);
if (h == TRUE || h == UNDET)
C_r = COMP(LIST2(f,u),C_r); } }
Step8: /* Recurse on the UNDET cells. */
if ( U != NIL )
Cb = COMP(C_r,CFLCELLLIST(U));
else
Cb = LIST1(C_r);
Step9: /* Update C to include the */
Cp = NIL;
while( C != NIL && Cb != NIL ) {
Cp = COMP(CCONC(FIRST(Cb),FIRST(C)),Cp);
C = RED(C); Cb = RED(Cb); }
Cp = CINV(Cp);
if ( C != NIL ) Cp = CCONC(Cp,C);
if ( Cb != NIL ) Cp = CCONC(Cp,Cb);
C = Cp; }
Return: /* Prepare to return. */
return (C);
}
void AFUPMPR(Word M, Word I, Word B, Word J, Word L, Word *Js_, Word *j_)
{
Word Js,L1,Lp,a,b,c,j,jp,s,t,v,vp;
/* hide L1,Lp,j,jp,s,t,v,vp; */
Step1: /* Initialize. */
FIRST2(J,&a,&b);
t = AFUPSR(M,I,B,b);
if (t == 0)
goto Step4;
Step2: /* Test for real roots of each Li in current interval. */
v = 0;
jp = 0;
Lp = L;
Js = LIST2(a,b);
do
{
ADV(Lp,&L1,&Lp);
jp = jp + 1;
vp = IUPVOI(L1,Js);
if (vp > 1)
goto Step3;
if (vp == 1)
if (v == 1)
goto Step3;
else
{
v = 1;
j = jp;
}
}
while (!(Lp == NIL));
goto Return;
Step3: /* Bisect current interval. */
c = RIB(a,b);
s = AFUPSR(M,I,B,c);
if (s == 0)
{
b = c;
goto Step4;
}
else
if (s * t < 0)
a = c;
else
{
b = c;
t = s;
}
goto Step2;
Step4: /* B has root at right end point of current interval. */
j = 0;
Js = LIST2(b,b);
Lp = L;
do
{
ADV(Lp,&L1,&Lp);
j = j + 1;
if (PDEG(L1) == 1)
if (IUPBES(L1,b) == 0)
goto Return;
}
while (1);
Return: /* Prepare for return. */
*Js_ = Js;
*j_ = j;
return;
}
Word QepcadCls::PROJMCmod(Word r, Word A)
{
Word A1,A2,Ap,Ap1,Ap2,App,D,L,Lh,P,R,W,i,t,Q,j,S,Sp;
Step1: /* Obtain coefficients. */
P = NIL;
Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
Ap1 = LELTI(A1,PO_POLY);
/* Deal with projection points! */
if (LELTI(A1,PO_TYPE) == PO_POINT) {
W = MPOLY(RED(Ap1),NIL,LIST1(LIST2(PT_PRJ,A1)),PO_POINT,PO_KEEP);
P = COMP(W,P);
continue;
}
/* Handle the leading coefficient! */
L = PLDCF(Ap1);
Lh = NIL;
t = 0;
/* if (!PCONST(r - 1,L)) {*/
if (!VERIFYCONSTSIGN(r-1,IPIP(r-1,ISIGNF(PLBCF(r-1,L)),L),1,GVNA.W)) {
W = MPOLY(L,NIL,LIST1(LIST3(PO_LCO,0,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P);
Lh = COMP(L,Lh);
t = 1; }
/* If r = 2 then we know the leading coefficient is always enough! */
if (r == 2)
t = 0;
/* If x_{r-1} is a bound variable, and the quantifier is
either F or G, then we know we'll only be lifting over
full dimensional cells so we don't have to add more
coefficients! */
if (t) {
j = r - GVNFV - 1;
if (j > 0) {
Q = LELTI(GVQ,j); /* Quantifier for x_{r-1} */
if (Q == FULLDE || Q == FULLDA)
t = 0; } }
/* If PCMZERROR is set to true, then we only need leading coefficients
when projecting polynomials of level k+1 or lower. */
if (t && PCMZERROR && r <= GVNFV + 1)
t = 0;
/* If it can be determined that the system of coefficients is
inconsistent ... we can stop with just the leading coeff! */
if (t) {
j = CLOCK();
S = COEFSYS(r,Ap1);
if (S == 1 || (Sp = SIMPLIFYSYSLIST(r-1,S,GVNA == NIL ? TRUE : GVNA.W)) == 1)
t = 0;
else {
QepcadCls Q; Word G;
for(t = 0; t == 0 && Sp != NIL; Sp = RED(Sp))
if ((G = SYSSOLVECAD(r-1,FIRST(Sp),GVNA == NIL ? TRUE : GVNA.W,GVVL,Q)) != NIL)
{
/* If there are finitely many solutions, add those points as projection
points. */
if (ISLIST(G)) {
for(Word Lp = G; Lp != NIL; Lp = RED(Lp)) {
/* ADD POINTS to PROJECTION POLS! */
Word X = NIL; /* List of all sample points up to and inluding FIRST(G) */
Word c = Q.GVPC;
for(Word I = LELTI(FIRST(Lp),INDX); I != NIL; I = RED(I))
{
c = LELTI(LELTI(c,CHILD),FIRST(I));
Word s = LELTI(c,SAMPLE);
X = COMP(ISPRIMIT(s) ? (LENGTH(s) > 3 ? FOURTH(s) : s) : s,X);
}
W = MPOLY(X,NIL,LIST1(LIST2(PT_NUL,A1)),PO_POINT,PO_KEEP);
P = COMP(W,P);
}
}
else
t = 1; /* Instead of adding all the other coeffs, better to add system! */
}
}
j = CLOCK() - j;
if (PCVERBOSE) {
SWRITE("Coef consistency check took "); IWRITE(j); SWRITE("ms\n");
if (!t)
SWRITE("Found system inconsistent for ");
else
SWRITE("Unable to determine consistency for ");
IPDWRITE(r,Ap1,GVVL);
SWRITE("\n");
}
}
/* Handle the rest of the coefficients as needed. */
i = 0;
while (t) {
Ap1 = PRED(Ap1); i++; L = PLDCF(Ap1);
t = 0;
if (Ap1 != 0)
if (!PCONST(r - 1,L))
if (!IPFZT(r - 1,Lh)) {
W = MPOLY(L,NIL,LIST1(LIST3(PO_LCO,i,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P);
Lh = COMP(L,Lh);
t = 1; } }
}
Step2: /* Obtain discriminants. */
Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
if (LELTI(A1,PO_TYPE) == PO_POINT) continue;
if (PCEQC && LELTI(A1,PO_TYPE) != PO_ECON) continue;
Ap1 = LELTI(A1,PO_POLY);
if (PDEG(Ap1) >= 2) {
D = IPDSCRQE(r,Ap1);
W = MPOLY(D,NIL,LIST1(LIST4(PO_DIS,0,0,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P); } }
Step3: /* Obtain resultants. */
Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
if (LELTI(A1,PO_TYPE) == PO_POINT) continue;
Ap1 = LELTI(A1,PO_POLY);
App = Ap;
while (App != NIL) {
ADV(App,&A2,&App);
if (LELTI(A2,PO_TYPE) == PO_POINT) continue;
if (PCEQC &&
LELTI(A1,PO_TYPE) != PO_ECON &&
LELTI(A2,PO_TYPE) != PO_ECON) continue;
Ap2 = LELTI(A2,PO_POLY);
R = IPRESQE(r,Ap1,Ap2);
W = MPOLY(R,NIL,LIST1(LIST6(PO_RES,0,0,A1,0,A2)),PO_OTHER,PO_KEEP);
P = COMP(W,P); } }
Step4: /* Finish. */
P = INV(P);
goto Return;
Return: /* Prepare for return. */
return(P);
}
void QepcadCls::CSORCELLTR_MOD(Word c, Word Pp, Word PpO, Word PpN, Word P)
{
Word f,s,sh,M,K,C,Pps,L,T,B,E,I,A,a,b,k;
Word PP,NP,L_P,TP,i,ta,t;
Step0:
k = LELTI(c,LEVEL);
s = LELTI(c,SAMPLE);
sh = CONVERT(s,k);
SLELTI(c,SAMPLE,sh);
/* Trick CONSTRUCT into working for us by wrapping the elements of
Pp (which are SACLIB polynomials) in a dummy QEPCAD projection
polynomial/factor data structure. */
Word PpM = NIL;
for(Word PpR = CINV(Pp),j=LENGTH(Pp); PpR != NIL; PpR = RED(PpR),--j)
PpM = COMP( LIST5(FIRST(PpR),LIST3(LFS("P"),k+1,j),0,PO_FAC,0) ,PpM);
CONSTRUCT(c,k,GVNFV,PpM,GVNIP);
Step5: /* Add two new fields to each cell to make it an RCell. */
T = NIL;
for(A = LELTI(c,CHILD); A != NIL; A = RED(A)) {
T = COMP(CCONC(FIRST(A),LIST2(NIL,NIL)),T); }
SLELTI(c,CHILD,CINV(T));
Step6: /* Add truth values and other information. */
/* Get mask for pivot pol's, i.e. a list of
1's and zeros corresponding to PpO, where
the non-pivot pol positions are 1, and
the pivot pol positions are zero. */
SEPPIVNONPIV(LELTI(P,k+1),k+1,&PP,&NP); /* Get list of pivot pol's for this level. */
if ( (NP != NIL) && SINTER(LELTI(GVPIVOT,k+1),LLPFZC(c,P)) != NIL ) {
PP = LELTI(P,k+1); NP = NIL; }
L_P = NIL;
ta = FIRST(LELTI(FIRST(LELTI(c,CHILD)),SIGNPF)); /* signiture of a sector on level
k+1 pols. */
for(TP = LELTI(P,k+1); TP != NIL; TP = RED(TP)) {
/* Subtle point: a pivot pol might vanish identically in this stack,
which would mess everything up. If this pol does vanish identically
in the stack, don't include it in the mask! */
ADV(ta,&i,&ta); /* sign of current pol in a sector: if 0 then pol vanishes in stack. */
if ( PFPIPFL(FIRST(TP),PP) && i ) {
L_P = COMP(0,L_P); }
else
L_P = COMP(1,L_P); }
L_P = INV(L_P);
A = LELTI(c,CHILD); /* Stack with more cells, i.e. new. */
B = LELTI(LELTI(c,INCELL),CHILD); /* Stack with fewer cells, i.e. old. */
ADV(B,&b,&B);
ADV(A,&a,&A);
while (A != NIL) {
SLELTI(a,INCELL,b);
SLELTI(a,TRUTH,LELTI(b,TRUTH));
SLELTI(a,HOWTV,LELTI(b,HOWTV));
ADV(A,&a,&A);
if (LELTI(b,MULSUB) != NIL)
ADV(B,&b,&B); /* i.e. if b is a section. */
if ( ISCSOPP(a,L_P) ) {
do{
ADV(B,&b,&B);
} while( ! ISCSOPP(b,L_P) ); } }
SLELTI(a,INCELL,b);
SLELTI(a,TRUTH,LELTI(b,TRUTH));
SLELTI(a,HOWTV,LELTI(b,HOWTV));
Return: /* */
return;
}
void QepcadCls::BOUNDARY2D(Word D, Word P, Word J)
{
Word G,L,S,s,c,Sp,i,j,cl,cm,cr,E,Lp,L0,L1,L2,v,t,tc,fc,LH,LI0;
Step1: /* Initialization. */
G = NIL;
Step2: /* Graph vertices. L is a list of all vert's in descending lex order. */
L = NIL;
for(S = LELTI(D,CHILD); S != NIL; S = RED(S))
for(s = LELTI(FIRST(S),CHILD); s != NIL; s = RED(s))
L = COMP(FIRST(s),L);
for(Lp = L; Lp != NIL; Lp = RED(Lp)) {
c = FIRST(Lp);
GADDVERTEX(LELTI(c,INDX),LELTI(c,TRUTH),&G); }
Step3: /* Add edges. */
S = LELTI(D,CHILD);
if (LENGTH(S) < 3)
goto StepX;
Step4: /* Edges between cells in the same stack. */
for(Sp = S; Sp != NIL; Sp = RED(Sp)) {
for(s = LELTI(FIRST(Sp),CHILD); s != NIL; s = RED(s)) {
FIRST2(LELTI(FIRST(s),INDX),&i,&j);
if (j % 2 == 0) {
GADDEDGE(LIST2(LIST2(i,j+1),LIST2(i,j)),G);
GADDEDGE(LIST2(LIST2(i,j-1),LIST2(i,j)),G); } } }
Step5: /* Edges between cells in different stacks. */
do {
ADV2(S,&cl,&cm,&S); cr = FIRST(S);
for(E = C1DTOEDGELIST(cl,cm,cr,P,J); E != NIL; E = RED(E))
GADDEDGE(FIRST(E),G);
}while(RED(S) != NIL);
Step6: /* Split cell list by dimension. */
for(L0 = NIL, L1 = NIL, L2 = NIL, Lp = L; Lp != NIL; Lp = RED(Lp)) {
c = LELTI(FIRST(Lp),INDX);
switch(vert2dim(c)) {
case 0: L0 = COMP(c,L0); break;
case 1: L1 = COMP(c,L1); break;
case 2: L2 = COMP(c,L2); break; } }
/* Find isolated true L0 cells */
LI0 = NIL;
for(Lp = L0; Lp != NIL; Lp = RED(Lp)) {
v = FIRST(Lp);
if (GVERTEXLABEL(v,G) != TRUE)
continue;
LH = NIL;
for(S = GPREDLIST(v,G), tc = 0, fc = 0;
S != NIL && GVERTEXLABEL(FIRST(S),G) == FALSE; S = RED(S))
LH = CCONC(GPREDLIST(FIRST(S),G),LH);
if (S == NIL) {
for(;LH != NIL && GVERTEXLABEL(FIRST(LH),G) == FALSE; LH = RED(LH));
if (LH == NIL)
LI0 = COMP(v,LI0);
} }
/* Set L1 cells to TRUE IFF they have both true & false predecessors,
or they are already true and all predecessors are false */
for(Lp = L1; Lp != NIL; Lp = RED(Lp)) {
v = FIRST(Lp);
for(S = GPREDLIST(v,G), tc = 0, fc = 0; S != NIL; S = RED(S)) {
if (GVERTEXLABEL(FIRST(S),G) == TRUE)
tc++;
else
fc++; }
if (tc > 0 && fc > 0 || GVERTEXLABEL(v,G) == TRUE && tc == 0)
GNEWLABEL(v,TRUE,G);
else
GNEWLABEL(v,FALSE,G); }
/* Set L2 cells to FALSE */
for(Lp = L2; Lp != NIL; Lp = RED(Lp))
GNEWLABEL(FIRST(Lp),FALSE,G);
/* Set L0 cells to TRUE IFF they have a true predecessor */
for(Lp = L0; Lp != NIL; Lp = RED(Lp)) {
v = FIRST(Lp);
for(S = GPREDLIST(v,G), tc = 0, fc = 0; S != NIL; S = RED(S)) {
if (GVERTEXLABEL(FIRST(S),G) == TRUE)
tc++;
else
fc++; }
if (tc > 0)
GNEWLABEL(v,TRUE,G);
else
GNEWLABEL(v,FALSE,G); }
/* Set all the isolated L0 cells to true */
for(Lp = LI0; Lp != NIL; Lp = RED(Lp))
GNEWLABEL(FIRST(Lp),TRUE,G);
Step10: /* Assign new TV's to CAD. */
for(Lp = L; Lp != NIL; Lp = RED(Lp)) {
c = FIRST(Lp);
t = GVERTEXLABEL(LELTI(c,INDX),G);
if (t != UNDET) {
SLELTI(c,TRUTH,t);
SLELTI(c,HOWTV,TOPINF); } }
StepX: /* Assignments between 1D cells.
TVCLOSURE1D(D,P,J,3);
CTVPROPUP(D,UNDET,GVNFV,TOPINF); */
Return: /* Prepare to return. */
return;
}
cell parse(char** s) {
// Skip whitespace
while (isspace(**s))
(*s)++;
if (!**s) return NIL;
switch (**s) {
case '"': {
*(*s)++;
cell str = read_string(s);
return cons(str, parse(s));
}
case ')':
(*s)++;
return NIL;
case '(': {
(*s)++;
cell first = parse(s);
return cons(first, parse(s));
}
case '\'': {
(*s)++;
cell rest = parse(s);
// ' -> ()
if (!rest) return NIL;
// '.a -> ()
// ' -> ()
if (!IS_PAIR(rest)) return NIL;
// 'a -> (quote a)
if (!IS_PAIR(car(rest)))
return cons(LIST2(sym("quote"), car(rest)), cdr(rest));
// '(a b c) -> (quote a b c)
return cons(cons(sym("quote"), rest), cdr(rest));
}
case '.': {
(*s)++;
cell rest = parse(s);
if (!rest) return NIL;
if (TYPE(rest) != PAIR) return NIL;
return car(rest);
}
default: {
char* i = *s;
while (*i && !isspace(*i) && *i != '(' && *i != ')')
i++;
size_t token_len = i - *s;
char* token = strncpy(malloc(token_len + 1), *s, token_len);
token[token_len] = '\0';
*s = i;
cell c;
// Try to turn the token into a number
char* endptr;
long val = strtol(token, &endptr, 0);
if (endptr != token)
c = make_int(val);
else
c = sym(token);
free(token);
return cons(c, parse(s));
}
}
}
