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)); } } }