void check_hint(int col, int spin, int ch, List hint, Atom *n, Atom *an)
{
List l, l1;
if(col==0)
return;
l=hint;
while(!is_empty_list(l))
{
Atom a1,a2;
Term cp, tp;
a1=CompoundArg1(ListFirst(l));
tp=GetAtomProperty(a1,PROP_TYPE);
if(tp==0 || !is_compound(tp) || CompoundName(tp)!=OPR_PARTICLE)
goto cnt;
cp=GetAtomProperty(a1,A_COLOR);
if(cp==0 || !is_compound(cp))
goto cnt;
cp=CompoundArg1(cp);
if((col==3 && IntegerValue(cp)!=3) ||
(col!=3 && IntegerValue(cp)==3))
goto cnt;
if(ch && CompoundArg1(tp)==CompoundArg2(tp))
goto cnt;
if(!ch && CompoundArg1(tp)!=CompoundArg2(tp))
goto cnt;
if(ch)
{
if(a1==CompoundArg1(tp))
a2=CompoundArg2(tp);
else
a2=CompoundArg1(tp);
}
else
a2=a1;
if(ch)
{
l1=ListTail(l);
while(!is_empty_list(l1))
{
if(a2==CompoundArg1(ListFirst(l1)))
break;
l1=ListTail(l1);
}
if(is_empty_list(l1))
goto cnt;
}
l1=used_fields;
while(!is_empty_list(l1))
{
Atom aa;
aa=CompoundArg2(CompoundArg2(ListFirst(l1)));
if(aa==a1 || aa==a2)
goto cnt;
l1=ListTail(l1);
}
a1=CompoundArg1(tp);
a2=CompoundArg2(tp);
if(spin==2)
{
*n=a1;
*an=a2;
return;
}
if(AtomValue(a1)[0]=='~' || AtomValue(a2)[0]=='~')
goto cnt;
sprintf(nnbuf,"~%s",AtomValue(a1));
a1=NewAtom(nnbuf,0);
sprintf(nnbuf,"~%s",AtomValue(a2));
a2=NewAtom(nnbuf,0);
if(is_particle(a1,NULL) || is_particle(a2,NULL))
goto cnt;
*n=a1;
*an=a2;
return;
cnt:
l=ListTail(l);
}
}
static int
get_indent (tree t) {
if (is_compound (t, "coq-indent", 1))
return as_int (t[0]);
return -1;
}
Term ProcMkProc(Term t, Term ind)
{
Atom prt[4];
Atom mass[4];
Term color[4];
int spin[4];
int i;
int neufact=1;
double thcut=0.0;
int dec=0;
char pname[128];
FILE *f;
if(CompoundArity(t)==1)
{
List l,dlist;
double m1;
set_ppl();
l=GetAtomProperty(CompoundArg1(t),PROP_TYPE);
if(!is_compound(l)||CompoundName(l)!=OPR_PARTICLE ||
CompoundArgN(l,5)==0)
{
ErrorInfo(0);
WriteTerm(t);
printf(" : decays are not generated.\n");
return 0;
}
m1=fabs(EvalParameter(CompoundArgN(l,5)));
dlist=GetAtomProperty(CompoundArg1(t),PROP_PPL);
for(l=dlist;l;l=ListTail(l))
{
List pl=ListFirst(l);
Atom prp,a;
Atom ap1, ap2;
double m2,m3;
int is_neut;
if(ListLength(pl)!=2)
continue;
prp=GetAtomProperty(ListFirst(pl),PROP_TYPE);
if(!is_compound(prp)||CompoundName(prp)!=OPR_PARTICLE)
continue;
if(CompoundArgN(prp,7)==OPR_MLT)
continue;
a=CompoundArgN(prp,5);
if(a==0)
continue;
else
m2=fabs(EvalParameter(a));
prp=GetAtomProperty(ListFirst(ListTail(pl)),PROP_TYPE);
if(!is_compound(prp)||CompoundName(prp)!=OPR_PARTICLE)
continue;
if(CompoundArgN(prp,7)==OPR_MLT)
continue;
a=CompoundArgN(prp,5);
if(a==0)
continue;
else
m3=fabs(EvalParameter(a));
if(m1<=m2+m3)
continue;
is_neut=(CompoundArg1(t)==GetAtomProperty(CompoundArg1(t),A_ANTI));
ap1=GetAtomProperty(ListFirst(pl),A_ANTI);
ap2=GetAtomProperty(ListFirst(ListTail(pl)),A_ANTI);
if(is_neut)
{
List l1;
for(l1=dlist;l1!=l;l1=ListTail(l1))
{
if( (ListFirst(ListFirst(l1))==ap1 &&
ListFirst(ListTail(ListFirst(l1)))==ap2) ||
(ListFirst(ListFirst(l1))==ap2 &&
ListFirst(ListTail(ListFirst(l1)))==ap1))
break;
}
if(l1!=l)
continue;
}
/*WriteTerm(CompoundArg1(t));printf(" -> ");
WriteTerm(pl);puts("");*/
prp=MakeCompound(A_I,4);
SetCompoundArg(prp,1,CompoundArg1(t));
SetCompoundArg(prp,2,NewInteger(0));
SetCompoundArg(prp,3,is_neut?ListFirst(pl):ap1);
SetCompoundArg(prp,4,is_neut?ListFirst(ListTail(pl)):ap2);
ProcMkProc(prp,0);
}
return 0;
}
if(CompoundArity(t)<4)
{
ErrorInfo(2000);
puts("mkProc: wrong argument number.");
return 0;
}
for(i=5;i<=CompoundArity(t);i++)
{
Term t1=CompoundArgN(t,i);
if(is_compound(t1) && is_atom(CompoundArg1(t1)) &&
strcmp(AtomValue(CompoundArg1(t1)),"THETACUT")==0)
{
if(is_integer(CompoundArg2(t1)))
thcut=IntegerValue(CompoundArg2(t1));
else if(is_float(CompoundArg2(t1)))
thcut=FloatValue(CompoundArg2(t1));
else
{
ErrorInfo(303);puts("wrong THETACUT value.");
continue;
}
continue;
}
ErrorInfo(304);
puts("wrong argument in mkProc.");
}
for(i=0;i<4;i++)
{
Term prp, t7;
prt[i]=CompoundArgN(t,i+1);
if(prt[i]==NewInteger(0)&&i==1)
{
dec=1;spin[i]=0;color[1]=0;
continue;
}
if(!is_particle(prt[i],NULL))
{
ErrorInfo(2001);
WriteTerm(prt[i]);
puts(": is not a particle.");
return 0;
}
prp=GetAtomProperty(prt[i],PROP_TYPE);
if(CompoundName(prp)!=OPR_PARTICLE)
{
ErrorInfo(2001);
WriteTerm(prt[i]);
puts(": is not a particle.");
return 0;
}
if(prt[i]==CompoundArg2(prp))
prp=GetAtomProperty(CompoundArg1(prp),PROP_TYPE);
spin[i]=IntegerValue(CompoundArgN(prp,4));
mass[i]=CompoundArgN(prp,5);
color[i]=GetAtomProperty(prt[i],A_COLOR);
t7=CompoundArgN(prp,7);
if(i<2 && (t7==A_LEFT||t7==A_RIGHT))
neufact*=2;
}
if(dec==0)
sprintf(pname,"%s%s__%s%s",AtomValue(prt[0]),AtomValue(prt[1]),
AtomValue(prt[2]),AtomValue(prt[3]));
else
sprintf(pname,"%s__%s%s",AtomValue(prt[0]),
AtomValue(prt[2]),AtomValue(prt[3]));
for(i=0;pname[i];i++)
{
if(pname[i]=='~') pname[i]='_';
if(pname[i]=='+') pname[i]='p';
if(pname[i]=='-') pname[i]='m';
}
f=fopen("scan.bat",inifile?"a":"w");
if(f==NULL)
{
ErrorInfo(2000);
puts("mkProc: can not open scan.bat");
return 0;
}
if(!inifile)
{
fprintf(f,"#!/bin/sh\n\n");
inifile=1;
}
fprintf(f,"echo Generating process %s `date`\n\n",pname);
fprintf(f,"echo Process %s: >> scan.log\n",pname);
fprintf(f,"num0=`date +%%s`\n");
fprintf(f,"cat > proc.m <<END\n");
if(dec==0)
fprintf(f,"process = {prt[\"%s\"],prt[\"%s\"]} ->",
AtomValue(prt[0]),AtomValue(prt[1]));
else
fprintf(f,"process = {prt[\"%s\"]} ->",
AtomValue(prt[0]));
fprintf(f," {prt[\"%s\"],prt[\"%s\"]}\n",
AtomValue(prt[2]),AtomValue(prt[3]));
if(FAver==4)
fprintf(f,"dir = SetupCodeDir[\"scan_%s\"]\n",pname);
if(FAver>4)
fprintf(f,"name = \"%s\"\n",pname);
fprintf(f,"SetOptions[InsertFields,Model->model%d, GenericModel->model%d,\n",
ModelNumber,ModelNumber);
fprintf(f," ExcludeParticles->{ ");
if(color[0]&&color[1]&&color[2]&&color[3])
{
int glu=1,gno=1;
if(GetAtomProperty(prt[0],A_ANTI)!=prt[1]) glu=0;
if(spin[0]==0&&spin[1]==0&&spin[2]==0&&spin[3]==0) gno=0;
if(glu)
fprintf(f,"prt[\"G\"]%c ",gno?',':' ');
if(gno)
fprintf(f,"prt[\"~%c\"] ",ModelNumber>30?'G':'g');
}
fprintf(f,"} ]\n");
fprintf(f,"END\n\n");
fprintf(f,"if test ! -d scan_%s/squaredme ;\n",pname);
fprintf(f,"then math < %s.m;\n",dec?"scand":"scan");
fprintf(f,"fi\n\n");
fprintf(f,"num1=$((`date +%%s`-num0))\nnum0=`date +%%s`\n\n");
fprintf(f,"if test ! -d scan_%s/squaredme ;\n",pname);
fprintf(f,"then echo Output directory is not created | tee -a scan.log && exit;\n");
fprintf(f,"fi\n\n");
fprintf(f,"if test ! -d drivers/F ;\n");
fprintf(f,"then cat > scan_%s/process.h <<END\n",pname);
for(i=1;i<=4;i++)
{
int i1=i;
if(dec&&i==2) continue;
if(dec&&i>2) i1=i-1;
fprintf(f,"#define TYPE%d %s\n",i1,
spin[i-1]==0?"SCALAR":(spin[i-1]==1?"FERMION":
(mass[i-1]==0?"PHOTON":"VECTOR")));
fprintf(f,"#define MASS%d %s\n",i1,mass[i-1]?AtomValue(mass[i-1]):"0");
fprintf(f,"#define CHARGE%d 0\n\n",i1);
}
fprintf(f,"#define IDENTICALFACTOR %s\n",(prt[2]==prt[3])?"0.5":"1");
fprintf(f,"#define COLOURFACTOR %dD0",neufact);
if(color[0] && color[1]) fprintf(f,"/9D0");
else if(color[0] || color[1]) fprintf(f,"/3D0");
fprintf(f,"\n");
if(FAver>4)
{fprintf(f,"#define SCALE sqrtS\n#define LUMI \"lumi_parton.F\"\n");
fprintf(f,"c#define FORCE_ONSHELL\n");
}
fprintf(f,"#define NCOMP 2\n#include \"%cto2.F\"\nEND\n\nfi\n\n",dec?'1':'2');
/*
fprintf(f,"cp model%d.h scan_%s/model.h\n",ModelNumber,pname);
fprintf(f,"cp mdl_ini%d.F scan_%s/mdl_ini.F\n\n",ModelNumber,pname);
*/
if(FAver==4)
fprintf(f,"cp main.F scan_%s/\n\n",pname);
if(thcut!=0.0)
{
fprintf(f,"echo \"#define THETACUT (%f*degree)\" > scan_%s/run.F\n",
thcut,pname);
fprintf(f,"grep -v THETACUT drivers/run.F >> scan_%s/run.F\n",pname);
}
fprintf(f,"cd scan_%s\n",pname);
fprintf(f,"sz0=`du -sm .`\n");
fprintf(f,"if test ! -f run ;\n");
fprintf(f,"then ./configure ;\n");
fprintf(f,"fi\n\n");
fprintf(f,"rm run ru*.01000*/*\n");
fprintf(f,"gmake\n");
fprintf(f,"if test ! -f run ;\n");
fprintf(f,"then echo Run file is not created | tee -a ../scan.log && exit;\n");
fprintf(f,"fi\n");
fprintf(f,"num2=$((`date +%%s`-num0))\nnum0=`date +%%s`\n\n");
fprintf(f,"sz1=`du -sm .`\n");
fprintf(f,"./run uuuu 1000,1000\n");
if(FAver>4)
fprintf(f,"../exval6 ru*.01000*/* >> ../scan.log\n\n\n");
fprintf(f,"cd ..\n");
// fprintf(f,"grep \"| 1000.000\" scan_%s/ru*.01000*/* >> scan.log\n\n\n",
// pname);
if(FAver==4)
fprintf(f,"./exval scan_%s/ru*.01000*/* >> scan.log\n\n\n",pname);
fprintf(f,"num3=$((`date +%%s`-num0))\n\n");
fprintf(f,"echo $num1 + $num2 + $num3 = $(((num1+num2+num3)/60))");
fprintf(f," min \\\n $sz0/$sz1 MB >> scan.log\n");
fprintf(f,"rm -rf scan_%s\n\n",pname);
fclose(f);
return 0;
}
/* retrieving environment variables */
inline bool get_bool (string var) {
tree t= env [var];
if (is_compound (t)) return false;
return as_bool (t->label); }
Term ProcLet(Term t, Term ind)
{
Term t1,nm,sub,kl=0;
List il,ol,l1;
int transf_fl=0;
Atom anti1=0, anti2=0;
ol=il=NewList();
t1=ConsumeCompoundArg(t,1);
FreeAtomic(t);
t1=ProcessAlias(t1);
if(is_compound(t1) && CompoundArity(t1)==2 && CompoundName(t1)==OPR_COMMA)
{
Term a1,a2;
a1=ConsumeCompoundArg(t1,1);
a2=ConsumeCompoundArg(t1,2);
FreeAtomic(t1);
ProcLet(MakeCompound1(OPR_LET,a1),0);
ProcLet(MakeCompound1(OPR_LET,a2),0);
return 0;
}
if(!is_compound(t1) || CompoundArity(t1)!=2 ||
(CompoundName(t1)!=OPR_EQSIGN && CompoundName(t1)!=OPR_RARROW))
{
ErrorInfo(325);
printf("bad argument in let statement\n");
return 0;
}
if(CompoundName(t1)==OPR_EQSIGN && is_atom(CompoundArg1(t1)) &&
is_atom(CompoundArg2(t1)) &&
(CompoundArg2(t1)==A_GAMMA5 || GetAtomProperty(CompoundArg2(t1),
A_GAMMA5)))
{
SetAtomProperty(CompoundArg1(t1),A_GAMMA5,NewInteger(1));
}
if(CompoundName(t1)==OPR_RARROW)
transf_fl=1;
if(CompoundName(t1)==OPR_EQSIGN && is_atom(CompoundArg1(t1)) &&
is_compound(CompoundArg2(t1)) &&
CompoundName(CompoundArg2(t1))==A_ANTI &&
is_atom(CompoundArg1(CompoundArg2(t1))))
{
anti1=CompoundArg1(t1);
anti2=CompoundArg1(CompoundArg2(t1));
}
nm=ConsumeCompoundArg(t1,1);
sub=ConsumeCompoundArg(t1,2);
FreeAtomic(t1);
if(transf_fl)
allow_transf_lets=0;
if(is_compound(nm) && (CompoundName(nm)==OPR_USCORE ||
CompoundName(nm)==OPR_CARET))
nm=SplitIndices(nm,&il);
if(!is_atom(nm))
{
ErrorInfo(325);
printf("bad left argument in let call\n");
FreeAtomic(sub);
FreeAtomic(t1);
return 0;
}
if(transf_fl)
{
if(!is_parameter(nm) && !is_particle(nm,NULL))
{
ErrorInfo(728);
printf("Unknown object '%s'.\n",AtomValue(nm));
return 0;
}
}
if(GetAtomProperty(nm,A_KEEP_LETS))
{
Term prp;
kl=ExprTo1kl(CopyTerm(sub));
if(kl==0)
return 0;
prp=GetAtomProperty(nm,A_KEEP_LETS);
SetCompoundArg(prp,1,kl);
}
sub=ExprTo1(sub);
alg1_set_cos0(sub);
if(sub==0)
return 0;
if(transf_fl)
allow_transf_lets=1;
t1=CopyTerm(CompoundArg2(sub));
if(is_empty_list(il))
{
l1=t1;
while(!is_empty_list(l1))
{
Term t;
t=CompoundArg2(ListFirst(l1));
if(!is_label(t))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
ol=AppendLast(ol,t);
l1=ListTail(l1);
}
/* mk_let(nm,sub,ol,t1); */
}
else
{
List t2;
t2=0;
if(ListLength(il)!=ListLength(t1))
{
ErrorInfo(327);
printf("distinct indices number ");
printf("in let statement.\n");
FreeAtomic(sub);
FreeAtomic(t1);
return 0;
}
l1=t1;
while(!is_empty_list(l1))
{
Term t;
t=CompoundArg2(ListFirst(l1));
if(!is_atom(t) || !ListMember(il,t))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
ol=AppendLast(ol,t);
l1=ListTail(l1);
}
l1=il;
while(!is_empty_list(l1))
{
List l2;
if(!ListMember(ol,ListFirst(l1)))
{
ErrorInfo(326);
printf("unbalanced index '");
WriteTerm(t);
printf("' in let statement\n");
FreeAtomic(sub);
FreeAtomic(t1);
FreeAtomic(ol);
return 0;
}
for(l2=t1;l2;l2=ListTail(l2))
if(ListFirst(l1)==CompoundArg2(ListFirst(l2)))
{
t2=AppendLast(t2,ListFirst(l2));
break;
}
l1=ListTail(l1);
}
RemoveList(t1);
t1=t2;
FreeAtomic(ol);
ol=il;
}
/* mk_let(nm,sub,ol,t1); */
l1=t1;
while(!is_empty_list(l1))
{
SetCompoundArg(ListFirst(l1),2,0);
l1=ListTail(l1);
}
/*WriteTerm(sub); puts(""); getchar();*/
t=MakeCompound(OPR_LET,5);
SetCompoundArg(t,1,sub);
SetCompoundArg(t,2,ol);
SetCompoundArg(t,3,alg1_inv_alg(sub));
if(transf_fl==0)
{
Term tt;
tt=alg1_guess_mpl(sub);
if(tt)
{
SetCompoundArg(t,4,NewInteger(1));
SetCompoundArg(t,5,tt);
}
else
{
int tp;
tt=alg1_guess_mtr(sub, &tp);
if(tt)
{
SetCompoundArg(t,4,NewInteger(tp));
SetCompoundArg(t,5,tt);
}
}
ReportRedefined(nm,"let-substitution");
SetAtomProperty(nm,PROP_INDEX,t1);
SetAtomProperty(nm,PROP_TYPE,t);
alg1_let_cw(nm);
if(anti1 && anti2)
{
SetAtomProperty(anti1,A_ANTI,anti2);
SetAtomProperty(anti2,A_ANTI,anti1);
}
else
if(only_prm(CompoundArg1(t)))
SetAtomProperty(nm,A_ANTI,nm);
return 0;
}
l1=GetAtomProperty(nm,PROP_INDEX);
if(!EqualTerms(l1,t1))
{
ErrorInfo(729);
puts("transformed object has other indices types");
return 0;
}
if(GetAtomProperty(nm,OPR_LET))
{
WarningInfo(0);
printf("Warning: transformation rule for '%s' is redefined.\n",
AtomValue(nm));
}
SetAtomProperty(nm,OPR_LET,t);
return 0;
}
Term ProcChVertex(Term t, List ind)
{
List l, pl, ml;
Term rpl;
Atom a1, a2;
int pli;
int ii;
if(lagr_hash==NULL)
{
ErrorInfo(107);
puts("ChVertex: no vertices");
return 0;
}
if(!is_compound(t)||CompoundArity(t)!=2)
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
pl=CompoundArg1(t);
for(l=pl;l;l=ListTail(l))
if(is_function(ListFirst(l),0))
ChangeList(l,CallFunction(ListFirst(l),0));
rpl=CompoundArg2(t);
if(!is_list(pl)|| !is_compound(rpl) || CompoundArity(rpl)!=2)
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
a1=CompoundArg1(rpl);a2=CompoundArg2(rpl);
if(!is_parameter(a1)||!is_parameter(a2))
{
ErrorInfo(107);
puts("wrong call to ChVertex");
return 0;
}
pl=SortedList(pl,acmp);
l=finda2(pl,0);
if(is_empty_list(l))
{
WarningInfo(108);printf("ChVertex: vertex ");
WriteTerm(pl); puts(" not found");
return 0;
}
ml=CompoundArgN(ListFirst(l),5);
ii=0;
for(l=ml;l;l=ListTail(l))
{
List l1;
for(l1=CompoundArg2(ListFirst(l));l1;l1=ListTail(l1))
if(CompoundArg1(ListFirst(l1))==a1)
{
SetCompoundArg(ListFirst(l1),1,a2);ii++;
}
}
if(ii==0)
{
WarningInfo(107);printf("ChVertex: vertex ");WriteTerm(pl);
printf("has no '%s' within.\n",AtomValue(a1));
}
return 0;
}
void
edit_select_rep::raw_cut (path p1, path p2) {
if (p2 == p1) return;
path p = common (p1, p2);
tree t = subtree (et, p);
int n = N(p);
int i1= p1[n];
int i2= p2[n];
if (is_document (t) || is_concat (t)) {
path q1= copy (p); q1 << path (i1, end (t[i1]));
path q2= copy (p); q2 << path (i2, start (t[i2]));
raw_cut (q2, p2);
if (i2>i1+1) remove (p * (i1+1), i2-i1-1);
raw_cut (p1, q1);
if (is_concat (t)) correct_concat (p);
else remove_return (p * i1);
return;
}
if (is_func (t, TFORMAT) || is_func (t, TABLE) || is_func (t, ROW)) {
path fp= ::table_search_format (et, p);
tree st= subtree (et, fp);
int row1, col1, row2, col2;
table_search_coordinates (st, tail (p1, N(fp)), row1, col1);
table_search_coordinates (st, tail (p2, N(fp)), row2, col2);
if (row1>row2) { int tmp= row1; row1= row2; row2= tmp; }
if (col1>col2) { int tmp= col1; col1= col2; col2= tmp; }
int i, j;
for (i=row1; i<=row2; i++)
for (j=col1; j<=col2; j++) {
path cp= fp * ::table_search_cell (st, i, j);
if (is_func (subtree (et, cp), CELL, 1)) cp= cp * 0;
assign (cp, "");
}
path cp= fp * ::table_search_cell (st, row1, col1);
go_to (cp * path (0, 0));
if (is_func (st, TFORMAT))
table_del_format (fp, row1+1, col1+1, row2+1, col2+1, "");
return;
}
if (is_compound (t) && (!is_format (t))) {
assign (p, "");
return;
}
if ((N(p1) != (N(p)+1)) || (N(p2) != (N(p)+1))) {
cerr << "t = " << t << "\n";
cerr << "p = " << p << "\n";
cerr << "p1= " << p1 << "\n";
cerr << "p2= " << p2 << "\n";
FAILED ("invalid cut");
}
if (is_atomic (t)) {
int pos= last_item (p1);
int nr = last_item (p2)-pos;
if (nr>0) remove (p1, nr);
}
else {
if ((last_item (p1) != 0) || (last_item (p2) != 1)) {
cerr << "t = " << t << "\n";
cerr << "p = " << p << "\n";
cerr << "p1= " << p1 << "\n";
cerr << "p2= " << p2 << "\n";
FAILED ("invalid object cut");
}
assign (p, "");
}
}
Term AtomicTo1(Term t, Term ind)
{
List rl;
Term ret;
Term t1;
Atom ttype;
if(is_compound(t) && CompoundName(t)==A_ALG1)
{
List l;
ttype=A_ALG1;
rl=CopyTerm(CompoundArg2(t));
for(l=rl;l;l=ListTail(l))
SetCompoundArg(ListFirst(l),2,0);
goto cnt;
}
if(is_compound(t) && CompoundName(t)==A_FBRACET)
{
t=alg1_mk_wild(t,&rl,&ind);
ttype=OPR_WILD;
goto cnt;
}
/*
if(is_compound(t) && CompoundName(t)==A_CC)
{
t=cc_particle(t,&rl);
ttype=OPR_FIELD;
goto cnt;
}
*/
if(is_let(t,&rl))
{
ttype=OPR_LET;
goto cnt;
}
if(is_parameter(t) || (is_compound(t) && (CompoundName(t)==A_COS ||
CompoundName(t)==A_SIN)) )
{
rl=NewList();
ttype=OPR_PARAMETER;
goto cnt;
}
if(is_particle(t,&rl))
{
ttype=OPR_FIELD;
goto cnt;
}
if(is_special(t,&rl))
{
ttype=OPR_SPECIAL;
goto cnt;
}
ErrorInfo(301);
printf(" \'%s\' undefined object.\n",AtomValue(t));
FreeAtomic(ind);
longjmp(alg1_jmp_buf,1);
cnt:
ret=MakeCompound(A_MTERM,4);
SetCompoundArg(ret,1,NewInteger(1));
SetCompoundArg(ret,2,NewInteger(1));
t1=0;
if(!is_empty_list(rl))
{
Term ttt;
int skipped;
rl=CopyTerm(rl);
if(is_empty_list(ind))
{
SetCompoundArg(ret,3,AppendFirst(NewList(),MakeCompound2(ttype,rl,t)));
return AppendFirst(NewList(),ret);
}
skipped=must_skip(ListLength(ind),rl);
if(skipped==-1)
{
ErrorInfo(302);
printf(" can not set indices ");
WriteTerm(ind);
printf(" to \'%s\'.\n",AtomValue(t));
FreeAtomic(ind); FreeAtomic(rl);
longjmp(alg1_jmp_buf,1);
}
t1=rl;
ttt=ind;
while(!is_empty_list(rl))
{
if(skipped!=0 && should_skip(skipped,CompoundArg1(ListFirst(rl))))
{ rl=ListTail(rl); continue; }
SetCompoundArg(ListFirst(rl),2,ListFirst(ttt));
rl=ListTail(rl);
ttt=ListTail(ttt);
}
FreeAtomic(ind);
}
if(ttype==OPR_PARAMETER && is_compound(t))
{
Term mmm=MakeCompound(ttype,CompoundArity(t)+2);
SetCompoundArg(mmm,1,t1);
SetCompoundArg(mmm,2,CompoundName(t));
SetCompoundArg(mmm,3,CompoundArg1(t));
if(CompoundArity(t)==2)
{
Term m=ExprTo1(ConsumeCompoundArg(t,2));
m=CompoundArg1(m);
if(ListLength(m)!=1)
{
ErrorInfo(0);
puts("bad expression in sin/cos.");
longjmp(alg1_jmp_buf,1);
}
m=ListFirst(m);
SetCompoundArg(mmm,4,m);
}
SetCompoundArg(ret,3,AppendFirst(NewList(),mmm));
}
else
SetCompoundArg(ret,3,AppendFirst(NewList(),MakeCompound2(ttype,t1,t)));
return AppendFirst(NewList(),ret);
}
tree
texmacs_invarianted_merge (tree t, string src,
tree org, tree u, hashmap<tree,path> h) {
if (is_atomic (t)) return t;
else {
if (true) {
int i, n= N(t);
tree r (t, n);
for (i=0; i<n; i++)
r[i]= texmacs_invarianted_merge (t[i], src, org, u, h);
t= r;
}
if (is_concat (t) || is_document (t)) {
int i, n= N(t);
tree r (L(t));
for (i=0; i<n; i++) {
if (is_document (t) && is_compound (t[i], "ilx", 1))
t[i]= compound ("ilx", texmacs_invarianted_extend (t[i][0], src));
if (N(r) > 0 &&
is_compound (r[N(r)-1], "ilx", 1) &&
is_compound (t[i], "ilx", 1)) {
int b1, e1, b2, e2;
bool ok = get_range (r[N(r)-1][0], b1, e1, src);
ok = get_range (t[i][0], b2, e2, src) || ok;
if (ok && e1 <= b2) {
skip_latex_spaces (src, e1);
if (e1 >= b2) {
string id= as_string (b1) * ":" * as_string (e2);
r[N(r)-1][0]= id;
continue;
}
}
}
int j= i;
while (j<n && !is_compound (t[j], "ilx", 1)) j++;
if (j < n && j > i && N(r) > 0 && is_compound (r[N(r)-1], "ilx", 1)) {
// NOTE: this special treatment allows for the recognition of
// pieces which may be invarianted even in case of missing markers
int b1, e1, b2, e2;
bool ok1= get_range (r[N(r)-1][0], b1, e1, src);
bool ok2= get_range (t[j][0], b2, e2, src);
if (ok1 && ok2 && e1 <= b2 && i-1 < N(org)) {
path p= h [org[i-1]];
if (p != path (-1)) {
tree pt= subtree (u, path_up (p));
int k, k2= last_item (p);
for (k=i-1; k<=j && k2<N(pt); k++, k2++)
if (org[k] != pt[k2]) {
//cout << " <<< " << org[k] << LF
// << " >>> " << pt[k2] << LF;
break;
}
if (k > j) {
string id= as_string (b1) * ":" * as_string (e2);
r[N(r)-1][0]= id;
i= j;
continue;
}
}
}
}
r << t[i];
}
if (is_concat (r) && N(r) == 1) r= r[0];
return r;
}
return t;
}
}
tree
rewrite_impl (tree t) {
switch (L(t)) {
case EXTERN:
{
int i, n= N(t);
tree r (TUPLE, n);
for (i=0; i<n; i++)
r[i]= evaluate (t[i]);
object expr= null_object ();
for (i=n-1; i>0; i--)
expr= cons (object (r[i]), expr);
string fun= evaluate_string (t[0]);
expr= cons (string_to_object (fun), expr);
bool secure= as_bool (std_env ["secure"]);
if (!secure && script_status < 2) {
if (!as_bool (call ("secure?", expr)))
return tree (ERROR, "insecure script");
}
environment old_env= reenter_rewrite_env;
reenter_rewrite_env= std_env;
object o= eval (expr);
reenter_rewrite_env= old_env;
return content_to_tree (o);
}
#ifdef CLASSICAL_MACRO_EXPANSION
case MAP_ARGS:
{
if (!(is_atomic (t[0]) && is_atomic (t[1]) && is_atomic (t[2])))
return evaluate_error ("invalid map-args");
if (macro_top_level (std_env))
return evaluate_error ("undefined", t[2]);
basic_environment local= macro_arguments (std_env);
int key= make_tree_label (t[2]->label);
if (!local->contains (key))
return evaluate_error ("undefined", t[2]);
tree v= local [key];
if (is_atomic (v))
return evaluate_error ("invalid-map-args");
macro_up (std_env);
int start= 0, end= N(v);
if (N(t)>=4) start= as_int (evaluate (t[3]));
if (N(t)>=5) end = as_int (evaluate (t[4]));
int i, n= max (0, end-start);
tree r (make_tree_label (t[1]->label), n);
for (i=0; i<n; i++)
r[i]= tree (make_tree_label (t[0]->label),
tree (ARG, copy (t[2]), as_string (start+i)),
as_string (start+i));
macro_redown (std_env, local);
return r;
}
#endif // CLASSICAL_MACRO_EXPANSION
case VAR_INCLUDE:
{
url base_file_name (as_string (std_env ["base-file-name"]));
url file_name= url_system (evaluate_string (t[0]));
return load_inclusion (relative (base_file_name, file_name));
}
case REWRITE_INACTIVE:
{
#ifdef CLASSICAL_MACRO_EXPANSION
if ((!is_func (t[0], ARG)) || is_compound (t[0][0]))
return evaluate_error ("invalid rewrite-inactive");
if (macro_top_level (std_env))
return evaluate_error ("undefined", t[0][0]);
basic_environment local= macro_arguments (std_env);
int key= make_tree_label (t[0][0]->label);
if (!local->contains (key))
return evaluate_error ("undefined", t[0][0]);
tree val= local [key];
int i, n= N(t[0]);
for (i=1; i<n; i++) {
int j= as_int (t[0][i]);
if ((j>=0) && (j<N(val))) val= val[j];
else return evaluate_error ("invalid rewrite-inactive");
}
#else
tree val= t[0];
#endif
int inactive_mode= INACTIVE_INLINE_RECURSE;
if (t[1] == "recurse") inactive_mode= INACTIVE_INLINE_RECURSE;
else if (t[1] == "recurse*") inactive_mode= INACTIVE_BLOCK_RECURSE;
else if (t[1] == "once") inactive_mode= INACTIVE_INLINE_ONCE;
else if (t[1] == "once*") inactive_mode= INACTIVE_BLOCK_ONCE;
else if (t[1] == "error") inactive_mode= INACTIVE_INLINE_ERROR;
else if (t[1] == "error*") inactive_mode= INACTIVE_BLOCK_ERROR;
return rewrite_inactive (val, inactive_mode);
}
default:
return t;
}
}
void
edit_process_rep::generate_bibliography (
string bib, string style, string fname)
{
system_wait ("Generating bibliography, ", "please wait");
if (DEBUG_AUTO)
debug_automatic << "Generating bibliography"
<< " [" << bib << ", " << style << ", " << fname << "]\n";
tree bib_t= buf->data->aux[bib];
if (buf->prj != NULL) bib_t= buf->prj->data->aux[bib];
tree t;
url bib_file= find_bib_file (buf->buf->name, fname);
//cout << fname << " -> " << concretize (bib_file) << "\n";
if (is_none (bib_file)) {
url bbl_file= find_bib_file (buf->buf->name, fname, ".bbl");
if (is_none (bbl_file)) {
if (supports_db ()) {
t= as_tree (call (string ("bib-compile"), bib, style, bib_t));
call (string ("bib-attach"), bib, bib_t);
}
else {
std_error << "Could not load BibTeX file " << fname;
set_message ("Could not find bibliography file",
"compile bibliography");
return;
}
}
else t= bibtex_load_bbl (bib, bbl_file);
}
else {
if (!bibtex_present () && !starts (style, "tm-")) {
if (style == "abbrv") style= "tm-abbrv";
else if (style == "acm") style= "tm-acm";
else if (style == "alpha") style= "tm-alpha";
else if (style == "elsart-num") style= "tm-elsart-num";
else if (style == "ieeetr") style= "tm-ieeetr";
else if (style == "siam") style= "tm-siam";
else if (style == "unsrt") style= "tm-unsrt";
else style= "tm-plain";
}
if (supports_db () && !is_rooted (bib_file))
bib_file= find_bib_file (buf->buf->name, fname, ".bib", true);
if (supports_db ()) {
//(void) call (string ("bib-import-bibtex"), bib_file);
t= as_tree (call (string ("bib-compile"), bib, style, bib_t, bib_file));
}
else if (starts (style, "tm-")) {
string sbib;
if (load_string (bib_file, sbib, false))
std_error << "Could not load BibTeX file " << fname;
tree te= bib_entries (parse_bib (sbib), bib_t);
object ot= tree_to_stree (te);
eval ("(use-modules (bibtex " * style (3, N(style)) * "))");
t= stree_to_tree (call (string ("bib-process"),
bib, style (3, N(style)), ot));
}
else
t= bibtex_run (bib, style, bib_file, bib_t);
if (supports_db ())
(void) call (string ("bib-attach"), bib, bib_t, bib_file);
}
if (is_atomic (t) && starts (t->label, "Error:"))
set_message (t->label, "compile bibliography");
else if (is_compound (t) && N(t) > 0) insert_tree (t);
}
void
edit_process_rep::generate_aux_recursively (string which, tree st, path p) {
int i, n= N(st);
for (i=0; i<n; i++)
if (!is_aux (st[i])) {
if (is_compound (st[i]))
generate_aux_recursively (which, st[i], p * i);
}
else {
tree t= st[i];
path doc_p= p * path (i, N(t)-1);
assign (doc_p, tree (DOCUMENT, ""));
go_to (doc_p * path (0, 0));
/*
cout << "et= " << et << "\n";
cout << "tp= " << tp << "\n";
cout << "------------------------------------------------------\n";
*/
if (arity (t) >= 1) {
if ((arity(t) >= 3) &&
(is_compound (t, "bibliography") ||
is_compound (t, "bibliography*")) &&
((which == "") || (which == "bibliography")))
generate_bibliography (as_string (t[0]), as_string (t[1]),
as_string (t[2]));
if ((is_compound (t, "table-of-contents") ||
is_compound (t, "table-of-contents*")) &&
((which == "") || (which == "table-of-contents")))
generate_table_of_contents (as_string (t[0]));
if ((is_compound (t, "the-index") || is_compound (t, "the-index*")) &&
((which == "") || (which == "the-index")))
generate_index (as_string (t[0]));
if ((is_compound (t, "the-glossary") ||
is_compound (t, "the-glossary*")) &&
((which == "") || (which == "the-glossary")))
generate_glossary (as_string (t[0]));
if (is_compound (t, "list-of-figures") &&
((which == "") || (which == "list-of-figures")))
generate_glossary (as_string (t[0]));
if (is_compound (t, "list-of-tables") &&
((which == "") || (which == "list-of-tables")))
generate_glossary (as_string (t[0]));
}
/*
cout << "et= " << et << "\n";
cout << "tp= " << tp << "\n";
cout << "------------------------------------------------------\n\n\n";
*/
}
}
static tree
move_brackets_sub (tree t, bool in) {
//cout << t << INDENT << LF;
if (is_compound (t)) {
int i, n= N(t);
tree r= tree (t, n);
for (i=0; i<n; i++)
r[i]= move_brackets_sub (t[i], in);
t= r;
}
while (true) {
tree r= t;
bool search= true;
if (is_concat (t))
for (int i=0; i<N(t) && search; i++)
if (is_compound (t[i], "math")) {
array<tree> a= concat_tokenize (t[i][0]);
for (int j=0; j<N(a) && search; j++)
if (is_atomic (a[j]) && is_simple_opening (a[j]->label))
for (int k= i+1; k<N(t) && search; k++)
if (is_atomic (t[k])) {
string s= t[k]->label;
for (int l=0; l<N(s) && search; tm_char_forwards (s, l))
if (is_simple_matching (a[j]->label, s (l, l+1))) {
if (k == i+1 && l == 0 && in) {
array<tree> c= concat_decompose (t);
a << tree (s (0, 1));
c[i]= compound ("math", concat_recompose (a));
c[i]= upgrade_brackets (c[i]);
c[i+1]= s (1, N(s));
r= move_brackets_sub (concat_recompose (c), in);
search= false;
}
else if (j == 0 && !in) {
tree x= a[0];
array<tree> c= concat_decompose (t);
a= range (a, 1, N(a));
c[i]= compound ("math", concat_recompose (a));
c= append (range (c, 0, i),
append (x, range (c, i, N(c))));
r= move_brackets_sub (concat_recompose (c), in);
search= false;
}
}
}
for (int j=N(a)-1; j>=0 && search; j--)
if (is_atomic (a[j]) && is_simple_closing (a[j]->label))
for (int k= i-1; k>=0 && search; k--)
if (is_atomic (t[k])) {
string s= t[k]->label;
for (int l=N(s); l>0 && search; tm_char_backwards (s, l))
if (is_simple_matching (s (l-1, l), a[j]->label)) {
if (k == i-1 && l == N(s) && in) {
array<tree> c= concat_decompose (t);
a= append (tree (s (l-1, l)), a);
c[i]= compound ("math", concat_recompose (a));
c[i]= upgrade_brackets (c[i]);
c[i-1]= s (0, l-1);
r= move_brackets_sub (concat_recompose (c), in);
search= false;
}
else if (j == N(a)-1 && !in) {
tree x= a[j];
array<tree> c= concat_decompose (t);
a= range (a, 0, j);
c[i]= compound ("math", concat_recompose (a));
c= append (range (c, 0, i+1),
append (x, range (c, i+1, N(c))));
r= move_brackets_sub (concat_recompose (c), in);
search= false;
}
}
}
}
if (search) break;
else {
//cout << "< " << t << LF;
//cout << "> " << r << LF;
t= r;
}
}
//cout << UNINDENT << "Done" << LF;
return t;
}
inline double get_double (string var) {
tree t= env [var];
if (is_compound (t)) return 0.0;
return as_double (t->label); }
static List s_l_1(Term m1)
{
List l,l1;
l=CompoundArgN(m1,3);
while(!is_empty_list(l))
{
Term t1;
t1=ListFirst(l);
if(CompoundName(t1)==OPR_LET)
{
Term sub,a1,ila,ill;
a1=sub=ConsumeCompoundArg(t1,2);
ill=ConsumeCompoundArg(t1,1);
FreeAtomic(t1);
ChangeList(l,0);
sub=CopyTerm(GetAtomProperty(a1,OPR_LET));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
sub=CopyTerm(GetAtomProperty(a1,PROP_TYPE));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
printf("Internal error: inconsistent substitution '");
WriteTerm(CompoundArg2(a1));
puts("'");
longjmp(alg1_jmp_buf,1);
}
}
renewlab(sub);
a1=ConsumeCompoundArg(sub,1);
ila=ConsumeCompoundArg(sub,2);
FreeAtomic(sub);
repl_ind(a1,ila,ill);
return SetLets(mk_let(m1,l,a1));
}
l=ListTail(l);
}
l=CompoundArgN(m1,4);
while(!is_empty_list(l))
{
Term t1;
t1=ListFirst(l);
if(CompoundName(t1)==OPR_LET)
{
Term sub,a1,ila,ill;
a1=sub=ConsumeCompoundArg(t1,2);
ill=ConsumeCompoundArg(t1,1);
if(ill)
{
puts("Integnal error (iinld)");
longjmp(alg1_jmp_buf,1);
}
l1=ConsumeCompoundArg(m1,4);
l1=CutFromList(l1,l);
SetCompoundArg(m1,4,l1);
sub=CopyTerm(GetAtomProperty(a1,OPR_LET));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
sub=CopyTerm(GetAtomProperty(a1,PROP_TYPE));
if(sub==0 || !is_compound(sub) || CompoundName(sub)!=OPR_LET)
{
printf("Internal error: inconsistent substitution '");
WriteTerm(CompoundArg2(a1));
puts("'");
longjmp(alg1_jmp_buf,1);
}
}
renewlab(sub);
if(CompoundArgN(sub,3)==0)
{
ErrorInfo(378);
printf("symbol '%s' can not be in denominator\n",AtomValue(a1));
longjmp(alg1_jmp_buf,1);
}
a1=ConsumeCompoundArg(sub,3);
ila=ConsumeCompoundArg(sub,2);
FreeAtomic(sub);
if(ila)
{
puts("Internal error (iidl1)");
longjmp(alg1_jmp_buf,1);
}
return SetLets(mk_let_d(m1,a1));
}
l=ListTail(l);
}
return AppendFirst(NewList(),m1);
}
inline string get_string (string var) {
tree t= env [var];
if (is_compound (t)) return "";
return t->label; }
void ProcessTerm(Term t)
{
Term res;
Atom procc=0;
char regbuf[80];
if(is_compound(t)&&CompoundName(t)==OPR_LOCAL)
{
List l1,la=ConsumeCompoundArg(t,1);
if(l_pro==0)
{
ErrorInfo(0);
puts("local: must be within template.");
return;
}
la=CommaToList(la);
for(l1=la;l1;l1=ListTail(l1))
l_ali=AppendLast(l_ali,
InterfSetAlias(MakeCompound1(OPR_ALIAS,ListFirst(l1)),0));
RemoveList(la);
return;
}
/* if(is_compound(t) && GetAtomProperty(CompoundName(t),OPR_ALIAS))
{*/
if(!is_compound(t) || (CompoundName(t)!=OPR_ALIAS &&
CompoundName(t)!=OPR_IN && CompoundName(t)!=OPR_WHERE) )
{
t=ProcessAlias(t);
proc_hash(t);
}
/*WriteTerm(t);puts("");*/
/*}*/
if(is_list(t))
{
List l, alisav;
l_pro++;
alisav=l_ali;
l_ali=0;
for(l=t;l;l=ListTail(l))
ProcessTerm(ListFirst(l));
if(l_ali)
RemoveAlias(l_ali);
RemoveList(t);
l_pro--;
l_ali=alisav;
return;
}
if(is_atom(t))
procc=t;
if(is_compound(t))
{
procc=CompoundName(t);
}
if(procc==0)
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Not a valid operator \'");
WriteTerm(t);
printf("\'.\n");
FreeAtomic(t);
return;
}
if(!IsTermInput())
sprintf(regbuf, "ProcTerm: File %s, line %d: %s statement.",
CurrentInputFile(), CurrentInputLine(), AtomValue(procc));
else
sprintf(regbuf, "(tty): %s statement.",AtomValue(procc));
RegisterLine(regbuf);
if(!is_function(t,NULL))
{
if(!IsTermInput())
printf("File \"%s\", line %d: ",CurrentInputFile(),
CurrentInputLine());
printf("Unknown operator \'%s\' in expression\n\t",AtomValue(procc));
WriteTerm(t);
puts("");
FreeAtomic(t);
UnregisterLine();
return;
}
if(is_compound(t) && ((VerbMode && CompoundName(t)==OPR_LTERM) ||
VerbMode==3))
{
char sment[1024];
sWriteTerm(sment,t);
sment[55]='.';
sment[56]='.';
sment[57]='.';
sment[58]=0;
printf("%s:%3d: %s\n",CurrentInputFile(),CurrentInputLine(),sment);
}
res=CallFunction(t,0);
if(res!=0 && (IsTermInput()))
{
if(is_compound(res) && CompoundArity(t)==2 &&
CompoundName(res)==A_ALG1)
res=Alg1ToExpr(res);
if(is_list(res))
DumpList(res);
else
{
WriteTerm(res);
puts("");
}
FreeAtomic(res);
}
UnregisterLine();
}
Term ExpandTerm(Term t)
{
List il=0;
Term res;
/*puts("");
WriteTerm(t);
puts("\n");*/
if(is_compound(t) && (CompoundName(t)==OPR_USCORE || CompoundName(t)==OPR_CARET))
{
t=SplitIndices(t,&il);
if(t==0)
longjmp(alg1_jmp_buf,1);
}
if(is_function(t,NULL))
return ExpandTerm(CallFunction(t,il));
if(is_float(t))
{
ErrorInfo(303);
printf(" illegal use of floating point number %f.\n",FloatValue(t));
FreeAtomic(t);
longjmp(alg1_jmp_buf,1);
}
if(is_integer(t))
{
if(IntegerValue(t)==0)
return 0;
if(il)
{
ErrorInfo(304);
puts("Integer can't have indices.\n");
longjmp(alg1_jmp_buf,1);
}
res=MakeCompound(A_MTERM,4);
SetCompoundArg(res,1,t);
SetCompoundArg(res,2,NewInteger(1));
return AppendFirst(0,res);
}
if(t==A_I)
{
res=MakeCompound(A_MTERM,4);
SetCompoundArg(res,1,NewInteger(1));
SetCompoundArg(res,2,NewInteger(-1));
return AppendFirst(0,res);
}
if(is_atom(t) || (is_compound(t) && CompoundName(t)==A_FBRACET) ||
(is_compound(t) && CompoundName(t)==A_ALG1 && CompoundArity(t)==2) ||
(is_compound(t) && (CompoundName(t)==A_SIN || CompoundName(t)==A_COS)
&& CompoundArity(t)<3 && is_integer(CompoundArg1(t))))
return AtomicTo1(t,il);
if(!is_empty_list(il))
{
ErrorInfo(307);
printf(" bad indices ");
WriteTerm(il);
printf(" in expression.\n");
longjmp(alg1_jmp_buf,1);
}
if(opSetGpm && is_compound(t) && CompoundArity(t)==2 && CompoundArg1(t)==NewInteger(1)
&& is_atom(CompoundArg2(t))
&& (CompoundArg2(t)==A_GAMMA5 || GetAtomProperty(CompoundArg2(t),A_GAMMA5))
&& (CompoundName(t)==OPR_PLUS || CompoundName(t)==OPR_MINUS))
{
Term ret,sp;
ret=MakeCompound(A_MTERM,4);
SetCompoundArg(ret,1,NewInteger(2));
SetCompoundArg(ret,2,NewInteger(1));
sp=MakeCompound(OPR_SPECIAL,2);
if(CompoundName(t)==OPR_PLUS)
SetCompoundArg(sp,2,A_GAMMAP);
else
SetCompoundArg(sp,2,A_GAMMAM);
SetCompoundArg(sp,1,CopyTerm(GetAtomProperty(A_GAMMA5,PROP_INDEX)));
SetCompoundArg(ret,3,AppendLast(NewList(),sp));
return AppendLast(NewList(),ret);
}
if(is_compound(t) && CompoundName(t)==OPR_PLUS && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
return ConcatList(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_MINUS && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
mult_no(t2,-1);
return ConcatList(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_MINUS && CompoundArity(t)==1)
{
Term t1;
t1=ConsumeCompoundArg(t,1);
FreeAtomic(t);
t1=ExpandTerm(t1);
mult_no(t1,-1);
return t1;
}
if(is_compound(t) && CompoundName(t)==OPR_MLT && CompoundArity(t)==2)
{
Term t1,t2;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2=ExpandTerm(t2);
return multiply_l(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_DIV && CompoundArity(t)==2)
{
Term t1,t2,t2s;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
t1=ExpandTerm(t1);
t2s=CopyTerm(t2);
t2=ExpandTerm(t2);
if(ListLength(t2)!=1)
{
ErrorInfo(306);
printf(" cannot divide by \'");
WriteTerm(t2s); printf("\'.\n");
FreeAtomic(t1); FreeAtomic(t2); FreeAtomic(t2s);
longjmp(alg1_jmp_buf,1);
}
FreeAtomic(t2s);
invert_term(ListFirst(t2));
return multiply_l(t1,t2);
}
if(is_compound(t) && CompoundName(t)==OPR_POW && CompoundArity(t)==2)
{
Term t1,t2,ret;
int i,pp;
t1=ConsumeCompoundArg(t,1);
t2=ConsumeCompoundArg(t,2);
FreeAtomic(t);
if(!is_integer(t2) || IntegerValue(t2)<1)
{
ErrorInfo(307);
printf(" illegal power \'");
WriteTerm(t2); printf("\'.\n");
FreeAtomic(t1); FreeAtomic(t2);
longjmp(alg1_jmp_buf,1);
}
pp=IntegerValue(t2);
t1=ExpandTerm(t1);
ret=CopyTerm(t1);
for(i=2;i<=pp;i++)
{
Term tmp;
tmp=CopyTerm(t1);
ret=multiply_l(ret,tmp);
}
FreeAtomic(t1);
return ret;
}
ErrorInfo(309);
printf("bad expression ");
WriteTerm(t);
puts("");
longjmp(alg1_jmp_buf,1);
}
static bool
is_begin_section (tree t) {
if (!is_compound (t, "coq-command", 3)) return false;
string s= as_string (t[2]);
return parse_command_name (s) == "Section";
}
Term ProcCoefVrt(Term t, List ind)
{
List l,pl,ml;
int ii;
Term a2;
int g=0, g5=0, re=0, im=0, abbr=0, cmplx=0;
if(!is_compound(t) || CompoundArity(t)>2 || !is_list(CompoundArg1(t)))
{
ErrorInfo(0);
puts("wrong parameters of CoefVrt function.");
return 0;
}
if(lagr_hash==NULL)
{
ErrorInfo(107);
puts("CoefVrt: no vertices");
return 0;
}
mmm=0;
if(CompoundArity(t)==2)
{
List ol=CompoundArg2(t);
if(!is_list(ol))
{
ErrorInfo(107);
puts("CoefVrt: second argument is not a list.");
return 0;
}
for(;ol;ol=ListTail(ol))
{
Term o=ListFirst(ol);
if(is_compound(o))
{
o=CompoundArg1(o);
if(!is_atom(o) || !is_particle(o,0))
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not a particle.\n");
return 0;
}
mmm=o;
continue;
}
if(!is_atom(o))
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not an option.\n");
return 0;
}
if(strcmp("gamma",AtomValue(o))==0)
{
g++;
continue;
}
if(strcmp("gamma5",AtomValue(o))==0)
{
g5++;
continue;
}
if(strcmp("re",AtomValue(o))==0)
{
re++;
continue;
}
if(strcmp("im",AtomValue(o))==0)
{
im++;
continue;
}
if(strcmp("abbr",AtomValue(o))==0)
{
abbr++;
continue;
}
{
ErrorInfo(0);
printf("CoefVrt: ");WriteTerm(o);
puts(" is not an option.\n");
return 0;
}
}
}
if(re&&im)
re=im=0;
pl=ConsumeCompoundArg(t,1);
for(l=pl;l;l=ListTail(l))
if(is_function(ListFirst(l),0))
ChangeList(l,CallFunction(ListFirst(l),0));
/* for(l=pl;l;l=ListTail(l))
{
Term aa=ListFirst(l);
if(is_compound(aa)&&CompoundName(aa)==A_ANTI)
ChangeList(l,GetAtomProperty(CompoundArg1(aa),A_ANTI));
}*/
pl=SortedList(pl,acmp);
l=finda2(pl,0);
if(mmm && !mmmpos)
{
ErrorInfo(0);
printf("CoefVrt: particle ");
WriteTerm(mmm);
puts(" not found in the vertex");
return 0;
}
if(is_empty_list(l))
{
ErrorInfo(108);
printf("CoefVrt: vertex ");
WriteTerm(pl);
puts(" not found");
return NewInteger(0);
}
a2=CopyTerm(ListFirst(l));
alg2_symmetrize(a2);
alg2_common_n(a2);
{
int sv=kill_gamma_pm;
kill_gamma_pm=1;
alg2_red_1pm5(a2);
kill_gamma_pm=sv;
}
alg2_recommon_n(a2);
ml=ConsumeCompoundArg(a2,5);
for(l=ml;l;l=ListTail(l))
{
List l1,ll;
int tg=0, tg5=0, tm=0;
for(l1=CompoundArgN(ListFirst(l),3);l1;l1=ListTail(l1))
{
Term tt=ListFirst(l1);
if(CompoundName(tt)==OPR_SPECIAL && CompoundArg1(tt)==A_GAMMA)
tg++;
if(CompoundName(tt)==OPR_SPECIAL && CompoundArg1(tt)==A_GAMMA5)
tg5++;
if(CompoundName(tt)==A_MOMENT && CompoundArg1(tt)==
NewInteger(mmmpos))
tm++;
}
if(g!=tg || g5!=tg5 || (mmm && !tm))
{
SetCompoundArg(ListFirst(l),1,0);
continue;
}
if(!re && !im)
continue;
for(l1=CompoundArg2(ListFirst(l));l1;l1=ListTail(l1))
if(GetAtomProperty(CompoundArg1(ListFirst(l1)),A_ANTI))
cmplx++;
}
if( (re||im) && !cmplx)
for(l=ml;l;l=ListTail(l))
{
List ll,l1;
if(CompoundArg1(ListFirst(l))==0)
continue;
ll=ConsumeCompoundArg(ListFirst(l),2);
for(l1=ll;l1;l1=ListTail(l1))
if(CompoundArg1(ListFirst(l1))==A_I)
break;
if( (re && l1) || (im && !l1) )
SetCompoundArg(ListFirst(l),1,0);
if(im && l1)
ll=CutFromList(ll,l1);
SetCompoundArg(ListFirst(l),2,ll);
}
rpt:
for(l=ml;l;l=ListTail(l))
if(CompoundArg1(ListFirst(l))==0)
{
ml=CutFromList(ml,l);
break;
}
if(l)
goto rpt;
SetCompoundArg(a2,5,ml);
alg2_recommon_n(a2);
alg2_common_s(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
alg2_red_sico(a2);
alg2_red_comsico(a2);
alg2_recommon_n(a2);
if(abbr)
{
int trisv=opTriHeu;
alg2_eval_vrt(a2);
doing_abbr=0;
opTriHeu=trisv;
}
{
int n,d;
Term cf;
Term res;
n=IntegerValue(CompoundArg1(CompoundArg2(a2)));
d=IntegerValue(CompoundArg2(CompoundArg2(a2)));
cf=l2expr(CompoundArgN(a2,3),n);
ml=CompoundArgN(a2,5);
if(ml==0)
return NewInteger(0);
res=l2expr(CompoundArg2(ListFirst(ml)),
IntegerValue(CompoundArg1(ListFirst(ml))));
for(l=ListTail(ml);l;l=ListTail(l))
{
Term ccc;
n=IntegerValue(CompoundArg1(ListFirst(l)));
ccc=l2expr(CompoundArg2(ListFirst(l)),n>0?n:-n);
if(n>0)
res=MakeCompound2(OPR_PLUS,res,ccc);
else
res=MakeCompound2(OPR_MINUS,res,ccc);
}
if(res==NewInteger(1))
res=cf;
else
res=MakeCompound2(OPR_MLT,cf,res);
if(d!=1)
res=MakeCompound2(OPR_DIV,res,NewInteger(d));
if( (im||re) && cmplx)
res=MakeCompound1(NewAtom(re?"creal":"cimag",0),res);
return res;
}
return a2;
}
static bool
is_end (tree t) {
if (!is_compound (t, "coq-command", 3)) return false;
string s= as_string (t[2]);
return parse_command_name (s) == "End";
}
static Term dif_term(Term t)
{
if(t==A_SQRT2 || t==A_I || is_float(t) || is_integer(t))
return 0;
if(is_atom(t) && is_parameter(t))
return MakeCompound1(OPR_USCORE,t);
if(!is_compound(t))
{
printf("Can't variate "); WriteTerm(t); puts(""); return 0;
}
if(CompoundName(t)==OPR_PLUS && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return d2;
if(d2==0)
return d1;
return MakeCompound2(OPR_PLUS,d1,d2);
}
if(CompoundName(t)==OPR_MINUS && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return d2;
if(d2==0)
return d1;
return MakeCompound2(OPR_MINUS,d1,d2);
}
if(CompoundName(t)==OPR_MINUS && CompoundArity(t)==1)
{
Term d1;
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
return MakeCompound1(OPR_MINUS,d1);
}
if(CompoundName(t)==A_SQRT && CompoundArity(t)==1)
{
Term d1;
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
if(is_compound(d1) && CompoundName(d1)==OPR_MLT &&
CompoundArg1(d1)==NewInteger(2))
{
Term d2;
d2=ConsumeCompoundArg(d1,2);
FreeAtomic(d1);
return MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV,d2,t));
}
return MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV, d1,
MakeCompound2(OPR_MLT, NewInteger(2), t)));
}
if(CompoundName(t)==OPR_POW && CompoundArity(t)==2)
{
Term d1;
int ppow;
ppow=IntegerValue(CompoundArg2(t));
d1=dif_term(CompoundArg1(t));
if(d1==0)
return 0;
if(ppow==2)
return MakeCompound2(OPR_MLT,NewInteger(2),
MakeCompound2(OPR_MLT, CompoundArg1(t), d1));
return MakeCompound2(OPR_MLT, d1, MakeCompound2(OPR_POW,
CompoundArg1(t),NewInteger(ppow-1)));
}
if(CompoundName(t)==OPR_MLT && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return MakeCompound2(OPR_MLT,CompoundArg1(t),d2);
if(d2==0)
return MakeCompound2(OPR_MLT,CompoundArg2(t),d1);
return MakeCompound2(OPR_PLUS,
MakeCompound2(OPR_MLT,CompoundArg1(t),d2),
MakeCompound2(OPR_MLT,CompoundArg2(t),d1));
}
if(CompoundName(t)==OPR_DIV && CompoundArity(t)==2)
{
Term d1,d2;
d1=dif_term(CompoundArg1(t));
d2=dif_term(CompoundArg2(t));
if(d1==0 && d2==0)
return 0;
if(d1==0)
return
MakeCompound1(OPR_MINUS,
MakeCompound2(OPR_DIV,
MakeCompound2(OPR_MLT,d2,CompoundArg1(t)),
MakeCompound2(OPR_POW,CompoundArg2(t),NewInteger(2))
)
);
if(d2==0)
return MakeCompound2(OPR_DIV,d1,CompoundArg2(t));
return
MakeCompound2(OPR_DIV,
MakeCompound2(OPR_MINUS,
MakeCompound2(OPR_MLT,d1,CompoundArg2(t)),
MakeCompound2(OPR_MLT,d2,CompoundArg1(t))
),
MakeCompound2(OPR_POW,CompoundArg2(t),NewInteger(2))
);
}
printf("Can't variate "); WriteTerm(t); puts("");
return 0;
}
static bool
is_begin_proof (tree t) {
if (!is_compound (t, "coq-command", 3)) return false;
string s= parse_command_name (as_string (t[2]));
return s == "Proof";
}
inline bool
is_applicable (tree t) {
return is_compound (t) && (N(t) >= 1) &&
((L(t) == MACRO) || (L(t) == FUNC) || (L(t) == XMACRO));
}
static bool
is_end_proof (tree t) {
if (!is_compound (t, "coq-command", 3)) return false;
string s= parse_command_name (as_string (t[2]));
return s == "Qed" || s == "Admitted" || s == "Defined" || s == "Abort";
}
inline int get_int (string var) {
tree t= env [var];
if (is_compound (t)) return 0;
return as_int (t->label); }
Term ProcImPrt(Term t, Term ind)
{
int spin, col, anti;
Atom n, an;
Term prt;
Atom pcomm=0, ptname=0;
if(!is_compound(t) || CompoundArity(t)<3 || CompoundArity(t)>5 ||
!is_integer(CompoundArg1(t)) || !is_integer(CompoundArg2(t)) ||
!is_integer(CompoundArgN(t,3)) ||
(CompoundArity(t)>3 && !is_atom(CompoundArgN(t,4))) ||
(CompoundArity(t)>4 && !is_atom(CompoundArgN(t,5))) )
{
ErrorInfo(502);
printf("AuxPrt: bad arguments ");WriteTerm(t);puts("");
return 0;
}
spin=IntegerValue(CompoundArg1(t));
col= IntegerValue(CompoundArg2(t));
anti=IntegerValue(CompoundArgN(t,3));
if(CompoundArity(t)>3)
pcomm=CompoundArgN(t,4);
if(CompoundArity(t)>4)
ptname=CompoundArgN(t,5);
FreeAtomic(t);
n=NewName();
if(anti)
an=NewName();
else
an=n;
if(1)
{
prt=MakeCompound(OPR_PARTICLE,8);
SetCompoundArg(prt,1,n);
SetCompoundArg(prt,2,an);
SetCompoundArg(prt,3,pcomm?pcomm:NewAtom("im particle",0));
SetCompoundArg(prt,4,NewInteger(spin?2:0));
SetCompoundArg(prt,5,spin==2?0:NewAtom("Maux",0));
if(spin<2)
SetCompoundArg(prt,7,OPR_MLT);
else
SetCompoundArg(prt,7,A_GAUGE);
if(col>1)
{
Term cl;
if(col==8)
cl=MakeCompound2(A_COLOR,NewAtom("c8",0),NewAtom("c8",0));
else
cl=MakeCompound2(A_COLOR,NewAtom("c3",0),NewAtom("c3b",0));
SetCompoundArg(prt,8,AppendFirst(NewList(),cl));
}
AddIMParticle(prt);
if(ptname)
{
char bbb[64];
SetAtomProperty(n,A_TEXNAME,ptname);
sprintf(bbb,"{\\bar{%s}}",AtomValue(ptname));
SetAtomProperty(an,A_TEXNAME,NewAtom(bbb,0));
}
}
if(spin<2)
{
if(!intr_param)
{
Term t1,t2,t3;
t1=NewCompound(NewFunctor(OPR_PARAMETER,1));
t2=NewCompound(NewFunctor(OPR_EQSIGN,2));
t3=NewCompound(NewFunctor(OPR_COLON,2));
SetCompoundArg(t1,1,t2);
SetCompoundArg(t2,1,NewAtom("Maux",0));
SetCompoundArg(t2,2,t3);
SetCompoundArg(t3,1,NewInteger(1));
SetCompoundArg(t3,2,NewAtom("mass of aux particles",0));
ProcessParameter(t1,0);
intr_param=1;
}
return n;
}
sprintf(nnbuf,"%s.t",AtomValue(n));
n=NewAtom(nnbuf,0);
return n;
}
