Word ADJ_2D1_COMPLETE(Word c, Word c_l, Word c_r, Word P, Word J)
{
Word Sol,Sol1,Sol2;
Step1: /* Construct list of possible adjacency assignments. */
if (LELTI(c,CHILD) == NIL) {
Sol = NIL;
goto Return; }
if (LELTI(c_l,CHILD) == NIL)
Sol1 = LIST1(NIL);
else
Sol1 = ADJ_2D1(c,c_l,P,J);
if (LELTI(c_r,CHILD) == NIL)
Sol2 = LIST1(NIL);
else
Sol2 = ADJ_2D1(c,c_r,P,J);
Step2: /* If assignment is not unique, decide which is correct. */
if (LENGTH(Sol1) == 1 && LENGTH(Sol2) == 1)
Sol = CCONC(FIRST(Sol1),FIRST(Sol2));
else
Sol = ACMADJ2D(c,c_l,c_r,P);
Sol = LIST1(Sol);
Return: /* Prepare to return. */
return Sol;
}
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 CYLIMPFORM(Word C, Word P, Word k, Word A)
{
Word SF,L,Lp,c,S,t,Q,As,Ap,Fp,F,Lt,Lf,s,Si,Fi,Qp,SF2;
Step1: /* Set L to a list of all (k-1)-level cells over which there are
k-level cells with SC_TMPM of TRUE. */
if (k == 0) {
if (LELTI(C,SC_TMPM) == TRUE)
SF = LIST1(TRUE);
else
SF = LIST1(FALSE);
goto Return; }
SF = NIL;
L = NIL;
for(Lp = PCADCL(C,k-1); Lp != NIL; Lp = RED(Lp)) {
c = FIRST(Lp);
S = LELTI(c,SC_CDTV); if (!ISLIST(S)) continue;
for(t = 0; S != NIL && !t; S = RED(S))
t = (LELTI(FIRST(S),SC_TMPM) == TRUE);
if (t)
L = COMP(c,L); }
Step2: /* Construct formula for the k-level cells. */
Lt = NIL;
Lf = NIL;
S = NIL;
for(Lp = L; Lp != NIL; Lp = RED(Lp))
S = CCONC(LELTI(FIRST(Lp),SC_CDTV),S);
for(S = PCADCL(C,k); S != NIL; S = RED(S)) {
s = FIRST(S);
if (LELTI(s,SC_TMPM) == TRUE)
Lt = COMP(s,Lt);
else
Lf = COMP(s,Lf); }
F = NAIVESF(SPCADCBDD(Lt,k),Lf,A,P);
Step3: /* */
S = GEOPARTII(FMASORT(FMA2DNF(F)),L,P,NIL);
/* Construct definiting formula from each (Si,Fi) in S. */
for(; S != NIL; S = RED(S)) {
FIRST2(FIRST(S),&Si,&Fi);
ESCSLKMF(C,k-1);
for(Qp = Si; Qp != NIL; Qp = RED(Qp))
SLELTI(FIRST(Qp),SC_TMPM,TRUE);
SF2 = CYLIMPFORM(C,P,k-1,A);
SF = COMP(LIST3(ANDOP,SF2,CLEANUPFORM(Si,Fi,P)),SF); }
Step4: /* Convert SF from a list of formulas to a formula. */
if (LENGTH(SF) > 1)
SF = COMP(OROP,SF);
else
SF = FIRST(SF);
Return: /* Prepare to return. */
return SF;
}
Word CF(Word L,Word F,Word P)
{
Word Fp,A,Ap,f;
switch(FIRST(F)) {
case (TRUE) : Fp = F; break;
case (FALSE) : Fp = F; break;
case (ANDOP) :
A = RED(F);
for(Ap = NIL; A != NIL; A = RED(A)) {
f = CF(L,FIRST(A),P);
if (FIRST(f) == FALSE) {
Fp = f;
goto Return; }
if (FIRST(f) != TRUE)
Ap = COMP(f,Ap); }
if (Ap == NIL)
Fp = LIST1(TRUE);
else if (LENGTH(Ap) == 1)
Fp = FIRST(Ap);
else
Fp = COMP(ANDOP,Ap);
break;
case (OROP) :
A = RED(F);
for(Ap = NIL; A != NIL; A = RED(A)) {
f = CF(L,FIRST(A),P);
if (FIRST(f) == TRUE) {
Fp = f;
goto Return; }
if (FIRST(f) != FALSE)
Ap = COMP(f,Ap); }
if (Ap == NIL)
Fp = LIST1(FALSE);
else if (LENGTH(Ap) == 1)
Fp = FIRST(Ap);
else
Fp = COMP(OROP,Ap);
break;
default:
f = UNIFORMTV(L,F,P);
if (f == UNDET)
Fp = F;
else
Fp = LIST1(f);
break; }
Return:
return Fp;
}
Word QepcadCls::SFCFULLDf(Word D, Word P, Word J, Word n)
{
Word t,SF,Dp,Pp,Lt,Lf,LA,Q,D1,P1,D0,P0,J0,i,Lp,pflag, L;
char e,s,m,c;
Step1: /* Space is either empty or R^n. */
t = DOPFSUFF_FULLD(P,LIST1(D));
if (t == TRUE) {
SF = LIST1(TRUE); /* CAD is identically TRUE. */
goto Return; }
else if (t == FALSE) {
SF = LIST1(FALSE); /* CAD is identically FALSE. */
goto Return; }
Step2: /* Extended language. */
/* Dp,Pp are a simplified CAD for D,P (based only on full-dimensional cells!) */
CCADCONmod(n,P,D,&Pp,&Dp);
Dp = PCAD2ESPCAD(P,Pp,Dp,NIL);
/* Get list of all the true and false cells. */
LTFOCALWTV(Dp,n,&Lt,&Lf);
/* Filter out all but the full-dimensional true/false cells. */
for(L = NIL; Lt != NIL; Lt = RED(Lt))
if (LELTI(LELTI(FIRST(Lt),SC_REP),LEVEL) == CELLDIM(LELTI(FIRST(Lt),SC_REP)))
L = COMP(FIRST(Lt),L);
Lt = L;
for(L = NIL; Lf != NIL; Lf = RED(Lf))
if (LELTI(LELTI(FIRST(Lf),SC_REP),LEVEL) == CELLDIM(LELTI(FIRST(Lf),SC_REP)))
L = COMP(FIRST(Lf),L);
Lf = L;
if (Lt == NIL && Lf == NIL) {
SWRITE("No cells have truth values!\n");
goto Return; }
t = ESPCADDOPFSUFF(Pp,LIST1(Dp));
LA = LISTOETAmod(Pp,n,t==NIL);
/* Construct formula */
SF = NECCONDS(Lt,Lf,LA,Pp);
SF = FMASORT(SF);
SF = FMA_REMCONST(SF);
SF = FMASMOOTH(SF);
SF = FMAOPCOMBINE(SF);
Return: /* Prepare to return. */
return SF;
}
void testSIimplOI(BDigit r, Word P, Word ZL, Word NZ, Word A)
{
/* Compute generators A and all its 1st order partials */
Word L = LIST1(A);
for(int i = 1; i <= r; ++i)
{
Word D = IPDER(r,A,i);
if (D != 0)
L = COMP(D,L);
}
L = CCONC(L,ZL);
/* Compute a variable list for output purposes. */
Word V = NIL;
for(int i = r; i > 0; i--)
{
char s[2];
s[0] = 'a' - 1 + i;
s[1] = '\0';
V = COMP(LFS(s),V);
}
/* Go through assumptions and find non-vanishing conditions. */
Word M = NZ;
SWRITE("Test si ==> oi: ");
IPDWRITE(r,A,V);
SWRITE("\n");
GBTest(r,L,V);
}
Word RMNOTOP(Word F)
{
Word F1,Fb,Fp,Fp1,T;
Step1: /* Classify the formula v{F}. */
T = FIRST(F);
if (T == ANDOP) goto Step3;
if (T == OROP) goto Step3;
if (T == NOTOP) goto Step4;
Step2: /* Atomic Formula. */
Fp = F; goto Return;
Step3: /* Conjunction/Disjunction. */
Fb = RED(F); Fp = LIST1(T);
while (Fb != NIL)
{
ADV(Fb,&F1,&Fb);
Fp1 = RMNOTOP(F1);
Fp = COMP(Fp1,Fp);
}
Fp = INV(Fp);
goto Return;
Step4: /* Negation. */
F1 = SECOND(F);
Fp = RMNOTOPN(F1);
goto Return;
Return: /* Prepare for return. */
return(Fp);
}
static void
xml_end_element_handler(void *userData, const XML_Char *name)
{
uim_xml_userdata *data = (uim_xml_userdata *)userData;
if (data && data->end_) {
uim_scm_call(data->end_, LIST1(MAKE_STR(name)));
}
}
/* 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;
}
void GBTest(Word r, Word L, Word N, Word Vp)
{
if (LENGTH(Vp) < r) { SWRITE("Not enough variables in GBTest!\n"); }
Word F = GVCAP->IPFACTGB(r,L,N);
SWRITE("\nSYSTEM:\n"); PRINTCOEFFSYS(r,LIST1(L),Vp); SWRITE("\n");
SWRITE("\nGB's:\n");
PRINTCOEFFSYS(r,F,Vp);
SWRITE("\n");
}
void QepcadCls::PROJMCECCLOSURE(Word P, Word J, Word Q)
{
Word N,k,Q_k,PP,NP,pp,L,l,i,S,s;
Step1: /* Initialization. */
N = LENGTH(Q);
Step2: /* Loop from */
for(k = N; k > 1; k--) {
Q_k = LELTI(Q,k);
SEPPIVNONPIV(Q_k,k,&PP,&NP);
while (PP != NIL) {
ADV(PP,&pp,&PP);
Step3: /* Add necessary coefficients of pp. */
L = PFSUFFCOEF(pp,P,J);
while (L != NIL ) {
ADV(L,&l,&L);
i = SECOND(LELTI(l,PO_LABEL));
SLELTI(Q,i,PFSUNION(LELTI(Q,i),LIST1(l))); }
Step4: /* Add factors of the discriminant of pp. */
if (PDEG(LELTI(pp,PO_POLY)) > 1) {
L = PFDISCRIM(pp,P,J);
while (L != NIL ) {
ADV(L,&l,&L);
i = SECOND(LELTI(l,PO_LABEL));
SLELTI(Q,i,PFSUNION(LELTI(Q,i),LIST1(l))); } }
Step5: /* Add resultants. */
for(S = CCONC(PP,NP); S != NIL; S = RED(S)) {
s = FIRST(S);
L = PFRES(pp,s,P,J);
while (L != NIL ) {
ADV(L,&l,&L);
i = SECOND(LELTI(l,PO_LABEL));
SLELTI(Q,i,PFSUNION(LELTI(Q,i),LIST1(l))); } } } }
Return:/* Return. */
return;
}
static uim_lisp
im_acquire_text(uim_lisp uc_, uim_lisp text_id_, uim_lisp origin_,
uim_lisp former_len_, uim_lisp latter_len_)
{
uim_context uc;
int err, former_len, latter_len;
enum UTextArea text_id;
enum UTextOrigin origin;
char *former, *latter, *cv_former, *cv_latter;
uim_lisp former_, latter_;
uc = retrieve_uim_context(uc_);
if (!uc->acquire_text_cb)
return uim_scm_f();
text_id = C_INT(text_id_);
origin = C_INT(origin_);
former_len = C_INT(former_len_);
latter_len = C_INT(latter_len_);
err = uc->acquire_text_cb(uc->ptr, text_id, origin,
former_len, latter_len, &former, &latter);
if (err)
return uim_scm_f();
/* FIXME: string->list is not applied here for each text part. This
* interface should be revised when SigScheme has been introduced to
* uim. Until then, perform character separation by each input methods if
* needed. -- YamaKen 2006-10-07 */
cv_former = uc->conv_if->convert(uc->inbound_conv, former);
cv_latter = uc->conv_if->convert(uc->inbound_conv, latter);
free(former);
free(latter);
former_
= (TEXT_EMPTYP(cv_former)) ? uim_scm_null() : LIST1(MAKE_STR_DIRECTLY(cv_former));
latter_
= (TEXT_EMPTYP(cv_latter)) ? uim_scm_null() : LIST1(MAKE_STR_DIRECTLY(cv_latter));
return uim_scm_callf("ustr-new", "oo", former_, latter_);
}
void IUPRWR(Word v, Word A, Word I)
{
Word l,r;
Step1: /* Write. */
SWRITE("the unique root of "); IPDWRITE(1,A,LIST1(v));
FIRST2(I,&l,&r);
SWRITE(" between "); RNWRITE(l); SWRITE(" and "); RNWRITE(r);
Return: /* Prepare for return. */
return;
}
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;
}
Word CELLSCPCELL(Word C, Word P, Word Ps)
{
Word c,A,i,L,N,Ps_N,Lp,l,S,s,k,Z,r;
Step1: /* Initialize. */
FIRST3(C,&c,&A,&i);
if (A == NIL) {
Lp = LIST1(c);
goto Return; }
L = CELLSCPCELL(A,P,Ps);
N = LELTI(c,LEVEL);
Ps_N = LELTI(Ps,N);
Step2: /* Loop over all the cells that form the projection of C. */
Lp = NIL;
while (L != NIL) {
ADV(L,&l,&L);
S = LELTI(l,CHILD);
if (S == NIL) { Lp = COMP(l,Lp); }
else {
Step3: /* Set s to the first child of l which lies in C. */
ADV(S,&s,&S);
for(k = 1; k < i; S = RED(S)) {
s = FIRST(S);
if ( EVEN(k) )
k++;
else {
Z = LPFZC(s,P);
if ( LPFSETINTERSECT(Z,Ps_N) != NIL )
k++; } }
Step4: /* Continue adding cells from S until they no longer lie in C. */
if ( EVEN(i) )
Lp = COMP(s,Lp);
else {
Lp = COMP(s,Lp);
while ( S != NIL ) {
ADV2(S,&s,&r,&S);
Z = LPFZC(s,P);
if ( LPFSETINTERSECT(Z,Ps_N) == NIL ) {
Lp = COMP(s,Lp);
Lp = COMP(r,Lp); }
else
break; } } } }
Return: /* Return. */
return (Lp);
}
Word CYLFORM(Word C, Word P, Word k, Word A)
{
Word SF,L,Lp,c,S,t,Q,As,Ap,Fp,F,Lt,Lf,s;
Step1: /* Set L to a list of all (k-1)-level cells over which there are
k-level cells with SC_TMPM of TRUE. */
if (k == 0) {
SF = LIST1(TRUE);
goto Return; }
SF = NIL;
L = NIL;
for(Lp = PCADCL(C,k-1); Lp != NIL; Lp = RED(Lp)) {
c = FIRST(Lp);
S = LELTI(c,SC_CDTV); if (!ISLIST(S)) continue;
for(t = 0; S != NIL && !t; S = RED(S))
t = (LELTI(FIRST(S),SC_TMPM) == TRUE);
if (t)
L = COMP(c,L); }
Step3: /* Construct formula for the k-level cells. */
Lt = NIL;
Lf = NIL;
S = NIL;
for(Lp = L; Lp != NIL; Lp = RED(Lp))
S = CCONC(LELTI(FIRST(Lp),SC_CDTV),S);
for(S = PCADCL(C,k); S != NIL; S = RED(S)) {
s = FIRST(S);
if (LELTI(s,SC_TMPM) == TRUE)
Lt = COMP(s,Lt);
else
Lf = COMP(s,Lf); }
F = NAIVESF(SPCADCBDD(Lt,k),Lf,A,P);
Step2: /* Formula for the projection. */
for(Q = L; Q != NIL; Q = RED(Q))
SLELTI(FIRST(Q),SC_TMPM,TRUE);
As = NIL;
for(Ap = CINV(A); Ap != NIL; Ap = RED(Ap))
if (FMALEVEL(FIRST(Ap)) < k)
As = COMP(FIRST(Ap),As);
Fp = CYLFORM(C,P,k-1,As);
SF = LIST3(ANDOP,Fp,F);
Return: /* Prepare to return. */
return SF;
}
static void
xml_characterdata_handler(void *userData, const XML_Char *s, int len)
{
uim_xml_userdata *data = (uim_xml_userdata *)userData;
char *str = uim_malloc(len + 1);
memcpy(str, s, len);
str[len] = '\0';
if (data && data->characterdata_) {
uim_scm_call(data->characterdata_, LIST1(MAKE_STR(str)));
}
free(str);
}
void MODCRDB(Word b, Word S1, Word Ms, Word Ns, Word *b1_)
{
Word b1;
Step1: /* Process. */
if (PCDBUSE == 'n')
{
MODCR(b,S1,Ms,Ns,&b1);
goto Return;
}
if (DBSRCH(DBMODCR,LIST4(b,S1,Ms,Ns)) == 0)
{
MODCR(b,S1,Ms,Ns,&b1);
DBADD(DBMODCR,LIST4(b,S1,Ms,Ns),LIST1(b1),&DBMODCR);
}
else
b1 = FIRST(DBINFO);
goto Return;
Return: /* Prepare for return. */
*b1_ = b1;
return;
}
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);
}
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);
}
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);
}
Word QepcadCls::PROJHO(Word r, Word A)
{
Word A1,A2,Ap,Ap1,Ap2,App,D,L,L1,P,Ps,R,R1,R11,R2,Rp,Rp11,Rpp,Rs,Rs1,
S1,T,W,ap1,b,d,i,k,w;
Step1: /* $r = 2$. */
if (r > 2) goto Step2;
P = NIL; Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
if (PCEQC && LELTI(A1,PO_TYPE) != PO_ECON) continue;
Ap1 = LELTI(A1,PO_POLY);
W = MPOLY(PLDCF(Ap1),NIL,LIST1(LIST3(PO_LCO,0,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P);
if (PDEG(Ap1) >= 2) {
D = IPDSCRQE(2,Ap1);
W = MPOLY(D,NIL,LIST1(LIST4(PO_DIS,0,0,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P); } }
Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
Ap1 = LELTI(A1,PO_POLY);
App = Ap;
while (App != NIL) {
ADV(App,&A2,&App);
if (PCEQC &&
LELTI(A1,PO_TYPE) != PO_ECON &&
LELTI(A2,PO_TYPE) != PO_ECON) continue;
Ap2 = LELTI(A2,PO_POLY);
T = IPRESQE(2,Ap1,Ap2);
W = MPOLY(T,NIL,LIST1(LIST6(PO_RES,0,0,A1,0,A2)),PO_OTHER,PO_KEEP);
P = COMP(W,P); } }
P = INV(P);
goto Return;
Step2: /* Determine number of reducta needed for each $A_i$. */
Ap = A; R = NIL;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
Ap1 = LELTI(A1,PO_POLY);
R1 = LIST1(Ap1);
ap1 = PLDCF(Ap1);
S1 = LIST1(ap1);
b = PCONST(r - 1,ap1);
d = 0;
Ap1 = PRED(Ap1);
while (!b && !d && Ap1 != 0) {
R1 = COMP(Ap1,R1);
ap1 = PLDCF(Ap1);
b = PCONST(r - 1,ap1);
if (!b) {
S1 = COMP(ap1,S1);
d = IPFZT(r - 1,S1); }
Ap1 = PRED(Ap1); }
R1 = INV(R1);
R = COMP(R1,R); }
R = INV(R);
Step3: /* Process each $R_i$. */
P = NIL; Rp = R; Ap = A;
while (Rp != NIL) {
ADV(Rp,&R1,&Rp); ADV(Ap,&A1,&Ap);
if (PCEQC && LELTI(A1,PO_TYPE) != PO_ECON) continue;
S1 = NIL;
i = 0;
do {
ADV(R1,&R11,&R1);
W = MPOLY(PLDCF(R11),NIL,LIST1(LIST3(PO_LCO,i,A1)),
PO_OTHER,PO_KEEP);
P = COMP(W,P);
if (PDEG(R11) >= 2) {
Rp11 = IPDMV(r,R11);
L = IPPSCT(r,R11,Rp11,S1);
k = 0;
while (L != NIL) {
ADV(L,&L1,&L);
W = MPOLY(L1,NIL,LIST1(LIST4(PO_DIS,k,i,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P);
k = k + 1; }
S1 = COMP(PLDCF(R11),S1); }
i++; }
while (R1 != NIL); }
Step4: /* Process pairs $R_i$, $R_j$. */
Rp = R; Ap = A;
while (Rp != NIL) {
ADV(Rp,&R1,&Rp); ADV(Ap,&A1,&Ap);
Rpp = Rp; App = Ap;
while (Rpp != NIL) {
ADV(Rpp,&R2,&Rpp); ADV(App,&A2,&App);
if (PCEQC &&
LELTI(A1,PO_TYPE) != PO_ECON &&
LELTI(A2,PO_TYPE) != PO_ECON) continue;
if (LENGTH(R1) > LENGTH(R2)) {
Ps = FIRST(R1);
Rs = R2;
w = 1; }
else {
Ps = FIRST(R2);
Rs = R1;
w = 0; }
S1 = NIL;
i = 0;
while (Rs != NIL) {
ADV(Rs,&Rs1,&Rs);
if (PDEG(Rs1) >= 1) {
if (w == 1) L = IPPSCT(r,Ps,Rs1,S1);
else L = IPPSCT(r,Rs1,Ps,S1);
k = 0;
while (L != NIL) {
ADV(L,&L1,&L);
if (w == 1)
W = MPOLY(L1,NIL,LIST1(LIST6(PO_RES,k,0,A1,i,A2)),
PO_OTHER,PO_KEEP);
else
W = MPOLY(L1,NIL,LIST1(LIST6(PO_RES,k,i,A1,0,A2)),
PO_OTHER,PO_KEEP);
P = COMP(W,P);
k++; }
S1 = COMP(PLDCF(Rs1),S1); }
i++; } } }
Step5: /* Finish. */
P = INV(P);
Return: /* Prepare for return. */
return(P);
}
Word QepcadCls::PROJMC(Word r, Word A)
{
Word A1,A2,Ap,Ap1,Ap2,App,D,L,Lh,P,R,W,i,t;
Step1: /* Obtain coefficients. */
P = NIL;
Ap = A;
while (Ap != NIL) {
ADV(Ap,&A1,&Ap);
if (PCEQC && LELTI(A1,PO_TYPE) != PO_ECON) continue;
Ap1 = LELTI(A1,PO_POLY);
L = PLDCF(Ap1);
Lh = NIL;
t = 0;
if (!PCONST(r - 1,L)) {
W = MPOLY(L,NIL,LIST1(LIST3(PO_LCO,0,A1)),PO_OTHER,PO_KEEP);
P = COMP(W,P);
Lh = COMP(L,Lh);
t = 1; }
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 (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);
Ap1 = LELTI(A1,PO_POLY);
App = Ap;
while (App != NIL) {
ADV(App,&A2,&App);
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);
}
Word sacMain()
{
interval *A;
Word P,t,L,n;
SWRITE("Enter pol. in x: ");
IPEXPREAD(1,LIST1(LFS("x")),&P,&t);
CREAD();
I = LBRIREAD();
Step1: /* Convert the isolating interval for \alpha to a
hardware interval. */
L = NIL;
LBRNIEEEE(FIRST(I), &t,&F1,&n1);
if (t != 0)
goto Return;
w1 = F1.num;
LBRNIEEEE(SECOND(I), &t,&F2,&n2);
if (t != 0)
goto Return;
w2 = F2.num;
np = MIN(n1,n2);
Step2: /* Convert the minimal polynomial to a hardware interval
polynomial and refine the hardware interval. */
FPCATCH();
IUPHIP(P,&A,&t);
if (t == 0) {
t = 1;
goto Return; }
n = PDEG(M);
t = HIPFES(n,A,w2);
if (FPCHECK() == 1) {
t = 1;
goto Return; }
if (t == NIL) {
t = 2;
goto Return; }
u = 0;
while (u == 0 && np > 0) {
p = (w1 + w2) / 2.0;
s = HIPFES(n,A,p);
if ((FPCHECK() == 1) || (s == NIL))
u = 1;
else if (s == t)
w2 = p;
else if (s == -t)
w1 = p;
else {
w1 = p;
w2 = p; }
np = np - 1; }
K.left = w1;
K.right = w2;
HIPFES(PDEG(P),A,x);
return 0;
}
void EC1(Word c, Word L, Word Bs)
{
Word B,I,J,Lp,M,N,S,Sp,P,a,b,kp,l,r,rp,s,xb,xp,Lp1,OL;
/* hide kp,xp; */
Word T;
Step1: /* Initialize. */
S = NIL; Lp = L; kp = 1; xp = 0;
M = PMON(1,1); J = LIST2(0,0);
Step2: /* No real root. */
if (Lp != NIL) goto Step3;
a = CSSP(NIL,NIL);
b = LIST1(a); s = LIST3(M,J,b);
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,NIL); S = COMP(Sp,S);
SLELTI(c,CHILD,S);
goto Return;
Step3: /* First sector. */
ADV(Lp,&Lp1,&Lp);
FIRST3(Lp1,&B,&I,&OL); FIRST2(I,&l,&r);
a = AFFRN(CSSP(NIL,l));
T = r;
b = LIST1(a); s = LIST3(M,J,b);
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,NIL); S = COMP(Sp,S);
Step4: /* First section. */
if (PDEG(B) == 1)
{ a = IUPRLP(B); a = AFFRN(a); b = LIST1(a); s = LIST3(M,J,b); }
else
{ a = AFGEN(); b = LIST1(a); s = LIST3(B,I,b); }
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
N = NIL;
for(Word X = OL; X != NIL; X = RED(X)) { N = COMP(LIST2(THIRD(LELTI(FIRST(X),PO_LABEL)),1),N); }
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,N); S = COMP(Sp,S);
Step5: /* Check if there are more roots. */
if (Lp == NIL) goto Step9;
rp = r;
Step6: /* Next sector. */
ADV(Lp,&Lp1,&Lp);
FIRST3(Lp1,&B,&I,&OL); FIRST2(I,&l,&r);
a = AFFRN(CSSP(T,l));
T = r;
b = LIST1(a); s = LIST3(M,J,b);
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,NIL); S = COMP(Sp,S);
Step7: /* Next section. */
if (PDEG(B) == 1)
{ a = IUPRLP(B); a = AFFRN(a); b = LIST1(a); s = LIST3(M,J,b); }
else
{ a = AFGEN(); b = LIST1(a); s = LIST3(B,I,b); }
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
N = NIL;
for(Word X = OL; X != NIL; X = RED(X)) { N = COMP(LIST2(THIRD(LELTI(FIRST(X),PO_LABEL)),1),N); }
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,N); S = COMP(Sp,S);
Step8: /* Loop. */
goto Step5;
Step9: /* Last sector. */
a = AFFRN(CSSP(T,NIL));
b = LIST1(a); s = LIST3(M,J,b);
xp = xp + 1; xb = LIST1(xp);
P = LIST1(0);
Sp = MCELL(kp,NIL,FALSE,LELTI(c,TRUTH),s,xb,P,LELTI(c,HOWTV),NIL,NIL); S = COMP(Sp,S);
Step10: /* Finalize. */
S = INV(S); SLELTI(c,CHILD,S); goto Return;
Return: /* Prepare for return. */
return;
}
