/* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.2 2014/09/05 11:55:18 ohara Exp $ */
/* The latest version will be at ftp://akagi.ms.u-tokyo.ac.jp/pub/math/muldif
scp os_muldif.[dp]* ${USER}@lemon.math.kobe-u.ac.jp:/home/web/OpenXM/Current/doc/other-docs
*/
#define USEMODULE 1
/* #undef USEMODULE */
/* os_muldif.rr (Library for Risa/Asir)
* Toshio Oshima (Nov. 2007 - Aug. 2014)
*
* For polynomials and differential operators with coefficients
* in rational funtions (See os_muldif.pdf)
*
* "Tab = 4 column" is best
*/
ord([zz,dz,dy,dx])$
#ifdef USEMODULE
module os_md;
static Muldif.rr$
static TeXEq$
static TeXLim$
static DIROUT$
static DVIOUTL$
static DVIOUTA$
static DVIOUTH$
static ErMsg$
static FLIST$
static IsYes$
localf erno$
localf chkfun$
localf makev$
localf vweyl$
localf mycat$
localf mycat0$
localf findin$
localf countin$
localf mycoef$
localf mydiff$
localf myediff$
localf m2l$
localf m2ll$
localf mydeg$
localf mymindeg$
localf m1div$
localf mulsubst$
localf cmpsimple$
localf simplify$
localf monotos$
localf monototex$
localf vnext$
localf ldict$
localf ndict$
localf nextsub$
localf nextpart$
localf transpart$
localf trpos$
localf sprod$
localf sinv$
localf slen$
localf sord$
localf vprod$
localf mulseries$
localf pluspower$
localf vtozv$
localf dupmat$
localf matrtop$
localf mydet$
localf mperm$
localf mtranspose$
localf mtoupper$
localf mydet2$
localf myrank$
localf meigen$
localf vgen$
localf mmc$
localf lpgcd$
localf mdivisor$
localf mdsimplify$
localf m2mc$
localf easierpol$
localf mykernel$
localf myimage$
localf mymod$
localf mmod$
localf llbase$
localf lsort$
localf lsol$
localf lnsol$
localf m2v$
localf lv2m$
localf m2lv$
localf s2m$
localf m2diag$
localf myinv$
localf madjust$
localf mpower$
localf texlen$
localf isdif$
localf fctrtos$
localf texlim$
localf fmult$
localf radd$
localf getel$
localf ptol$
localf rmul$
localf mtransbys$
localf mysubst$
localf mmulbys$
localf appldo$
localf appledo$
localf muldo$
localf adj$
localf laplace1$
localf laplace$
localf mce$
localf mc$
localf rede$
localf ad$
localf add$
localf vadd$
localf addl$
localf cotr$
localf rcotr$
localf muledo$
localf mulpdo$
localf transpdosub$
localf transpdo$
localf translpdo$
localf rpdiv$
localf mygcd$
localf mylcm$
localf sftpexp$
localf applpdo$
localf tranlpdo$
localf divdo$
localf qdo$
localf sqrtdo$
localf ghg$
localf ev4s$
localf b2e$
localf sftpow$
localf sftpowext$
localf polinsft$
localf pol2sft$
localf binom$
localf expower$
localf seriesHG$
localf toeul$
localf fromeul$
localf sftexp$
localf fractrans$
localf soldif$
localf chkexp$
localf getroot$
localf expat$
localf polbyroot$
localf polbyvalue$
localf pcoef$
localf prehombf$
localf prehombfold$
localf sub3e$
localf fuchs3e$
localf okubo3e$
localf eosub$
localf even4e$
localf odd5e$
localf extra6e$
localf rigid211$
localf solpokuboe$
localf stoe$
localf dform$
localf polinvsym$
localf polinsym$
localf tohomog$
localf substblock$
localf okuboetos$
localf heun$
localf fspt$
localf abs$
localf calc$
localf isint$
localf isalpha$
localf isnum$
localf isalphanum$
localf isvar$
localf isyes$
localf isall$
localf sproot$
localf spgen$
localf chkspt$
localf cterm$
localf terms$
localf polcut$
localf redgrs$
localf cutgrs$
localf mcgrs$
localf str_char$
localf str_pair$
localf str_cut$
localf str_str$
localf ssubgrs$
localf verb_tex_form$
localf my_tex_form$
localf smallmattex$
localf str_subst$
localf dviout0$
localf myhelp$
localf isMs$
localf showbyshell$
localf getbyshell$
localf show$
localf dviout$
localf rtotex$
localf mtotex$
localf ltotex$
localf str_tb$
localf getbygrs$
localf shiftop$
localf conf1sp$
localf pgen$
localf mgen$
localf madj$
localf newbmat$
localf pfrac$
localf cfrac$
localf cfrac2n$
localf s2sp$
localf sp2grs$
localf intpoly$
localf powsum$
localf bernoulli$
localf lft01$
localf linfrac01$
localf nthmodp$
localf issquaremodp$
localf rootmodp$
localf rabin$
localf primroot$
localf ptype$
localf average$
localf sint$
localf xyproc$
localf xypos$
localf xyput$
localf xybox$
localf xyline$
localf xylines$
localf xycirc$
localf xybezier$
localf xygraph$
localf xy2graph$
localf xyarrow$
localf ptcopy$
localf ptaffine$
localf ptlattice$
localf ptpolygon$
localf ptwindow$
localf lchange$
localf init$
#else
extern Muldif.rr$
extern TeXEq$
extern TeXLim$
extern DIROUT$
extern DVIOUTL$
extern DVIOUTA$
extern DVIOUTH$
extern ErMsg$
extern FLIST$
extern IsYes$
#endif
extern AMSTeX$
Muldif.rr="00140813"$
AMSTeX=1$
TeXEq=5$
TeXLim=80$
DIROUT="%HOME%\\tex"$
DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$
DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$
DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$
ErMsg = newvect(3,[
"irregal argument", /* 0 */
"too big size", /* 1 */
"irregal option" /* 2 */
])$
FLIST=0$
IsYes=[]$
def erno(N)
{
/* extern ErMsg; */
print(ErMsg[N]);
}
def chkfun(Fu, Fi)
{
/* extern FLIST; */
/* extern Muldif.rr; */
if(type(Fu) <= 1){
if(Fu==1)
mycat(["Loaded os_muldif Ver.", Muldif.rr, "(Toshio Oshima)"]);
else
mycat(["Risa/Asir Ver.", version()]);
return 1;
}
if(type(FLIST) < 4)
FLIST = flist();
if(type(Fu) == 4){
for(; Fu != [] ;Fu = cdr(Fu))
if(chkfun(car(Fu),Fi) == 0) return 0;
return 1;
}
if(findin(Fu, FLIST) >= 0)
return 1;
FLIST = flist();
if(findin(Fu, FLIST) >= 0)
return 1;
if(type(Fi)==7){
mycat0(["load(\"", Fi,"\") -> try again!\n"],1);
load(Fi);
}
return 0;
/*
if(type(Fi) == 7)
Fi = [Fi];
for( ; Fi != []; Fi = cdr(Fi))
load(car(Fi));
FLIST = flist();
return (findin(Fu,FLIST)>=0)?1:0;
*/
}
def makev(L)
{
S = "";
Num=getopt(num);
while(length(L) > 0){
VL = car(L); L = cdr(L);
if(type(VL) == 7)
S = S+VL;
else if(type(VL) == 2 || VL < 10)
S = S+rtostr(VL);
else if(VL<46 && Num!=1)
S = S+asciitostr([VL+87]);
else
S = S+rtostr(VL);
}
return strtov(S);
}
def vweyl(L)
{
if(type(L) == 4){
if(length(L) == 2)
return L;
else
return [L[0],makev(["d",L[0]])];
}else
return [L,makev(["d", L])];
}
def mycat(L)
{
if(type(L) != 4){
print(L);
return;
}
Opt = getopt(delim);
Del = (type(Opt) >= 0)?Opt:" ";
Opt = getopt(cr);
CR = (type(Opt) >= 0)?0:1;
while(L != []){
if(Do==1)
print(Del,0);
print(car(L),0);
L=cdr(L);
Do = 1;
}
if(CR) print("");
}
def mycat0(L,T)
{
Opt = getopt(delim);
Del = (type(Opt) >= 0)?Opt:"";
while(L != []){
if(Do==1)
print(Del,0);
print(car(L),0);
L=cdr(L);
Do = 1;
}
if(T) print("");
}
def findin(M,L)
{
if(type(L)==4){
for(I = 0; L != []; L = cdr(L), I++)
if(car(L) == M) return I;
}else if(type(L)==5){
K=length(L);
for(I = 0; I < K; I++)
if(L[I] == M) return I;
}else return -2;
return -1;
}
def countin(S,M,L)
{
if(type(L)==4){
for(N=0; L!=[]; L=cdr(L))
if(car(L)>=S && car(L)<=M) N++;
}else if(type(L)==5){
K=length(L);
for(I = 0; I < K; I++)
if(L[I]>=S && L[I]<=M) N++;
}else return -2;
return N;
}
def mycoef(P,N,X)
{
if(type(P) < 3)
return coef(P,N,X);
if(type(P) >= 4)
return map(mycoef,P,N,X);
if(deg(dn(P), X) > 0){
P = red(P);
if(deg(dn(P), X) > 0)
return 0;
}
return red(coef(nm(P),N,X)/dn(P));
}
def mydiff(P,X)
{
if(X == 0)
return 0;
if(type(P) < 3)
return diff(P,X);
if(type(P) >= 4)
return map(mydiff,P,X);
if(deg(dn(P),X) == 0)
return red(diff(nm(P),X)/dn(P));
return red(diff(P,X));
}
def myediff(P,X)
{
if(X == 0)
return 0;
if(type(P) < 3)
return ediff(P,X);
if(type(P) >= 4)
return map(myediff,P,X);
if(deg(dn(P),X) == 0)
return red(ediff(nm(P),X)/dn(P));
return red(X*diff(P,X));
}
def m2l(M)
{
if(type(M) < 4)
return [M];
if(type(M) == 4){
if(type(car(M))==4 && getopt(flat)==1){
for(MM = []; M!=[]; M=cdr(M))
MM = append(MM,car(M));
return MM;
}
return M;
}
if(type(M) == 5)
return vtol(M);
S = size(M);
for(MM = [], I = S[0]-1; I >= 0; I--)
MM = append(vtol(M[I]), MM);
return MM;
}
def mydeg(P,X)
{
if(type(P) < 3)
return deg(P,X);
II = -1;
Opt = getopt(opt);
if(type(P) >= 4){
S=(type(P) == 6)?size(P)[0]:0;
P = m2l(P);
for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
if( (DT = mydeg(car(P),X)) == -2)
return -2;
if(DT > Deg){
Deg = DT;
II = I;
}
}
return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
}
P = red(P);
if(deg(dn(P),X) == 0)
return deg(nm(P),X);
return -2;
}
def mymindeg(P,X)
{
if(type(P) < 3)
return mindeg(P,X);
II = -1;
Opt = getopt(opt);
if(type(P) >= 4){
S=(type(P) == 6)?size(P)[0]:0;
P = m2l(P);
for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
if(car(P) == 0)
continue;
if( (DT = mydeg(car(P),X)) == -2)
return -2;
if(DT < Deg || Deg == -3){
Deg = DT;
II = I;
if(Deg==0) break;
}
}
return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
}
P = red(P);
if(deg(dn(P),X) == 0)
return mindeg(nm(P),X);
return -2;
}
def m1div(M,N,L)
{
L = (type(L) <= 3)?[0,L]:vweyl[L];
DX = L[1]; X = L[0];
if(mydeg(N,DX) != 0)
return 0;
DD = mydeg(M,DX);
MM = M;
while( (Deg=mydeg(MM,DX)) > 0){
MC = mycoef(MM,Deg,DX)*DX^(Deg-1);
MS = radd(MC, MS);
MM = radd(MM, muldo(MC,radd(-DX,N),L));
}
return [MM, MS];
}
def mulsubst(F,L)
{
N = length(L);
if(N == 0)
return F;
if(type(L[0])!=4) L=[L];
if(length(L)==1) return mysubst(F,L);
L1 = newvect(N);
for(J = 0; J < N ; J++)
L1[J] = uc();
L2 = newvect(N);
for(J = 0; J < N; J++){
S = L[J][1];
for(I = 0; I < N; I++)
S = mysubst(S,[L[I][0],L1[I]]);
L2[J] = S;
}
for(J = 0; J < N; J++)
F = mysubst(F, [L[J][0],L2[J]]);
for(J = 0; J < N; J++)
F = mysubst(F, [L1[J],L[J][0]]);
return F;
}
def cmpsimple(P,Q)
{
T = getopt(comp);
if(P == Q)
return 0;
D = 0;
if(type(T) < 0)
T = 7;
if(iand(T,1))
D = length(vars(P)) - length(vars(Q));
if(!D && iand(T,2))
D = nmono(P) - nmono(Q);
if(!D && iand(T,4))
D = str_len(rtostr(P)) - str_len(rtostr(Q));
if(!D){
if(P > Q) D++;
else D--;
}
return D;
}
def simplify(P,L,T)
{
if(type(P) > 3)
return map(simplify,P,L,T);
if(type(L[0]) == 4){
if(length(L[0]) > 1)
return fmult(simplify,P,L,[T]);
L = L[0];
}
if(type(Var=getopt(var)) == 4 && Var!=[]){
if(type(P) == 3)
return simplify(nm(P),P,L,T|var=Var)/simplify(dn(P),P,L,T|var=Var);
V = car(Var);
if((I = mydeg(P,V)) > 0){
Var = cdr(Var);
for(Q=0; I>=0 ; I--)
Q += simplify(mycoef(P,I,V), L, T|var=Var)*V^I;
return Q;
}
}
if(length(L) == 1){
L = car(L);
for(V = vars(L); V != []; V = cdr(V)){
VT = car(V);
if(deg(L,VT) != 1) continue;
P = simplify(P, [VT, -red(coef(L,0,VT)/coef(L,1,VT))], T);
}
return P;
}
Q = mysubst(P,[L[0],L[1]]);
return (cmpsimple(P,Q|comp=T) <= 0)?P:Q;
}
def monotos(P)
{
if(nmono(P) <= 1)
return rtostr(P);
return "("+rtostr(P)+")";
}
def monototex(P)
{
if(nmono(P) <= 1)
return my_tex_form(P);
return "("+my_tex_form(P)+")";
}
def vnext(V)
{
S = length(V);
for(I = S-1; I > 0; I--){
if(V[I-1] < V[I]){
V0 = V[I-1];
for(J = I+1; J < S; J++)
if(V0 >= V[J]) break;
V[I-1] = V[--J];
V[J] = V0;
for(J = S-1; I < J; I++, J--){
V0 = V[I];
V[I] = V[J];
V[J] = V0;
}
return 1;
}
}
return 0;
}
def ldict(N, M)
{
Opt = getopt(opt);
R = S = [];
for(I = 2; N > 0; I++){
R = cons(irem(N,I), R);
N = idiv(N,I);
}
L = LL = length(R);
T=newvect(LL+1);
while(L-- > 0){
V = car(R); R = cdr(R);
for(I = J = 0; J <= V ; I++){
if(T[I] == 0)
J++;
}
T[I-1] = 1;
S = cons(LL-I+1, S);
}
for(I = 0; I <= LL; I++){
if(T[I] == 0){
S = cons(LL-I, S);
break;
}
}
if(M == 0)
return S;
if(M <= LL){
print("too small size");
return 0;
}
T = [];
for(I = --M; I > LL; I--)
T = cons(I,T);
S = append(S,T);
if(Opt == 2 || Opt == 3)
S = reverse(S);
if(Opt != 1 && Opt != 3)
return S;
for(T = []; S != []; S = cdr(S))
T = cons(M-car(S),T);
return T;
}
def ndict(L)
{
Opt = getopt(opt);
R = [];
if(Opt != 1 && Opt != 2)
L = reverse(L);
T = (Opt == 1 || Opt == 3)?1:0;
for( ; L != []; L = cdr(L)){
for(I = 0, V = car(L), LT = cdr(L); LT != []; LT = cdr(LT))
if(T == 0){
if(V < car(LT)) I++;
}else if (V > car(LT)) I++;
R = cons(I, R);
}
R = reverse(R);
for(V = 0, I = length(R); I > 0; R = cdr(R), I--)
V = V*I + car(R);
return V;
}
def nextsub(L,N)
{
if(type(L) == 1){
for(LL = [], I = L-1; I >= 0; I--)
LL = cons(I,LL);
return LL;
}
M = length(L = ltov(L));
K = N-M;
for(I = M-1; I >= 0; I--)
if(L[I] < I+K) break;
if(I < 0)
return 0;
for(J = L[I]+1; I < M; I++, J++)
L[I] = J;
return vtol(L);
}
def nextpart(L)
{
if(car(L) <= 1)
return 0;
for(I = 0, L = reverse(L); car(L) == 1; L=cdr(L))
I++;
I += (K = car(L));
R = irem(I,--K);
R = (R==0)?[]:[R];
for(J = idiv(I,K); J > 0; J--)
R = cons(K,R);
L = cdr(L);
while(L!=[]){
R = cons(car(L), R);
L = cdr(L);
}
return R;
}
def transpart(L)
{
L = reverse(L);
for(I=1, R=[]; L!= []; I++){
R = cons(length(L), R);
while(L != [] && car(L) <= I)
L = cdr(L);
}
return reverse(R);
}
def trpos(A,B,N)
{
S = newvect(N);
for(I = 0; I < N; I++)
S[I]=(I==A)?B:((I==B)?A:I);
return S;
}
def sprod(S,T)
{
L = length(S);
V = newvect(L);
while(--L >= 0)
V[L] = S[T[L]];
return V;
}
def sinv(S)
{
L = length(S);
V = newvect(L);
while(--L >= 0)
V[S[L]] = L;
return V;
}
def slen(S)
{
L = length(S);
for(V = 0, J = 2; J < L; i++){
for(I = 0; I < J; I++)
if(S[I] > S[J]) V++;
}
return V;
}
def sord(W,V)
{
L = length(W);
W0 = nevect(L);
V0 = newvect(L);
for(I = F = C = 0; I < L; I++){
C = 0;
if( (W1 = W[I]) > (V1 = V[I]) ){
if(F < 0) C = 1;
else if(F==0) F = 1;
}else if(W1 < V1){
if(F > 0) C = 1;
else if(F==0) F = -1;
}
for(J = I;--J >= 0 && W0[J] > W1; ) W0[J+1] = W0[J];
W0[J+1] = W1;
for(J = I;--J >= 0 && V0[J] > V1; ) V0[J+1] = V0[J];
V0[J+1] = V1;
if(C){
for(J = I; J >= 0; J--){
if((W1=W0[J]) == (V1=V0[J])) continue;
if(W1 > V1){
if(F < 0) return 2;
}
else if(F > 0) return 2;
}
}
}
return F;
}
def vprod(V1,V2)
{
for(R = 0, I = length(V1)-1; I >= 0; I--)
R = radd(R, rmul(V1[I], V2[I]));
return R;
}
def mulseries(V1,V2)
{
L = length(V1);
if(size(V2) < L)
L = size(V2);
VV = newvect(L);
for(J = 0; J < L; J++){
for(K = R = 0; K <= J; K++)
R = radd(R,rmul(V1[K],V2[J-K]));
VV[J] = R;
}
return VV;
}
def pluspower(P,V,N,M)
{
RR = 1;
for(K = R = 1; K < M-1; I++){
R = R*(N-K+1)*P/K;
RR = radd(RR,R);
}
VV = newvect(M);
for(K = 0; K < M-1; K++)
VV[K] = red(mycoef(RR,K,V));
}
def vtozv(V)
{
if(type(V)<4) V=newvect(1,[V]);
S = length(V);
VV = newvect(S);
Lcm = 1;
for(K = 0; K < S; K++){
VV[K] = red(V[K]);
Lcm = lcm(Lcm,dn(VV[K]));
C = ptozp(nm(VV[K])|factor=0);
if(K == 0){
Dn = dn(C[1]);
Nm = nm(C[1]);
PNm = nm(C[0]);
}else{
Dn = ilcm(Dn,dn(C[1]));
Nm = igcd(Nm,nm(C[1]));
PNm = gcd(PNm,nm(C[0]));
}
}
Mul = (Lcm*Dn)/(PNm*Nm);
for(K = 0; K < S; K++)
VV[K] = rmul(VV[K],Mul);
return [VV,Mul];
}
def dupmat(M)
{
if(type(M) == 6){
Size = size(M);
MM = newmat(Size[0],Size[1]);
for(I = 0; I < Size[0]; I++){
for(J = 0; J < Size[1]; J++)
MM[I][J] = M[I][J];
}
return MM;
}
if(type(M) == 5)
return ltov(vtol(M));
return M;
}
def matrtop(M)
{
S = size(M);
MM = dupmat(M);
Lcm = newvect(S[0]);
for(J = 0; J < S[0]; J++){
U = vtozv(M[J]);
for(K = -1, I = 0; I < S[1]; I++)
MM[J][I] = U[0][I];
Lcm[J] = U[1];
}
return [MM,Lcm];
}
def mydet(M)
{
MM = matrtop(M);
if(type(MM[0]) == 6){
S = size(M);
for(Dn = 1, I = 0; I < S[0]; I++)
Dn *= MM[1][I];
return red(det(MM[0])/Dn);
}
}
def mperm(M,P,Q)
{
if(type(M) == 6){
S = size(M);
if(type(P) <= 1)
P=(P==1)?Q:trpos(0,0,S[0]);
if(type(P) > 3 && type(P[0]) >= 4)
P = trpos(P[0][0],P[0][1],S[0]);
else if(type(P) == 4){
if(length(P)==2 && type(P[1])==4){
P0=P[0];P1=car(P[1]);P=newvect(P1);
for(I=0;I<P1;I++) P[I]=P0+I;
}else P = ltov(P);
}
if(type(Q) <= 1)
Q=(Q==1)?P:trpos(0,0,S[1]);
if(type(Q) > 3 && type(Q[0]) >= 4)
Q = trpos(Q[0][0],Q[0][1],S[1]);
if(type(Q) == 4){
if(length(Q)==2 && type(Q[1])==4){
P0=Q[0];P1=car(Q[1]);Q=newvect(P1);
for(I=0;I<P1;I++) Q[I]=P0+I;
}else Q = ltov(Q);
}
MM = newmat(S0=length(P),S1=length(Q));
for(I = 0; I < S0; I++){
MMI = MM[I]; MPI = M[P[I]];
for(J = 0; J < S1; J++)
MMI[J] = MPI[Q[J]];
}
return MM;
}
if((type(M) == 5 || type(M) == 4) && type(P) >= 4){
if(length(P) == 1 && type(car(P)) == 4)
P = trpos(car(P)[0],car(P)[1],length(M));
MM = newvect(S = length(P));
for(I = 0; I < S; I++)
MM[I] = M[P[I]];
if(type(M) == 4)
MM = vtol(MM);
return MM;
}
return M;
}
def mtranspose(M)
{
if(type(M)==4){
MV=ltov(M);
II=length(MV);
for(I=L=0; I<II; I++){
if(type(MV[I])!=4) return M;
MV[I]=ltov(MV[I]);
}
for(R=[],J=0; ;J++){
for(T=[],I=F=0; I<II; I++){
if(length(MV[I])>J){
F=1;
T=cons(MV[I][J],T);
}
}
if(F==0) return reverse(R);
if(F==1) R=cons(reverse(T),R);
}
}
if(type(M) != 6)
return M;
S = size(M);
MM = newmat(S[1],S[0]);
for(I = 0; I < S[0]; I++){
for(J = 0; J < S[1]; J++)
MM[J][I] = M[I][J];
}
return MM;
}
def mtoupper(MM, F)
{
Opt = getopt(opt);
if(type(Opt)!=1) Opt=0;
TeX=getopt(dviout);
Line="\\text{line}";
St = getopt(step);
if(type(TeX)!=1 || St!=1) TeX=0;
Size = size(MM);
if(F ==-1){
M = newmat(Size[0], Size[1]+1);
for(I = 0; I < Size[0]; I++){
for(J = 0; J < Size[1]; J++)
M[I][J] = MM[I][J];
M[I][Size[1]] = zz^I;
}
Size = size(M);
F = 1;
}else if(F<0){
F=Size[0];
M = newbmat(1,2,[[MM,mgen(F,0,[1],0)]]);
Size=[Size[0],F+Size[1]];
}else
M = dupmat(MM);
if(St==1){
if(TeX) Lout=[[dupmat(M)]];
else mycat0([M,"\n\n"],0);
}
Top="";
if(Opt>3){
for(I=Opt; I>4; I--)
Top+=(TeX==1)?"\\ ":" ";
}
for(K = JJ = 0; K < Size[1] - F; K++){
for(J = JJ; J < Size[0]; J++){
if(M[J][K] != 0){
if(Opt>2 && (Mul=M[J][K])!=1){
for(FF=0,JT=J; JT<Size[0]; JT++){
if((Val=M[JT][K])==1){
J=JT; break;
}
if(Val==0 || type(Val)>type(Mul)) continue;
if(type(Val)<type(Mul) || (Val==-1 && Mul!=-1)){
Mul=Val; J=JT;
}
else if(Opt>3 && isint(Val)==1){
for(FF=1,JK=K+1; JK<Size[1]-F; JK++){
if(isint(M[JT][JK]/Val)!=1){
FF=0;break;
}
}
if(FF==1){
Mul=Val; J=JT;
}
}
}
if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){
for(FF=0,J0=J; J0<Size[0]-1 && FF!=4; J0++){
VV0=M[J0][K];
if(VV0==0 || isint(VV0)==0) continue;
for(J1=J0+1;J1<Size[0] && FF!=4; J1++){
VV1=M[J1][K];
if(VV1==0 || isint(VV1)==0) continue;
for(C=FT=0,V0=VV0,V1=VV1; C<2 && FF!=5; C++,V1=V0,V0=VV1){
for(CC=0,RC=ceil(V0/V1);CC<2;CC++,RC--){
if((CD=V0-RC*V1)==0 && (RC==1 || RC==-1)){
FT=1; FF=5;
}else if(CD==1){
if((RC==1 || RC==-1) && FF<4){
FT=1; FF=4;
}else if(FF<3){
FT=1; FF=3;
}
}else if(CD==-1){
if((RC==1 || RC==-1) && FF<2){
FT=1; FF=2;
}else if(FF<1){
FT=1; FF=1;
}
}
if(FT==1){
FT=0; KRC=RC;
if(C==0){
KJ0=J0; KJ1=J1;
}else{
KJ0=J1; KJ1=J0;
}
}
}
}
}
}
if(FF>0){
for(I=K;I<Size[1];I++)
M[KJ0][I]=radd(M[KJ0][I],rmul(M[KJ1][I],-KRC));
if(St==1){
if(TeX){
if(KRC==1)
Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,"\\ -=\\ ",
Line,KJ1+1,"}",dupmat(M)],Lout);
else if(KRC==-1)
Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,"\\ +=\\ ",
Line,KJ1+1,"}",dupmat(M)],Lout);
else
Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,"\\ +=\\ ",
Line,KJ1+1,"\\times\\left(",-KRC,"\\right)}",
dupmat(M)],Lout);
}else{
if(KRC==1)
mycat0([Top+"line",KJ0+1," -= line",KJ1+1,"\n",M,"\n\n"],0); else if(KRC==-1)
mycat0([Top+"line",KJ0+1," += line",KJ1+1,"\n",M,"\n\n"],0); else
mycat0([Top+"line",KJ0+1, " += line",KJ1+1," * (",-KRC,")\n",M,"\n\n"],0);
}
}
Mul=M[KJ0][K]; J=KJ0;
if(FF==5){
J--; continue;
}
}
}
/*
if(St==1 && Opt>3 && (type(Mul)==2 || type(Mul)==3)){
Nm=nm(red(Mul)); FT=fctr(Nm);
for(FF=cdr(FT);FF!=[];FF=cdr(FF)){
FT=car(FF);VV=vars(FT);
for( ; VV!=[]; VV=cdr(VV)){
V=car(VV);
if(mydeg(FT,V)==1 && type(mycoef(FT,1,V))==1){
CC=mycoef(FT,1,V); VC=FT/CC-V;
if(TeX)
Lout=cons([Top+"\\text{If }",V,"=",VC],Lout);
else
mycat([Top+"If ",V,"=",VC]);
mtoupper(mysubst(MM,V,VC),F|dviout=TeX,opt=Opt+1,step=1);
break;
}
}
}
if(length(FT)>1){
if(TeX) Lout=cons([Top+"\\text{If }",V,"\ne",Nm],Lout);
else mycat([Top+"If ",V,"!=",Nm]);
}
}
*/
}
if(J != JJ){
for(I = K; I < Size[1]; I++){
Temp = M[JJ][I];
M[JJ][I] = M[J][I];
M[J][I] = (Opt>=2)?Temp:-Temp;
}
if(St==1){
if(TeX)
Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\leftrightarrow\\ ",Line,
J+1,"}",dupmat(M)],Lout);
else
mycat0([Top+"line",JJ+1," <-> line",J+1,"\n",M,"\n\n"],0);
}
}
if(Opt>1){
Mul = M[JJ][K]; M[JJ][K]=1;
if(Mul!=1){
for(L=K+1; L<Size[1]; L++)
M[JJ][L]=red(M[JJ][L]/Mul);
if(St==1){
if(TeX)
Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\times=\\ \\left(",1/Mul,
"\\right)}",
dupmat(M)],Lout);
else
mycat0([Top+"line",JJ+1, " *= (",1/Mul, ")\n",M,"\n\n"],0);
}
}
}
for(J = (Opt>0)?0:(JJ+1); J < Size[0]; J++){
if(J == JJ)
continue;
Mul = -M[J][K];
if(Mul!=0){
if(Opt!=2) Mul=rmul(Mul,1/M[JJ][K]);
for(I = K+1; I < Size[1]; I++)
M[J][I] = radd(M[J][I],rmul(M[JJ][I],Mul));
M[J][K] = 0;
if(St==1){
if(TeX){
if(Mul==1)
Lout=cons([Top+"\\xrightarrow{", Line,J+1,"\\ +=\\ ",Line,JJ+1,
"}",dupmat(M)],Lout);
else if(Mul==-1)
Lout=cons([Top+"\\xrightarrow{", Line,J+1,"\\ -=\\ ",Line,JJ+1,
"}",dupmat(M)],Lout);
else
Lout=cons([Top+"\\xrightarrow{", Line,J+1,"\\ +=\\ ",Line,JJ+1,
"\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout);
}else{
if(Mul==1)
mycat0([Top+"line",J+1, " += line",JJ+1,"\n",M,"\n\n"],0);
else if(Mul==-1)
mycat0([Top+"line",J+1, " -= line",JJ+1,"\n",M,"\n\n"],0);
else
mycat0([Top+"line",J+1, " += line",JJ+1," * (",Mul,")\n",M,"\n\n"],0);
}
}
}
}
JJ++;
}
}
}
if(TeX){
Cr=getopt(cr);
Lout=reverse(Lout);
if(type(Cr)==7){
Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr);
dviout(Out|eq=5);
}
else show(Lout);
}
return M;
}
def mydet2(M)
{
S = size(M);
Det = 1;
MM = mtoupper(M,0);
for(I = 0; I < S[0]; I++)
Det = rmul(Det,MM[I][I]);
return Det;
}
def myrank(MM)
{
S = size(MM);
M = dupmat(MM);
M = mtoupper(M,0);
C = 0;
for(I = K = 0; I < S[0]; I++){
for(J = K; J < S[1]; J++){
if(M[I][J] != 0){
C++; K++;
break;
}
}
}
return C;
}
def meigen(M)
{
F = getopt(mult);
if(type(M)==4 || type(M)==5){
II=length(M);
for(R=[],I=II-1; I>=0; I--){
if(F==1)
R=cons(meigen(M[I]|mult=1),R);
else
R=cons(meigen(M[I]),R);
}
return R;
}
S = size(M)[0];
P = mydet2(mgen(S,0,[zz],0)-M);
return (F==1)?getroot(P,zz|mult=1):getroot(P,zz);
}
def vgen(V,W,S)
{
IM=length(V);
I=(getopt(opt)==0)?IM:0;
for(SS=0; I<IM && (SS==0 || V[I]<=W[I]); I++)
SS += W[I];
if(I<IM){
W[I]++;
SS--;
}else
SS=S;
for(J=0;J<I;J++){
W[J] = (SS<=V[J])?SS:V[J];
SS -= W[J];
}
if(SS>0)
return -1;
return(I==IM)?0:I;
}
def mmc(M,X)
{
L=length(M);
if(getopt(mult)==1){
for(SS=I=2; I<L; I+=(++SS));
if(I!=L) return -1;
}else SS=L;
N=newvect(L);
for(I=0;I<L;I++)
N[I]=M[I];
S=size(N[0])[0];
if(type(X)==4){
for(I=0;I<SS;I++){
if(X[I] != 0)
N[I] = radd(N[I],X[I]);
}
X=X[SS];
}
MZ = newmat(S,S);
ME = mgen(S,0,[X],0);
MM = newvect(L);
for(J=0; J<SS; J++){
for(R=[],I=SS-1; I>=0; I--){
if(I==J){
for(RR=[],K=SS-1; K>=0; K--)
RR=cons((K==I)?N[K]+ME:N[K],RR);
R=cons(RR,R);
}else R=cons([MZ],R);
}
MM[J]=newbmat(SS,SS,R);
}
for( ;J<L; J++){
for(R=[],I=SS-1; I>=0; I--){
for(RR=[N[J]],K=0;K<I;K++)
RR=cons(MZ,RR);
R=cons(RR,R);
}
MM[J]=newbmat(SS,SS,R);
}
for(II=JJ=1,J=SS; J<L; J++){
JI=(II==JJ)?0:II;
IS=JI*S;JS=JJ*S;
for(P=0; P<S; P++){
for(Q=0; Q<S; Q++){
MM[J][JS+P][JS+Q] += N[JI][P][Q];
MM[J][JS+P][IS+Q] -= N[JI][P][Q];
MM[J][IS+P][IS+Q] += N[JJ][P][Q];
MM[J][IS+P][JS+Q] -= N[JJ][P][Q];
}
}
if(++II>=SS) II=++JJ;
}
for(R=[],I=SS-1; I>=0; I--){
for(RR=[N[I]],J=0; J<I; J++) RR=cons(MZ,RR);
R=cons(RR,R);
}
M0 = newbmat(SS,SS,R);
for(M1=MM[0], J=1; J<SS; J++) M1=radd(M1,MM[J]);
KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
if(length(KE) == 0) return MM;
KK = mtoupper(lv2m(KE),0);
for(I=0;I<L;I++)
MM[I] = mmod(MM[I],KK);
return MM;
}
def lpgcd(L)
{
for(F=[]; L!=[]; L=cdr(L)){
if((P=car(L))==0) continue;
if(F==[]){
F=fctr(P);
S=length(F);
S--;
V=newvect(S);
M=newvect(S);
for(I=0; I<S; I++){
M[I] = F[I+1][1];
V[I] = F[I+1][0];
}
N=nm(ptozp(P|factor=1)[1]);
continue;
}
N=igcd(ptozp(P|factor=1)[1],N);
for(I=0; I<S; I++){
for(Q=P,CT=0; CT<M[I]; CT++)
if((Q=tdiv(Q,V[I])) == 0) break;
if(CT<M[I]) M[I]=CT;
}
}
if(F==[]) return 0;
for(Q=N,I=0;I<S; I++){
while(M[I]>0){
Q *= V[I];
M[I]--;
}
}
return Q;
}
def mdivisor(M,X)
{
S=size(M);
XX=(type(X)==4)?X:[0,X];
S0=S[0]; S1=S[1];
if((Tr=getopt(trans))==1){
GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0);
}else Tr=0;
if(type(St=getopt(step))!=1) St=0;
for(FF=": start";;){
if(St){
if(Tr){
mycat0([St,FF,"\n"],0);
mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
}
else mycat0([St,FF,"\n",M,"\n"],0);
}
/* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
if(X==0){ /* search minimal non-zero element */
for(K=F=I=0; I<S0; I++){
for(J=0; J<S1; J++){
if((P=abs(M[I][J]))!=0 && (K>P || K==0)){
K=P; R=[I,J];
}
}
}
R=cons(K-1,[R]);
}
else R=mymindeg(M,XX[1]|opt=1);
if(R[0]<0){ /*zero matrix */
if(Tr==1) return [[],newmat(S0,S0),newmat(S1,S1)];
return [];
}
R0=R[1][0];R1=R[1][1];
if(R0!=0){
M=rowx(M,0,R0);
if(Tr==1) GR=rowx(GR,0,R0);
}
if(R1!=0){
M=colx(M,0,R1);
if(Tr==1) GC=colx(GC,0,R1);
}
if(St>0 && (R0!=0 || R1!=0))
if(Tr==1){
mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n"],0);
mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
}else mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n",M,"\n"],0);
/* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
if(R[0]==0){ /* (1,1) : invertible */
P=M[0][0]; M[0][0]=1;
for(J=0;J<S1;J++){ /* (1,1) -> 1 */
if(J>0) M[0][J]= red(M[0][J]/P);
if(Tr==1) GR[0][J]=red(GR[0][J]/P);
}
/* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
if(S0>1 && S1>1) N=newmat(S0-1,S1-1);
else N=0;
for(I=1;I<S0;I++){
P=M[I][0]; M[I][0]=0;
for(J=1;J<S1;J++)
N[I-1][J-1]=M[I][J]=red(M[I][J] - muldo(P,M[0][J],XX));
if(Tr==1){
for(J=0;J<S0;J++)
GR[I][J] = red(GR[I][J] -muldo(P,GR[0][J],XX));
}
}
/* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
if(Tr==1){
for(J=1;J<S1; J++){
for(I=0;I<S1;I++) GC[I][J]=red(GC[I][J]-muldo(M[0][J],GC[I][0],XX));
M[0][J]=0;
}
}
if(St>0){
if(Tr==1){
mycat0([St,": unit\n"],0);
mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
}
else mycat0([St,": unit\n",M,"\n"],0);
}
/* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
if(N==0){
if(Tr==0) return [1];
return [[1],GR,GC];
}
R=mdivisor(N,XX|trans=Tr,step=(St>0)?St+1:St);
if(Tr==0) return cons(1,R);
/* mycat(["Ret",R]); */
GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
if(S0==S1 && countin(1,1,R[0])==S0-1){
GR=muldo(GR,GC,XX); GC=mgen(S0,0,1,0);
}
return [cons(1,R[0]),GR,GC];
}
for(I=1;I<S0;I++){
if(M[I][0]!=0){
R=mygcd(M[I][0],M[0][0],XX); /* R[0]=R[1]*M[I][0]+R[2]*M[0][0] */
M[0][0]=R[0]; M[I][0]=0; /* 0=R[3]*M[I][0]+R[4]*M[0][0] */
for(J=1;J<S1;J++){
T=red(muldo(R[1],M[I][J],XX)+muldo(R[2],M[0][J],XX));
M[I][J]=red(muldo(R[3],M[I][J],XX)+muldo(R[4],M[0][J],XX));
M[0][J]=T;
}
if(Tr==1){
for(J=0;J<S0;J++){
T=red(muldo(R[1],GR[I][J],XX)+muldo(R[2],GR[0][J],XX));
GR[I][J]=red(muldo(R[3],GR[I][J],XX)+muldo(R[4],GR[0][J],XX));
GR[0][J]=T;
}
}
if(St){
mycat([" [",R[2],R[1],"]*"]);
mycat([" [",R[4],R[3],"]"]);
}
FF=": line 1 & "+rtostr(I+1);I=S0;
}
}
if(I>S0) continue;
for(J=1;J<S1;J++){
if(M[0][J]!=0){
R=mygcd(M[0][J],M[0][0],XX|rev=1); /* R[0]=M[0][J]*R[1]+M[0][0]*R[2] */
M[0][0]=R[0]; M[0][J]=0; /* 0=M[0][J]*R[3]+M[0][0]*R[4] */
for(I=1;I<S0;I++){
T=red(muldo(M[I][J],R[1],XX)+muldo(M[I][0],R[2],XX));
M[I][J]=red(muldo(M[I][J],R[3],XX)+muldo(M[I][0],R[4],XX));
M[I][0]=T;
}
if(Tr==1){
for(I=0;I<S1;I++){
T=red(muldo(GC[I][J],R[1],XX)+muldo(GC[I][0],R[2],XX));
GC[I][J]=red(muldo(GC[I][J],R[3],XX)+muldo(GC[I][0],R[4],XX));
GC[I][0]=T;
}
}
FF=": column 1 & "+rtostr(J+1);J=S1;
if(St){
mycat([" *[",R[2],R[4],"]"]);
mycat([" [",R[1],R[3],"]"]);
}
}
}
if(J>S1) continue;
if(S0==1 || S1==1){
P=M[0][0];
if(X==0){
if(P<0) P=-P;
if(Tr==1) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
}else{
P=nm(P);
P/=(R=fctr(P)[0][0]);
if(Tr==1) for(J=0;J<S0;J++) GR[0][J]/=R;
}
if(Tr==0) return [P];
return [[P],GR,GC];
}
if(XX[0]==0){ /* commutative case */
P=M[0][0];
for(I=1; I<S0; I++){
for(J=1; J<S1; J++)
if(divdo(M[I][J],P,XX)[1]!=0) break;
if(J<S1){
FF=": column 1 += col"+rtostr(J+1);
for(I=1;I<S0;I++) M[I][0]=M[I][J];
if(Tr==1) for(I=0;I<S1;I++) GC[I][0]=red(GC[I][0]+GC[I][J]);
break;
}
}
if(J<S1) continue;
N=newmat(S0-1,S1-1);
for(I=1;I<S0;I++)
for(J=1;J<S1;J++) N[I-1][J-1]=red(M[I][J]/P);
if(X==0){
if(P<0) P=-P;
if(Tr==1) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
}else{
P=M[0][0];
P=nm(P);
P/=fctr(P)[0][0];
if(Tr==1) for(J=0;J<S0;J++) GR[0][J]/=fctr(P)[0][0];
}
R=mdivisor(N,XX|trans=Tr,step=(St>0)?St+1:St);
RT=(Tr==1)?R[0]:R;
for(RR=[],L=reverse(RT);L!=[];L=cdr(L))
RR=cons(red(P*car(L)),RR);
RR=cons(P,RR);
if(Tr==0) return RR;
GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
if(S0==S1 && countin(1,1,RR)==S0){
GR=muldo(GR,GC,XX); GC=mgen(S0,0,1,0);
}
return [RR,GR,GC];
} /* End of commutative case */
for(I=1; I<S0; I++){
for(J=1; J<S1; J++){
if(M[I][J] != 0){
for(T=1;I<S0;T*=XX[0]){
R=divdo(muldo(M[I][J],T,XX),M[0][0],XX);
if(R[1]!=0){
FF=": column 1 += col"+rtostr((J+1)*T);
if(I>1){
M=rowx(M,1,I);
if(Tr==1) GR=rowx(GR,1,I);
FF+=", line 2<->"+rtostr(I+1);
}
for(I=1;I<S0;I++) M[I][0]=muldo(M[I][J],T,XX);
if(Tr==1)
for(I=1;I<S1;I++) GC[I][0]=red(GC[I][0]+muldo(GC[I][J],T,XX));
I=S0+1; J=S1;
break;
}
}
}
}
if(I>S0) break;
}
if(I==S0) return []; /* zero matrix : never happen */
}
}
def mdsimplify(L)
{
T=getopt(type);
SS=0;
if(type(L)==6){
L=[L]; SS=1;
}
if(type(L)==5){
SS=2;
L = vtol(L);
}
M=car(L);
S=size(M)[0];
DD=newvect(S);
for(I=0; I<S; I++){
LN=RN=[];
LD=RD=1;
for(LL=L; LL!=[]; LL=cdr(LL)){
M = car(LL);
for(J=0; J<S; J++){
if(J==I) continue;
if((MM=M[I][J]) != 0){
LN = cons(nm(MM),LN);
if(type(MM)==3 && tdiv(LD,P=dn(MM))==0)
LD=tdiv(LD*P,gcd(LD,P));
}
if((MM=M[J][I]) != 0){
RN = cons(nm(MM),RN);
if(type(MM)==3 && tdiv(RD,P=dn(MM))==0)
RD=tdiv(RD*P,gcd(RD,P));
}
}
}
if(T==1 || T==3) LQ=RD;
else{
P=lpgcd(LN);
LQ=gcd(P,RD);
if(P!=0) LQ *= nm(fctr(P)[0][0]);
}
if(T==1 || T==2) RQ=LD;
else{
P=lpgcd(RN);
RQ=gcd(P,LD);
if(P!=0) RQ *= nm(fctr(P)[0][0]);
}
if((P=gcdz(LQ,RQ))!=1){
LQ = red(LQ/P); RQ=red(RQ/P);
}
DD[I]=red(LQ/RQ);
if(LQ!=1 || RQ!=1){
for(LA=[],LL=L; LL!=[]; LL=cdr(LL)){
M = car(LL);
for(J=0; J<S; J++){
if(I!=J){
if(LQ!=1){
M[I][J] = red(M[I][J]/LQ);
M[J][I] = red(M[J][I]*LQ);
}
if(RQ!=1){
M[J][I] = red(M[J][I]/RQ);
M[I][J] = red(M[I][J]*RQ);
}
}
}
}
}
}
if(SS==2) L=ltov(L);
if(SS==1) L=L[0];
if(getopt(show)==1) L=[L,DD];
return L;
}
def m2mc(M,X)
{
if(type(M)<2){
mycat([
"m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
" m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
" t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
" s : TeX, dviout, GRSC\n",
" option : swap, small, simplify, operator, int\n",
" Ex: m2mc(\"21,21,21,21\",\"All\")\n"
]);
return 0;
}
if(type(M)==7) M=s2sp(M);
if(type(X)==7)
X=[X];
Simp=getopt(simplify);
if(Simp!=0 && type(Simp)!=1) Simp=2;
Small=(getopt(small)==1)?1:0;
if(type(M[0])==4){
if(type(M[0][0])==1){ /* spectral type */
XX=getopt(dep);
if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
if(getopt(int)!=0){
T=M[XX[0]-1][XX[1]-1][1];
for(V=vars(T);V!=[];V=cdr(V)){
F=coef(T,1,car(V));
if(type(F)==1 && dn(F)>1)
M = subst(M,car(V),dn(F)*car(V));
}
}
V=vars(M);
if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
M=subst(M,d1,d);
}
RC=chkspt(M|mat=1);
if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
erno(0);return 0;
}
R=getbygrs(M,1|mat=1);
Z=newmat(1,1,[[0]]);
N=[Z,Z,Z,Z,Z];
for(RR=R; RR!=[]; RR=cdr(RR)){
RT=car(RR)[0];
if(type(RT)==4){
if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
}
}
if(type(X)==4 && type(X[0])==7)
return m2mc(N,X|keep=Keep,small=Small);
return N;
}
if(type(X)==4 && type(X[0])==7){
Keep=(getopt(keep)==1)?1:0;
if(X[0]=="All"){
dviout("Riemann scheme"|keep=1);
m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
dviout("Spectral types : "|keep=1);
m2mc(M,["sp","dviout"]|keep=1);
dviout("\\\\\nBy the decompositions"|keep=1);
R=m2mc(M,["pairs","dviout"]|keep=1);
for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
if(S==0) R0=cons(I,R0);
else if(S<0) R1=cons(I,R1);
}
S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
+"\\ \\emptyset=\\mathbb Z\\cap$";
dviout(S|keep=1);
m2mc(M,["irreducible","dviout"]|keep=1);
if(R0!=[])
dviout(ltotex(reverse(R0))|eq=0,keep=1,
title="The following conditions may not be necessary for the irreducibility.");
if(R1!=[])
dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
if(getopt(operator)!=0){
dviout("The equation in a Pfaff form is"|keep=1);
m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
}
else if(Keep!=1) dviout(" ");
return M;
}
Show=0;
if(length(X)>1){
if(X[1]=="dviout") Show=2;
if(X[1]=="TeX") Show=1;
}
if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"){
Y=radd(-M[0],-M[1]-M[2]);
if(X[0]!="GRSC"){
L=meigen([M[0],M[1],M[2],M[3],M[4],Y,radd(-M[1],-M[3]-M[4]),radd(Y,-M[3]-M[4])]|mult=1);
if(X[0]=="sp"){
L=chkspt(L|opt="sp");
V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
return [V,W];
}
S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
}else{
L=meigen([M[0],M[1],M[2],M[3],M[4],Y,radd(-M[1],-M[3]-M[4]),radd(Y,-M[3]-M[4]),
radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty&x=y=0&x=y=1\\\\\n";
}
T=ltotex(L|opt="GRS",pre=S,small=Small);
if(Show==2) dviout(T|eq=0,keep=Keep);
if(Show==1) L=T;
return L;
}
if(X[0]=="Pfaff"){
S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
if(Show==2) dviout(S|eq=0,keep=Keep);
return S;
}
if(X[0]=="irreducible"){
L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
S=getbygrs(L,10|mat=1);
if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
return S;
}
if(X[0]=="pairs"||X[0]=="pair"){
L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
S=chkspt(L|opt=0);
V=(Show==2)?1:0;
S=sproot(L,X[0]|dviout=V,keep=Keep);
return S;
}
if(X[0]=="swap"){
Swap=getopt(swap);
if(type(Swap)<1 || Swap==1)
return newvect(5,[M[3],M[1],M[4],M[0],M[2]]);
if(Swap==2)
return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
if(type(Swap)==4 && length(Swap)==3){
MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
if(Swap[0]==1){
MX0=M[2];MY0=M[4];
}
else if(Swap[0]==2){
MX0=MX;MY0=MY;
}else{
MX0=M[0];MY0=M[3];
}
if(Swap[1]==1){
MX1=M[2];MY1=M[4];
}
else if(Swap[1]==2){
MX1=MX;MY1=MY;
}else{
MX1=M[0];MY1=M[3];
}
return newvect(5,MX0,M[1],MX1,MY0,MY1);
}
}
return 0;
}
if(getopt(swap)==1)
return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
N=newvect(5);
for(I=0;I<5;I++)
N[I]=M[I];
S=size(N[0])[0];
if(type(X)==4){
for(I=0;I<3;I++){
if(X[I] != 0)
N[I] = radd(N[I],X[I]);
}
if(length(X)==3) return N;
X=X[3];
}
MZ = newmat(S,S);
ME = mgen(S,0,[X],0);
MM = newvect(5);
MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]);
MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]);
MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]);
MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]);
MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]);
M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
M1 = radd(MM[0],MM[1]+MM[2]);
KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
if(length(KE) == 0) return MM;
KK = mtoupper(lv2m(KE),0);
for(I=0;I<5;I++)
MM[I] = mmod(MM[I],KK);
if(Simp!=0) MM = mdsimplify(MM|type=Simp);
return MM;
}
/*
def mmc(M,X)
{
if(type(M)==4)
M=ltov(M);
L = length(M);
S = size(M[0])[0];
SS = L*S;
MM = newvect(L);
M0 = newmat(SS,SS);
if(type(X)<4){
Y = newvect(L+1);
Y[L]=X;
}else Y = X;
for(KI = 0; KI < L; KI++){
MM[KI] = newmat(SS,SS);
II=KI*S;
for(I=0; I<S; I++){
for(KJ=0; KJ<L; KJ++){
JJ=KJ*S;
for(J=0; J<S; J++){
MM[KI][II+I][JJ+J]=M[KJ][I][J]+((I==J)?Y[KJ]:0);
if(KI==KJ){
M0[II+I][JJ+J]=M[KJ][I][J]+((I==J)?Y[KJ]:0);
if(I==J)
MM[KI][II+I][JJ+J]+=Y[L];
}
}
}
}
}
M1 = newmat(SS,SS);
for(I=0; I<L; I++)
M1 += MM[I];
KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
if(length(KE)==0) return MM;
KK = toupper(lv2m(KE,0));
for(KI = 0; KI < L; KI++)
MM[KI] = mmod(MM[KI],KK);
return MM;
}
*/
def easierpol(P,X)
{
if(type(X) == 4){
for( Y = [] ; X != []; X = cdr(X) )
Y = cons([0,car(X)], Y);
}else
Y = [0,X];
return rede(P,Y);
}
def mykernel(M)
{
if(getopt(opt) == 1)
M = mtranspose(M);
S = size(M);
R = [];
MM = mtoupper(M,-1);
for(I = S[0]-1; I >= 0; I--){
for(J = S[1]-1; J >= 0; J--){
if(MM[I][J] != 0)
return R;
}
P = easierpol(MM[I][S[1]],zz);
RR = newvect(S[0]);
for(J = 0; J < S[0]; J++)
RR[J] = mycoef(P,J,zz);
R = cons(RR,R);
}
return R;
}
def myimage(M)
{
if(getopt(opt) == 1)
M = mtranspose(M);
S = size(M);
V = [];
M0 = newvect(S[1]);
M = mtoupper(M,0|opt=1);
for(I = S[0]-1; I >= 0; I--)
if(M0 != M[I])
V = cons(vtozv(M[I])[0], V);
return V;
}
def mymod(V,L)
{
Opt = getopt(opt);
S = length(V);
VP = newvect(S);
if(type(L)==6)
L=m2lv(L);
CT = length(L);
for(LT = L; LT != []; LT = cdr(LT)){
for(VT = car(LT), I = 0; I < S; I++)
if(VT[I] != 0) break;
if(I >= S){
CT--;
continue;
}
VP[I] = 1;
MI = -red(V[I]/VT[I]);
if(MI != 0)
V = radd(V,rmul(MI,VT));
}
if(Opt==1){
for(I = 0; I < S; I++)
if(V[I] != 0)
return 1;
return 0;
}
if(Opt==2){
W=newvect(S-CT);
for(CC = I = 0; I < S; I++){
if(VP[I]==0) W[CC++] =V[I];
}
return W;
}
return V;
}
def mmod(M,L)
{
S=size(M)[1];
MM=mtranspose(M);
VP = newvect(S);
if(type(L)==6)
L=m2lv(L);
for(CT = 0, LT = L; LT != []; LT = cdr(LT)){
for(VT = car(LT), I = 0; I < S; I++){
if(VT[I] != 0){
VP[I] = 1;
break;
}
}
}
if(getopt(opt)==1)
NE=1;
for(D=I=0; I<S; I++){
if(NE != 1 && VP[I] == 1) continue;
T = mymod(MM[I],L|opt=2);
if(D==0){
K=length(T);
MN=newmat((NE==1)?S:K,K);
}
for(J=0;J<K;J++)
MN[J][D]=T[J];
D++;
}
return MN;
}
def llbase(VV,L)
{
S = length(VV);
V = dupmat(VV);
if(type(V) == 4)
V = ltov(V);
T = length(L);
for(I = 0; I < S; I++)
V[I] = nm(red(V[I]));
LV = 0;
for(J = 0; J < T; J++){
X = var(L[J]); N = deg(L[J],X);
for(I = LV; I < S; I++){
if((C2=coef(V[I],N,X)) != 0){
if(I > LV){
Temp = V[I];
V[I] = V[LV];
V[LV] = Temp;
}
for(I = 0; I < S; I++){
if(I == LV || (C1 = coef(V[I],N,X)) == 0)
continue;
Gcd = gcd(C1,C2);
V[I] = V[I]*tdiv(C2,Gcd)-V[LV]*tdiv(C1,Gcd);
}
LV++;
}
}
}
return map(ptozp,V);
}
def lsort(L1,L2,T)
{
if(type(T)==7)
T = findin(T,["cup","setminus","cap","reduce"]);
if(L2 == []){
if(T == 2) return L2;
if(T == 3) return [L1,L2];
L1 = ltov(L1); qsort(L1);
if(T != 1)
return vtol(L1);
L3 = [];
for(I = length(L1)-1; I >= 0; I--){
if(I > 0 && L1[I] == L1[I-1])
continue;
L3 = cons(L1[I], L3);
}
return L3;
}
if(T == 1 || T == 2){
L1 = lsort(L1,[],1);
L2 = lsort(L2,[],1);
L3 = [];
if(T == 1){
while(L1 != []){
if(L2 == [] || car(L1) < car(L2)){
L3 = cons(car(L1), L3);
L1 = cdr(L1);
continue;
}
if(car(L1) > car(L2)){
L2 = cdr(L2);
continue;
}
L1 = cdr(L1); L2 = cdr(L2);
}
return reverse(L3);
}
if(T==2){
while(L1 != [] && L2 != []){
if(car(L1) != car(L2)){
if(car(L1) <= car(L2))
L1 = cdr(L1);
else L2 = cdr(L2);
continue;
}
while(car(L1) == car(L2))
L1 = cdr(L1);
L3 = cons(car(L2), L3);
}
return reverse(L3);
}
}
if(T==3){
L1 = qsort(L1); L2 = qsort(L2);
L3 = L4 = [];
while(L1 != [] && L2 != []){
if(car(L1) == car(L2)){
L1 = cdr(L1); L2 = cdr(L2);
}else if(car(L1) < car(L2)){
L3 = cons(car(L1),L3);
L1 = cdr(L1);
}else{
L4 = cons(car(L2), L4);
L2 = cdr(L2);
}
}
L4 = append(reverse(L4),L2);
L3 = append(reverse(L3),L1);
return [L3,L4];
}
L1 = append(L1,L2);
return lsort(L1,[],1);
}
def lchange(L,P,V)
{
if(type(P)==4){
IP=car(P); P=cdr(P);
}else{
IP=P; P=[];
}
for(I=0, LL=[], LT=L; LT!=[]; I++,LT=cdr(LT)){
if(I==IP){
LL=cons((P==[])?V:lchange(car(LT),P,V),LL);
}else
LL=cons(car(LT),LL);
}
return reverse(LL);
}
def lsol(VV,L)
{
if(type(VV)<4 && type(L)==2)
return red(L-VV/mycoef(VV,1,L));
S = length(VV);
T = length(L);
V = llbase(VV,L);
for(J = K = 0; J < T; J++){
X = var(L[J]); N = deg(L[J],X);
for(I = K; I < S; I++){
if((C=mycoef(V[I], N, X)) != 0){
V[I] = [L[J],red(X^N-V[I]/C)];
K++;
break;
}
}
}
return V;
}
def lnsol(VV,L)
{
LL=lsort(vars(VV),L,1);
VV=ptol(VV,LL|opt=0);
return lsol(VV,L);
}
def m2v(M)
{
S = size(M);
V = newvect(S[0]*S[1]);
for(I = C = 0; I < S[0]; I++){
MI = M[I];
for(J = 0; J < S[1]; J++)
V[C++] = MI[J];
}
return V;
}
def lv2m(L)
{
if(type(L)==5) L=vtol(L);
II=length(L);
for(J=1,T=L; T!=[]; T=cdr(T))
if(length(car(T))>J) JJ=length(car(T));
M = newmat(II,JJ);
N = getopt(fill);
if(type(N)<0) N=0;
for(I=0; I<II; I++){
V=car(L); L=cdr(L);
for(J=length(V);J-->0;)
M[I][J] = V[J];
if(N!=0){
for(J=length(V); J<JJ; J++)
M[I][J]=N;
}
}
return M;
}
def m2lv(M)
{
I=size(M)[0];
for(N=[],I=size(M)[0];I-->0;)
N=cons(M[I],N);
return N;
}
def s2m(S)
{
if(type(S)==7){
if(str_chr(S,0,"[")!=0) S=s2sp(S);
else if(str_chr(S,0,",")>=0) return eval_str(S);
else{
for(L=LL=[],I=0; ; ){
II=str_chr(S,I+2,"]");
if(II<0) return 0;
J=str_chr(S,I+2," ");
while(str_chr(S,J+1," ")==J+1) J++;
if(J>II-2 || J<0) J=II;
V=eval_str(sub_str(S,I+1,J-1));
L=cons(V,L);
I=J;
if(J==II){
LL=cons(ltov(reverse(L)),LL);
L=[];
if((I=str_chr(S,II+1,"["))<0)
return lv2m(reverse(LL));
}
}
}
}
if(type(S)==5) S=vtol(S);
if(type(S[0])==5) return lv2m(S);
I=length(S);
for(J=1,T=S; T!=[]; T=cdr(T))
if(length(car(T))>J) J=length(car(T));
return newmat(I,J,S);
}
#if 0
def m2diag(M,N)
{
S = size(M);
MM = mtoupper(M,N);
for(I = S[0]-1; I >= 0; I--){
for(J = 0; I < S[1]-N; I++){
if(MM[I][J] != 0){
P = MM[I][J];
for(K = 0; K < I; K++){
Q = -rmul(MM[K][J],1/P);
MM[K][J] = 0;
if(Q != 0){
for(L = J+1; L < S[1]; L++){
if(MM[I][L] != 0)
MM[K][L] = radd(MM[K][L], rmul(MM[I][L],Q));
}
}
}
}
}
}
return MM;
}
#endif
def myinv(M)
{
S = size(M);
if((T=S[0]) != S[1])
return 0;
MM = mtoupper(M,-T|opt=2);
if(MM[T-1][T-1] != 1) return 0;
return mperm(MM,0,[T,[T]]);
}
def madj(G,M)
{
H=myinv(G);
if(type(M)==6)
return rmul(rmul(G,M),H);
if(type(M)==4||type(M)==5){
L=length(M);
N=newvect(L);
for(I=0;I<L;I++){
N[I]=rmul(rmul(G,M[I]),H);
}
if(type(N)==4) N=vtol(N);
return N;
}
return -1;
}
def mpower(M,N)
{
if(type(M)<=3) return (red(M))^N;
S = size(M);
if(S[0] != S[1])
return 0;
if(N == 0) return mgen(S[0],0,[1],0);
if(N < 0)
return(mpower(myinv(M), -N));
R = dupmat(M);
V=1;
for(V=1;;){
if(iand(N,1)){
V=map(red,R*V);
N--;
}
if((N/=2)==0) break;
R=map(red,R*R);
}
return V;
}
def texlen(S)
{
if(type(S)!=7) return 0;
LF=I=J=0;
LM=str_len(S);
while((I=str_str(S,"\\frac{"|top=J))>=0){
if(I>J) LF+=texlen(str_cut(S,J,I-1));
I+=6;
for(F=L=0,J=I;F<2 && J<LM-1;F++){
for(C=1;C>0 && J<LM;){
if((K0=str_char(S,J,"}"))<0) K0=LM;
if((K1=str_char(S,J,"{"))<0) K1=LM;
if(K0<0 && K1<0){
J = str_len(S)-1;
break;
}
if(K0<K1){
J=K0+1; C--;
}else{
J=K1+1; C++;
}
}
T=str_cut(S,I,J-1);
if(F==0){
I=J=K1+1;C=1;
}else J=K0+1;
if(type(T)==7 && (LL=texlen(T))>L) L=LL;
}
LF+=L;
}
if(J>0) S=str_cut(S,J,str_len(S)-1);
if(S==0) return LF;
S=ltov(strtoascii(S));
L=LL=length(S);
for(I=F=0; I<L; I++){
if(S[I]==92) F=1;
else if(F==1){
if((S[I]>96 && S[I]<123)||(S[I]>64 && S[I]<91)) LL--;
else F=0;
}
if(S[I]<=32||S[I]==123||S[I]==125||S[I]==94||S[I]==38) LL--; /* {}^& */
else if(S[I]==95){
LL--;
if(I+2<L && S[I+2]==94) LL--; /* x_2^3 */
else if(I+6<L && S[I+1]==123 && S[I+4]==125){ /* x_{11}^2 */
if(S[I+5]==94 || (S[I+5]==125 && S[I+6]==94)) LL-- ; /* x_{11}}^2 */
}
}
}
return LL+LF;
}
def isdif(P)
{
if(type(P)<1 || type(P)>3) return 0;
for(Var=[],R=vars(P);R!=[];R=cdr(R)){
V0=rtostr(car(R));
if(V0>"d" && V0<"e"){
V=sub_str(V0,1,str_len(V0)-1);
if(V>="a" && V<"{") Var=cons([strtov(V),strtov(V0)],Var);
}
}
if(Var==[]) return 0;
for(V=Var; V!=[]; V=cdr(V))
if(ptype(P,car(V)[1])==3) return 0;
return Var;
}
def fctrtos(P)
{
/* extern TeXLim; */
if(!chkfun("write_to_tb", "names.rr"))
return 0;
TeX = getopt(TeX);
if(TeX != 1 && TeX != 2 && TeX != 3)
TeX = 0;
if((Dvi=getopt(dviout)==1) && TeX<2) TeX=3;
if(TeX>0){
Lim=getopt(lim);
if(Lim!=0 && TeX>1 && (type(Lim)!=1||Lim<30)) Lim=TeXLim;
else if(type(Lim)!=1) Lim=0;
CR=(TeX==2)?"\\\\\n":"\\\\\n&";
if(TeX==1 && Lim==0) CR="";
else if((Pages=getopt(pages))==1) CR="\\allowdisplaybreaks"+CR;
if(!chkfun("print_tex_form", "names.rr"))
return 0;
Small=getopt(small);
}
Dif=getopt(dif);
Var=getopt(var);
if(Lim>0 && type(Var)<2 && TeX!=1) Var=[strtov("0"),""];
Dif=0;
if(Var=="dif"){
Dif=DV=1;
}else if (Var=="dif0") Dif=1;
else if(Var=="dif1") Dif=2;
else if(Var=="dif2") Dif=3;
if(Dif>0){
for(Var=[],R=vars(P);R!=[];R=cdr(R)){
V=rtostr(car(R));
if(V>"d" && V<"e"){
V=sub_str(V,1,str_len(V)-1);
if(V>="a" && V<"{"){
if(TeX>0){
V=my_tex_form(strtov(V));
if(Dif>=1){
if(Dif==1){
if(str_len(V)==1) V="\\partial_"+V;
else V="\\partial_{"+V+"}";
}
Var=cons([car(R),V],Var);
}
else Var=cons([car(R)],Var);
}else Var=cons([car(R)],Var);
}
}
}
if(TeX>0){
if(length(Var)==1){
if(DV==1 && str_len(Var[0][1])==10) Var=[[Var[0][0],"\\partial"]];
}else if(DV==1){
for(V=Var;V!=[];V=cdr(V)){
VV=rtostr(car(V)[0]);
if(VV<"dx0" || VV>= "dx:" || str_len(VV)>4) break;
}
if(V==[]){
for(VT=[],V=Var;V!=[];V=cdr(V)){
VV=str_cut(rtostr(car(V)[0]),2,3);
if(str_len(VV)==1) VT=cons([car(V)[0],"\\partial_"+VV],VT);
else VT=cons([car(V)[0],"\\partial_{"+VV+"}"],VT);
}
Var=reverse(VT);
}
}else
if(Dif==2 && length(Var)>1) Dif=3;
}
if(Dif>0) Dif--;
}
if(type(Var)>1 && Var!=[]){ /* as a polynomial of Var */
Add=getopt(add);
if(type(Add)>0){
if(type(Add)!=7){
Add=my_tex_form(Add);
if(str_char(Add,0,"-")>=0 || str_char(Add,0,"+")>=0) Add="("+Add+")";
}
if(str_char(Add,0,"(")!=0) Add = " "+Add;
}else Add=0;
if(type(Var)!=4) Var=[Var];
if(length(Var)==2 && type(Var[1]) == 7)
Var = [Var];
for(VV=VD=[]; Var!=[];Var=cdr(Var)){
VT=(type(car(Var))==4)?car(Var):[car(Var)];
VT0=var(car(VT));
VV=cons(VT0,VV);
if(length(VT)==1){
VD=cons((TeX>=1)?my_tex_form(VT0):rtostr(VT0),VD);
}else VD=cons(VT[1],VD);
}
VV=reverse(VV);VD=reverse(VD);
Rev=(getopt(rev)==1)?1:0;
Dic=(getopt(dic)==1)?1:0;
TT=terms(P,VV|rev=Rev,dic=Dic);
if(TeX==0){
Pre="("; Post=")";
}
else{
Pre="{"; Post="}";
}
Out = string_to_tb("");
for(L=C=0,Tm=TT;Tm!=[];C++,Tm=cdr(Tm)){
for(I=0,PC=P,T=cdr(car(Tm)),PW="";T!=[];T=cdr(T),I++){
PC=mycoef(PC,D=car(T),VV[I]);
if(PC==0) continue;
PT="";
if(D!=0 && VD[I]!=""){
if(TeX==0 && PW!="") PW+="*";
if(D>1){
if(D>9) PT="^"+Pre+rtostr(D)+Post;
else PT="^"+rtostr(D);
}
if(Dif>0) PW+=(Dif==1)?"d":"\\partial ";
PW+=VD[I]+PT;
}
}
D=car(Tm)[0];
if(Dif>0 && D>0){
Op=(Dif==1)?"\\frac{d":"\\frac{\\partial";
if(D>1) Op+="^"+((D>9)?(Pre+rtostr(D)+Post):rtostr(D));
PW=Op+Add+"}{"+PW+"}";
}else if(Add!=0) PW=PW+Add;
OC = (TeX>=1)?fctrtos(PC|TeX=1,br=1):fctrtos(PC|br=1);
if(PW!=""){
if(OC == "1") OC = "";
else if(OC == "-1") OC = "-";
}
if(TeX==0 && D!=0 && OC!="" && OC!="-") PW= "*"+PW;
if((TOC=type(OC)) == 4){ /* rational coef. */
if(Lim>0 && (texlen(OC[0])>Lim || texlen(OC[0])>Lim)){
OC = (Small==1)?"("+OC[0]+")/("+OC[1]+")"
:"\\Bigl("+OC[0]+"\\Bigr)\\Bigm/\\Bigl("+OC[1]+"\\Bigr)";
TOC = 7;
}else{
if(str_char(OC[0],0,"-")==0){
P0=str_char(OC[0],1,"(");P1=str_char(OC[0],1,"+");P2=str_char(OC[0],1,"-");
if(P1>=P0 && P2>=P0) /* -5(a+b)/(c+d) */
OC="-"+"\\frac{"+str_cut(OC[0],1,str_len(OC[0]))+"}{"+OC[1]+"}";
else OC="\\frac{"+OC[0]+"}{"+OC[1]+"}";
}
else
OC = "\\frac{"+OC[0]+"}{"+OC[1]+"}";
}
}
if(Lim>0){
LL=texlen(OC)+texlen(PW);
if(LL+L>=Lim){
if(L>0) str_tb(CR,Out);
if(LL>Lim){
if(TOC==7) OC=texlim(OC,Lim|cut=CR);
PW+=CR; L=0;
}else L=LL;
}else L+=LL;
}else if(length(Tm)!=1) PW += CR; /* not final term */
if(str_chr(OC,0,"-") == 0 || C==0) str_tb([OC,PW], Out);
else{
str_tb(["+",OC,PW],Out);
if(LL<=Lim) L++;
}
}
S=str_tb(0,Out);
}else{ /* Var is not specified */
if((TP=type(P)) == 3){ /* rational function */
P = red(P); Nm=nm(P); Dn=dn(P);
Q=dn(ptozp(Nm|factor=1)[1]);
if(Q>1){
Nm*=Q;Dn*=Q;
}
if(TeX>0){
return (TeX==2)?
"\\frac\{"+fctrtos(Nm|TeX=1)+"\}\{"+fctrtos(Dn|TeX=1)+"\}"
:[fctrtos(Nm|TeX=1),fctrtos(Dn|TeX=1)];
}
else return fctrtos(Nm)+"/("+fctrtos(Dn)+")";
}
P = fctr(P); /* usual polynomial */
S = str_tb(0,0);
for(J = N = 0; J < length(P); J++){
if(type(P[J][0]) <= 1){
if(P[J][0] == -1){
write_to_tb("-",S);
if(length(P) == 1)
str_tb("1", S);
}else if(P[J][0] != 1){
str_tb((TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]), S);
N++;
}else if(length(P) == 1)
str_tb("1", S);
else if(getopt(br)!=1 && length(P) == 2 && P[1][1] == 1){
str_tb((TeX>=1)?my_tex_form(P[1][0]):rtostr(P[1][0]), S);
J++;
}
continue;
}
if(N > 0 && TeX != 1 && TeX != 2 && TeX != 3)
write_to_tb("*", S);
write_to_tb((TeX>=1)?monototex(P[J][0]):monotos(P[J][0]), S);
N++;
if(P[J][1] != 1)
if(TeX>=1)
str_tb(["^", rtotex(P[J][1])],S);
else
str_tb(["^", monotos(P[J][1])],S);
}
S = str_tb(0,S);
if((Lim>0 || TP!=2) && CR!="") S=texlim(S,Lim|cut=CR);
}
if(TeX>0){
if(Small==1) S=str_subst(S,"\\frac{","\\tfrac{");
if(Dvi==1){
dviout(S|eq=(Pages==1)?6:0); S=1;
}
}
return S;
}
def texlim(S,Lim)
{
/* extern TeXLim; */
if(S==1 && Lim>10){
TeXLim=Lim;
mycat(["Set TeXLim =",Lim]);
return 1;
}
if(type(Out=getopt(cut))!=7) Out="\\\\\n&";
if(type(Del=getopt(del))!=7) Del=Out;
if(Lim<30) Lim=TeXLim;
S=ltov(strtoascii(S));
for(L=[0],I=F=0;F==0; ){
II=str_str(S,Del|top=I)+2;
if(II<2){
F++;II=/* str_len(S) */ length(S)-1;
}
for(J=JJ=I+1;;JJ=K+1){
K=str_char(S,JJ,43); /* + */
if((K1=str_char(S,JJ,45))>2 && K1<K){ /* - */
if(S[K1-1]!=123 && S[K1-1]!=40) K=K1; /* {, ( */
}
if((K1=str_char(S,JJ,40))>0 && K1-JJ>6 && K1<K && S[K1-1]!=43 && S[K1-1]!=45){ /* ( */
T=str_char(S,K1-6,"\\"); /* \Big*(, \big*( */
if((T==K1-6 || T==K1-5)
&& (str_str(S,"big"|top=T+1,end=T+1)>0 || str_str(S,"Big"|top=T+1,end=T+1)>0))
K=T;
else if(K1>0 && K1<K) K=K1;
}
if(K<0 || K>II) break;
if(K-J>Lim && texlen(str_cut(S,J,K-1))>=Lim){
J=K+1; L=cons(JJ-1,L); SL=0;
}
}
I=II;
}
SS=str_tb(0,0);
L=cons(length(S),L);
L=reverse(L);
for(I=0; L!=[]; I=J,L=cdr(L)){
str_tb((I==0)?"":Out,SS);
J=car(L);
str_tb(str_cut(S,I,J-1),SS);
}
return str_tb(0,SS);
}
def fmult(FN,M,L,N)
{
for(I = 0; I < length(M); I++)
M = call(FN, cons(M,cons(L[I],N)));
return M;
}
def radd(P,Q)
{
if(type(P) <= 3 || type(Q) <= 3){
if(type(P) >= 5)
return radd(Q,P);
if(type(Q) >= 5){
R = dupmat(Q);
if(P == 0)
return R;
if(type(Q) == 6){
S = size(Q);
if(S[0] != S[1])
return 0;
for(I = 0; I < S[0]; I++)
R[I][I] = radd(R[I][I], P);
}else{
for(I = length(R)-1; I >= 0; I--)
R[I] = radd(R[I],P);
}
return R;
}
/* P=red(P);Q=red(Q); */
if((P1=dn(P)) == (Q1=dn(Q))){
if(P1==1) return P+Q;
return red((nm(P)+nm(Q))/P1);
}
R=gcd(P1,Q1);S=tdiv(P1,R);
return red((nm(P)*tdiv(Q1,R)+nm(Q)*S)/(S*Q1));
}
if(type(P) == 5){
S = length(P);
R = newvect(S);
for(I = 0; I < S; I++)
R[I] = radd(P[I],Q[I]);
return R;
}
if(type(P) == 6){
S = size(P);
R = newmat(S[0],S[1]);
for(I = 0; I < S[0]; I++){
for(J = 0; J < S[1]; J++)
R[I][J] = radd(P[I][J],Q[I][J]);
}
return R;
}
erno(0);
}
def getel(M,I)
{
if(type(M) >= 4 && type(M) <= 6 && type(I) <= 1)
return M[I];
if(type(M) == 6 && type(I) == 5)
return M[I][J];
return M;
}
def ptol(P,X)
{
F=(getopt(opt)==0)?0:1;
if(type(P) <= 3)
P = [P];
if(type(X) == 4){
for( ; X != []; X = cdr(X))
P=ptol(P,car(X)|opt=F);
return P;
}
P = reverse(P);
for(R=[]; P != []; P = cdr(P)){
Q = car(P);
for(I = mydeg(Q,X); I >= 0; I--){
S=mycoef(Q,I,X);
if(F==1 || S!=0) R = cons(S,R);
}
}
return R;
}
def rmul(P,Q)
{
if(type(P) <= 3 && type(Q) <= 3){
P=red(P);Q=red(Q);
P1=dn(P);P2=nm(P);Q1=dn(Q);Q2=nm(Q);
if(P1==1 && Q1==1)
return P*Q;
if((R=gcd(P1,Q2)) != 1){
P1=tdiv(P1,R);Q2=tdiv(Q2,R);
}
if((R=gcd(Q1,P2)) != 1){
Q1=tdiv(Q1,R);P2=tdiv(P2,R);
}
return P2*Q2/(P1*Q1);
}
return mmulbys(rmul,P,Q,[]);
}
def mtransbys(FN,F,LL)
{
if(type(F) == 4){
F = ltov(F);
S = length(F);
R = newvect(S);
for(I = 0; I < S; I++)
R[I] = mtransbys(FN,F[I],LL);
return vtol(R);
}
if(type(F) == 5){
S = length(F);
R = newvect(S);
for(I = 0; I < S; I++)
R[I] = mtransbys(FN,F[I],LL);
return R;
}
if(type(F) == 6){
S = size(F);
R = newmat(S[0],S[1]);
for(I = 0; I < S[0]; I++){
for(J = 0; J < S[1]; J++)
R[I][J] = mtransbys(FN,F[I][J],LL);
}
return R;
}
return call(FN, cons(F,LL));
}
def mysubst(P,L)
{
if(P==0) return 0;
if(type(L[0]) == 4){
while((L0 = car(L))!=[]){
P = mysubst(P,L0);
L = cdr(L);
}
return P;
}
if(type(P) > 3){
if(type(P)>6)
return subst(P,L[0],L[1]);
return mtransbys(mysubst,P,[L]);
}
P = red(P);
if(type(P) == 3){
A=mysubst(nm(P),L);B=mysubst(dn(P),L);
return red(nm(A)/nm(B))*red(dn(B)/dn(A));
}
L1=red(L[1]);X=L[0];
if(type(L1)==3){
LN=nm(L1);LD=dn(L1);
Deg=deg(P,X);
if(Deg <= 0) return P;
V = newvect(Deg+1);
for(V[I=Deg]=1;I >= 1;I--)
V[I-1]=V[I]*LD;
for(R = 0, I = Deg; I >= 0; I--)
R = R*LN + coef(P,I,X)*V[I];
return red(R/V[0]);
}
return subst(P,X,L1);
}
def mmulbys(FN,P,F,L)
{
if(type(F) <= 3){
if(type(P) <= 3)
return call(FN, cons(P,cons(F,L)));
if(type(P) == 5){
S = length(P);
R = newvect(S);
for(I = 0; I < S; I++)
R[I] = call(FN, cons(P[I],cons(F,L)));
return R;
}else if(type(P) == 6){
S = size(P);
R = newmat(S[0],S[1]);
for(I = 0; I < S[0]; I++){
for(J = 0; J < S[1]; J++)
R[I][J] = call(FN, cons(P[I][J],cons(F,L)));
}
return R;
}
}
if(type(F) == 5){
S = length(F);
if(type(P) <= 3){
R = newvect(S);
for(I = 0; I < S; I++)
R[I] = call(FN, cons(P,cons(F[I],L)));
return R;
}
if(type(P) == 5){
for(J=R=0; J<S; J++)
R = radd(R, call(FN, cons(P[J],cons(F[J],L))));
return R;
}
T = size(P);
R = newvect(T[0]);
for(I = 0; I < T[0]; I++){
for(J = 0; J < S; J++)
R[I] = radd(R[I], call(FN, cons(P[I][J],cons(F[J],L))));
}
return R;
}
if(type(F) == 6){
S = size(F);
if(type(P) <= 3){
R = newmat(S[0],S[1]);
for(I = 0; I < S[0]; I++){
for(J = 0; J < S[1]; J++)
R[I][J] = call(FN, cons(P,cons(F[I][J],L)));
}
return R;
}
if(type(P) == 5){
R = newvect(S[1]);
for(J = 0; J < S[1]; J++){
for(K = U = 0; K < S[0]; K++)
U = radd(U, call(FN, cons(P[K],cons(F[K][J],L))));
R[J] = U;
}
return R;
}
T = size(P);
R = newmat(T[0],S[1]);
for(I = 0; I < T[0]; I++){
for(J = 0; J < S[1]; J++){
for(K = U = 0; K < S[0]; K++)
U = radd(U, call(FN, cons(P[I][K],cons(F[K][J],L))));
R[I][J] = U;
}
}
return R;
}
erno(0);
return 0;
}
def appldo(P,F,L)
{
if(type(F) <= 3){
if(type(L) == 4 && type(L[0]) == 4)
return applpdo(P,F,L);
L = vweyl(L);
X = L[0]; DX = L[1];
J = mydeg(P,DX);
for(I = R = 0; I <= J; I++){
if(I > 0)
F = mydiff(F,X);
R = radd(R,mycoef(P,I,DX)*F);
}
return R;
}
return mmulbys(appldo,P,F,[L]);
}
def appledo(P,F,L)
{
if(type(F) <= 3){
L = vweyl(L);
X = L[0]; DX = L[1];
J = mydeg(P,DX);
for(I = R = 0; I <= J; I++){
if(I > 0)
F = myediff(F,X);
R = radd(R,mycoef(P,I,DX)*F);
}
return R;
}
mmulbys(appledo,P,F,[L]);
}
def muldo(P,Q,L)
{
if(type(Lim=getopt(lim))!=1) Lim=100;
if(type(Q) <= 3){
if(type(L) == 4 && type(L[0]) == 4)
return mulpdo(P,Q,L|lim=Lim); /* several variables */
R = rmul(P,Q);
L = vweyl(L);
X = L[0]; DX = L[1];
if(X != 0){
for(I = F = 1; ; I++){
P = mydiff(P,DX);
if(I>Lim){
mycat(["Over", Lim,"derivations!"]);
break;
}
if(P == 0)
break;
Q = mydiff(Q,X);
if(Q == 0)
break;
F *= I;
R = radd(R,P*Q/F);
}
}
return R;
}
return mmulbys(muldo,P,Q,[L]);
}
def adj(P,L)
{
if(type(P) == 4)
return map(adj,mtranspose(P),L);
if(type(L) == 4 && type(L[0]) == 4)
return fmult(adj,P,L,[]);
L = vweyl(L);
X = L[0]; DX = L[1];
P = R = subst(P, DX, -DX);
for(I = 1; (R = mydiff(mydiff(R, X), DX)/I) != 0 && I < 100; I++)
P = radd(P,R);
return P;
}
def laplace1(P,L)
{
if(type(L) == 4 && type(L[0]) == 4)
return fmult(laplace,P,L,[]);
L = vweyl(L);
X = L[0]; DX = L[1];
P = adj(P, L);
return subst(P,X,o_1,DX,X,o_1,DX);
}
def laplace(P,L)
{
if(type(L) == 4 && type(L[0]) == 4)
return fmult(laplace1,P,L,[]);
L = vweyl(L);
X = L[0]; DX = L[1];
P = adj(P, L);
return subst(P,X,o_1,DX,-X,o_1,-DX);
}
def mce(P,L,V,R)
{
L = vweyl(L);
X = L[0]; DX = L[1];
P = sftexp(laplace1(P,L),L,V,R);
return laplace(P,L);
}
def mc(P,L,R)
{
return mce(P,L,0,R);
}
def rede(P,L)
{
Q = ltov(fctr(nm(red(P))));
P = 1;
if(type(L) < 4)
L = [L];
if(type(L[0]) < 4)
L = [L];
for( ; L != []; L = cdr(L)){
DX = vweyl(car(L))[1];
for(I = 1; I < length(Q); I++){
if(mydeg(Q[I][0],DX) > 0){
P *= (Q[I][0])^(Q[I][1]);
Q[I]=[1,0];
}
}
}
return P;
}
def ad(P,L,R)
{
L = vweyl(L);
DX = L[1];
K = mydeg(P,DX);
S = mycoef(P,0,DX);
Q = 1;
for(I=1; I <= K;I++){
Q = muldo(Q,DX-R,L);
S = radd(S,mycoef(P,I,DX)*Q);
}
return S;
}
def add(P,L,R)
{
return rede(ad(P,L,R),L);
}
def vadd(P,L,R)
{
L = vweyl(L);
if(type(R) != 4)
return 0;
N = length(R);
DN = 1; Ad = PW = 0;
for( ; R != []; R = cdr(R), PW++){
DN *= (T=1-car(R)[0]*L[0]);
Ad = Ad*T-car(R)[1]*x^PW;
}
Ad /= DN;
return add(P,L,Ad);
}
def addl(P,L,R)
{
return laplace1(add(laplace(P,L),L,R),L);
}
def cotr(P,L,R)
{
L = vweyl(L);
X = L[0]; DX = L[1];
T = 1/mydiff(P,DX);
K = mydeg(P,DX);
S = mysubst(mycoef(P,0,DX), [X, R]);
Q = 1;
for(I = 1; I <= K; I++){
Q = muldo(Q, K*DX, L);
S = radd(S,mysubst(mycoef(P,I,DX), [X, R])*Q);
}
}
def rcotr(P,L,R)
{
return rede(cotr(P,L,R), L);
}
def muledo(P,Q,L)
{
if(type(Q)>3)
return mmulbys(muledo,P,Q,[L]);
R = P*Q;
L = vweyl(L);
X = L[0]; DX = L[1];
for(I = F = 1; I < 100; I++){
P = mydiff(P,DX);
if(P == 0)
break;
Q = myediff(Q,X);
if(Q == 0)
break;
F = rmul(F,I);
R = radd(R,P*Q/F);
}
return R;
}
#if 1
def mulpdo(P,Q,L)
{
if(type(Q)>3)
return mmulbys(mulpdo,P,Q,[L]);
if(type(Lim=getopt(lim))!=1) Lim=100;
M = vweyl(car(L)); X= M[0]; DX = M[1];
L = cdr(L);
R = 0;
for(I = 0; Q != 0 && I <= Lim; I++){
if(I>Lim){
mycat(["Over", Lim,"derivations!"]);
break;
}
if(I > 0)
P /= I;
if(length(L)==0)
R = radd(R,P*Q);
else
R = radd(R,mulpdo(P,Q,L));
if(X==0) break;
P = mydiff(P,DX);
if(P == 0)
break;
Q = mydiff(Q,X);
}
if(I>Lim) mycat(["Over", Lim,"derivations!"]);
return R;
}
#else
def mulpdo(P,Q,L);
{
if(type(Q)>3)
return mmulbys(mulpdo,P,Q,[L]);
if(type(Lim=getopt(lim))!=1) Lim=100;
N = length(L);
VO = newvect(2*N);
VN = newvect(2*N);
for(I = J = 0; I < N; J += 2, I++){
M = vweyl(L[I]);
P = subst(P, VO[J]=M[0], VN[J]=strtov("o_"+rtostr(V[J])),
VO[J+1]=M[1], VN[J+1] = strtov("o_"+rtostr(V[J+1])));
}
for(PQ = P*Q, I = 0; I < 2*N; I += 2){
for(R = PQ, J = 1; J < Lim; J++){
R = mydiff(R, VN[I+1])/J;
if(R == 0)
break;
R = mydiff(R, VO[I]);
if(R == 0)
break;
PQ = radd(PQ,R);
}
if(I==Lim) mycat(["Over", Lim,"derivations!"]);
PQ = red(subst(PQ,VN[I],VO[I],VN[I+1],VO[I+1]));
}
}
#endif
def transpdosub(P,LL,K)
{
Len = length(K)-1;
if(Len < 0 || P == 0)
return P;
KK=K[Len];
if(type(KK)==4){
KK0=KK[0]; KK1=KK[1];
}else{
L = vweyl(LL[Len]);
KK0=L[1]; KK1=K[Len];
}
Deg = mydeg(P,KK0);
K1 = reverse(cdr(reverse(K)));
R = transpdosub(mycoef(P,0,KK0),LL,K1);
for(I = M = 1; I <= Deg ; I++){
M = mulpdo(M,KK1,LL);
S = mycoef(P,I,KK0);
if(Len > 0)
S = transpdosub(S,LL,K1);
R = radd(R,mulpdo(S,M,LL));
}
return R;
}
def transpdo(P,LL,K)
{
if(type(K[0]) < 4)
K = [K];
Len = length(K)-1;
K1=K2=[];
if(type(LL)!=4) LL=[LL];
if(type(LL[0])!=4) LL=[LL];
if(getopt(ex)==1){
for(LT=LL, KT=K; KT!=[]; LT=cdr(LT), KT=cdr(KT)){
L = vweyl(LL[J]);
K1=cons([L[0],car(KT)[0]],K1);
K2=cons([L[1],car(KT)[1]],K2);
}
K2=append(K1,K2);
}else{
for(J = length(K)-1; J >= 0; J--){
L = vweyl(LL[J]);
if(L[0] != K[J][0])
K1 = cons([L[0],K[J][0]],K1);
K2 = cons(K[J][1],K2);
}
P = mulsubst(P, K1);
}
return transpdosub(P,LL,K2);
}
def translpdo(P,LL,M)
{
S=length(LL);
L0=newvect(S);L1=newvect(S);
K=newvect(S);
for(J=0;J<S;J++){
L = vweyl(LL[J]);
L0[J]=L[0];
L1[J]=L[1];
}
K=rmul(M,L0);
for(T=[],J=0;J<S;J++)
T=cons([L0[J],K[J]],T);
P=mulsubst(P,T);
K=rmul(myinv(M),L1);
for(T=[],J=0;J<S;J++)
T=cons([L1[J],K[J]],T);
return mulsubst(P,T);
}
/*
return [R, M, S] : R = M*P - S*Q
deg(R,X) < deg(Q,X)
*/
def rpdiv(P,Q,X)
{
if(P == 0)
return [0,1,0];
DQ = mydeg(Q,X);
CO = mycoef(Q,DQ,X);
S = 0;
while((DP = mydeg(P,X)) >= DQ){
R = mycoef(P,DP,X)/CO;
S = radd(S,R*X^(DP-DQ));
P = radd(P, -R*Q*X^(DP-DQ));
}
Lcm = lcm(dn(S),dn(P));
Gcd = gcd(nm(S),nm(P));
return [red(P*Lcm/Gcd), red(Lcm/Gcd),red(S*Lcm/Gcd)];
}
def mygcd(P,Q,L)
{
if(L == 0){
if(type(P) > 1 || type(Q) > 1 || P <= 0 || Q <= 0
|| dn(P) > 1 || dn(Q) > 1)
return 0;
CPP = CQQ = 1; CQP = CPQ = 0;
P1 = P; Q1 = Q;
/* P1 = CPP*P + CPQ*Q
Q1 = CQP*P + CQQ*Q */
while(Q1 > 0){
Div1 = idiv(P1,Q1); Div2 = irem(P1,Q1);
P1 = Q1 ; Q1 = Div2;
TP = CQP; TQ = CQQ;
CQP = CPP-Div1*CQP;
CQQ = CPQ-Div1*CQQ;
CPP = TP; CPQ = TQ;
}
return [P1, CPP, CPQ, CQP, CQQ];
}
if(type(L) == 2)
L = [0,L];
if(getopt(rev)==1 && L[0]!=0){
R=mygcd(adj(P,L),adj(Q,L),L);
return [adj(R[0],L),adj(R[1],L),adj(R[2],L),adj(R[3],L),adj(R[4],L)];
}
if(type(P) == 3)
P = red(P);
if(type(Q) == 3)
Q = red(Q);
CP=newvect(2,[dn(P),0]); CQ=newvect(2,[0,dn(Q)]);
P = nm(P); Q = nm(Q);
L = vweyl(L);
while(Q != 0){
R = divdo(P,Q,L);
P = Q;
Q = R[1];
/* R[1] = R[2]*P - R[0]*Q
= R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */
{
CT = dupmat(CQ);
CQ = [R[2]*CP[0]-muldo(R[0],CQ[0],L),
R[2]*CP[1]-muldo(R[0],CQ[1],L)];
CP = CT;
}
}
Q = rede(P,L);
R = red(P/Q);
return [Q,red(CP[0]/R),red(CP[1]/R),red(CQ[0]/R),red(CQ[1]/R)];
}
def mylcm(P,Q,L)
{
Rev=(getopt(rev)==1)?1:0;
if(Rev==1){
P=adj(P); Q=adj(Q);
}
R = mygcd(P,Q,L);
S=(type(L)<=2)?R[3]*P:muldo(R[3],P,L);
S = nm(S);
if(type(S) <= 1 && type(L) <= 1){
if(S<0) S = -S;
return S;
}
if(type(L) == 2)
return easierpol(S,L);
S=rede(easierpol(S,L[1]),L);
return (Rev==1)?adj(S):S;
}
def sftpexp(P,LL,F,Q)
{
if(type(LL[0]) < 4)
LL = [LL];
for(KK=[], I=length(LL)-1; I >= 0; I--){
L = vweyl(LL[I]);
R = mydiff(F,L[1]);
KK = cons(Q*R*L[1]/F,KK);
}
return transpdosub(P,LL,KK);
}
def applpdo(P,F,LL)
{
if(type(F)>3)
return mmulbys(applpdo,P,F,[LL]);
L = vweyl(LL[0]);
LL = cdr(LL);
Deg = deg(P,L[1]);
S = F;
for(I = R = 0; I <= Deg ; I++){
if(I > 0)
S = mydiff(S,L[0]);
if(LL == [])
R = radd(R,mycoef(P,I,L[1])*S);
else
R = radd(R,applpdo(mycoef(P,I,L[1]), S, LL));
}
return R;
}
def tranlpdo(P,L,M)
{
N = length(L);
R = size(M);
if(R[0] != N || R[1] != N){
print("Strange size");
return;
}
InvM = M;
if(InvM[1] == 0){
print("Not invertible");
return;
}
XL = newvector(N);
DL = newvector(N);
for(I = 0; I < 0; I++){
R = vweyl(L[I]);
XL[I] = R[0];
DL[I] = R[1];
}
for(I = 0; I < N; I++){
for(J = XX = D0 = 0; J < N; J++){
XX = radd(XX,M[I][J]*XL[J]);
DD = radd(DD, red(InvM[0][I][J]/InvM[1])*DL[J]);
P = mysubst(P,[[XL[I],XX],[DL[I],DD]]);
}
}
return P;
}
def divdo(P,Q,L)
{
L = vweyl(L);
if(getopt(rev)==1){
R=divdo(adj(P,L),adj(Q,L),L);
return [adj(R[0],L),adj(R[1],L),R[2]];
}
X = L[0]; DX = L[1];
S = 0;
M = 1;
I = mydeg(Q,DX);
CQ = mycoef(Q,I,DX);
while((J=mydeg(P,DX)) >= I){
C = mycoef(P,J,DX);
SR = red(C/CQ);
if(dn(SR) != 1){
M *= dn(SR);
P *= dn(SR);
S *= dn(SR);
SR = nm(SR);
}
P -= muldo(SR*(DX)^(J-I),Q,L);
S += SR*(DX)^(J-I);
}
return [S,P,M];
}
def qdo(P,Q,L)
{
L = vweyl(L); DX = L[1]; OD = deg(P,DX);
V = newvect(OD+1);
for(I = 0; I <= OD; I++){
if(I)
Q = muldo(DX,Q,L);
S = divdo(Q,P,L);
V[I] = S[1]*DX-S[2]*zz^I;
}
for(K = [], I = OD; I >= 0; I--)
K = cons(DX^(I+1), K);
R = lsol(V,K);
S = length(R);
for(I = P1 = 0; I < S; I++){
if(type(R[I]) < 4 && mydeg(R[I],DX) == 0 && R[I] != 0
&& (mydeg(R[I],zz) <= mydeg(P,DX)))
P1 = R[I];
else if(type(R[I]) == 4 && R[I][0] == DX)
P2 = R[I][1];
}
T=fctr(P1);
for(I=0, S=length(T), P1=1; I<S; I++){
if(mydeg(T[I][0],zz) > 0)
P1 *= T[I][0]^(T[I][1]);
}
return subst([P1,P2],zz,DX);
}
def sqrtdo(P,L)
{
L = vweyl(L);
P = toeul(P,L,0);
V = -1;
for(R = 0, Ord = mydeg(P,L[1]); Ord >= 0; Ord--){
Q = coef(P,Ord,L[1]);
M = mydeg(Q,L[0]);
N = mymindeg(Q,L[0]);
if(V < 0)
V = M+N;
else if(V != M+N){
print("Cannot be transformed!");
return;
}
Q = tohomog(red(Q/L[0]^N), [L[0]], z_z);
if(irem(Ord,2))
B = x-z_z;
else
B = x+z_z;
Q = substblock(Q,x,B,z_zz);
if(mydeg(Q,x) > 0){
print("Cannot be transformed!");
return;
}
R += mysubst(Q,[z_zz,x])*L[1]^Ord;
}
return fromeul(R,L,0);
}
def ghg(A,B)
{
R = dx;
while(length(B)>0){
R = muldo(x*dx+car(B),R,[x,dx]);
B = cdr(B);
}
T = 1;
while(length(A)>0){
T = muldo(x*dx+car(A),T,[x,dx]);
A = cdr(A);
}
return R-T;
}
def ev4s(A,B,C,S,T)
{
R4 = x^2*(x-1)^2;
R3 = x*(x-1)*((2*A-2*B-8)*x-2*A+5);
R2 = (-3/2*(A^2+B^2)+3*A*B+9*A-9*B-29/2+1/4*(S^2+T^2))*x^2
+(5*A^2/2-13*A-3*A*B+B^2/2+7*B-C^2+C+35/2 - 1/4*(S^2+T^2))*x
- (2*A+2*C-5)*(2*A-2*C-3)/4;
R1 = 1/4*(A-B-2)*(2*A^2-4*A*B-8*A+2*B^2+8*B+10-S^2-T^2)*x
+15/4+3*B^2/4-C^2/2+11*A^2/4 - 11*A/2+3*B+B*C-7*A*B/2+C/2-A*B^2/2
#if 1
+ A^2*B
#endif
- B*C^2 - A^3/2+(2*A-3)*(S^2+T^2)/8;
/* OK? for the above term added */
R0 = -(A-B-1-S)*(A-B-1+S)*(A-B-1-T)*(A-B-1+T)/16;
return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
}
def b2e(A,B,C,S,T)
{
R4 = x^2*(x-1)^2;
R3 = x*(x-1)*(2*x-1)*(2*c-5);
R2 = (-6*C^2+24*C-25+1/2*S^2+1/2*T^2)*x^2
+(6*C^2-24*C+25-1/2*S^2-1/2*T^2-A^2+B^2+A-B)*x
+A^2-C^2-A+4*C-15/4;
R1 = (2*C-3)*(2*C^2-6*C+5-1/2*S^2-1/2*T^2)*x
+(2*C-3)*(-C^2+3*C+1/2*A^2-1/2*B^2+1/2*B-1/2*A-5/2+1/4*S^2+1/4*T^2);
R0 = -(2-2*C+S+T)*(2-2*C-S-T)*(2-2*C+S-T)*(2-2*C-S+T)/16;
return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
}
/*
T^m = T(T-1)....(T-m+1)
f(t) -> g(t)
f(t) = a_mt^m + ... + a_1t+a_0
g(x*dx) = a_m*x^m*dx^m + ... + a_1*x*dx+a_0
ret: x(x-1)...(x-i+1)
*/
def sftpow(X,I)
{
R = 1;
for(J=0; J<I;J++)
R *= X-J;
return(R);
}
/*
ret: x(x+K)(x+2*k)...(x+(i-1)*k)
*/
def sftpowext(X,I,K)
{
R = 1;
for(J=0; J<I;J++)
R *= X+K*J;
return(R);
}
def polinsft(F,A)
{
R = 0;
while(F != 0){
D = mydeg(F,A);
C = mycoef(F,D,A);
R += C*A^D;
F -= C*sftpow(A,D);
}
return R;
}
def pol2sft(F,A)
{
S=getopt(sft);
if(type(S)<0 || type(S)>2) S=1;
R = 0;
for(I = mydeg(F,A); I >= 0; I--)
R = R*(A-I*S) + mycoef(F,I,A);
return R;
}
def binom(P,N)
{
if(type(N)!=1 || N<0) return 1;
for(S=1;N>0;N--,P-=1) S*=P/N;
return red(S);
}
def expower(P,R,N)
{
if(type(N)!=1 || N<0) return 0;
for(S=S0=K=1;K<=N;K++,R-=1){
S0*=P*R/K;S+=S0;
}
return red(S);
}
def seriesHG(A,B,X,N)
{
if(type(N)!=1 || N<0) return 0;
for(K=0,S=S0=1;K<N;K++){
for(T=A; T!=[]; T=cdr(T)) S0*=car(T)+K;
for(T=B; T!=[]; T=cdr(T)) S0/=car(T)+K;
S0=red(S0*X/(K+1));
DN=dn(S0);
S=red((red(S*DN)+nm(S0))/DN);
}
}
def toeul(F,L,V)
{
L = vweyl(L);
X = L[0]; DX = L[1];
I = mydeg(F,DX);
if(V == "infty"){
for(II=I; II>=0; II--){
J = mydeg(P=mycoef(F,I,DX),X);
if(II==I) S=II-J;
else if(P!=0 && II-J>S) S=II-J;
}
F *= X^S;
R = 0;
for( ; I >= 0; I--)
R += red((mysubst(mycoef(F,I,DX),[X,1/X])*(x*DX)^I));
return(subst(pol2sft(R,DX),DX,-DX));
}
F = subst(F,X,X+V);
for(II=I; II>=0; II--){
J = mymindeg(P=mycoef(F,II,DX),X);
if(II==I) S=II-J;
else if(P!=0 && II-J>S) S=II-J;
}
F *= X^S;
R = 0;
for( ; I >= 0; I--)
R += (red(mycoef(F,I,DX)/X^I))*DX^I;
return pol2sft(R,DX);
}
/*
def topoldif(P,F,L)
{
L = vweyl(L);
P = nm(red(P));
while(deg(P,L[1]) > 0){
R = coef(P,0,L[0]);
Q = red((P-R)/(F*L[0]);
P = nm(Q)*zz+F*R*dn(Q);
}
}
*/
def fromeul(P,L,V)
{
if(P == 0)
return 0;
L = vweyl(L);
X = L[0]; DX = L[1];
I = mydeg(P,DX);
if(V == "infty"){
P = subst(P,DX,-DX);
J = mydeg(P,X);
P = red(mysubst(P,[X,1/X])*X^J);
}
R = mycoef(P,0,DX);
S = 1;
for(S = J = 1; J <= I; J++){
S = DX*(S*X + mydiff(S,DX));
R += mycoef(P,J,DX)*S;
}
while(mycoef(R,0,X) == 0)
R = tdiv(R,X);
if(V != "infty" && V != 0)
R = mysubst(R,[X,X-V]);
return R;
}
def sftexp(P,L,V,N)
{
L = vweyl(L); DX = L[1];
P = mysubst(toeul(P,L,V),[DX,DX+N]);
return fromeul(P,L,V);
}
def fractrans(P,L,N0,N1,N2)
{
L = vweyl(L);
if(N2 != "infty"){
if(N0 == "infty")
N0 = 0;
else
N0 = red(1/(N0-N2));
if(N1 == "infty")
N1 = 0;
else
N1 = red(1/(N1-N2));
P = mysubst(P,[L[0],L[0]+N2]);
P = fromeul(toeul(P,L,"infty"),L,0);
}
if(N0 != 0){
P = mysubst(P,[L[0],L[0]+N0]);
N1 -= N0;
}
if(N1 != 1)
P = mysubst(P,[[L[0],L[0]/N1],[L[1],L[1]*N1]]);
return P;
}
def soldif(P,L,V,Q,N)
{
L = vweyl(L); X = L[0]; DX = L[1];
P = mysubst(toeul(P,L,V),[DX,DX+Q]);
DEG = mydeg(P,X);
P0 = newvect(DEG+1);
for(I = 0; I <= DEG; I++)
P0[I] = coef(P,I,X);
if(P0[0] == 0)
return 0;
if(subst(P0[0],DX,0) != 0){
mycat([Q,"is not the exponent at", V])$
return 0;
}
R = newvect(N+1);
R[0] = 1;
for(I = 1; I <= N; I++){
for(S = 0, K = 1; K <= DEG && K <= I; K++)
S += mysubst(P0[K],[DX,I-K])*R[I-K];
S = red(S);
M = mysubst(P0[0],[DX,I]);
if(M != 0){
R[I] = -red(S/M);
if(R1 != 0){
for(S = 0, K = 1; K <= DEG && K <= I; K++)
S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
mysubst(P1[K],[DX,I-K])*R[I-K];
R1[I] = -red(S/M);
}
}else{
if(S == 0){
if(R1 != 0){
for(S = 0, K = 1; K <= DEG && K <= I; K++)
S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
mysubst(P1[K],[DX,I-K])*R[I-K];
}
if(S == 0)
continue;
}
R1 = newvect(N+1);
for(K = 0; K < I; K++){
R1[K] = R[K];
R[K] = 0;
}
R1[I] = 0;
P1 = newvect(DEG);
for(K = 0; K <= DEG; K++)
P1[K] = mydiff(P0[K], DX);
M = mysubst(P1[0],[DX,I]);
if(M == 0){
cat(["multiple log at ", I])$
return 0;
}
R[I] = -red(S/M);
}
}
if(R1 != 0)
return [R1, R];
else
return R;
}
def chkexp(P,L,V,Q,N)
{
L = vweyl(L); X = L[0]; DX = L[1];
P = mysubst(toeul(P,L,V),[DX,DX+Q]);
P = fromeul(P,L,0);
D = mydeg(P,DX);
Z = mindeg(mycoef(P,D,DX), X) - (D-N);
R = [];
for(I = 0; I < Z; I++){
S = mycoef(P,I,X);
if(S != 0){
for(J = mydeg(S,DX); J >= 0; J--){
T = mycoef(S,J,DX);
if(T != 0)
R = cons(T,R);
}
}
}
return R;
}
def getroot(F,X)
{
S=[];
M=getopt(mult);
if(type(F) == 3)
F = nm(red(F));
for(R = fctr(F); length(R)>0; R = cdr(R)){
T=car(R);
P=car(T);
I=car(cdr(T));
if(mydeg(P,X)>0){
if(mydeg(P,X)==1){
C = mycoef(P,1,X);
P = X - red(P/C);
}
if(M==1){
S=cons([I,P],S);
}else{
for( ; I>0; I--)
S=cons(P,S);
}
}
}
if(M==1) S=reverse(qsort(S));
return S;
}
def expat(F,L,V)
{
L = vweyl(L);
if(V == "?"){
Ans = [];
F = nm(red(F));
S = fromeul(toeul(F,L,"infty"),L,0);
S = mycoef(S,mydeg(S,L[1]),L[1]);
if(mydeg(S,L[0]) > 0)
Ans = cons(["infty", expat(F,L,"infty")],Ans);
S = mycoef(F,mydeg(F,L[1]), L[1]);
R = getroot(S,L[0]);
for(I = 0; I < length(R); I++){
if(I > 0 && R[I-1] == R[I])
continue;
if(mydeg(R[I], L[0]) <= 0)
Ans = cons([R[I], expat(F,L,R[I])], Ans);
else
Ans = cons([R[I]], Ans);
}
return Ans;
}
return getroot(subst(toeul(F,L,V),L[0],0),L[1]);
}
def polbyroot(P,X)
{
R = 1;
while(length(P)){
R *= X-car(P);
if(type(R)>2) R = red(R);
P = cdr(P);
}
return R;
}
def polbyvalue(P,X)
{
R = 1; S = 0;
while(length(P)){
T = car(P);
V0 = T[1] - mysubst(S,[X,T[0]]);
if(V0 != 0){
if(type(R) > 2) R = red(R);
V1 = mysubst(R,[X,T[0]]);
if(V1 == 0){
erno(0);
return 0;
}
S += (V0/V1)*R;
if(type(S) > 2) S = red(S);
}
R *= X - T[0];
P = cdr(P);
}
return S;
}
def pcoef(P,L,Q)
{
if(L==0)
return 1;
Coef=TP=0;
if(type(Q)>=4){
TP=1;
V=Q[0];
if(type(V)==4)
V=ltov(V);
else V=dupmat(V);
N=length(V);
if(type(Q[1])==5) MR=dupmat(Q[1]);
else{
MR=newvect(N);
for(K=Q[1], I=0; I< N; I++){
MR[I] = car(K);
K = cdr(K);
}
}
}else{
V=ltov(vars(P));
N=length(V);
MR=newvect(N);
for(I=0;I<N;I++){
MR[I]=mydeg(Q,V[I]);
Q=mycoef(Q,MR[I],V[I]);
}
if(type(Q)>1) return 0;
}
/* mycat([V,MR]); */
if(L==1){
for(I=0;I<N;I++)
P=mycoef(P,MR[I],V[I]);
return P;
}
for(I=1;I<N;I++){ /* sorted by required degrees */
for(K1=MR[I],K2=V[I],J=I-1; J>=0 && MR[J]<K1; J--);
for(II=I-1;II>J;II--){
MR[II+1]=MR[II];V[II+1]=V[II];
}
MR[II+1]=K1;V[II+1]=K2;
}
for(NN=N; N>0 && MR[N-1]==0; N--);
Mon=[];Coe=[];Q=P;
while(Q!=0){
M=newvect(N);
for(R=Q,F=I=0,MT=1;I<NN;I++){
K=mydeg(R,V[I]);
R=mycoef(R,K,V[I]);
if(I<N) M[I]=K;
if(K>0) MT*=V[I]^K;
if(K>MR[I]) F=1;
}
Q -= R*MT;
if(F==0){
Mon=cons(M,Mon);
Coe=cons(R,Coe);
}
}
Mon=ltov(reverse(Mon));
Coe=ltov(reverse(Coe));
Len=length(Mon);
S=newvect(Len);
for(JL=0; JL<Len;JL++){
if(L*Mon[JL][0]<MR[0]) break;
}
S[0]=L;
K0=Mon[0][0];
K=L*K0-MR[0];
for(I=II=0;II<Len && K>=0;II++){
if((K1=K0-Mon[0][II])>0){
while(K>K1 && S[I]>0){
S[I]--;S[II]++;
K-=K1;
I=II;
K0=Mon[0][II];
}
}else break;
}
I=0;
while(1){
for(T=T0=J=JP=0; J<Len; J++){
if(S[J]!=0){
if(T0==0 && J>=JL) return Coef;
JP=J;T0=1;
T+=S[J]*Mon[J][I];
}
}
if(T==MR[I]){
if(++I<N) continue;
for(TT=1,J=1; J<=L; J++) /* find a solution */
TT*=J;
for(J=0;J<Len;J++){
if(S[J]!=0){
TT*=Coe[J]^S[J];
for(II=S[J]; II>1; II--)
TT/=II;
}
}
Coef+=TT;
if(TP==1 && type(Coef)==3) Coef=red(Coef);
if(JP<Len-2 && S[JP]>1){
S[JP]-=2;S[JP+1]++;S[JP+2]++;
}else{
for(JT=JP-1;JT>=0&&S[JT]==0;JT--);
if(JT<0) break;
if(JT==JP-1){
S[JT]--;
if(JP<Len-1)
S[JP+1]++;
else
S[JP]++;
}else{
S[JT]--;
S[JT+1]+=S[JP]+1;
S[JP]=0;
}
}
I=0;
continue;
}
if(JP<Len-1){
for(JP1=JP+1;JP1<Len-1;JP1++){
if(Mon[JP1][I]!=Mon[JP][I]) break;
}
if(I>0 && Mon[JP1][0] < Mon[JP][0]){
S[JP]--;S[Len-1]++;JP=JP-1;
}else{
S[JP]--;
if(JP1<Len){
S[JP1]++;
}else{
S[JP1-1]++;
}
}
}
if(JP==Len-1){
for(JT=JP-1;JT>=0 && S[JT]==0;JT--);
if(JT<0) break;
S[JT]--;
if(JT==JP-1){
S[JP]++;
}else{
S[JT+1]+=S[JP]+1;
S[JP]=0;
}
}
I=0;
}
return Coef;
}
def prehombf(P,Q)
{
if((Mem=getopt(mem))!=1 && Mem!=-1)
return prehombfold(P,Q);
/* CT=0; */
if(Q==0) Q=P;
V=ltov(vars(P));
N=length(V);
for(I=1;I<N;I++){ /* sorted by required degrees */
for(K=mydeg(P,V[I]),K1=V[I],J=I-1; J>=0 && mydeg(P,V[J])<K; J--);
for(II=I-1;II>J;II--) V[II+1]=V[II];
V[II+1]=K1;
}
S=newvect(N);T=newvect(N);U=newvect(N);
for(R=P,M=1,Deg=I=0;I<N;I++){ /* extreme vector */
Deg+=(S[I]=mydeg(R,V[I]));
R=mycoef(R,S[I],V[I]);
}
DR=[[-1,0]];
if((R1=N/Deg)!=1){
DR=cons([-R1,0],DR);
Sft=1;
}else Sft=0;
if(Deg%2==0) Sg=1;
else Sg=-1;
for(I=0,R=R2=1,QQ=Q; 2*I+Sft < Deg; I++){
if(Mem==-1){
print(I+1,0);print("/",0);print(idiv(Deg-Sft+1,2),0);print(" ",2);
}
Coef=0;
Q=QQ;
while(Q!=0){
for(R=Q,J=0,RR=1;J<N;J++){
T[J]=mydeg(R,V[J]);
R=mycoef(R,T[J],V[J]);
if(T[J]>0) RR*=V[J]^T[J];
}
Q-=R*RR;
for(J=0,CC=R;J<N;J++){
U[J]=I*S[J]+T[J];
for(II=0; II<T[J]; II++)
CC*=(U[J]-II);
}
/* mycat([I+1,U,CC]); */
CC*=pcoef(P,I+1,[V,U]);
if(Mem==-1) print("*",2);
/* mycat([++CT]); */
Coef+=CC;
}
DR=cons([I,Coef],DR);
DR=cons([-R1-1-I,Sg*Coef],DR);
if(Mem==-1) print("");
}
/* mycat([DR]); */
P = polbyvalue(DR,s);
return fctr(P);
}
def prehombfold(P,Q)
{
V = vars(P);
if(Q==0) Q=P;
for(Deg=0, R=P, V1=V, DD=[]; V1!=[]; V1=cdr(V1)){
VT = car(V1);
D = mydeg(R,VT);
R = mycoef(R,D,VT);
Deg += D;
X = makev(["d",VT]);
Q = subst(Q,VT,X);
DD=cons([VT,X],DD);
}
DR=[[-1,0]];
NV=length(V);
if((R1=NV/Deg)!=1){
DR=cons([-R1,0],DR);
Sft=1;
}else
Sft=0;
if(Deg%2==0)
Sg=1;
else Sg=-1;
for(I = 0, R=R2=1; 2*I+Sft < Deg; I++){
R = R2;
R2 = R*P;
S = appldo(Q,R2,DD);
QQ = sdiv(S,R);
DR=cons([I,QQ],DR);
DR=cons([-R1-1-I,Sg*QQ],DR);
}
/* mycat([DR]); */
P = polbyvalue(DR,s);
return fctr(P);
}
def sub3e(P0,P1,P2,N0,N1,N)
{
R = x^N0*(x-1)^N1*dx^N;
for(V = I = 1, J = 1; I <= N; I++){
S = 0;
M = N-I;
if(I <= N0){
T = mycoef(P0,N0-I,x);
S += T;
R += T*x^(N0-I)*(x-1)^N1*dx^M;
K1 = N0-I+1;
}else
K1 = 0;
if(I <= N1){
T = mycoef(P1,N1-I,x);
S += T;
R += T*x^N0*(x-1)^(N1-I)*dx^M;
K2 = N0-1;
}else
K2 = N-I;
for(K = K1; K <= K2; K++){
if(K == K2){
R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(M-K)*dx^M;
continue;
}
R += strtov("r"+rtostr(V))*x^K*(x-1)^(M-K)*dx^M;
S += strtov("r"+rtostr(V++));
}
}
if(V > 1)
mycat([V-1, "accessory parameters: r1,r2,..."]);
return R;
}
def fuchs3e(P,Q,R)
{
S = N = N1 = N2 = 0;
V = -1;
#if 0
L = newvect(3,[[],[],[]]);
N = newvect(3,[0,0,0]);
for(I = 2; I >= 0; I--){
if(I == 2)
U = R;
else if(I == 1)
U = Q;
else
U = P;
for( ; length(U); U = cdr(U)){
T = car(U);
if( T == "?"){
if(V < 0)
V = I;
else
return 0;
}else{
if(I == 2)
L[I] = cons(-T, L[I]);
else
L[I] = cons(T, L[I]);
S += T;
}
N[I]++;
}
}
if(N[0]!= N[2] || N[1] != N[2]){
print("Number of exponents are wrong",0);
return -1;
}
S -= N[2]*(N[2]-1)/2;
if(V < 0){
if(S != 0){
mycat(["Viorate Fuchs relation ->",S]);
return -2;
}
}else{
if(V != 2)
S = -S;
L[V] = cons(S, L[V]);
}
for(I = 0; I <= 2; I++)
L[I] = polinsft(polbyroot(L[I],x),x);
return sub3e(L[0],L[1],L[2],N[0],N[1],N[2]);
#else
L0 = [];
L1 = [];
L2 = [];
while(T = car(R), R = cdr(R), R != []){
if( T == "?"){
if(V < 0)
V = 2;
else
return 0;
}else{
L2 = cons(-T, L2);
S += T;
}
N++;
}
while(T = car(P), P = cdr(P), P != []){
if( T == "?"){
if(V < 0)
V = 0;
else
return 0;
}else{
L0 = cons(T, L0);
S += T;
}
N1++;
}
while(T = car(Q), Q = cdr(Q), Q != []){
if( T == "?"){
if(V < 0)
V = 1;
else
return 0;
}else{
L1 = cons(T, L1);
S += T;
}
N2++;
}
if(N0 != N || N1 != N){
print("Number of exponents are wrong!",0);
return -1;
}
S -= N*(N-1)/2;
if(V < 0){
if(S != 0){
mycat(["Viorate Fuchs relation!",S]);
return -2;
}else if(V == 0)
L0 = cons(-S, L0);
else if(V == 1)
L1 = cons(-S, L1);
else
L2 = cons(S, L2);
P0 = pol2sft(polbyroot(L0,x),x);
P1 = pol2sft(polbyroot(L1,x),x);
P2 = pol2sft(polbyroot(L2,x),x);
R = x^N*(x-1)^N*dx^N;
for(V = I = 1, J = 1; I <= N; I++){
S = T = mycoef(P0,N0-I,x);
R += T*x^(N-I)*(x-1)^N*dx^(N-I);
K1 = N-I+1;
T = mycoef(P1,N1-I,x);
S += T;
R += T*x^N*(x-1)^(N-I)*dx^(N-I);
K2 = N-1;
for(S = 0, K = N-I+1; K < N; K++){
if(K == N-1)
R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(2*N-K-I)*dx^(N-I);
continue;
}
R += strtov("r"+rtostr(V))*x^K*(x-1)^(2*N-K-I)*dx^(N-I);
S += strtov("r"+rtostr(V++));
}
}
if(V > 1)
mycat([V-1, "accessory parameters: r1,r2,..."]);
return R;
#endif
}
def okubo3e(P,Q,R)
{
S = 0;
V = -1;
L = newvect(3,[[],[],[]]);
N = newvect(3,[0,0,0]);
if(type(R) < 4){
I = -1;
V = 3;
}else{
I = 2;
V = -1;
}
for( ; I >= 0; I--){
if(I == 2)
U = R;
else if(I == 1)
U = Q;
else
U = P;
for( ; length(U); U = cdr(U)){
T = car(U);
if( T == "?"){
if(V < 0)
V = I;
else
return 0;
}else{
if(I == 2)
L[I] = cons(-T, L[I]);
else
L[I] = cons(T, L[I]);
S += T;
}
N[I]++;
}
}
if(V == 3){
N[2] = N[0] + N[1];
P2 = x^N;
for(I = 1; I <= N; I++)
P2 += makev([R,I])*x^(N-I);
}else{
if(N[0]+N[1] != N[2]){
print("Number of exponents are wrong",0);
return -1;
}
S -= N[0]*N[1];
if(V < 0){
if(S != 0){
mycat(["Viorate Fuchs relation ->",S]);
return -2;
}
}else{
if(V != 2)
S = -S;
L[V] = cons(S, L[V]);
}
P2 = polinsft(polbyroot(L[2],x),x);
}
P0 = polinsft(mysubst(polbyroot(L[0],x),[x,x+N[1]]),x);
P1 = polinsft(mysubst(polbyroot(L[1],x),[x,x+N[0]]),x);
return sub3e(P0,P1,P2,N[0],N[1],N[2]);
}
/* N = 2*M (N-M = M) or 2*M+1 (N-M = M+1)
0 : 0 1 ..... M-1 B B+1 ... B+N-M-2 A
1 : C C+1 ... C+M-1 0 1 .... N-M-2 N-M-1
*/
def eosub(A,B,C,N)
{
M = N%2;
P = [];
Q = [];
P = cons(A,P);
for(I = 0; I < N-M-1; I++)
P = cons(B+I,P);
for(I = 0; I < M; I++)
Q = cons(C+I,Q);
P = okubo3e(P,Q,s);
C = newvect(2);
L = newvect(2);
C[1] = chkexp(P,[x,dx],0,b,N-M-1);
C[0] = chkexp(P,[x,dx],1,c,M);
for(LL = K = 0; K < 2; K++){
L[K] = length(C[K]);
C[K] = ltov(C[K]);
if(L[K] > LL)
LL = L[K];
}
JJ = 0;
for(I = 1; Do; I++){
Do = 0;
S = makev(["r",I]);
for(J = JJ; J < LL; J++){
JJ = LL;
for(K = 0; K < 2; K++){
if(J >= L[K] || C[K][J] == 0)
continue;
if(J < JJ)
JJ = J;
if(Do == 1){
CC = C[K];
CC[J] = mysubst(CC[J], [S, Var]);
continue;
}
if(mydeg(C[K][J]) >= 1){
if(mydeg(C[K][J]) > 1){
print("Internal error");
return;
}
Var = getroot(C[K][J],S);
Var = Var[0];
CC = C[K];
CC[J] = 0;
P = mysubst(P, [S, Var]);
Do = 1;
J = JJ - 1;
K++;
}
}
}
}
if(JJ != L){
print("Internal error (non Rigid)");
return;
}
return P;
}
def even4e(X,Y){
if(length(X) != 4 || length(Y) != 2){
print("Usage: even4e([a,b,c,d],[e,f])");
print("0: 0 1 e f");
print("1; 0 1 * *+1");
print("infty: a b c d");
return;
}
S = -3;
for(I = 0; I < 4; I++){
S += X[I];
if(I < 2)
S += Y[I];
}
S = -S/2;
P = okubo3e(Y,[S,"?"],X);
T = chkexp(P,x,1,S,2);
T = getroot(T[0],r1);
return mysubst(P,[r1,T[0]]);
}
def odd5e(X,Y)
{
if(length(X) != 5 || length(Y) != 2){
print("Usage: spec6e([a,b,c,d,e],[f,g])");
print("0: 0 1 f g g+1");
print("1: 0 1 2 * *+1");
print("infty: a b c d e");
return;
}
S = -4;
for(I = 0; I < 5; I++){
S += X[I];
if(I < 2)
S += Y[I];
}
S = -(S + Y[1])/2;
P = okubo3e([Y[0],Y[1],Y[1]+1],[S,"?"],X);
T = chkexp(P,x,1,S,2);
T = getroot(T[0],r1);
P = mysubst(P,[r1,T[0]]);
T = chkexp(P,x,0,Y[1],2);
T = getroot(T[0],r2);
return mysubst(P,[r2,T[0]]);
}
def extra6e(X,Y)
{
if(length(X) != 6 || length(Y) != 2){
print("Usage: extra6e([a,b,c,d,e,f],[g,h])");
print("0: 0 1 g g+1 h h+1");
print("1: 0 1 2 3 * *+1");
print("infty: a b c d e f");
return;
}
S = -5;
for(I = 0; I < 6; I++){
S += X[I];
if(I < 2)
S += 2*Y[I];
}
S = -S/2;
P = okubo3e([Y[0],Y[0]+1,Y[1],Y[1]+1],[S,"?"],X);
T = chkexp(P,x,1,S,2);
T = getroot(T[0],r1);
P = mysubst(P,[r1,T[0]]);
T = chkexp(P,x,0,Y[0],2);
T = getroot(T[0],r3);
P = mysubst(P,[r3,T[0]]);
T = chkexp(P,x,0,Y[1],2);
T = getroot(T[0],r2);
return mysubst(P,[r2,T[0]]);
}
def rigid211(X,Y,Z)
{
if(length(X) != 2 || length(Y) != 2 || length(Z) != 2){
print("Usage: rigid211([a,b],[c,d],[e,f])");
print("0: 0 1 a b");
print("1: 0 1 c d");
print("infty: e e+1 f *");
return;
}
P = okubo3e(X,Y,[Z[0],Z[0]+1,Z[1],"?"]);
T = chkexp(P,x,"infty",Z[0],2);
T = getroot(T[0],r1);
return mysubst(P,[r1,T[0]]);
}
def solpokuboe(P,L,N)
{
if(type(N) > 1 || ntype(N) != 0 || dn(N) != 1){
mycat(["Irrigal argument :", N]);
return 0;
}
L = vweyl(L);
DD=N+1;
for(U = S = L[0]^N; U != 0; ){
D = mydeg(U,L[0]);
if(D>=DD){
mycat(["Internal Error",D,DD]);
return -1;
}
DD=D;
UU = L[0]^D;
R = appldo(P,UU,L);
if(mydeg(R,L[0]) > D){
printf("Bad operator\n");
return 0;
}
CC = mycoef(R,D,L[0]);
if(D == N){
P -= (E = CC);
U = R-E*U;
continue;
}
if(CC == 0){
printf("No polynomial\n");
return 0;
}
CC= mycoef(U,D,L[0])/CC;
S = red(S - UU*CC);
U = red(U - R*CC);
}
return [nm(S),E];
}
def stoe(M,L,N)
{
L = vweyl(L);
Size = size(M);
S = Size[0];
NN = 0;
if(type(N) == 4){
NN=N[0]; N=N[1];
}else if(N < 0){
NN=-N; N=0;
}
if(S != Size[1] || N >= S || NN >= S)
return;
D = newmat(S+1,S+1);
MN = dupmat(M);
MD = newmat(S,S);
DD = D[0];
DD[N] = 1; DD[S] = 1;
for(Lcm = I = 1; ; ){
DD = D[I];
MM = MN[N];
for(J = 0; J < S; J++){
DD[J] = MM[J];
Lcm = lcm(dn(DD[J]),Lcm);
}
DD[S] = L[1]^I;
for(J = 0; J <= S; J++)
DD[J] = red(DD[J]*Lcm);
if(I++ >= S)
break;
if(I==S && NN>0){
DD = D[I];
DD[0]=-z_zz; DD[NN]=1;
break;
}
Mm = dupmat(MN*M);
for(J = 0; J < S; J++){
for(K = 0; K < S; K++)
MN[J][K] = red(diff(MN[J][K],L[0])+Mm[J][K]);
}
}
#if 0
P = fctr(mydet2(D));
#else
P = fctr(det(D));
#endif
for(I = R = 1; I < length(P); I++){
if(mydeg(P[I][0],L[1]) > 0)
R *= P[I][0]^P[I][1];
}
if(NN > 0)
R = -red(coef(R,0,z_zz)/coef(R,1,z_zz));
return R;
}
def dform(L,X)
{
if(type(X)==2) X=[X];
if(type(L[0])!=4) L=[L];
if(type(X)==4) X=ltov(X);
M=length(X);
if(length(car(L))==2){
R=newvect(M);
for(LL=L; LL!=[]; LL=cdr(LL)){
for(I=0; I<M; I++){
RT=rmul(car(LL)[0],mydiff(car(LL)[1],X[I]));
R[I] = (R[I]==0)?RT:radd(R[I],RT);
}
}
Dif=getopt(dif);
for(RR=[], I=M-1; I>=0; I--){
if(Dif==1) RR=cons([1,R[I],X[I]],RR);
else RR=cons([R[I],X[I]],RR);
}
if(Dif==1) RR=dform(RR,X);
return RR;
}else if(length(car(L))!=3) return L;
N=M*(M-1)/2;
R=newvect(N);
S=newvect(N);
for(LL=L; LL!=[]; LL=cdr(LL)){
for(I=K=0; I<M; I++){
for(J=I+1; J<M; J++, K++){
if(LL==L) S[K]=[X[I],X[J]];
LT=car(LL);
R1=mydiff(LT[2],X[J]);
R2=mydiff(-LT[2],X[I]);
if(R2==0){
if(R1==0) continue;
R1=rmul(mydiff(LT[1],X[I]),R1);
}else if(R1==0){
R1=rmul(mydiff(LT[1],X[J]),R2);
}else
R1=rmul(mydiff(LT[1],X[I]),R1)+rmul(mydiff(LT[1],X[J]),R2);
R1=rmul(LT[0],R1);
R[K] = (R[K]==0)?R1:radd(R[K],R1);
}
}
}
for(RR=[],I=N-1; I>=0; I--)
RR=cons([R[I],S[I][0],S[I][1]],RR);
return RR;
}
def polinvsym(P,Q,Sym)
{
N = length(Q);
T = polbyroot(Q,zz);
for(I = 1; I <= N; I++){
P = mysubst(P,[makev([Sym,I]), (-1)^I*coef(T,N-I,zz)]);
}
return P;
}
def polinsym(P,Q,Sym)
{
if(type(P) == 3){
P = red(P);
if(type(P) == 3){
D = polinsym(dn(P),Q,Sym);
if(D == 0)
return 0;
return polinsym(nm(P),Q,Sym)/D;
}
}
N = length(Q);
V = newvect(N+1);
S = newvect(N+1);
E = newvect(N+1);
E0 = newvect(N+1);
T = polbyroot(Q,zzz);
for(J = 1; J <= N; J++){
K = coef(T,N-J,zzz);
if(J % 2)
K = -K;
S[J] = K;
V[J] = makev([Sym,J]);
}
K = deg(P,Q[0]);
for(J = 0; J <= N; J++)
E0[J] = K+1;
E[0] = K+1;
while(deg(P,Q[0]) > 0){
for(P0 = P, J = 1; J <= N; J++){
E[J] = deg(P0,Q[J-1]);
P0 = coef(P0,E[J],Q[J-1]);
}
/* P0*Q[0]^E[1]*Q[1]^E[2]*... E[1] >= E[2} >= ... */
for(J = 1; J <= N; J++){
if(E[J] < E0[J])
break;
if(E[J-1] < E[J])
J = N;
}
if(J > N){
print("Not symmetric");
return 0;
}
for(J = 1; J <= N; J++)
E0[J] = E[J];
for(J = N; J > 1; J--){
if(E[J] != 0)
for(K = 1; K < J; K++)
E[K] -= E[J];
}
for(R0 = P0, K = 1; K <= N; K++){
if(E[K] > 0)
P0 *= S[K]^E[K];
R0 *= V[K]^E[K];
}
P += R0 - P0;
}
return P;
}
def tohomog(P,L,V)
{
while(length(L)>0){
P = mysubst(P,[car(L),car(L)/V]);
L = cdr(L);
}
P = red(P);
N = mindeg(dn(P),V);
if(N > 0)
P = red(P*V^N);
N = mindeg(dn(P),V);
if(N > 0)
P = red(P/(V^N));
return P;
}
def substblock(P,X,Q,Y)
{
P = red(P);
if(deg(dn(P),X) > 0)
return substblock(nm(P),X,Q,Y)/substblock(dn(P),X,Q,Y);
N = mydeg(Q,X);
if(N < 1)
return P;
R = mycoef(Q,N,X);
while(M = mydeg(P,X), M >= N)
P = red(P - mycoef(P,M,X)*(Q-Y)*X^(M-N)/R);
return P;
}
def okuboetos(P,L)
{
L = vweyl(L); X = L[0]; DX = L[1];
N = mydeg(P,DX);
C = mycoef(P,N,DX);
K = mydeg(C,X);
if(K > N){
print("Irregular singularity at infinity")$
return 0;
}
if(N > K)
P *= x^(N-K);
L = getroot(mycoef(P,N,DX),x);
L = ltov(reverse(L));
if(length(L) != N || N == 0){
print("Cannot get exponents")$
return 0;
}
if( type(LL = getopt(diag)) == 4 ){
LL = ltov(LL);
if(length(LL) != N){
mycat(["Length of the option should be", N]);
return 0;
}
Tmp = newvect(N);
for(I = N-1; I >= 0; I--){
for(LLT = LL[I], J = N-1; J >=0 ; J--){
if(LLT == L[J] && Tmp[J] == 0){
Tmp[J] = 1;
break;
}
}
if(J < 0){
print("option is wrong");
return 0;
}
}
L = LL;
}
P /= mycoef(C,N,X);
A = newmat(N,N);
AT = newmat(N+1,N+1);
Phi= newvect(N+1);
Phi[0] = 1;
for(J = 0; J < N; J++)
Phi[J+1] = Phi[J]*(X-L[J]);
for(ATT = AT[N], J = 0; J < N; J++)
ATT[J] = mycoef(P,J,DX);
for(K = 1; K <= N; K++){
for(J = N; J >= K; J--){
Aj = A[J-1];
SIG = AT[J][J-K];
for(I = 0; I <= K-2; I++)
SIG += Aj[J-I-1]*AT[J-I-1][J-K];
if(K == 1)
DAT = mydiff(Phi[J-1],X);
else
DAT = mydiff(AT[J-1][J-K],X);
Aj[J-K] = -SIG+(X-L[J-1])*DAT;
Aj[J-K] /= Phi[J-K];
Aj[J-K] = mysubst(Aj[J-K],[X,L[J-1]]);
if(J < K+1) continue;
ATj = AT[J-1];
ATj[J-K-1] = SIG+Aj[J-K]*Phi[J-K];
ATj[J-K-1] /= (X - L[J-1]);
ATj[J-K-1] = red(ATj[J-K-1]-DAT);
}
}
ATT = newmat(N,N);
for(J = 0; J < N; J++){
for(K = 0; K < N; K++){
ATj = ATT[J];
ATj[K] = AT[J][K];
}
ATj[J] = Phi[J];
if(J < N-1){
ATj = A[J];
ATj[J+1] = 1;
}
}
return [L,A,ATT];
}
def heun(X,P,R)
{
if(type(X) != 4 || length(X) != 5){
print("Usage: huen([a,b,c,d,e],p,r)");
print("0: 0 c");
print("1: 0 d");
print("p: 0 e");
print("infty: a b");
print("Fuchs relation: a+b+1 = c+d+e");
return;
}
S = 1;
V = -1;
X = ltov(X);
for(I = 0; I < 5; I++){
if(X[I] == "?"){
if(V >= 0)
return;
V = I;
}else if(I < 2){
S += X[I];
}else
S -= X[I];
}
if(V >= 0){
if(V < 2)
X[V] = -S;
else
X[V] = S;
}else if(S != 0){
mycat(["Fuch relation:", S,"should be zero!"]);
return;
}
return
x*(x-1)*(x-P)*dx^2
+ (X[2]*(x-1)*(x-P)+X[3]*x*(x-P)+X[4]*x*(x-1))*dx
+ X[0]*X[1]*(x-R);
}
def fspt(M,T)
{
if(type(M)==7) M=s2sp(M);
if(T == 3) /* 3: cut 0 */
return cutgrs(M);
if(T == 4 || T== 5){ /* 4: short 5: long */
for(MN = [] ; M != []; M = cdr(M)){
MT = car(M);
for(MNT = []; MT != []; MT = cdr(MT)){
if(type(car(MT)) <= 3){
if(T == 4) MNT = cons(car(MT),MNT);
else MNT = cons([1,car(MT)],MNT);
}else{
if(T == 5 || car(MT)[0] > 1) MNT = cons(car(MT),MNT);
else if(car(MT)[0] == 1) MNT = cons(car(MT)[1],MNT);
}
}
MN = cons(reverse(MNT), MN);
}
return reverse(MN);
}
if(type(M[0][0]) == 4){
for(MN = [] ; M != []; M = cdr(M)){
MT = car(M);
for(MNT = []; MT != []; MT = cdr(MT))
MNT = cons(car(MT)[0], MNT);
MN = cons(reverse(MNT), MN);
}
return fspt(reverse(MN),T);
}
if(T == 0) /* 0: sp */
return M;
for(MN = [] ; M != []; M = cdr(M)){
MT = qsort(ltov(car(M)));
L = length(MT);
for(MNT = [], I = 0; I < L; I++)
MNT = cons(MT[I], MNT);
MN = cons(MNT, MN);
}
MN = reverse(MN);
if(T==6) return MN; /* 7: sort */
L = length(MN);
for(M = MN; M != []; M = cdr(M)){
for(I = 0, MT = car(M); MT != []; MT = cdr(MT))
I += car(MT);
if(OD == 0)
OD = I;
else if(OD != I || OD == 0)
return 0;
}
ALL = [MN];
RD=[];
while(OD > 0){
for(S = 0, MT = MN; MT != []; MT = cdr(MT))
S += car(MT)[0];
S -= (L-2)*OD;
if(S <= 0){
if(T==7) return [ALL[0],ALL[length(ALL)-1],RD];
return (T==1)?MN:ALL;
}
/* */
RD=cons([S,0,0],RD);
for(NP=0, M = [], MT = MN; MT != []; NP++, MT = cdr(MT)){
MTT = car(MT);
I = MTT[0] - S;
/* mycat([MNT, " ", MT, " ", I]); */
if(I < 0){
if(I+OD!=0) return 0;
if(T==7) return [ALL[0],ALL[length(ALL)-1],cdr(RD)];
return (T==1)?MN:ALL;
}
/* return cdr(RD); */
MTT = cdr(MTT);
NC=1; DO=0;
for(MNT = []; MTT != []; MTT = cdr(MTT)){
if(MTT[0] > I){
if(DO==0) RD=cons([MTT[0]-I,NP,NC++],RD);
MNT = cons(MTT[0], MNT);
}
else if(MTT[0] <= I && I != 0){
DO=1;
MNT = cons(I, MNT);
I = 0;
if(MTT[0] > 0)
MNT = cons(MTT[0], MNT);
}
}
if(I > 0)
MNT = cons(I,MNT);
M = cons(reverse(MNT), M);
}
MN = reverse(M);
ALL = cons(MN,ALL);
/* print(MN); */
OD -= S;
}
}
def abs(X)
{
if(type(X)==1 && X<0) X=-X;
return X;
}
def calc(X,L)
{
if(type(X)<4){
if(type(L)==4){
V=L[1];
if((L0=L[0])=="+") X+=V;
else if(L0=="-") X-=V;
else if(L0=="*") X*=V;
else if(L0=="/") X/=V;
else if(L0=="^") X^=V;
else if(L0==">") X=(X>V);
else if(L0=="<") X=(X<V);
else if(L0=="=") X=(X==V);
else if(L0==">=") X=(X>=V);
else if(L0=="<=") X=(X<=V);
else if(L0=="!=") X=(X!=V);
}else if(type(L)==7){
if(L=="neg") X=-X;
else if(L=="abs") X=abs(X);
else if(L=="neg") X=-X;
else if(L=="sqr") X*=X;
else if(L=="inv") X=1/X;
else if(L=="sgn"){
if(X>0)X=1;
else if(X<0) X=-1;
}
}
}
return X;
}
def isint(X)
{
if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1;
return 0;
}
def isalpha(X)
{
return ((X>64&&X<91)||(X>96&&X<123))?1:0;
}
def isnum(X)
{
return (X>47&&X<58)?1:0;
}
def isalphanum(X)
{
return (isalpha(X)||isnum(X))?1:0;
}
def isvar(X)
{
return ([X]==vars(X))?1:0;
}
def isyes(F)
{
if((CC=getopt(set))==1){
IsYes=(type(F[0])==4)?F:[F];
return 1;
}else if(CC==0) return(IsYes);
if(type(CC)!=7)
CC=IsYes;
for(;CC!=[]; CC=cdr(CC)){
C=car(CC);
V=call(C[0],cons(F,C[1]));
if(type(C[2])!=4){
if(V!=C[2]) break;
}else{
if(C[2][0]!="" && V<C[2][0]) break;
if(C[2][1]!="" && V>C[2][1]) break;
}
}
return (CC==[])?1:0;
}
def isall(FN,M)
{
if(type(M)<4 || type(M)>6) return ((*FN)(M)==0)?0:1;
if(type(M)==4){
for(;M!=[];M=cdr(M))
if((*FN)(car(M))==0) return 0;
}else if(type(M)==5){
K=length(M);
for(I=0;I<K;I++)
if((*FN)(M[I])==0) return 0;
}else if(type(M)==6){
K=size(M)[0];
for(I=0;I<K;I++)
if (isall(FN,M[I])==0) return 0;
}
return 1;
}
def sproot(MP,T)
{
if((I=str_chr(T,0,","))>0){
if(type(MP)==7) M=s2sp(MP);
else M=chkspt(MP|opt=0);
if(I==length(M[0])){
N=s2sp(T);S=SM=SN=K=0;
for(MM=M,NN=N;MM!=[];MM=cdr(MM),NN=cdr(NN),K++){
for(MT=car(MM),NT=car(NN);MT!=[];MT=cdr(MT),NT=cdr(NT)){
S+=car(MT)*car(NT);
if(K==0){
SM+=car(MT);SN+=car(NT);
}
}
}
return S-(length(M)-2)*SM*SN;
}
}
MM=chkspt(MP|opt=7);
if(T=="base") return MM;
Keep=(getopt(keep)==1)?1:0;
Null=getopt(null);
Only=getopt(only);
if(type(Only)!=1) Only=7;
M0=MM[0];
M1=MM[1];
M=MM[2];
if(T=="length") return length(M);
if(T=="height"){
for(J=2,S=M1[0][0],M2=M1; M2!=[]; M2=cdr(M2)){
for(MT=cdr(car(M2)); MT!=[]; J++, MT=cdr(MT)){
S+= J*car(MT);
}
J=1;
}
return S;
}
for(OD=0, MT=M1[0]; MT!=[]; MT=cdr(MT)) OD+=car(MT);
if(T=="type"){
R=newvect(OD+1);
for(MT=M; MT!=[]; MT=cdr(MT)) R[MT[0][0]]++;
for(RR=[],I=OD; I>0; I--)
if(R[I]>0) RR=cons([R[I],I],RR);
return RR;
}
if(T=="part"||T=="pair"||T=="pairs"){
NP=length(M1);
LM=newvect(NP);
R=newvect(length(M));
for(K=0; K<NP; K++) LM[K]=length(M1[K]);
for(I=0,TM=M; TM!=[]; I++, TM=cdr(TM)){
V=newvect(NP);
for(K=0; K<NP; K++) V[K]=newvect(LM[K]);
TP=car(TM);
if(TP[2]==0){
for(K=0;K<NP;K++) V[K][0]=1;
for(J=0; J<I; J++){
VJ=R[J][1];
for(S=K=0;K<NP;K++) S+=VJ[K][0];
for(OD=0,K=0;K<LM[0];K++) OD+=VJ[0][K];
S-=(NP-2)*OD;
for(K=0;K<NP;K++) VJ[K][0]-=S;
}
}else{
K=TP[1]; P=TP[2];
V[K][P-1]=-1; V[K][P]=1;
for(J=0; J<I; J++){
VJ=R[J][1];
S=VJ[K][P]; VJ[K][P]=VJ[K][P-1]; VJ[K][P-1]=S;
}
}
R[I]=[TP[0],V];
}
if(T=="pair"||T=="pairs"){
MV=ltov(M1);
for(K=0; K<NP; K++) MV[K] = ltov(MV[K]);
for(RR=UU=SS=[],I=0; I<length(M); I++){
V=newvect(NP); W=newvect(NP); U=newvect(NP);
for(K=0; K<NP; K++){
U[K]=newvect(LM[K]); V[K]=newvect(LM[K]); W[K]=newvect(LM[K]);
}
S=R[I][0];
for(K=0; K<NP; K++){
for(Q=J=0; J<LM[K]; J++){
V[K][J] = S*(U[K][J] = R[I][1][K][J]);
Q+=(W[K][J] = MV[K][J] - V[K][J]);
}
}
if(Q>0 && iand(Only,1)==0) continue;
if(Q==0 && iand(Only,2)==0) continue;
if(Q<0 && iand(Only,4)==0) continue;
for(K=0; K<NP; K++){
V[K] = vtol(V[K]); W[K] = vtol(W[K]); U[K]=vtol(U[K]);
}
V=vtol(V); W=vtol(W);U=vtol(U);
if(Q<0) S=-S;
RR = cons([V,W], RR); UU = cons(U,UU); SS=cons(S,SS);
}
RR = reverse(RR); UU=reverse(UU); SS=reverse(SS);
if(getopt(dviout)==1 && (Null!=1 || RR!=[])){
Out=string_to_tb("\\begin{align}\\begin{split}"+s2sp(M1)+"&=");
for(I=0,R=RR, U=UU; R!=[]; I++, R=cdr(R), U=cdr(U)){
if(I>0) str_tb("\\\\\n &=",Out);
if(T=="pairs"){
if((S=SS[I])<0) S=-S;
if(S>1) str_tb([my_tex_form(S),"("],Out);
str_tb(s2sp(car(U)),Out);
if(S>1) str_tb(")",Out);
str_tb(" \\oplus ",Out);
if(SS[I]<0){
str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out);
}else
str_tb(s2sp(car(R)[1]),Out);
}else
str_tb([s2sp(car(R)[0])," \\oplus ",s2sp(car(R)[1])],Out);
}
str_tb("\n\\end{split}\\end{align}",Out);
dviout(str_tb(0,Out)|keep=Keep);
}
return RR;
}
for(I=0; I<length(M); I++){
for(K=0; K<NP; K++) R[I][1][K] = vtol(R[I][1][K]);
R[I] = [R[I][0],vtol(R[I][1])];
}
R = vtol(R);
return [M0,M1,R];
}
}
def spgen(MO)
{
Eq=(getopt(eq)==1)?1:0;
Sp=getopt(sp);
if(type(Sp)==7) Sp=s2sp(Sp);
St=getopt(str);
LP=getopt(pt);
if(type(LP)==4){
L0=LP[0]; L1=LP[1];
}else{
L0=0; L1=MO+1;
}
if(MO<=0){
MO=-MO;
if(iand(MO,1)==1) return [];
if(MO>1){
if(isMs()==0) return [];
Cmd="okubo "+rtostr(-MO);
MO/=2;
if(L1>0) Cmd=Cmd+"+"+rtostr(L0)+"-"+rtostr(L1);
else L1=MO+4;
Cmd=Cmd+" B";
Id=getbyshell(Cmd);
if(Id<0) return [];
B=[];
while((S=get_line(Id)) !=0){
P0=str_chr(S,1,":")+1;
if(P0>1){
P1=str_chr(S,P,"\n");
if(P1<0) P1=str_len(S);
B=cons(sub_str(S,P0,P1-1),B);
}
}
}else{
MO/=2;
if(L1<=1) L1=MO+4;
BB=[
["11,11,11,11","111,111,111","1^4,1^4,22","1^6,222,33"],
["11,11,11,11,11","1^4,1^4,211","211,22,22,22","1^6,2211,33",
"2211,222,222","22211,2^4,44","2^511,444,66","1^4,22,22,31",
"2^5,3331,55","1^5,1^5,32","1^8,332,44","111,111,21,21","1^5,221,221"],
["11,11,11,11,11,11","1^4,1^4,1^4","1^4,22,22,22","111,111,111,21",
"1^6,21^4,33","21^4,222,222","221^4,2^4,44","2^41^4,444,66",
"1^5,1^5,311","1^8,3311,44","1^6,222,321","321,33,33,33",
"3321,333,333","33321,3^4,66","3^721,666,99","2^5,3322,55",
"1^6,1^6,42","222,33,33,42","1^a,442,55","1^6,33,33,51",
"222,222,33,51","1^9,333,54","2^7,554,77","1^5,2111,221",
"2^41,333,441","1^7,2221,43","211,211,22,22","2211,2211,222",
"22211,22211,44","1^4,211,22,31","2^411,3331,55","1^4,1^4,31,31",
"22,22,22,31,31","1^7,331,331","2221,2221,331","111,21,21,21,21"],
["11,11,11,11,11,11,11","111,111,111,111","1^6,1^6,33",
"1^6,222,222","222,33,33,33","1^5,1^5,221",
"1^4,211,22,22","1^4,1^4,22,31","22,22,22,22,31",
"111,111,21,21,21","21^6,2^4,44","2221^6,444,66",
"1^6,222,3111","3111,33,33,33","33111,333,333",
"333111,3^4,66","3^5111,666,99","2^5,33211,55",
"1^8,3221,44","3222,333,333","33222,3^4,66",
"3^4222,666,99","1^6,1^6,411","222,33,33,411",
"1^a,4411,55","2^4,2^4,431","431,44,44,44",
"2^6,4431,66","4431,444,444","44431,4^4,88",
"4^531,888,cc","1^a,433,55","1^7,1^7,52",
"1^c,552,66","3^4,444,552","1^8,2^4,53",
"1^8,44,44,71","3^5,555,771","21^4,2211,222",
"221^4,22211,44","2221^4,3331,55","1^6,2211,321",
"2^411,3322,55","1^7,322,331","2211,33,33,42",
"3^42,4442,77","2211,222,33,51","3^51,5551,88",
"2^611,554,77","2221,2221,322","2^41,2^41,54",
"1^5,2111,2111","222111,333,441","1^7,22111,43",
"1^5,1^5,41,41","1^9,441,441","22111,2221,331",
"1^5,221,32,41","221,221,221,41","211,211,211,22",
"2211,2211,2211","1^4,211,211,31","211,22,22,31,31",
"1^4,22,31,31,31","1^5,32,32,32","221,221,32,32","21,21,21,21,21,21"],
["11,11,11,11,11,11,11,11","1^4,1^4,22,22","1^8,2^4,44",
"1^6,2211,222","2211,33,33,33","111,111,111,21,21",
"1^5,1^5,2111","1^4,211,211,22","1^4,1^4,211,31",
"211,22,22,22,31","1^4,22,22,31,31","111,21,21,21,21,21",
"221^8,444,66","2^5,331^4,55","1^8,32111,44",
"32211,333,333","332211,3^4,66","3^42211,666,99",
"2^5,32221,55","1^7,1^7,511","1^c,5511,66",
"3^4,444,5511","541,55,55,55","5541,555,555",
"55541,5^4,aa","5^541,aaa,ff","1^8,1^8,62",
"1^a1^4,662,77","1^a,55,55,91","2^71,555,87",
"21^6,22211,44","221^6,3331,55","1^6,2211,3111",
"2^411,33211,55","1^7,3211,331","2211,33,33,411",
"3^42,44411,77","22211,2^4,431","2^511,4431,66",
"1^8,332,431","3^42,4433,77","1^8,22211,53",
"2221,2221,3211","221^5,333,441","1^7,21^5,43",
"1^b,443,65","21^5,2221,331","2^51,3332,65",
"21^4,21^4,222","221^4,221^4,44","1^6,21^4,321",
"2221^4,3322,55","21^4,33,33,42","21^4,222,33,51",
"2^51^4,554,77","2^4,3311,3311","3^411,4442,77",
"321,321,33,33","3321,3321,333","33321,33321,66",
"222,321,33,42","1^6,321,33,51","222,222,321,51",
"1^9,3321,54","1^7,322,322","3^422,5551,88",
"1^6,33,42,42","1^6,222,42,51","33,33,33,42,51",
"1^6,1^6,51,51","222,33,33,51,51","1^b,551,551",
"1^5,221,311,41","2^41,3321,441","22111,2221,322",
"2^51,443,551","222111,2^41,54","21^4,2211,2211",
"1^5,311,32,32","3331,3331,442","2211,2211,33,51",
"221,221,311,32","22111,22111,331","1^5,2111,32,41",
"2111,221,221,41","2111,221,32,32","211,211,211,211",
"211,211,22,31,31","1^4,211,31,31,31","22,22,31,31,31,31"],
["11,11,11,11,11,11,11,11,11","1^5,1^5,1^5","2^5,2^5,55",
"111,111,111,111,21","2^41,333,333","1^4,1^4,211,22",
"211,22,22,22,22","1^8,22211,44","1^4,1^4,1^4,31",
"1^4,22,22,22,31","1^7,1^7,43","1^7,2221,331",
"2221,2221,2221","1^6,21^4,222","21^4,33,33,33",
"1^6,1^6,321","222,321,33,33","1^6,33,33,42",
"222,222,33,42","1^6,222,33,51","222,222,222,51",
"33,33,33,33,51","1^6,2211,2211","111,111,21,21,21,21",
"1^5,1^5,32,41","1^5,221,221,41","1^5,221,32,32",
"221,221,221,32","1^4,211,211,211","211,211,22,22,31",
"1^4,211,22,31,31","1^4,1^4,31,31,31","22,22,22,31,31,31",
"21,21,21,21,21,21,21","21^a,444,66","1^8,31^5,44",
"321^4,333,333","3321^4,3^4,66","3^421^4,666,99",
"2^5,322111,55","32^41,3^4,66","3332^41,666,99",
"1^8,1^8,611","2^4,44,44,611","1^d,6611,77",
"4^5,66611,aa","2^6,444,651","3^4,3^4,651",
"651,66,66,66","3^6,6651,99","6651,666,666",
"66651,6^4,cc","6^551,ccc,ii","2^8,655,88",
"1^9,1^9,72","1^g,772,88","1^c,444,75",
"2^6,3^4,75","1^c,66,66,b1","3^4,444,66,b1",
"3^7,777,ba","1^7,2221,4111","2^41,333,4311",
"1^9,2^41,63","21^8,3331,55","2^411,331^4,55",
"1^7,31^4,331","2^411,32221,55","22211,2^4,422",
"2^511,4422,66","1^8,332,422","2^5,3331,541",
"22211,44,44,62","2^411,2^5,64","2^711,664,88",
"1^a,3331,64","2221,2221,31^4","21^7,333,441",
"333,333,441,81","2^6111,555,87","21^6,221^4,44",
"221^6,3322,55","2^41^6,554,77","1^6,21^4,3111",
"3111,321,33,33","33111,3321,333","333111,33321,66",
"222,3111,33,42","1^6,3111,33,51","222,222,3111,51",
"1^9,33111,54","2221^4,33211,55","1^7,3211,322",
"3^4211,5551,88","2^4,3221,3311","333221,4442,77",
"3222,3321,333","33222,33321,66","1^9,3222,54",
"21^4,33,33,411","3^411,44411,77","222,321,33,411",
"1^6,33,411,42","1^6,222,411,51","33,33,33,411,51",
"221^4,2^4,431","2^41^4,4431,66","1^8,3311,431",
"3^411,4433,77","33321,444,552","1^8,221^4,53",
"3311,44,44,53","4^42,5553,99","2^4,3311,44,71",
"3^421,555,771","4^52,7771,bb","3^611,776,aa",
"2^41,33111,441","22111,2221,3211","2^41,3222,441",
"2^61,4441,76","3331,3331,4411","22211,22211,431",
"3331,3331,433","3^41,3^41,76","1^7,1^7,61,61",
"1^d,661,661","21^5,2221,322","221^5,2^41,54",
"2^51,33311,65","21^5,22111,331","3^41,4441,661",
"1^7,331,43,61","2221,2221,43,61","2221,331,331,61",
"21^4,21^4,2211","21^4,2211,33,51","22211,3311,3311",
"1^5,311,311,32","2211,321,33,42","2211,222,321,51",
"3322,3331,442","2211,222,42,42","2^411,442,442",
"1^6,2211,42,51","2211,33,33,51,51","221,221,311,311",
"1^5,2111,311,41","222111,3321,441","22111,22111,322",
"222111,222111,54","2111,221,311,32","2111,2111,221,41",
"1^5,221,41,41,41","2221,43,43,43","1^5,32,32,41,41",
"331,331,43,43","221,221,32,41,41","221,32,32,32,41",
"211,211,211,31,31","211,22,31,31,31,31","1^4,31,31,31,31,31"]];
B=BB[MO];
}
if(St!=1){
for(R=[]; B!=[]; B=cdr(B)){
RT=s2sp(car(B));
if(length(RT)<L0 || length(RT)>L1) continue;
R=cons(RT,R);
}
return reverse(R);
}else{
if(L0<=3 && L1>=MO+4) return B;
for(R=[]; B!=[]; B=cdr(B)){
RT=s2sp(car(B));
if(length(RT)<L0 || length(RT)>L1) continue;
R=cons(car(B),R);
}
return reverse(R);
}
/*
MM = 3*MO+5;
if(L1<=1) L1=MM/2+1;
R = newvect(MM+2);
for(RR=[], I=MO/2+2; I>0; I--)
RR=cons([1,1],RR);
R[2]=[RR];
if(MO==0){
R[6] = [[[3,3],[2,2,2],[1,1,1,1,1,1]]];
R[4] = [[[2,2],[1,1,1,1],[1,1,1,1,]]];
R[3] = [[[1,1,1],[1,1,1],[1,1,1]]];
}else{
I=MO/2+1;
R[MM+1]=[[[3*I,3*I],[2*I,2*I,2*I],[I,I,I,I,I,I-1,1]]];
}
*/
}
MP=(L1<MO+1)?L1:MO+1;
LL=newvect(MO+1);
R=newvect(MP+2);
R0=newvect(MP+2);
for(I=1; I<=MO; I++) LL[I]=[];
if(type(Sp)==4){
if(getopt(basic)==1) Sp=chkspt(Sp[6]);
R=chkspt(Sp);
if(R[1]>MO) return 0;
LL[R[1]]=R;
K=R[1];
}
if(K==1||type(Sp)!=4){
LL[1]=[[[1]]];
for(I=2; I<=MO && I<MP;I++){
for(T=[], J=0; J<I+1; J++)
T=cons([I-1,1],T);
LL[I]=cons(T,LL[I]);
}
K=2;
}
/* mycat(LL); */
for(OD=K; OD<MO; OD++){
for(LT=LL[OD]; LT!=[]; LT=cdr(LT)){
for(II=0,L=car(LT); L!=[]; II++, L=cdr(L)){
R0[II]=R[II]=car(L);
}
/* mycat([R0,R]); */
for(; ;){
for(S=-2*OD, I=0; I<II; I++){
S += OD;
if(R[I]!=[]) S-=car(R[I]);
}
--I;
for(;S+OD<=MO && I<=MP;S+=OD,I++){
/* mycat(["C",I]); */
if(S<=0) continue;
/* mycat(["+",S,I,II,R,R0]); */
for(J=0;J<=I;J++){
/* mycat([S+((R[J]==[])?0:car(R[J])),car(R0[J])]); */
if(J>=II){
if(S<OD) break;
}else
if(S+((R[J]==[])?0:car(R[J]))<car(R0[J])) break;
}
if(--J>=I){
V=newvect(I);
RRR=[];
for(;J>=0;J--){
if(J>=II) RR=[OD,S];
else{
K=length(R[J]);
RR=[S+((K==0)?0:car(R[J]))];
K=length(R0[J])-K;
for(RT=R0[J]; RT!=[]; K--,RT=cdr(RT)){
if(K!=0) RR=cons(car(RT),RR);
}
}
RRR=cons(reverse(RR),RRR);
}
/* mycat(["Get",s2sp(RRR)]); */
RRR=qsort(reverse(RRR));
if(findin(RRR,LL[S+OD])<0)
LL[S+OD]=cons(RRR,LL[S+OD]);
}
}
/* mycat(["*",I,R]); */
for(K=0; K<II; K++){
if(R[K]!=[]){
S=car(R[K]);
while((R[K]=cdr(R[K]))!=[] && car(R[K])==S);
break;
}else R[K]=R0[K];
}
/* mycat([R,R0]); */
if(K>=II) break;
}
}
}
if(L0>0 || L1<MO+1 || St==1){
for(J=1; J<=MO; J++){
for(RT=[],R=LL[J]; R!=[];R=cdr(R)){
L=length(car(R));
if(L<L0 || L>L1) continue;
RT=cons((St==1)?s2sp(car(R)):car(R),RT);
}
LL[J] = reverse(RT);
}
}
if(Eq==1) return LL[MO];
return LL;
}
/* ret [#points, order, idx, Fuchs, reduction order, reduction exponents, fund] */
def chkspt(M)
{
Opt= getopt(opt);
Mat= getopt(mat);
if(type(M)==7) M=s2sp(M);
if(type(Opt) >= 0){
if(type(Opt) == 7)
Opt = findin(Opt, ["sp","basic","construct","strip","short","long","sort","root"]);
if(Opt < 0){
erno(2);
return 0;
}
return fspt(M,Opt);
}
MR = fspt(M,1);
P = length(M);
OD = -1;
XM = newvect(P);
Fu = 0;
for( I = SM = SSM = 0; I < P; I++ ){
LJ = length(M[I]);
JM = JMV = 0;
for(J = SM = 0; J < LJ; J++){
MV = M[I][J];
if(type(MV) == 4){
Fu += MV[0]*MV[1];
MV = MV[0];
}
if(MV > JMV){
JM = J; JMV = MV;
}
SM += MV;
SSM += MV^2;
}
if(OD < 0)
OD = SM;
else if(OD != SM){
print("irregal partitions");
return 0;
}
XM[I] = JM;
}
SSM -= (P-2)*OD^2;
for(I = SM = JM = 0; I < P; I++){
MV = M[I][XM[I]];
if(type(MV) == 4){
MV = MV[0]; JM = 1;
}
if(I == 0)
SMM = MV;
else if(SMM > MV)
SMM = MV;
SM += MV;
}
SM -= (P-2)*OD;
if(SM > SMM && SM != 2*OD){
print("not realizable");
return -1;
}
if(JM==1 && Mat!=1)
Fu -= OD - SSM/2;
return [P, OD, SSM, Fu, SM, XM, MR];
}
def cterm(P)
{
V = getopt(var);
if(type(V) != 4)
V=vars(P);
for(; V !=[]; V = cdr(V))
P = mycoef(P,0,car(V));
return P;
}
def terms(P,L)
{
Lv=getopt(level);
if(type(Lv)!=1) Lv=0;
V=car(L);L=cdr(L);
for(R=[],D=mydeg(P,V);D>=0; D--){
if((Q=mycoef(P,D,V))==0) continue;
if(L!=[]){
R0=terms(Q,L|level=Lv+1);
for(;R0!=[];R0=cdr(R0)) R=cons(cons(D,car(R0)),R);
}else R=cons([D],R);
}
if(Lv>0) return R;
R=qsort(R);
Rev = getopt(rev); Dic=getopt(dic);
if(Dic==1 && Rev==1) R=reverse(R);
for(R0=[];R!=[];R=cdr(R)){
for(RT=car(R),S=0;RT!=[];RT=cdr(RT)) S+=car(RT);
R0=cons(cons(S,car(R)),R0);
}
if(Dic==1) return R0;
R0=qsort(R0);
return (Rev==1)?R0:reverse(R0);
}
def polcut(P,N,L)
{
if(type(L)==2) L=[L];
M=getopt(top);
if(type(M)!=1) M=0;
T=terms(P,L);
for(S=0;T!=[];T=cdr(T)){
LT=car(T);
if(LT[0]<M || LT[0]>N) continue;
for(PW=1,LT=cdr(LT),V=L,Q=P;LT!=[];LT=cdr(LT),V=cdr(V)){
Q=mycoef(Q,car(LT),car(V));PW*=car(V)^car(LT);
}
S+=Q*PW;
}
return S;
}
def redgrs(M)
{
Mat = getopt(mat);
if(Mat!=1) Mat=0;
R = chkspt(M|mat=Mat);
if(type(R) < 4)
return -1;
if(R[4] <= 0)
return 1-R[4];
if(R[4] == 2*R[1])
return 0;
V = newvect(R[0]);
Type = type(M[0][0]);
if(Type > 3){
Mu = Mat-1;
for(I = 0; I < R[0]; I++)
Mu += M[I][R[5][I]][1];
}
for(I = 0; I < R[0]; I++){
IR = R[5][I]; L = []; MI = M[I]; MIE=MI[IR];
for(J = length(MI)-1; J >= 0; J--){
if(Type <= 3){
VM = MI[J];
if(J == IR){
VM -= R[4];
if(VM < 0)
return -1;
}
L = cons(VM, L);
}else{
VM = MI[J][0];
if(J == IR){
VM -= R[4];
if(VM < 0)
return -1;
if(I == 0)
EV = 1-Mat-Mu;
else
EV = 0;
}else{
if(I == 0)
EV = MI[J][1] - M[0][R[5][0]][1] + 1-Mat; /* + MX - Mu; */
else
EV = MI[J][1] - MIE[1] + Mu;
}
L = cons([VM,EV], L);
/*
if(R[2] >= 2){ */ /* digid */
/* P = dx^(R[1]);
} */
}
}
V[I] = L;
}
return [R[5], vtol(V)];
}
def cutgrs(A)
{
for(AL=[] ; A!=[]; A=cdr(A)){ /* AT: level 2 */
for(ALT=[], AT=car(A); AT!=[]; AT=cdr(AT)){
M = (type(car(AT)) < 4)?car(AT):car(AT)[0];
if(M > 0)
ALT = cons(car(AT), ALT); /* ALT: level 2 */
}
AL = cons(reverse(ALT), AL); /* AL: level 3 */
}
return reverse(AL);
}
def mcgrs(G, R)
{
NP = length(G);
Mat = (getopt(mat)==1)?0:1;
for(R = reverse(R) ; R != []; R = cdr(R)){
GN = [];
L = length(G)-1;
RT = car(R);
if(type(RT) == 4){
RT = reverse(RT); S = 0;
for(G = reverse(G); G != []; G = cdr(G), L--){
AD = car(RT); RT = cdr(RT);
if(L > 0)
S += AD;
else
AD = -S;
for(GTN = [], GT = reverse(car(G)); GT != []; GT = cdr(GT))
GTN = cons([car(GT)[0],car(GT)[1]+AD], GTN);
GN = cons(GTN, GN);
}
G = GN;
continue;
}
VP = newvec(L+1); GV = ltov(G);
for(I = S = OD = 0; I <= L; I++){
RTT = (I==0)?(Mat-RT):0;
VP[I] = -1;
for(J = M = 0, GT = GV[I]; GT != []; GT = cdr(GT), J++){
if(I == 0)
OD += car(GT)[0];
if(car(GT)[1] == RTT && car(GT)[0] > M){
S += car(GT)[0]-M;
VP[I] = J;
}
}
S -= (L-1)*OD;
for(GN = [] ; L >= 0; L--){
GT = GV[L];
RTT = (L==0)?(-RT):RT;
FTN = (VP[L] >= 0 || S == 0)?[]:[-S,(L==0)?(Mat-RT):0];
for(J = 0; GT != []; GT = cdr(GT), J++){
if(J != VP[L]){
GTN = cons([car(GT)[0],car(GT)[1]+RTT], GTN);
continue;
}
K = car(GT)[0] - S;
if(K < 0){
print("Not realizable");
return;
}
GTN = cons([K,(L==0)?(Mat-RT):0], GTN);
}
GN = cons(reverse(GTN), GN);
}
}
G = cutgrs(GN);
}
return G;
}
def str_char(S,N,L)
{
if(type(S)==7){
if(type(L)==1) L=asciitostr([L]);
return str_chr(S,N,L);
}
if(type(L)==7) L=strtoascii(L)[0];
if(type(S)==4){
M=N;
while(M-->0) S=cdr(S);
M=findin(L,S);
return (M>=0)?findin(L,S)+N:-1;
}else if(type(S)==5){
K=length(S);
for(I=N;I<K;I++)
if(S[I]==L) return I;
}
return -1;
}
def str_pair(S,N,I,J)
{
if(type(I)==7) I=(II=strtoascii(I))[0];
if(type(J)==7) J=(JJ=strtoascii(J))[0];
if(type(S)==7) S=strtoascii(S);
if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){
for(;;){
MJ=str_str(S,N|top=JJ);
if(MJ>=0){
MI=str_str(S,II|top=N);
if(MI<0 || MI>MJ){
if(C==0) return MJ;
C--; N=MJ+length(II);
}else if(MI>=0){
C++; N=MI+length(JJ);
}
}
return -1;
}
}
if(type(S)==4){
M=N;
while(M-->0) S=cdr(S);
while(S!=[]){
if(car(S)==I) C++;
else if(car(S)==J){
if(C==0) return N;
C--;
}
S=cdr(S);N++;
}
}else if(type(S)==5){
K=length(S);
for(T=N;T<K && C>=0; T++){
if(S[T]==I) C++;
else if(S[T]==J){
if(C==0) return T;
C--;
}
}
}
return -1;
}
def str_cut(S,I,J)
{
if(type(S)==7) return sub_str(S,I,J);
if((JJ=length(S))<=J) J=JJ-1;
if(type(S)==5){
for(L=[],K=J; K>=I; K--) L=cons(S[K],L);
}else if(type(S)==4){
J-=I;
while(I-->0) S=cdr(S);
for(L=[];J-->=0;S=cdr(S)) L=cons(car(S),L);
L=reverse(L);
}
return asciitostr(L);
}
def str_str(S,T)
{
if(S==0) return -1;
if(type(S) == 7)
S = strtoascii(S);
if(type(J=getopt(top))!=1 || J<0) J=0;
LS=length(S);
if(LS-J<1) return -1;
if(type(S)==4){
LS-=(J0=J);
for( ; J>0 && S!=[]; S=cdr(S),J--);
}
if(type(JJ=getopt(end))!=1 && JJ!=0) JJ=LS;
else JJ-=J0;
if((SJIS=getopt(sjis))!=1) SJIS=0;
if(JJ-J<0) return -1;
/* search from J-th to JJ-th */
if(type(T)==1) T=[T];
else if(type(T)==7) T = strtoascii(T);
else if(type(T)==4 && type(T[0])>3){
for(K=(KF=-1)-J0; T!=[]; F++,T=cdr(T)){
JK=str_str(S,car(T)|top=J,end=JJ,sjis=SJIS);
if(JK>=0){
JJ=(K=JK)-1; KF=F;
if(J>JJ) break;
}
}
return [KF,J0+K];
}
if(type(T)==4) T=ltov(T);
LT = length(T);
if(LT>0){
LE = LS-LT;
LP = T[0];
if(JJ==0 ||(type(JJ)==1 && JJ<LE)) LE=JJ;
if(type(S)==5){
for(; J <= LE; J++){
if(S[J] != LP){
if(SJIS && (V=S[J])>128){
if(V<160 || (V>223 && V<240)) J++;
}
continue;
}
for(I = 1; I < LT && S[I+J] == T[I]; I++);
if(I >= LT) return J;
}
}else if(type(S)==4){
for(; J<=LE; S=cdr(S),J++){
if(car(S) != LP){
if(SJIS && (V=S[J])>128){
if(V<160 || (V>223 && V<240)) J++;
}
continue;
}
for(ST=cdr(S), I = 1; I < LT && car(ST) == T[I]; I++, ST=cdr(ST));
if(I >= LT) return J0+J;
}
}
}
return -1;
}
def ssubgrs(M,L)
{
if(type(L)==7) L=s2sp(L);
for(S=0, L=L, M=M; L!=[]; L=cdr(L), M=cdr(M)){
for(LT=car(L), MT=car(M); LT!=[]; LT=cdr(LT), MT=cdr(MT)){
S += car(LT)*car(MT)[1];
}
}
return S;
}
def verb_tex_form(P)
{
L = reverse(strtoascii(rtostr(P)));
for(SS = []; L != []; L = cdr(L)){
Ch = car(L); /* ^~\{} */
if(Ch == 92 || Ch == 94 || Ch == 123 || Ch == 125 || Ch == 126){
SS = append([92,Ch,123,125],SS); /* \Ch{} */
if(Ch != 94 && Ch != 126) /* \char` */
SS = append([92,99,104,97,114,96],SS);
continue;
}
SS = cons(Ch, SS);
if((Ch >= 35 && Ch <= 38) || Ch == 95) /* #$%&_ */
SS = cons(92, SS); /* \Ch */
}
return asciitostr(SS);
}
def my_tex_form(S)
{
if(getopt(skip) != 1){
S = print_tex_form(S);
for(F=Top=0;(L=str_str(S,"\\verb`"|top=Top))>=0;Top=LV+1){
F++;
if(Top==0) Tb = string_to_tb("");
LV = str_chr(S, L+6, "`");
if(LV<0) LV=str_len(S);
str_tb([my_tex_form(sub_str(S, Top, L-1)|skip=1), "\\texttt{"], Tb);
str_tb([verb_tex_form(sub_str(S,L+6, LV-1)),"}"], Tb);
Top=LV+1;
}
str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb);
if(F>0) return tb_to_string(Tb);
}
if(S==0) return "";
S = ltov(strtoascii(S));
L = length(S)-1;
while(L >= 1 && S[L] == 10)
L--;
for(I = L, T = 0, SS = [S[I]]; --I >= 0; ){
if(S[I] == 32){
if(findin(S[I+1], [32,40,41,43,45,123,125]) >= 0 /* " ()+-{}" */
|| (S[I+1] >= 49 && S[I+1] <= 57)) /* 1 - 9 */
if(I == 0 || S[I-1] >= 32) continue;
}
SS = cons(S[I], SS);
}
Subst=getopt(subst);
if(type(Subst) == 4)
SS = strtoascii(str_subst(SS,Subst[0],Subst[1]));
S = ltov(SS);
L = length(S);
SS = [];
while(--L >= 0){
if(S[I=L] == 125){
while(--I >= 0 && S[I] == 125);
J = 2*I - L;
if(J >= 0 && S[I] != 123){
for(K = J; K < I && S[K] == 123; K++);
if(K == I){
if(J-- <= 0 || S[J] < 65 || S[J] > 122 || (S[J] > 90 && S[J] < 97)){
SS = cons(S[I], SS);
L = J+1;
continue;
}
}
}
}
SS = cons(S[L], SS);
}
return asciitostr(SS);
}
def smallmattex(S)
{
return str_subst(S,[["\\begin{pmatrix}","\\left(\\begin{smallmatrix}"],
["\\end{pmatrix}","\\end{smallmatrix}\\right)"],
["\\begin{Bmatrix}","\\left\\{\\begin{smallmatrix}"],
["\\end{Bmatrix}","\\end{smallmatrix}\\right\\}"],
["\\begin{bmatrix}","\\left[{\\begin{smallmatrix}"],
["\\end{bmatrix}","\\end{smallmatrix}\\right]"],
["\\begin{vmatrix}","\\left|\\begin{smallmatrix}"],
["\\end{vmatrix}","\\end{smallmatrix}\\right|"],
["\\begin{Vmatrix}","\\left\\|\\begin{smallmatrix}"],
["\\end{Vmatrix}","\\end{smallmatrix}\\right\\|"],
["\\begin{matrix}","\\begin{smallmatrix}"],
["\\end{matrix}","\\end{smallmatrix}"]],0);
}
def str_subst(S, L0, L1)
{
if(type(S) == 7)
S = strtoascii(S);
if(type(S) == 4)
S = ltov(S);
SE = length(S);
if(L1 == 0){
for(L1 = L = [], L0 = reverse(L0); L0 != []; L0 = cdr(L0)){
L = cons(car(L0)[0], L);
L1 = cons(car(L0)[1], L1);
}
L0 = L;
}
if(type(L0)==7) L0 = [strtoascii(L0)];
else{
for(LT = []; L0 != []; L0 = cdr(L0))
LT = cons(strtoascii(car(L0)), LT);
L0 = ltov(LT);
}
E0 = length(L0);
if(type(L1)==7) L1 = [strtoascii(L1)];
else{
for(LT = []; L1 != []; L1 = cdr(L1))
LT = cons(strtoascii(car(L1)), LT);
L1 = ltov(LT);
}
if((SJIS=getopt(sjis))!=1) SJIS=0;
for(J = JJ = 0, ST = []; J < SE; J++){
SP = S[J];
for(I = E0-1; I >= 0; I--){
if(SP != L0[I][0] || J + (K = length(L0[I])) > SE)
continue;
while(--K >= 1)
if(L0[I][K] != S[J+K]) break;
if(K > 0) continue;
for(KE = length(L1[I]), K = 0 ;K < KE; K++)
ST = cons(L1[I][K],ST);
J += length(L0[I])-1;
break;
}
if(I < 0){
ST = cons(S[J],ST);
if(SJIS && (V=S[J])>128){
if(V<160 || (V>223 && V<240)) ST = cons(S[J++],ST);
}
}
}
return asciitostr(reverse(ST));
}
def dviout0(L)
{
if(type(L) == 4){
for( ; L != []; L = cdr(L))
dviout0(car(L));
return 1;
}
if(type(L) == 7){
if(L == "")
L = " ";
dviout(L|keep=1,clear=1);
return 1;
}
if(L == 0)
dviout(" "|keep=1,clear=1);
else if(L == 1)
dviout(" ");
else if(L == 2)
dviout(" "|clear=1);
else if(L>10)
dviout("\\setcounter{MaxMatrixCols}{"+rtostr(L)+"}%"|keep=1);
else if(L < 0)
dviout(" "|delete=-L,keep=1);
else if(L == 3){
mycat(["DIROUT =", DIROUT]);
mycat(["DVIOUTH=", DVIOUTH]);
mycat(["DVIOUTA=", DVIOUTA]);
mycat(["DVIOUTL=", DVIOUTL]);
mycat(["TeXLim =", TeXLim]);
mycat(["TeXEq =", TeXEq]);
mycat(["AMSTeX =", AMSTeX]);
}
return 1;
}
def myhelp(T)
{
/* extern DVIOUT; */
/* extern HDVI; */
/* extern DVIOUTH; */
if(type(T)==2){
if(T==getbygrs){
getbygrs(0,0);
return 0;
}
else if(T==m2mc){
m2mc(0,0);
return 0;
}
else if(T==mgen){
mgen(0,0,0,0);
return 0;
}
else T=rtostr(T);
}
if(type(T)==4 && typeT[0]==7){
if(length(T)==2 && type(T[1])==1){
DVIOUTH="start "+T[0]+" -"+rtostr(T[1])+"-hyper:0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #r:%LABEL%";
}else if(str_len(T[0])>2) DVIOUTH=T[0];
mycat(["DVIOUTH="+DVIOUTH,"\nmyhelp(fn) is set!"]);
return 0;
}
if(T==0){
mycat([
"myhelp(t) : show help\n",
#ifdef USEMODULE
" t : -1 (dvi), 1 (pdf) or os_md.getbygrs, os_md.m2mc, os_md.mgen\n",
#else
" t : -1 (dvi), 1 (pdf) or getbygrs, m2mc, mgen\n",
#endif
" \"fn\" : Help of the function fn\n",
" [path,n] : path of dviout, n = # dviout\n",
" [DVIOUTH] : Way to jump to the help of a function\n",
" default: start dviout -2 \"%ASIRTOOT%\\help\\os_muldif.dvi\" #r:%LABEL%"
]);
return 0;
}
if(type(T)==7){
if(str_str(T,"os_md.")==0) T=str_cut(T,6,str_len(T)-1);
Dr=str_subst(DVIOUTH,["%ASIRROOT%","%LABEL%"],[get_rootdir(),"r:"+str_subst(T,"_","")]);
shell(Dr);
return 0;
}
Dr=get_rootdir();
if(T==-1) Dr+="\\help\\os_muldif.dvi";
else Dr+="\\help\\os_muldif.pdf";
if(!isMs()) Dr=str_subst(Dr,"\\","/");
shell(Dr);
return 0;
}
def isMs()
{
if(type(Tmp=getenv("TEMP"))!=7) {
if (type(Tmp=getenv("TMP")) != 7) Tmp=getenv("HOME");
}
if(type(Tmp)==7 && str_chr(Tmp,0,"\\")==2) return 1;
else return 0;
}
def showbyshell(S)
{
Id = getbyshell(S);
if(Id<0) return Id;
while((S=get_line(Id))!=0) print(S,2);
return close_file(Id);
}
def getbyshell(S)
{
/* extern DIROUT; */
Home=getenv("HOME");
if(type(Home)!=7) Home="";
if(type(Tmp=getenv("TEMP"))!=7 && type(Tmp=getenv("TMP")) != 7)
Tmp=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
Sep=isMs()?"\\":"/";
F=Tmp+Sep+"muldif.tmp";
if(type(S)<=1 && S>=0) close_file(Id);
remove_file(F);
if(type(S)<=1) return -1;
shell(S+" > \""+F+"\"");
return open_file(F);
}
def show(P)
{
T=type(P);
S=P;
Var=getopt(opt);
if(Var=="verb"){
dviout("{\\tt"+verb_tex_form(T)+"}\n\n");
return;
}
if(T==6){
if((Sp=getopt(sp))==1 || Sp==2)
S=mtotex(P|lim=1,small=2,sp=Sp,null=1,mat="B");
else if(type(var)==4 || type(Var)==7)
S=mtotex(P|lim=1,small=2,var=Var);
else
S=mtotex(P|lim=1,small=2);
Size=size(P);
Size=(Size[0]>Size[1])?Size[0]:Size[1];
if(Size>10) dviout0(Size);
}else if(T<=3){
if(type(Var)==7){
if(Var=="pfrac") pfrac(P,var(P)|dviout=1);
else fctrtos(P|var=Var,dviout=1);
}else if(type(Var)>0) fctrtos(P|dviout=1);
else if(isdif(P)!=0) fctrtos(P|var="dif",dviout=1);
else fctrtos(P|dviout=1);
return;
}else if(T==4){
if(type(Var)==4 || type(Var)==7){
S=ltotex(P|opt=Var);
if(Var=="text"){
dviout(S);
return;
}
}else{
for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
LL=car(L);
if(type(LL)==4){
if(F==0){
T=type(LL[0]);
if(T==4) F=2; /* [[[? */
else if(T==1 || T==0) F=1; /* [[num,.. */
}
if(F==1){
if(length(LL)!=2 || !isint(LL[0]) || LL[0]<0 || type(LL[1])>3)
F=-1; /* [[num,rat],[num,rat],...] */
}else if(F==2){
for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
LLL=car(LLT); /* [[[num,rat],[num,rat],...],[[..],..]],....] */
if(length(LLL)!=2 || !isint(LLL[0]) || LLL[0]<0 || type(LLL[1])>3)
F=-1;
}
}
}else if((F==0 || F==7) && type(LL)==7){
F=7;
}else F=-1;
}
if(F==1) S=ltotex(P|opt="spt");
else if(F==2){
M=mtranspose(lv2m(S));
show(M|sp=1); /* GRS */
return;
}else if(F==7) S=ltotex(P|opt="spts");
else{
for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
LL=car(L);
if(type(LL)!=4){
F=-1; break;
}
for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
T=type(LLL=car(LLT));
if(T<7 && T!=4) F0++;
else if(T==7){
if(str_char(LLL,0,"\\")<0) F1++;
else F2++;
}else F=-1;
}
}
}
if(F==0 && F0>0 && (F1+F2)>0){ /* list of list of eq and str */
if(F2>0) S=ltotex(P|opt=["cr","spts0"],str=1);
else S=ltotex(P|opt=["cr","spts"]);
}
}
}else if(T==7){
if(Var=="raw" ||
(Var !="eq" && str_chr(P,0,"\\")<0 && str_char(P,0,"^")<0 && str_char(P,0,"_")<0
&& str_char(P,0,"&")<0)){
dviout(P+"\n\n");
return;
}
}
dviout(S|eq=5);
}
/* options : eq = 1 - 8, clear=1, keep=1, delete=1, title=s,
fctr=1 */
def dviout(L)
{
/* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTL; */
MyEq = [
["\\[\n ","\\]"],
["\\begin{align}\n","\\end{align}"],
["\\begin{gather}\n ","\\end{gather}"],
["\\begin{multline}\n ","\\\\[-15pt]\\end{multline}"],
["\\begin{align}\\begin{split}\n &","\\end{split}\\end{align}"],
["\\begin{align*}\n &","\\end{align*}"],
["\\begin{gather*}\n ","\\end{gather*}"],
["\\begin{equation}\n ","\\end{equation}"]
];
if(!chkfun("print_tex_form", "names.rr"))
return 0;
Home=getenv("HOME");
if(type(Home)!=7) Home="";
Dir=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
Dir=str_subst(Dir,"\\","/");
Dirout=Dir+(AMSTeX?"/out.tex":"/out0.tex");
Risaout=(AMSTeX)?"risaout":"risaout0";
Dirisa=Dir+"/"+Risaout+".tex";
Viewer="dviout";
SV=["c:/w32tex/dviout","c:/dviout"];
Risatex=str_subst(AMSTeX?DVIOUTA:DVIOUTL,
["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
if(isMs() && !access(Risatex)){
for(TV=SV; TV!=[]; TV=cdr(TV)){
VV=car(TV)+"/dviout.exe";
if(access(VV)){
Viewer=str_subst(VV,"/","\\");
break;
}
}
output(Risatex);
print("cd \""+str_subst(Dir,"/","\\")+"\"");
print("latex -src=cr,display,hbox,math,par "+Risaout);
print("start "+Viewer+" -1 \""+Dr+"\\tex\\"+Risaout+"\" 1000");
output();
}
if(access(Dirisa) == 0){
D0="\""+(isMs()?str_subst(Dir,"/","\\")+"\"":Dir);
shell("mkdir "+D0);
output(Dirisa);
if(AMSTeX){
print("\\documentclass[a4paper]{amsart}");
print("\\usepackage{amsmath,amssymb,amsfonts}");
}else
print("\\documentclass[a4paper]{article}");
print("\\pagestyle{empty}\n\\begin{document}\n\\thispagestyle{empty}");
print(AMSTeX?"\\input{out}\n\\end{document}":"\\input{out0}\n\\end{document}");
output();
}
if((K = getopt(delete)) >= 1){ /* delete */
LC = 0;
if(type(K) == 1 && K > 10) K = 10;
if(type(K) == 4){
K = qsort(K);
LC = 1; /* specific lines */
}
Done = 1;
Id = open_file(Dirout);
if(Id >= 0){
Buf = Buf0 = Buf1 = Key = "";
PE = 0;
if(type(K) == 1)
BufE = newvect(K--);
Dout = Dirout+"0";
remove_file(Dout);
output(Dout);
while((S = get_line(Id)) != 0){
if(LC){
while(K != [] && car(K) < LC)
K = cdr(K);
if(K == [] || car(K) > LC)
output(S);
}
if(Key == ""){
if((P0 = str_str(S,"\\begin{")) == 0){
Key = sub_str(S,7,str_str(S,"}")-1);
if(findin(Key,["align", "gather","multline", "equation"]) < 0)
Key = "";
else{
Key = "\\end{"+Key+"}";
if(!LC){
if(Buf != ""){
if(PE < K)
BufE[PE++] = Buf1+Buf;
else{
if(K > 0){
print(BufE[0]);
for(I = 1; I < K; I++)
BufE[I-1]=BufE[I];
BufE[K-1] = Buf1+Buf;
}else
print(Buf1+Buf);
Done = 0;
}
Buf1 = Buf0;
Buf = Buf0 ="";
}
}
}
}
if(Key == "" && !LC) Buf0 += S;
}
if(Key != ""){
if(!LC) Buf += S;
if(str_str(S,Key) >= 0){
Key = "";
if(LC) LC++;
}
}
}
output();
close_file(Id);
}
if(Done==0){
Id = open_file(Dout);
if(Id >= 0){
remove_file(Dirout);
output(Dirout);
while((S = get_line(Id)) != 0)
print(S,0);
output();
close_file(Id);
}
remove_file(Dout);
}else L=" ";
}
if(getopt(clear) == 1 || Done == 1){ /* clear */
remove_file(Dirout);
if(L == "" || L == " "){
output(Dirout);
print("\\centerline{Risa/Asir}");
output();
}
}
if(L != " "){
Eqo = getopt(eq);
Fc = getopt(fctr);
if(Fc == 1 && (type(L) == 2 || type(L) == 3)){
L = fctrtos(L|TeX=1);
if(type(L) == 4)
L = "\\fact{"+L[0]+"}{"+L[1]+"}";
if(type(Eqo) != 0)
Eqo=0;
}
if(type(L) != 4 || getopt(mult) != 1)
L = [L];
if(Eqo<1 || Eqo>8)
Eqo = (AMSTeX==1)?TeXEq:1;
Title = getopt(title);
if(type(Title) == 7){
output(Dirout);
print(Title);
output();
}
Sb = getopt(subst);
for( ; L != []; L = cdr(L)){
Eq = 1;
if(type(LT=car(L)) != 7 && type(LT) != 21)
LT = my_tex_form(LT);
else if(type(getopt(eq)) < 0)
Eq = 0;
if(type(Sb) == 4)
LT = str_subst(LT,Sb[0],Sb[1]);
output(Dirout);
if(Eq == 1 && Eqo >= 1 && Eqo <= 8){
mycat0([MyEq[Eqo-1][0],LT,"%"],1);
print(MyEq[Eqo-1][1]);
}
else print(LT);
output();
}
}
if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTL,0," ")<0)
Risatex="\""+Risatex+"\"";
if(getopt(keep) != 1) shell(Risatex);
return 1;
}
def rtotex(P)
{
S = my_tex_form(P);
return (str_len(S) == 1)?S:"{"+S+"}";
}
def mtotex(M)
{
/* extern TexLim; */
MB=mat(["(",")","p"],["\\{","\\}","B"],["[","]","b"],["|","|","v"],
["\\|","\\|","V"], [".",".",""]);
if(type(MT=getopt(mat))==7){
MT=findin(MT,["p","B","b","v","V",""]);
if(MT<0) MT=0;
}
else MT=0;
MT=MB[MT];
if((F=getopt(small))!=1 && F!=2) F=0;
Lim=getopt(lim);
if(type(Lim)==1){
if(Lim<30 && Lim!=0) Lim = TexLim;
}else Lim=0;
FL=getopt(len);
Rw=getopt(raw);
Sp=getopt(sp);
Idx=getopt(idx);
if(type(Idx)==4) Idx=ltov(Idx);
if(type(Idx)==6 && length(Idx)==0) Idx=-1;
Var=getopt(var);
if(Lim>0) FL=1;
Null=getopt(null);
if(Null!=1 && Null!=2) Null=0;
if(type(M)!=6) return monototex(M);
S=size(M);
if(FL==1){
L=newmat(S[0],S[1]); LL=newvect(S[1]);
}
SS=newmat(S[0],S[1]);
for(I=0; I<S[0]; I++){
for(J=0; J<S[1]; J++){
if(type(P=M[I][J])<=3){
if(P!=0 || Null == 0 || (Null==2 && I==J)){
SS[I][J]=(type(Var)>1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0);
}
}else if(type(P)==6){
ST= mtotex(P|small=1,len=1);
SS[I][J]=ST[0];
L[I][J]=ST[1];
}else if(type(P)==7){
if(Rw==1) SS[I][J]=P;
else SS[I][J]="\\text{"+P+"\}";
}else if(type(P)==4 && length(P)==2 && P[0]>0 && (Sp==1 || Sp==2)){
if(P[0]==1){
SS[I][J]=fctrtos(P[1]|TeX=2,lim=0);
}else{
ST=my_tex_form(P[0]);
if(Sp==2) ST="("+ST+")";
SS[I][J]="["+fctrtos(P[1]|TeX=2,lim=0)+"]_";
if(str_len(ST)<2) SS[I][J]+=ST;
else SS[I][J]+="{"+ST+"}";
}
}else
SS[I][J]=my_tex_form(P);
if(FL==1) L[I][J]=texlen(SS[I][J]);
}
}
if(Lim>0 || FL==1){
for(LLL=J=0; J<S[1];J++){
for(I=K=0; I<S[0];I++){
if(K<L[I][J]) K=L[I][J];
}
LLL+=(LL[J]=K);
}
}
if(Lim>0){
if(F==2 && LLL>Lim-2*S[1]-2) F=1;
if(F==1)
Lim=idiv(Lim*6,5);
if(LLL<=Lim-(2-F)*S[I]-2) Lim=0;
}
Mat=(F==1)?"smallmatrix}":"matrix}";
if(F==1) Out=str_tb("\\left"+MT[0]+"\\begin{",0);
else Out=str_tb((Lim==0)?"\\begin{"+MT[2]:"\\left"+MT[0]+"\\begin{",0);
Out = str_tb(Mat,Out);
for(I=II=LT=0; II<=S[0]; II++){
if(Lim==0) II=S[0];
if(II<S[0]){
K=LL[II]+(2-F);
if(I==II){
LT+=K;
continue;
}
if(LT+K<Lim-2) continue;
LT=K;
}
for(I0=I; I<II; I++){
if(I==I0){
str_tb((I==0)?
"\n ":
"\\right.\\\\\n \\allowdisplaybreaks\\\\\n &\\ \\left.\\begin{"+Mat+"\n ", Out);
if(Idx==1||Idx==0||type(Idx)==5){
for(J=I; J<II; J++){
if(type(Idx)!=4)
str_tb("("+rtostr(J+Idx)+")",Out);
else{
JJ=length(Idx)-1;
if(J<JJ) JJ=J;
str_tb(my_tex_form(Idx[JJ]),Out);
}
if(J<II) str_tb(" & ",Out);
}
str_tb("\\\\\n ",Out);
}
}
else str_tb("\\\\\n ",Out);
for(J=0; J<S[1]; J++){
if(J!=0) str_tb(" & ",Out);
if(type(SS[I][J])==7) str_tb(SS[I][J],Out);
}
}
Out=str_tb("\n\\end{", Out);
if(II==S[0]) Out=str_tb((Lim==0&&F!=1)?MT[2]+Mat:Mat+"\\right"+MT[1],Out);
else Out=str_tb(Mat+"\\right.",Out);
}
SS = str_tb(0,Out);
if(FL!=1) return SS;
if(F==1) LLL=idiv((LLL+S[1])*5+13,6);
else LLL+=2*(1+S[1]);
return [SS,LLL];
}
def sint(N,P)
{
if(type(N)>1)
return mtransbys(sint,N,[P]);
if(type(N)!=1) return N;
X=rint(N*10^P);
return ((X+1.0)-1.0)/10^P;
}
def xyproc(F)
{
if(F==1) return "\\begin{xy}\n";
else if(F==0) return "\\end{xy}\n";
if(type(F)==7){
F=xyproc(1)+F+xyproc(0);
if(getopt(dviout)==1) dviout(F);
else return F;
}
}
def xypos(P)
{
if(type(P[0])==7)
S="\""+P[0]+"\"";
else{
X=sint(P[0],4); Y=sint(P[1],4);
S="("+rtostr(X)+","+rtostr(Y)+")";
}
if(length(P)>2 && (PP=P[2])!=""){
S=S+" *";
if(type(PP)==4 && length(PP)==2 && type(PP[0])==7){
S=S+PP[0];
PP=PP[1];
}
if(type(PP)==4 && type(PP[0])==7){
S+="\\txt"; PP=PP[0];
}
if(type(PP)!=7) PP=my_tex_form(PP);
S=S+"{"+PP+"}";
}
if(length(P)>3){
if(type(P[3])==7) S=S+"=\""+P[3]+"\"";
if(length(P)>4 && type(P[4])==7) S=S+P[4];
}
return S;
}
def xyput(P)
{
if((type(Sc=getopt(scale))==1 && Sc!=1) || type(Sc)==4){
if(type(Sc)==1) Sc=[Sc,Sc];
Sx=Sc[0];Sy=Sc[1];
P1=cons(Sy*P[1],cdr(cdr(P)));
P=cons(Sx*P[0],P1);
}
return "{"+xypos(P)+"};\n";
}
def xyline(P,Q)
{
return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n";
}
def xylines(P)
{
Lf=getopt(curve);
if(type(Lf)!=1) Lf=0;
SS=getopt(opt);
if(type(SS)!=7){
if(Lf==0) SS="@{-}";
else SS="";
}
if(type(Sc=getopt(scale))==1 || type(Sc)==4){
if(type(Sc)==1) Sc=[Sc,Sc];
Sx=Sc[0];Sy=Sc[1];
if(Sx!=1 || Sy!=1){
for(PP=[], P0=P; P0!=[]; P0=cdr(P0)){
PT=car(P0);
if(type(PT)!=4 || type(PT[0])!=1) PP=cons(PT,PP);
else{
P1=cons(Sy*PT[1],cdr(cdr(PT)));
PP=cons(cons(Sx*PT[0],P1),PP);
}
}
P=reverse(PP);
}
}
Cl=getopt(close);
if((Vb=getopt(verb))!=1) Vb=0;
if(type(Lf)!=1 || Lf==0){ /* lines */
Out = str_tb(0,0);
for(PT=P; PT!=[]; ){
PS1=car(PT);
PT=cdr(PT);
if(PT==[]){
if(Cl==1) PS2=car(P);
else PS2=0;
}else PS2=car(PT);
str_tb(xyarrow(PS1,PS2|opt=SS),Out);
}
}else if(Lf==2){ /* B-spline */
Out = str_tb("{\\curve{",0);
for(PT=P;PT!=[];PT=cdr(PT)){
if(car(PT)==0){
str_tb("}};\n{\\curve{",Out);
continue;
}
if(PT!=P) str_tb("&",Out);
str_tb(xypos([car(PT)[0],car(PT)[1]]),Out);
}
str_tb("}};\n",Out);
for(I=0;I<2;I++){
Q=car(P);
if(length(Q)>2)
str_tb(xyput(Q),Out);
P=reverse(P);
}
}else{ /* extended Bezier */
RTo=getopt(ratio);
if(type(RTo)!=1 || RTo>1.5 || RTo<0.001) RTo=0;
if(Cl==1){
PR=reverse(P);
PT=car(PR);
PR=cons(P[0],PR);
PR=cons(P[1],PR);
P=cons(PT,reverse(PR));
}else if(Cl==-1) Cl=1;
Out=str_tb(0,0);
for(P2=P3=0,PT=P;;){
P1=P2;P2=P3;P3=P4;
P4=(PT==[])?0:car(PT);
if(PT==[] && (Cl==1 || P3==0)) break;
PT=cdr(PT);
if(P3==0) str_tb("%\n", Out);
if(P2==0 || P3==0 || (Cl==1 && P1==0)) continue;
L=[P3];
X=P3[0]-P2[0];Y=P3[1]-P2[1];
RT=(RTo==0)? RT=0.39:RTo;
DL=DL2=1;
if(P4!=0){
XD=P4[0]-P2[0];YD=P4[1]-P2[1];
if(XD==0 && YD==0) continue;
if(RTo==0 && P1!=0 && (P3[0]!=P1[0] || P3[1]!=P1[1])){
XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];
DL=dsqrt(XD^2+YD^2); DL2=dsqrt(XD2^2+YD2^2);
Cos=(XD*XD2+YD*YD2)/(DL*DL2);
RT=2/(3*dsqrt((1+Cos)/2)+3);
}
R=dsqrt((X^2+Y^2)/(XD^2+YD^2))*RT*2*DL2/(DL+DL2);
L=cons([P3[0]-R*XD,P3[1]-R*YD],L);
}
if(P1!=0){
XD=P3[0]-P1[0];YD=P3[1]-P1[1];
if(XD==0 && YD==0) continue;
R=dsqrt((X^2+Y^2)/(XD^2+YD^2))*RT*2*DL/(DL+DL2);
L=cons([P2[0]+R*XD,P2[1]+R*YD],L);
}
L=cons([P2[0],P2[1]],L);
if(Vb==1){
if(P4!=0 && PT!=[]) Vbb=2;
else Vbb=1;
}else Vbb=0;
str_tb(xybezier(L|opt=SS,verb=Vbb),Out);
}
}
S=str_tb(0,Out);
if(getopt(dviout)!=1) return S;
xyproc(S|dviout=1);
}
def xy2graph(F0,N,Lx,Ly,Lz,A,B)
{
/* (x,y,z) -> ( -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */
if(N==0 || N>100 || N<-100) N=-16;
if(N<0){
N=-N;N1=-1;N2=NN+1;
}else{
N1=0;N2=NN=N;
}
if(type(Sc=getopt(scale))!=1 && type(Sc)!=4) Sc=1;
if(type(Vw=getopt(view))!=1) Vw=0;
if(type(Raw=getopt(raw))!=1) Raw=0;
if(type(M1=getopt(dev))==1) M2=M1;
else if(type(M1)==4){
M2=M1[1];M1=M1[0];
}else M1=0;
if(type(M3=getopt(acc))!=1 ||(M3<0.5 && M3>100)) M3=1;
if(M1<=0) M1=16;
if(M2<=0) M2=16;
OL=[["scale",Sc]];
if(Raw==1) OL=cons(["raw",1],OL);
Sh=1;F1=F0;
L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]);
if((A0=A)>180) A-=360;
if(A>90){ /* x -> y, y -> -x */
Sh=2;A-=90;F1=mulsubst(F0,[[x,y],[y,-x]]);
LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;
}else if(A<0){
if(A<-90){
Sh=3;A+=180; F1=subst(F0,x,-x,y,-y);
Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];
}else{
Sh=4;A+=90; F1=mulsubst(F0,[[x,-y],[y,x]]);
LL=Ly;Ly=[-Lx[1],-Lx[0]];Ly=LL;
}
}
A=deval(@pi*A/180); B=deval(@pi*B/180);
if(A==0) A=@pi/3;
if(B==0) B=@pi/6;
Dev=N*M1; NN=N*M2;
Ac=deval(cos(A)); As=deval(sin(A));
if(Ac<=0.087 || As<=0.087){
mycat(["Unsuitable angle",A0,"(6-th argument)!"]);
return -1;
}
Bc=deval(cos(B)); Bs=deval(sin(B));
if(Bc<0){
mycat("Unsuitable angle (7-th argument)!");
return -1;
}
X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1];XD=(X1-X0)/Dev;
Bsc=Bs*Ac;Bss=Bs*As;
F=Bc*F1-Bsc*x-Bss*y;
Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN;
if(type(Err=getopt(err))==1)
F=subst(F,x,x+Err*Dx/1011.23,y,y+Err*Dx/1101.34);
Out=str_tb(0,0);
for(KC=0; KC<=1; KC++){
Z0=newvect(Dev+1); Z1=newvect(Dev+1); ZF=newvect(Dev+1);
for(I=0; I<=NN; I++){
FV=I%M2;
if(KC==0){
X=x; Y=Ly[1]-I*Dy; LX=Lx; DD=Dx; G=subst(F,y,Y);
if(!FV) str_tb(["%y=",rtostr(Y),"\n"],Out);
}else{
X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=subst(F,x,X,y,Y);
if(!FV) str_tb(["%x=",rtostr(X),"\n"],Out);
}
XX=-As*X+Ac*Y; A1=coef(XX,1,x); A0=coef(XX,0,x); /* XX = A1*x + A0, x = (XX-A0)/A1 */
if(!FV && Vw==1){
str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc),Out);
continue;
}
V=VT=LX[1];
J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD;
if(J0<J1){
J0=ceil(J0); J1=floor(J1); JD=1; /* fixed x: y: dec => (x,z):(dec,inc) */
}else{
J0=floor(J0); J1=ceil(J1); JD=-1; /* fixed y: x: dec => (x,z):(inc,inc) */
}
for(FF=1,J=J1;;J-=JD){
V1=VT;
VT=(X0+J*XD-A0)/A1; VV=deval(subst(G,x,VT)); /* J -> V */
if(ZF[J]==0 || VV<=Z0[J] || VV>=Z1[J]){ /* visible */
if(FF==0){
V0=(VT+V1)/2;
if(!FV && Vw==-1 && Raw!=1) /* draw doted line */
str_tb(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|opt="~*=<3pt>{.}",scale=Sc),Out);
V=V0;
}
if(ZF[J]==0){
ZF[J]=1; Z0[J]=Z1[J]=VV;
}else if(VV<=Z0[J]) Z0[J]=VV;
else Z1[J]=VV;
FF=1;
}else{
if(FF==1){
V0=(VT+V1)/2;
K=ceil(M3*(V-V0)/(M2*DD));
if(N1<0) K=-K;
if(!FV)
str_tb(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OL),Out);
V=V0;
}
FF=0;
}
if(J==J0) break;
}
if(FV) continue;
V0=Lx[0];K=ceil(M3*(V-V0)/(M2*DD));
if(N1<0) K=-K;
if(FF==1)
if(Raw!=1) str_tb(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OL),Out);
else if(Vw==-1 && Raw!=1)
str_tb(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|opt="~*=<3pt>{.}",scale=Sc),Out);
}
}
LZ=Lz;
if(type(Ax=getopt(ax))==4 || type(Ax)==1){
FC=0;
if(type(Ax)==4){
LZ=Ax;
if(length(Ax)==3) FC=Ax[2];
}
P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*LZ[0]-Bsc*Lx[1]-Bss*Ly[1]]);
Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]);
Vy=newvect(2,[Ac*(Lx[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]);
Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]);
str_tb(xylines([vtol(P0),vtol(P0+Vx)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vz),vtol(P0+Vx+Vz)]|option_list=OL),Out);
if(Bs>0){
str_tb(xylines([vtol(P0+Vy+Vz),vtol(P0+Vx+Vy+Vz)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vx+Vz),vtol(P0+Vx+Vy+Vz)]|option_list=OL),Out);
}else{
str_tb(xylines([vtol(P0+Vy),vtol(P0+Vx+Vy)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vx),vtol(P0+Vx+Vy)]|option_list=OL),Out);
}
str_tb(xylines([vtol(P0),vtol(P0+Vy)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vz),vtol(P0+Vy+Vz)]|option_list=OL),Out);
str_tb(xylines([vtol(P0),vtol(P0+Vz)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vx),vtol(P0+Vx+Vz)]|option_list=OL),Out);
str_tb(xylines([vtol(P0+Vy),vtol(P0+Vy+Vz)]|option_list=OL),Out);
if(FC>0 && Raw!=1){
if(Bs>0){
LL=L[Sh%4];
S="("+rtostr(LL[0])+","+rtostr(LL[1])+","+rtostr(LZ[0])+")";
str_tb(xyput([P0[0],P0[1],["+!U",S]]|scale=Sc),Out);
LL=L[(Sh+2)%4];
S="("+rtostr(LL[0])+","+rtostr(LL[1])+","+rtostr(LZ[1])+")";
Q=P0+Vx+Vy+Vz;
str_tb(xyput([Q[0],Q[1],["+!D",S]]|scale=Sc),Out);
}else{
LL=L[(Sh+2)%4];
S="("+rtostr(LL[0])+","+rtostr(LL[0])+","+rtostr(LZ[1])+")";
Q=P0+Vx+Vy;
str_tb(xyput([Q[0],Q[1],["+!U",S]]|scale=Sc),Out);
LL=L[Sh%4];
S="("+rtostr(LL[0])+","+rtostr(LL[1])+","+rtostr(LZ[1])+")";
Q=P0+Vz;
str_tb(xyput([Q[0],Q[1],["+!D",S]]|scale=Sc),Out);
}
if(FC>1){
LL=L[(Sh+1)%4];
S="("+rtostr(LL[0])+","+rtostr(LL[1])+","+rtostr(LZ[0])+")";
Q=P0+Vx;
str_tb(xyput([Q[0],Q[1],["+!L",S]]|scale=Sc),Out);
LL=L[(Sh+3)%4];
S="("+rtostr(LL[0])+","+rtostr(LL[1])+","+rtostr(LZ[0])+")";
Q=P0+Vy;
str_tb(xyput([Q[0],Q[1],["+!R",S]]|scale=Sc),Out);
}
}
}
S=xyproc(str_tb(0,Out));
if(type(Dvi=getopt(dviout))!=1) return S;
if(Dvi==2){
T="("+my_tex_form(L[3][0])+"\\le x\\le "+my_tex_form(L[1][0])+",\\,"+
my_tex_form(L[3][1])+"\\le y\\le "+my_tex_form(L[1][1])+")";
dviout("z="+my_tex_form(F0)+"\\ \\ "+T|eq=1,keep=1);
dviout(S|eq=8);
}else dviout(S);
}
def xygraph(F,N,LT,LX,LY)
{
if(N==0) N=32;
if(N<0){
N=-N;
N1=-1; N2=N+1;
}else{
N1=0; N2=N;
}
if(length(LT)==3 && isvar(LT[0])==1){
TT=LT[0]; LT=cdr(LT);
}else TT=x;
TD=(LT[1]-LT[0])/N;
if(type(Mul=getopt(scale))!=1){
if(type(Mul)==4){
MulX=Mul[0]; MulY=Mul[1];
}else MulX=MulY=1;
}else MulX=MulY=Mul;
if(type(F)!=4){
if(getopt(rev)!=1){
F1=TT; /* LX[0]+(LX[1]-LX[0])*(TT-LT[0])/(TD*N); */
F2=F;
}else{
F1=F;
F2=TT; /* LY[0]+(LY[1]-LY[0])*(TT-LT[0])/(TD*N); */
}
}else{
F1=F[0]; F2=F[1];
}
Dn=dn(F1)*dn(F2);
V=[];
if(length(LT)>2){
for(PT=LT;PT!=[]; PT=cdr(PT)){
T=car(PT);
if(deval(subst(Dn,TT,T))==0){
V=cons(0,V); continue;
}
X=deval(subst(F1,TT,T)); Y=deval(subst(F2,TT,T));
if(X<LX[0] || X>LX[1] || Y<LY[0] || Y>LY[1]) V=cons(0,V);
else cons([MulX*X,MulY*Y],V);
}
N2=N1-1;
}
if(F1==0 && F2==0) N2=N1-1;
if(type(Err=getopt(err))==1)
Dn=subst(Dn,TT,TT+Err*TD/1001.23);
for(I=N1; I<=N2; I++){
T=LT[0]+I*TD;
if(deval(subst(Dn,TT,T))==0){
V=cons(0,V); continue;
}
X=deval(subst(F1,TT,T)); Y=deval(subst(F2,TT,T));
if(X<LX[0] || X>LX[1] || Y<LY[0] || Y>LY[1]){
/*
if(V!=[] && V[0]!=0){
VX=V[0][0]/MulX; VY=V[0][1]/MulY;
if(X>=LX[0] && X<=LX[1]){
if(Y<LY[0]){
X=(X*(VY-LY[0])+VX*(LY[0]-Y))/(VY-Y);
Y=LY[0];
}else{
X=(X*(LY[1]-VY)+VX*(Y-LY[1]))/(Y-VY);
Y=LY[1];
}
V=cons([MulX*X,MulY*Y],V);
}else if(Y>=LY[0] && Y<=LY[1]){
if(X<LX[0]){
Y=(Y*(VX-LX[0])+VY*(LX[0]-X))/(VX-X);
X=LX[0];
}else{
Y=(Y*(LX[1]-VX)+VY*(X-LX[1]))/(X-VX);
X=LX[1];
}
V=cons([MulX*X,MulY*Y],V);
}
}
*/
/*
for(J=0; J<7; J++){
T-=TD/8;
if(deval(subst(Dn,TT,T))==0) continue;
X=deval(subst(F1,TT,T)); Y=deval(subst(F2,TT,T));
if(X>=LX[0] && X<=LX[1] && Y>=LY[0] && Y<=LY[1]){
V=cons([MulX*X,MulY*Y],V);
break;
}
}
*/
V=cons(0,V);
}
else V=cons([MulX*X,MulY*Y],V);
}
V=reverse(V);
if(getopt(raw)==1) return V;
if(type(C=getopt(ratio))!=1) C=0;
if(type(Opt=getopt(opt))!=7) Opt=0;
if(type(Vb=getopt(verb))!=1) Vb=0;
if(N1<0) S=xylines(V|curve=1,close=-1,opt=Opt,ratio=C,verb=Vb);
else S=xylines(V|curve=1,opt=Opt,ratio=C,verb=Vb);
if(type(Ax=getopt(ax))==4){ /* draw axis */
Adx0=Ady0=0; Adx1=Ady1=1; LOp="@{-}"; LxOp="+!U"; LyOp="+!R"; LxOO="+!UR";
if(type(AxOp=getopt(axopt))>0){
if(type(AxOp)==1){
if(AxOp>0) Adx1=Ady1=AxOp;
else if(AxOp<0){
Adx1=Ady1=0; Adx0=Ady0=AxOp;
}
}else if(type(AxOp)==4){
if(type(T=car(AxOp))==4 && length(AxOp)>2){
if(type(T)==7){
LxOp=T; LyOp=AxOp[2];
}else if(type(T)==4){
Ay0=T[0]; Ay1=T[1]; Ax0=AxOp[1][0]; Ax1=AxOp[1][1];
if(length(T)>2) LxOp=T[2];
if(length(AxOp[1])>2) LyOp=AxOp[1][2];
}
}
if(length(AxOp)>2 && type(AxOp[2])==7) LxOO=AxOp[2];
if(length(AxOp)>3 && type(AxOp[3])==7) LOp=AxOp[3];
}
if(type(AxOp)==7) LOp=AxOp;
}
if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */
S=S+xyarrow([MulX*Ax[0],MulY*LY[0]],[MulX*Ax[0],MulY*LY[1]]|opt=LOp);
if(length(Ax)>2){
D=Ax[2];
if(type(D)==1 && D>0){
I0=ceil((LX[0]-Ax[0])/D); I1=floor((LX[1]-Ax[0])/D);
for(DD=[],I=I0; I<=I1; I++){
if(length(Ax)<5) DD=cons(I*D,DD);
else if(Ax[4]==1) DD=cons([I*D,I*D],DD);
else if(Ax[4]==2) DD=cons([I*D,I],DD);
}
D=DD;
}
for(;D!=[]; D=cdr(D)){
T=car(D);
if(type(T)==4) T=car(T);
X=MulX*(T+Ax[0]); Y=MulY*Ax[1];
if(T!=0) S=S+xyline([X,Y+Ady0],[X,Y+Ady1]);
if(type(car(D))==4){
if(T!=0) SS=xypos([X,Y+Ady0,[LxOp,D[0][1]]]);
else SS=xypos([X,Y+Ady0,[LxOO,D[0][1]]]);
S=S+"{"+SS+"};\n";
}
}
}
}
if(Ax[1]>=LY[0] && Ax[1]<=LX[1]){ /* draw marks on y-axis */
S=S+xyarrow([MulX*LX[0],MulY*Ax[1]],[MulX*LX[1],MulY*Ax[1]]|opt=LOp);
if(length(Ax)>3){
D=Ax[3];
if(type(D)==1 && D>0){
I0=ceil((LY[0]-Ax[1])/D); I1=floor((LY[1]-Ax[0])/D);
for(DD=[],I=I0; I<=I1; I++){
if(length(Ax)<5) DD=cons(I*D,DD);
else if(I!=0 && Ax[4]==1) DD=cons([I*D,I*D],DD);
else if(I!=0 && Ax[4]==2) DD=cons([I*D,I],DD);
}
D=DD;
}
for(;D!=[]; D=cdr(D)){
T=car(D);
if(type(T)==4) T=car(T);
X=MulX*Ax[0]; Y=MulY*(T+Ax[1]);
if(T!=0) S=S+xyline([X+Adx0,Y],[X+Adx1,Y]);
if(type(car(D))==4) S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]);
}
}
}
}
if(getopt(dviout)!=1) return S;
xyproc(S|dviout=1);
}
def xyarrow(P,Q)
{
if(P==0) return "%\n";
if(Q==0) return "";
S="{"+xypos(P)+" \\ar";
SS=getopt(opt);
if(type(SS)==7) S=S+SS;
return S+" "+xypos(Q)+"};\n";
}
def xybezier(L)
{
LS=length(L);
if(LS==0) return "";
S="{"+xypos(L[0])+";"+xypos(L[LS-1])+"\n";
S = S+"**\\crv{";
if(type(Opt=getopt(opt))==7) S=S+Opt;
for(I=1; I<LS-1;I++){
if(I>1) S=S+"&";
S=S+xypos([L[I][0],L[I][1]]);
}
S=S+"}};\n";
if((Vb=getopt(verb))==1 || Vb==2){
for(I=0; I<=LS-Vb; I++)
S=S+xyput([L[I][0],L[I][1],(I==0||I==LS-1)?"\\bullet":"\\times"]);
}
return S;
}
def xybox(L)
{
K=length(L);
P=L[0];Q=L[1];
if(K==2)
LL=[ P, [P[0],Q[1]], Q, [Q[0],P[1]] ];
else{
R=L[2];
LL=[ P, R, Q, [P[0]+Q[0]-R[0],P[1]+Q[1]-R[1]] ];
}
SS=getopt(opt);
if(type(SS)!=7) SS="@{-}";
return xylines(LL|opt=SS,close=1);
}
def xycirc(P,R)
{
ST=getopt(opt);
if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
}
if(type(Arg)!=4) Arg=0;
else{
Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
if(Arg1<=Arg0 || Arg0<-7 || Arg1-Arg0>7) return 0;
if(type(ST)==7)
S= xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
[P[1]-R-1,P[1]+R+1]|opt=ST);
else
S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
[P[1]-R-1,P[1]+R+1]);
if(getopt(close)==1){
S=S+xyline([0,0],
[deval(subst(R*cos(x)+P[0],x,Arg0)),deval(subst(R*sin(x)+P[0],x,Arg0))]);
S=S+xyline([0,0],
[deval(subst(R*cos(x)+P[0],x,Arg1)),deval(subst(R*sin(x)+P[0],x,Arg1))]);
}
return S;
}
S="{"+xypos([P[0],P[1]]);
if(length(P)>2){
SP=P[2];
if(type(P)!=7) SP=my_tex_form(SP);
S=S+" *+{"+SP+"}";
}
S =S+" *\\cir";
if(R!=0){
R=(R+0.1)-0.1;
S=S+"<"+rtostr(R)+"mm>";
}
S = S+"{";
if(type(ST)==7) S=S+ST;
return S+"}};\n";
}
def ptaffine(M,L)
{
if(type(Arg=getopt(deg))==1)
Arg=@pi*Arg/180;
else Arg=getopt(arg);
if(type(Arg)==2) Arg=deval(Arg);
if(type(Arg)==1)
M=M*mat([dcos(Arg),-dsin(Arg)],[dsin(Arg),dcos(Arg)]);
if(type(Sft=getopt(org))==4){
Sft=ltov(Sft);
Sft-=M*Sft;
}else Sft=0;
if(type(V=getopt(shift))==4)
Sft+=ltov(V);
for(F=0,LT=L; LT!=[]; LT=cdr(LT)){
if(type(car(LT))==4){
F=1; break;
}
}
if(F==0) return (Sft==0)?ptaffine(M,[L])[0]:ptaffine(M,[L]|shift=vtol(Sft))[0];
for(LO=[],LT=L; LT!=[]; LT=cdr(LT)){
if((P=car(LT))==0) LO=cons(0,LO);
else{V=M*ltov(P);
if(Sft!=0) V+=Sft;
LO=cons(vtol(V),LO);
}
}
return reverse(LO);
}
def ptlattice(M,N,X,Y)
{
if(type(S=getopt(scale))!=1) S=1;
if(type(Cond=getopt(cond))!=4) Cond=[];
Line=getopt(line);
if(Line==1 || Line==2) F=newmat(M,N);
else Line=0;
if(type(Org=getopt(org))==4) Org=ltov(Org);
else Org=newvect(length(X));
X=ltov(X); Y=ltov(Y);
for(L=[],I=M-1;I>=0;I--){
for(P0=P1=0,J=N-1;J>=0;J--){
P=Org+I*X+J*Y;
for(C=Cond; C!=[]; C=cdr(C))
if(subst(C,x,car(P)[0],y,car(P)[1])<0) break;
if(Line) F[I][J]=1;
else L=cons(vtol(S*P),L);
}
}
if(Line==0) return L;
for(I=M-1;I>=0;I--){
for(T0=0,T1=J=N-1;J>=0;J--){
if((K=F[I][J])!=0){
if(T0==0) T0=J;
else T1=J;
}
if(K==0 || T1==0){
if(T1<T0){
L=cons(vtol(S*(Org+I*X+T0*Y)), L);
L=cons(vtol(S*(Org+I*X+T1*Y)), L);
L=cons(0,L);
}
T0=0; T1=N-1;
}
}
}
for(J=N-1;J>=0;J--){
for(T0=0,T1=I=M-1;I>=0;I--){
if((K=F[I][J])!=0){
if(T0==0) T0=I;
else T1=I;
}
if(K==0 || T1==0){
if(T1<T0){
L=cons(vtol(S*(Org+T0*X+J*Y)), L);
L=cons(vtol(S*(Org+T1*X+J*Y)), L);
L=cons(0,L);
}
T0=0; T1=M-1;
}
}
}
return cdr(L);
}
def ptpolygon(N,R)
{
if(type(S=getopt(scale))!=1) S=1;
if(type(Org=getopt(org))!=4) Org=[0,0];
if(type(Arg=getopt(deg))==1)
Arg=(Pi=deval(@pi))*Arg/180;
else Arg=getopt(arg);
if(type(Arg)==2) Arg=deval(Arg);
if(type(Arg)!=1) Arg=0;
Arg -= Pi*(1/2+1/N);
D=Pi*2/N;
for(L=[],I=N-1; I>=0; I--)
L=cons([S*(Org[0]+R*dcos(Arg+I*D)),S*(Org[1]+R*dsin(Arg+I*D))],L);
return L;
}
def ptwindow(L,X,Y)
{
if(type(S=getopt(scale))==1){
X=[S*X[0],S*X[1]]; Y=[S*Y[0],S*Y[1]];
}
for(R=[],LT=L;LT!=[];LT=cdr(LT)){
P=car(LT);
if(P[0]<X[0] || P[0]>X[1] || P[1]<Y[0] || P[1]>Y[1])
R=cons(0,R);
else R=cons(P,R);
}
return reverse(R);
}
def ptcopy(L,V)
{
if(type(V[0])!=4) V=[V];
for(F=0,LL=[]; V!=[]; V=cdr(V)){
if(F) LL=append(LL,[0]);
F++;
LL=append(LL,ptaffine(1,L|shift=car(V)));
}
}
def average(L)
{
L=os_md.m2l(L|flat=1);
M0=M1=car(L);
for(I=SS=0, LT=L; LT!=[]; LT=cdr(LT), I++){
S+=(V=car(LT));
SS+=V^2;
if(V<M0) M0=V;
else if(V>M1) M1=V;
}
SS=dsqrt(SS/I-S^2/I^2);
S=((S+0.1)-0.1)/I;
return [S,SS,I,M0,M1];
}
def m2ll(M)
{
for(R=[],I=size(M)[0]-1; I>=0; I--)
R=cons(vtol(M[I]),R);
return R;
}
def madjust(M,W)
{
if(type(Null=getopt(null))<0) Null=0;
if(type(M)==4 && type(M[0])==4){
M=lv2m(M|null=Null);
return m2ll(madjust(M,W|null=Null));
}
S=size(M);
if(W<0){
W=-W;
T0=ceil(S[0]/W);
T1=S[1]*W;
N=newmat(T0,T1);
for(I=0; I<T0; I++){
for(K=0; K<W; K++){
II=K*T0+I;
for(J=0; J<S[1]; J++)
N[I][S[1]*K+J]=(II<S[0])?M[II][J]:Null;
}
}
}else{
T1=W;
T0=S[0]*(D=ceil(S[1]/T1));
N=newmat(T0,T1);
for(K=0; K<D; K++){
for(J=0; J<W;J++){
JJ=W*K+J;
for(I=0; I<S[0]; I++)
N[S[0]*K+I][J]=(JJ<S[1])?M[I][JJ]:Null;
}
}
}
return N;
}
def ltotex(L)
{
/* extern TeXLim; */
if(type(L)==5)
L = vtol(L);
if(type(L) != 4)
return my_tex_form(L);
Opt=getopt(opt);
Pre=getopt(pre);
Cr=getopt(cr);
if(type(Cr)!=7) Cr="\\\\\n & ";
if(type(Opt)==7) Opt= [Opt];
if(type(Opt)!=4)
Op = -1;
else{
Op=findin(Opt[0],["spt","GRS","Pfaff","Fuchs","vect","cr","text","spts","spts0",
"dform","tab", "graph"]);
Opt=cdr(Opt);
}
if(Op==0){ /* spt */
Out = str_tb("\\left\\{\n ",0);
for(CC=0; L!=[]; L=cdr(L), CC++){
if(CC>0) str_tb(",\\, ",Out);
TP=car(L);
if(Op!=0)
str_tb(my_tex_form(TP),Out);
else if(TP[0]==1)
str_tb(my_tex_form(TP[1]),Out);
else
str_tb(["[", my_tex_form(TP[1]), "]_", rtotex(TP[0])],Out);
}
str_tb("%\n\\right\\}\n",Out);
}else if(Op==1){ /* GRS */
Out = string_to_tb("\\begin{Bmatrix}\n");
if(type(Pre)==7) str_tb(Pre,Out);
MC=length(M=ltov(L));
for(ML=0, I=length(M); --I>=0; ){
if(length(M[I]) > ML) ML=length(M[I]);
}
for(I=0; I<ML; I++){
for(CC=J=0; J<MC; J++, CC++){
if(length(M[J]) <= I){
if(CC > 0) str_tb(" & ",Out);
}else if(M[J][I][0] <= 1){
if(M[J][I][0] == 0) str_tb(" & ",Out);
else
str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
}else
str_tb([((!CC)?" [":" & ["), my_tex_form(M[J][I][1]), "]_",
rtotex(M[J][I][0])], Out);
}
str_tb((I<ML-1)?"\\\\\n":"\n", Out);
}
str_tb("\\end{Bmatrix}",Out);
}else if(Op==2){ /* Pfaff */
V=monototex(Opt[0]);
Out = string_to_tb("d"+V+"= \\Biggl(");
Opt=cdr(Opt);
II=length(Opt);
for(I=0; I<II; I++){
str_tb([(I>0)?" + ":" ",mtotex(L[I]),"\\frac{d",monototex(Opt[I]),"}{",
my_tex_form(Opt[I]),(I==II-1)?"}\n":"}\n\\\\&\n"],Out);
}
str_tb(["\\Biggr)",V,"\n"],Out);
}else if(Op==3){ /* Fuchs */
Out = string_to_tb("\\frac{d");
V=my_tex_form(Opt[0]);
str_tb([V,"}{d",my_tex_form(Opt[1]),"}="] ,Out);
Opt=cdr(Opt); Opt=cdr(Opt);
II=length(Opt);
for(I=0; I<II; I++){
str_tb([(I>0)?" +":"\\Biggl(", " \\frac{",
my_tex_form(L[I]),"}{", my_tex_form(Opt[I]),"}\n"],Out);
}
str_tb(["\\Biggr)",V,"\n"],Out);
}else if(Op==4){ /* vect */
Out=str_tb(mtotex(matc(L)|lim=0),0);
}else if(Op==5 || Op==6){ /* cr or text */
Out = str_tb(0,0);
Str=getopt(str);
if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1)
Str=2;
for(I=0; L!=[]; I++, L=cdr(L)){
if(I>0) str_tb((Op==5)?Cr:"\n",Out);
LT=car(L);
if(Op==6){
if(Str==1 && type(LT)==7){
str_tb([LT," "],Out);
I=-1;
continue;
}
str_tb("$",Out);
}
if(Str>0 && type(LT)==4)
str_tb(ltotex(LT|opt=car(Opt),lim=0,str=Str),Out);
else
str_tb(my_tex_form(LT),Out);
if(Op==6) str_tb("$",Out);
}
}else if(Op==7||Op==8){ /* spts, spts0 */
if(type(Lim=getopt(lim))!=1 || (Lim<30 && Lim!=0))
Lim=TeXLim;
Str=getopt(str);
Out = str_tb(0,0);
for(K=0; L!=[]; L=cdr(L)){
LT=car(L);
S=(type(LT)==7 && Str==1)?LT:my_tex_form(LT);
if(Lim !=0){
KK=texlen(S);
if(K>0 && K+KK>Lim){
str_tb(Cr,Out);
K=0;
}
}
if(K>0){
str_tb((OP==7)?"\\ ":" ",Out);
if(type(LT)>3 && type(LT)<7) str_tb("%\n",Out);
}
str_tb(S,Out);
K+=KK;
if(OP==7) K++;
}
}else if(Op==9){ /* dform */
Out=str_tb(0,0);
for(I=0;L!=[];L=cdr(L),I++){
for(J=0,LT=car(L); LT!=[]; LT=cdr(LT),J++){
if(J==0){
if((V=car(LT))==0) continue;
if(I>0){
if(type(V)==1){
if(V<0){
str_tb("-",Out);
V=-V;
}
else str_tb("+",Out);
if(V==1 && length(LT)>1) continue;
str_tb(monototex(V),Out);
continue;
}
else str_tb("+",Out);
}
}else if(J>0) str_tb((J>1)?"\\wedge d":"\\,d",Out);
V=monototex(car(LT));
if(V<"-" || V>=".") str_tb(V,Out);
else str_tb(["(",V,")"],Out);
}
}
}
else if(Op==10 && type(L)==4 && type(car(L))==4){ /* tab */
if(type(Null=getopt(null))<0) Null="";
if(getopt(vert)==1){
M=lv2m(L|fill=Null);
L=m2ll(mtranspose(M));
}
if(type(getopt(width))==1)
L=madjust(L|fill=NULL);
LV=ltov(L);
S=length(LV);
for(I=CS=0; I<S; I++)
if(length(LV[I])>CS) CS=length(LV[I]);
if(type(Title=getopt(title))!=7) Title="";
if(type(Vline=getopt(vline))!=4) Vline=[0,CS];
else Vline=qsort(Vline);
Out=str_tb("\\begin{tabular}{",0);
if(type(Al=getopt(align))==7 && length(Al)>1){
str_tb(Al,Out);
}else{
if(type(Al)!=7 || length(Al)<1) Al="r";
for(I=0;I<=CS;I++){
if(I!=0) str_tb(Al,Out);
while(Vline!=[] && car(Vline)==I){
str_tb("|",Out);
Vline=cdr(Vline);
}
}
}
str_tb("}",Out);
if(Title!="")
str_tb("\n\\multicolumn{"+rtostr(CS)+"}{c}{"+Title+"}\\\\",Out);
if(type(Hline=getopt(hline))!=4) Hline=[0,S];
else Hline=qsort(Hline);
while(Hline!=[] && car(Hline)==0){
str_tb(" \\hline\n",Out);
Hline=cdr(Hline);
}
for(I=0; I<S; I++){
for(C=0,LT=LV[I];C<CS; C++){
if(LT!=[]){
P=car(LT);
if(type(P)!=7) P="$"+my_tex_form(P)+"$";
if(P!="") str_tb(P,Out);
LT=cdr(LT);
}
if(C<CS-1) str_tb("& ",Out);
}
str_tb("\\\\",Out);
while(Hline!=[] && car(Hline)==I+1){
str_tb(" \\hline",Out);
Hline=cdr(Hline);
}
str_tb("\n",Out);
}
str_tb("\\end{tabular}\n",Out);
}else if(Op==11){ /* graph */
Width=80; Hight=30; WRet=1/2; HMerg=2;
if(type(V=getopt(size))==4){
Width=V[0];Hight=V[1];
if(length(V)>2) WRet=V[2];
if(length(V)>3) HMerg=V[3];
}
Val=getopt(value);
if(!isint(Val)) Val=-1;
if(type(Shift=getopt(shift))!=1)
Shift=0;
if(type(Line=getopt(line))!=1){
if(type(Line)==4 && type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
Opt=Line[1]; Line=Line[0];
}else Line=0;
}else Opt="@{-}";
if(type(car(L))==4){
LL=L[1]; L=L[0];
}else LL=[];
if(Line==-1){
for(Sum=0, LT=L; LT!=[]; LT=cdr(LT)){
if((S=car(LT))<=0) return 0;
Sum+=S;
}
for(R=[],LT=L;LT!=[];LT=cdr(LT))
R=cons(car(LT)/Sum,R);
R=reverse(R);
Opt0=Opt*2/3;
Out=str_tb(xyproc(1),0);
str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out);
for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){
str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out);
T=S+RT[0]/2;
S+=RT[0];
if(LT!=[]){
if(type(SS=LT[0])==7) SS=[SS];
str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),SS]),Out);
LT=cdr(LT);
}
}
str_tb(xyproc(0),Out);
return str_tb(0,Out);
}
if(type(MX=getopt(max))!=1)
MX=0;
if(MX==0){
for(MX=0,LT=L; LT!=[]; LT=cdr(LT))
if(car(LT)>MX) MX=car(LT);
}
MX-=Shift;
S=length(L);
WStep=Width/S;
WWStep=WStep*WRet;
HStep=Hight/MX;
Out=str_tb(xyproc(1),0);
str_tb(xyline([0,0],[Width-WStep+WWStep,0]),Out);
for(I=0,LT=L;LT!=[]; LT=cdr(LT),I++){
XP=WStep*I; XPM=XP+WWStep/2; YP=(car(LT)-Shift)*HStep;
if(Line!=0){
if(I>0)
str_tb(xyarrow([XPM-WStep,YPP],[XPM,YP]|opt=Opt),Out);
if(Val!=0)
str_tb(xyput([XPM,YP+HMerg,car(LT)]),Out);
if(Line==2)
str_tb(xyput([XPM,YP,"\\bullet"]),Out);
YPP=YP;
}else if(YP!=0 || Val==1){
str_tb(xybox([[XP,0],[XP+WWStep,YP]]),Out);
if(Val!=0){
str_tb(xyput([XPM,(YP<0)?(YP-HMerg):(YP+HMerg),car(LT)]),Out);
}
}
if(LL!=[]){
if(type(LP=LL[I])==7) LP=[LP]; /* string */
str_tb(xyput([XPM,-HMerg,LP]),Out);
}
}
str_tb(xyproc(0),Out);
}
else return my_tex_form(L);
S = str_tb(0,Out);
return (getopt(small)==1)?smallmattex(S):S;
}
def str_tb(L,TB)
{
if(type(TB) == 0) TB = "";
if(L == 0)
return (type(TB) == 7)?string_to_tb(TB):tb_to_string(TB);
if(type(L) == 7)
L = [L];
else if(type(L) != 4){
erno(0);
return 0;
}
if(type(TB) <= 7)
TB = string_to_tb((type(TB)==7)?TB:"");
for(; L != []; L = cdr(L))
write_to_tb(car(L), TB);
return TB;
}
/*
def redgrs(M,T)
{
L = [zzz];
for(I=S=0,Eq=[],MT=M; MT!=[]; I++, MT=cdr(MT)){
for(J=LS=0, N=car(MT); N!=[]; N=cdr(N)){
X = makev([z,I,z,J]);
L=cons(X,L);
LS += X;
S += car(N)[1]*X;
}
Eq = cons(LS-zzz,Eq);
}
Eq = cons(S-T,Eq);
Sol= lnsol(Eq,L);
for(LS=[],S=Sol; S!=[]; S=cdr(S)){
T=car(S);
if(type(S)!=4) return 0;
LS=cons(car(S)[0],LS);
}
}
*/
/* T=0 : all reduction
=1 : construction procedure
=2 : connection coefficient
=3 : operator
=4 : series expansion
=5 : expression by TeX
=6 : Fuchs relation
=7 : All
=8 : basic
=9 : ""
=10: irreducible
=11: recurrence */
def getbygrs(M, TT)
{
/* extern TeXEq; */
if(type(M)==7) M=s2sp(M);
if(type(M) != 4 || TT =="help"){
mycat(
["getbygrs(m,t) or getbygrs(m,[t,s_1,s_2,...]|perm=?,var=?,pt=?,mat=?)\n",
" m: generalized Riemann scheme or spectral type\n",
" t: reduction, construct, connection, series, operator, TeX, Fuchs, irreducible, basic, recurrence,\n",
" All\n",
" s: TeX dviout simplify short general operator irreducible top0 x1 x2 sft\n",
"Ex: getbygrs(\"111,21,111\", [\"All\",\"dviout\",\"operator\",\"top0\"])\n"]);
return 0;
}
if(type(TT) == 4){
T = TT[0];
T1 = cdr(TT);
}else{
T = TT;
T1 = [];
}
if(type(T) == 7)
T = findin(T,["reduction","construct","connection", "operator", "series",
"TeX", "Fuchs", "All", "basic", "", "irreducible", "recurrence"]);
TeX = findin("TeX", T1);
Simp = findin("simplify", T1);
Short = findin("short", T1);
Dviout= findin("dviout", T1);
General=findin("general", T1);
Op =findin("operator", T1);
Irr =findin("irreducible", T1);
Top0 =findin("top0",T1);
X1 =findin("x1",T1);
X2 =findin("x2",T1);
Sft =findin("sft",T1);
Title = getopt(title);
Mat = getopt(mat);
if(Mat!=1 || T<0 ||(T!=0&&T!=1&&T!=5&&T!=6&&T!=8&&T!=10)) Mat = 0;
if(findin("keep",T1) >= 0)
Keep = Dviout = 1;
else Keep = 0;
if(Dviout >= 0 || T == 5) TeX = 1;
for(J = 0, MM = M; J == 0 && MM != []; MM = cdr(MM)){
for(MI = car(MM); MI != []; MI = cdr(MI)){
if(type(car(MI)) != 1 || car(MI) <= 0){
J = 1; break;
}
}
}
/* spectral type -> GRS */
if(J == 0){
for(R = [], S = J = 0, MM = M; MM != []; MM = cdr(MM), J++){
MT = qsort(car(MM));
R = cons(reverse(MT), R);
if(J == 1){
S = length(MT)-1;
if(MT[S] > MT[0]) S = 0;
}
}
M = reverse(R);
R = getopt(var);
if(type(R)<1){
for(R = [], I = J-1; I >= 0; I--)
R = cons(asciitostr([97+I]), R);
}
Sft=(Sft>=0)?1:0;
if(General < 0)
Sft=-Sft-1;
M = sp2grs(M,R,Sft|mat=Mat);
}
M = fspt(M,5);
NP = length(M);
Perm = getopt(perm);
if(type(Perm) == 4)
M = mperm(M,Perm,0);
if(T == 9){ /* "" */
if(Short >= 0)
M = chkspt(M|opt=4,mat=Mat);
return M;
}
R = [0,M];
ALL = [R];
while(type(R = redgrs(R[1]|mat=Mat)) == 4)
ALL = cons(R, ALL);
if(R < 0)
return 0;
/* TeX */
if(TeX >= 0 && !chkfun("print_tex_form", "names.rr"))
return 0;
if(Dviout >= 0 && type(Title) == 7)
dviout(Title|keep=1);
if(T == 7 && Dviout >= 0){
S=["keep","simplify"];
if(Top0 >= 0)
S = cons("top0",S);
getbygrs(M,cons(5,S)|title="\\noindent Riemann Scheme",mat=Mat);
Same = 0;
if(R > 0){
MM = getbygrs(M,8|mat=Mat); /* basic GRS */
MS = chkspt(MM|opt=0,mat=Mat); /* spectral type */
if(M != MM)
getbygrs(MM,cons(5,S)|title="Basic Riemann Scheme",mat=Mat);
else{
dviout("This is a basic Riemann Scheme.\n\n\\noindent"|keep=1);
Same = 1;
}
dviout(MS|keep=1);
}
if(chkspt(ALL[0][1]|mat=Mat)[3] != 0)
getbygrs(M,cons(6,S)|title="Fuchs condition",mat=Mat);
if(Same == 0){
M1 = M[1];
if(M1[length(M1)-1][0]==1 && Mat!=1){
M1=M[2];
if(M1[length(M1)-1][0] == 1){
getbygrs(M,cons(2,S)|title="Connection formula");
if(M1[length(M[0][0])-1][0] == 1 && R==0)
getbygrs(M,cons(11,S)|title="Recurrence relation shifting the last exponents at $\\infty$, 0, 1");
}
getbygrs(M,cons(1,S)|title="Integral representation");
getbygrs(M,cons(4,S)|title="Series expansion");
}
if(Irr < 0){
TI="Irreduciblity $\\Leftrightarrow$ any value of the following linear forms $\\notin\\mathbb Z$";
if(R > 0)
TI += " + fundamental irreducibility";
getbygrs(M,cons(10,S)|title=TI,mat=Mat);
dviout("which coorespond to the decompositions"|keep=1);
sproot(chkspt(M|opt=0),"pairs"|dviout=1,keep=1);
}
}
if(Op >= 0 && Mat!=1) getbygrs(M,cons(3,S)|title="Operator");
dviout(" ");
return 1;
}
if(T == 0 && TeX >= 0){
T = 1; TeX = 16;
}
/* Fuchs */
Fuc = chkspt(ALL[0][1]|Mat=mat)[3];
if(Fuc == 0) Simp = -1;
if(type(Fuc) == 1){
print("Violate Fuchs condition");
return 0;
}
if(T == 6){
if(Dviout >= 0) dviout(Fuc|eq=0,keep=Keep);
return (TeX >= 0)?my_tex_form(Fuc):Fuc;
}
Fuc = [Fuc];
/* Generelized Riemann scheme */
if(T == 5){
M = ltov(M);
for(ML=0, I=0; I<NP; I++){
L = length(M[I]);
if(L > ML) ML = L;
}
Out = string_to_tb("P\\begin{Bmatrix}\nx=");
if(Top0 < 0)
write_to_tb("\\infty & ",Out);
Pt = getopt(pt);
if(type(Pt) == 4){
for(J = 3; J < NP; J++){
str_tb(["& ",rtotex(car(Pt))],Out);
Pt = cdr(Pt);
}
}
else if(X2>=0)
str_tb("0 & x_2",Out);
else
str_tb((X1>=0)?"x_1 & x_2":"0 & 1",Out);
for(J = 3; J < NP; J++)
str_tb(["& x_",rtotex(J)],Out);
if(Top0 >= 0)
write_to_tb("& \\infty",Out);
write_to_tb("\\\\\n",Out);
for(I = 0; I < ML; I++){
for(CC = 0, J = (Top0 >= 0)?1:0; ; J++, CC++){
if(J == NP){
if(Top0 < 0) break;
J = 0;
}
if(length(M[J]) <= I){
if(CC > 0) write_to_tb(" & ",Out);
}else if(M[J][I][0] <= 1){
if(M[J][I][0] == 0) str_tb(" & ",Out);
else
str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
}else{
str_tb([((!CC)?"[":" & ["), my_tex_form(M[J][I][1]),
(Mat==1)?"]_{":"]_{("],Out);
str_tb([my_tex_form(M[J][I][0]),(Mat==1)?"}":")}"],Out);
}
if(Top0 >= 0 && J == 0)
break;
}
if(I == 0)
str_tb("&\\!\\!;x",Out);
str_tb("\\\\\n",Out);
}
str_tb("\\end{Bmatrix}",Out);
Out = str_tb(0,Out);
if(Dviout >= 0)
dviout(Out|eq=0,keep=Keep);
return Out;
}
/* Reduction */
if(T == 0){
if(Simp >= 0)
ALL = simplify(ALL,Fuc,4);
return reverse(ALL);
}
LA = length(ALL) - 1;
NP = length(ALL[0][1]);
/* irreducible */
if(T == 10){
for(IR=[], I = 0; I < LA; I++){
AI = ALL[I]; AIT = AI[1];
K = AI[0][0];
P = -AIT[0][K][1];
P -= cterm(P);
IR = cons(P, IR);
for(J = 0; J < NP; J++){
K = AI[0][J];
for(L = length(AIT[J]) - 1; L >= 0 ; L--){
if(L == K || AIT[J][L][0] <= AIT[J][K][0])
continue;
P = AIT[J][L][1] - AIT[J][K][1];
Q = cterm(P);
if(dn(Q)==1)
P -= Q;
IR = cons(P,IR);
}
}
}
P=Fuc[0];
Q=cterm(P);
if(type(Q)==1 && dn(Q)==1){
for(F=0,V=vars(P);V!=[];V=cdr(V)){
R=mycoef(P,1,car(V));
if(type(R)!=1 || Q%R!=0){
F=1; break;
}
}
if(F==0){
P-=Q;
Simp=0;
}
}
if(Simp >= 0){
IR=simplify(IR,[P],4);
for(R=[]; IR!=[]; IR=cdr(IR)){
P=car(IR);
Q=cterm(P);
if(dn(Q)==1) P-=Q;
R=cons(P,R);
}
IR=R;
}
for(R=[]; IR!=[]; IR=cdr(IR)){
P=car(IR);
if(str_len(rtostr(P)) > str_len(rtostr(-P)))
P = -P;
R = cons(P,R);
}
R = ltov(R);
#ifdef USEMODULE
R = qsort(R,os_md.cmpsimple);
#else
R = qsort(R,cmpsimple);
#endif
R = vtol(R);
if(TeX >= 0){
Out = string_to_tb("");
for(I=L=K=0; R!=[]; R=cdr(R),I++){
K1 = K;
RS = my_tex_form(car(R));
/* K = str_len(RS);
L += K+4; */
K = nmono(car(R));
L += K;
if(I){
if(K1 == K && L < 30)
str_tb("\\quad ",Out);
else{
L = K;
str_tb((TeXEq==5)?["\\\\%\n &"]:["\\\\%\n "],Out);
}
}
str_tb(RS,Out);
}
R = Out;
if(Dviout>=0){
dviout(R|eq=0,keep=Keep);
return 1;
}
}
return R;
}
AL = []; SS = 0;
for(I = 0; I <= LA; I++){
AI = ALL[I]; AIT = AI[1]; /* AIT: GRS */
if(I > 0){
for(S = J = 0; J < NP; J++){
GE = AIT[J][AI0[J]][1];
S += GE;
if(J == 0)
SS = [];
else
SS = cons(GE,SS);
}
SS = cons(1-Mat-S, reverse(SS));
}
AI0 = AI[0];
AL = cons([SS, cutgrs(AIT)], AL);
}
AL = reverse(AL);
AD = newvect(NP);
ALT = AL[0][1];
for(J = 1; J < NP; J++){
/* AD[J] = ALT[J][0][1]; [J][?][1] <- [J][?][0]: max */
for(MMX=0, K = KM = length(ALT[J])-1; K >= 0; K--){
if(MMX <= ALT[J][K][0]){
if(J == 1 && MMX == ALT[J][K][0])
continue;
KM = K;
MMX = ALT[J][K][0];
}
}
AD[J] = ALT[J][KM][1];
}
AL = cdr(AL);
AL = cons([vtol(AD), ALT], AL);
AL = cons([0, mcgrs(ALT, [vtol(-AD)]|mat=Mat)], AL);
if(Simp >= 0 && T != 3)
AL = simplify(AL,Fuc,4);
/* Basic */
if(T == 8){
ALT = AL[0][1];
if(TeX >= 0){
if(Dviout >= 0){
return getbygrs(ALT,["TeX","dviout","keep"]);
}
return getbygrs(ALT,"TeX");
}
if(Short >= 0)
ALT = chkspt(ALT|opt=4);
return ALT;
}
/* Construct */
if(T == 1){
if(TeX >= 0){
L = length(AL);
I = Done = 0; Out0=Out1=""; NM = DN = [];
if(TeX != 16){
AL11=AL[L-1][1][1];
AT = AL11[length(AL11)-1];
if(type(AT) == 4){
PW = (AT[0] > 1)?"":AT[1];
}else PW = AT;
}
Out = string_to_tb("");
while(--L >= 0){
if(TeX == 16){
if(Done)
write_to_tb(":\\ ", Out);
write_to_tb(getbygrs(AL[L][1],(Top0>=0)?["TeX", "top0"]:"TeX"|mat=Mat), Out);
Done = 1;
if(L != 0) write_to_tb((TeXEq==5)?
"\\\\%\n&\\leftarrow ":"\\\\%\n\\leftarrow ", Out);
}
ALT = AL[L][0];
if(TeX != 16){
V1 = (I==0)?"x":V2;
V2 = /* (I==0 && L<=2)?"s": */
"s_"+rtotex(I);
}else V1=V2="x";
JJ = (type(ALT) == 4)?length(ALT):0;
if(I > 0 && L > 0)
write_to_tb("\n ", Out);
for(Outt = "", J = 1; J < JJ; J++){
if(ALT[J] == 0) continue;
if(J == 1) Outt += V1;
else if(J == 2) Outt += "(1-"+V1+")";
else Outt += "(x_"+rtotex(J)+"-"+V1+")";
Outt += "^"+ rtotex(ALT[J]);
}
if(TeX != 16) write_to_tb(Outt, Out);
else if(Outt != "")
str_tb(["\\mathrm{Ad}\\Bigl(",Outt,"\\Bigr)"], Out);
if(JJ == 0){
if(I != 0)
Out1 = "ds_"+rtotex(I-1)+Out1;
continue;
}
if(ALT[0] == 0) continue;
Out0 += "\\int_p^{"+V1+"}";
if(TeX == 16)
str_tb(["mc_",rtotex(ALT[0])], Out);
else{
str_tb(["(",V1,"-",V2,")^",rtotex(-1+ALT[0])], Out);
AL11=AL[L-1][1][1];
AT = AL11[length(AL11)-1];
if(type(AT) == 4) AT = AT[1];
DN = cons(ALT[0]+AT+1,DN);
NM = cons(AT+1,cons(ALT[0],NM));
}
if(L != 2) Out1 += "d"+V2;
I++;
}
if(R){
if(I == 0) Ov = "x";
else Ov = "s_"+rtotex(I-1);
Out1 = "u_B("+Ov+")"+Out1;
}
if(TeX != 16){
Out0 = string_to_tb(Out0);
str_tb([Out, Out1], Out0);
Out = Out0;
NM = simplify(NM, Fuc, 4);
DN = simplify(DN, Fuc, 4);
DNT = lsort(NM,DN,"reduce");
NMT = DNT[0]; DNT = DNT[1];
if(NMT != [] && PW != ""){
write_to_tb((TeXEq==5)?"\\\\\n &\\sim\\frac{\n"
:"\\\\\n \\sim\\frac{\n", Out);
for(PT = NMT; PT != []; PT = cdr(PT))
str_tb([" \\Gamma(",my_tex_form(car(PT)), ")\n"], Out);
write_to_tb(" }{\n", Out);
for(PT = DNT; PT != []; PT = cdr(PT))
write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
write_to_tb(" }", Out);
if(R > 0) write_to_tb("C_0", Out);
write_to_tb("x^"+rtotex(PW) +"\\ \\ (p=0,\\ x\\to0)", Out);
}
}else
Out = str_tb(0, Out);
if(Dviout >= 0){
dviout(Out|eq=0,keep=Keep);
return 1;
}
return O;
}
if(Short >= 0){
for(ALL = [] ; AL != []; AL = cdr(AL)){
AT = car(AL);
ALL = cons([AT[0], chkspt(AT[1]|opt=4)], ALL);
}
AL = reverse(ALL);
}
return AL; /* AL[0][1] : reduced GRS, R==0 -> rigid */
}
if(T == 2 || T == 4 || T == 11){
for(I = (T==2)?2:1; I >= (T==11)?0:1; I--){
ALT = M[I];
if(ALT[length(ALT)-1][0] != 1){
mycat(["multiplicity for",I,":",ALT[length(ALT)-1][1],
"should be 1"]);
return;
}
}
}
LA++;
NM = DN = [];
/* Three term relation */
if(T == 11){
if(R > 0){
print("This is not rigid\n");
return 0;
}
for(I = 0; I <= LA; I++){
if(I > 0){
AI = AL[I][0]; /* operation */
if(AI[0] != 0){
DN = cons(simplify(AI1+1,Fuc,4),DN);
NM = cons(simplify(AI1+AI[0]+1,Fuc,4),NM);
}
}
ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
}
DNT = lsort(NM,DN,"reduce");
if(TeX < 0) return DNT;
NMT = DNT[0]; DNT = DNT[1];
Out = str_tb("u_{0,0,0}-u_{+1,0,-1}=\\frac{","");
for(PT = NMT; PT != []; PT = cdr(PT))
str_tb(["(",my_tex_form(car(PT)),")"], Out);
str_tb(["}\n{"],Out);
for(PT = DNT; PT != []; PT = cdr(PT))
str_tb(["(",my_tex_form(car(PT)),")"], Out);
write_to_tb("}u_{0,+1,-1}",Out);
if(Dviout >= 0){
dviout(Out|eq=0,keep=Keep);
return 1;
}
return Out;
}
AD=newvect(NP);
for(I = 0; I <= LA; I++){
if(I > 0){
AI = AL[I][0]; /* operation */
if(T == 2 && AI[0] != 0){
DN = cons(simplify(-AI2,Fuc,4), cons(simplify(AI1+1,Fuc,4),DN));
NM = cons(simplify(-AI2-AI[0],Fuc,4), cons(simplify(AI1+AI[0]+1,Fuc,4),
NM));
}
for(J = 1; J < NP; J++)
AD[J] += simplify(AI[J],Fuc,4);
}
if(T == 2){
ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
ALT = AL[I][1][2]; AI2 = ALT[length(ALT)-1][1];
if(I == 0){
C3 = AI1; C4 = AI2;
}
}
}
/* Connection */
if(T == 2){
DNT = lsort(NM,DN,"reduce");
NMT = DNT[0]; DNT = DNT[1];
if(TeX < 0) return [NMT,DNT,AD];
C0 = M[1][length(M[1])-1][1];
C1 = M[2][length(M[2])-1][1];
M = AL[0][1];
C3 = M[1][length(M[1])-1][1];
C4 = M[2][length(M[2])-1][1];
Out = str_tb(["c(0\\!:\\!", my_tex_form(C0),
" \\rightsquigarrow 1\\!:\\!", my_tex_form(C1),")"], "");
if(R > 0 && AMSTeX == 1 && (TeXEq == 4 || TeXEq == 5)){
write_to_tb("\\\\\n", Out);
if(TeXEq == 5) write_to_tb(" &", Out);
}
write_to_tb("=\\frac{\n",Out);
for(PT = NMT; PT != []; PT = cdr(PT))
write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
write_to_tb(" }{\n",Out);
for(PT = DNT; PT != []; PT = cdr(PT))
write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n",Out);
write_to_tb(" }", Out);
for(J = 3; J < length(AD); J++){
if(AD[J] == 0) continue;
str_tb(["\n (1-x_", rtotex(J), "^{-1})^", rtotex(AD[J])], Out);
}
if(R != 0)
str_tb(["\n c_B(0\\!:\\!", my_tex_form(C3),
" \\rightsquigarrow 1\\!:\\!", my_tex_form(C4), ")"], Out);
Out = tb_to_string(Out);
if(Dviout >= 0){
dviout(Out|eq=0,keep=Keep);
return 1;
}
return Out;
}
/* Series */
if(T == 4){
AL11 = AL[0][1][1];
V = AL11[length(AL11)-1][1];
S00 = -V; S01 = (R==0)?[]:[[0,0]];
S1 = S2 = [];
for(Ix = 1, ALL = cdr(AL); ALL != []; ){
ALT = ALL[0][0];
if(ALT[0] != 0){ /* mc */
for(Sum = [], ST = S01; ST != []; ST = cdr(ST))
Sum = cons(car(ST)[0], Sum);
S1 = cons(cons(S00+1,Sum), S1);
S2 = cons(cons(S00+1+ALT[0],Sum),S2);
S00 += ALT[0];
}
ALL = cdr(ALL);
for(I = 1; I < length(ALT); I++){ /* addition */
if(I == 1){
S00 += ALT[1];
if(ALL == [])
S00 = [S00];
}else{
if(ALT[I] == 0)
continue;
if(ALL != []){
S1 = cons([-ALT[I],Ix],S1);
S2 = cons([1,Ix],S2);
S01= cons([Ix,I],S01);
Ix++;
}else
S00 = cons([ALT[I],I],S00);
}
}
}
S00 = reverse(S00);
S01 = qsort(S01); S1 = qsort(S1); S2 = qsort(S2);
if(Simp >= 0){
S00 = simplify(S00,Fuc,4);
S01 = simplify(S01,Fuc,4);
S1 = simplify(S1,Fuc,4);
S2 = simplify(S2,Fuc,4);
SS = lsort(S1,S2,"reduce");
S1 = SS[0]; S2 = SS[1];
}
if(TeX >= 0){
/* Top linear power */
TOP = Ps = Sm = "";
for(TOP = Ps = Sm = "", ST = cdr(S00); ST != []; ST = cdr(ST)){
SP = car(ST);
if(SP[0] != 0){
if(SP[1] == 2)
TOP += "(1-x)^"+rtotex(SP[0]);
else
TOP += "(1-x/x_"+rtotex(SP[1])+")^"+rtotex(SP[0]);
}
}
/* Top power */
PW = my_tex_form(car(S00));
if(PW == "0")
PW = "";
NP = length(AL[0][1]);
PWS = newvect(NP);
for(I = 0; I < NP; I++)
PWS[I] = "";
for(S = S01, I = 0; S != []; S = cdr(S), I++){
SI = rtotex(car(S)[0]);
if(I > 0) Sm += ",\\ ";
Sm += "n_"+SI+"\\ge0";
if(PW != "")
PW += "+";
PW += "n_"+SI;
if(car(S)[1] > 2)
PWS[car(S)[1]] += "-n_"+rtotex(car(S)[0]);
else if(car(S)[1] == 0)
Ps = "C_{n_0}"+Ps;
}
for(I = 3; I < NP; I++){
if(PWS[I] != "")
Ps += "x_"+rtotex(I)+"^{"+PWS[I]+"}";
}
Out = str_tb([TOP, Ps, "x^{", PW, "}"], "");
/* Gamma factor */
for(I = 0, SS = S1; I <= 1; I++, SS = S2){
PW = string_to_tb("");
for(PW1=""; SS != [] ; SS = cdr(SS)){
for(J = 0, SST = car(SS); SST != []; SST = cdr(SST), J++){
if(J == 0){
JJ = (car(SST) == 1)?((length(SST)==2)?(-1):0):1;
if(JJ > 0)
str_tb(["(", my_tex_form(car(SST)), ")_{"], PW);
else if(JJ == 0)
PW1 = "(";
}else{
if(JJ > 0){
if(J > 1) write_to_tb("+", PW);
str_tb(["n_", rtotex(car(SST))], PW);
}else{
if(J > 1) PW1 += "+";
PW1 += "n_"+rtotex(car(SST));
}
}
}
if(JJ > 0) write_to_tb("}", PW);
else PW1 += (JJ == 0)?")!":"!";
}
if(I == 0)
Out0 = "\\frac";
Out0 += "{"+tb_to_string(PW)+PW1+"}";
PW = string_to_tb(""); PW1 = "";
}
if(Out0 == "\\frac{}{}")
Out0 = "";
Out = "\\sum_{"+Sm+"}"+Out0 + Top + tb_to_string(Out);
if(length(S01) == 1){
Out = str_subst(Out, "{n_"+SI+"}", "n");
Out = str_subst(Out, "n_"+SI, "n");
}
if(Dviout >= 0)
dviout(Out|eq=0,keep=Keep);
return Out;
}
return [cons(S00, S01), S1, S2];
}
/* Operator */
if(T==3){
Fuc0 = car(Fuc);
if(Fuc0 != 0){ /* Kill Fuchs relation */
for(V = vars(Fuc0); V != []; V = cdr(V)){
VT = car(V);
if(deg(Fuc0,VT) == 1){
AL = mysubst(AL, [VT, -red(coef(Fuc0,0,VT)/coef(Fuc0,1,VT))]);
break;
}
}
if(V == []){
print("Fuchs condition has no variable with degree 1");
return 0;
}
}
L = newvect(NP);
Pt = getopt(pt);
for(I = NP-1; I >= 1; I--){
if(type(Pt) == 4)
L[I] = Pt[I-1];
else if(I >= 3 || X1 >= 0 || (X2 >= 0 && I >= 2))
L[I] = makev(["x_", I]);
else L[I] = I-1;
}
if(R){ /* non-rigid basic */
MM = AL[0][1]; /* Riemann scheme */
for(OD = 0, MT = car(MM); MT != []; MT = cdr(MT))
OD += car(MT)[0];
for(V = DN = [], M = MM; M != []; M = cdr(M)){
MT = car(M); /* exponents */
for(K = KM = 0, NT = []; ; K++){
for(J = 0, P = 1, MTT = MT; MTT != []; MTT = cdr(MTT)){
if(J == 0 && car(MTT)[1] == 0)
KM = car(MTT)[0];
for(KK = car(MTT)[0] - K -1; KK >= 0; KK--)
P *= (dx-car(MTT)[1]-KK);
}
if(P == 1) break;
NT = cons(P,NT);
}
V = cons(reverse(NT), V);
DN = cons(KM, DN);
}
V = ltov(reverse(V)); /* conditions for GRS */
DN = ltov(reverse(DN)); /* dims of local hol. sol. */
for(J = OD; J >= 0; J--){
for(I = Q = 1; I < NP; I++){
if(J > DN[I])
Q *= (x-L[I])^(J-DN[I]);
}
K = mydeg(Q,x);
if(J == OD){
P = Q*dx^J;
DM = K;
}else{
for(I = DM-OD+J-K; I >= 0; I--){
X = makev(["r",J,"_",I]);
P += Q*x^I*X*dx^J;
}
}
}
for(R = [], I = 0; I < NP; I++){
Q = toeul(P, [x,dx], (I==0)?"infty":L[I]); /* Euler at I-th pt */
for(VT = V[I], J=0; VT != [] ; VT = cdr(VT), J++){
if(car(VT) != 0)
R = cons(rpdiv(coef(Q,J,x), car(VT), dx)[0], R); /* equations */
}
}
for(RR = RRR = [], I = OD-1; I>=0; I--){
RR = [];
for(RT = R; RT != [] ; RT = cdr(RT)){
if( (VT = mycoef(car(RT), I, dx)) != 0)
RR = cons(VT, RR); /* real linear eqs */
}
J = mydeg(mycoef(P,I,dx),x);
for(S = 0, VVV = []; J >= 0; J--){
X = makev(["r",I,"_",J]);
VVV = cons(X, VVV); /* unknowns */
}
RR = lsol(RR,VVV);
LN = length(RR);
for(K=0; K<LN; K++){
RRT = RR[K];
if(type(RRT) != 4) continue;
R = mysubst(R,RRT);
P = mysubst(P,RRT);
}
}
}else /* Rigid case */
P = dx^(AL[0][1][0][0][0]);
/* additions and middle convolutions */
for(ALT = AL; ALT != []; ALT = cdr(ALT)){
AI = car(ALT)[0];
if(type(AI) != 4) continue;
V = ltov(AI);
if(V[0] != 0) P = mc(P,x,V[0]);
for(I = 1; I < NP; I++){
if(V[I] != 0)
P = sftexp(P,x,L[I],-V[I]);
}
}
P = (Simp>=0)? simplify(P,Fuc,4|var=[dx]):simplify(P,Fuc,4);
if(TeX >= 0){
Val = 1;
if(mydeg(P,dx) > 2 && AMSTeX == 1 && TeXEq > 3)
Val = (TeXEq==5)?3:2;
Out = fctrtos(P|var=[dx,"\\partial"],TeX=Val);
if(Dviout < 0) return Out;
dviout(Out|eq=0,keep=Keep);
return 1;
}
return P;
}
return 0;
}
/* option: zero, all, raw */
def shiftop(M,S)
{
if(type(M)==7) M=s2sp(M);
if(type(S)==7) S=s2sp(S);
Zero=getopt(zero);
NP=length(M);
for(V=L=[],I=NP-1; I>=0; I--){
V=cons(strtov(asciitostr([97+I])),V);
if(I>2) L=cons(makev(["y_", I-1]),L);
else L=cons(I-1,L);
}
if(type(M[0][0])==4){
F=1;RS=M;SS=S;
R=chkspt(M);
if(R[2]!=2 || R[3]!=0){
mycat("GRS is not valid!");return 0;
}
for(; S!=[]; S=cdr(S)){
if(nmono(S[0][0])!=1) break;
if(isint(S[0][1]-S[0][0])==0) break;
}
if(S!=[]){
mycat("Error in shift!"); return 0;
}
}else{
F=0;
RS=sp2grs(M,V,[1,length(M[0]),1]);
for(SS=S0=[],I=0; I<NP; I++){
for(J=F=0; J<length(M[I]); J++){
if(I==0 && J==length(M[0])-1) break;
if((U=S[I][J])!=0){
if(isint(U)!=1){
mycat("Error in shift!"); return 0;
}
VT=RS[I][J][1];
SS=cons([VT,VT+U],SS);
}else if(I>0 && Zero==1 && F==0){
RS=mysubst(RS,[RS[I][J][1],0]);
F=J+1;
}
}
if((F>0 && J==2) || (I==0 && J==1)){
J=(I==0)?0:2-F; VT=RS[I][J][1];
S0=cons([VT,strtov(asciitostr([strtoascii(rtostr(VT))[0]]))],S0);
}
}
}
RS1=mysubst(RS,SS);
if(F==1){
R=chkspt(RS1);
if(R[2]!=2 || R[3]!=0){
mycat("Error in shift!");
return 0;
}
}
R=getbygrs(RS,1); R1=getbygrs(RS1,1);
RT=R[0][1][0];
if(length(RT)!=1 || RT[0][0]!=1){
mycat("Not rigid!");
return 0;
}
P=dx;Q=Q1=1;
for(RT = R, RT1=R1; RT != []; RT = cdr(RT), RT1=cdr(RT1)){
V=car(RT)[0]; V1=car(RT1)[0];
if(type(V) != 4) continue;
if(V[0] != 0){
P = mc(P,x,V[0]); /* middle convolution */
QT = mc(Q,x,V[0]);
}else QT=Q;
D0=mydeg(Q,dx);D0T=mydeg(QT,dx);
C0=red(mycoef(Q,D0,dx)/mycoef(QT,D0T,dx));
if(C0!=1) QT=red(C0*QT);
if(V1[0] != 0) Q1T = mc(Q1,x,V1[0]);
else Q1T=Q1;
D1=mydeg(Q1,dx);D1T=mydeg(Q1T,dx);
C1=red(mycoef(Q1,D1,dx)/mycoef(Q1T,D1T,dx));
if(C1!=1) Q1T=red(C1*Q1T);
DD=(V[0]-V1[0])+(D0-D0T)-(D1-D1T);
if(DD>0){
QT=muldo(dx^DD,QT,[x,dx]);
D0T+=DD;
}else if(DD<0){
Q1T=muldo(dx^(-DD),Q1T,[x,dx]);
D1T-=DD;
}
C=mylcm(dn(QT),dn(Q1T),x);
if(C!=1){
QT=red(C*QT); Q1T=red(C*Q1T);
}
Q=QT;Q1=Q1T;
for(I = 1; I < NP; I++){
if(V[I]!=0){
P = sftexp(P,x,L[I],-V[I]); /* addition u -> (x-L[I])^V[I]u */
QT = sftexp(QT,x,L[I],-V[I]);
}
if(V1[I]!=0)
Q1T = sftexp(Q1T,x,L[I],-V1[I]);
}
C=red(mycoef(QT,D0T,dx)*mycoef(Q1,D1T,dx)/(mycoef(Q,D0T,dx)*mycoef(Q1T,D1T,dx)));
Q=red(dn(C)*QT);Q1=red(nm(C)*Q1T);
for(I = 1; I < NP; I++){
if((J=V[I]-V1[I])!=0){
if(J>0) Q1*=(x-L[I])^J;
else Q*=(x-L[I])^(-J);
}
while((QT=tdiv(Q,x-L[I]))!=0){
if((Q1T=tdiv(Q1,x-L[I]))!=0){
Q=QT;Q1=Q1T;
}else break;
}
}
}
P1=mysubst(P,SS);
if(type(S0)==4 && S0!=[]){
P=mysubst(P,S0); Q=mysubst(Q,S0);
P1=mysubst(P1,S0); Q1=mysubst(Q1,S0);
RS=mysubst(RS,S0); RS1=mysubst(RS1,S0);
}
R=mygcd(Q1,P1,[x,dx]);
if(findin(dx,vars(R[0]))>=0){
mycat("Some error!");
return 0;
}
Q=muldo(R[1]/R[0],Q,[x,dx]);
R=divdo(Q,P,[x,dx]);
Q=red(R[1]/R[2]);
R=fctr(nm(Q));
QQ=Q/R[0][0];
R1=fctr(dn(QQ));
for(RR=cdr(R1); RR!=[]; RR=cdr(RR)){
VT=vars(car(RR)[0]);
if(findin(x,VT)<0 && findin(dx,VT)<0){
for(I=car(RR)[1];I>0;I--) QQ=red(QQ*car(RR)[0]);
}
}
Raw=getopt(raw);
Dviout=getopt(dviout);
if(Dviout==1) Raw=4;
if(Raw!=1){
for(RR=cdr(R); RR!=[]; RR=cdr(RR)){
VT=vars(car(RR)[0]);
if(findin(x,VT)<0 && findin(dx,VT)<0){
for(I=car(RR)[1];I>0;I--) QQ=red(QQ/car(RR)[0]);
}
}
}
if(Raw==2||Raw==3||Raw==4){
R=mygcd(QQ,P,[x,dx]); /* R[0]=R[1]*QQ + R[2]*P */
Q1=red(R[0]/R[2]);
for(Q=1,RR=cdr(fctr(nm(Q1))); RR!=[]; RR=cdr(RR)){
VT=vars(car(RR)[0]);
if(findin(x,VT)<0){
for(I=car(RR)[1];I>0;I--) Q*=car(RR)[0];
}
}
if(Raw==3) QQ=[QQ,Q];
else if(Raw==4) /* Q=Q*R[1]/R[0]*QQ+Q/R[0]*P */
QQ=[QQ,Q,red(R[1]*Q/R[0])];
else QQ=Q;
}
F=getopt(all);
if(Dviout==1){
Pre = " x=\\infty & 0 & 1";
for(I=3; I<NP; I++) Pre = Pre+"& "+rtostr(L[I]);
Pre = Pre+"\\\\\n";
PW=str_tb(ltotex(RS|opt="GRS",pre=Pre),0);
str_tb(
"=\\{u\\mid Pu=0\\}\\\\\n&\\underset{Q_2}{\\overset{Q_1}{\\rightleftarrows}}\n",PW);
str_tb([ltotex(RS1|opt="GRS",pre=Pre),"\\\\\n"],PW);
R=fctrtos(QQ[0]|TeX=3,var=[dx,"\\partial"]);
if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
str_tb(["Q_1&=",R,"\\\\\n"],PW);
R=fctrtos(QQ[2]|TeX=3,var=[dx,"\\partial"]);
if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
str_tb(["Q_2&=",R,"\\\\\n"],PW);
str_tb(["Q_2Q_1&\\equiv ",fctrtos(QQ[1]|TeX=3),"\\mod W(x)P"],PW);
if(F==1)
str_tb(["\\\\\nP&=",fctrtos(P|TeX=3,var=[dx,"\\partial"])],PW);
dviout(str_tb(0,PW)|eq=0,title="Shift Operator");
}
if(F==1) return [QQ,P,RS,P1,RS1];
else if(F==0) return QQ;
return [QQ,P,RS];
}
def conf1sp(M)
{
if(type(M)==7) M=s2sp(M);
L0 = length(M);
L1 = length(M[L0-1]);
X2 = getopt(x2);
Conf= getopt(conf);
if(Conf != 0)
Conf = -1;
if((X2==1 || X2==-1) && Conf != 0){
X1 = 0;
X = x_1;
}else{
X1 = 1;
X = x_2;
}
G = sp2grs(M,a,[L0,L1]);
for(I = 0; I < L0-1; I++){
V = makev([a,I-Conf,0]);
G = subst(G,V,0);
}
L2 = length(M[1]);
for(I=J=S0=S1=0; I < L2; I++){
S1 += G[1][I][0];
while(S0 < S1){
S0 += G[0][J][0];
if((V=G[0][J][1]) != 0)
G = mysubst(G,[V,V-G[1][I][1]]);
J++;
}
if(S0 > S1){
print("Error in data!");
return 0;
}
}
if(Conf==0){
for(L=[], I=L0-2; I>=0; I--)
L=cons(I,L);
L=cons(L0-1,L);
P = getbygrs(G,["operator","x2"]|perm=L);
}else if(X1)
P = getbygrs(mperm(G,[[1,2]],[]), ["operator","x2"]);
else
P = getbygrs(G,["operator","x1"]);
if(Conf==0)
P=nm(mysubst(P,[X,c]));
else{
P = nm(mysubst(P,[X,1/c]));
if(X2==-1){
for(I=2; I<L0; I++){
V=makev(["x_",I]); VC=makev([c,I]);
P = nm(mysubst(P,[V,1/VC]));
}
}
}
for(I = 1; I < L2; I++){
X = G[1][I][1];
P = nm(mysubst(P,[X,X/c]));
}
VS = vars(P);
while(VS!=[]){
V = car(VS);
if(str_chr(rtostr(V),0,"r")==0){
CV = mycoef(P,1,V);
D = mymindeg(CV,c);
if(D > 0) P = mysubst(P,[V,V/c^D]);
CV = mycoef(P,1,V);
DD = mydeg(CV,dx);
CVV = mycoef(CV,DD,dx);
CD1 = mydeg(CVV,x);
CD = (X==x1)?0:CD1;
while(CD>=0 && CD<=CD1){
CC = mycoef(CVV,CD,x);
if(type(CC)==1){
VT = mycoef(mycoef(mycoef(P,DD,dx),CD,x),0,V)/CC;
if(VT != 0) P = mysubst(P,[V,V-VT]);
break;
}
if(X==x1) CD++;
else CD--;
}
while(subst(P,c,0,V,0) == 0)
P = red(mysubst(P,[V,c*V])/c);
}
VS =cdr(VS);
}
return P;
}
def pgen(L,VV)
{
if(type(L[0])<4) L=[L];
if(type(L)==4) L=ltov(L);
K=length(L);
V=newvect(K);
if(type(Sum=getopt(sum))!=1) Sum=0;
if((Num=getopt(num))!=1) Num=0;
if((Sep=getopt(sep))!=1) Sep=0;
if(type(Shift=getopt(shift))!=1) Shift=0;
for(;;){
for(PP=1,R=[],II=K-1; II>=0; II--){
R=cons(V[II]+Shift,R);
if(II>0 && Sep==1) R=cons("_",R);
PP*=L[II][0]^V[II];
}
P+=makev(cons(VV,R)|num=Num)*PP;
for(I=0;I<K;){
if(++V[I]<=L[I][1]){
if(Sum>0){
for(S=II=0;II<K;) S+=V[II++];
if(S>Sum){
V[I++]=0;
continue;
}
}
}else{
V[I++]=0;
continue;
}
break;
}
if(I>=K) return P;
}
}
def mgen(M,N,A,S)
{
if(M==0 && N==0){
mycat([
"mgen(m,n,a,s|sep=1) : generate a matrix of size m x n\n",
" n : a number or \"diagonal\", \"highdiag\", \"lowdiag\",\"skew\",\"symmetric\" = 0,-1,-2,..\n",
" a : a symbol or list (ex. a, [a], [a,b,c], [1,2,3])\n",
" s : 0 or 1 (shift of suffix)\n"
]);
return 0;
}
if(type(N)==7) N=-findin(N,["diag","highdiag","lowdiag","skew","symmetric"]);
Sep=(getopt(sep)==1)?1:0;
if(S < 0 || S > 2)
S = 0;
if(M+S > 30 || N+S > 30){
erno(1);
return;
}
if(type(A) == 4)
L = length(A)-1;
else
L = -1;
if(N <= 0 && N >= -2){
MM = newmat(M,M);
J = K = 0;
if(N == -1){
K = 1; M--;
}else if(N == -2){
J = 1; M--;
}
for(I = 0; I < M; I++){
if(L >= 0)
MM[I+J][I+K] = A[(I > L)?L:I];
else if(type(A)==7 || isvar(A))
MM[I+J][I+K] = makev([A,S+I]|sep=Sep);
else
MM[I+J][I+K] = A;
}
return MM;
}
K = N;
if(K < 0) N = M;
MM = newmat(M,N);
for(I = 0; I < M; I++){
if(L >= 0)
AA = rtostr(A[(I > L)?L:I]);
else
AA = rtostr(A)+rtostr(I+S);
if(AA>="0" && AA<=":"){
erno(0); return;
}
for(J = 0; J < N; J++){
if(K < 0){
if(I > J) continue;
if(K == -3 && I == J) continue;
}
MM[I][J] = makev([AA,J+S]|sep=Sep);
}
}
if(K < 0){
for(I = 0; I < M; I++){
for(J = 0; J < I; J++)
MM[I][J] = (K == -4)?MM[J][I]:-MM[J][I];
}
}
return MM;
}
def newbmat(M,N,R)
{
S = newvect(M);
T = newvect(N);
IM = length(R);
for(I = 0; I < IM; I++){
RI = R[I];
JM = length(RI);
for(J = 0; J < JM; J++){
RIJ = RI[J];
if(type(RIJ) == 6){
S[I] = size(RIJ)[0];
T[J] = size(RIJ)[1];
}
}
}
for(I = K = 0; I < M; I++){
if(S[I] == 0)
S[I] = 1;
K += S[I];
}
for(J = L = 0; J < N; J++){
if(T[J] == 0)
T[J] = 1;
L += T[J];
}
M = newmat(K,L);
for(I0 = II = 0; II < IM; I0 += S[II++]){
RI = R[II];
JM = length(RI);
for(J0 = JJ = 0; JJ < JM; J0 += T[JJ++]){
if((RIJ = RI[JJ]) == 0)
continue;
Type = type(RIJ);
for(I = 0; I < S[II]; I++){
for(J = 0; J < T[JJ]; J++){
if(Type == 6)
M[I0+I][J0+J] = RIJ[I][J];
else if(Type == 4 || Type == 5)
M[I0+I][J0+J] = (I>0)?RIJ[I]:RIJ[J];
else
M[I0+I][J0+J] = RIJ;
}
}
}
}
return M;
}
def pfrac(F,X)
{
F = red(F);
FN = nm(F);
FD = dn(F);
if(mydeg(FD,X) == 0)
return [[F,1,1]];
R = rpdiv(FN,FD,X);
FN = R[0]/R[1];
R0 = R[2]/R[1];
FC = fctr(FD);
N = Q = 0;
L = [];
for(I = length(FC)-1; I >= 0; I--){
if((D = mydeg(FC[I][0],X)) == 0) continue;
for(K=1; K<=FC[I][1]; K++){
for(J=P=0; J < D; J++){
V = makev(["zz_",++N]);
P = P*X + V;
L = cons(V,L);
}
Q += P/(FC[I][0]^K);
Q = red(Q);
}
}
L=reverse(L);
Q = nm(red(red(Q*FD)-FN));
Q = ptol(Q,X);
S = lsol(Q,L);
R = (R0==0)?[]:[[R0,1,1]];
for(N=0,I=length(FC)-1; I >= 0; I--){
if((D = mydeg(FC[I][0],X)) == 0) continue;
for(K=1; K<=FC[I][1]; K++){
for(P=J=0; J < D; N++,J++)
P = P*X + S[N][1];
R = cons([P,FC[I][0],K],R);
}
}
TeX=getopt(TeX);
if((Dvi=getopt(dviout))==1||TeX==1){
V=strtov("0");
for(S=L=0,RR=R;RR!=[];RR=cdr(RR),L++){
RT=car(RR);
S+=(RT[0]/RT[1]^RT[2])*V^L;
}
if(TeX!=1) fctrtos(S|var=[V,""],dviout=1);
else return fctrtos(S|var=[V,""],TeX=3);
}
return reverse(R);
}
def cfrac(X,N)
{
F=[floor(X)];
if(N<0){
Max=N=-N;
}
X-=F[0];
if(Max!=1)
M=mat([F[0],1],[1,0]);
for(;N>0 && X!=0;N--){
X=1/X;
F=cons(Y=floor(X),F);
X-=Y;
if(Max){
M0=M[0][0];M1=M[1][0];
M=M*mat([Y,1],[1,0]);
if(M[0][0]>Max) return M0/M1;
}
}
return (Max==0)?reverse(F):M[0][0]/M[1][0];
}
def cfrac2n(X)
{
for(V=0,X=reverse(X);X!=[];X=cdr(X)){
if(V!=0) V=1/V;
V+=car(X);
}
return V;
}
def s2sp(S)
{
if(type(S)==7){
S = strtoascii(S);
if(type(S) == 5) S = vtol(S);
for(N=0,R=TR=[]; S!=[]; S=cdr(S)){
if(car(S)==45) /* - */
N=1;
else if(car(S)==47) /* / */
N=2;
if(N>0){
while(car(S)<48&&car(S)!=40) S=cdr(S);
}
if((T=car(S))>=48 && T<=57) TR=cons(T-48,TR);
else if(T>=97) TR=cons(T-87,TR);
else if(T>=65 && T<=90) TR=cons(T-29,TR); /* A-Z */
else if(T==44){
R=cons(reverse(TR),R);
TR=[];
}else if(T==94){ /* ^ */
S=cdr(S);
if(car(S)==40){ /* ( */
S=cdr(S);
for(T=0; car(S)!=41 && S!=[]; S=cdr(S)){
V=car(S)-48;
if(V>=10) V-=39;
T=10*T+V;
}
}else{
while(car(S)<48) S=cdr(S);
T=car(S)-48;
if(T>=10) T-=39;
}
while(--T>=1) TR=cons(car(TR),TR);
}else if(T==40){ /* ( */
S=cdr(S);
if(N==1){
N=0; NN=1;
}else NN=0;
if(car(S)==45){ /* - */
S=cdr(S);
NN=1-NN;
}
for(I=0; I<2; I++){
for(V=0; (SS=car(S))!=41 && SS!=47 && S!=[]; S=cdr(S)){
T=SS-48;
if(T>=10) T-=39;
V=10*V+T;
}
if(NN==1){
V=-V; NN=0;
}
TR=cons(V,TR);
if(SS!=47) break;
else{
N=2; S=cdr(S);
}
}
}else if(T<48) continue;
if(N==1){
T = car(TR);
TR=cons(-T,cdr(TR));
N=0;
}else if(N==2){
T=car(TR); TR=cdr(TR);
TR=cons(car(TR)/T,cdr(TR));
N=0;
}
}
return reverse(cons(reverse(TR),R));
}else if(type(S)==4){
Num=getopt(num);
for(R=[]; ; ){
for(TS=car(S); TS!=[]; TS=cdr(TS)){
V=car(TS);
if(dn(V)>1){
P=reverse(strtoascii(rtostr(V)));
R=append(P,cons(40,R));
R=cons(41,R);
continue;
}
if(V<0 && V>-10){
V=-V;
R=cons(45,R);
}
if(V<0 || V>35 || (V>9 && Num==1)){
P=reverse(strtoascii(rtostr(V)));
R=append(P,cons(40,R));
V=41;
}else if(V<10) V+=48;
else V+=87;
R=cons(V,R);
}
if((S=cdr(S))==[]) break;
R=cons(44,R);
}
return asciitostr(reverse(R));
}
return 0;
}
def sp2grs(M,A,L)
{
MM = [];
T0 = 0;
Mat=getopt(mat);
if(Mat!=1) Mat=0;
if(type(M)==7) M=s2sp(M);
if((LM = length(M)) > 10 && type(A) < 4)
CK = 1;
Sft = (type(L)==1)?L:0;
if(type(L)==4 && length(L)>=3)
Sft = L[2];
if(Sft < 0){
T0 = 1;
Sft = -Sft-1;
}
for(I = LM-1; I >= 0; I--){
MI = M[I]; MN = [];
if(CK == 1 && length(MI) > 10){
erno(1);
return;
}
if(type(A) == 4)
AA = rtostr(A[I]);
else
AA = rtostr(A)+rtostr(I);
for(J = LM = length(MI)-1; J >= 0; J--){
V = MI[J];
if(type(V) > 3)
V = V[0];
if(T0 == 0 || I == 0)
MN = cons([V, makev([AA,J+Sft])], MN);
else{
if(LM == 1)
MN = cons([V, (J==0)?0:makev([AA])], MN);
else if(I == 1 && Mat == 0)
MN = cons([V, (J==length(MI)-1)?0:makev([AA,J+Sft])], MN);
else
MN = cons([V, (J==0)?0:makev([AA,J])], MN);
}
}
MM = cons(MN, MM);
}
if(type(L) == 4 && length(L) >= 2){
R = chkspt(MM|mat=Mat); /* R[3]: Fuchs */
AA = var(MM[L[0]-1][L[1]-1][1]);
if(AA==0) AA=var(R[3]);
if(AA!=0 && (P = mycoef(R[3],1,AA))!=0){
P = -mycoef(R[3], 0, AA)/P;
MM = mysubst(MM,[AA,P]);
}
}
return MM;
}
def intpoly(F,X)
{
D = mydeg(F,X);
P = 0;
for(I = D; I >= 0; I--){
P += mycoef(F,I,X)*x^(I+1)/(I+1);
}
return P;
}
def powsum(N)
{
if (N < 0) return 0;
if (N == 0) return x;
P = intpoly(N*powsum(N-1),x);
C = subst(P,x,1);
return P+(1-C)*x;
}
def bernoulli(N)
{
return mydiff(powsum(N),x) - N*x^(N-1);
}
/* linfrac01([x,y]) */
/* linfrac01(newvect(10,[0,1,2,3,4,5,6,7,8,9]) */
/* 0:x=0, 1:x=y, 2:x=1, 3:y=0, 4:y=1, 5:x=\infty, 6:y=\infty, 7:x=y=0, 8:x=y=1, 9:x=y=\infty
10:y_2=0, 11:y_2=x, 12:y_2=y, 13: y_2=1, 14: y_2=\infty
15:y_3=0, 16:y_3=x, 17:y_3=y, 18: y_3=y_2, 19: y_3=1, 20:y_3=\infty
X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
X[3],X[1],X[12],X[4],X[6]
T=0 (x_2,x_1,x_3,x_4,...)
T=-j (x_1,x_2,..,x_{j-1},x_{j+1},x_j,x_{j+2},...)
T=1 (1-x_1,1-x_2,1-x_3,1-x_4,...)
T=2 (1/x_1,1/x_2,1/x_3,1/x_4,...)
T=3 (x_1,x_1/x_2,x_1/x_3,x_1/x_4,...)
*/
def lft01(X,T)
{
MX=getopt();
if(type(X)==4){
K=length(X);
if(K>=1) D=1;
}
if(type(X)==5){
K=length(X);
for(J=5, F=K-10; F>0; F-=J++);
if(F==0) D=2;
}
if(D==0) return 0;
if(T==0){ /* x <-> y */
if(D==1){
R=cdr(X); R=cdr(R);
R=cons(X[0],R);
return cons(X[1],R);
}
R=newvect(K,[X[3],X[1],X[4],X[0],X[2],X[6],X[5]]);
for(I=7;I<K;I++) R[I]=X[I];
for(I=11,J=5; I<K; I+=J++){
R[I]=X[I+1]; R[I+1]=X[I];
}
return R;
}
if(T==1){
if(D==1){
for(R=[];X!=[];X=cdr(X)) R=cons(1-car(X),R);
return reverse(R);
}
R=newvect(K,[X[2],X[1],X[0],X[4],X[3],X[5],X[6],X[8],X[7],X[9]]);
for(I=11;I<K;I++) R[I]=X[I];
for(I=10, J=5; I<K; I+=J++){
R[I]=X[I+J-2]; R[I+J-2]=X[I];
}
return R;
}
if(T==2){
if(D==1){
for(R=[]; X!=[]; X=cdr(X)) R=cons(red(1/car(X)),R);
return reverse(R);
}
R=newvect(K,[X[5],X[1],X[2],X[6],X[4],X[0],X[3],X[9],X[8],X[7]]);
for(I=11;I<K;I++) R[I]=X[I];
for(I=10,J=5; I<K; I+=J++){
R[I]=X[I+J-1]; R[I+J-1]=X[I];
}
return R;
}
if(T==3){
if(D==1){
T=car(X);
for(R=[T],X=cdr(X); X!=[]; X=cdr(X))
R=cons(red(T/car(X)),R);
return reverse(R);
}
R=newvect(K,[X[7],X[4],X[2],X[6],X[1],X[9],X[3],X[0],X[8],X[5]]);
for(I=10,J=5; I<K; I+=J++){
R[I]=X[I+J-1]; R[I+1]=X[I+J-2]; R[I+J-2]=X[I+1]; R[I+J-1]=X[I];
}
return R;
}
if(T==-1){
if(D==1){
return append([X[1],X[2],X[0]],cdr(cdr(cdr(X))));
}
R=newvect(K,[X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
X[3],X[1],X[12],X[4],X[6]]);
for(I=11;I<K;I++) R[I]=X[I];
for(I=17,J=5; I<K; I+=J++){
R[I]=X[I+1]; R[I+1]=X[I];
}
return R;
}
if(T<0){
if(D==1){
for(R=[],I=0; X!=[]; X=cdr(X),I--){
if(I==T){
R=cons(X[1],R);
R=cons(X[0],R);
X=cdr(X);
}
else R=cons(car(X),R);
}
return reverse(R);
}
T=3-T;
R=newvect(K);
for(I=0;I<K;I++) R[I]=X[I];
for(I=10,J=5;J<T;I+=J++);
for(II=0; II<J-2; II++){
R[I]=X[I+J]; R[I+J]=R[I];
}
for( ; II<J; II++){
R[I]=X[I+J+1]; R[I+J+1]=X[I];
}
return R;
}
return 0;
}
def linfrac01(X)
{
if(type(X)==4) K=length(X)-2;
else if(type(X)==5){
L=length(X);
for(K=0,I=10,J=5; I<L; K++,I+=J++);
if(I!=L) return 0;
}
if(K>3 && getopt(over)!=1) return(-1);
II=(K==-1)?3:4;
for(CC=C=1,L=[X]; C!=0; CC+=C){
for(F=C,C=0,R=L; F>0; R=cdr(R), F--){
P=car(R);
for(I=-K; I<II; I++){
S=lft01(P,I);
if(findin(S,L) < 0){
C++; L=cons(S,L);
}
}
}
}
return L;
}
def ptype(P,L)
{
if((T=type(P))<2 || T>3) return T;
if(type(L)!=4) L=[L];
if(lsort(L,vars(dn(P)),2)!=[]) return 3;
return (lsort(L,vars(nm(P)),2)==[])?1:2;
}
def nthmodp(X,N,P)
{
X=X%P;
for(Z=1;;){
if((W=iand(N,1))==1) Z=(Z*X)%P;
if((N=(N-W)/2)<=0) return Z;
X=irem(X*X,P);
}
}
def issquaremodp(X,P)
{
N=getopt(power);
if(!isint(N)) N=2;
if(P<=1 || !isint(P) || !pari(ispsp,P) || !isint(X) || !isint(N) || N<1){
errno(0);
return -2;
}
M=(P-1)/igcd(N,P-1);
if((X%=P) == 0) return 0;
if(X==1 || M==P-1) return 1;
return (nthmodp(X,M,P)==1)?1:-1;
}
def rootmodp(X,P)
{
X%=P;
if(X==0) return [0];
N=getopt(power);
PP=pari(factor,P);
P0=PP[0][0]; P1=PP[0][1];
P2=pari(phi,P);
if(!isint(N)) N=2;
N%=P2;
if(P0==2 || size(PP)[0]>1){
for(I=1,R=[]; I<P2; I++)
if(nthmodp(I,N,P)==X) R=cons(I,R);
return qsort(R);
}
Y=primroot(P);
if(Y==0) return 0;
Z=nthmodp(Y,N,P);
G=igcd(N,P2);
P3=P2/G;
for(I=0, W=1; I<P3;I++){
if(W==X) break;
W=(W*Z)%P;
}
if(I==P3) return [];
W=nthmodp(Y,I,P);
Z=nthmodp(Y,P3,P);
for(I=0,R=[];;){
R=cons(W,R);
if(++I>=G) break;
W=(W*Z)%P;
}
return qsort(R);
}
def primroot(P)
{
PP=pari(factor,P);
P0=PP[0][0]; P1=PP[0][1];
S=size(PP);
if(S[0]>1 || !isint(P) || P0<=2){
print("Not odd prime(power)!");
return 0;
}
if(isint(Ind=getopt(ind))){
Ind %= P;
if(Ind<=0 || igcd(Ind,P)!=1 || (Z=primroot(P))==0){
print("Not exist!");
return 0;
}
P2=P0^(P1-1)*(P0-1);
for(I=1,S=1; I<P2; I++)
if((S = (S*Z)%P) == Ind) return I;
return 0;
}
if(getopt(all)==1){
I=primroot(P);
P2=P0^(P1-1)*(P0-1);
for(L=[],J=1; J<P2; J++){
if(P1>1 && igcd(P0,J)!=1) continue;
if(igcd(P0-1,J)!=1) continue;
L=cons(nthmodp(I,J,P),L);
}
return qsort(L);
}
if(PP[0][1]>1){
I=primroot(P0);
P2=P0^(P1-2)*(P0-1);
if(nthmodp(I,P2,P)==1) I+=P0;
return I;
}
F=pari(factor,P-1);
SF=size(F)[0];
for(I=2; I<P; I++){
for(J=0; J<SF; J++)
if(nthmodp(I,(P-1)/F[J][0],P)==1) break;
if(J==SF) return I;
}
}
def rabin(P,X)
{
for(M=0,Q=P-1;iand(Q,1)==0;M++,Q/=2);
Z=nthmodp(X,Q,P);
for(N=M;M>0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P);
return (M<N&&(M==0||Z==1))?0:1;
}
def init() {
if(!access(get_rootdir()+"/help/os_muldif.dvi")||!access(get_rootdir()+"/help/os_muldif.pdf"))
mycat(["Put os_muldif.dvi and os_muldif.pdf in", get_rootdir()+(isMs()?"\\help.":"/help.")]);
if(!isMs()){
DIROUT="%HOME%/Asir/tex";
DVIOUTA=str_subst(DVIOUTA,"\\","/");
DVIOUTL=str_subst(DVIOUTL,"\\","/");
DVIOUTH="";
}
Home=getenv("HOME");
if(type(Home)==7) Home="";
for(Id=-6, F=Home; Id<-1;){
G = F+"/.muldif";
if(access(G)) Id = open_file(G);
else Id++;
if(Id==-6) F+="asir";
else if(Id==-5) F=get_rootdir();
else if(Id==-4) F+="/bin";
else if(Id==-3) F=get_rootdir()+"/lib-asir-contrib";
}
if(Id>=0){
while((S=get_line(Id))!=0){
P=str_str(S,["DIROUT","DVIOUTA","DVIOUTH","DVIOUTL","TeXLim","TeXEq"]);
if(type(P)==4 && (P0=str_char(S,P[1]+5,"="))>0){
if(P[0]<4){
P0=str_chr(S,P0+1,"\"");
if(P0>0){
for(P1=P0;(P2=str_char(S,P1+1,"\""))>0; P1=P2);
if(P1>P0+1){
SS=str_cut(S,P0+1,P1-1);
SS=str_subst(SS,["\\\\","\\\""],["\\","\""]);
if(P[0]==0) DIROUT=SS;
else if(P[0]==1) DVIOUTA=SS;
else if(P[0]==2) DVIOUTH=SS;
else if(P[0]==3) DVIOUTL=SS;
}
}
}else{
SV=eval_str(str_cut(S,P0+1,str_len(S)-1));
if(P[0]==4) TeXLim=SV;
else if(P[0]==5) TeXEq=SV;
}
}
}
close_file(Id);
}
chkfun(1,0);
}
#ifdef USEMODULE
endmodule;
os_md.init()$
#else
init()$
#endif
end$
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to os_muldif.rr CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / asir-contrib / packages / src