static void proc_hash(Term t)
{
if(is_list(t))
{
for(;t;t=ListTail(t))
proc_hash(ListFirst(t));
return;
}
if(is_compound(t))
{
int i;
for(i=1;i<=CompoundArity(t);i++)
{
Term t1=CompoundArgN(t,i);
if(is_compound(t1)&&CompoundName(t1)==OPR_HASH)
{
char cbuf[1024];
int n=0;
List l,al;
t1=ConsumeCompoundArg(t,i);
al=OperToList(t1,OPR_HASH);
for(l=al;l;l=ListTail(l))
n+=sWriteTerm(cbuf+n,ListFirst(l));
FreeAtomic(al);
SetCompoundArg(t,i,NewAtom(cbuf,0));
}
else
proc_hash(t1);
}
}
return;
}
static Atom NewName(void)
{
Atom ret;
do
{
sprintf(nnbuf,"~%c%c",ch1,ch2);
ch2++;
if(ch2-1=='9')
ch2='A';
if(ch2-1=='Z')
ch2='a';
if(ch2-1=='z')
{
ch2='0';
ch1++;
if(ch1-1=='9')
ch1='A';
if(ch1-1=='Z')
ch1='a';
if(ch1-1=='z')
{
if(ch00=='~')
puts("Internal error: too many im particles, output incorrect...");
ch1=ch2='0';
ch00--;
}
}
ret=NewAtom(nnbuf,3);
} while(is_particle(ret,NULL));
return ret;
}
static Atomic read_quoted(char *s, int *len, char stop)
{
int alen=0;
s++;
while(s[alen]!=0)
{
if(s[alen]==stop)
{ *len=alen+2;
return NewAtom(s,alen);
}
if(s[alen]=='\\')
{
int i=alen;
while(s[i]!=0)
{ s[i]=s[i+1]; i++; }
}
alen++;
}
*len=alen+1;
ErrorInfo(1);
printf(" unbalanced %c \n",stop);
return NewAtom(s,alen);
}
static int set_ppl(void)
{
List l;
if(PROP_PPL==0) PROP_PPL=NewAtom("pprtlst",0);
if(prop_gened)
return 1;
if(vlist==0)
{
vlist=all_vert_list();
for(l=vlist; !is_empty_list(l); l=ListTail(l))
{
Term a2;
a2=ListFirst(l);
alg2_common_s(a2);
alg2_common_n(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
}
}
for(l=vlist; !is_empty_list(l); l=ListTail(l))
{
List pl,l1,l2,lr;
pl=CompoundArg1(ListFirst(l));
if(ListLength(pl)<3 || CompoundArg2(ListFirst(l))==NewInteger(0) ||
is_empty_list(CompoundArgN(ListFirst(l),5)))
continue;
#ifdef DBG_PPL
WriteVertex(pl); printf(": ");
#endif
l1=pl;
while(!is_empty_list(l1))
{
Atom pp,app;
Term prop;
pp=CompoundArg1(ListFirst(l1));
prop=GetAtomProperty(pp,PROP_TYPE);
app=remcc(pp);
if(!ListMember(plist,app))
plist=AppendFirst(plist,app);
#ifdef DBG_PPL
WriteTerm(app); printf(" -> ");
#endif
lr=NewList();
l2=pl;
while(!is_empty_list(l2))
{
Atom a;
if(l2==l1)
{
l2=ListTail(l2);
continue;
}
a=remcc(CompoundArg1(ListFirst(l2)));
lr=AppendLast(lr,a);
l2=ListTail(l2);
}
prop=GetAtomProperty(app,PROP_PPL);
if(prop==0)
SetAtomProperty(app,PROP_PPL,AppendFirst(NewList(),lr));
else
AppendLast(prop,lr);
#ifdef DBG_PPL
WriteTerm(lr); printf(" ");
#endif
while(!is_empty_list(l1) &&
remcc(CompoundArg1(ListFirst(l1)))==app)
l1=ListTail(l1);
}
#ifdef DBG_PPL
puts("");
#endif
}
if(ListLength(plist)>1)
plist=SortedList(plist,p__cmp);
prop_gened=1;
return 1;
}
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 Atomic read_a(char *s, int *len)
{
if(s[0]=='(')
{ *len=1; return A_RBRA; }
if(s[0]==')')
{ *len=1; return A_RCET; }
if(s[0]=='{')
{ *len=1; return A_FBRA; }
if(s[0]=='}')
{ *len=1; return A_FCET; }
if(s[0]=='[')
{ *len=1; return A_QBRA; }
if(s[0]==']')
{ *len=1; return A_QCET; }
if(s[0]=='.')
{ *len=1; return A_POINT; }
if(s[0]==';')
{ *len=1; return A_SECO; }
if(s[0]==',')
{ *len=1; return A_COMMA; }
if(s[0]=='\'')
return read_quoted(s,len,'\'');
if(s[0]=='\"')
return read_quoted(s,len,'\"');
if(s[0]=='`')
{ *len=1; return A_RQUOTE; }
if(isalpha(s[0]) || s[0]=='_' || s[0]=='~')
{
int alen;
alen=0;
while(isalnum(s[alen]) || s[alen]=='_' || s[alen]=='~' )
alen++;
*len=alen;
return NewAtom(s,alen);
}
/* test for numbers */
if(isdigit(s[0]) /*|| (s[0]=='-' && isdigit(s[1]))*/ )
{
int negflag=0;
int alen=0;
int lll;
if(s[0]=='-')
{negflag=1; s++; alen++; }
lll=0;
while(isdigit(s[lll])) lll++;
if((s[lll]=='e' || s[lll]=='E') && (isdigit(s[lll+1]) || s[lll+1]=='-'))
{
double f=0.0;
int eneg=0,exp=0;
while(s[0]!='e' && s[0]!='E')
{
f*=10.0;
f+=s[0]-'0';
s++;
alen++;
}
if(negflag) f=-f;
s++; alen++;
if(s[0]=='-')
{
s++; alen++; eneg=1;
}
if(s[0]=='+')
{
s++; alen++;
}
while(isdigit(s[0]))
{
exp*=10;
exp+=s[0]-'0';
s++; alen++;
}
if(eneg) exp=-exp;
f*=pow(10.0,exp);
*len=alen;
return NewFloat(f);
}
if(s[lll]=='.' && isdigit(s[lll+1]))
{
double f=0.0;
double fact=1.0;
while(s[0]!='.')
{
f*=10.0;
f+=s[0]-'0';
s++;
alen++;
}
s++; alen++;
while(isdigit(s[0]))
{
fact/=10.0;
f+=fact*(s[0]-'0');
s++; alen++;
}
if(negflag) f=-f;
if(s[0]=='e' || s[0]=='E')
{
int eneg=0;
int exp=0;
s++; alen++;
if(s[0]=='-')
{
s++; alen++; eneg=1;
}
if(s[0]=='+')
{
s++; alen++;
}
while(isdigit(s[0]))
{
exp*=10;
exp+=s[0]-'0';
s++; alen++;
}
if(eneg) exp=-exp;
f*=pow(10.0,exp);
}
*len=alen;
return NewFloat(f);
}
lll=0;
while(isdigit(s[0]))
{
lll*=10;
lll+=s[0]-'0';
s++;
alen++;
}
if(negflag) lll=-lll;
*len=alen;
return NewInteger(lll);
}
if(ispunct(s[0]))
{
int alen;
alen=0;
while(ispunct(s[alen]) && !alone(s[alen]) &&
!(alen>0 && s[alen-1] == '=' && s[alen]!= '=') )
alen++;
*len=alen;
return NewAtom(s,alen);
}
*len=1;
return NewAtom("???",0);
}
Atom NewAtom(std::string _name, dcomplex _q, Eigen::Vector3cd _xyz) {
Atom atom = NewAtom(_name, _q);
atom->Add(_xyz);
return atom;
}
void SaveRules(char *fname)
{
List l,l1,li,lj;
{
int f;
f=itrSetOut(fname);
if(f==0)
{
printf("Can not open file '%s' for writing to save Feynman rules\n",
fname);
return;
}
}
itrOut(NewAtom("parameters",0));
l=all_param_list();
while(!is_empty_list(l))
{
itrOut(ListFirst(l));
l=ListTail(l);
}
itrOut(A_END);
l=all_prtc_list();
while(!is_empty_list(l))
{
Atom pp;
List pl;
pp=ListFirst(l);
pl=GetProperties(MakeCompound1(A_I,pp),0);
itrOut(MakeCompound1(OPR_PARTICLE,pp));
itrOut(pl);
FreeAtomic(pl);
l=ListTail(l);
}
l1=l=all_vert_list();
for(li=l;!is_empty_list(li);li=ListTail(li))
{
Term a2;
List a2l;
int sf=0;
a2=ListFirst(li);
if(CompoundArgN(a2,5)==0)
continue;
if(need_col_rdc(a2))
{
List l1,l2,l3=0;
sf=1;
l1=alg2_denorm(CopyTerm(a2));
for(l2=l1;l2;l2=ListTail(l2))
l3=ConcatList(l3,color_reduce(ListFirst(l2)));
RemoveList(l1);
a2l=l3;
for(l1=a2l;l1;l1=ListTail(l1))
alg2_norm(ListFirst(l1));
}
else
a2l=MakeList1(a2);
for(lj=a2l;lj;lj=ListTail(lj))
{
Term a2;
a2=ListFirst(lj);
if(is_atom(CompoundArg1(a2)))
continue;
alg2_symmetrize(a2);
alg2_common_s(a2);
alg2_common_n(a2);
alg2_red_cos(a2);
alg2_red_orth(a2);
alg2_red_sico(a2);
alg2_red_comsico(a2);
alg2_red_1pm5(a2);
alg2_recommon_n(a2);
alg2_recommon_s(a2);
if(CompoundArg2(a2)!=NewInteger(0) &&
!is_empty_list(CompoundArgN(a2,5)))
{
itrOut(a2);
}
if(sf)
FreeAtomic(a2l);
else
RemoveList(a2l);
}
}
FreeAtomic(l1);
itrCloseOut();
}
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);
}
}
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;
}
List mk_im_field(int col, int spin, int ch, List hint)
{
Atom n, an, spp;
int checked_hint=0;
Term prt;
n=0;
check_hint(col, spin, ch, hint, &n, &an);
if(n) checked_hint=1;
if(n==0)
{
n=NewName();
if(ch)
an=NewName();
else
an=n;
}
sprintf(nnbuf,"%s%s%s%s",AtomValue(CompoundArg1(ListFirst(hint))),
AtomValue(CompoundArg1(ListNth(hint,2))),
AtomValue(CompoundArg1(ListNth(hint,3))),
AtomValue(CompoundArg1(ListNth(hint,4))));
spp=NewAtom(nnbuf,0);
used_fields=AppendLast(used_fields, MakeCompound2(OPR_MINUS,
spp, MakeCompound2(OPR_DIV, n, an)));
if(verb_imprt)
{
printf("Intermediate field %s/%s for vertex ",AtomValue(n),
AtomValue(an));
WriteVertex(hint);
printf(".\n");
}
if(!checked_hint || spin<2)
{
char bbb[64];
prt=MakeCompound(OPR_PARTICLE,8);
SetCompoundArg(prt,1,n);
SetCompoundArg(prt,2,an);
sprintf(bbb,"%s",AtomValue(spp));
SetCompoundArg(prt,3,NewAtom(bbb,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)
{
Term cl;
if(col==3)
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(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 im particles",0));
ProcessParameter(t1,0);
intr_param=1;
}
return MakeList2(an,n);
}
sprintf(nnbuf,"%s.t",AtomValue(n));
n=NewAtom(nnbuf,0);
sprintf(nnbuf,"%s.t",AtomValue(an));
an=NewAtom(nnbuf,0);
return MakeList2(an,n);
}
