=================================================================== RCS file: /home/cvs/OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v retrieving revision 1.2 retrieving revision 1.50 diff -u -p -r1.2 -r1.50 --- OpenXM/src/asir-contrib/packages/src/os_muldif.rr 2014/09/05 11:55:18 1.2 +++ OpenXM/src/asir-contrib/packages/src/os_muldif.rr 2019/06/27 02:53:26 1.50 @@ -1,9557 +1,20555 @@ -/* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.1 2014/08/16 01:06:59 takayama 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 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= 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; IJ){ - 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; JTtype(Mul)) continue; - if(type(Val)3 && isint(Val)==1){ - for(FF=1,JK=K+1; JK3 && Mul!=1 && Mul!=-1){ - for(FF=0,J0=J; J00){ - for(I=K;I3 && (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; L0)?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; I0) - return -1; - return(I==IM)?0:I; -} - -def mmc(M,X) -{ - L=length(M); - if(getopt(mult)==1){ - for(SS=I=2; 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=0; I--){ - for(RR=[N[J]],K=0;K=SS) II=++JJ; - } - for(R=[],I=SS-1; I>=0; I--){ - for(RR=[N[I]],J=0; J0){ - 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; IP || 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 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;I0){ - 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;IS0) continue; - for(J=1;JS1) continue; - if(S0==1 || S1==1){ - P=M[0][0]; - if(X==0){ - if(P<0) P=-P; - if(Tr==1) for(J=0;J0)?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; I1){ - M=rowx(M,1,I); - if(Tr==1) GR=rowx(GR,1,I); - FF+=", line 2<->"+rtostr(I+1); - } - for(I=1;IS0) 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; I1) 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= 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 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; I0;) - M[I][J] = V[J]; - if(N!=0){ - for(J=length(V); J0;) - 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=0){ - if(I>J) LF+=texlen(str_cut(S,J,I-1)); - I+=6; - for(F=L=0,J=I;F<2 && J0 && JL) 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; I96 && 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+23) 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 && K10 && K1-JJ>6 && K10 || str_str(S,"Big"|top=T+1,end=T+1)>0)) - K=T; - else if(K1>0 && K1II) 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 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= 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 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; J2) 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=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;I1) return 0; - } -/* mycat([V,MR]); */ - if(L==1){ - for(I=0;I=0 && MR[J]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;I0) 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=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=JL) return Coef; - JP=J;T0=1; - T+=S[J]*Mon[J][I]; - } - } - if(T==MR[I]){ - if(++I1; II--) - TT/=II; - } - } - Coef+=TT; - if(TP==1 && type(Coef)==3) Coef=red(Coef); - if(JP1){ - 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(JP0 && Mon[JP1][0] < Mon[JP][0]){ - S[JP]--;S[Len-1]++;JP=JP-1; - }else{ - - S[JP]--; - if(JP1=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=0 && mydeg(P,V[J])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;I0) RR*=V[J]^T[J]; - } - Q-=R*RR; - for(J=0,CC=R;J 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=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=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=") 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]!="" && VC[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;I0){ - 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; K0 && iand(Only,1)==0) continue; - if(Q==0 && iand(Only,2)==0) continue; - if(Q<0 && iand(Only,4)==0) continue; - for(K=0; K0) 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; I1){ - 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)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)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=(L1MO) return 0; - LL[R[1]]=R; - K=R[1]; - } - if(K==1||type(Sp)!=4){ - LL[1]=[[[1]]]; - for(I=2; I<=MO && I=II){ - if(S=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) break; - } - } - } - if(L0>0 || L1L1) 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]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;I1)||(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=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 && JJ128){ - 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; I1)?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; J0){ - 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(II1) - 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 (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(XLX[1] || YLY[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(XLX[1] || YLY[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] && Y<=LY[1]){ - 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; I1) 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=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=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[1] || 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(VM1) 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; I0) 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 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((I0)?" + ":" ",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; I0)?" +":"\\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; ICS) 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; I2) 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 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=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; I0 && 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 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 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;I0){ - for(S=II=0;IISum){ - 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;I3 && 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; I3) 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=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; I1 && 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; I0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P); - return (M=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$ +/* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.49 2019/05/23 01:47:53 takayama 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 - Feb. 2019) + * + * 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 DIROUTD$ +static DVIOUTL$ +static DVIOUTA$ +static DVIOUTB$ +static DVIOUTH$ +static DVIOUTF$ +static LCOPT$ +static COLOPT$ +static LPOPT$ +static LFOPT$ +static ErMsg$ +static FLIST$ +static IsYes$ +static XYPrec$ +static XYcm$ +static TikZ$ +static XYLim$ +static Canvas$ +static ID_PLOT$ +static Rand$ +static LQS$ +static SVORG$ +localf spType2$ +localf erno$ +localf chkfun$ +localf makev$ +localf shortv$ +localf makenewv$ +localf vweyl$ +localf mycat$ +localf mycat0$ +localf fcat$ +localf findin$ +localf countin$ +localf mycoef$ +localf mydiff$ +localf myediff$ +localf m2l$ +localf m2ll$ +localf mydeg$ +localf pfctr$ +localf mymindeg$ +localf m1div$ +localf mulsubst$ +localf cmpsimple$ +localf simplify$ +localf monotos$ +localf minustos$ +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 dvangle$ +localf dvprod$ +localf dnorm$ +localf mulseries$ +localf pluspower$ +localf vtozv$ +localf dupmat$ +localf matrtop$ +localf mytrace$ +localf mydet$ +localf mperm$ +localf mtranspose$ +localf mtoupper$ +localf mydet2$ +localf myrank$ +localf meigen$ +localf transm$ +localf vgen$ +localf mmc$ +localf lpgcd$ +localf mdivisor$ +localf mdsimplify$ +localf m2mc$ +localf easierpol$ +localf paracmpl$ +localf mykernel$ +localf myimage$ +localf mymod$ +localf mmod$ +localf ladd$ +localf lchange$ +localf llsize$ +localf llbase$ +localf lsort$ +localf rsort$ +localf lpair$ +localf lmax$ +localf lmin$ +localf lgcd$ +localf llcm$ +localf ldev$ +localf lsol$ +localf lnsol$ +localf l2p$ +localf m2v$ +localf lv2m$ +localf m2lv$ +localf s2m$ +localf c2m$ +localf m2diag$ +localf myinv$ +localf madjust$ +localf mpower$ +localf mrot$ +localf texlen$ +localf isdif$ +localf fctrtos$ +localf texlim$ +localf fmult$ +localf radd$ +localf getel$ +localf ptol$ +localf rmul$ +localf mtransbys$ +localf drawopt$ +localf execdraw$ +localf execproc$ +localf myswap$ +localf mysubst$ +localf evals$ +localf myval$ +localf myeval$ +localf mydeval$ +localf myfeval$ +localf myf2eval$ +localf myf3eval$ +localf myfdeval$ +localf myf2deval$ +localf myf3deval$ +localf myexp$ +localf mycos$ +localf mysin$ +localf mytan$ +localf myarg$ +localf myasin$ +localf myacos$ +localf myatan$ +localf mylog$ +localf mypow$ +localf scale$ +localf arg$ +localf sqrt$ +localf gamma$ +localf lngamma$ +localf digamma$ +localf dilog$ +localf zeta$ +localf eta$ +localf jell$ +localf frac$ +localf erfc$ +localf orthpoly$ +localf schurpoly$ +localf fouriers$ +localf todf$ +localf f2df$ +localf df2big$ +localf compdf$ +localf fzero$ +localf fmmx$ +localf flim$ +localf fcont$ +localf fresidue$ +localf mmulbys$ +localf appldo$ +localf appledo$ +localf muldo$ +localf jacobian$ +localf hessian$ +localf wronskian$ +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 polroots$ +localf fctri$ +localf binom$ +localf expower$ +localf seriesHG$ +localf seriesMc$ +localf seriesTaylor$ +localf mulpolyMod$ +localf solveEq$ +localf baseODE$ +localf taylorODE$ +localf evalred$ +localf toeul$ +localf fromeul$ +localf sftexp$ +localf fractrans$ +localf soldif$ +localf chkexp$ +localf sqrtrat$ +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 sgn$ +localf calc$ +localf isint$ +localf israt$ +localf iscrat$ +localf isalpha$ +localf isnum$ +localf isalphanum$ +localf isdecimal$ +localf isvar$ +localf isyes$ +localf isall$ +localf iscoef$ +localf iscombox$ +localf sproot$ +localf spgen$ +localf chkspt$ +localf cterm$ +localf terms$ +localf polcut$ +localf redgrs$ +localf cutgrs$ +localf mcgrs$ +localf mc2grs$ +localf mcmgrs$ +localf spslm$ +localf anal2sp$ +localf delopt$ +localf str_char$ +localf str_pair$ +localf str_cut$ +localf str_str$ +localf str_subst$ +localf str_times$ +localf str_tb$ +localf strip$ +localf i2hex$ +localf sjis2jis$ +localf jis2sjis$ +localf s2os$ +localf l2os$ +localf r2os$ +localf s2euc$ +localf s2sjis$ +localf r2ma$ +localf evalma$ +localf ssubgrs$ +localf verb_tex_form$ +localf tex_cuteq$ +localf my_tex_form$ +localf texket$ +localf smallmattex$ +localf divmattex$ +localf dviout0$ +localf myhelp$ +localf isMs$ +localf showbyshell$ +localf readcsv$ +localf tocsv$ +localf getbyshell$ +localf show$ +localf dviout$ +localf rtotex$ +localf mtotex$ +localf ltotex$ +localf texbegin$ +localf texcr$ +localf texsp$ +localf getbygrs$ +localf mcop$ +localf shiftop$ +localf conf1sp$ +localf confexp$ +localf confspt$ +localf mcvm$ +localf s2csp$ +localf partspt$ +localf pgen$ +localf diagm$ +localf mgen$ +localf madj$ +localf newbmat$ +localf unim$ +localf pfrac$ +localf cfrac$ +localf cfrac2n$ +localf sqrt2rat$ +localf s2sp$ +localf sp2grs$ +localf fimag$ +localf trig2exp$ +localf intpoly$ +localf integrate$ +localf rungeKutta$ +localf simplog$ +localf fshorter$ +localf isshortneg$ +localf intrat$ +localf powsum$ +localf bernoulli$ +localf lft01$ +localf linfrac01$ +localf nthmodp$ +localf issquaremodp$ +localf rootmodp$ +localf rabin$ +localf primroot$ +localf varargs$ +localf ptype$ +localf pfargs$ +localf average$ +localf tobig$ +localf sint$ +localf frac2n$ +localf xyproc$ +localf xypos$ +localf xyput$ +localf xybox$ +localf xyline$ +localf xylines$ +localf xycirc$ +localf xybezier$ +localf lbezier$ +localf draw_bezier$ +localf tobezier$ +localf velbezier$ +localf ptbezier$ +localf cutf$ +localf fsum$ +localf fint$ +localf periodicf$ +localf cmpf$ +localf areabezier$ +localf saveproc$ +localf xygraph$ +localf xy2graph$ +localf addIL$ +localf xy2curve$ +localf xygrid$ +localf xyarrow$ +localf xyarrows$ +localf xyang$ +localf xyoval$ +localf xypoch$ +localf ptcommon$ +localf ptcopy$ +localf ptaffine$ +localf ptlattice$ +localf ptpolygon$ +localf ptwindow$ +localf ptbbox$ +localf lninbox$ +localf ptcombezier$ +localf ptcombz$ +localf lchange$ +localf init$ +localf powprimroot$ +localf distpoint$ +localf ntable$ +localf keyin$ +localf mqsub$ +localf msort$ +#else +extern Muldif.rr$ +extern TeXEq$ +extern TeXLim$ +extern DIROUT$ +extern DIROUTD$ +extern DVIOUTL$ +extern DVIOUTA$ +extern DVIOUTB$ +extern DVIOUTH$ +extern DVIOUTF$ +static LCOPT$ +static COLOPT$ +static LPOPT$ +static LFOPT$ +extern TikZ$ +extern ErMsg$ +extern FLIST$ +extern IsYes$ +extern XYPrec$ +extern XYcm$ +extern TikZ$ +extern XYLim$ +extern Canvas$ +extern ID_PLOT$ +extern Rand$ +extern LQS$ +extern SV=SVORG$ +#endif +static S_Fc,S_Dc,S_Ic,S_Ec,S_EC,S_Lc$ +static S_FDot$ +extern AMSTeX$ +Muldif.rr="00190620"$ +AMSTeX=1$ +TeXEq=5$ +TeXLim=80$ +TikZ=0$ +XYcm=0$ +XYPrec=3$ +XYLim=4$ +Rand=0$ +DIROUT="%HOME%\\tex"$ +DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$ +DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$ +DVIOUTB="%ASIRROOT%\\bin\\risatex1%TikZ%.bat"$ +DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$ +DVIOUTF=0$ +LCOPT=["red","green","blue","yellow","cyan","magenta","black","white","gray"]$ +COLOPT=[0xff,0xff00,0xff0000,0xffff,0xffff00,0xff00ff,0,0xffffff,0xc0c0c0]$ +LPOPT=["above","below","left","right"]$ +LFOPT=["very thin","thin","dotted","dashed"]$ +SVORG=["x","y","z","w","u","v","p","q","r","s"]$ +Canvas=[400,400]$ +LQS=[[1,0]]$ + +ErMsg = newvect(3,[ + "irregal argument", /* 0 */ + "too big size", /* 1 */ + "irregal option" /* 2 */ +])$ +FLIST=0$ +IsYes=[]$ +ID_PLOT=-1$ + +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 makenewv(L) +{ + if((V=getopt(var))<2) V="z_"; + else if(isvar(V)) V=rtostr(V); + if(type(N=getopt(num))!=1) N=0; + Var=varargs(L|all=2); + for(XX=[],I=J=0;;I++){ + X=strtov(V+rtostr(I)); + if(findin(X,Var)<0){ + XX=cons(X,XX); + if(++J>N) return X; + else if(J==N) return reverse(XX); + } + } +} + +def shortv(P,L) +{ + V=vars(P); + if(type(T=getopt(top))==2) T=strtoascii(rtostr(T))[0]-87; + else T=10; + for(;L!=[];L=cdr(L)){ + for(J=0;J<36;J++){ + if(findin(X=makev([car(L),J]|num=1),V)>=0){ + while(findin(Y=makev([T]),V)>=0) T++; + if(T>35) return P; + P=subst(P,X,Y); + T++; + }else if(J>0) break; + } + } + return P; +} + +def vweyl(L) +{ + if(type(L) == 4){ + if(length(L) == 2) + return L; + else + return [L[0],makev(["d",L[0]])]; + } + /* else if(type(L)<2) return L; */ + 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(""); + else print("",2); +} + +def fcat(S,X) +{ + if(type(S)!=7){ + if(type(DIROUTD)!=7){ + DIROUTD=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"], + [getenv("HOME"),get_rootdir(),"/"])+"/"; + if(isMs()) DIROUTD=str_subst(DIROUTD,"/","\\"|sjis=1); + } + if(S==-1) return; + T="fcat"; + if(S>=2&&S<=9) T+=rtostr(S); + T=DIROUTD+T+".txt"; + if(S==-1) return T; + if(S!=0&&access(T)) remove_file(T); + S=T; + } + R=output(S); + print(X); + output(); + if(getopt(exe)==1) shell("\""+S+"\""); + return R; +} + +def mycat0(L,T) +{ + Opt = getopt(delim); + Del = (type(Opt) >= 0)?Opt:""; + if(type(L)!=4) L=[L]; + while(L != []){ + if(Do==1) + print(Del,0); + print(car(L),0); + L=cdr(L); + Do = 1; + } + if(T) print(""); + else print("",2); +} + +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) +{ + Step=getopt(step); + if(type(Step)==1){ + N=(Step>0)?Step:-Step; + if(type(L)==5) L=vtol(L); + L=qsort(L); + while(car(L)0&&car(L)==S)){ + C++; + L=cdr(L); + }else{ + R=cons(C,R);C=0;S+=M; + if(N>1&&++I>=N) break; + } + } + if(C>0) R=cons(C,R); + if(N>1&&(N-=length(R))>0) while(N-->0) R=cons(0,R); + return reverse(R); + } + 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 && type(N)<3) + return coef(P,N,X); + if(type(P) >= 4) +#ifdef USEMODULE + return map(os_md.mycoef,P,N,X); +#else + return map(mycoef,P,N,X); +#endif + if(type(N)==4){ + for(;N!=[];N=cdr(N),X=cdr(X)) + P=mycoef(P,car(N),car(X)); + return P; + } + 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 && type(X)<3) + return diff(P,X); + if(type(P) >= 4) +#ifdef USEMODULE + return map(os_md.mydiff,P,X); +#else + return map(mydiff,P,X); +#endif + if(type(X)==4){ + for(;X!=[];X=cdr(X)) P=mydiff(P,car(X)); + return P; + } + if(ptype(dn(P),X)<2) + 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) +#ifdef USEMODULE + return map(os_md.myediff,P,X); +#else + return map(myediff,P,X); +#endif + 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 pfctr(P,X) +{ + P=red(P); + if((T=ptype(P,X))>3) return []; + if(T==3){ + G=pfctr(dn(P),X); + F=pfctr(nm(P),X); + R=[[car(F)[0]/car(G)[0],1]]; + for(F=cdr(F);F!=[];F=cdr(F)) R=cons(car(F),R); + for(G=cdr(G);G!=[];G=cdr(G)) R=cons([car(G)[0],-car(G)[1]],R); + return reverse(R); + } + F=fctr(nm(P)); + for(R=[],C=1/dn(P);F!=[];F=cdr(F)) + if(mydeg(car(F)[0],X)>0) R=cons(car(F),R); + else C*=car(F)[0]^car(F)[1]; + return cons([C,1],reverse(R)); +} + +def mymindeg(P,X) +{ + if(type(P) < 3) + return mindeg(P,X); + II = -1;T=60; + 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){ + if(DT==0){ + if(type(car(P))>=T) continue; + T=type(car(P)); + } + 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 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(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]); + if(getopt(inv)==1){ + for(R=[];L!=[];L=cdr(L)) R=cons([car(L)[1],car(L)[0]],R); + L=reverse(R); + } + 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) +#ifdef USEMODULE + return map(os_md.simplify,P,L,T); +#else + return map(simplify,P,L,T); +#endif + if(type(L[0]) == 4){ + if(length(L[0]) > 1) +#if USEMODULE + return fmult(os_md.simplify,P,L,[T]); +#else + return fmult(simplify,P,L,[T]); +#endif + 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) +{ + Q=my_tex_form(P); + if(nmono(P)<2 && (getopt(minus)!=1 || str_str(Q,"-"|top=0,end=0)<0)) + return Q; + return "("+Q+")"; +} + +def minustos(S) +{ + if(str_str(S,"-"|top=0,end=0)<0) return S; + return "("+S+")"; +} + +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 dnorm(V) +{ + if(type(V)<2) return dabs(V); + R=0; + if(type(V)!=4) + for (I = length(V)-1; I >= 0; I--) R+= V[I]^2; + else{ + if(type(V[0])>3){ + V=ltov(V[0])-ltov(V[1]); + return dnorm(V); + } + for(;V!=[]; V=cdr(V)) R+=car(V)^2; + } + return dsqrt(R); +} + +def dvprod(V1,V2) +{ + if(type(V1)<2) return V1*V2; + R=0; + if(type(V1)!=4) + for(I = length(V1)-1; I >= 0; I--) + R += V1[I]*V2[I]; + else{ + for(; V1!=[]; V1=cdr(V1),V2=cdr(V2)) + R+=car(V1)*car(V2); + } + return R; +} + +def dvangle(V1,V2) +{ + if(V2==0 && type(V1)==4 && length(V1)==3 && + (type(V1[0])==4 || type(V1[0])==5 || type(V1[1])==4 || type(V1[1])==5 || + type(V1[2])==4 || type(V1[2])==5) ){ + if(V1[0]==0 || V1[1]==0 || V1[2]==0) return 1; + PV2=V1[1]; + if(type(PV2)==4){ + PV2=ltov(PV2); + return dvangle(PV2-ltov(V1[0]),ltov(V1[2])-PV2); + }else + return dvangle(PV2-V1[0],V1[2]-PV2); + } + if((L1=dnorm(V1))==0 || (L2=dnorm(V2))==0) return 1; + return dvprod(V1,V2)/(L1*L2); +} + +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 scale(L) +{ + T=F=0;LS=1; + Pr=getopt(prec); + Inv=getopt(inv); + Log10=dlog(10); + if(type(L)==7){ + V=findin(L,["CI","DI","CIF","CIF'","DIF","DIF'","SI","TI1","TI2","STI"]); + if(V>=0){ + L=["C","D","CF","CF'","DF","DF'","S","T1","T2","ST"]; + Inv=1;L=L[V]; + } + V=findin(L,["C","A","K","CF","CF'","S","T1","T2","ST","LL0","LL1","LL2","LL3","LL00", + "LL01","LL02","LL03"])+1; + if(V==0) V=findin(L,["D","B","K","DF","DF'"])+1; + if(V>0) L=V; + } + if(type(OL=L)!=4){ + if(L==2){ + L=(Pr==0)? + [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2]], + [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5]], + [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10]]]: + [[[1,2,1/50],[2,5,1/20],[5,10,1/10], [10,20,1/5],[20,50,1/2],[50,100,1]], + [[1,5,1/10],[5,10,1/2], [10,20,1],[50,100,5]], + [[1,5,1/2],[5,10,1], [10,50,5],[50,100,10]]]; + LS=2;M2=[[1,10,1],[10,100,10]]; + }else if(L==3){ + L=(Pr==0)? + [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2], + [100,200,5],[200,500,10],[500,1000,20]], + [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5], [100,200,10],[200,500,50]], + [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10], [100,200,50],[200,1000,100]]]: + [[[1,2,1/50],[2,5,1/20],[5,10,1/10],[10,20,1/5],[20,50,1/2],[50,100,1], + [100,200,2],[200,500,5],[500,1000,10]], + [[1,5,1/10],[5,10,1/2], [10,50,1],[50,100,5], [100,500,10],[500,1000,50]], + [[1,5,1/2],[5,10,1],[10,50,5],[50,100,10], [100,500,50],[500,1000,100]]]; + LS=3;M2=[[1,5,1],[10,50,10],[100,500,100],[500,1000,500]]; + }else if(L>9&&L<18){ + if(L<18){ /* LL0 - LL3, LL00 - LL03 */ + if(L==10){ + L=[ [[1.001,1.002,0.00001],[1.002,1.005,0.00002],[1.005,1.0105,0.00005]], + [[1.001,1.002,0.00005],[1.002,1.005,0.0001], [1.005,1.0105,0.0001]], + [[1.001,1.002,0.0001],[1.002,1.005,0.0005], [1.005,1.0105,0.0005]]]; + M2=[1.001,1.0015,1.002,1.003,1.004,1.005,1.006,1.007,1.008,1.009,1.01]; + } + if(L==11){ + L=[ [[1.01,1.02,0.0001],[1.02,1.05,0.0002],[1.05,1.105,0.0005]], + [[1.01,1.02,0.0005],[1.02,1.05,0.001], [1.05,1.105,0.001]], + [[1.01,1.02,0.001],[1.02,1.05,0.005], [1.05,1.105,0.005]]]; + M2=[1.01,1.015,1.02,1.03,1.04,1.05,1.06,1.07,1.08,1.09,1.10]; + }else if(L==12){ + L=[ [[1.105,1.2,0.001],[1.2,1.4,0.002],[1.4,1.8,0.005],[1.8,2.5,0.01], + [2.5,2.72,0.02]], + [[1.105,1.2,0.005],[1.2,1.4,0.01],[1.4,1.8,0.01],[1.8,2.5,0.05], + [2.5,2.72,0.1]], + [[1.105,1.2,0.01],[1.2,1.4,0.05],[1.4,1.8,0.05],[1.8,2.5,0.1], + [2.5,2.72,0.1]]]; + M2=[1.11,1.15,1.2,1.3,1.4,1.5,1.6,1.7,1.8,1.9,2.0,2.2,2.5]; + }else if(L==13){ + L=[ [[2.72,4,0.02],[4,6,0.05],[6,10,0.1],[10,15,0.2],[15,30,0.5],[30,50,1], + [50,100,2],[100,200,5],[200,400,10],[400,500,20],[500,1000,50], + [1000,2000,100],[2000,5000,200],[5000,10000,500],[10000,22000,1000]], + [[2.7,4,0.1],[4,6,0.1],[6,10,0.5],[10,15,1],[15,30,1],[30,50,5], + [50,100,10],[100,200,10],[200,400,50],[400,500,100],[500,1000,100], + [1000,2000,500],[2000,5000,1000],[5000,10000,1000],[10000,22000,5000]], + [[3,4,0.5],[4,6,0.5],[6,10,1],[10,15,5],[15,30,5],[30,50,10], + [50,100,50],[100,200,50],[200,400,100],[400,500,100],[500,1000,500], + [1000,2000,1000],[2000,5000,3000],[5000,10000,5000],[10000,22000,10000]]]; + M2=[3,4,5,6,7,8,9,10,15,20,30,40,50,100,200,500,1000,2000,5000,10000,20000]; + }else if(L==14){ + L=[ [[0.998,0.999,0.00001],[0.995,0.998,0.00002],[0.99,0.995,0.00005]], + [[0.998,0.999,0.00005],[0.995,0.998,0.0001],[0.99,0.995,0.0001]], + [[0.998,0.999,0.0001],[0.995,0.998,0.0005],[0.99,0.995,0.0005]]]; + M2=[0.999,0.9985,0.998,0.997,0.996,0.995,0.994,0.993,0.992,0.991,0.99]; + }else if(L==15){ + L=[ [[0.98,0.9901,0.0001],[0.95,0.98,0.0002],[0.905,0.95,0.0005]], + [[0.98,0.99,0.0005],[0.95,0.98,0.001], [0.905,0.95,0.001]], + [[0.98,0.99,0.001],[0.95,0.98,0.005], [0.91,0.95,0.005]]]; + M2=[0.99,0.985,0.98,0.97,0.96,0.95,0.94,0.93,0.92,0.91]; + }else if(L==16){ + L=[ [[0.8,0.906,0.001],[0.6,0.8,0.002],[0.37,0.6,0.005]], + [[0.8,0.906,0.005],[0.6,0.8,0.01],[0.37,0.6,0.01]], + [[0.8,0.9,0.01],[0.6,0.8,0.05],[0.4,0.6,0.05]]]; + M2=[0.9,0.85,0.8,0.75,0.7,0.65,0.6,0.55,0.5,0.45,0.4]; + }else{ + L=[ [[0.05,0.37,0.002],[0.02,0.05,0.001],[0.01,0.02,0.0005], + [0.005,0.01,0.0002],[0.001,0.005,0.0001], + [0.0005,0.001,0.00002],[0.0001,0.0005,0.00001],[0.00005,0.0001,0.000002]], + [[0.05,0.37,0.01],[0.02,0.05,0.002],[0.01,0.02,0.001], + [0.005,0.01,0.001],[0.001,0.005,0.0002], + [0.0005,0.001,0.0001],[0.0001,0.0005,0.00002],[0.00005,0.0001,0.00001]], + [[0.05,0.37,0.05],[0.02,0.05,0.01],[0.01,0.02,0.005], + [0.005,0.01,0.005],[0.002,0.005,0.001], + [0.0005,0.001,0.0005],[0.0001,0.0005,0.0001],[0.00005,0.0001,0.00005]]]; + M2=[0.3,0.2,0.1,0.05,0.03,0.02,0.01,0.005,0.002,0.001,0.0005,0.0002,0.0001]; + } + } + }else{ + if(L==6){ /* S */ + L=[ [[6-3/12,15,1/12],[15,30,1/6],[30,50,1/3],[50,70,1/2],[70,80,1],[80,90,5]], + [[6-1/6,15,1/6],[15,30,1/2],[30,70,1],[70,80,5],[80,90,10]], + [[6,15,1/2],[15,30,1],[30,70,5],[70,90,10]] ]; + M2=[6,7,8,9,10,15,20,30,40,50,60,70,90]; + }else if(L==7){ /* T1 */ + F=log(tan(x*3.1416/180))/Log10+1; + L=[ [[6-1/3,15,1/12],[15,45,1/6]], + [[6-1/3,15,1/6],[15,45,1/2]], + [[6,45,1]] ]; + M2=[6,7,8,9,10,15,20,30,40,45]; + }else if(L==8){ /* T2 */ + L=[ [[45,75,1/6],[75,84+1/6,1/12]], + [[45,75,1],[75,84+1/6,1/6]], + [[45,84,1]] ]; + M2=[45,50,60,70,75,80,81,82,83,84]; + }else if(L==9){ /* ST */ + L=[ [[35/60,1,1/120],[1,2,1/60],[2,5+9/12,1/30]], + [[35/60,1,1/60],[1,2,1/6],[2,5+9/12,1/6]], + [[40/60,1,1/6],[1,2,1/2],[2,5+9/12,1]] ]; + M2=[1,2,3,4,5]; + }else{ + M2=(L==4||L==5)?[[1,2,1/2],[2,9,1]]:[[1,2,1/2],[2,10,1]]; + L=(Pr==0)? + [ [[1,2,1/50],[2,5,1/20],[5,10,1/10]], + [[1,5,1/10],[5,10,1/2]], + [[1,5,1/2],[5,10,1]] ]: + [[[1,2,1/100],[2,5,1/50],[5,10,1/20]], + [[1,2,1/20],[2,10,1/10]], + [[1,2,1/10],[2,10,1/2]] ]; + } + } + }else if(type(L[0])!=4){ + L=[L]; + if(length(L)!=3||L[0]+L[2]>L[1]) T=L; + } + if(T==0){ + if(type(L[0][0])!=4) L=[L]; + for(R=[];L!=[];L=cdr(L)){ + for(RR=[],LT=car(L);LT!=[];LT=cdr(LT)) + for(I=car(LT)[0];I<=car(LT)[1];I+=car(LT)[2]) RR=cons(I,RR); + RR=lsort(RR,[],1); + R=cons(RR,R); + } + R=reverse(R); + for(T=[];R!=[];R=cdr(R)){ + if(length(R)>1) T=cons(lsort(R[0],R[1],"setminus"),T); + else T=cons(R[0],T); + } + } + V0=dlog(10); + S0=S1=1;D0=D1=0; + SC=getopt(scale); + if(type(SC)==4){ + S0=SC[0];S1=SC[1]; + }else if(type(SC)==1){ + S0=SC;S1=0; + }else return T; + if(type(D=getopt(shift))==4){ + D0=D[0];D1=D[1]; + }else if(type(D)<2&&type(D)>=0){ + D0=0;D1=D; + }; + if(Inv==1){ + D0+=S0;S0=-S0; + } + if(type(TF=getopt(f))>1) F=TF; + if(F) F=f2df(F); + if(type(I=getopt(ol))==1&&OL>3) OL=I; + for(M=M0=[],I=length(T);T!=[];T=cdr(T),I--){ + for(S=car(T);S!=[];S=cdr(S)){ + VS=car(S); + if(F) V=myfdeval(F,car(S)); + else if(OL==4) V=frac(dlog(VS)/Log10+0.5); + else if(OL==5) V=frac(dlog(VS*3.1416)/Log10); + else if(OL>5&&OL<10){ + VS=VS*3.1416/180; + if(OL==6) V=dlog(dsin(VS))/Log10+1; + else if(OL==9) V=dlog(VS)/Log10+2; + else V=dlog(dtan(VS))/Log10+8-OL; + } + else if(OL>9&&OL<14) V=dlog(dlog(VS))/Log10+13-OL; + else if(OL>13&&OL<18) V=dlog(-dlog(VS))/Log10+17-OL; + else V=dlog(VS)/Log10/LS; + V*=S0; + if(S1!=0){ + M=cons([V+D0,D1],M); + M=cons([V+D0,((length(SC)>2)?SC[I]:(I*S1))+D1],M); + M=cons(0,M); + }else M0=cons(V+D0,M0); + } + if(S1==0) M=cons(reverse(M0),M); + } + if(S1!=0) M=cdr(M); + if(S1==0||getopt(TeX)!=1) return M; + M=reverse(M); + if(type(U=getopt(line))==4){ + if(Inv==1) U=[U[0]+S0,U[1]+S0]; + M=cons([U[0]+D0,D1],cons([U[1]+D0,D1],cons(0,M))); + } + if((VT=getopt(vert))==1){ + for(N=[];M!=[];M=cdr(M)){ + if(type(TM=car(M))==4) N=cons([TM[1],TM[0]],N); + else N=cons(TM,N); + } + M=reverse(N); + } + if(type(Col=getopt(col))<1) S=xylines(M); + else S=xylines(M|opt=Col); + if(type(Mes=getopt(mes))==4){ + if(length(Mes)==1&&type(M2)==4) Mes=cons(car(Mes),M2); + S3=car(Mes); + if(type(S3)==4){ + Col=S3[1]; + S3=car(S3); + }else Col=0; + V=car(scale(cdr(Mes))); + if(!F) Mes=scale(cdr(Mes)|scale=[S0/LS,0],shift=[D0,D1],ol=OL); + else Mes=scale(cdr(Mes)|f=F,scale=[S0,0],shift=[D0,D1]); + for(M=car(Mes);M!=[];M=cdr(M),V=cdr(V)){ + TV=deval(car(V)); + if(Col!=0) TV=[Col,TV]; + S+=(VT==1)?xyput([S3+D1,car(M),TV]):xyput([car(M),S3+D1,TV]); + } + } + if(type(Mes=getopt(mes2))==4){ + if(type(car(Mes))!=4) Mes=[Mes]; + for(;Mes!=[];Mes=cdr(Mes)){ + TM=car(Mes); + if(!F) V=scale([car(TM)]|scale=[S0/LS,0],shift=[D0,D1],ol=OL); + else V=scale([car(TM)]|f=F,scale=[S0,0],shift=[D0,D1]); + V=car(car(V)); + TM=cdr(TM); + if(type(Col=car(TM))==4){ + C0=Col[0];C1=Col[1]; + if(length(Col)==3){ + S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]|opt=Col[2]) + :xyline([V,D1+C0],[V,D1+C1]|opt=Col[2]); + }else S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]):xyline([V,D1+C0],[V,D1+C1]); + } + if(type(TM[1]<2)){ + TM=cdr(TM); + S3=car(TM); + } + S+=(VT==1)?xyput([S3+D1,V,TM[1]]):xyput([V,S3+D1,TM[1]]); + } + } + return S; +} + +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])); + } + } + if(!(M=Nm*PNm)) return [VV,0]; + Mul = (Lcm*Dn)/M; + 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 mytrace(M) +{ + S=size(M); + if(S[0]!=S[1]) return 0; + for(I=V=0; I 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 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= 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; IJ){ + 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) +{ + TeXs=["\\ -=\\ ","\\ +=\\ "]; + Lins=[" -= line"," += line"]; + Assume=["If","Assume"]; + if(type(St = getopt(step))!=1) St=0; + Opt = getopt(opt); + if(type(Opt)!=1) Opt=0; + if(type(Main=getopt(main))!=1) Main=0; + TeX=getopt(dviout); + if(type(Tab=getopt(tab))!=1 && Tab!=0) Tab=2; + Line="\\text{line}"; + if(type(TeX)!=1 || !St) 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){ + if(TeX) Lout=[[dupmat(M)]]; + else mycat0([M,"\n\n"],0); + } + Top=""; + if(Opt>3){ + for(I=Opt; I>4; I--) + Top+=(TeX)?"\\ ":" "; + } + PC=IF=1; + if(Opt>3){ + for(P=[1],K=0;K2 && (Mul=M[J][K])!=1){ + for(FF=0,JT=J; JTtype(Mul)) continue; + if(type(Val)3){ + if(isint(Val)==1){ /* integer elememt */ + if(isint(Mul)!=1){ + Mul=Val; J=JT; /* integer */ + } + if(FF<3||(FF==3&&Val>0)){ + for(JK=K+1;;){ + if(JK>=Size[1]-F){ + J=JT; + FF=((Mul=Val)>0)?4:3; + break; /* divisible int => 4: pos_int 3: neg_int */ + } + if(isint(M[JT][JK++]/Val)!=1) break; + } + } + }else if(!FF){ + for(JK=K+1; JK 1: non integer */ + } + } + } + } + if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){ /* FF > 0 => divisible */ + for(FF=0,J0=J; J00){ + for(I=K;I4 && length(Var=vars(nm(M[J][K])))==1){ + J0=J;Jv=mydeg(nm(M[J0][K]),car(Var)); + for(I=JJ;I1) continue; + if(mydeg(MIK,T[0])0){ + QF=1;Q0*=T; continue; + } + if(subst(PC,Var,T)==0) continue; + Q0*=(Var-(T=QR[0][1])); + if(type(T)<2){ + M0=subst(M,Var,T); + if(TeX){ + Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }", + Var,"=",T,","] ,Lout); + Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),Lout); + }else{ + mycat([str_times(" ",St-1)+"If",Var,"=",T,","]); + mtoupper(M0,F|step=St+1,opt=Opt,main=Main); + } + } + } + if(Q0!=1){ + if(TeX) + Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[QF]+" }", + Q0/=fctr(Q0)[0][0],"\\ne0,"],Lout); + else + mycat([str_times(" ",St-1)+Assume[QF],Q0,"!=0,"]); + PC*=Q0; + } + IF=0;St++; + }else{ + KRC=-red((T[2]*dn(M[J0][K]))/(T[1]*dn(M[I][K]))); + for(II=K;II=2)?Temp:-Temp; + } + if(St){ + 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); + } + } + /* Assume PC != 0 */ + if(Opt>1){ + Mul = M[JJ][K]; + if(Opt > 5 && St && IF && (Var=vars(MIK=nm(Mul)))!=[]){ + TF=fctr(MIK); + for(FF=0,Q0=1,TP=cdr(TF);TP!=[];TP=cdr(TP)){ + if(type(dn(red(PC/(TP0=car(car(TP))))))<2) continue; /* divisible */ + Q0*=TP0; + for(Var=vars(TP0);Var!=[];Var=cdr(Var)){ + if(mydeg(TP0,X=car(Var))==1 && type(dn(red(PC/mycoef(TP0,1,X))))<2){ + /* TP0=A*X+B with non-vanishing A */ + T=red(-mycoef(TP0,0,X)/mycoef(TP0,1,X)); + M0=mysubst(M,[X,T]); + if(TeX){ + Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }", + X,"=",T,","] ,Lout); + Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main), + Lout); + }else{ + mycat([str_times(" ",St-1)+"If",X,"=",T,","]); + mtoupper(M0,F|step=St+1,opt=Opt,main=Main); + } + break; + } + } + if(Var==[] && Opt>6){ + for(Var=vars(TP0);Var!=[];Var=cdr(Var)){ + if(mydeg(TP0,X=car(Var))==1){ + /* TP0=A*X+B, A is a poly of X0 with rational funct */ + T=nm(mycoef(TP0,1,X)); + for(Var0=vars(T);Var0!=[]; Var0=cdr(Var0)){ + X0=car(Var0); + if(type(dn(red(PC/type(mycoef(T,mydeg(T,X0),X0)))))>1) continue; + TR=getroot(T,X0|mult=1); + if(findin(X0,vars(TR))<0) break; + } + if(Var0==[]) continue; + for(;TR!=[0];TR=cdr(TR)){ + if(TR==[]){ + TR=[0,0]; + T0=-mycoef(TP0,0,X)/mycoef(TP0,1,X); + X0=X; + }else T0=car(TR)[1]; + M0=mysubst(M,[X0,T0]); + if(TeX){ + Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }", + X0,"=",T0,","] ,Lout); + Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main), + Lout); + }else{ + mycat([str_times(" ",St-1)+"If",X0,"=",T0,","]); + mtoupper(M0,F|step=St+1,opt=Opt,main=Main); + } + } + + } + break; + } + } + if(Var==[]){ + FF=1; + } + } + if(Q0!=1){ + if(FF) FF=1; + if(TeX) Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[FF]+" }",Q0/=fctr(Q0)[0][0],"\\ne0,"], + Lout); + else mycat([str_times(" ",St-1)+Assume[FF],Q0,"!=0,"]); + PC*=Q0;St++; + } + } + IF=M[JJ][K]=1; + if(Mul!=1){ + for(L=K+1; L0)?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&&!Main){ + if(Mul<0){ + Mul=-Mul;Sgn=0; + }else Sgn=1; + if(TeX){ + if(Mul==1) + Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1, + "}",dupmat(M)],Lout); + else Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1, + "\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout); + }else{ + if(Mul==1) + mycat0([Top+"line",J+1, Lins[Sgn],JJ+1,"\n",M,"\n\n"],0); + else + mycat0([Top+"line",J+1, Lins[Sgn],JJ+1," * (",Mul,")\n",M,"\n\n"],0); + } + } + } + } + JJ++; + } + } + } + if(TeX){ + if(TeX==-2) return Lout; + Lout=reverse(Lout); + Br="\\allowdisplaybreaks"; + Cr="\\\\\n &"; + if(getopt(pages)==1) Cr=Br+Cr; + if(type(S=getopt(cr))==7) Cr=S; + if(type(Lim=getopt(lim))==1){ + if(Lim>0){ + if(Lim<30) Lim=TeXLim; + Lim*=2; + } + }else Lim=0; + Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr,lim=Lim); + if(TeX<0) return Out; + dviout(Out|eq=(str_str(Cr,Br)>=0)?6:5,keep=(TeX==1)?0:1); + } + 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 transm(M) +{ + if(type(M)!=6) M=s2m(M); + if(type(M)!=6){ + errno(0); + return 0; + } + L=[M];TeX=""; + Line=["\\text{line}","\\text{col}"]; + if((DVI=getopt(dviout)) !=1) DVI=0; + else dviout(M); + for(;;){ + print(L0=dupmat(car(L))); + Sz=size(L0); + S=keyin("? "); + N=0; + if(str_len(S)<=1){ + if(S=="q") return L; + if(S=="t"){ + N=mtranspose(L0); + TeX=["\\text{transpose}"]; + } + else if(S=="f"){ + if(length(L)>1){ + if(LF!=0) TeX=""; + L=cdr(L);LF=L0; + if(DVI){ + dviout0(-1); + dviout(" "); + } + } + }else if(S=="g"){ + if(LF!=0) N=LF; + }else if(S=="0"){ + N=M;L=[];TeX=[]; + }else if(S=="a"||S=="A"){ + if(DVI&&S=="A") mtoupper(L0,0|step=1,opt=10,dviout=1); + else mtoupper(L0,0|step=1,opt=10); + }else{ + mycat0([ + "2,5 : line2 <-> line5", + "2,5,-2 ; line2 += (-2)*line5", + "2,2,-2 : line2 *= -2", + "2,5,0 : line2 += (?)*line5 for reduction", + "r,2,5 : raw2 <-> raw5 (r,2,5,-2 etc.)", + "s,x,2 : subst(*,x,2)", + "t : transpose", + "0 : first matrix", + "f : previous matrix", + "g : next matrix (only after f)", + "A : auto (a : without TeX)", + "q : quit" + ],1|delim="\n"); + } + }else{ + FR=0; + S=evals(S|del=","); + if(S[0]==r){ + FR=1; S=cdr(S); + } + if((LL=length(S))>=2){ + S0=S[0]-1;S1=S[1]-1; + if(S[0]==s){ + if(length(S)==3) N=subst(L0,S[1],S[2]); + if(DVI) TeX=[S[1],"\\mapsto",S[2]]; + }else if(FR==0){ + if(S0<0 || S0>=Sz[0] || S1<0 || S1>=Sz[0]) continue; + if(LL==2){ + N=rowx(L0,S0,S1); + if(DVI) TeX=[Line[0],S[0],"\\ \\leftrightarrow\\ ",Line[0],S[1]]; + }else{ + S2=S[2]; + if(S0==S1){ + N=rowm(L0,S0,S2); + if(DVI) TeX=[Line[0],S[0],"\\ \\times=\\ ",S2]; + }else{ + if(S2==0){ + for(J=0;J=Sz[1] || S1<0 && S1>=Sz[1]) continue; + if(LL==2){ + N=colx(L0,S0,S1); + if(DVI) TeX=[Line[1],S[0],"\\ \\leftrightarrow\\ ",Line[1],S[1]]; + }else{ + S2=S[2]; + if(S0==S1){ + N=colm(L0,S0,S2); + if(DVI) TeX=[Line[1],S[0],"\\ \\times=\\ ",S[2]]; + }else{ + if(S2!=0){ + for(J=0; I10) + return -1; + return(I==IM)?0:I; +} + +def mmc(M,X) +{ + Mt=getopt(mult); + if(type(M)==7) M=s2sp(M); + if(type(M)!=4) return 0; + if(type(M[0])<=3){ + for(RR=[];M!=[];M=cdr(M)) RR=cons(mat([car(M)]),RR); + M=reverse(RR); + } + if(type(M[0])!=6){ /* spectre type -> GRS */ + G=s2sp(M|std=1); + L=length(G); + for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V); + V=cons(makev([L+9]),V); + G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1); + if(getopt(short)!=0){ + V=append(cdr(V),[V[0]]); + G=shortv(G,V); + } + R=chkspt(G|mat=1); + if(Mt!=1) Mt=0; + if(R[2]!=2 || R[3]!=0 || !(R=getbygrs(G,1|mat=1))) return 0; + MZ=newmat(1,1); + SS=length(G); + if(Mt==1) SS=SS*(SS-1)/2; + for(M=[],I=0;I=6 && Mt!=0)||(L==3&&Mt==1)){ + for(SS=2,I=3; ISS){ /* addition */ + for(I=0;I=0; I--){ + if(I==J){ + for(RR=[],K=SS-1; K>=0; K--) + RR=cons((K==I)?N[K]+diagm(S,[X]):N[K],RR); + R=cons(RR,R); + }else R=cons([MZ],R); + } + MM[J]=newbmat(SS,SS,R); + if(J==0) M1=MM[0]; + else M1=radd(M1,MM[J]); + } + /* middle convolution */ + for(P=0,Q=1;J=0; I--){ + for(RR=[],K=SS-1;K>=0;K--){ + MT=MZ; + if(I==K){ + MT=N[J]; + if(I==P) MT-=N[Q]; + else if(I==Q) MT-=N[P]; + }else if(I==P && K==Q) MT=N[Q]; + else if(I==Q && K==P) MT=N[P]; + RR=cons(MT,RR); + } + R=cons(RR,R); + } + MM[J]=newbmat(SS,SS,R); + if(++Q==SS){ + P++;Q=P+1; + } + } + for(R=[],I=SS-1; I>=0; I--){ + for(RR=[N[I]],J=0; J0){ + Q *= V[I]; + M[I]--; + } + } + return Q; +} + +def mdivisor(M,X) +{ + S=size(M=dupmat(M)); + XX=(type(X)==4||X==0)?X:[0,X]; + S0=S[0]; S1=S[1]; + if((Tr=getopt(trans))==1||Tr==2){ + Tr0=1; + GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0); + }else Tr=Tr0=0; + /* 0,a,b : (a,b)->(1,1) + 1 : (1,1) invertible + 2,i,M : line 0,i by M + 3,j,M : col 0,j by M + 4,j : col 1 += col j + 5,j,T : line j by T + 6,j,T : col 1 += col j by T (non-com) + 7,j : line 2<->j (non-com) + */ + if(type(V=getopt(dviout))==1){ + if(type(XX)==4 && type(XX[0])>1) Var=[XX[1],"\\partial"]; + else Var=0; + Tr=(abs(V)==3)?0:1; + MM=dupmat(M); + II=((S[0]>S[1])?S[1]:S[0])+1; + if(abs(V)>1){ + Is1=Js1=S[0]+S[1]; + Is=Js=[0,[Is1]]; + }else{ + Is=[0,[Is1=S[0]]];Js=[0,[Js1=S[1]]]; + } + VV=V; + V=newvect(II); + for(I=0;I",I,")"],Out); + NN=mperm(N,Is1,Js1); + for(K=S[0];K",I,")"],Out); + else continue; + }else if(C==2){ + C=mat(N[I0],N[R[1]+I0]);C=muldo(R[2],C,XX); + for(J=0;J0){ + dviout(Out|eq=6); + return NN; + } + return Out; + }else if(type(V)!=5) V=0; + + if(type(St=getopt(step))!=1) St=0; + for(FF=": start";;){ + if(St && V==0){ + 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(X==0||X==[0,0]){ /* search minimal non-zero element */ + for(K=F=I=0; IP || 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) return [[],mgen(S0,0,1,0),mgen(S1,0,1,0)]; + return []; + } + R0=R[1][0];R1=R[1][1]; + if(R0!=0){ + M=rowx(M,0,R0); + if(Tr) GR=rowx(GR,0,R0); + } + if(R1!=0){ + M=colx(M,0,R1); + if(Tr) GC=colx(GC,0,R1); + } + if(St>0 && (R0!=0 || R1!=0)) + if(type(V)==5) V[St]=cons([0,R0,R1],V[St]); + else if(Tr){ + 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(R[0]==0){ /* (1,1) : invertible */ + if(type(V)==5) V[St]=cons([1],V[St]); + P=M[0][0]; M[0][0]=1; + for(J=0;J 1 */ + if(J>0) M[0][J]= red(M[0][J]/P); + if(Tr) GR[0][J]=red(GR[0][J]/P); + } + if(S0>1 && S1>1) N=newmat(S0-1,S1-1); + else N=0; + for(I=1;I0 && V==0){ + if(Tr){ + mycat0([St,": unit\n"],0); + mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]); + } + else mycat0([St,": unit\n",M,"\n"],0); + } + if(N==0){ + if(!Tr) return [1]; + if(Tr==2){ + GR0=mdivisor(GR,X|trans=1)[1]; + GC0=mdivisor(GC,X|trans=1)[1]; + return [[1],GR,GC,GR0,GC0]; + } + return [[1],GR,GC]; + } + R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St); + if(!Tr) return cons(1,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(GC,GR,XX); GC=mgen(S0,0,1,0); + } + if(Tr==2){ + GR0=mdivisor(GR,X|trans=1)[1]; + GC0=mdivisor(GC,X|trans=1)[1]; + return [cons(1,R[0]),GR,GC,GR0,GC0]; + } + return [cons(1,R[0]),GR,GC]; + } + for(I=1;IS0) continue; + for(J=1;JS1) continue; + if(S0==1 || S1==1){ + P=M[0][0]; + if(X==0){ + if(P<0){ + P=-P; + if(Tr) for(J=0;J0)?St+1:St); + RT=(Tr)?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) 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(GC,GR,XX); GC=mgen(S0,0,1,0); + } + if(Tr==2){ + GR0=mdivisor(GR,X|trans=1)[1]; + GC0=mdivisor(GC,X|trans=1)[1]; + return [RR,GR,GC,GR0,GC0]; + } + return [RR,GR,GC]; + } /* End of commutative case */ + for(I=1; I1){ + M=rowx(M,1,I); + if(Tr) GR=rowx(GR,1,I); + if(type(V)==5) V[St]=cons([7,I],V[St]); + FF+=", line 2<->"+rtostr(I+1); + } + for(I=1;IS0) 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]; +#if 0 + MN=newmat(S,S); + MD=newmat(S,S); + for(I=0;I2) continue; + } + } + } +#endif + DD=newvect(S); + for(I=0; I1) 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); + if(getopt(anal)==1) return R; /* called by mc2grs() */ + 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 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 l2p(L,V) +{ + if(type(L)==4){ + for(S=I=0;L!=[];L=cdr(L),I++) + S+=car(L)*V^I; + return S; + }else if(type(L)==5){ + for(S=0,I=size(L)-1;I>=0;I--) + S+=L[I]*V^I; + return S; + }else{ + if(type(D=getopt(size))==1) D--; + else D=mydeg(L,V); + for(S=[];D>=0;D--) + S=cons(mycoef(L,D,V),S); + return S; + } +} + +def paracmpl(L,V) +{ + if(type(L)==4) L=ltov(L); + S=length(L); + Lim=getopt(lim);Low=getopt(low); + if((F=type(L[0]))>3){ + SV=length(L[0]); + V0=makenewv(L); + for(LL=[];S>0;S--) + LL=cons(l2p(L[S-1],V0),LL); + G=paracmpl(LL,V|option_list=getopt()); + H=(Lim==1)?G:G[0]; + for(HH=[];H!=[];H=cdr(H)){ + HT=l2p(car(H),V0|size=SV); + if(F==5) HT=ltov(HT); + HH=cons(HT,HH); + } + H=reverse(HH); + return (Lim==1)?H:[H,G[1]]; + } + H=newvect(S);D=newvect(S); + for(Dn=1,I=0;I0){ + P=red(P/V^K); + G=colm(G,I,1/V^K); + } + for(DT=[],VT=VV;VT!=[];VT=cdr(VT)){ + K=(Low==1)?mymindeg(C,car(VT)):mydeg(C,car(VT)); + C=mycoef(C,K,car(VT)); + DT=cons(K,DT); + } + D[I]=DT=reverse(DT); + for(C=P,VT=VV;VT!=[];VT=cdr(VT),DT=cdr(DT)) + C=mycoef(C,car(DT),car(VT)); + H[I]=P=red(P/C); + G=colm(G,I,1/C); + } + if(Dn!=1){ + for(I=0;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; IJ) J=length(car(V)); + return [I,J]; +} + +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 V; +} + +def rsort(L,T,K) +{ + for(R=[];L!=[];L=cdr(L)) + R=cons((type(car(L))==4)?rsort(car(L),T-1,K):car(L),R); + if(T>0||iand(T,iand(K,2)/2)) return reverse(R); + R=qsort(R); + return (iand(K,1))? reverse(R):R; +} + + +def lsort(L1,L2,T) +{ + C1=getopt(c1);C2=getopt(c2); + if(type(T)==4){ + K=T; + if(length(T)>0){ + T=K[0]; + K=cdr(K); + }else T=0; + }else K=0; + if(type(TT=T)==7) + T = findin(T,["cup","setminus","cap","reduce","sum","subst"]); + if(type(L2)==7&&T<0) + T=findin(TT,["put","get","sub"]); + if(K){ /* [[..],..] */ + if(K!=[]) KN=K[0]; + if(L2==[]||L2=="sort"){ /* sort or deduce duplication */ + if((T!=0&&T!=3)||length(K)!=1) return L1; + if(KN<0){ + KN=-KN-1; + F=-1; + }else F=1; + L1=msort(L1,[F,0,KN]); + if(T==3){ + R=[car(L1)];L1=cdr(L1); + for(;L1!=[];L1=cdr(L1)){ + if(car(L1)[KN]!=car(R)[KN]) R=cons(car(L1),R); + } + L1=reverse(R); + } + return L1; + }else if((L2==0||L2=="col")&&type(C1)==4){ + if(T==0||T==1){ /* extract or delete columns */ + for(R=[];L1!=[];L1=cdr(L1)){ + if(T==1&&C1==[0]){ /* delete top column */ + R=cons(cdr(car(L1)),R); + continue; + } + LT=car(L1);RT=[]; + if(T==0){ + for(CT=C1;CT!=[];CT=cdr(CT)) RT=cons(LT[car(CT)],RT); + }else{ + for(I=0;LT!=[];I++,LT=cdr(LT)) + if(findin(I,C1)<0) RT=cons(car(LT),RT); + RT=reverse(RT); + } + R=cons(RT,R); + } + return reverse(R); + } + }else if(type(L2)==1||type(L2)==7){ + if(L2==1||L2=="num"){ + if(T==4) T=3; + I=(length(K)<2)?(-1):K[1]; + if(T==0||T==1||T==2||T==3){ + S=F=CT=0;R=[]; + if(K==[] || type((S=K[0]))==1 || S==0){ + if(T==0||T==1||T==2){ + for(J;L1!=[];L1=cdr(L1),J++){ + if(T==0) R=cons(cons(J+S,car(L1)),R); + else if(T==1){ + for( ;C1!=[]; C1=cdr(C1)) + R=cons(L1[car(C1)],R); + }else{ + if(findin(J,C1)<0) R=cons(car(L1),R); + } + } + return reverse(R); + }else if(T==3) return length(L1); + }else{ + if(type(S)==2&&vtype(S)>2) F=1; + else if(type(S)==4) F=2; + else if(S=="+") F=3; + else return L1; + } + for(R=[];L1!=[];L1=cdr(L1)){ + L1T=car(L1); + if(F==1) V=call(S,(I<0)?L1T:L1T[I]); + else if(F==2) V=calc((I<0)?L1T:L1T[I],S); + else if(F==3){ + for(C=C1,V=0;C!=[];C=cdr(C)) + if(type(X=L1T[car(C)])==1) V+=X; + } + if(T==0) R=cons(cons(V,L1T),R); + else if(T==1){ + if(V) R=cons(L1T,R); + }else if(T==2){ + if(!V) R=cons(L1T,R); + }else if(T==3){ + if(F==3) CT+=V; + else if(V) CT++; + } + } + return (T==3)?CT:reverse(R); + }else if(TT=="col"){ + J=(length(K)>0)?car(K):0; + I=length(car(L1))+J; + for(V=[];I>J;) + V=cons(--I,V); + return cons(V,L1); + } + }else if(L2=="transpose") return mtranspose(L1); + else if(L2=="subst"||L2=="adjust"){ + Null=(!K)?"":car(K); + if(L2=="adjust") C1=[]; + R=lv2m(L1|null=""); + for(;C1!=[];C1=cdr(C1)) R[car(C1)[0]][car(C1)[1]]=car(C1)[2]; + return m2ll(R); + } + return L1; + }else{ /* [[..],..], [[..],..] */ + if(type(L2[0])<4){ + for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R); + L2=reverse(R); + } + if(TT=="sum") T=3; + if(TT=="over") T=4; + if(findin(T,[0,1,2,3,4,5])<0) return L1; + if(T==4||T==5){ + if(type(C1)<2) C1=[C1]; + if(type(C2)<2) C2=[C2]; + } + if(type(car(L2))!=4){ + for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R); + R=reverse(R); + if(length(K)==1) K=[K[0],0]; + C2=0; + } + L1=lsort(L1,"num",["put",0]); /* insert number */ + K0=(length(K)>0)?K[0]+1:1; + K1=(length(K)>1)?K1=K[1]:0; + L1=lsort(L1,"sort",[0,K0]); + if(T<4&&type(C2)==4&&length(L2[0])>1){ + L2=lsort(L2,"col",["put"]|c1=cons(K1,C2)); /* add key and extract columns */ + C2=0;K1=0; + } + L2=lsort(L2,"sort",[0,K1]); + for(R0=[],S=S1=length(L1[0]);S>0;S--) R0=cons("",R0); + for(R1=[],S=length(L2[0]);S>0;S--) R1=cons("",R1); + if(!K1&&T!=3) R1=cdr(R1); + for(R=[];L1!=[];L1=cdr(L1)){ + while(L2!=[]&&car(L1)[K0]>car(L2)[K1]){ + if(T==3) R=cons(append(R0,car(L2)),R); + L2=cdr(L2); + } + if(L2==[]||car(L1)[K0]3||R1==[])?car(L1):append(car(L1),R1),R); + }else if(T==0||T==2||T==3){ + if(R0==[]) R=append(car(L1),R); + else R=cons(append(car(L1),(!K1&&T!=3)?cdr(car(L2)):car(L2)),R); + L2=cdr(L2); + }else if(T==4||T==5){ + V1=ltov(car(L1));V2=ltov(car(L2)); + for(D1=C1,D2=C2;D1!=[];D1=cdr(D1),D2=cdr(D2)) + if((I=V2[car(D2)])!=""||T==4) V1[car(D1)+1]=I; + R=cons(vtol(V1),R); + } + } + if(T==3){ + while(L2!=[]){ + R=cons(append(R0,car(L2)),R); + L2=cdr(L2); + } + } + R=lsort(R,"sort",["put",0]); /* original order */ + D=(((T==0||T==2)&&!K1)||T==3)?[0]:[0,S1+K1]; + R=lsort(R,0,[1]|c1=D); /* delete */ + if(type(C1)!=4||T==1||T==4||T==5) return R; + C=[];S0=size(L1[0]); + for(;C1!=[];C1=cdr(C1)) C=cons(car(C1),C); + for(I=0;I= 0; I--){ + if(I > 0 && L1[I] == L1[I-1]) + continue; + L3 = cons(L1[I], L3); + } + return L3; + } + if(T==8||TT=="count"){ + K=length(lsort(L1,L2,3)[0]); + R=[length(L2),length(L1)]; + L1 = lsort(L1,[],1); + L2 = lsort(L2,[],1); + R=append([length(L2),length(L1)],R); + R=cons(length(lsort(L1,L2,2)),R); + return reverse(cons(K,R)); + } + if((T==9||TT=="cons")&&type(car(L1))==4){ + if(type(L2)!=4) L2=[L2]; + for(R=[];L1!=[];L1=cdr(L1)){ + R=cons(cons(car(L2),car(L1)),R); + if(length(L2)>1) L2=cdr(L2); + } + return reverse(R); + } + if(T==10||TT=="cmp"){ + if(length(L1)!=length(L2)){ + mycat("Different length!"); + return 1; + } + R=[]; + if(type(car(L1))==4){ + for(U=[],I=0;L1!=[];I++,L1=cdr(L1),L2=cdr(L2)){ + if(length(S=car(L1))!=length(T=car(L2))){ + mycat(["Different size : line ",I]); + return 0; + } + for(J=0;S!=[];S=cdr(S),T=cdr(T),J++) + if(car(S)!=car(T)) U=cons([[I,J],car(S),car(T)],U); + } + if(U!=[]) R=cons(reverse(U),R); + }else{ + for(I=0;L1!=[];L1=cdr(L1),L2=cdr(L2),I++) + if(car(L1)!=car(L2)) R=cons([I,car(L1),car(L2)],R); + } + return reverse(R); + } + if(T==11||TT=="append"){ + if(type(car(L1))!=4) return append(L1,L2); + for(R=[];L1!=[];L1=cdr(L1),L2=cdr(L2)) + R=cons(append(car(L1),car(L2)),R); + return reverse(R); + } + 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 mqsub(X,Y) +{ + for(L=LQS;L!=[];L=cdr(L)){ + F=(T=car(L))[0];M=(T=cdr(T))[0]; + X0=X;Y0=Y; + for(T=cdr(T);T!=[];T=cdr(T)){ + X0=X0[car(T)];Y0=Y0[car(T)]; + } + if(type(M)==1){ + if(M==3){ + X0=type(X0);Y0=type(Y0); + }else if(M==4&&type(X0)<2&&type(Y0)<2){ + X0=abs(X0);Y0=abs(Y0); + }else if(M==5){ + X0=str_len(rtostr(X0));Y0=str_len(rtostr(Y0)); + }else if(type(X0)==type(Y0)&&type(X0)>3&&type(X0)<7){ + if(M==1){ + X0=length(X0);Y0=length(Y0); + }else if(M==2){ + LX=length(X0);LY=length(Y0); + L0=(LX car(L)) V=car(L); + return V; + }else if(type(L)==5||type(L)==6) + return lmin(m2l(L)); + return []; +} + +def lgcd(L) +{ + if(type(L)==4){ + F=getopt(poly); + V=car(L); + while((L=cdr(L))!=[]&&V!=1){ + if(V!=0) + V=(F==1)?gcd(V,car(L)):igcd(V,car(L)); + } + return V; + }else if(type(L)==5||type(L)==6) + return lgcd(m2l(L)|option_list=getopt()); + return []; +} + +def llcm(L) +{ + if(type(L)==4){ + F=getopt(poly); + V=car(L); + while((L=cdr(L))!=[]){ + if(V!=0){ + if((V0=car(L))!=0) + V=(F==1)?red(V*V0/gcd(V,V0)):ilcm(V,V0); + } + else V=car(L); + } + if(F!=1&&V<0) V=-V; + return V; + } + else if(type(L)==5||type(L)==6) + return llcm(m2l(L)|option_list=getopt()); + return []; +} + +def ldev(L,S) +{ + M=abs(lmax(L));N=abs(lmin(L)); + if(M=M) break; + M=MT; + } + if(!C){ + for(C=0,LT=L;;C--){ + LT=ladd(LT,S,-1); + MT=abs(lmax(LT));NT=abs(lmin(LT)); + if(MT=M) break; + M=MT; + } + } + return [C,ladd(L,S,C)]; +} + +def lchange(L,P,V) +{ + if(getopt(flat)==1&&type(P)==4){ + for(L=ltov(L);P!=[];P=cdr(P),V=cdr(V)) + L[car(P)]=car(V); + return vtol(L); + } + 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 ladd(X,Y,M) +{ + if(type(Y)==4) Y=ltov(Y); + if(type(X)==4) X=ltov(X); + return vtol(X+M*Y); +} + +def mrot(X) +{ + if(type(X)==4){ + if(getopt(deg)==1) + X=[deval(@pi*X[0]/180),deval(@pi*X[1]/180),deval(@pi*X[2]/180)]; + if(getopt(conj)==1) + return mrot([-X[2],-X[1],0])*mrot([X[0],X[1],X[2]]); + if(X[1]==0){ + X=[X[0]+X[2],0,0]; + if(X[0]==0) return diagm(3,[1]); + } + if(X[0]!=0){ + M=mat([dcos(X[0]),-dsin(X[0]),0],[dsin(X[0]),dcos(X[0]),0],[0,0,1]); + if(X[1]==0) return M; + } + N=mat([dcos(X[1]),0,-dsin(X[1])],[0,1,0],[dsin(X[1]),0,dcos(X[1])]); + if(X[0]!=0) N=M*N; + if(X[2]==0) return N; + return N*mrot([X[2],0,0]); + } + if(getopt(deg)==1) X=@pi*X/180; + X=deval(X); + return mat([dcos(X),-dsin(X)],[dsin(X),dcos(X)]); +} + +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))>JJ) JJ=length(car(T)); + M = newmat(II,JJ); + N = getopt(null); + if(type(N)<0) N=0; + for(I=0; I=0;) + M[I][J] = V[J]; + if(N!=0){ + for(J=length(V); J0;) + N=cons(M[I],N); + return N; +} + +def s2m(S) +{ + if(type(S)==6) return 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); +} + +def c2m(L,V) +{ + if(type(Pow=getopt(pow))!=1){ + if(isvar(V)==1){ + for(Pow=0,LT=L;LT!=[];LT=cdr(LT)){ + if(mydeg(car(LT),V)>JJ) Pow=mydeg(car(LT),V); + } + JJ=Pow+1; + }else{ + Pow=-1; + JJ=length(V); + } + }else JJ=Pow+1; + M=newmat(length(L),JJ); + for(I=0;L!=[];L=cdr(L),I++){ + for(J=0;J=0)?mycoef(LT,J,V):mycoef(LT,1,V[J]); + } + } + return M; +} + +#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=0){ + if(I>J) LF+=texlen(str_cut(S,J,I-1)); + I+=6; + for(F=L=0,J=I;F<2 && J0 && JL) 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; I96 && 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+23) 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 texsp(P) +{ + Q=strtoascii(P); + if((J=str_char(Q,0,92))<0 || (C=Q[L=str_len(P)-1])==32||C==41||C==125) + return P; + for(;;){ + if((I=str_char(Q,J+1,92))<0) break; + J=I; + }; + for(I=J+1;I0){ + 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; + if(TeX>=1){ + if(type(PC)==1 && ntype(PC)==0 && PC<0) + OC="-"+my_tex_form(-PC); + else OC=fctrtos(PC|TeX=1,br=1); + }else OC=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){ + OC = fctrtos(-PC|TeX=1,br=1); + 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(TeX) OC=texsp(OC); + 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); + if(S=="") S="0"; + }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{ + S=fctrtos(Nm); + if(nmono(Nm)>1) S="("+S+")"; + return S+"/("+fctrtos(Dn)+")"; + } + } + if(imag(P)==0) P = fctr(P); /* usual polynomial */ + else P=[[P,1]]; + 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); + SS=(TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]); + N++; + if(P[J][1] != 1){ /* (log(x))^2 */ + if(nmono(P[J][0])>1|| + (!isvar(P[J][0])||vtype(P[J][0]))&&str_len(SS)>1) SS="("+SS+")"; + write_to_tb(SS,S); + str_tb(["^", (TeX>1)?rtotex(P[J][1]):monotos(P[J][1])],S); + }else{ + if(nmono(P[J][0])>1) SS="("+SS+")"; + write_to_tb(SS,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(strip(S,"(",")")|eq=(Pages==1)?6:0); S=1; + } + } + return S; +} + +def strip(S,S0,S1) +{ + SS=strtoascii(S); + if(length(SS)>1){ + if(SS[0]==40&&SS[length(SS)-1]==41&&str_pair(SS,1,S0,S1)==length(SS)-1) + S=str_cut(SS,1,length(SS)-2); + } + 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 && K10 && K1-JJ>6 && K10 || str_str(S,"Big"|top=T+1,end=T+1)>0)) + K=T; + else if(K1>0 && K1II) 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) +{ + Opt=getopt(); + for(I = 0; I < length(M); I++) + M = call(FN, cons(M,cons(L[I],N))|option_list=Opt); + 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); + } +#ifdef USEMODULE + return mmulbys(os_md.rmul,P,Q,[]); +#else + return mmulbys(rmul,P,Q,[]); +#endif +} + +def mtransbys(FN,F,LL) +{ + Opt=getopt(); + 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|option_list=Opt); + 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|option_list=Opt); + 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|option_list=Opt); + } + return R; + } + if(type(F) == 7) return F; + return call(FN, cons(F,LL)|option_list=Opt); +} + +def drawopt(S,T) +{ + if(type(S)!=7) return -1; + if(T==0||T==1){ + for(I=0,R=LCOPT;I<7;I++,R=cdr(R)) + if(str_str(S,car(R))>=0) return(T==0)?COLOPT[I]:car(R); + return -1; + } + if(T==2){ + V0=V1=0; + for(I=0,R=LPOPT;R!=[];I++,R=cdr(R)){ + if(str_str(S,car(R))>=0){ + if(I==0) V1++; + else if(I==1) V1--; + else if(I==2) V0--; + else V0++; + } + } + if(V0==0&&V1==0) return -1; + return [V0,V1]; + } + if(T==3){ + V=0; + for(I=1,R=LFOPT;R!=[];R=cdr(R),I*=2){ + if(str_str(S,car(R))>=0) V+=I; + } + return (V==0)?-1:V; + } + return -1; +} + +def execdraw(L,P) +{ + if((Proc=getopt(proc))!=1) Proc=0; + if(type(P)<2) P=[P]; + if(L!=[]&&type(L[0])!=4) L=[L]; + /* special command */ + if(P[0]<0){ + if(length(P)==1&&(P[0]==-1||P[0]==-2||P[0]==-3)){ /* Bounding Box */ + W=WS=N=LS=0; + for(LL=L;LL!=[];LL=cdr(LL)){ + T=car(LL); + if(P[0]!=-3 && T[0]==0){ + if(length(T)>3) S=" by "+rtostr(T[3])+" cm"; + else S=""; + if(P[0]==-1){ + mycat(["Windows : ",T[1][0],"< x <",T[1][1],", ", + T[2][0],"< y <",T[2][1],S]); + if(length(T)>4 && type(T[4])==4) mycat(["ext :",T[4]]); + if(length(T)>5) mycat(["shift :",T[5]]); + } + return cdr(T); + } + if(type(T[0])==1){ + if(T[0]==1){ + for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){ + D=car(TT); + if(type(D[0][0])==4){ + for(DT=D;DT!=[];DT=cdr(DT)){ + if(N++==0) W=ptbbox(car(DT)); + else W=ptbbox(car(DT)|box=W); + } + }else{ + if(N++==0) W=ptbbox(D); + else W=ptbbox(D|box=W); + } + } + }else if(T[0]==2){ + V=T[2]; + if(type(V[0])>1||type(V[1])>1) continue; /* not supported */ + if((Sc=delopt(T[1],"scale"|inv=1))!=[]){ + Sc=car(Sc)[1]; + if(type(Sc)==1) V=[Sc*V[0],Sc*V[1]]; + else V=[Sc[0]*V[0],Sc[1]*V[1]]; + } + if(LS==0) WS=ptbbox([V]); + else WS=ptbbox([V]|box=WS); + if(length(T)>4) S=T[4]; + else if(type(S=T[3])==4){ + S=S[0]; + if(type(S)==4) S=S[length(S)-1]; + S=rtostr(S); + } + if(str_len(S)>LS) LS=str_len(S); + }else if(T[0]==3||T[0]==4){ + if(N++==0) W=ptbbox(cdr(cdr(T))); + else W=ptbbox(cdr(cdr(T))|box=W); + } + } + } + if(W!=0&&WS!=0) W=ptbbox([W,WS]|box=1); + return (P[0]==-3)?[W,LS,WS]:W; + }else if(length(P)>1&&P[0]==-1){ /* set Bounding Box */ + P=cons(0,cdr(P)); + Ex=Sft=[0,0]; + if(type(X=getopt(ext))==4) Ex=X; + if(type(X=getopt(shift))==4) Sft=X; + if(Ex!=Sft||Ex!=[0,0]){ + if(Sft==[0,0]) Sft=[Ex]; + else Sft=[Ex,Sft]; + if(length(P)==3) Sft=cons(1,Sft); + if(length(P)==3||length(P)==4) P=append(P,Sft); + } + return cons(P,delopt(L,0)); + } + if(P[0]==-4){ + for(N=0,LT=L;LT!=[];LT=cdr(LT)){ /* count coord. */ + T=car(LT); + if(T[0]==1){ + for(T=cdr(cdr(T));T!=[];T=cdr(T)){ + if(type((S=car(T))[0][0])==4) N+=length(S); + else for(;S!=[];S=cdr(S)) if(type(car(S))==4) N++; + } + }else if(T[0]==2) N++; + else if(T[0]==3||T[0]==4) N+=2; + } + return N; + } + if(P[0]==-5){ /* functions */ + for(N=0,R=[],LT=L;LT!=[];LT=cdr(LT)){ + T=car(LT); + if(T[0]==0) N=ior(N,1); + else if(type(T[0])==1){ + if(T[0]>0) N=ior(N,2^T[0]); + } + else if(Type(T[0])==2){ + if(findin(T[0],R)<0) R=cons(T[0],R); + } + } + for(I=5;I>=0;I--) if(iand(N,2^I)) R=cons(I,R); + return R; + } + return 0; + } + + if(length(P)>1){ + if(type(P[1])==6||(type(P[1])<2&&P[1]>0)) M=P[1]; + else if(type(P[1])==4&&length(P[1])==2) M=diagm(2,P[1]); + } + if(length(P)>2&&type(P[2])==4){ + Org=[["shift",P[2]]]; + if(M==0) M=1; + }else Org=[]; + if(P[0]==0||(type(P[0])==4&&P[0][0]==0)){ /* Risa/Asir */ + PP=car(P);PPP=0; + if(type(PP)!=4) PP=[PP]; + if(length(PP)<3){ + if(length(PP)==1 || type(PP[1])==4){ + if(ID_PLOT<0) ID_PLOT=ox_launch_nox(0,"ox_plot"); + Id=ID_PLOT; + if(length(PP)==1&&type(Canvas)==4&&length(Canvas)==2) + PP=cons(PP[0],[Canvas]); + if(length(PP)>1){ + PPP=PP[1][0]; + PPQ=(length(PP[1])==2)?PP[1][1]:PPP; + open_canvas(Id,[PPP,PPQ]); + }else open_canvas(Id); + Ind=ox_pop_cmo(Id); + }else{ + Ind=PP[1]; + if(getopt(cl)==1) clear_canvas(Id,Ind); + } + }else{ + Id=PP[1];Ind=PP[2]; + if(length(PP)>3 && type(PP[3])==1) PPP=PP[3]; + if(length(PP)>4 && type(PP[4])==1) PPQ=PP[4]; + if(getopt(cl)==1) clear_canvas(Id,Ind); + } + if(L==[]) return (PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind]; + Ex0=Ex0;Sft=[0,0]; + if(length(P)>1&&P[1]==0&&length(P)<4){ + R=execdraw(L,-3); + Ex0=Ex1=Ex2=10; + if((U=R[1])>0){ /* string */ + if(U>20) U=16; /* adj 16,8,2,7,15 */ + if(R[0][0][0]>R[2][0][0]-(R[0][0][1]-R[0][0][0])/256) Ex0+=8*U; /* adj 256 */ + else Ex0+=2*U; + if(R[0][0][1]2 && P[2]==1) + mycat0(["Box:",[R[0],R[1]], ", ext=",R[3],", shift=",R[4]],1); + }else R=execdraw((length(P)>3)?P[3]:L,-2); /* Windows */ + XW=R[0];YW=R[1]; + if(length(R)>3){ + if(R[3]!=0 && R[3]!=[0,0]) Ex=R[3]; + if(length(R)>4) Sft=R[4]; + } + if(type(X=getopt(ext))==4) + Ex=(Ex0)?[X[0]+Ex[0],X[1]+Ex[1]]:X; + if(type(M)<2){ + if(length(P)>1&&type(P[1])==1) M=P[1]; + else if((length(P)==1||P[1]==0||P[1]==1)&& PPP>0) M=PPP; + if(M<2) M=400; + if(Ex!=0 && type(Ex)==4){ + M-=Ex[0]+Ex[1]; + } + M=(M/(XW[1]-XW[0]))*diagm(2,[1,-1]); + } + if(type(X=getopt(shift))==4) Sft=(Ex0)?[Sft[0]+X[0],Sft[1]+X[1]]:X; + if(type(Sft)==4) Sft=[Sft[0],-Sft[1]]; + if(Ex!=0) Sft=[Sft[0]+Ex[0],Sft[1]]; + Org=[["shift",ptaffine(M,[-XW[0],-YW[1]]|shift=Sft)]]; + for(CT=0;CT<2;CT++){ + for(LT=L;LT!=[];LT=cdr(LT)){ + T=car(LT); + if(!CT && T[0]!=2) continue; + if(CT && T[0]==2) continue; + if(T[0]==1){ + for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){ + D=car(TT); + if(type(D[0][0])==4){ + for(DT=D;DT!=[];DT=cdr(DT)){ + V=car(DT); + if(M) V=ptaffine(M,V|option_list=Org); + draw_bezier(Id,Ind,V|option_list=T[1]); + } + }else{ + if(M) D=ptaffine(M,D|option_list=Org); + draw_bezier(Id,Ind,D|option_list=T[1]); + } + } + }else if(T[0]==2){ /* put */ + if(length(T)<4) continue; + V=T[2]; + if(type(VLB)==4&&V[0]=="_") V=VLB; + else if(type(V[0])>1||type(V[1])>1) continue; /* not supported */ + if(length(T)>3&&type(T[3])==4&&length(T[3])>1&&T[3][1]==1) VLB=V; + F++;MM=M; + if((Sc=delopt(T[1],"scale"|inv=1))!=[]){ + if(!MM) MM=1; + Sc=car(Sc)[1]; + if(type(Sc)==1) MM=MM*Sc; + else if(type(Sc)==6) MM=MM*diagm(2,Sc); + } + if(MM) V=ptaffine(MM,V|option_list=Org); + if(type(S=S0=T[3])==4) S=S0[0]; + if(length(T)>4) S=T[4]; /* subst. string */ + if(type(S0)==4&&type(S0[0])==4){ + if((Col=drawopt(S0[0][0],0))<0) Col=0; /* attrib. */ + if(type(S)!=7) S=rtostr(S0[0][1]); + S=str_subst(S,[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0); + if(type(Pos=drawopt(S0[0][0],2))==4) + V=[V[0]+4*str_len(S)*Pos[0],V[1]-10*Pos[1]]; /* adjustable */ + }else S=str_subst(rtostr(S),[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0); + V=[V[0]-str_len(S)*4,V[1]-8]; /* adjustable */ + draw_string(Id,Ind,V,S,Col); + }else if(T[0]==3){ /* arrow */ + F++; + T1=T[2];T2=T[3]; + if(M){ + T1=ptaffine(M,T1|option_list=Org); + T2=ptaffine(M,T2|option_list=Org); + } + draw_bezier(Id,Ind,[T1,T2]|option_list=T[1]); + }else if(T[0]==4){ /* line */ + F++; + T1=T[2];T2=T[3]; + if(M){ + T1=ptaffine(M,T1|option_list=Org); + T2=ptaffine(M,T2|option_list=Org); + } + V=delopt(T1=T[1],"opt"|inv=1); + if(V!=[]&&str_str(V[1],".")>=0) + T1=cons(["opt",cons("dotted,",V[1])],delopt(T1,"opt")); + draw_bezier(Id,Ind,[T1,T2]|option_list=T1); + }else if(T[0]==5){ /* TeX */ + mycat(rtostr(T[2])); + if(F){ + S=str_tb(0,Out); + Out=str_tb(0,0); + F=0; + if(S!=""){ + if(P[0]==2) dviout(xyproc(S)|keep=1); + else LOut=cons(xyproc(S),LOut); + } + if(P[0]==2) dviout(T[2]|option_list=T[1]); + else{ + LOut=cons(T[2],Out); + } + } + }else if(Proc==1&&type(T[0])==2){ + if(length(T)<3) call(T[0],T[1]); + else call(T[0],T[1]|option_list=T[2]); + } + } + } + S=(PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind]; + if(Ex==0&&Sft!=[0,0]) Ex=[0,0]; + return (Ex!=0&&length(P)>2&&P[2]==-1)? + [S,0,0,[0,R[0],R[1],0,Ex,[Sft[0]-Ex[0],-Sft[1]]]]:S; + } + if(P[0]==1||P[0]==2){ /* TeX */ + Out=str_tb(0,0);LOut=[];F=0; + if(getopt(cl)==1) dviout0(0); + for(;L!=[];L=cdr(L)){ + T=car(L);Opt=T[1]; + if(type(T[0])>=2) continue; + if(T[0]==0){ + XW=T[1];YW=T[2]; + if(length(P)>1&&type(P[1])==1&&P[1]<0) + M=-P[1]/(XW[0]-XW[1]); + }else if(T[0]==1){ + F++; + for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){ + D=car(TT); + if(type(D[0][0])==4){ + for(DT=D;DT!=[];DT=cdr(DT)){ + V=car(DT); + if(M) V=ptaffine(M,V|option_list=Org); + str_tb(xybezier(V|option_list=Opt),Out); + } + }else{ + if(M) D=ptaffine(M,D|option_list=Org); + str_tb(xybezier(D|option_list=Opt),Out); + } + } + }else if(T[0]==2){ + F++;V=T[2]; + Opt=delopt(Opt,"scale"|inv=1); + MM=M; + if(Opt!=[]){ + Opt=car(Opt)[1]; + if(type(Opt)==1) Opt=[Opt,Opt]; + if(Opt!=[1,1]){ + if(!MM) MM=1; + MM=MM*diagm(2,[Opt[0],Opt[1]]); + } + } + if(MM) V=ptaffine(MM,V|option_list=Org); + if(length(T)>3) V=append(V,T[3]); + str_tb(xyput(V),Out); + }else if(T[0]==3){ + F++; + T1=T[2];T2=T[3]; + if(M){ + T1=ptaffine(M,T1|option_list=Org); + T2=ptaffine(M,T2|option_list=Org); + } + str_tb(xyarrow(T1,T2|option_list=Opt),Out); + }else if(T[0]==4){ + F++; + T1=T[2];T2=T[3]; + if(M){ + T1=ptaffine(M,T1|option_list=Org); + T2=ptaffine(M,T2|option_list=Org); + } + str_tb(xyline(T1,T2|option_list=Opt),Out); + }else if(T[0]==5){ + if(F){ + S=str_tb(0,Out); + Out=str_tb(0,0); + F=0; + if(S!=""){ + if(P[0]==2) dviout(xyproc(S)|keep=1); + else LOut=cons(xyproc(S),LOut); + } + if(P[0]==2) dviout(T[2]|option_list=T[1]); + else LOut=cons(T[2],Out); + } + }else if(T[0]==-2) + str_tb(["%",T[1],"\n"],Out); + else if(Proc==1&&type(T[0])==2){ + if(length(T)<3) call(T[0],T[1]); + else call(T[0],T[1]|option_list=T[2]); + } + } + S=str_tb(0,Out); + if(P[0]==1){ + if(F) LOut=cons(xyproc(S),LOut); + Out=str_tb(0,0); + for(L=reverse(LOut);L!=[];L=cdr(L)) + str_tb(car(L),Out); + return str_tb(0,Out); + } + if(F) dviout(xyproc(S)); + else dviout(" "); + } +} + +def execproc(L) +{ + if(type(N=getopt(var))!=1&&N!=0) N=2; + for(R=[];L!=[];L=cdr(L)){ + P=car(L); + if(type(P[0])==2&&vtype(P[0])==3){ + if((VS=vars(cdr(P)))!=[]){ + for(I=0;I=0) P=mysubst(P,[V,R[I]]); + } + } + if(length(P)<3) R=cons(call(P[0],P[1]),R); + else R=cons(call(P[0],P[1]|option_list=P[2]),R); + } + } + return (getopt(all)==1)?R:car(R); +} + +def myswap(P,L) +{ + X=makenewv(P); + for(L=reverse(L);length(L)>1;L=cdr(L)) + P=subst(P,L[0],X,L[1],L[0],X,L[1]); + return P; +} + +def mysubst(P,L) +{ + if(P==0) return 0; + if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]); + Inv=getopt(inv); + if(type(L[0]) == 4){ + while((L0 = car(L))!=[]){ + P = mysubst(P,(Inv==1)?[L0[1],L0[0]]:L0); + L = cdr(L); + } + return P; + } + if(Inv==1) L=[L[1],L[0]]; + if(type(P) > 3){ + if(type(P)==7) return P; + if(type(P)>7) + return subst(P,L[0],L[1]); +#ifdef USEMODULE + return mtransbys(os_md.mysubst,P,[L]); +#else + return mtransbys(mysubst,P,[L]); +#endif + } + 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=(type(L[1])==3)?red(L[1]):L[1];X=L[0]; + if(ptype(L1,X)==3){ + LN=nm(L1);LD=dn(L1); + Deg=mydeg(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 + mycoef(P,I,X)*V[I]; + return red(R/V[0]); + } + return subst(P,X,L1); +} + +def mmulbys(FN,P,F,L) +{ + Opt=getopt(); + if(type(F) <= 3){ + if(type(P) <= 3) + return call(FN, cons(P,cons(F,L))|option_list=Opt); + 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))|option_list=Opt); + 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))|option_list=Opt); + } + 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))|option_list=Opt); + return R; + } + if(type(P) == 5){ + for(J=R=0; J 0) + F = mydiff(F,X); + R = radd(R,mycoef(P,I,DX)*F); + } + return R; + } +#ifdef USEMODULE + return mmulbys(os_md.appldo,P,F,[L]); +#else + return mmulbys(appldo,P,F,[L]); +#endif +} + +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; + } +#ifdef USEMODULE + mmulbys(os_md.appledo,P,F,[L]); +#else + mmulbys(appledo,P,F,[L]); +#endif +} + +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; + } +#ifdef USEMODULE + return mmulbys(os_md.muldo,P,Q,[L]); +#else + return mmulbys(muldo,P,Q,[L]); +#endif +} + +def jacobian(F,X) +{ + F=ltov(F);X=ltov(X); + N=length(F);L=length(X); + M=newmat(N,L); + for(I=0;I 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) +#ifdef USEMODULE + return mmulbys(os_md.muledo,P,Q,[L]); +#else + return mmulbys(muledo,P,Q,[L]); +#endif + 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) +#ifdef USEMODULE + return mmulbys(os_md.mulpdo,P,Q,[L]); +#else + return mmulbys(mulpdo,P,Q,[L]); +#endif + 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) +#ifdef USEMODULE + return mmulbys(os_md.mulpdo,P,Q,[L]); +#else + return mmulbys(mulpdo,P,Q,[L]); +#endif + 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) +{ + if(type(P)>3) return +#ifdef USEMODULE + mtransbys(os_md.transpdosub,P,[LL,K]); +#else + mtransbys(transpdosub,P,[LL,K]); +#endif + 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) +{ + Len = length(K)-1; + K1=K2=[]; + if(type(LL)!=4) LL=[LL]; + if(type(LL[0])!=4) LL=[LL]; + if(type(car(K)) < 4 && length(LL)!=length(K)) K = [K]; + 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{ + if(length(LL)==length(K) && type(car(K))!=4){ + for(DV=V=TL=[],J=length(LL)-1;J>=0;J--){ + TL=cons(vweyl(LL[J]),TL); + V=cons(car(TL)[0],V); + DV=cons(car(TL)[1],DV); + } + LL=TL; + if(type(RK=solveEq(K,V|inv=1))!=4) return TK; + if(!isint(Inv=getopt(inv))) Inv=0; + if(iand(Inv,1)){J=K;K=RK;RK=J;} + M=jacobian(RK,V|mat=1); + M=mulsubst(M,[V,K]|lpair=1); + RK=vtol(M*ltov(DV)); + if(Inv>1) return RK; + K=lpair(K,RK); + } + 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= 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 texbegin(T,S) +{ + if(type(Opt=getopt(opt))==7) Opt="["+Opt+"]\n"; + else Opt="\n"; + U=(str_chr(S,str_len(S)-1,"\n")<0)?"%\n":""; + return "\\begin{"+T+"}"+Opt+S+U+"\\end{"+T+"}\n"; +} + +def mygcd(P,Q,L) +{ + if((Dvi=getopt(dviout))==3 || Dvi==-3){ /* dviout=3 */ + if((Rev=getopt(rev))!=1) Rev=0; + R=mygcd(P,Q,L|rev=Rev); + if(type(L)<2) Var=0; + else if(type(L)==2){ + Val=L;L=[0,L]; + }else if(type(L)==4){ + L=vweyl(L); + Var=[[L[1],"\\partial"]]; + } + S=mat([P],[Q]);T=mat([R[0]],[0]); + M=mat([R[1],R[2]],[R[3],R[4]]); + if(type(Val)==4) + N=mdivisor(M,L|trans=1)[1]; + else N=myinv(M); + Tb=str_tb(mtotex(S|var=Var),0); + str_tb("&="+mtotex(N|var=Var)+mtotex(T|var=Var)+",\\\\\n",Tb); + str_tb(mtotex(T|var=Var),Tb); + str_tb("&="+mtotex(M|var=Var)+mtotex(S|var=Var)+".",Tb); + Out=str_tb(0,Tb); + if(Dvi<0) return Out; + dviout(Out|eq="align*"); + return 1; + } + if((type(Dvi)==1||Dvi==0) && getopt(rev)!=1) V=[[P,Q]]; + else V=0; + if(L==0){ /* integer case */ + if(type(P) > 1 || type(Q) > 1 || Q==0 /* 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); + if(type(V)==4) V=cons([Div1,Div2],V); + P1 = Q1 ; Q1 = Div2; + TP = CQP; TQ = CQQ; + CQP = CPP-Div1*CQP; + CQQ = CPQ-Div1*CQQ; + CPP = TP; CPQ = TQ; + } + if(V!=0){ + V=reverse(V); + if((DVI=abs(Dvi))==0) return V; + PT=P;QT=Q; + if(DVI==1 || DVI==2){ + Tb=str_tb(0,0); + for(C=0,V=cdr(V);V!=[];V=cdr(V)){ + T=car(V); + if(C++) str_tb(texcr(11),Tb); + if(DVI==1){ + Qs=rtostr(QT); + if(QT<0) Qs="("+Qs+")"; + if(T[1]>0) Qs=Qs+"+"; + if(T[1]!=0) Qs=Qs+rtostr(T[1]); + str_tb(rtostr(PT)+"&=" + +rtostr(T[0])+"\\times"+Qs,Tb); + }else{ + N=mat([T[0],1],[1,0]); + if(C==1){ + str_tb(S0=mtotex(mat([PT],[QT])),Tb); + M=N; + } + str_tb("&=",Tb); + if(C>1) str_tb(mtotex(M),Tb); + str_tb(mtotex(N),Tb); + str_tb(S=mtotex(mat([QT],[T[1]])),Tb); + if(C>1){ + str_tb("=",Tb); + str_tb(mtotex(M=M*N),Tb); + str_tb(S,Tb); + } + } + PT=QT;QT=T[1]; + } + if(DVI==2){ + str_tb(texcr(43)+S+"&=",Tb); + str_tb(mtotex(myinv(M)),Tb); + str_tb(S0,Tb); + } + Out=str_tb(0,Tb); + if(Dvi>0){ + dviout(Out|eq="align*"); + return 1; + } + return Out; + } + } + if(P1<0) return [-P1,-CPP,-CPQ,CQP,CQQ]; + return [P1, CPP, CPQ, CQP, CQQ]; + } + if(type(L) == 2) /* polynomical case */ + 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,[1/dn(P),0]); CQ=newvect(2,[0,1/dn(Q)]); + P=PT=nm(P); Q =QT=nm(Q); + L = vweyl(L); + while(Q != 0){ + R = divdo(P,Q,L); + if(type(V)==4) V=cons(R,V); +/* R[1] = R[2]*P - R[0]*Q + = R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */ +/* + P(n) |0 1 | P(n-1) + = | | + R[1] |R[2] -R[0]| P(n) + P(n+1) = R[1], P(n) = P, P(n-1) = Q +*/ + P = Q; + Q = R[1]; + { + 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; + } + } + if(V!=0){ + V=reverse(V); + if((DVI=abs(Dvi))==0) return V; + if(type(L[0])<1) Var=L[1]; + else Var=[L[1],"\\partial"]; + if(DVI==1 || DVI==2){ + Tb=str_tb(0,0); + PT=car(V)[0];QT=car(V)[1]; + for(C=0,V=cdr(V);V!=[];V=cdr(V)){ + T=car(V); + if(C++) str_tb(texcr(11),Tb); + if(DVI==1){ + if(T[2]!=1){ + str_tb(monototex(T[2]),Tb); + str_tb("(",Tb); + str_tb(fctrtos(PT|var=Var,TeX=2),Tb); + str_tb(")&=",Tb); + }else{ + str_tb(fctrtos(PT|var=Var,TeX=2),Tb); + str_tb("&=",Tb); + } + str_tb("(",Tb); + str_tb(fctrtos(T[0]|var=Var,TeX=2),Tb); + str_tb(")(",Tb); + str_tb(fctrtos(QT|var=Var,TeX=2),Tb); + if(T[1]!=0){ + str_tb(")+(",Tb); + str_tb(fctrtos(T[1]|var=Var,TeX=2),Tb); + } + str_tb(")",Tb); + }else{ + N=mat([red(T[0]/T[2]),1],[1,0]); + if(C==1){ + str_tb(S0=mtotex(mat([PT],[QT])|var=Var),Tb); + M=N; + } + str_tb("&=",Tb); + if(C>1) str_tb(mtotex(M),Tb); + str_tb(mtotex(N|var=Var),Tb); + str_tb(S=mtotex(mat([QT],[T[1]])|var=Var),Tb); + if(C>1){ + str_tb("=",Tb); + str_tb(mtotex(M=muldo(M,N,L)|var=Var),Tb); + str_tb(S,Tb); + } + } + PT=QT;QT=T[1]; + } + if(DVI==2){ + FT=fctr(PT); + for(R=1;FT!=[];FT=cdr(FT)){ + if(mydeg(car(FT)[0],L[1])<1) + for(J=car(FT)[1];J>0;J--) R*=car(FT)[0]; + } + if(R!=1){ + str_tb(texcr(79),Tb); + M=muldo(M,mat([R,0],[0,1]),L); + str_tb(mtotex(M|var=Var),Tb); + str_tb(S=mtotex(mat([PT/R],[QT])|var=Var),Tb); + } + str_tb(texcr(43)+S+"&=",Tb); + if(type(Var)==4){ + N=mdivisor(M,L|trans=1); + N=N[1]; + }else + N=myinv(M); + str_tb(mtotex(N|var=Var),Tb); + str_tb(S0,Tb); + } + Out=str_tb(0,Tb); + if(Dvi>0){ + dviout(Out|eq="align*"); + return 1; + } + return Out; + } + } + 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(L0=L1=[],LT=LL;LT!=[];LT=cdr(LT)){ + W=vweyl(car(LT)); + L0=cons(W,L0); + D=mydiff(F,W[0]); + if(D!=0) L1=cons(W[1]+Q*D/F,L1); + else L1=cons(W[1],L1); + } + return rede(transpdosub(P,L0,L1),L0); +} + +def applpdo(P,F,LL) +{ + if(type(F)>3) +#ifdef USEMODULE + return mmulbys(os_md.applpdo,P,F,[LL]); +#else + return mmulbys(applpdo,P,F,[LL]); +#endif + 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) +{ + if(L==0){ + R=P-idiv(P,Q)*Q; + if(R<0){ + if(Q>0) R+=Q; + else R-=Q; + } + return [(P-R)/Q,R,1]; + } + 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 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;J2) 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(N==0) return 1; + if(type(N)!=1 || N<0) return 0; + if(type(X)<4){ + for(K=0,S=S0=1;K2||type(Q)>2)?1:0; + for(I=R=0;I<=N;I++){ + P0=mycoef(P,I,X); + for(J=0;J<=N-I;J++){ + R+=P0*mycoef(Q,J,X)*X^(I+J); + if(Red) R=red(R); + } + } + return R; +} + +def solveEq(L,V) +{ + Inv=0;K=length(V); + H=(getopt(h)==1)?1:0; + if(getopt(inv)==1){ + if(K!=length(L)) return -5; + Inv=1; + VN=makenewv(vars(L)|num=K); + for(TL=[],I=K-1;I>=0;I--) TL=cons(VN[I]-L[I],TL); + S=solveEq(TL,V|h=H); + if(type(S)!=4) return S; + return mysubst(S,[VN,V]|lpair=1); + } + for(TL=[];L!=[];L=cdr(L)) TL=cons(nm(red(car(L))),TL); + S=gr(TL,reverse(V),2); + if(length(S)!=K) return -1; + for(R=[],I=F=0;I3){ + Ord-=4; Hgr=1; + }else Hgr=0; + if(type(car(L))==4&&type(L[1])==7){ + Tt=L[1];L=car(L); + } + M=N=length(L); SV=SVORG; + if(type(Var=getopt(var))==4&&(In>0||length(Var)==N)){ + SV=Var; + M=length(SV); + if(type(car(SV))==2){ + for(R=[];SV!=[];SV=cdr(SV)) R=cons(rtostr(car(SV)),R); + SV=reverse(R); + } + }else{ + if(N>10){ + R=[]; + for(K=M-1;K>9;K++) R=cons(SV[floor(K/10)-1]+SV[K%10],R); + SV=append(SV,R); + } + for(Var=[],I=M-1;I>=0;I--) Var=cons(makev([SV[I]]),Var); + } + if(type(To=getopt(to))<2||type(To)>4) To=0; + else if(!isvar(To)){ + if(type(To)!=4){ + To=red(To); + for(K=0;K0&&I<2&&J<2) break; + } + if(K==length(Var)) return -9; + J=To; + for(To=[],I=length(Var)-1;I>=0;I--) + if(I!=K) To=cons(Var[I],To); + To=cons(J,To); + } + if(type(To)==4){ + if(type(car(To))==4){ + R=1;To=car(To); + }else R=0; + if(type(IL=solveEq(To,Var|inv=1))!=4) return IL; + if(R==1){ + R=To;To=IL;IL=R; + } + L=mulsubst(L,[Var,IL]|lpair=1); + if(!In){ /* X_i'=\sum_j(\p_{x_j}X_i)*x_j' */ + for(TL=[],I=M-1;I>=0;I--){ + P=To[I];Q=mydiff(P,t); + for(J=0;J=0;I--){ + P=IL[I];Q=mydiff(P,t); + for(J=0;J=0;I--) L=cons(num(TL[I]),L); + } + } + } + if(F==-3) return [Var,L]; + for(I=0;I=0 && IT=0&&!chkfun("gr",0)){ + mycat("load(\"gr\"); /* <- do! */\n"); + F=-1; + } + if(F==-2) return [VV,L]; + if(F<0) return [V,L]; + LL=(Hgr==1)?hgr(L,V,Ord):gr(L,V,Ord); + if(F==2) return [V,L,LL]; + if(Ord==2) P=LL[0]; + else{ + P=LL[length(LL)-1]; + for(RV=reverse(V), I=0;I30) return 0; + if(type(H=getopt(taylor))==4&&length(H)==2){ + if(type(Lim=getopt(lim))==2) DD=D; + else if(type(Lim)==4){ + DD=Lim[1];Lim=Lim[0]; + }else Lim=0; + for(R=I=0;I<=D;I++){ + if(I){ + if(Lim) H0=mulpolyMod(H0,H[0],Lim,DD); + else H0*=H[0]; + }else H0=1; + if(type(F)!=7) G=I?mydiff(G,x):F; + for(J=0;J<=D-I;J++){ + if(J){ + if(Lim) H1=mulpolyMod(H1,H[1],Lim,DD); + else H1*=H[1]; + }else H1=H0; + if(type(F)==7) G=makev([F,I,J]); + else if(J) G=mydiff(G,y); + R+=G*H1/fac(I)/fac(J); + } + } + if(Lim) R=os_md.polcut(R,DD,Lim); + return R; + }else{ + if(type(H=getopt(series))>=0||getopt(list)==1){ + if(type(F)!=7){ + for(PP=[F],I=1;I=1;DD--,PP=cdr(PP)) R+=car(PP)*H^DD/fac(DD); + return red(R); + } + if(type(H)>=0) D--; + PP=taylorODE(D-1|list=1); + if(type(PP)!=4) PP=[PP]; + P=car(PP); + }else P=taylorODE(D-1); + for(R=I=0;I=0){ + R=y+R*H^(D+1)/fac(D+1); + for(DD=D;DD>0;PP=cdr(PP),DD--) R+=car(PP)*H^(DD)/fac(DD); + if(T){ + if(T<0){ + Dif=0;TT=-T; + }else TT=T; + K=newvect(TT);K[0]=Dif?f:f_00; + if(getopt(c1)==1) K[0]=taylorODE(D|taylor=[c_1*H,0]); + for(I=1;I=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 sqrtrat(P) +{ + if(P==0) return 0; + if(type(P)==3||type(P)==2){ + P=red(P); + if(imag(dn(P))!=0||imag(nm(P))!=0){ + if(imag(dn(P))==0&&real(P)!=0){ + F=red(imag(P)/real(P)); + if(F==3^(1/2)||F==-3^(1/2)){ + if(eval(real(P))<0) + return -real(P)+imag(P)*@i; + else{ + if(eval(imag(P))>0) return imag(P)+real(P)*@i; + else return -imag(P)-real(P)*@i; + } + } + } + return []; + } + F=fctr(dn(P)); + R=sqrtrat(car(F)[0]); + for(F=cdr(F);F!=[];F=cdr(F)){ + if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2); + else return []; + } + F=fctr(nm(P)); + R=sqrtrat(car(F)[0])/R; + for(F=cdr(F);F!=[];F=cdr(F)){ + if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2); + else return []; + } + return R; + } + if(ntype(P)==4){ + P0=real(P);P1=imag(P)/2; + X=makenewv(P); + for(R=fctr(X^4-P0*X^2-P1^2);R!=[];R=cdr(R)){ + RT=car(R)[0]; + if(deg(RT,X)==1){ + X=-mycoef(RT,0,X)/mycoef(RT,1,X); + return X+P1/X*@i; + } + if(deg(RT,X)==2){ + if((D=mycoef(RT,1,X)^2-4*mycoef(RT,2,X)*mycoef(RT,0,X))<0) continue; + X=(-mycoef(RT,1,X)+sqrtrat(D))/(2*mycoef(RT,2,X)); + return X+P1*sqrt2rat(1/X)*@i; + } + } + D=P0^2+4*P1^2; + if(P1>0) return ((sqrtrat(D)+P0)/2)^(1/2)+((sqrtrat(D)-P0)/2)^(1/2)*@i; + return ((sqrtrat(D)+P0)/2)^(1/2)-((sqrtrat(D)-P0)/2)^(1/2)*@i; + }else if(ntype(P)!=0) return []; + if(P==1) return P; + Dn=dn(P);Nm=nm(P);C=R=1; + N=pari(factor,Dn); + if(N){ + for(II=car(size(N))-1;II>=0;II--){ + if(iand(K=N[II][1],1)){ + R*=N[II][0]; + K++; + } + C/=N[II][0]^(K/2); + } + } + N=pari(factor,Nm); + if(N){ + for(II=car(size(N))-1;II>=0;II--){ + if(N[II][0]==-1){ + C*=@i; + continue; + } + K=N[II][1]; + if(iand(K,1)){ + R*=N[II][0]; + K--; + } + if(K!=0) C*=N[II][0]^(K/2); + } + } + if(R!=1) C*=R^(1/2); + return C; +} + +def fctri(F) +{ + R=(iscoef(F,os_md.israt))?fctr(F):[[1,1],[F,1]]; + if(!iscoef(F,os_md.iscrat)||chkfun("af_noalg",0)==0) return R; + X=makenewv(vars(F)); + for(S=[];R!=[];R=cdr(R)){ + if(length(Var=vars(R0=car(R)[0])) == 1 && (D=mydeg(R0,Var=car(Var))) > 0){ + if(imag(T=mycoef(R0,D,Var))!=0) R0/=T; + T=af_noalg(real(R0)+imag(R0)*X,[[X,X^2+1]]); + if(length(T)>1||T[0][1]>1){ + T=subst(T,X,@i); + for(; T!=[];T=cdr(T)){ + if(vars(T[0])!=[]) + S=cons([car(T)[0],car(T)[1]*car(R)[1]],S); + } + continue; + } + } + S=cons(R[0],S); + } + return reverse(S); +} + +def getroot(F,X) +{ + S=[]; + if(type(Cpx=getopt(cpx))!=1) Cpx=0; + M=getopt(mult); + if(type(F) == 3) + F = nm(red(F)); + for(R=fctri(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); + }else if(mydeg(P,X)==2 && Cpx>0){ + C2=mycoef(P,2,X);C1=mycoef(P,1,X);C0=mycoef(P,0,X); + C=sqrt2rat(C1^2-4*C0*C2); + C0=[]; + if(type(C)==0&&ntype(C)==0&&pari(issquare,-C)) C0=sqrt(C); + else if(Cpx>1) C0=sqrtrat(C); + if(C0==[]&&Cpx>2) C0=C^(1/2); + if(C0!=[]){ + if(M==1) + S=cons([I,sqrt2rat((-C1+C0)/(2*C2))],S); + else{ + for(II=I; II>0; II--) + S=cons(sqrt2rat((-C1+C0)/(2*C2)),S); + } + P=sqrt2rat((-C1-C0)/(2*C2)); + } + }else if(mydeg(P,X)==3 && Cpx>1){ + Omg=(-1+3^(1/2)*@i)/2; + PP=P/mycoef(P,3,X); + C2=mycoef(PP,2,X)/3; + PP=subst(PP,X,X-C2); + if((C1=mycoef(PP,1,X))==0){ + C0=mycoef(PP,0,X); + if(real(C0)==0||imag(C0)==0){ + if(real(C0)==0){ + PP=getroot(X^3+imag(C0),X); + if(length(PP)==3){ + for(;PP!=[];PP=cdr(PP)){ + if(imag(PP[0])==0){ + C0=PP[0]*@i; + break; + } + } + if(PP==[]) C0=0; + } + }else{ + if(C0>0) C0=C0^(1/3); + else C0=-(-C0)^(1/3); + } + if(C0!=0){ + if(M==1){ + S=cons([I,C0-C2],S); + S=cons([I,C0*Omg-C2],S); + S=cons([I,C0*(-1-Omg)-C2],S); + }else{ + for(II=I; II>0; II--){ + S=cons(C0-C2,S); + S=cons(C0*Omg-C2,S); + S=cons(C0*(-1-Omg)-C2,S); + } + } + continue; + } + } + } + if(Cpx>2){ + Q=X^2+(mycoef(PP,1,X)/3)*X+mycoef(PP,0,X)^3; + SQ=getroot(Q,X|cpx=2); + SQ=SQ[0]^(1/3);SQ2=mycoef(PP,0,X)/SQ; + if(M==1){ + S=cons([I,SQ+SQ2-C2],S); + S=cons([I,SQ*Omg+SQ2*(-1-Omg)-C2],S); + S=cons([I,SQ*(-1-Omg)+SQ2*Omg-C2],S); + }else{ + for(II=I; II>0; II--){ + S=cons(SQ+SQ2-C2,S); + S=cons(SQ*Omg+SQ2*(-1-Omg)-C2,S); + S=cons(SQ*(-1-Omg)+SQ2*Omg-C2,S); + } + } + continue; + } + }else if(mydeg(P,X)==4 && Cpx>0){ + C2=mycoef(P,3,X)/(4*mycoef(P,4,X)); + PP=subst(P,X,X-C2); + if(mycoef(PP,1,X)==0){ + PP=mycoef(PP,4,X)*X^2+mycoef(PP,2,X)*X+(SQ2=mycoef(PP,0,X)); + SQ=getroot(PP,X|cpx=2); + if(length(SQ)==2){ + if((C0=sqrtrat(SQ[0]))==[]){ + if(mycoef(PP,1,X)==0){ + if(SQ2<0) C0=(-SQ2)^(1/4); + else C0=SQ2^(1/4)*(1+@i)/2; + } + else if(Cpx>2) C0=SQ[0]^(1/2); + else C0=0; + } + if((C1=sqrtrat(SQ[1]))==[]){ + if(mycoef(PP,1,X)==0) C1=-C0; + else C1=SQ[1]^(1/2); + } + if(C0!=0){ + if(M==1) + S=append([[I,C0-C2],[I,-C0-C2],[I,C1-C2],[I,-C1-C2]],S); + else{ + for(II=I; II>0; II--) + S=append([C0-C2,-C0-C2,C1-C2,-C1-C2],S); + } + continue; + } + } + }else{ + PP/=mycoef(PP,4,X); + CC=mycoef(PP,2,X);C1=mycoef(PP,1,X);C0=mycoef(PP,0,X); + SQ=getroot(X*(CC+X)^2-4*C0*X-C1^2,X|cpx=Cpx); + if(length(SQ)>1){ + SQ=sqrt2rat(SQ[0]); + SQ2=getroot(X^2-SQ,X|cpx=Cpx); + if(length(SQ2)>1){ + C1=SQ2[0]*X-C1/SQ2[0]/2; + C0=getroot(X^2+CC/2+SQ/2+C1,X|cpx=Cpx); + C1=getroot(X^2+CC/2+SQ/2-C1,X|cpx=Cpx); + if(length(C0)>1&&length(C1)>1){ + C0=[sqrt2rat(C0[0]-C2),sqrt2rat(C0[1]-C2), + sqrt2rat(C1[0]-C2),sqrt2rat(C1[1]-C2)]; + if(M==1) for(II=0;II<4;II++) S=cons([I,C0[II]],S); + else for(II=I; II>0; II--) S=append(C0,S); + continue; + } + } + } + } + } + if(M==1) + S=cons([I,P],S); + else for( ; I>0; I--) S=cons(P,S); + } + } + S=qsort(S); + if(M==1) S=reverse(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) +{ + if(isvar(V=getopt(var))&&length(P)>1&&isint(car(P))){ + for(Q=[],I=car(P);I<=P[1];I++) Q=cons(makev([V,I]),Q); + P=Q; + } + 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;I1) return 0; + } + if(L==1){ + for(I=0;I=0 && MR[J]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;I0) 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=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=JL) return Coef; + JP=J;T0=1; + T+=S[J]*Mon[J][I]; + } + } + if(T==MR[I]){ + if(++I1; II--) + TT/=II; + } + } + Coef+=TT; + if(TP==1 && type(Coef)==3) Coef=red(Coef); + if(JP1){ + 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(JP0 && Mon[JP1][0] < Mon[JP][0]){ + S[JP]--;S[Len-1]++;JP=JP-1; + }else{ + + S[JP]--; + if(JP1=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); + if(Q==0) Q=P; + V=ltov(vars(P)); + N=length(V); + for(I=1;I=0 && mydeg(P,V[J])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;I0) RR*=V[J]^T[J]; + } + Q-=R*RR; + for(J=0,CC=R;J 1) + mycat([V-1, "accessory parameters: r1,r2,..."]); + return R; +} + +def fuchs3e(P,Q,R) +{ + return getbygrs([R,P,Q],3); +} + +def okubo3e(P,Q,R) +{ + if(getopt(opt)==1){ + N=length(R); + M1=N-length(P);M2=N-length(Q); + V=(M1-1)*(M2-1); + if(V>0) mycat([V, "accessory parameters"]); + return getbygrs([R,cons([M1,0],P),cons([M2,0],Q)],3); + } + 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=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=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; + 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; + } + 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); + OD -= S; + } +} + +def abs(X) +{ + if(vars(X)!=[]) return todf(os_md.abs,[X]); + if(type(X)==4){ + P=X[1];X=X[0]; + }else P=0; + if(type(X)==1){ + if((T=ntype(X))<2 || T==3){ + if(X<0) X=-X; + }else if(T==4) X=P?pari(abs,X,P):pari(abs,X); + } + return X; +} + +def sgn(X) +{ + if(X==0) return 0; + if(type(X)==1){ + return (X>0)?1:-1; + } + if(type(X)==5) X=vtol(X); + if(type(X)==4){ + for(W=0,Y=X;Y!=[];Y=cdr(Y)) + for(Z=cdr(Y);Z!=[];Z=cdr(Z)) + if(car(Y)>car(Z)) W++; + if(getopt(val)==1) return W; + return (iand(W,1))?-1:1; + } +} + +def calc(X,L) +{ + if(type(X)<4||type(X)==7){ + if(type(L)==4||type(L)==7){ + V=L[1]; + if(type(X)!=7){ + 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; + } + if((L0=L[0])==">") X=(X>V); + else if(L0=="<") X=(X=") X=(X>=V); + else if(L0=="<=") X=(X<=V); + else if(L0=="!=") X=(X!=V); + }else if(type(L)==7&&type(X)<4){ + 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 tobig(X) +{ + if((type(X)==1 && ntype(X)==3)||type(X)>3) return X; + return eval(X*exp(0)); +} + +def isint(X) +{ + if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1; + return 0; +} + +def israt(X) +{ + if(X==0||(type(X)==1 && ntype(X)==0)) return 1; + return 0; +} + +def iscrat(X) +{ + if(X==0 || (type(X)==1 && israt(real(X)) && israt(imag(X)))) 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 isdecimal(X) +{ + if(type(X)!=7) return 0; + F=S=0; + L=strtoascii(X); + while(L!=[]&&car(L)==32) L=cdr(L); + if(L!=[]&&car(L)==45) L=cdr(L); /* - */ + while(L!=[]&&isnum(car(L))){ + F=1; L=cdr(L); + } + while(L!=[]&&car(L)<33){ + S=1;L=cdr(L); + } + if(L==[]) return F; + else if(S||car(L)!=46) return 0; /* . */ + L=cdr(L);F=0; + while(L!=[]&&isnum(car(L))){ + F=1; L=cdr(L); + } + while(L!=[]&&car(L)<33) L=cdr(L); + return (L==[])?F:0; +} + +def isvar(X) +{ + return ([X]==vars(X)&&vtype(X)<3)?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]!="" && VC[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;I0){ + 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; K0 && iand(Only,1)==0) continue; + if(Q==0 && iand(Only,2)==0) continue; + if(Q<0 && iand(Only,4)==0) continue; + for(K=0; K0) 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){ +#ifdef USEMODULE + str_tb(["-(",s2sp(mtransbys(os_md.abs,car(R)[1],[])),")"],Out); +#else + str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out); +#endif + }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; I1){ + 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); + } + } + close_file(Id); + }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=F?s2sp(car(B)|std=F):s2sp(car(B)); + if(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(T=car(B)); + if(length(RT)L1) continue; + if(F) T=s2sp(s2sp(T|std=K)); + R=cons(T,R); + } + return reverse(R); + } + } + MP=(L1MO) return 0; + LL[R[1]]=R; + K=R[1]; + } + if(K==1||type(Sp)!=4){ + LL[1]=[[[1]]]; + for(I=2; I<=MO && I=II){ + if(S=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); + } + RRR=qsort(reverse(RRR)); + if(findin(RRR,LL[S+OD])<0) + LL[S+OD]=cons(RRR,LL[S+OD]); + } + } + for(K=0; K=II) break; + } + } + } + if(L0>0 || L1L1) continue; + if(F) T=s2sp(T|std=F); + RT=cons((St==1)?s2sp(T):T,RT); + } + LL[J] = reverse(RT); + } + } + if(Eq==1) return LL[MO]; + return LL; +} + +def spType2(L) +{ + C=0;R=[]; + for(LT=L;LT!=[];LT=cdr(LT)){ + D=-1;LP=car(LT); + for(LPT=LP;LPT!=[];LPT=cdr(LPT)){ + if(D==-1) D=car(LPT); + else D=igcd(D,car(LPT)); + if(D==1){ + C++;break; + } + } + if(C==2) return 0; + R=cons(D,R); + } + if(C==0) return L; + if(C==1){ + for(K=length(R)-1;R[K]!=1;K--); + D=-1; + for(I=length(R)-1;I>=0;I--){ + if(I==K) continue; + if(D==-1) D=R[I]; + else D=igcd(D,R[I]); + if(D==1) return 0; + } + } + return L; +} + + +/* 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&&Opt!="idx"){ + 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); + } + 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){ + if(getopt(dumb)!=1) print("irregal partitions"); + return -1; + } + 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(Opt=="idx") return SSM; + if(SM > SMM && SM != 2*OD){ + if(getopt(dumb)!=1) print("not realizable"); + return 0; + } + if(JM==1 && Mat!=1) + Fu -= OD - SSM/2; + return [P, OD, SSM, Fu, SM, XM, fspt(M,1)]; +} + +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; + if(Rev==1){ + for(R=[];R0!=[];R0=cdr(R0)){ + T=car(R0); + R=cons(cons(-car(T),cdr(T)),R); + } + R0=R; + } + R0=qsort(R0); + if(Rev==1){ + for(R=[];R0!=[];R0=cdr(R0)){ + T=car(R0); + R=cons(cons(-car(T),cdr(T)),R); + } + R0=R; + } + 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]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){ */ /* rigid */ +/* 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; + if(Mat==0 && type(SM=getopt(slm))==4){ + SM0=SM[0];SM1=anal2sp(SM[1],["*",-1]); + if(findin(0,SM0)>=0){ + for(SM=[],I=length(G)-1;I>0;I--) + if(findin(I,SM0)<0) SM=cons(I,SM); + SM=[SM,SM1]; + G=mcgrs(G,R|mat=1,slm=SM); + return [G[0],anal2sp(G[1],["*",-1])]; + } + }else SM0=0; + for(R = reverse(R) ; R != []; R = cdr(R)){ + GN = []; + L = length(G)-1; + RT = car(R); + if(type(RT) == 4){ + if(length(RT)==L+1&&RT[0]!=0){ + R=cons(cdr(RT),cdr(R)); + R=cons(RT[0],R); + R=cons(0,R); + continue; + } /* addition */ + RT = reverse(RT); S = ADS = 0; + for(G = reverse(G); G != []; G = cdr(G), L--, RT=cdr(RT)){ + AD = car(RT); + if(L > 0){ + S += AD; + if(SM && findin(L,SM0)>=0) ADS+=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; + if(SM0){ + for(ST=reverse(SM1),SM1=[]; ST!=[]; ST=cdr(ST)) + SM1 = cons([car(ST)[0],car(ST)[1]+ADS], SM1); + } + continue; + } + if(RT==0) continue; + VP = newvect(L+1); GV = ltov(G); /* middle convolution */ + for(I = S = OD = 0; I <= L; I++){ + RTT = (I==0)?(Mat-RT):0; + VP[I] = -1; + for(J = M = K = 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; + M=car(GT)[0]; + VP[I] = J; + } + } + } + S -= (L-1)*OD; + for(GN = []; L >= 0; L--){ + GT = GV[L]; + RTT = (L==0)?(-RT):RT; + GTN = (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; + } + if(K>0) GTN = cons([K,(L==0)?(Mat-RT):0], GTN); + } + GN = cons(reverse(GTN), GN); + } + if(SM0&&RT!=0){ + for(M0=M1=-OD,L=length(G)-1;L>=0;L--){ + if(findin(L,SM0)>=0){ + M0+=OD; + if(VP[L]>=0) M0-=GV[L][VP[L]][0]; + }else{ + M1+=OD; + if(VP[L]>=0) M1-=GV[L][VP[L]][0]; + } + } + SM2=[]; + if((Mx1=anal2sp(SM1,["max",1,-RT])[0])<0){ + if(M1>0) SM2=cons([M1,0],SM2); + }else M1+=car(SM1[Mx1]); + if((Mx0=anal2sp(SM1,["max",1,0])[0])<0){ + if(M0>0) SM2=cons([M0,RT],SM2); + }else M0+=car(SM1[Mx0]); + for(J=0;SM1!=[];J++,SM1=cdr(SM1)){ + if(J==Mx0){ + if(M0>0) SM2=cons([M0,-RT],SM2); + }else if(J==Mx1){ + if(M1>0) SM2=cons([M1,0],SM2); + }else SM2=cons([car(SM1)[0],car(SM1)[1]+RT],SM2); + } + SM1=reverse(SM2); + } + G = cutgrs(GN); + } + return SM0?[G,SM1]:G; +} + +def spslm(M,TT) +{ + R=getbygrs(M,1|mat=1); + if(type(R)!=4||type(R[0])!=4||type(S=R[0][1])!=4){ + errno(0);return0; + } + if(S[1]!=[[1,0]]){ + print("Not rigid!");return0; + } + if((F=S[0][0][1])!=0){ + for(V=vars(F);V!=[];V=cdr(V)){ + if(mydeg(F,car(V))==1){ + T=lsol(F,car(V)); + break; + } + } + if(V==[]){ + print("Violate Fuchs condition!"); + return0; + } + } + for(P=[];R!=[];R=cdr(R)) + P=cons(car(R)[0],P); + if(F!=0){ + S=mysubst(S,[car(V),T]);P=mysubst(P,[car(V),T]); + } + return mcgrs(S,P|mat=1,slm=[TT,[[1,0]]]); +} + +/* + F=0 : unify + F=["add",S] : + F=["sub",S] : + F=["+",A,B] : + F=["*",A,B] : + F=["mul",K]; + F=["get",F,V] : + F=["put",F,V] : + F=["get1",F,V] : + F=["put1",F,V] : + F=["max"] : + F=["max",F.V] : + F=["put1"] : + F=["val",F]; + F=["swap"]; + */ +def anal2sp(R,F) +{ + if(type(F)==4&&type(F[0])==4){ /* multiple commands */ + for(;F!=[];F=cdr(F)) R=anal2sp(R,car(F)); + return R; + } + if(type(F)==7) F=[F]; + if(F==0){ /* unify */ + R=ltov(R); + L=length(R); + for(J=1;J=0;I--) + if(R[I][0]!=0) G=cons(R[I],G); + if(length(G[0])==2){ /* sort by multiplicity */ + R=ltov(G); + L=length(R); + for(I=1;I0;J--){ + if(R[J-1][0]>R[J][0]) break; + if(R[J-1][0]==R[J][0]){ + S1=rtostr(R[J-1][1]);S2=rtostr(R[J][1]); + if((K=str_len(S1)-str_len(S2))<0) break; + if(!K&&S10&&car(R)[F[1]]!=F[2]) continue; + if(M0;I--) S=cons(car(R)[I]+F[I],S); + G=cons(cons(car(R)[0],S),G); + } + return G; + } + if(F[0]=="*"){ + L=length(F); + for(G=[];R!=[];R=cdr(R)){ + for(S=0,I=1;I=0;I--){ + V=lsort([0,1,2,3,4],[I],1); + for(J=1;J<4;J++){ + for(T=[],K=3;K>0;K--) + if(K!=J) T=cons(V[K],T); + G=cons([[[V[0],V[J]],T],[1,0,0]],G); + } + } + G=mc2grs(G,"sort"); + }else if(type(G)==7||(type(G)==4&&length(G)==4)){ + if(type(G)==7) G=s2sp(G); + F=(getopt(top)==0)?1:0; + K=[]; + if(type(P)==1&&iand(P,1)&&type(G[0][0])<4){ + G=s2sp(G|std=1); + if(F) G=[G[1],G[2],G[3],G[0]]; + G=sp2grs(G,[d,c,b,a],[1,length(G[0]),-1]|mat=1); + G=reverse(G); + if(iand(P,3)==3){ + V=vars(G); + for(H=L=[a,b,c,d];H!=[];H=cdr(H)) + if(findin(car(H),V)>=0) G=subst(G,car(H),makev([car(H),1])); + G=shortv(G,[a,b,c,d]); + V=vars(G); + for(H=G[3];H!=[];H=cdr(H)){ + T=car(H)[1]; + if(type(T)>1&&!isvar(T)){ + K=[car(H)[0],T]; + break; + } + } + } + F=1; + } + if(F) G=[G[3],G[0],G[1],G[2]]; + S=cons(["anal",1],getopt()); + if(!(R=m2mc(G,0|option_list=S))) return R; + for(G=0,R=cdr(R);R!=[];R=cdr(R)){ + TR=car(R)[0]; + if(TR[0]) G=mc2grs(G,[[TR[0]]]); + G=mc2grs(G,[cdr(TR)]); + } + if(type(P)==1&&K!=[]){ + for(T=10;T<36;T++){ + if(findin(X=makev([T]),V)>=0) continue; + F=K[0]*(X-K[1]); + return [F,simplify(G,[F],4)]; + } + } + } + if(type(P)<2) return G; + F=0; + if(type(P)==7||(type(P)==4&& + (type(P[0])<4||(type(P[0])==4&&length(P[0])==2&&type(P[0][0])<4&&type(P[1])<4)) + )) P=[P]; + if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0; + Keep=(Dvi==2)?1:0; + if(type(P)==4&&type(F=car(P))==7){ + if(F=="mult"){ + for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt()); + return G; + } + if(F=="show"){ + for(R=str_tb(0,0);G!=[];){ + L=car(G); + I=L[0][0];J=L[0][1]; + str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1]) + +"}]&=\\left\\{",R); + for(L=cdr(L);;){ + S=car(L); + str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R); + if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R); + if((L=cdr(L))==[]) break; + str_tb(",\\,",R); + } + str_tb("\\right\\}",R); + if((G=cdr(G))==[]) break; + str_tb(",\\\\\n",R); + } + R=texbegin("align*",str_tb(0,R)); + if(Dvi!=-1) dviout(R|keep=Keep); + return R; + } + if(F=="show0"){ + if(type(Fig=getopt(fig))>0){ + PP=[[-1.24747,-5.86889],[1.24747,-5.86889],[3.52671,-4.8541],[5.19615,-3], + [5.96713,-0.627171],[5.70634,1.8541],[4.45887,4.01478],[2.44042,5.48127], + [0,6],[-2.44042,5.48127],[-4.45887,4.01478],[-5.70634,1.8541], + [-5.96713,-0.627171],[-5.19615,-3],[-3.52671,-4.8541]]; + PL=[[1.8,-5.2],[5.7,-1.7],[3.2,5],[-3.6,4.7],[2.2,3],[-2.8,2.8], + [-1.5,-1.4],[-3.2,-2.5],[0.76,-1.4],[-2,0.2]]; + PC=["black,dashed","green,dashed","red,dashed","blue,dashed", + "black","cyan","green","blue","red","magenta"]; + N=["1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"]; + LL=[[1,2,3],[4,5,6],[7,8,9],[10,11,12],[7,10,13],[4,11,14],[5,8,15],[1,12,15], + [2,9,14],[3,6,13]]; + TB=str_tb("\\draw\n",TB); + if(type(Fig)==4){ + if(type(car(Fig))==1){ + PP=ptaffine(car(Fig)/12,PP);PL=ptaffine(car(Fig)/12,PL); + Fig=cdr(Fig); + } + if(Fig!=[]&&length(Fig)==10) PC=Fig; + } + for(R=mc2grs(G,"show0"|dviout=-1),I=0;R!="";I++){ /* 頂点 */ + J=str_chr(R,0,","); + if(J>0){ + S=str_cut(R,0,J-1); + R=str_cut(R,J+1,1000); + }else{ + S=R;R=""; + } + T=(str_chr(S,0,"1")==0)?"":"[red]"; + str_tb(["node",T,"(",N[I],") at ",xypos(PP[I]),"{$",S,"$}\n"],TB); + } + for(S=PC,P=PL,I=0;I<4;I++){ + for(J=I+1;J<5;J++,S=cdr(S),P=cdr(P)){ /* 線の番号 */ + SS=car(S); + if((K=str_chr(SS,0,","))>0) SS=sub_str(SS,0,K-1); + str_tb(["node[",SS,"] at ",xypos(car(P)), + "{$[",rtostr(I),rtostr(J),"]$}\n"],TB); + } + } + str_tb(";\n",TB); + for(I=0;I<10;I++){ /* 線 */ + S=car(PC);P0=car(PC);L0=car(LL);PC=cdr(PC);LL=cdr(LL); + C=[N[L0[0]-1],N[L0[1]-1],N[L0[2]-1]]; + str_tb(["\\draw[",S,"] (", C[0],")--(",C[1],") (", + C[0],")--(",C[2],") (",C[1],")--(",C[2],");\n"],TB); + } + R=str_tb(0,TB); + if(TikZ==1&&Dvi!=-1) dviout(xyproc(R)|dviout=1,keep=Keep); + return R; + } + for(S="",L=[];G!=[];G=cdr(G)){ + for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL); + TL=msort(TL,[-1,0]); + if(Dvi){ + if(S!="") S=S+","; + for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){ + if(car(T)==I) J++; + else{ + if(I>0&&J>0){ + if(I>9) S=S+"("+rtostr(I)+")"; + else S=S+rtostr(I); + if(J>1){ + if(J>9) S=S+"^{"+rtostr(J)+"}"; + else S=S+"^"+rtostr(J); + } + } + I=car(T);J=1; + } + } + } + L=cons(TL,L); + } + if(Dvi){ + if(Dvi!=-1) dviout(S|eq=0); + return S; + } + return reverse(L); + } + if(F=="sort"){ + G=ltov(G);L=length(G); + for(I=0;IS[0][1]) S=[[S[0][1],S[0][0]],S[1]]; + if(S[1][0]>S[1][1]) S=[S[0],[S[1][1],S[1][0]]]; + if(S[0]>S[1]){ + F=0;S=[S[1],S[0]]; + } + if(S!=G[I][0]){ + if(F==0) G[I]=cons(S,anal2sp(cdr(G[I]),"swap")); + else G[I]=cons(S,cdr(G[I])); + } + for(J=I;J>0;J--){ + if(G[J-1][0]=0;I--){ + for(J=4;J>I;J--) L=cons(mc2grs(G,[F,[I,J]]),L); + } + }else{ + for(I=P[1],J=4;J>=0;J--){ + if(I==J) continue; + L=cons(mc2grs(G,[F,(I0) dviout(L|eq=0,keep=Keep); + } + return L; /* get all spct */ + } + if(type(T=P[1])==4){ + if(F=="get0"&&length(P)==3&&type(I=P[1])==4&&type(J=P[2])==4){ + if(I[0]>I[1]) I=[I[1],I[0]]; + if(J[0]>J[1]) J=[J[1],J[0]]; + if(I[0]>I[0]){S=I;I=J;J=S;}; + K=lsort(I,J,0); + if(length(K)==4){ + S=mc2grs(G,["get0",[I,J]]); + return anal2sp(S,[["*",1,1],0]); + } + I=lsort(K,lsort(I,J,2),1); + S=lsort([0,1,2,3,4],K,1); + D=mc2grs(G,"deg"); + if(findin(4,S)<0) D=-D; + J=mc2grs(G,["get0",[I,S]]); + if(I[0]>S[0]) J=sp2grs(J,"swap"); + return anal2sp(J,[["+",0,D],["*",-1,1]]); + } + if(type(car(T))==4){ + if(T[0][0]>T[0][1]) T=[[T[0][1],T[0][0]],T[1]]; + if(T[1][0]>T[1][1]) T=[T[0],[T[1][1],T[1][0]]]; + if(T[0][0]>T[1][0]) T=[T[1],T[0]]; + for(PG=G;PG!=[];PG=cdr(PG)) + if(car(PG)[0]==T) return (F=="get")?car(PG):cdr(car(PG)); + return []; /* get common spct */ + } + if(length(T)==3){ + T0=T;T=lsort([0,1,2,3,4],T,1); + if(length(T)!=2) return []; + }else T0=0; + if(T[0]>T[1]) T=[T[1],T[0]]; + for(FT=0,PG=G;PG!=[];PG=cdr(PG)){ + if(car(PG)[0][0]==T){ + FT=1;break; + } + if(car(PG)[0][1]==T){ + FT=2;break; + } + } + if(!FT) return []; + L=anal2sp(cdr(car(PG)),[["get1",FT],0]); + if(T0!=0){ + if((K=mc2grs(G,"deg"))!=0){ + if(T[1]!=4) K=-K; + R=reverse(L); + for(L=[];R!=[];R=cdr(R)) L=cons([car(R)[0],car(R)[1]+K],L); + } + T=T0; + } + return (F=="get")?cons(T,L):L; + } + } + if(F=="rest"||F=="eigen"||F=="rest0"||F=="rest1"){ + if(F!="eigen") G=mc2grs(G,"homog"); + if(length(P)==1){ + for(R=[],I=0;I<4;I++){ + for(J=I+1;J<5;J++){ + S=mc2grs(G,[F,[I,J]]); + if(S!=[]) R=cons(cons([I,J],S),R); + } + } + R=reverse(R); + if(Dvi){ + TB=str_tb(0,0); + if(F=="rest0"||F=="rest1"){ + for(T=R;;){ + TT=car(T); + S=rtostr(car(TT)[0])+rtostr(car(TT)[1]); + str_tb(["[",S,"]","&: "],TB); + for(TR=[],TT=cdr(TT);TT!=[];TT=cdr(TT)) + TR=cons(car(TT)[1],TR); + for(TR=qsort(TR);TR!=[];TR=cdr(TR)) + str_tb([s2sp(car(TR)|short=1,std=-1),"\\ \\ "],TB); + if((T=cdr(T))==[]) break; + str_tb("\\\\\n",TB); + } + }else{ + TB=str_tb(0,0); + for(T=R;;){ + TT=car(T); + S=rtostr(car(TT)[0])+rtostr(car(TT)[1]); + str_tb(["[",S,"]",":\\ "],TB); + for(TR=[],TT=cdr(TT);;){ + T0=car(TT); + str_tb(["&",my_tex_form(car(T0)),"&&\\to\\ \n", + ltotex(cdr(T0)|opt="GRS")],TB); + if((TT=cdr(TT))==[]) break; + str_tb("\\\\\n",TB); + } + if((T=cdr(T))==[]) break; + str_tb("\\allowdisplaybreaks\\\\\n",TB); + } + } + R=texbegin("align*",str_tb(0,TB)); + if(Dvi!=-1) dviout(R|keep=Keep); + } + return R; + } + I=P[1]; + if(I[0]>I[1]) I=[I[1],I[0]]; + L=lsort([0,1,2,3,4],I,1); + if(F=="rest"&&length(P)==3){ + J=P[2];if(J[0]>J[1]) J=[J[1],J[0]]; + L=lsort(L,J,1); + if(length(L)!=1) return 0; + return [mc2grs(G,["get0",I]),mc2grs(G,["get0",[I[0],J[0]],[I[1],J[1]]]), + mc2grs(G,["get0",[I[0],J[1]],[I[1],J[0]]]),mc2grs(G,["get0",[I[0],I[1],L[0]]])]; + } + L=[[L[0],L[1]],[L[0],L[2]],[L[1],L[2]]]; + if(F!="eigen"){ + if(I==[0,4]) L=reverse(L); + else{ + for(V=[],J=2;J>=0;J--){ + if(L[J][0]==0) V=cons([L[J][1],J],V); + else{ + for(K=4;K>=0;K--){ + if(findin(K,L[J])<0){ + V=cons([K,J],V);break; + } + } + } + } + V=qsort(V); + L=[L[V[0][1]],L[V[1][1]],L[V[2][1]]]; + } + } + for(LL=[],T=L;T!=[];T=cdr(T)) + LL=cons(mc2grs(G,["get0",[I,car(T)]]),LL); + LL=reverse(LL); + for(R=[],Q=mc2grs(G,["get0",I]);Q!=[];Q=cdr(Q)){ + for(T=[],J=2;J>=0;J--){ + V=anal2sp(LL[J],["get1",(I[0]=0;J--) + if(I!=J) S=cons(M[I][J],S); + R=chkspt(S|opt=2); + M[I][5]=((L=length(R))>1)?s2sp(R[L-2]|short=1):""; + } + } + if(Dvi){ + S=[]; + for(I=4;I>=0;I--){ + L=(K==6)?[M[I][5]]:[]; + L=cons(M[I][I],L); + for(J=4;J>=0;J--){ + if(I==J) L=cons("",L); + else L=cons(s2sp([M[I][J]]),L); + } + S=cons(L,S); + } + T=(K==6)?["reduction"]:[]; + S=cons(append([x0,x1,x2,x3,x4,"idx"],T),S); + M=ltotex(S|opt="tab",hline=[0,1,z], + vline=(K==6)?[0,1,z-2,z-1,z]:[0,1,z-1,z], + left=["","$x_0$","$x_1$","$x_2$","$x_3$","$x_4$"]); + if(Dvi>0) dviout(M|keep=Keep); + } + return M; + } + if(F=="swap"||F=="perm"){ + if(F=="perm") TR=P[1]; + else{ + TR=newvect(5,[0,1,2,3,4]); + K=P[1][0];L=P[1][1]; + TR[K]=L;TR[L]=K; + if(TR[4]!=4) G=mc2grs(G,"deg"); + } + V=newvect(2); + for(L=[],T=G;T!=[];T=cdr(T)){ + TP=car(T)[0]; + for(TQ=[],I=1;I>=0;I--){ + V=[TR[TP[I][0]],TR[TP[I][1]]]; + if(V[0]>V[1]) V=[V[1],V[0]]; + TQ=cons(V,TQ); + } + if(TQ[0][0]T[1]) T=[T[1],T[0]]; + T1=[T[0],4];T2=[T[1],4]; + for(L=[],PG=reverse(G);PG!=[];PG=cdr(PG)){ + R=car(PG);R0=R[0];F=0;K=P[0][1]; + if(R0[0]==T) F=1; + else if(R0[1]==T) F=2; + else if(getopt(unique)!=1){ + K=-K; + if(R0[0]==T1||R0[0]==T2) F=1; + else if(R0[1]==T1||R0[1]==T2) F=2; + } + if(F==0) L=cons(R,L); + else{ + R1=anal2sp(cdr(R),(F==1)?["+",K,0]:["+",0,K]); + L=cons(cons(R0,R1),L); + } + } + G=L; + }else if(type(S[0])<4){ + if(length(S)==1){ /* mc wrt0 4:cases */ + U=mc2grs(G,"deg"); + C=P[0][0]; + L=[]; + /* [[0,1],[2,3]] : [K=[0,k],J=[i,j]], S=[k,4] : 3 cases */ + for(K=1;K<4;K++){ + J=lsort([1,2,3],[K],1); + K4=[K,4];K0=[0,K]; + G0=mc2grs(G,["get0",[K0,J]]); + LT=anal2sp(G0,["+",C,0]); + G0=mc2grs(G,["get0",J]); + L0=anal2sp(G0,["put1",1,0]); + LT=anal2sp(LT,["add",L0]); + G0=mc2grs(G,["get0",K4]); + L0=anal2sp(G0,[["put1",1,0],["+",0,U]]); + LT=anal2sp(LT,["add",L0]); + G0=mc2grs(G,["get0",[[0,J[0]],K4]]); + L0=anal2sp(G0,[["get",1,0],["+",0,U]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,J[1]],K4]]); + L0=anal2sp(G0,[["get",1,0],["+",0,U]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[K0,J]]); + L0=anal2sp(G0,[["get",1,0],["+",C,0]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,4],J]]); + L0=anal2sp(G0,[["+",-C,0],["get",1,0]]); + LT=anal2sp(LT,[["sub",L0],0]); + L=cons(cons([K0,J],LT),L); + } + /* [[0,1],[2,4]] : [K,I]=[[0,k],[i,4]] S=[j,k] : 6 cases */ + for(K=1;K<4;K++){ + for(I=1;I<4;I++){ + if(I==K) continue; + for(J=1;J<4;J++) if(J!=I&&J!=K) break; + I4=[I,4];S=(J0;K--){ + J=lsort([1,2,3],[K],1); + G0=mc2grs(G,["get0",[[0,4],J]]); + LT=anal2sp(G0,["+",-C,0]); + G0=mc2grs(G,["get0",J]); + L0=anal2sp(G0,["put1",1,-C]); + LT=anal2sp(LT,["add",L0]); + G0=mc2grs(G,["get0",[K,4]]); + L0=anal2sp(G0,[["put1",1,-C],["+",0,U]]); + LT=anal2sp(LT,["add",L0]); + + G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]); + L0=anal2sp(G0,[["get",1,0],["+",-C,U]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]); + L0=anal2sp(G0,[["get",1,0],["+",-C,U]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,K],J]]); + L0=anal2sp(G0,[["get",1,0],["+",-C,0]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,4],J]]); + L0=anal2sp(G0,[["get",1,C],["put",1,0]]); + LT=anal2sp(LT,[["sub",L0],0]); + L=cons(cons([[0,4],J],LT),L); + } + /* [[1,2],[3,4]] : [J,K]=[[i,j],[k,4]] 3 cases */ + for(K=3;K>0;K--){ + J=lsort([1,2,3],[K],1); + if(K>1) + LT=mc2grs(G,["get0",[J,[K,4]]]); + else{ + LT=mc2grs(G,["get0",[[K,4],J]]); + LT=anal2sp(LT,"swap"); + } + G0=mc2grs(G,["get0",J]); + L0=anal2sp(G0,[["put1"],["+",0,-C-U]]); + LT=anal2sp(LT,["add",L0]); + G0=mc2grs(G,["get0",[K,4]]); + L0=anal2sp(G0,[["put1"],["+",U,0]]); + LT=anal2sp(LT,["add",L0]); + + G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]); + L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]); + L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,K],J]]); + L0=anal2sp(G0,[["get1",1,0],["put1"],["+",0,-C-U]]); + LT=anal2sp(LT,["sub",L0]); + G0=mc2grs(G,["get0",[[0,4],J]]); + L0=anal2sp(G0,[["get1",1,C],["put1"],["+",0,-C-U]]); + LT=anal2sp(LT,[["sub",L0],0]); + if(K==1){ + LT=anal2sp(LT,"swap"); + L=cons(cons([[K,4],J],LT),L); + }else L=cons(cons([J,[K,4]],LT),L); + } + G=L; + }else if(length(S)==2){ /* general mc */ + if(S[1]!=0){ + I=S[0]; + if(I!=0) G=mc2grs(G,["swap",[0,I]]); + G=mc2grs(G,[S[1]]); + if(I!=0) G=mc2grs(G,["swap",[0,I]]); + } + }else if(length(S)==3||length(S)==4){ /* addition */ + for(I=1;I<4;I++,S=cdr(S)) + if(S[0]) G=mc2grs(G,[[[0,I],S[0]]]); + if(length(S)==1 && S[0]) /* mc */ + G=mc2grs(G,[S[0]]); + } + } + } + return mc2grs(G,"sort"); +} + +def mcmgrs(G,P) +{ + if(type(G)<2){ + if(G>1){ + N=G+2;G=[]; + for(I=1;I<=N;I++){ + for(J=1;J GRS */ + G=s2sp(G|std=1); + L=length(G); + for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V); + V=cons(makev([L+9]),V); + G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1); + if(getopt(short)!=0){ + V=append(cdr(V),[V[0]]); + G=shortv(G,V); + } + R=chkspt(G|mat=1); + if(R[2] != 2 || R[3] != 0 || !(R=getbygrs(G,1|mat=1))) return 0; + if(getopt(anal)==1) return R; /* called by mcmgrs() */ + if(!(G=mcmgrs(L-2,0))) return 0; + for(R=cdr(R);R!=[];R=cdr(R)){ + TR=car(R)[0]; + if(TR[0]) G=mcmgrs(G,[[TR[0]]]); + G=mcmgrs(G,[cdr(TR)]); + } + } + L=length(G); + for(N=4;N<25;N++){ + K=N^2*(N-1)/2; + if(K>L) return 0; + if(K==L) break; + } + if(type(P)<2) return G; + F=0; + if(type(P)==7||(type(P)==4&&type(P[0])<4)) P=[P]; + if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0; + Keep=(Dvi==2)?1:0; + if(type(P)==4 && type(F=car(P))==7){ + if(F=="mult"){ + for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt()); + return G; + } + if(F=="get"||F=="get0"){ + if(Dvi!=0) F="get"; + if(length(P)==2){ + if(type(P[1])==4){ + if(type(P[1][1])==4){ /* [[,],[,]] */ + for(PG=reverse(G);PG!=[];PG=cdr(PG)){ + TP=car(PG); + if(TP[0]==P[1]) return (F=="get")?TP:cdr(TP); + } + return []; + } + if(P[1][0]==0){ + if(length(P[1])==2){ /* [0,] */ + for(J=1;J<=N;J++) if(J!=P[1][1]) break; + for(K=J+1;K<=N;K++) if(K!=P[1][1]) break; + L=mcmgrs(G,["get0",[P[1],[J,K]]]); + L=anal2sp(L,["get1",1]); + }else{ /* [0,*,*] */ + L=mcmgrs(G,["get0",[[P[1][0],P[1][1]],P[1]]]); + L=anal2sp(L,["get1",2]); + } + }else{ /* [,] */ + for(J=1;J<=N;J++) if(J!=P[1][0]&&J!=P[1][1]) break; + L=mcmgrs(G,["get0",[[0,J],P[1]]]); + L=anal2sp(L,["get1",2]); + } + L=anal2sp(L,0); + if(F=="get") L=cons(P[1],L); + return L; + }else{ /* I */ + for(L=[],I=P[1],J=0;J<=N;J++){ + if(I==J) continue; + II=(I10) + for(I=9;I0){ + if(V!=[]) dviout(L|keep=Keep); + else dviout(L|eq=0,keep=Keep); + } + }else L=reverse(L); + return L; + } + if(F=="show"){ + for(R=str_tb(0,0);G!=[];){ + L=car(G); + I=L[0][0];J=L[0][1]; + str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1]),R); + if(length(J)==3) str_tb(rtostr(J[2]),R); + str_tb("}]&=\\left\\{",R); + for(L=cdr(L);;){ + S=car(L); + str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R); + if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R); + if((L=cdr(L))==[]) break; + str_tb(",\\,",R); + } + str_tb("\\right\\}",R); + if((G=cdr(G))==[]) break; + str_tb(texcr(43),R); + } + R=texbegin("align*",str_tb(0,R)); + if(Dvi!=-1) dviout(R|keep=Keep); + return R; + } + if(F=="show0"){ + for(C=N*(N-1)*(N-2)/2,S="",L=[];G!=[];G=cdr(G)){ + for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL); + TL=msort(TL,[-1,0]); + if(Dvi){ + if(S!=""){ + if(--C==0) S=S+";"; + else S=S+","; + } + for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){ + if(car(T)==I) J++; + else{ + if(I>0&&J>0){ + if(I>9) S=S+"("+rtostr(I)+")"; + else S=S+rtostr(I); + if(J>1){ + if(J>9) S=S+"^{"+rtostr(J)+"}"; + else S=S+"^"+rtostr(J); + } + } + I=car(T);J=1; + } + } + } + L=cons(TL,L); + } + if(Dvi){ + if(Dvi!=-1) dviout(S|eq=0,keep=Keep); + return S; + } + return reverse(L); + } + if(F=="spct"){ + G=mcmgrs(G,"get"); + M=newmat(N+1,N+1); + for(;G!=[];G=cdr(G)){ + GT=car(G);I=GT[0][0];J=GT[0][1]; + for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){ + L=cons(car(GT)[0],L); + } + L=reverse(qsort(L)); + M[I][J]=M[J][I]=L; + } + for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT); + for(I=0;I<=N;I++){ + S=-(N-2)*D^2; + for(J=0;J<=N;J++){ + if(I==J) continue; + for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2; + } + M[I][I]=S; + } + if(Dvi){ + S=[]; + for(LS=[],I=N;I>=0;I--){ + L=[M[I][I]]; + for(J=N;J>=0;J--){ + if(I==J) L=cons("",L); + else L=cons(s2sp([M[I][J]]),L); + } + S=cons(L,S); + LS=cons("$x_"+rtostr(I)+"$",LS); + } + S=cons(append(LS,["idx"]),S); + M=ltotex(S|opt="tab",hline=[0,1,z],vline=[0,1,z-1,z],left=cons("",LS)); + if(Dvi>0) dviout(M|keep=Keep); + } + return M; + } + if(F=="deg"){ + for(S=I=0;IT[1]) T=[T[1],T[0]]; + T1=[T[0],N];T2=[T[1],N]; + T01=cons(0,T1);T02=cons(0,T2); + for(PG=G;PG!=[];PG=cdr(PG)){ + R=car(PG);R0=R[0];K1=K2=0; + TP=R0[0]; + if(TP==T) K1=K; + else if(TP==T1||TP==T2) K1=-K; + if(length(TP=R0[1])==2){ + if(TP==T) K2=K; + else if(TP==T1||TP==T2) K2=-K; + }else{ + S=0; + if(findin(T[0],TP)>=0) S++; + if(findin(T[1],TP)>=0) S++; + if(S>0&&TP[2]==N) K2=-K; + else if(S==2) K2=K; + } + R1=anal2sp(cdr(R),["+",K1,K2]); + L=cons(cons(R0,R1),L); + } + G=reverse(L); + } + }else if(length(S)==1){ /* middle convolution */ + C=S[0];L=[]; + for(I=1;I<=N;I++){ + for(J=1;J<=N;J++){ + if(I==J) continue; + for(K=J+1;K<=N;K++){ /* [[0,I],[J,K]] */ + if(I==K)continue; + T=[[0,I],JK=[J,K]]; + if(I==N){ + LT=mcmgrs(G,["get0",T]); + G0=mcmgrs(G,["get0",JK]); + L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]); + G0=mcmgrs(G,["get0",[0,J,K]]); + LT=anal2sp(LT,["add",L0]); + L0=anal2sp(G0,["put1",1,0]); + LT=anal2sp(LT,["add",L0]); + for(V=1;V<=N;V++){ + if(V==I){ + G0=mcmgrs(G,["get0",T]); + L0=anal2sp(G0,["get",1,C]); + }else if(V==J||V==K){ + G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]); + L0=anal2sp(G0,["get",1,0]); + }else{ + G0=mcmgrs(G,["get0",[[0,V],JK]]); + L0=anal2sp(G0,["get",1,0]); + } + LT=anal2sp(LT,["sub",L0]); + } + LT=anal2sp(LT,["+",-C,0]); + }else if(K==N){ + LT=mcmgrs(G,["get0",T]); + LT=anal2sp(LT,["+",C,0]); + G0=mcmgrs(G,["get0",JK]); + L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]); + LT=anal2sp(LT,["add",L0]); + G0=mcmgrs(G,["get0",[0,J,K]]); + L0=anal2sp(G0,[["put1",1,0],["+",0,-C]]); + LT=anal2sp(LT,["add",L0]); + for(V=1;V<=N;V++){ + if(V==I){ + G0=mcmgrs(G,["get0",T]); + L0=anal2sp(G0,[["get",1,0],["+",C,0]]); + }else if(V==J){ + G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]); + L0=anal2sp(G0,[["get",1,0],["+",0,-C]]); + }else if(V==N){ + G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]); + L0=anal2sp(G0,[["get",1,C],["+",-C,-C]]); + }else{ + G0=mcmgrs(G,["get0",[[0,V],JK]]); + L0=anal2sp(G0,["get",1,0]); + } + LT=anal2sp(LT,["sub",L0]); + } + }else{ + G0=mcmgrs(G,["get0",T]); + LT=anal2sp(G0,["+",C,0]); + G0=mcmgrs(G,["get0",JK]); + L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]); + LT=anal2sp(LT,["add",L0]); + G0=mcmgrs(G,["get0",[0,J,K]]); + L0=anal2sp(G0,["put1",1,0]); + LT=anal2sp(LT,["add",L0]); + for(V=1;V<=N;V++){ + if(V==I){ + G0=mcmgrs(G,["get0",T]); + L0=anal2sp(G0,[["get",1,0],["+",C,0]]); + }else if(V==J||V==K){ + G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]); + L0=anal2sp(G0,["get",1,0]); + }else if(V==N){ + G0=mcmgrs(G,["get0",[[0,V],JK]]); + L0=anal2sp(G0,[["get",1,C],["+",-C,0]]); + }else{ + G0=mcmgrs(G,["get0",[[0,V],JK]]); + L0=anal2sp(G0,["get",1,0]); + } + LT=anal2sp(LT,["sub",L0]); + } + } + LT=anal2sp(LT,0); + L=cons(cons(T,LT),L); + } + T=[[0,I],(I0) 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=0) R=length(S)-IL-R; + return R; + } + if((SJIS=getopt(sjis))!=1) SJIS=0; + if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){ + for(;;){ + MJ=str_str(S,N|top=JJ,sjis=SJIS); + if(MJ>=0){ + MI=str_str(S,II|top=N,sjis=SJIS); + 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=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 && JJ128){ + 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 str_times(S,N) +{ + if(!isint(N)) return ""; + if(type(S)==7){ + for(Tb=str_tb(0,0);N-->0;) + str_tb(S,Tb); + return str_tb(0,Tb); + } + if(type(S)==4){ + for(LT=[],I=0;I1) { + if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */ + if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */ + Mode = 1; + } else return 0; + }else if(C == 0x28 && length(L)>1) { /* ( */ + if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */ + Mode = 0; + }else if(C == 0x49) { /* I */ + Mode = 2; + }else{ + R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R); + } + }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */ + L=cdr(L); + }else{ + R=cons(0x1b,R);R=cons(C,R); + } + }else if(C == 0x0e) { + Mode = 2; + }else if(C == 0x0f) { + Mode = 0; + }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */ + D=car(L=cdr(L)); + if(D>0x20 && D<0x7f) { + R=cons(ior(C,0x80),R);R=cons(ior(D,0x80),R); + } else return 0; + }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */ + R=cons(0x8e,R); R=cons(ior(C,0x80),R); + }else if(((C>0x80 && C<0xa0) || (C>0xdf && C<0xf0)) && length(L)>1) { /* ShiftJIS */ + D=car(L=cdr(L)); + if(D>0x3f && D<0xfd && D!=0x7f) { + T=sjis2jis([C,D]); + R=cons(ior(T[0],0x80),R); R=cons(ior(T[1],0x80),R); + }else return 0; + }else if(C>0x9f && C<0xe0) { /* HanKana */ + R=cons(0x8e,R); R=cons(C,R); + }else if(C == 0x0a){ + CR++; + }else if(C == 0x0d){ + R=cons(0x0d,R); + CR=0; + }else{ + while(CR-->0) R=cons(0x0d,R); + R=cons(C,R); + } + } + while(CR-->0) R=cons(0x0d,R); + return asciitostr(reverse(R)); +} + +def s2sjis(S) +{ + for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){ + if((C=car(L)) == 0x1b && length(L)>1) { + if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */ + if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */ + Mode = 1; + } else return 0; + }else if(C == 0x28 && length(L)>1) { /* ( */ + if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */ + Mode = 0; + }else if(C == 0x49) { /* I */ + Mode = 2; + }else{ + R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R); + } + }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */ + L=cdr(L); + }else{ + R=cons(0x1b,R);R=cons(C,R); + } + }else if(C == 0x0e) { + Mode = 2; + }else if(C == 0x0f) { + Mode = 0; + }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */ + D=car(L=cdr(L)); + if(D>0x20 && D<0x7f) { + T=jis2sjis([C,D]); + R=cons(T[0],R);R=cons(T[1],R); + } else return 0; + }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */ + R=cons(ior(C,0x80),R); + }else if(C>0xa0 && C<0xff && length(L)>1) { /* EUC */ + D=car(L=cdr(L)); + if(D>0xa0 && D<0xff) { + T=jis2sjis([iand(C,0x7f),iand(D,0x7f)]); + R=cons(T[0],R);R=cons(T[1],R); + }else return 0; + }else if(C == 0x0a){ + CR++; + }else if(C == 0x0d){ + R=cons(0x0a,R);R=cons(0x0d,R); + CR=0; + }else{ + while(CR-->0){ + R=cons(0x0a,R);R=cons(0x0d,R); + } + R=cons(C,R); + } + } + while(CR-->0){ + R=cons(0x0a,R);R=cons(0x0d,R); + } + return asciitostr(reverse(R)); +} + +def r2ma(S) +{ + return evalma(S|inv=1); +} + +def evalma(S) +{ + L0=["\n","\d","{","}","[","]","Log","Exp","Sinh","Cosh","Tanh","Sin","Cos","Tan", + "ArcSin","ArcCos","ArcTan"]; + L1=["", "" ,"[","]","(",")","log","exp","sinh","cosh","tanh","sin","cos","tan", + "asin", "acos", "atan"]; + if(getopt(inv)==1){ + if(type(S)==6) S=m2ll(S); + else if(type(S)==5) S=vtol(S); + if(type(S)==4){ + for(L=[];S!=[];S=cdr(S)){ + if(type(car(S))==6) L=cons(m2ll(car(S)),L); + else if(type(car(S))==5) L=cons(vtol(car(S)),L); + else L=cons(car(S),L); + } + S=reverse(L); + }else return 0; + return str_subst(rtostr(S),cdr(cdr(L1)),cdr(cdr(L0))); + } + if(S==0){ + print("Mathematica text (terminated by ;) ?"); + purge_stdin(); + Tb=str_tb(0,0); + for(;;){ + S=get_line(); + str_tb(S,Tb); + if(str_char(S,0,";")>=0) break; + } + S=str_tb(0,Tb); + } +/* + while((P=str_chr(S,0,";"))>=0){ + V0=evalma(str_cut(S,0,P+1)); + S=str_cut(S,P+1,length(S)); + } + if((P=str_char(S,0,"="))>=0){ + X=strtoascii(str_cut(S,0,P)); + L=length(X); + for(P0=P1=-1,I=0;I=0){ + for(I==P0;I-->0;) X=cdr(X); + if((X0=car(X))>96) X0-=32; + Y=[X0];X=cdr(X); + for(I=P1-P0;I-->0;X=cdr(X)) + Y=cons(car(X),Y); + Y=cons(61,Y); + Var=asciitostr(reverse(Y)); + S=str_cut(S,P,length(S)); + } + } +*/ + S=eval_str(str_subst(S,L0,L1)); + if(type(S)==4){ + for(L=-1,T=S;T!=[];T=cdr(T)){ + if(type(T0=car(T))>4) break; + if(type(T0)<4){ + if(L>=0) break; + L=-2;continue; + } + if(L<-2) break; + if(L==-1) L=length(T0); + else if(L!=length(T0)) break; + } + if(T==[]){ + if(L>0) S=s2m(S); + else S=ltov(S); + } + } +/* + if(S==0 && V0!=0) return V0; + if(type(Var)==7){ + T=rtostr(S); + if(type(S)==7) T="\""+T+"\""; + S=eval_str(Var+T); + mycat(["Define",Var]); + } +*/ + return S; +} + +def i2hex(N) +{ + Opt=getopt(); + if(type(N)==4 && isint(car(N))){ +#ifdef USEMODULE + L=mtransbys(os_md.i2hex,N,[]|option_list=Opt); +#else + L=mtransbys(i2hex,N,[]|option_list=Opt); +#endif + return rtostr(L); + } + if(!isint(N) || N<0) return 0; + if(!N) L=[]; + else{ + Cap=(getopt(cap)==1)?32:0; + for(L=[];N!=0;N=ishift(N,4)){ + J=iand(N,15); + L=cons(((J>9)?(87-Cap):48)+J,L); + } + } + if(!isint(Min=getopt(min))) Min=2; + for(Min-=length(L);Min-->0;) + L=cons(48,L); + if(getopt(num)==1){ + L=cons(120,L);L=cons(48,L); + } + return asciitostr(L); +} + +def sjis2jis(L) +{ + L1=L[1]; + if((L0=L[0])<=0x9f){ + if(L1<0x9f) L0=L0*2-0xe1; + else L0=(L0*2)-0xe0; + }else{ + if(L1<0x9f) L0=L0*2-0x161; + else L0=L0*2-0x160; + } + if(L1<0x7f) return [L0,L1-0x1f]; + else if(L1<0x9f) return [L0,L1-0x20]; + return [L0,L1-0x7e]; +} + +def jis2sjis(L) +{ + L1=L[1]; + if(iand(L0=L[0],1)){ + if(L1<0x60) L=[L1+0x1f]; + else L=[L1+0x20]; + }else L=[L1+0x7e]; + if(L0<0x5f) return cons(ishift(L0+0xe1,1),L); + return cons(ishift(L0+0x161,1),L); +} + +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 tex_cuteq(S,P) +{ + if(P==0) return 0; + if(S[P]==125){ /* } */ + if((Q=str_pair(S,P-1,"{","}"|inv=1))<0) return -1; + if(Q<2||S[Q-1]!=95) return Q; + return tex_cuteq(S,Q-2); + } + if(!isalphanum(S[Q=P--])) return -1; + while(P>0&&isalphanum(S[P])) P--; + if(S[P]==92){ /* \ */ + if(P==0) return P; + else P--; + } + if(S[P]!=95||P==0) return Q; /* _ */ + return tex_cuteq(S,P-1); +} + + +def texket(S) +{ + if(!isint(F=getopt(all))) F=0; + if(type(S)==7){ + L=str_len(S); + SS=strtoascii(S); + }else{ + L=length(S); + SS=S; + } + for(T="",I=I0=0;I4 && str_str(SS,"\\left"|top=J-5,end=J-1)>=0){ + I=J+1;continue; + } + if((K=str_pair(SS,J+1,"(",")"))>=0){ + KK=str_char(SS,J+2,"("); + if(KK>K||KK<0){ + if(F!=1){ + if(!F){ + for(N=J+1;N=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; + } + if(F>0){ + str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb); + return tb_to_string(Tb); + } + } + if(S==0) return ""; + S = ltov(strtoascii(S)); + L = length(S)-1; + while(L >= 1 && S[L] == 10) + L--; + if((Fr=getopt(frac))!=0 && Fr!=1) Fr=2; + for(I = L+1, T = K = 0, SS = []; --I >= 0; ){ + if(S[I] == 32 && I!=L){ + if(I==L) continue; + 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; + } + if(Fr && S[I]>=48 && S[I]<=57){ /* 2/3 -> \tfrac{2}{3} */ + for(K=0,II=I; II>=0; II--){ + if(S[II]>=48 && S[II]<=57) continue; + if(S[II]==47){ /* / */ + if(K>0) break; + K=II; + }else break; + } + if(K>II+1){ + SS=cons(125,SS); + for(J=I; J>K; J--) SS=cons(S[J],SS); + if(AMSTeX){ + SS=cons(123,SS);SS=cons(125,SS); + }else{ + for(J=[114,101,118,111,92];J!=[];J=cdr(J)) /* \over */ + SS=cons(car(J),SS); + } + for(J=K-1;J>II;J--) SS=cons(S[J],SS); + SS=cons(123,SS); + if(AMSTeX){ + J=(Fr==2)?[99,97,114,102,116,92]:[99,97,114,102,92]; + for(;J!=[];J=cdr(J)) /* \tfrac */ + SS=cons(car(J),SS); + } + I=II+1; + }else{ + for(;I>II;I--) SS = cons(S[I], SS); + I++; + } + continue; + } + SS = cons(S[I], SS); + } + SS=str_subst(SS,"\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1); + Subst=getopt(subst); + Sub0=["{asin}","{acos}","{atan}"]; + Sub1=["\\arcsin ","\\arccos","\\arctan "]; + if(type(Subst) == 4){ + Sub0=append(Sub0,Subst[0]);Sub1=append(Sub1,Subst[1]); + } + SS = str_subst(SS,Sub0,Sub1|raw=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); + } + RT=getopt(root); + for(Top=0;;Top++){ /* ((x+1))^{y} , 1/y=2,3,...,9 */ +#if 1 + P=str_str(SS,["))^","^{\\tfrac{1}"]|top=Top); + if(P[0]<0) break; + Sq=0; + if(P[0]==0){ + P=P[1]; + if((Q=str_pair(SS,P,"(",")"|inv=1))<0||SS[Q+1]!=40) continue; + if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3 + && SS[P+14]==125){ + if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0; + } + F=2; + }else{ + P=P[1]; + if(SS[P+12]!=125||(Sq=(SS[P+11]-48))<2||Sq>9) break; + if(SS[P-1]==125){ + if((Q=str_pair(SS,P-2,"{","}"|inv=1))<0) break; + if(Q>1&&SS[Q-1]==95){ + if((Q=tex_cuteq(SS,Q-2))<0) break; + F=0; + }else F=1; + }else{ + if(!isalphanum(SS[Q=P-1]) || (Q=tex_cuteq(SS,Q))<0) break; + F=0; + } + if(RT!=2&&P-Q>32) break; + } +#else + if((P=str_str(SS,"))^"|top=Top))<0 || (Q=str_pair(SS,P,"(",")"|inv=1))<0) break; + else F=2; + Sq=0; + if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3 + && SS[P+14]==125){ + if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0; + } +#endif + for(I=0,S=[];SS!=[];SS=cdr(SS),I++){ + if(I==Q){ + if(Sq){ + S=append([116,114,113,115,92],S); + if(Sq>2) S=append([93,Sq+48,91],S); + S=cons(123,S); + if(F==2) SS=cdr(SS); + else if(F==0) S=cons(car(SS),S); + }else if(F==2&&P-Q==3){ /* (2)^x -> 2^x*/ + SS=cdr(SS);SS=cdr(SS); + S=cons(123,S);S=cons(car(SS),S);S=cons(125,S); + SS=cdr(SS);SS=cdr(SS); + I+=3; + } + continue; + }else if(I==P){ + if(Sq){ + if(F>0) S=cdr(S); + S=cons(125,S); + if(F==2) SS=cdr(SS); + for(J=0;J<12;J++) SS=cdr(SS); + } + continue; + } + S=cons(car(SS),S); + } + SS=reverse(S); + Top=P; + } + S=asciitostr(SS); + if((K=getopt(ket))==1) S=texket(S); + else if(K==2) S=texket(S|all=1); + return S; +} + +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 divmattex(S,T) +{ + TF=["matrix","pmatrix","Bmatrix","bmatrix","vmatrix","Vmatrix"]; + TG=[0,"(","\\{","[","|","\\|"]; + TH=[0,")","\\}","]","|","\\|"]; + if(type(S)!=7) S=mtotex(S); + S=strtoascii(S0=S); + if((P0=str_str(S,"\\begin{"))<0 || (P1=str_str(S,"}"|top=P0+7))<0) + return S0; + F=str_cut(S,P0+7,P1-1); + if((K=findin(F,TF))<0) return S0; + Q=str_str(S,"\\end{"+F+"}"); + if(Q<0) return S0; + for(J=P1+1;S[J]<33;J++); + for(L0=L=[],I=J;J=J) L0=cons(0,L0); + else L0=cons(str_cut(S,I,J-1),L0); + I=J+1; + } + if(S[J]==92&&S[J+1]==92){ /* \\ */ + if(I>=J) L0=cons(0,L0); + else L0=cons(str_cut(S,I,J-1),L0); + L=cons(reverse(L0),L); + L0=[]; + J++; + for(I=J+1;S[I]<33;I++); + } + } + J--; + if(S[J]<33) J--; + if(I<=J) L0=cons(str_cut(S,I,J),L0); + if(length(L0)>0) L=cons(reverse(L0),L); + L=lv2m(reverse(L)); /* get matrix */ + if(T==0) return L; + if(type(T)==1) T=[T]; + Size=size(L);S0=Size[0]; + if(type(T[0])!=4){ + S1=Size[1]; + T=append(T,[S1]); + for(TT=[],I=0;T!=[];T=cdr(T)){ + J=car(T); + if(J>S1) J=S1; + for(T0=[];J>I;J--) T0=cons(J-1,T0); + if(T0!=[]) TT=cons(T0,TT); + I=car(T); + } + T=reverse(TT); + } + SS=length(T); + St=str_tb(0,0); + if(SS==1) St=str_tb("\\begin{"+F+"}\n",St); + else{ + if(K>0) St=str_tb("&\\left"+TG[K],St); + St=str_tb("\\begin{matrix}\n",St); + } + for(;T!=[];T=cdr(T)){ + for(I=0;I0) St=str_tb("&",St); + if(L[I][car(TT)]!=0) St=str_tb(L[I][car(TT)],St); + } + if(I1) + St=str_tb("\\end{matrix}\\right.\\\\\n&\\quad\\left.\\begin{matrix}\n",St); + else{ + if(SS==1) St=str_tb("\\end{"+F+"}\n",St); + else St=str_tb("\\end{matrix}\\right"+TH[K]+"\n",St); + } + } + S=str_tb(0,St); + if(SS==1) return S; + return texbegin("align*",S); +} + +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(getopt(inv)==1){ + L2=L0;L0=L1;L0=L2; + } + 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); + } + } + } + if(getopt(raw)==1) return reverse(ST); + return asciitostr(reverse(ST)); +} + +def dviout0(L) +{ + Cmd=["TikZ","TeXLim","TeXEq","DVIOUT","XYPrec","XYcm","XYLim","Canvas"]; + if(type(Opt=getopt(opt))==7){ + if((F=findin(Opt,Cmd)) < 0) return -1; + if(L==-1){ + if(F<=3){ + if(F==0) V=TikZ; + else if(F==1) V=TeXLim; + else if(F==2) V=TeXEq; + else V=iand(DVIOUTF,1); + }else{ + if(F==4) V=XYPrec; + else if(F==5) V=XYcm; + else if(F==6) V=XYLim; + else V=Canvas; + } + return V; + } + if(F==0) TikZ=L; + else if(F==2) TeXEq=L; + else if(F==3){ + if(iand(DVIOUTF,1)==L) + mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1); + else dviout0(4); + return 1; + }else if(F==7&&type(L)==4) + Canvas=L; + else if(L>0){ + if(F==1) TeXLim=L; + else if(F==4) XYPrec=L; + else if(F==5) XYcm=L; + else if(F==6) XYLim=L; + } + mycat0([Cmd[F],"=",L],1); + return 1; + } + if(type(L) == 4){ + for( ; L != []; L = cdr(L)) dviout0(car(L)); + return 1; + } + if(type(L) == 7){ + if(L=="") dviout(" \n"|keep=1); + else if(L=="cls") dviout0(0); + else if(L=="show") dviout(" "); + else if(L=="?") dviout0(3); + else dviout("\\"+L+"\n"|keep=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){ + mycat0(["DIROUT =\"", DIROUT,"\""],1); + mycat0(["DVIOUTH=\"", DVIOUTH,"\""],1); + mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1); + mycat0(["DVIOUTB=\"", DVIOUTB,"\""],1); + mycat0(["DVIOUTL=\"", DVIOUTL,"\""],1); + mycat(["Canvas =", Canvas]); + mycat(["TeXLim =", TeXLim]); + mycat(["TeXEq =", TeXEq]); + mycat(["AMSTeX =", AMSTeX]); + mycat(["TikZ =", TikZ]); + mycat(["XYPrec =", XYPrec]); + mycat(["XYcm =", XYcm]); + mycat(["XYLim =", XYLim]); + }else if(L==4){ + Tmp=DVIOUTA; DVIOUTA=DVIOUTB; DVIOUTB=Tmp; + mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1); + DVIOUTF++; + }else if(L==5){ + if(!iand(DVIOUTF,1)) dviout0(4); + }else if(L==6){ + TikZ=1;mycat("TikZ=1"); + }else if(L==7){ + TikZ=0;mycat("TikZ=0"); + } + 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 tocsv(L) +{ + if(type(L)==6) L=m2ll(L); + else if(type(L)==5) L=vtol(L); + Null=getopt(null); + Tb=str_tb(0,0); + for(LL=L; LL!=[]; LL=cdr(LL)){ + LT=car(LL); + if(type(LT)==5) LT=vtol(LT); + if(type(LT)<4) LT=[LT]; + for(N=0; LT!=[]; LT=cdr(LT),N++){ + if(N) str_tb(", ",Tb); + if((T=car(LT))==Null) continue; + if(type(T)==7){ + K=str_len(T); + T=str_subst(T,["\""],["\"\""]); + if(str_len(T)>K||str_char(T,0,",")>=0) T="\""+T+"\""; + str_tb(T,Tb); + }else str_tb(rtostr(T),Tb); + } + str_tb("\n",Tb); + } + S=str_tb(0,Tb); + if(type(EXE=getopt(exe))!=1&&EXE!=0&&type(EXE)!=7) return S; + if(type(F)!=7){ + fcat(-1,0); + F="risaout"; + if(EXE>=2&&EXE<=9) F+=rtostr(EXE); + F=DIROUTD+F+".csv"; + }else F=S; + if(EXE!=0 && access(F)) remove_file(F); + fcat(F,S|exe=1); + return 1; +} + +def readcsv(F) +{ + if((ID=open_file(F))<0) return -1; + SJIS=isMs(); + L=[]; + if(type(V=getopt(eval))!=4){ + if(V=="all") V=1; + else if(type(V)==1) V=[V]; + else V=[]; + } + Eq=getopt(eq); + Sp=getopt(sp); + if(type(T=getopt(col))!=1) T=0; + Null=getopt(null); + if(type(Null)<0) Null=(Eq==1)?0:""; + while((S=get_line(ID))!=0){ + S=strtoascii(S); + N=length(S); + for(I=J=F=0,LL=LT=[];I128 && C<160)||(C>223 && C<240))){ + LT=cons(C,LT);LT=cons(S[++I],LT);continue; + } + if(F>0){ + LT=cons(C,LT);continue; + } + LS=asciitostr(reverse(LT)); + if(V==1||findin(++J,V)>=0){ + if(Eq==1) LS=(LS=="")?Null:eval_str(LS); + else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS); + } + if(!T || T==J) LL=cons(LS,LL); + if(F==-2) while(++I0)){ /* lastline */ + LS=asciitostr(reverse(LT)); + if(V==1||findin(++J,V)>=0){ + if(Eq==1) LS=(LS=="")?Null:eval_str(LS); + else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS); + } + if(!T || T==J) LL=cons(LS,LL); + } + L=cons(reverse(LL),L); + } + close_file(ID); + if(T) L=m2l(L|flat=1); + L=reverse(L); + return L; +} + +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(S); + 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(type(Var)<0) Var=getopt(var); + 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){ + X=0; + if(Var=="pfrac") X=var(P); + else X=getopt(pfrac); + if(isvar(X)){ + pfrac(P,X|dviout=1); + return; + } + Opt=cons(["dviout",1],getopt()); + if(type(Var)==2||type(Var)==4||type(Var)==7) fctrtos(P|option_list=Opt); + else{ + if(isdif(P)!=0) Opt=cons(["var","dif"],Opt); + else Opt=cons(["br",1],Opt); + fctrtos(P|option_list=Opt); + } + return; + }else if(T==4){ + if(type(Var)==4 || type(Var)==7){ + S=ltotex(P|option_list=getopt()); + 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{ + for(S="[";;){ + S+=my_tex_form(car(P)); + if((P=cdr(P))==[]){ + S+="]";break; + } + S+=","; + } + } + } + }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, begin=s */ +def dviout(L) +{ + /* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTB, 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(),"/"]); + 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%","%TikZ%"],[Home,get_rootdir(),rtostr(TikZ)]); + 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","align*"]) < 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 != " "){ + Eq=1; + 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 && type(Eqo) !=7){ + Eqo=0; + } + } + if(type(L) != 4 || getopt(mult) != 1) + L = [L]; + if(type(Eqo)!=7 && (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){ + if(type(Eqo)==7) + print(texbegin(Eqo,LT)); + else if(Eqo >= 1 && Eqo <= 8){ + mycat0([MyEq[Eqo-1][0],LT,"%"],1); + print(MyEq[Eqo-1][1]); + }else print(LT); + }else print(LT); + output(); + } + } + if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTB,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)==5) M=lv2m([V]); + else 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; I1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0); + if(type(P)==1 && str_str(SS[I][J],"\\frac{-"|end=0)==0) + SS[I][J]="-\\frac{"+str_cut(SS[I][J],7,100000); + } + }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; J0){ + 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=0 && P>=0){ + if(Opt==2 || Opt==4 || Opt==0){ + if(N==0) return (Opt>0)?"0":0; + Pw=0; + if(NT==4){ + NN=abs(real(N));N1=abs(imag(N)); + if(NN-1){ + Pw--; + N*=10;NN*=10; + } + while(N>=10 || N<=-10){ + Pw++; + N/=10;NN/=10; + } + if(Opt==0) return sint(N*10^Pw,P-Pw-1); + S=(getopt(sqrt)==1)?sint(N,P|str=(Opt==4)?3:1,sqrt=1):sint(N,P|str=(Opt==4)?3:1); + if(Pw==0) return S; + if(NT==4) + S="("+S+")"; + if(Pw==1){ + if(Opt==2) + return S+"*10"; + else + return S+"\\times10"; + } + if(Opt==2) + return S+"*10^("+rtostr(Pw)+")"; + else + return S+"\\times10^{"+rtostr(Pw)+"}"; + } + if(NT==4){ + NN=real(N); + if(NN!=0){ + S=sint(NN,P|str=1); + if(imag(N)>0) S=S+"+"; + } + else S=""; + S=S+sint(imag(N),P|str=1)+((Opt==3)?((getopt(sqrt)==1)?"\\sqrt{-1}":"i"):"@i"); + return S; + } + if(N<0){ + N=-N; + Neg="-"; + }else Neg=""; + N=rint(N*10^P)/10^P; + NN=floor(N); + NV=(N-NN+1)*10^P; + NS=rtostr(NN); + if(P<=0) return Neg+NS; + if(NN==0 && getopt(zero)==0) NS=""; + return Neg+NS+"."+str_cut(rtostr(NV),1,P); + } + if(NT==4) + return sint(real(N),P)+sint(imag(N),P)*@i; + X = rint( N*10^P ); + return deval(X/10^P); + } + if( (type(N)==2) || (type(N)==3) ){ + NN = eval(N); + if( type(NN)==1 ) + return sint(NN,P|option_list=getopt()); + else return N; + } + if( type(N)>3 && type(N) < 7) +#ifdef USEMODULE + return mtransbys(os_md.sint,N,[P]|option_list=getopt()); +#else + return mtransbys(sint,N,[P]|option_list=getopt())); +#endif + return N; +} + +def frac2n(N) +{ + if((T=type(N))<0) return N; + E=(getopt(big)==1)?eval(@e):0.1; + if(T==1){ + if(ntype(N)==0) return (E*N)/E; + else if(ntype(N)!=4) return N; + else return (E*(1+@i)*N)/(E*(1+@i)); + } + if(T==3||T==2){ + N=red(N); + Nm=nm(N);Var=vars(Nm);V=car(Var);K=length(Var); + for(S=0,I=mydeg(Nm,V);I>=0;I--) S+=frac2n(mycoef(Nm,I,V))*V^I; + return S/dn(N); + } + if(T<4) return (E*N)/E; +#ifdef USEMODULE + return mtransbys(os_md.frac2n,N,[]|option_list=getopt()); +#else + return mtransbys(frac2n,N,[]|option_list=getopt()); +#endif +} + +def xyproc(F) +{ + if(type(Opt=getopt(opt))!=7) Opt=""; + if(type(Env=getopt(env))!=7) + Env=(!TikZ)?"xy":"tikzpicture"; + if(F==1) + return(Opt=="")?"\\begin{"+Env+"}\n":"\\begin{"+Env+"}["+Opt+"]\n"; + if(F==0) return "\\end{"+Env+"}\n"; + if(type(F)==7){ + F=xyproc(1|opt=Opt,env=Env)+F+xyproc(0|env=Env); + if(getopt(dviout)==1) dviout(F); + else return F; + } +} + +def xypos(P) +{ + if(type(P[0])==7){ + if(P[0]=="") S=""; + else S=(!TikZ)?"\""+P[0]+"\"":"("+P[0]+")"; + } + else{ + if(TikZ==0 && XYcm==1){ + X=sint(P[0]*10,XYPrec); Y=sint(P[1]*10,XYPrec); + }else{ + X=sint(P[0],XYPrec); Y=sint(P[1],XYPrec); + } + S="("+rtostr(X)+","+rtostr(Y)+")"; + } + if(!TikZ){ + 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)==7){ + L=str_len(PP); + if(str_chr(PP,0,"$")==0 && str_chr(PP,L-1,"$")==L-1){ + PP=str_cut(PP,1,L-2); + }else S+="\\txt"; + } + else PP=my_tex_form(PP); + S=S+"{"+PP+"}"; + } + if(length(P)>3){ + if(type(P[3])==7 && P[3]!="") S=S+"=\""+P[3]+"\""; + if(length(P)>4 && type(P[4])==7) S=S+P[4]; + } + }else{ + T=""; + if(length(P)>2 && (PP=P[2])!=""){ + F=1; + if(type(PP)==4){ + if(length(PP)==2 && type(PP[0])==7){ + T="["+PP[0]+"]"; + PP=PP[1]; + } + } + if(type(PP)!=7) PP="$"+my_tex_form(PP)+"$"; + S=S+"{"+PP+"}"; + }else F=0; + if(length(P)>3){ + if(type(P[3])==7 && P[3]!="") T=T+"("+P[3]+")"; + else if(P[3]==1) T=T+"(_)"; + if(length(P)>4 && type(P[4])==7) S=S+P[4]; + } + if(length(P)>2){ + if(F) S="node"+T+" at"+S; + else S="coordinate"+T+" at"+S; + } + } + 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]; + if(length(P)>2) + P1=cons(Sy*P[1],cdr(cdr(P))); + else P1=[Sy*P[1]]; + P=cons((type(P[0])==7)?P[0]:(Sx*P[0]),P1); + } + if(!TikZ) return "{"+xypos(P)+"};\n"; + return "\\"+xypos(P)+";\n"; +} + +def xyline(P,Q) +{ + if(!TikZ) return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n"; + if(type(T=getopt(opt))!=7) T=""; + else T="["+T+"]"; + if(length(P)<3 && length(Q)<3) + return "\\draw"+T+xypos(P)+"--"+xypos(Q)+";\n"; + if(length(P)==2) P=[P[0],P[1],"","_0"]; + else if(length(P)==3 || (length(P)==4 && P[3]=="")) + P=[P[0],P[1],P[2],"_0"]; + else if(length(P)>4 && P[3]=="") + P=[P[0],P[1],P[2],"_0",P[4]]; + if(length(Q)==2) Q=[Q[0],Q[1],"","_1"]; + else if(length(Q)==3 || (length(Q)==4 && Q[3]=="")) + Q=[Q[0],Q[1],Q[2],"_1"]; + else if(length(Q)>4 && Q[3]=="") + Q=[Q[0],Q[1],Q[2],"_1",Q[4]]; + return "\\draw "+T+xypos(P)+" "+xypos(Q)+"("+P[3]+")--("+Q[3]+");\n"; +} + +def xylines(P) +{ + Lf=getopt(curve); + if(type(Lf)!=1) Lf=0; + SS=getopt(opt); + SF=(SS==0)?1:0; + if((Proc=getopt(proc))==1||Proc==2||Proc==3){ + OL=cons(["opt",0],delopt(getopt(),["opt","proc"])); + R=xylines(P|option_list=OL); + OP=(type(SS)<0)?[]:((type(SS)==4)?[["opt",SS[0]],["cmd",SS[1]]]:[["opt",SS]]); + return [1,OP,R]; + } + if(type(SS)!=7 && type(SS)!=4){ + if(Lf==0 && !TikZ) 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)!=5) || (type(PT[0])!=1 && PT[0]!=0)) + PP=cons(PT,PP); + else{ + if(length(PT)>2 && type(PT)==4) + P1=cons(Sy*PT[1],cdr(cdr(PT))); + else P1=[Sy*PT[1]]; + PP=cons(cons(Sx*PT[0],P1),PP); + } + } + P=reverse(PP); + } + } + if(type(Cl=CL0=getopt(close))!=1) Cl=0; + if((Vb=getopt(verb))!=1&&type(Vb)!=4) Vb=0; + if(type(Lf)!=1 || Lf==0){ /* lines */ + if(TikZ||SF){ + for(L=[],F=0,PT=P;PT!=[];PT=cdr(PT)){ + if(type(car(PT))<4){ + L=cons(car(PT),L); + F=0; + }else{ + if(F++>1) L=cons(1,L); + L=cons(car(PT),L); + } + } + if(Cl==1){ + L=cons(1,L);L=cons(-1,L); + } + if(L) L=reverse(L); + if(SF) return L; + if(type(SS)!=4) S=xybezier(L|opt=SS); + else S=xybezier(L|opt=SS[0],cmd=SS[1]); + + }else{ + 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); + } + S=str_tb(0,Out); + } + }else if(Lf==2){ /* B-spline */ + if(SF) return P; + if(!TikZ){ + 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); + S=str_tb(0,Out); + }else Out=str_tb(xybezier(P|opt=SS),0); + for(I=0;I<2;I++){ + Q=car(P); + if(length(Q)>2) + str_tb(xyput(Q),Out); + P=reverse(P); + } + S=str_tb(0,Out); + }else{ /* extended Bezier */ + RTo=getopt(ratio); + if(type(Acc=getopt(Acc))!=1) Acc=0; + 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; + for(L=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; + if(L!=0){ + if(car(L)==P2) + L=cons(1,L); + else{ + L=cons(0,L); L=cons(P2,L); + } + }else L=[P2]; + X=P3[0]-P2[0];Y=P3[1]-P2[1]; + DL1=DL2=0;DL=Acc?sqrt(X^2+Y^2):dsqrt(X^2+Y^2); + if(P4!=0){ + XD1=P4[0]-P2[0];YD1=P4[1]-P2[1];DL1=Acc?sqrt(XD1^2+YD1^2):dsqrt(XD1^2+YD1^2); + } + if(P1!=0){ + XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];DL2=Acc?sqrt(XD2^2+YD2^2):dsqrt(XD2^2+YD2^2); + } + if(RTo!=0) + R=RTo; + else if(DL1>0 && DL2>0){ + Cos=(XD1*XD2+YD1*YD2)/(DL1*DL2); + RT=4/(3*(Acc?sqrt((1+Cos)/2):dsqrt((1+Cos)/2))+3); + R=DL*RT/(DL1+DL2); + }else if(DL1!=0) + R=DL/(2*DL1); + else if(DL2!=0) + R=DL/(2*DL2); + if(DL2!=0) L=cons([P2[0]+R*XD2,P2[1]+R*YD2],L); + if(DL1!=0) L=cons([P3[0]-R*XD1,P3[1]-R*YD1],L); + L=cons([P3[0],P3[1]],L); + } + if(CL0==1) L=cons(-1,cdr(L)); + if(L!=0) L=reverse(L); + if(SF) return L; + if(type(SS)==4) + S=xybezier(L|opt=SS[0],cmd=SS[1],verb=Vb); + else + S=xybezier(L|opt=SS,verb=Vb); + } + if(getopt(dviout)!=1) return S; + xyproc(S|dviout=1); +} + +def saveproc(S,Out) +{ + if(type(Out)==4){ + Out=cons(S,Out); + return Out; + }else{ + str_tb(S,Out); + return Out; + } +} + +def xygrid(X,Y) +{ + for(RR=[],I=0,Z=X;I<2;I++){ + U=Z[2];L=LL=[];M=Z[3]; + if(Z[1]==1||Z[1]==-1){ + if(type(M)==4) L=M; + else{ + if(U*(-dlog(1-1/20)/dlog(10))>=M){ + L=cons([1,2,1/10],L); + LL=cons([1,2,1/2],LL); + }else if(U*(-dlog(1-1/10)/dlog(10))>=M) + L=cons([1,2,1/5],L); + else if(U*(-dlog(1-1/4)/dlog(10))>=M) + L=cons([1,2,1/2],L); + if(U*(-dlog(1-1/50)/dlog(10))>=M){ + L=cons([2,5,1/10],L); + LL=cons([2,5,1/2],LL); + }else if(U*(-dlog(1-1/25)/dlog(10))>=M) + L=cons([2,5,1/5],L); + else if(U*(-dlog(1-1/10)/dlog(10))>=M) + L=cons([2,5,1/2],L); + if(U*(-dlog(1-1/100)/dlog(10))>=M){ + L=cons([5,10,1/10],L); + LL=cons([5,10,1/2],LL); + } + else if(U*(-dlog(1-1/50)/dlog(10))>=M) + L=cons([5,10,1/5],L); + else if(U*(-dlog(1-1/20)/dlog(10))>=M) + L=cons([5,10,1/2],L); + L=cons(L,cons(LL,[[[1,10,1]]])); + } + R=scale(L|scale=U); + if(Z[1]==-1){ + for(LL=[];R!=[];R=cdr(R)){ + for(L=[],T=car(R);T!=[];T=cdr(T)) L=cons(U-car(T),L); + LL=cons(reverse(L),LL); + } + R=reverse(LL); + } + }else if(Z[1]==0){ + if(type(M)==4){ + R=scale(M|f=x,scale=U); + }else{ + V=0; + if(U/10>=M) V=1/10; + else if(U/5>=M) V=1/5; + else if(U/2>=M) V=1/2; + R=[]; + if(V>0){ + UU=U*V; + for(R=[],J=UU;J0;J--){ + U=lsort(S[J],U,0);S[J-1]=lsort(S[J-1],U,1); + } + RR=cons(vtol(S),RR); + Z=Y; + } + if((Raw=getopt(raw))==1) return RR; + SS=[]; + if(type(Sf=getopt(shift))==7){ + Sx=Sf[0];Sy=Sf[1]; + }else Sx=Sy=0; + for(I=0;I<2;I++){ + for(S0=[],L=RR[I];L!=[];L=cdr(L)){ + for(S=[],T=car(L);T!=[];T=cdr(T)){ + if(S!=[]) S=cons(0,S); + if(I==0){ + S=cons([X[0]+Sx,car(T)+Sy],S); + S=cons([Sx,car(T)+Sy],S); + }else{ + S=cons([car(T)+Sx,Y[0]+Sy],S); + S=cons([car(T)+Sx,Sy],S); + } + } + S0=cons(S,S0); + } + SS=cons(reverse(S0),SS); + } + SS=reverse(SS); + if(Raw==2) return SS; + if(length(Y)<5) T=[["",""]]; + else if(type(Y[4])==4) T=[Y[4]]; + else T=[Y[4],Y[4]]; + if(length(X[4])==4) T=cons([""],T); + else if(type(X[4])==4) T=cons(X[4],T); + else T=cons([X[4]],T); + for(Sx=Sy=[],I=0;I<2;I++){ + TT=T[I]; + for(V=SS[I];V!=[];V=cdr(V)){ + Op=car(TT); + if(length(TT)>1) TT=cdr(TT); + if(car(V)==[]) continue; + if(Op=="") S=xylines(car(V)); + else S=xylines(car(V)|opt=Op); + if(I==0) Sx=cons(S,Sx); + else Sy=cons(S,Sy); + } + } + for(S="",Sx=reverse(Sx), Sy=reverse(Sy);Sx!=[]&&Sy!=[];){ + if(Sx!=[]){ + S+=car(Sx);Sx=cdr(Sx); + } + if(Sy!=[]){ + S+=car(Sy);Sy=cdr(Sy); + } + } + return S; +} + + +def addIL(I,L) +{ + if(I==0){ + for(R=[];L!=[];L=cdr(L)) R=addIL(car(L),R); + return reverse(R); + } + if(type(In=getopt(in))==1){ + if(In==-1){ + J=JJ=I[1];I=I[0]; + for(R=[];L!=[];L=cdr(L)){ + J=lmin([car(L)[0],JJ]); + if(J>I) R=cons([I,J],R); + I=lmax([car(L)[1],I]); + } + if(II) return 0; + if(car(L)[1]>=I){ + if(In==3) return car(L); + if(In==1||(I!=car(L)[0]&&I!=car(L)[1])) return 1; + return 2; + } + } + return 0; + } + } + I0=car(I);I1=I[1]; + for(F=0,R=[];L!=[];L=cdr(L)){ + if(I0>car(L)[1]){ + R=cons(car(L),R); + continue; + } + if(I0<=car(L)[1]){ + I0=lmin([I0,car(L)[0]]); + if(I10) Db[I-1]=addIL([P-W+1,1],Db[I-1]); + if(P+W>1 && I+11) OL=[["opt",Opt[0]],["cmd",Opt[1]]]; + else OL=[["opt",Opt]]; + }else OL=[]; + S=xybezier(lbezier(Bf|inv=1)|option_list=OL); + if(Raw==1||!Dvi) return S; + return xyproc(S|dviout=Dvi); +} + +def rungeKutta(F,N,Lx,Y,IY) +{ + if((Pr=getopt(prec))==1){ + One=eval(exp(0)); + }else{ + One=1;Pr=0; + } + if((FL=getopt(last))!=1) FL=0; + if(length(Lx)>2){ + V=car(Lx);Lx=cdr(Lx); + }else V=x; + if(Pr==0) Lx=[deval(Lx[0]),deval(Lx[1])]; + else Lx=[eval(Lx[0]),eval(Lx[1])]; + if(type(Y)==4){ + if((Sing=getopt(single))==1||type(F)!=4) + F=append(cdr(Y),[F]); + L=length(Y); + for(TF=[];F!=[];F=cdr(F)) + TF=cons(f2df(car(F)),TF); + F=reverse(TF); + }else{ + L=1; + F=f2df(F); + } + if(getopt(val)==1) V1=1; + else V1=0; + H=(Lx[1]-Lx[0])/N;H2=H/2; + FV=findin(V,vars(F)); + K=newvect(4); + if(L==1){ + R=[[T=Lx[0],S=IY]]; + if(!H) return R; + for(;;){ + for(I=0;I<4;I++){ + if(I==0) W=[[V,T],[Y,S]]; + else if(I==3) W=[[V,T+H],[Y,S+H*K[2]]]; + else W=[[V,T+H2],[Y,S+H2*K[I-1]]]; + if(FV<0) W=cdr(W); + K[I]=Pr?myfeval(F,W)*One:myfdeval(F,W); + } + S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H; + if(!FL) R=cons([deval(T),S],R); + if((T+H-Lx[1])*H>0) break; + } + }else{ + T=Lx[0]; + R=[cons(T,V1?[car(IY)]:IY)]; + S=ltov(IY); + if(!H) return R; + for(;;){ + for(I=0;I<4;I++){ + if(I==0) W=cons([V,T ],lpair(Y,vtol(S))); + else if(I==3) W=cons([V,T+H ],lpair(Y,vtol(S+H*K[2]))); + else W=cons([V,T+H2],lpair(Y,vtol(S+H2*K[I-1]))); + if(FV<0) W=cdr(W); + for(TK=[],TF=F;TF!=[];TF=cdr(TF)){ + TK=cons(Pr?myfeval(car(TF),W)*One:myfdeval(car(TF),W),TK); + } + K[I]=ltov(reverse(TK)); + } + S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H; + TS=vtol(S); + if(V1) TS=[car(TS)]; + if(!FL) R=cons(cons(deval(T),TS),R); + if((T+H-Lx[1])*H>0) break; + } + } + return FL?(V1?S[0]:S):reverse(R); +} + +def xy2graph(F0,N,Lx,Ly,Lz,A,B) +{ + /* (x,y,z) -> (z sin B + x cos A cos B + y sin A cos B, + -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */ + if((Proc=getopt(proc))==1||Proc==2){ + OPT0=[["proc",3]]; + }else{ + Proc=0;OPT0=[]; + } + if(type(DV=getopt(dviout))==4){ + S=["ext","shift","cl","dviout"]; + OL=delopt(getopt(),S); + OL=cons(["proc",1],OL); + R=xy2graph(F0,N,Lx,Ly,Lz,A,B|option_list=OL); + OL=delopt(getopt(),S|inv=1); + return execdraw(R,DV|optilon_list=OL); + } + 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; + } + + Ratio=Ratio2=1; + if(type(Sc=Sc0=getopt(scale))!=1 && type(Sc)!=4) Sc=1; + if(type(Sc)==4){ + Ratio=Sc[1]/Sc[0]; + if(length(Sc)>2) Ratio2=Sc[2]/Sc[0]; + Sc=Sc[0]; + } + 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=[["para",1],["scale",Sc]]; + if(Raw==1) OL=cons(["raw",1],OL); + if(type(Prec=getopt(prec))>=0) OL=cons(["prec",Prec],OL); + L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]); + Lx=[deval(Lx[0]),deval(Lx[1])]; + Ly=[deval(Ly[0]),deval(Ly[1])]; + Lz=[deval(Lz[0]),deval(Lz[1])]; + A=(A0=A)%360; + F00=F0; + if(type(F0)<4){ + FC=f2df(F0); + if(findin(z,Vars=vars(FC))>=0 && findin(x,Vars)<0 && findin(y,Vars)<0) + F0=[w,[z,0,x+y*@i],[w,os_md.abs,FC]]; + } + if(type(Org=getopt(org))==4){ /* shift origin */ + Lx=[Lx[0]-Org[0],Lx[1]-Org[0]]; + Ly=[Ly[0]-Org[1],Ly[1]-Org[1]]; + Lz=[Lz[0]-Org[2],Lz[1]-Org[2]]; + F0=mysubst(F0,[[x,x+Org[0]],[y,y+Org[1]]]); + if(type(F0)==4){ + F0=cons(F0[0]-Org[2],cdr(F0)); + } + else F0-=Org[2]; + }else Org=[0,0,0]; + Cpx=getopt(cpx); + if(type(Cpx)<0){ + if(str_str(rtostr(F0),"@i")>=0) Cpx=1; + else Cpx=0; + } + if(A<0) A+=360; + if(A<90){ + Sh=1;F1=F0;Cx=x-Org[0];Cy=y-Org[1]; + }else if(A<180){ /* x -> y, y -> -x */ + Sh=2;A-=90; F1=mulsubst(F0,[[x,-y],[y,x]]); + LL=Ly;Ly=[-Lx[1],-Lx[0]];Lx=LL;Cx=y-Org[1];Cy=-x+Org[0]; + }else if(A<270){ + Sh=3;A-=180; F1=subst(F0,[[x,-x],[y,-y]]); + Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];Cx=-x+Org[0];Cy=-y+Org[1]; + }else{ + Sh=4;A-=270;F1=mulsubst(F0,[[x,y],[y,-x]]); + LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;Cx=-y+Org[1];Cy=x-Org[0]; + } + A=@pi*A/180; B=@pi*B/180; + if(A==0) A=@pi/3; + if(B==0) B=@pi/12; + NN=N*M2; + Ac=dcos(deval(A)); As=dsin(deval(A)); + if(Ac<=0.087 || As<=0.087){ + mycat(["Unsuitable angle",A0,"(6-th argument)!"]); + return -1; + } + Bc=Ratio*dcos(deval(B)); Bs=dsin(deval(B)); + if(Bc<0){ + mycat("Unsuitable angle (7-th argument)!"); + return -1; + } + /* + z = f(x,y) => X=-As*x+Ac*y, Y= Bc*f(x,y)-Bsc*x-Bss*y + Out X-coord is in [X0,X1], dvided by Dev segments + J-th segment of Y-coord : ZF[J]==1 => [Z0[0],Z1[J]] + */ + Bsc=Bs*Ac;Bss=Bs*As; + if(Ratio2!=1){ + if(Sh%2==1){ + Ac*=Ratio2;Bss*=Ratio2; + }else{ + As*=Ratio2;Bsc*=Ratio2; + } + } + CX=-As*Cx+Ac*Cy;CY=Bc*(z-Org[2])-Bsc*Cx-Bss*Cy; + if(type(Dvi=getopt(dviout))!=1 && getopt(trans)==1) return [CX*Sc,CY*Sc]; + if(type(N1=getopt(inf))==1){ + if(Proc) Dvi=N1; + else if(Dvi<=0) Dvi=-N1; + } + X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1]; + F1=mysubst(F1,[@pi,deval(@pi)]); + Tf=type(F1=f2df(F1|opt=0)); + if(Tf!=4) F=Bc*F1-Bsc*x-Bss*y; + else F=append([Bc*F1[0]-Bsc*x-Bss*y],cdr(F1)); + Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN; + if(type(Err=getopt(err))==1) + F=mysubst(F,[[x,x+Err*Dx/1011.23],[y,y+Err*Dy/1101.34]]); + Out=(Proc)?[]:str_tb(0,0); + Dev=N*M1; + XD=(X1-X0)/Dev; + OLV=newvect(2,[OL,OL]); + if(type(Ura=getopt(opt))==4 || type(Ura)==7){ + if(type(Ura)==7) Ura=[Ura,Ura]; + else{ + OLV[0]=cons(["opt",Ura[0]],OL); + OLV[1]=cons(["opt",Ura[1]],OL); + } + } + for(KC=0; KC<=1; KC++){ /* draw curves */ + 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=mysubst(F,[y,Y]); + if(!FV){ + if(!Proc) str_tb(["%y=",rtostr(Y),"\n"],Out); + else Out=cons([-2,"y="+rtostr(Y)],Out); + } + }else{ + X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=mysubst(F,[[x,X],[y,Y]]); + if(!FV){ + if(!Proc) str_tb(["%x=",rtostr(X),"\n"],Out); + else Out=cons([-2,"x="+rtostr(X)],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){ + if(Proc) Out=cons(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1,proc=3),Out); + else str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1),Out); + continue; + } + V=VT=LX[1]; + J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD; + if(J0 (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;GG=mysubst(G,[x,VT]); + if(Cpx>=1) VV=myeval(GG); + else VV=(Tf==4)? mydeval(GG):deval(GG); /* 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 */ + K=ceil(M3*(V-V0)/(M2*DD)); + if(N1<0) K=-K; + OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"],["scale",Sc],["para",1]]); + Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz| + option_list=OPT),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; + + if(VV>=Z1[J]) FF=1; + else if(VV<=Z0[J]) FF=-1; + }else{ + if(FF!=0){ + V0=(VT+V1)/2; + K=ceil(M3*(V-V0)/(M2*DD)); + if(N1<0) K=-K; + if(!FV){ + OPT=append(OPT0,OLV[(1-FF)/2]); + Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),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!=0){ + if(Raw!=1){ + OPT=append(OPT0,OLV[(1-FF)/2]); + Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out); + }else if(Vw==-1 && Raw!=1){ + OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"]]); + Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out); + } + } + } + } + OptSc=(Sc==1)?[]:[["scale",Sc]]; + if(type(LZ=getopt(ax))==4){ /* draw box */ + FC=0; + if(length(LZ)==3) FC=LZ[2]; + P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*(LZ[0]-Org[0])-Bsc*Lx[1]-Bss*Ly[1]]); + Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]); + Vy=newvect(2,[Ac*(Ly[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]); + Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]); + OL=OL0=append(OPT0,OL); + if(TikZ && type(Ura)==4 && length(Ura)>2) OL0=cons(["opt",Ura[2]],OL); + LL=[[P0+Vz,P0+Vx+Vz],[P0,P0+Vx]]; + if(Bs>0){ + LL=cons([P0+Vy+Vz,Pz=P0+Vx+Vy+Vz],LL); + LL=cons([P0+Vx+Vz,Pz],LL); + PP=Pz-Vz; + } + else{ + LL=cons([P0+Vy,Pz=P0+Vx+Vy+Vz],LL); + LL=cons([P0+Vx,Pz],LL); + PP=Pz+Vz; + } + J=ceil((PP[0]-X0)/XD+0.5); + LL=append([[P0+Vy,P0+Vy+Vz],[P0+Vy,P0+Vy+Vz],[P0+Vx,P0+Vx+Vz],[P0,P0+Vz], + [P0+Vz,P0+Vy+Vz],[P0,P0+Vy]],LL); + for(LL=reverse(LL);LL!=[];LL=cdr(LL)) Out=saveproc(xylines(car(LL)|option_list=OL0),Out); + if(Dev>4) Dev2=ceil(Dev/2); + if(FC<0 && Raw!=1){ + if(TikZ){ + if(type(Ura)==4 && length(Ura)>2) + OL1=cons(["opt",Ura[2]+",dotted"],OL); + else OL1=cons(["opt","dotted"],OL); + }else OL1=cons(["opt","@{.}"],OL); + if(FC==-8) FC=0; + } + for(I=0;I<3;I++){ /* box with hidden part */ + if(I==1) Pz=PP-Vx; + else if(I==2) Pz=PP-Vy; + LP=Pz-PP; + for(FV=-1,K=0;K<=Dev2; K++){ + PPx=PP[0]+(K/Dev2)*LP[0]; PPy=PP[1]+(K/Dev2)*LP[1]; + J=ceil((PPx-X0)/XD); + if(K!=Dev2 && (J<0||J>Dev)) continue; + if(K!=Dev2 && (ZF[J]==0 || PPyZ1[J])){ /* visible */ + if(FV!=1){ + FV=1; + PPP=[PPx,PPy]; + } + }else{ + if(FV!=0){ + if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out); + FV=0; + } + } + } + } + if(FC!=0 && Raw!=1){ /* show coordinate*/ + if(iand(FC,4)){ + Sub=1; + if(TikZ){ + S0="\\scriptsize";S1=""; + }else{ + S0="{}_{"; S1="}"; + } + }else Sub=0; + if(iand(FC,2)) + LLL=[[1,0,P0+Vx,(TikZ)?"right":"+!L"],[3,0,P0+Vy,(TikZ)?"left":"+!R"]]; + else LL=[]; + if(Bs>0){ + LLL=cons([0,0,P0,(TikZ)?"below":"+!U"],LLL); + LLL=cons([2,1,P0+Vx+Vy+Vz,(TikZ)?"above":"+!D"],LLL); + }else{ + LLL=cons([2,0,P0+Vx+Vy,(TikZ)?"below":"+!U"],LLL); + LLL=cons([0,1,P0+Vz,(TikZ)?"above":"+!D"],LLL); + } + for(TLL=LLL;TLL!=[];TLL=cdr(TLL)){ + TL=car(TLL);LL=L[(Sh+TL[0])%4]; + if(Cpx==0 || Cpx==3){ + S=ltotex([LL[0],LL[1],LZ[TL[1]]]|opt="coord"); + SS="("+rtostr(LL[0]) +","+rtostr(LL[1])+","+rtostr(LZ[TL[1]])+")"; + }else{ + S=ltotex([LL[0]+LL[1]*@i,LZ[TL[1]]]|opt="coord",cpx=Cpx); + SS="("+rtostr(LL[0])+"+"+rtostr(LL[1])+"i,"+ rtostr(LZ[TL[1]])+")"; + } + if(TikZ) S="$"+S+"$"; + if(Sub) S=S0+S+S1; + if(!TikZ) S="$"+S+"$"; + if(Proc) Out=cons([2,OptSc,[TL[2][0],TL[2][1]],[[TL[3],S]],SS],Out); + else str_tb(xyput([TL[2][0],TL[2][1],[TL[3],S]]|option_list=OptSc),Out); + } + } + } + if(type(Pt=getopt(pt))==4){ /* option pt=[] */ + if(type(Pt[0])<4) Pt=[[Pt]]; + if(length(Pt)>1&&type(Pt[1])!=4) Pt=[Pt]; + for(PT=Pt;PT!=[];PT=cdr(PT)){ + PP=car(PT); + if(type(PP)==4 && length(PP)==3 && type(PP[0])<2 && type(PP[2])<2) PP=[PP]; + P=car(PP); + if(type(P)==7) Q=[P,0]; + else if(P==1) Q=["_",0]; + else Q=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]); + if(length(PP)>1 && type(PP[1])==4 && length(PP[1])==3){ /* draw line */ + PP=cdr(PP);P=car(PP); + if(type(P)==7) Q1=P; + else if(P==1) Q="_"; + else Q1=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]); + if(length(PP)<2 || PP[1]==0 || iand(PP[1],1)) OL2=""; + else OL2=(TikZ)?"dotted":"@{.}"; + if(length(PP)>2 && type(PP[2])==7){ + if(OL2=="") OL2=PP[2]; + else{ + if(TikZ) OL2=OL2+","; + OL2=OL2+PP[2]; + } + } + OL1=OL; + if(OL2!="") OL1=cons(["opt",OL2],OL1); + if(length(PP)<2 || PP[1]>=0) + Out=saveproc(xylines([Q,Q1]|option_list=OL1),Out); + else{ + LP0=Q1[0]-Q[0];LP1=Q1[1]-Q[1]; + for(FV=-1,K=0;K<=Dev2; K++){ + PPx=Q[0]+(K/Dev2)*LP0; PPy=Q[1]+(K/Dev2)*LP1; + J=ceil((PPx-X0)/XD); + if(K!=Dev2 && (J<0 || J>Dev || ZF[J]==0 || PPyZ1[J])){ + /* visible */ + if(FV!=1){ + FV=1; + PPP=[PPx,PPy]; + } + }else{ + if(FV!=0){ + if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out); + FV=0; + } + } + } + } + continue; + } + if(length(PP)==1) S="$\\bullet$"; + else if(type(PP[1])==7) S=PP[1]; + else if(type(PP[1])==4){ + if(length(PP[1])>1 && type(PP[1][1])!=7) + S=cons(car(PP),cons("$\\bullet$",cdr(cdr(PP)))); + else S=PP[1]; + }else S="$\\bullet$"; + if(length(PP)<=2){ + if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S]],Out); + else str_tb(xyput([Q[0],Q[1],S]|option_list=OptSc),Out); + }else if(!TikZ){ + if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S,"",PP[2]]],Out); + else str_tb(xyput([Q[0],Q[1],S,"",PP[2]]|option_list=OptSc),Out); + }else{ + if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],cons(S,cdr(cdr(PP)))],Out); + else str_tb(xyput(append([Q[0],Q[1],S],cdr(cdr(PP)))|option_list=OptSc),Out); + } + } + } + if(Proc){ + S=reverse(Out); + if(Proc==1||Proc==3){ + for(W=[],I=0;I<2;I++) for(J=0;J<2;J++) for(K=0;K<2;K++) + W=cons(mysubst([CX*Sc,CY*Sc],[[x,Lx[I]],[y,Ly[J]],[z,Lz[K]]]),W); + W=ptbbox(W); + S=cons([0,W[0],W[1],(TikZ)?1:1/10],S); + } + }else S=str_tb(0,Out); + if(type(Dvi)!=1||(Proc&&abs(Dvi)<2)) return S; + Lout=[]; + if(abs(Dvi)>=2){ + /* show title */ + L0=[]; + Title=getopt(title); + if(type(Title)!=7) + Title=(type(F00)==4)?("\\texttt{"+verb_tex_form(F00)+"}"):my_tex_form(F00); + if(type(Title)==7){ + 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])+")"; + if(Proc){ + if(Cpx>=1) L0=[[5,[["eq",1]],"|"+Title+"|\\quad(z=x+yi,\\ "+T]]; + else L0=[[5,[["eq",1]],"z="+Title+"\\ \\ ("+T]]; + }else{ + if(Cpx>=1) dviout("|"+Title+"|\\quad(z=x+yi,\\ "+T|eq=1,keep=1); + else dviout("z="+Title+"\\ \\ ("+T|eq=1,keep=1); + } + } + A=rint(deval(180*A/@pi))+90*(Sh-1); + if(A>=180) A-=180; + B=rint(deval(180*B/@pi)); + if(abs(Dvi)>=3){ + T="\\text{angle } ("+my_tex_form(A)+"^\\circ,"+my_tex_form(B)+"^\\circ)"; + if(Ratio!=1 || Ratio2!=1) T=T+"\\quad\\text{ratio }1:" + +my_tex_form(sint(Ratio2,2))+":"+my_tex_form(sint(Ratio,2)); + if(Proc) L0=cons([5,[["eq",1]],T],L0); + else dviout(T|eq=1,keep=1); + } + SS="% range "+rtostr([L[3][0],L[1][0]])+"x"+rtostr([L[3][1],L[1][1]])+ + " angle ("+ rtostr(A) +","+ rtostr(B)+") dev="; + if(M1==M2) SS=SS+rtostr(M1); + else SS=SS+rtostr([M1,M2]); + if(M3!=1) SS=SS+" acc="+rtostr(M3); + if(type(Sc0)>=0) SS=SS+" scale="+rtostr(Sc0); + if(Proc){ + S=cons([5,[],SS],S); + for(;L0!=[];L0=cdr(L0)) S=cons(car(L0),S); + return S; + } + if(Dvi>0){ + dviout(SS|keep=1); + dviout(xyproc(S)|eq=8); + }else Lout=[SS,S]; + }else{ + if(Dvi>0) dviout(xyproc(S)); + else Lout=[S]; + } + if(getopt(trans)==1) return cons([CX*Sc,CY*Sc],Lout); + if(Dvi<0) return Lout; +} + +def orthpoly(N) +{ + F=0; + if(type(P=getopt(pol))==7){ + for(L=["Le","Ge","Tc","2T","Ja","He","La","Se"];L!=[];L=cdr(L),F++) + if(str_str(P,car(L)|end=2)==0) break; + }else P=0; + if(type(D=N)==4) D=N[0]; + if(!isint(D)||D<0) return 0; + if(F==0) return seriesHG([-D,D+1],[1],(1-x)/2,D); + if(F==1) return red(seriesHG([-D,D+2*N[1]],[N[1]+1/2],(1-x)/2,D)*binom(D+2*N[1]-1,D)); + if(F==2) return seriesHG([-D,D],[1/2],(1-x)/2,D); + if(F==3){ + if(D==0) return 0; + return orthpoly([D-1,1]|pol="Ge"); + } + if(F==4) return red(seriesHG([-D,D+N[1]],[N[2]],x,D)); + if(F==5){ + for(S=I=1;I<=D;I+=2) S*=I; + if(iand(D,1)) return seriesHG([-(D-1)/2],[3/2],x^2/2,D-1)*x*S*(-1)^((D-1)/2); + else return seriesHG([-D/2],[1/2],x^2/2,D)*S*(-1)^(D/2); + } + if(F==6){ + NN=(type(N)==4)?N[1]:0; + return red(seriesHG([-D],[NN+1],x,D)*binom(D+NN,D)); + } + if(F==7){ + NN=N[1]; + for(S=1,I=1;I<=D;I++) S+=(-1)^I*binom(D,I)*binom(D+I,I)*sftpow(x,I)/sftpow(NN,I); + return S; + } + return 0; +} + +def schurpoly(L) +{ + N=length(L); + for(R=[],I=1;L!=[];L=cdr(L),I++) R=cons(car(L)+N-I,R); + L=reverse(R); + if(type(X=getopt(var))!=4){ + V=(type(X)>1)?X:"x"; + for(X=[],I=0;I0) Y=deval(Y); + else Y=0; + if((V=getopt(const))==0||type(V)>0){ + V=myfeval(V,Y); + K=1; + }else K=0; + if(A!=[]&&type(car(A))>1){ + for(C=[],I=A[1];I>=K;I--) C=cons(myf2eval(car(A),I,Y),C); + if(K) C=cons(0,C); + A=C; + } + if(K){ + if(A!=[]) A=cdr(A); + A=cons(V,A); + } + if(B!=[]&&type(car(B))>1){ + for(C=[],I=B[1];I>0;I--) C=cons(myf2eval(car(B),I,Y),C); + B=C; + } + L=length(B)+1; + if(length(A)>=L) L=length(A)+1; + if(type(Sum=getopt(sum))>0){ + if(Sum==1) Sum=1-x; + else if(Sum==2) Sum=[(z__)/(3.1416*x),[z__,os_md.mysin,3.1416*x]]; + else Sum=f2df(Sum); + C=[]; + if(A!=[]){ + C=cons(car(A),C); + A=cdr(A); + } + for(I=1;A!=[];A=cdr(A),I++) C=cons(car(A)*myf2eval(Sum,I/L,L),C); + A=reverse(C); + for(C=[],I=1;B!=[];B=cdr(B),I++) C=cons(car(B)*myf2eval(Sum,I/L,L),C); + B=reverse(C); + } + if(getopt(cpx)==1){ + if(type(X=eval(X))>1) return todf([os_md.fouriers,[["cpx",1]]],[[A],[B],[X]]); + V=dexp(@i*X); + for(C=A,P=1,I=0;C!=[];C=cdr(C),I++){ + R+=S*car(C)*P; + P*=V; + } + V=dexp(-@i*X); + for(C=B,P=1,I=0;C!=[];C=cdr(C),I++){ + P*=V; + R+=car(C)*P; + } + return R; + } + if(type(X=eval(X))>1) return todf(os_md.fouriers,[[A],[B],[X]]); + for(C=A,I=0;C!=[];C=cdr(C),I++) + R+=car(C)*mycos(I*X); + for(C=B,I=1;C!=[];C=cdr(C),I++) + R+=car(C)*mysin(I*X); + return R; +} + + +def myexp(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.myexp,[Z]); + if((Im=imag(Z))==0) return dexp(Z); + return dexp(real(Z))*(dcos(Im)+@i*dsin(Im)); +} + +def mycos(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.mycos,[Z]); + if((Im=imag(Z))==0) return dcos(Z); + V=myexp(Z*@i); + return (V+1/V)/2; +} + +def mysin(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.mysin,[Z]); + if((Im=imag(Z))==0) return dsin(Z); + V=myexp(Z*@i); + return (1/V-V)*@i/2; +} + +def mytan(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.mytan,[Z]); + if((Im=imag(Z))==0) return dtan(Z); + V=myexp(2*Z*@i); + return @i*(1-V)/(1+V); +} + +def mylog(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.mylog,[Z]); + if((Im=imag(Z))==0) return dlog(Z); + return dlog(dabs(Z))+@i*myarg(Z); +} + +def mypow(Z,R) +{ + if(type(Z=eval(Z))>1||type(R=eval(R))>1) return todf(os_md.mypow,[Z,R]); + if(Z==0) return 0; + if(isint(2*R)){ + if(R==0) return 1; + if(isint(R)) return Z^R; + V=dsqrt(Z); + if(R==1/2) return V; + return Z^(R-1/2)*V; + } + return myexp(R*mylog(Z)); +} + +def myarg(Z) +{ + if(type(Z=map(eval,Z))==4){ + if(length(Z)!=2) return todf(os_md.myarg,[Z]); + Re=Z[0];Im=Z[1]; + }else if(type(Z)>1){ + return todf(os_md.myarg,[Z]); + }else { + Im=imag(Z);Re=real(Z); + } + if(Re==0) return (Im<0)?-deval(@pi)/2:deval(@pi)/2; + V=datan(Im/Re); + if(Re>0) return V; + return (V>0)?(V-deval(@pi)):(V+deval(@pi)); +} + +def myatan(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.myatan,[Z]); + if((Im=imag(Z))==0) return datan(Z); + mylog((1-Z*@i)/(1+Z*@i))*@i/2; +} + +def myasin(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.myasin,[Z]); + return deval(@pi/2)-myacos(Z); +} + +def frac(X) +{ + if(type(X=eval(X))>1) return todf(os_md.frac,[X]); + return (ntype(X)==3)? pari(frac,X):(X-floor(X)); +} + +def myacos(Z) +{ + if(type(Z=eval(Z))>1) return todf(os_md.myacos,[Z]); + if(imag(Z)==0 && Z<=1 && Z>=-1) return dacos(Z); + return mylog(Z-dsqrt(Z^2-1))*@i; +} + +def arg(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.arg,[Z]); + return (type(Z)==4)?pari(arg,Z[0],Z[1]):arg(sqrt,Z); +} + +def sqrt(Z){ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.sqrt,[Z]); + R=(type(Z)==4)?Z[1]:Z; + if(ntype(R)==0){ + if(R==0) return 0; + if(R>0){ + if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R)); + }else{ + R=-R; + if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R))*@i; + } + } + return (type(Z)==4)?pari(sqrt,Z[0],Z[1]):pari(sqrt,Z); +} + +def gamma(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.gamma,[Z]); + return (type(Z)==4)?pari(gamma,Z[0],Z[1]):pari(gamma,Z); +} + +def lngamma(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.lngamma,[Z]); + return (type(Z)==4)?pari(lngamma,Z[0],Z[1]):pari(lngamma,Z); +} + +def digamma(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.digamma,[Z]); + return (type(Z)==4)?pari(digamma,Z[0],Z[1]):pari(digamma,Z); +} + +def dilog(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.dilog,[Z]); + return (type(Z)==4)?pari(dilog,Z[0],Z[1]):pari(dilog,Z); +} + +def erfc(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.erfc,[Z]); + return (type(Z)==4)?pari(erfc,Z[0],Z[1]):pari(erfc,Z); +} + +def zeta(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.zeta,[Z]); + return (type(Z)==4)?pari(zeta,Z[0],Z[1]):pari(zeta,Z); +} + +def eta(Z) +{ + if(vars(Z=map(eval,Z))!=[]) return todf(os_md.eta,[Z]); + return (type(Z)==4)?pari(eta,Z[0],Z[1]):pari(eta,Z); +} + +def jell(Z) +{ + if(vars(Z=map(eval,V))>1) return todf(os_md.jell,[Z]); + return (type(Z)==4)?pari(jell,Z[0],Z[1]):jell(jell,Z); +} + +def evals(F) +{ + if(type(F)==7){ + if(type(Del=getopt(del))!= 7) return eval_str(F); + S=strtoascii(Del);K=length(S); + if(K==0) return [eval_str(F)]; + Raw=getopt(raw); + F=strtoascii(F);L=[];T1=0; + do{ + T2=str_str(F,S|top=T1); + if(T2<0) T2=10000; + FT=str_cut(F,T1,T2-1); + L=cons((Raw==1)?FT:evals(FT),L); + T1=T2+K; + }while(T2!=10000); + return reverse(L); + } + if(type(F)==4){ + if(type(S=car(F))==7){ + S+="("; + for(I=0,FT=cdr(F); FT!=[]; I++,FT=cdr(FT)){ + if(type(ST=car(FT))!=7) ST=rtostr(ST); + if(I>0) S=S+","+ST; + else S=S+ST; + } + S=S+")"; + return eval_str(S); + }else return call(S,cdr(F)); + } + return F; +} + +def myval(F) +{ + if(type(F)!=4){ + F=f2df(sqrt2rat(F)); + if(type(F)!=4) return F; + }; + if(length(F)==1) V=car(F); + else for(V=car(F),F=cdr(F); F!=[];){ + FT=car(F); + if(type(G=FT[1])==2){ + if(length(FT)>2){ + FT2=myval(FT[2]); + if(length(FT)>3) FT3=myval(FT[3]); + }; + X=red(FT2/@pi);Vi=-red(FT2*@i/@pi);W=red(FT2/@e); + if(G==os_md.mypow && FT3==1/2){ + G=os_md.sqrt; + FT=[FT[0],G,FT[2]]; + } + if((T=findin(G, + [sin,os_md.mysin,cos,os_md.mycos,tan,os_md.mytan]))>=0 + &&(isint(6*X)||isint(4*X))){ + if(T==2||T==3){ + T=0;X=1/2-X; + } + X=X-floor(X/2)*2; + if(T==0||T==1){ + if(X>1){ + S=-1;X-=1; + }else S=1; + if(X>1/2) X=1-X; + if(X==0) R=0; + else if(X==1/6) R=1/2; + else if(X==1/4) R=2^(1/2)/2; + else if(X==1/3) R=3^(1/2)/2; + else R=1; + R*=S; + }else{ + if(X>1) X-=1; + if(X>1/2){ + S=-1;V=1-X; + }else S=1; + if(X==0) R=0; + else if(X==1/6) R=3^(1/2)/3; + else if(X==1/4) R=1; + else if(X==1/3) R=3^(1/2); + else R=2^512; + R*=S; + } + }else if((G==exp||G==os_md.myexp)&&(isint(FT2)||isint(6*Vi)||isint(4*Vi))){ + if(isint(FT2)) R=@e^FT2; + else R=myval([z+w*@i,[z,cos,Vi*@pi],[w,sin,Vi*@pi]]); + }else if((G==pow||G==os_md.mypow) && (isint(FT3)||FT2==1||FT2==0)){ + if(FT2==0) R=0; + else if(FT2==1) R=1; + else R=FT2^FT3; + }else if(G==os_md.abs&&ntype(P=eval(FT2))<4){ + R=FT2; + if(P<0) R=-R; + }else if((G==os_md.sqrt||G==dsqrt)&&type(FT2)<2&&ntype(FT2)==0) + R=sqrtrat(FT2); + else if((G==os_md.mylog||G==dlog)&&(FT2==@e||FT2==1)) + R=(FT2==1)?0:1; + else if(length(FT)==3) R=eval((*G)(myeval(FT2))); +#ifdef USEMODULE + else R=call(G,map(os_md.myeval,cdr(cdr(FT)))); +#else + else R=call(G,map(myeval,cdr(cdr(FT)))); +#endif + } + else if(G==0) R=FT[2]; +#ifdef USEMODULE + else R=eval(call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1])); +#else + else R=eval(call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1])); +#endif + V=mysubst(V,[FT[0],R]); + F=mysubst(cdr(F),[FT[0],R]); + } + if(type(V)<4 && !iscoef(V,os_md.iscrat)) V=eval(V); +#if 0 + return (type(V)<4)?myeval(V):mtransbys(os_md.myeval,V,[]); +#else + return V; +#endif +} + +/* -1:空 0:整数 1:有理数 2:Gauss整数 3:Gauss有理数 4:それ以外の複素数 */ +/* def vntype(F) +{ + if((T=type(F))<2){ + if(T<0) return -1; + if((Tn=ntype(F))==0){ + return (isint(F))?0:1; + } + if(Tn==4){ + if(ntype(real(F))==0&&ntype(real(F))==0) + return (isint(F)&&isint(F))?2:3; + return 4; + } + } + if(T==2){ + V=vars(F); + if((VV=lsort(V,[@e,@pi],1))==[]){ + FT=mycoef( + }else{ + if(length(VV)==1){ + }else + } + }else if(T==3){ + + } +} +*/ + + +def myeval(F) +{ + if(type(F)!=4) V=F; + else if(length(F)==1) V=car(F); + else for(V=car(F),F=cdr(F); F!=[];){ + FT=car(F); + if(type(G=FT[1])==2){ + if(length(FT)==3) R=(*G)(myeval(FT[2])); +#ifdef USEMODULE + else R=call(G,map(os_md.myeval,cdr(cdr(FT)))); +#else + else R=call(G,map(myeval,cdr(cdr(FT)))); +#endif + } + else if(G==0) R=myeval(FT[2]); +#ifdef USEMODULE + else R=call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]); +#else + else R=call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]); +#endif + V=mysubst(V,[FT[0],R]); + F=mysubst(cdr(F),[FT[0],R]); + } + return (type(V)<4)?eval(V):mtransbys(eval,V,[]); +} + +def mydeval(F) +{ + if(type(F)!=4) V=F; + else if(length(F)==1) V=car(F); + else for(V=car(F),F=cdr(F); F!=[]; ){ + FT=car(F); + if(type(G=FT[1])==2){ + if(length(FT)==3) R=(*G)(myeval(FT[2])); +#ifdef USEMODULE + else R=call(G,map(os_md.mydeval,cdr(cdr(FT)))); +#else + else R=call(G,map(mydeval,cdr(cdr(FT)))); +#endif + } + else if(G==0) R=mydeval(FT[2]); +#ifdef USEMODULE + else R=call(G[0],map(os_md.mydeval,cdr(cdr(FT)))|option_list=G[1]); +#else + else R=call(G[0],map(mydeval,cdr(cdr(FT)))|option_list=G[1]); +#endif + V=mysubst(V,[FT[0],R]); + F=mysubst(cdr(F),[FT[0],R]); + } + return (type(V)<4)?deval(V):mtransbys(deval,V,[]); +} + +def myfeval(F,X) +{ + if(type(X)==4){ + if(isvar(X[0])&&length(X)==2) + return mydeval(mysubst(F,[X[0],X[1]])); + if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){ + for(Y=X;Y!=[];Y=cdr(Y)) + F=mysubst(F,[car(Y)[0],car(Y)[1]]); + return myeval(F); + } + } + return myeval(mysubst(F,[x,X])); +} + +def myf2eval(F,X,Y) +{ + return myeval(mysubst(F,[[x,X],[y,Y]])); +} + +def myf3eval(F,X,Y,Z) +{ + return myeval(mysubst(F,[[x,X],[y,Y],[z,Z]])); +} + +def myfdeval(F,X) +{ + if(type(X)==4){ + if(isvar(X[0])&&length(X)==2) + return mydeval(mysubst(F,[X[0],X[1]])); + if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){ + for(Y=X;Y!=[];Y=cdr(Y)) + F=mysubst(F,[car(Y)[0],car(Y)[1]]); + return mydeval(F); + } + } + return mydeval(mysubst(F,[x,X])); +} + +def myf2deval(F,X,Y) +{ + return mydeval(mysubst(F,[[x,X],[y,Y]])); +} + +def myf3deval(F,X,Y,Z) +{ + return mydeval(mysubst(F,[[x,X],[y,Y],[z,Z]])); +} + +def df2big(F) +{ + AG=[[os_md.mysin,sin],[os_md.mycos,cos],[os_md.mytan,tan],[os_md.myasin,asin], + [os_md.acos,acos],[os_md,atan,atan],[os_md.myexp,exp],[os_md.mylog,log],[os_md.mypow,pow]]; + if(getopt(inv)!=1) return mysubst(F,AG); + else return mysubst(F,AG|inv=1); + +} + +def f2df(F) +{ + if(type(Opt=getopt(opt))!=1) Opt=0; + if(iand(Opt,1)){ + if(Opt>0) F=map(eval,F); + else F=map(deval,F); + } + Cpx=getopt(cpx); + if(type(F)==4 && iand(Opt,2)==0) return F; + K=getopt(level); + if(type(K)!=1) K=0; + AG=[sin,cos,tan,asin,acos,atan,exp,sinh,cosh,tanh,log,pow]; + AGd=[os_md.mysin,os_md.mycos,os_md.mytan,os_md.myasin,os_md.myacos, + os_md.myatan,os_md.myexp,os_md.myexp,os_md.myexp,os_md.myexp, + os_md.mylog,os_md.sqrt,os_md.myexp]; + for(R=[],I=0,Arg=vars(F);Arg!=[];Arg=cdr(Arg)){ + Fn=functor(car(Arg)); + if(vtype(Fn)!=3) continue; + V=args(car(Arg)); + for(PAG=AG,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)){ + if(Fn==car(PAG)){ + if(K==0) L="z__"; + else L="z"+rtostr(K)+"__"; + if(I==0) VC=makev([L]); + else VC=makev([L,I]); + I++; + VC0=VC; + if(Fn==sinh || Fn==cosh || Fn==tanh){ + VC=makev([L,I++]); + if(Fn==sinh) + R=cons([VC0,0,(VC^2-1)/(2*VC)],R); + else if(Fn==cosh) + R=cons([VC0,0,(VC^2+1)/(2*VC)],R); + else + R=cons([VC0,0,(VC^2-1)/(VC^2+1)],R); + } + if(Fn==pow && (V[1]!=1/2||Cpx==1)){ +#if 0 + R0=f2df(V[1]*((type(V[0])==1)?dlog(V[0]):log(V[0]))|level=K+1); + PAGd=cdr(PAGd); +#else + R=cons([VC,os_md.mypow,V[0],V[1]],R); + F=mysubst(F,[car(Arg),VC0]); + Arg=cons(0,vars(F)); + break; +#endif + }else R0=f2df(V[0]|level=K+1); + R=cons([VC,car(PAGd),R0],R); + F=mysubst(F,[car(Arg),VC0]); + Arg=cons(0,vars(F)); + break; + } + } + } + if(R==[]) return F; + if(Cpx==1){ + for(PAG=P,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)) + R=mysubst(R,[car(PADd),car(PAG)]); + } + return cons(F,reverse(R)); +} + +def todf(F,V) +{ + if(type(V)!=4) V=[V]; + for(R=[];V!=[];V=cdr(V)){ + R=cons(f2df(car(V)),R); + } + V=reverse(R); + Z=makenewv([F,V]); + return [Z,cons(Z,cons(F,V))]; +} + +def compdf(F,V,G) +{ + FL=["abs","floor","rint","zeta","gamma","arg","real","imag","conj"]; + FS=[os_md.abs,floor,rint,os_md.zeta,os_md.gamma,os_md.myarg,real,imag,conj]; + if(type(F)==7){ + if(str_str(F,"|")==0){ + F="abs("+str_cut(F,1,str_len(F)-2)+")"; + }else if(str_str(F,"[")==0){ + F="floor("+str_cut(F,1,str_len(F)-2)+")"; + } + I=str_str(F,"("); + Var=x; + if(I>0){ + J=str_pair(F,I+1,"(",")"); + if(J<0) return 0; + Var=eval_str(str_cut(F,I+1,J-1)); + Var=f2df(Var); + F0=str_cut(F,0,I-1); + } + if((I=findin(F0,FL))<0&&(I=findin(F,FL))<0) F=f2df(eval_str(F)); + else F=[z__,[z__,FS[I],Var]]; + } + if(type(F)!=4) F=f2df(F); + if(type(G)!=4) G=f2df(G); + if(V==G) return F; /* subst(F(V),V,G) */ + VF=vars(F);VG=vars(G); + if(type(V)==4){ + for(VT=[],VV=V;VV!=[];VV=cdr(VV)){ + if(findin(car(VV),VF)>=0){ + X=makenewv(append(VF,VG)); + VF=cons(X,VF); + F=mysubst(F,[car(VV),X]); + VT=cons(X,VT); + }else VT=cons(car(VV),VT); + } + for(V=reverse(VT);V!=[];V=cdr(V),G=cdr(G)) F=compdf(F,car(V),car(G)); + return F; + } + for(E=I=0;I<30;I++){ + for(J=0;J<30;J++){ + X=makev(["z__",I,J]); + if(findin(X,VF)<0 && findin(X,VG)<0){ + E=1;break; + } + } + if(E) break; + } + if(!E) return 0; + if(type(G)<4) return mysubst(F,[V,G]); + if(type(F)<4) F=[F]; /* return compdf([X,[X,0,F]],V,G); */ + F=mysubst(F,[V,X]); + if(isvar(G[0])){ + G=mysubst(G,[G[0],X]); + if(length(G)==2&&type(G[1])==4&&G[1][0]==X) G=G[1]; + G=cons(G,cdr(F)); + } + else G=cons([X,0,G],cdr(F)); + return cons(car(F),G); +} + +def fzero(F,LX) +{ + if(length(LX)==3){ + V=LX[0];LX=cdr(LX); + }else V=x; + LX1=eval(LX[0]);LX2=eval(LX[1]); + if(getopt(zero)==1){ + if(getopt(cont)==1) CT=1; + else CT=0; + if(getopt(trans)!=1 && type(F)<4) F=f2df(F); + F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]); + if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16; + V1=myeval(mysubst(F,[V,X1=LX1])); + V2=myeval(mysubst(F,[V,X2=LX2])); + if(V1>0){ + V0=V1;V1=V2;V2=V0; + X0=X1;X1=X2;X2=X0; + } + if(V1<0 && V2>0){ + D=(V2-V1)*1024; + for(I=0; ID) return []; + V2=V0;X2=X0; + } + } + X0=(V2*X1-V1*X2)/(V2-V1); + return [X0,myeval(mysubst(F,[V,X0]))]; + } + if(V0==0) return [X0,V0]; + if(V1==0) return [X1,V1]; + return []; + } + if(type(F)<4) F=f2df(F); + F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]); + L=[]; + if(type(F)<4){ + if(type(F)==3) F=nm(red(F)); + if((Deg=deg(F,V))<=2){ + if(Deg==2){ + D=(C1=coef(F,1,V))^2-4*(C2=coef(F,2,V))*coef(F,0,V); + if(D>=0){ + R=dsqrt(D); + if((S=(-C1+R)/(2*C2))>=LX1&&S<=LX2) L=[[S,mysubst(F,[V,S])]]; + if(D!=0 && (S=(-C1-R)/(2*C2))>=LX1&&S<=LX2) L=cons([S,mysubst(F,[V,S])],L); + } + L=qsort(L); + }else if(Deg==1&&(S=-coef(F,0,V)/coef(F,1,V))>=LX1&&S<=LX2) + L=[[S,mysubst(F,[V,S])]]; + return L; + } + for(L=[];S!=[];S=cdr(S)) + if(car(S)>=LX1&&car(S)<=LX2) L=cons([car(S),mysubst(F,[V,car(S)])],L); + return qsort(L); + } + if(type(Div=getopt(mesh))!=1 || Div<=0) + Div = 2^(10); + W=(LX2-LX1)/Div; + for(I=V2=0;I<=Div;I++){ + X1=X2;X2=LX1+I*W;V1=V2; + if((V2=myeval(mysubst(F,[V,X2])))==0) + L=cons([X2,V2],L); + if(V1*V2<0){ + L0=fzero(F,[V,X1,X2]|zero=1,trans=1); + if(L0!=[]) L=cons(L0,L); + } + } + return reverse(L); +} + +def fmmx(F,LX) +{ + if(length(LX)==3){ + V=LX[0];LX=cdr(LX); + }else V=x; + LX1=eval(LX[0]);LX2=eval(LX[1]); + FT=F; + if(getopt(trans)!=1 && type(F)<4) FT=f2df(FT); + FT=mysubst(FT,[[@pi,eval(@pi)],[@e,eval(@e)]]); + if(type(G=getopt(dif))>=1){ + if(G==1) G=os_md.mydiff(F,V); + L=fzero(G,[V,LX1,LX2]|option_list=getopt()); + R=[[LX1,myeval(mysubst(FT,[V,LX1]))]]; + for(I=0;L!=[];L=cdr(L),I++){ + X=car(L)[0]; + if(X==LX1) continue; + R=cons([X,myeval(mysubst(FT,[V,X]))],R); + } + if(X!=LX2) R=cons([LX2,myeval(mysubst(FT,[V,LX2]))],R); + if(getopt(mmx)!=1) return reverse(R); + for(Mi=Ma=car(R);R!=[];R=cdr(R)){ + if(car(R)[1]>Ma[1]) Ma=car(R); + else if(car(R)[1]Ma[1]) Ma=car(L); + else if(car(L)[1]1&&Pc<31)||Pc>-5) Lim+=Pc; + } + if(type(Pc=getopt(init))==1 && Pc>0) FS*=Pc; + if(type(L)==7) L=[L]; + else if(type(L)<2){ + K=flim(F,["+",L]|option_list=getopt()); + if(K=="") return K; + K1=flim(F,["-",L]|option_list=getopt()); + if(K1=="") return K1; + if(type(K)==7||type(K1)==7){ + if(K!=K1) return ""; + return K; + } + if(abs(K)<10^(-5)){ + if(abs(K1)<10^(-5)) return (K1+K)/2; + else return ""; + } + if(abs((K1-K)/K)<10^(-4)) return (K1+K)/2; + return ""; + } + if(type(L)!=4||type(L[0])!=7) return ""; + if(L[0]=="-"||L[0]=="-infty"){ + FS=-FS; + }else if(L[0]!="+"&&L[0]!="infty") return ""; + FI=(length(L)==1)?1:0; + for(Inf=0,I=Lim0;ID2){ + D=D1;D1=D2;D1=D; + X1=D1;X2=D2; + } + if(FI==0){ + D1+=L[1];D2+=L[1]; + } + K=fmmx(FD,[D1,D2]|mmx=1,mesh=16,dev=4); + if(I>Lim0){ + if(DF10^(-8)&&DF<10^7){ + if(I>Lim0+1){ + if(Inf==0) return ""; + }else Inf=1; + }else if(Inf==1) return ""; + } + DF=K[1][1]-K[0][1]; + } + if(Inf==1){ + if(K[0][1]>10^8) return "+"; + else if(K[1][1]<-10^8) return "-"; + return ""; + } + V=(myfeval(FD,D1)+1.0)-1.0; + if(V!=0 && abs(V)<10^(-9)) return 0; + return V; +} + +def fcont(F,LX) +{ + if(length(LX)==3){ + V=LX[0];LX=cdr(LX); + }else V=x; + LX1=eval(LX[0]);LX2=eval(LX[1]); + if(getopt(trans)!=1 && type(F)<4) FT=f2df(F); + if(type(Div=getopt(mesh))!=1 || Div<=0) + Div = 2^(10); + if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16; + W=(LX2-LX1)/Div; + if((Df=getopt(dif))!=1){ + Df=0; + }else{ + if(Dev==16) Dev=6; + WD=W/2^(Dev+1); + } + F=FT; + C=2; + for(I=V2=V3=0;I<=Div;I++){ + X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3; + V3=myeval(mysubst(F,[V,X3])); + if(Df){ + if(I==Div) break; + V3=(myeval(mysubst(F,[V,X3+WD]))-V3)/WD; + } + if(I==0) L=[[X3,V3]]; + if(I<2) continue; + if(C*dabs(2*V2-V1-V3) > dabs(V1-V3)){ + X01=X1;V01=V1;X02=X2;V02=V2;X03=X3;V03=V3; + for(J=0; X01!=X03; J++){ + if(dabs(V01-V02)>dabs(V02-V03)){ + X03=X02;V03=V02; + }else{ + X01=X02;V01=V02; + } + if(J==Dev) break; + X02=(X01+X02)/2; + V02=myeval(mysubst(F,[V,X02])); + if(Df) V02=(myeval(mysubst(F,[V,WD]))-V02)/WD; + if(C*dabs(2*V02-V01-V03) < dabs(V01-V03)) break; + } + if(J==Dev||X01==X03) L=cons([X01,X03,V03-V01],L); + } + } + return reverse(L); +} + +def xygraph(F,N,LT,LX,LY) +{ + if((Proc=getopt(proc))!=1&&Proc!=2&&Proc!=3) Proc=0; + if(type(DV=getopt(dviout))==4){ + OL=delopt(getopt(),["dviout","shift","ext","cl"]); + OL=cons(["proc",1],OL); + R=xygraph(F,N,LT,LX,LY|option_list=OL); + OL=delopt(getopt(),["shift","ext","cl"]|inv=1); + return execdraw(R,DV|optilon_list=OL); + } + 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); + F=mysubst(F,[TT,x]); + } + if(LX==0) LX=LT; + if((Acc=getopt(Acc))!=1) Acc=0; + if(Acc){ + LX=[eval(LX[0]),eval(LX[1])]; + LY=[eval(LY[0]),eval(LY[1])]; + LT=[eval(LT[0]),eval(LT[1])]; + }else{ + LX=[deval(LX[0]),deval(LX[1])]; + LY=[deval(LY[0]),deval(LY[1])]; + LT=[deval(LT[0]),deval(LT[1])]; + } + 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(Org=getopt(org))==4){ + Orgx=Org[0];Orgy=Org[1]; + }else Orgx=Orgy=0; + if(type(F)!=4 || (getopt(para)!=1 && length(F)>1 && type(F[0])<4 && type(F[1])==4)) { + if(getopt(rev)!=1){ + F1=x; /* LX[0]+(LX[1]-LX[0])*(x-LT[0])/(TD*N); */ + F2=F; + }else{ + F1=F; + F2=x; /* LY[0]+(LY[1]-LY[0])*(x-LT[0])/(TD*N); */ + } + }else{ + F1=F[0]; F2=F[1]; + } + if(F1==0 || F2==0) LT=[]; + if(length(LT)==2){ + if(Acc){ + for(LTT=[],I=N2;I>=N1;I--) + LTT=cons(eval(LT[0]+I*(LT[1]-LT[0])/N),LTT); + }else{ + for(LTT=[],I=N2;I>=N1;I--) + LTT=cons(deval(LT[0]+I*(LT[1]-LT[0])/N),LTT); + } + LT=LTT; + } + Cpx=getopt(cpx); + if(Cpx!=1 && (str_str(rtostr(F1),"@i")>=0 || str_str(rtostr(F2),"@i")>=0)) + Cpx=1; + if(type(Cpx)<0) Cpx=0; + if(!Acc){ + if(type(F1)<4) F1=f2df(F1); + if(type(F2)<4) F2=f2df(F2); + } + if(type(Err=getopt(err))==1){ + F1=mysubst(F1,[x,x+Err*TD/1001.23]); + F2=mysubst(F2,[x,x+Err*TD/1001.23]); + } + if(type(F1)==4 || type(F2)==4){ + Dn=1; + }else Dn=dn(F1)*dn(F2); + for(V=[],PT=LT;PT!=[]; PT=cdr(PT)){ + T=car(PT); + if(myfeval(Dn,T)==0){ + V=cons(0,V); continue; + } + if(Cpx>0||Acc){ + X=myfeval(F1,T);Y=myfeval(F2,T); + }else{ + X=myfdeval(F1,T);Y=myfdeval(F2,T); + } + if((N1==0||(PT!=LT&&length(PT)!=1)) && (XLX[1]||YLY[1])) + V=cons(0,V); + else + V=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],V); + } + V=reverse(V); + Gap0=Gap=Arg=0; + if(type(Prec=getopt(prec))<0) + Level=0; + else if(Prec==0) Level=4; + else if(type(Prec)==1){ + Level=Prec; + if(Level<0){ + Level=-Level; + Gap0=1; + } + }else if(type(Prec)==4){ + Level=Prec[0]; + if(length(Prec)>1) Arg=Prec[1]; + if(length(Prec)>2) Gap0=Prec[2]; + } + if(Level>0){ + if(Level>16) Level=16; + if(Arg<=0) Arg=30; + else if(Arg>120) Arg=120; + Arg=Acc?eval(@pi*Arg/180):deval(@pi*Arg/180); + SL=dcos(Arg); + } + if(Gap0>0){ + if(Gap0<2) Gap0=16; + else if(Gap0>512) Gap0=512; + Gap=((MulX*(LX[1]-LX[0]))^2+(MulY*(LY[1]-LY[0]))^2)/(Gap0^2); + } + for(I=0;I1){ + if((CV1=car(cdr(PV)))!=0 && CV!=0) + D1=[CV[0]-CV1[0],CV[1]-CV1[1]]; + else D1=0; + }else K=-1; /* ? */ + if(K>0 &&(((D1==0||D0==0)&&(CV0!=0||CV!=0||CV1!=0)) || dvangle(D0,D1)0 && type(D0)==4 && (TG=(D0[0]^2+D0[1]^2-Gap)>0)))){ + G++;T1=(CLT0+CLT)/2; + if(F==0 && (CV0!=0 || CV!=0)){ + if(myfdeval(Dn,T1)==0){ + NV=cons(0,NV); NLT=cons(T1,NLT); + } + if(Cpx>0||Acc){ + X=myfeval(F1,T1);Y=myfeval(F2,T1); + }else{ + X=myfdeval(F1,T1);Y=myfdeval(F2,T1); + } + if(K==1 && N1<0){ + NV=[];NLT=[]; + } + if((K>1||N1==0)&&(XLX[1]||YLY[1])){ + NV=cons(0,NV);NLT=cons(T1,NLT);F=0; + }else{ + NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T1,NLT); + } + } + NV=cons(CV,NV);NLT=cons(CLT,NLT); + if(!TG&&(CV0!=0||CV1!=0)){ + T2=(car(cdr(PLT))+CLT)/2; + if(myfdeval(Dn,T2)==0){ + NV=cons(0,NV); NLT=cons(CLT,NLT); + } + if(Cpx>0||Acc){ + X=myfeval(F1,T2);Y=myfeval(F2,T2); + }else{ + X=myfdeval(F1,T2);Y=myfdeval(F2,T2); + } + if((N1==0||length(PV)!=2)&&(XLX[1]||YLY[1])){ + NV=cons(0,NV);NLT=cons(T1,NLT); + }else{ + NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T2,NLT); + } + } + if(length(PV)==2 && N1==-1) break; + F=1; + }else{ + F=0;NV=cons(CV,NV);NLT=cons(CLT,NLT); + } + } + V=reverse(NV);LT=reverse(NLT); + if(G==0) break; + } + if(Gap>0){ + for(NV=[],PV=V;PV!=[];PV=cdr(PV)){ + NV=cons(P0=car(PV),NV); + if(length(PV)>1 && P0!=0 && PV[1]!=0 + && (P0[0]-PV[1][0])^2+(P0[1]-PV[1][1])^2>Gap) NV=cons(0,NV); + } + V=reverse(NV); + } + if((Raw=getopt(raw))==1) return V; + if(Raw==2) return [V,LT]; + OL=[["curve",1]];OLP=[]; + if(type(C=getopt(ratio))==1){ + OL=cons(["ratio",C],OL);OLP=cons(["ratio",C],OLP); + } + if(Acc==1) OL=cons(["Acc",1],OL); + if(N1<0) OL=cons(["close",-1],OL); + if(type(Opt=getopt(opt))!=7 && type(Opt)!=4){ + if(Opt==0) return xylines(V|option_list=cons(["opt",0],OL)); + } + OL=cons(["opt",(Proc)?0:Opt],OL); + if(type(Opt)>=0) OLP=cons(["opt",Opt],OLP); + if(type(Vb=getopt(verb))==1||type(Vb)==4){ + OL=cons(["verb",Vb],OL);OLP=cons(["verb",Vb],OL); + } + if(Proc){ + S=(Proc==1)? + [[0,[MulX*(LX[0]-Orgx),MulX*(LX[1]-Orgx)],[MulY*(LY[0]-Orgy),MulY*(LY[1]-Orgy)], + (TikZ)?1:1/10]]:[]; + S=cons([1,OLP,xylines(V|option_list=OL)],S); + if(Proc==3) return car(S); + }else S=xylines(V|option_list=OL); + if(type(Pt=getopt(pt))==4){ + if(type(Pt[0])!=4) Pt=[Pt]; + if(length(Pt)>1 && type(Pt[1])!=4) Pt=[Pt]; + for(PT=Pt;PT!=[];PT=cdr(PT)){ + PP=car(PT); + if(type(PP[0])!=4) PP=[PP]; + P=car(PP);PP=cdr(PP); + Qx=MulX*(P[0]-Orgx);Qy=MulY*(P[1]-Orgy); + if(length(PP)>0 && type(PP[0])==4){ /* draw line */ + P=car(PP); + Q1x=MulX*(P[0]-Orgx);Q1y=MulY*(P[1]-Orgy); + if(length(PP)<1 || car(PP)==0 || iand(car(PP),1)) + OL=["opt",(TikZ)?"-":"@{-}"]; + else OL=["opt",(TikZ)?".":"@{.}"]; + if(Proc) S=cons([1,OL,[[Qx,Qy],[Q1x,Q1y]]],S); + else S=S+xylines([[Qx,Qy],[Q1x,Q1y]]|optilon_list=OL); + continue; + } + if(length(PP)==0 || type(car(PP))!=7) SS="$\\bullet$"; + else SS=car(PP); + if(length(PP)<=1){ + if(Proc) S=cons([2,[],[Qx,Qy],[SS]],S); + else S=S+xyput([Qx,Qy,SS]); + }else{ + if(Proc) S=cons([2,[],[Qx,Qy],[[SS],"",PP[1]]],S); + S=S+xyput([Qx,Qy,SS,"",PP[1]]); + } + } + } + if(type(Ax=getopt(ax))==4){ /* draw axis */ + Adx0=Ady0=0; Adx1=Ady1=0.1; + if(!TikZ){ + if(!XYcm) Adx1=Ady1=1; + LOp="@{-}"; LxOp="+!U"; LyOp="+!R"; + }else{ + LOp="-"; LxOp="below"; LyOp="left"; + } + LOp0=LOp1=LOp; + LxOO=(Ax[1]==LY[0])?LxOp:(TikZ)?"below left":"+!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)>1){ + if(type(T)==7){ + LxOp=T; LyOp=AxOp[1]; + }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) LOp0=AxOp[3]; + if(length(AxOp)>4 && type(AxOp[4])==7) LOp1=AxOp[4]; + } + if(type(AxOp)==7) LOp0=AxOp; + } + if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */ + if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp0]]:[], + [MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],[MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]],S); + else S=S+xyarrow([MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)], + [MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]|opt=LOp0); + 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]==0) DD=cons([I*D,I*D+Ax[0]],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; + } + if(type(D)==4){ + for(;D!=[]; D=cdr(D)){ + T=car(D); + if(type(T)==4) T=car(T); + X=MulX*(T+Ax[0]-Orgx); Y=MulY*(Ax[1]-Orgy); + if(T!=0){ + if(Proc) S=cons([3,(type(LOp1)>=0)?[["opt",LOp1]]:[],[X,Y+Ady0],[X,Y+Ady1]],S); + else S=S+xyarrow([X,Y+Ady0],[X,Y+Ady1]|opt=LOp1); + } + if(type(car(D))==4){ + Arg=[(T==0)?LxOO:LxOp,D[0][1]]; + if(Proc) S=cons([2,[],[X,Y+Ady0],[Arg]],S); + else S=S+xyput([X,Y+Ady0,Arg]); + } + } + } + } + } + if(Ax[1]>=LY[0] && Ax[1]<=LY[1]){ /* draw marks on y-axis */ + if(Proc) S=cons([3,[["opt",LOp0]], + [MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)], + [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]],S); + else S=S+xyarrow([MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)], + [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]|opt=LOp0); + 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){ + if(Ax[4]==0) DD=cons([I*D,I*D+Ax[1]],DD); + if(Ax[4]==1) DD=cons([I*D,I*D],DD); + if(Ax[4]==2) DD=cons([I*D,I],DD); + } + } + D=DD; + } + if(type(D)==4){ + for(;type(D)==4&&D!=[]; D=cdr(D)){ + T=car(D); + if(type(T)==4) T=car(T); + X=MulX*(Ax[0]-Orgx); Y=MulY*(T+Ax[1]-Orgy); + if(T!=0){ + if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp1]]:[], + [X+Adx0,Y],[X+Adx1,Y]],S); + else S=S+xyarrow([X+Adx0,Y],[X+Adx1,Y]|opt=LOp1); + } + if(type(car(D))==4){ + if(Proc) S=cons([2,[],[X,Y+Ady0],[[LyOp,D[0][1]]]],S); + else S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]); + } + } + } + } + } + } + if(Proc) return reverse(S); + if(getopt(dviout)!=1) return S; + xyproc(S|dviout=1); +} + +def xyarrow(P,Q) +{ + Cmd = ["fill","filldaw","shade","shadedraw","clip ","pattern","path ","node","coordinate"]; + if(type(P)<4) return "%\n"; + SS=getopt(opt); + if(!TikZ){ + if(type(Q)<4) return ""; + S="{"+xypos(P)+" \\ar"; + if(type(SS)==7) S=S+SS; + return S+" "+xypos(Q)+"};\n"; + } + if(type(SS)==4 && length(SS)>1){ + if(length(SS)>2) SU=SS[2]; + ST=SS[1]; + SS=SS[0]; + } + if(type(SS)!=7) SS="->"; + if(type(ST)!=7) ST=" -- "; + if(type(SU)!=7) SU=""; + if(type(S=getopt(cmd))==7) S="\\"+S; + else S="\\draw"; + if(type(Q)!=4){ + if(Q>0 && Q<=length(Cmd)) S="\\"+Cmd[Q-1]+""; + if(SS!="-") S=S+"["+SS+"]"; + if(SU!="") SU="["+SU+"]"; + return S+xypos(P)+ST+SU+";\n"; + } + if(SS!="-"&&SS!="") S=S+"["+SS+"]"; + if(length(P)<3 && length(Q)<3) + return S+xypos(P)+ST+xypos(Q)+SU+";\n"; + if(length(P)==2) P=[P[0],P[1],"","_0"]; + else if(length(P)==3 || (length(P)==4 && P[3]=="")) + P=[P[0],P[1],P[2],"_0"]; + else if(P[3]=="") + P=[P[0],P[1],P[2],"_0",P[4]]; + if(length(Q)==2) Q=[Q[0],Q[1],"","_1"]; + else if(length(Q)==3 || (length(Q)==4 && Q[3]=="")) + Q=[Q[0],Q[1],Q[2],"_1"]; + else if(Q[3]=="") + Q=[Q[0],Q[1],Q[2],"_1",Q[4]]; + return S+xypos(P)+" "+xypos(Q)+"("+P[3]+")"+ST+"("+Q[3]+")"+SU+";\n"; +} + +def xyarrows(P,Q,R) +{ + PQ=newvect(4); + PQ[0]=(type(P[0])!=4)?f2df(P[0]):P[0]; + PQ[1]=(type(P[1])!=4)?f2df(P[1]):P[1]; + PQ[2]=(type(Q[0])!=4)?f2df(Q[0]):Q[0]; + PQ[3]=(type(Q[1])!=4)?f2df(Q[1]):Q[1]; + if(type(R[0])!=4) R=[R]; + TR=R[0];NX=TR[2];X=X0=TR[0];DX=(TR[1]-TR[0])/NX; + if(length(R)==2){ + TR=R[1];NY=TR[2];Y=TR[0];DY=(TR[1]-TR[0])/NY; + }else{ + NY=1;Y=DY=0; + } + if(type(L=getopt(abs))!=1) L=0; + if(type(Sc=getopt(scale))!=1) Sc=0; + OL=[]; + if(type(Opt=getopt(opt))==7) OL=cons(["opt",Opt],OL); + Tb=str_tb(0,0); + for(J=0;J0){ + C=dnorm([VX,VY]); + if(C!=0){ + VX*=L/C;VY*=L/C; + } + } + if(Sc){ + VX*=Sc;VY*=Sc; + } + if(VX||VY) str_tb(xyarrow([PX,PY],[PX+VX,PY+VY]|optilon_list=OL),Tb); + } + } + return str_tb(0,Tb); +} + +def polroots(L,V) +{ + INIT=1; + if(type(CF=getopt(comp))!=1) CF=0; + OL=getopt(); + if(CF>32){ + CF-=64; + INIT=0; + }else OL=cons(["comp",CF+64],delopt(OL,"comp")); + if(type(V)==4&&length(V)==1){ + L=L[0];V=V[0]; + } + Lim=Lim2=[]; + if(type(L)<4){ + if(type(Lim=getopt(lim))==4){ + if(type(Lim[0])!=4){ + if(!isvar(Lim[0])) Lim=cons(V,[Lim]); + Lim=[Lim]; + } + if(!isvar(Lim[0][0])) Lim=[cons(V,Lim)]; + Lim=delopt(Lim,V|inv=1); + if(Lim!=[]){ + Lim=Lim[0]; + if(length(Lim)==3) Lim2=Lim[2]; + Lim=Lim[1]; + } + }else{ + Lim=Lim2=[]; + } + if((CF==-2||CF==-1||CF==2)&&iscoef(L,os_md.israt)){ /* Rat+Comp, Rat+Real or Rat */ + S=(CF==-1)?getroot(L,V|cpx=1):getroot(L,V); + for(RR=[],F=x;S!=[];S=cdr(S)){ + if(findin(V,vars(C=car(S)))<0){ /* Rational solution */ + if(type(C)<2){ + if(Lim!=[]&&(real(C)Lim[1])) continue; + if(Lim2!=[]&&(imag(C)Lim2[1])) continue; + } + if(F!=C) RR=cons(F=C,RR); + }else if(CF<0){ /* Irrational solution */ + if((R=pari(roots,mysubst(C,[V,x])))!=0){ + for(R=vtol(R);R!=[];R=cdr(R)) + if((C=car(R))!=F && ntype(C)Lim[1])) continue; + if(Lim2!=[]&&(imag(C)Lim2[1])) continue; + RR=cons(F=C,RR); + } + } + } + } + return qsort(RR); + } + R=pari(roots,subst(L,V,x)); + if(R==0){ + R=[0]; + if(CF==1){ + for(R=[0],I=mydeg(L,V);I>1; I--) + R=cons(0,R); + } + return R; + } + if(CF==1){ /* Complex */ + if(Lim==[]&&Lim2==[]) return vtol(R); + for(L=[],I=length(R)-1;I>=0;I--){ + C=R[I]; + if(Lim!=[]&&(real(C)Lim[1])) continue; + if(Lim2!=[]&&(imag(C)Lim2[1])) continue; + L=cons(C,L); + } + return L; + } + for(L=[],F=x,I=length(R)-1;I>=0;I--){ /* Real */ + if(ntype(R[I])<4 && F!=R[I]){ + if(Lim!=[] && (R[I]Lim[1])) continue; + L=cons(F=R[I],L); + } + } + return qsort(L); + } + if(SS==0&&INIT==1){ + SS=polroots(L,V|option_list=OL); + if(SS!=0) return SS; + for(C=0;SS==0&&C<5;C++){ + I=(C==0)?1:(iand(random(),0xff)-0x80); + for(LL=[],K=length(L)-1;K>=0;K--){ + for(Q=0,J=length(L)-1;J>=0;J--) + Q+=L[J]*(I+K)^J; + LL=cons(Q,LL); + } + SS=polroots(LL,V|option_list=OL); + if(SS!=0) return SS; + } + return SS; + } + C=2^(-32); + if(type(getopt(err))==1) C=err; + if((N=length(V))!=length(L)) return []; + if(N==1) return polroots(L[0],V[0]|option_list=OL); + for(L1=[],I=1;IC) break; + } + if(LT==[]) SS=cons(S0,SS); + } + } + return reverse(SS); +} + +def ptcommon(X,Y) +{ + if(length(X)!=2 || length(Y)!=2) return 0; + if(type(X[1])==4){ /* X is a line */ + if((In=getopt(in))==-1||In==-2||In==-3){ + X0=(X[0][0]+X[1][0])/2;X1=(X[0][1]+X[1][1])/2; + X=[[X0,X1],[X0+X[1][1]-X[0][1],X1-X[1][0]+X[0][0]]]; + if(In==-1&&type(Y[1])==4) return ptcommon(Y,X|in=-2); + /* for the second line */ + if(In==-3) In=1; + else In=0; + }else if(In==2||In==3){ + X=(X[1][0]-X[0][0])+(X[1][1]-X[0][1])*@i; + if(X==0) return 0; + Y=(Y[1][0]-Y[0][0])+(Y[1][1]-Y[0][1])*@i; + X=myarg(Y/X); + return (In==2)?X:(X*180/deval(@pi)); + }else if(In!=1) In=0; + if(type(Y[0])<=3){ + if(In==1){ + return [(Y[1]*X[0][0]+Y[0]*X[1][0])/(Y[0]+Y[1]), + (Y[1]*X[0][1]+Y[0]*X[1][1])/(Y[0]+Y[1])]; + } + XX=X[1][0]-X[0][0];YY=X[1][1]-X[0][1]; + Arg=(length(Y)<2)?0:Y[1]; + Arg=deval(Arg); + if(Arg!=0){ + S=dcos(Arg)*XX-dsin(Arg)*YY; + YY=dsin(Arg)*XX+dcos(Arg)*YY; + XX=S; + } + S=dnorm([XX,YY]); + if(S!=0){ + XX*=Y[0]/S;YY*=Y[0]/S; + } + return [X[1][0]+XX,X[1][1]+YY]; + } + S=[X[0][0]+(X[1][0]-X[0][0])*x_,X[0][1]+(X[1][1]-X[0][1])*x_]; + if(type(Y[1])==4){ /* Y is a line */ + T=[Y[0][0]+(Y[1][0]-Y[0][0])*y_-S[0], + Y[0][1]+(Y[1][1]-Y[0][1])*y_-S[1]]; + R=lsol(T,[x_,y_]); + if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){ + if(!In || (R[0][1]>=0&&R[0][1]<=1&&R[1][1]>=0&&R[1][1]<=1) ) + return subst(S,x_,R[0][1],y_,R[1][1]); + } + if((type(R[0])>0&&type(R[0])<4)||(type(R[1])>0&&type(R[1])<4)) return 0; + if(!In) return 1; + I=(X[0][0]==X[1][0]&&Y[0][0]==Y[1][0]&&X[0][0]==Y[0][0])?1:0; + if(X[0][I]<=X[1][I]){ + X0=X[0][I];X1=X[1][I]; + }else{ + X1=X[0][I];X0=X[1][I]; + } + return ((Y[0][I]X1&&Y[1][I]>X1))?0:1; + }else if(Y[1]==0){ /* orth */ + T=[Y[0][0]+(X[1][1]-X[0][1])*y_-S[0], + Y[0][1]-(X[1][0]-X[0][0])*y_-S[1]]; + R=lsol(T,[x_,y_]); + if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){ + if(!In||(R[0][1]>=0&&R[0][1]<=1)) + return subst(S,x_,R[0][1],y_,R[1][1]); + } + return (X[0]==X[1])?0:1; + }else if(type(Y[1])==1 && Y[1]>0){ /* circle */ + T=(S[0]-Y[0][0])^2+(S[1]-Y[0][1])^2-Y[1]^2; + D=mycoef(T,1,x_)^2-4*mycoef(T,0,x_)*mycoef(T,2,x_); + if(D==0){ + V=mycoef(T,1,x_)/(2*mycoef(T,2,x_)); + if(!in||(V>=0&&V<=1)) return [subst(S,x_,V)]; + } + else if((type(D)==1&&D>0)){ + D=dsqrt(D); + V=-(mycoef(T,1,x_)+D)/(2*mycoef(T,2,x_)); + if(!In||(V>=0&&V<=1)) L=[subst(S,x_,V)]; + else L=[]; + V=(D-mycoef(T,1,x_))/(2*mycoef(T,2,x_)); + if(!In||(V>=0&&V<=1)) L=cons(subst(S,x_,V),L); + if(length(L)>0) return L; + } + } + return 0; + } + if(type(Y[1])==4 || X[1]==0) return ptcommon(Y,X); + /* X is a circle */ + if(Y[1]==0){ /* tangent line */ + if(Y[0][0]==X[0][0]+X[1] || Y[0][0]==X[0][0]-X[1]) L=[[Y[0][0],X[0][1]]]; + else L=[]; + P=(Y[0][0]+x_-X[0][0])^2+(Y[0][1]+x_*y_-X[0][1])^2-X[1]^2; + Q=mycoef(P,1,x_)^2-4*mycoef(P,2,x_)*mycoef(P,0,x_); + for(R=polroots(Q,y_);R!=[];R=cdr(R)){ + X0=-subst(mycoef(P,1,x_)/(2*mycoef(P,2,x_)),y_,car(R)); + L=cons([Y[0][0]+X0,Y[0][1]+car(R)*X0],L); + } + }else{ /* Y is a circle */ + P=(x_-X[0][0])^2+(y_-X[0][1])^2-X[1]^2; + Q=(x_-Y[0][0])^2+(y_-Y[0][1])^2-Y[1]^2; + V=(X[0][0]!=Y[0][0])?[x_,y_]:[y_,x_]; + R=subst(P,V[0],T=lsol(P-Q,V[0])); + if(type(T[0])<4) return (T[0]==0)?1:0; + S=polroots(R,V[1]); + for(L=[];S!=[];S=cdr(S)){ + R=subst(T,V[1],car(S)); + if(V[0]==x_) L=cons([R,car(S)],L); + else L=cons([S,R],L); + } + } + if(length(L)!=0) return L; + return 0; +} + +def tobezier(L) +{ + if((Div=getopt(div))==1||Div==2){ + if(length(L)!=4) return [tobezier(L|inv=[0,1/2]),tobezier(L|inv=[1/2,1])]; + if(type(L)==4) L=ltov(L); + if(type(L[0])==4) + L=[ltov(L[0]),ltov(L[1]),ltov(L[2]),ltov(L[3])]; + S=[(L[0]+3*L[1]+3*L[2]+L[3])/8]; + T=[L[3]]; + S=cons((L[0]+2*L[1]+L[2])/4,S); + T=cons((L[2]+L[3])/2,T); + S=cons((L[0]+L[1])/2,S); + T=cons((L[1]+2*L[2]+L[3])/4,T); + S=cons(L[0],S); + T=cons((L[0]+3*L[1]+3*L[2]+L[3])/8,T); + return [S,T]; + } + if(Div>2&&Div<257){ + L=tobezier(L); + for(R=[],I=Div-1;I>=0;I--) + R=cons(tobezier(L|inv=[I/Div,(I+1)/Div]),R); + return R; + } + if((V=getopt(inv))==1 || type(V)>3){ + if(type(L[0])>3 && type(V)>3) L=tobezier(L); + if(type(V)>3 && length(V)>2) V2=V[2]; + if(type(V2)!=2) V2=t; + if(type(V)>3) L=subst(L,V2,(V[1]-V[0])*V2+V[0]); + N=mydeg(L,V2); + for(R=[],I=0;I<=N;I++){ + RT=mycoef(L,I,V2); + R=cons(RT/binom(N,I),R); + L-=RT*V2^I*(1-V2)^(N-I); + } + return reverse(R); + }; + N=length(L)-1; + V=newvect(2); + for(I=0;I<=N;I++,L=cdr(L)){ + if(type(X=car(L))==4) X=ltov(X); + V+=X*binom(N,I)*t^I*(1-t)^(N-I); + } + return V; +} + +def cutf(F,X,VV) +{ + if(type(car(V=VV))==2){ + Y=[car(V),X]; + V=cdr(V); + }else Y=X; + if(type(X)>1){ + Y=(type(Y)==4)?Y[0]:x; + V1=makenewv(F); + if(X==Y||Y==x){ + V2=makenewv([F,V1]); + F=mysubst(F,[Y,V2]); + V=cons(V2,V); + } + return [V1,[V1,os_md.cutf,[F],X,[V]]]; + } + if(car(V)!=[] && Xcar(V)[0]) continue; + if(X==car(V)[0]) return car(V)[1]; + return myfeval(F,Y); + } +} + +def fsum(F,L) +{ + if(getopt(df)==1){ + F=f2df(F); + }else Sub=getopt(subst); + if(type(L[0])==2){ + X=L[0]; + L=cdr(L); + }else X=0; + V=(length(L)>2)?L[2]:1; + for(R=0,I=L[0];;I+=V){ + if(V==0||(I-L[1])*V>0) return R; + R+=(Sub==1)?subst(F,X?X:x,I):os_md.myfeval(F,X?[X,I]:I); + } +} + +def periodicf(F,L,X) +{ + if(type(L)==4) L=[eval(L[0]),eval(L[1])]; + else L=eval(L); + if(isvar(X)){ + Y=makenewv([X,F]); + Z=makenewv([X,Y,F]); + return [Z,[Z,os_md.periodicf,[mysubst(F,[x,Y])],(type(L)==4)?[L]:L,[[Y,X]]]]; + } + if(type(X)==4){ + V=X[0]; + X=X[1]; + }else V=x; + if(type(F)==5){ + X=eval(X); + return myfeval(F[floor(X/L)%length(F)],[V,X-floor(X/L)*L]); + } + if(type(L)==4){ + X-=floor((X-L[0])/(L[1]-L[0]))*(L[1]-L[0]); + return myfeval(F,[V,X]); + } +} + +def cmpf(X) +{ + if(type(X)>3){ + if(type(L)==7) return [S_Fc,Dx,S_Ic,S_Ec,S_EC,S_Lc]; + S_Lc=0; + if(type(S_Fc=X[0])!=4) S_Fc=f2df(S_Fc); + S_Ic=X[1]; + if(length(S_Ic)>2){ + S_Fc=mysubst(S_Fc,[S_Ic[0],x]); + S_Ic=cdr(S_Ic); + } + S_Dc=(type(S_Ic[0])==7)?1:0; + if(type(S_Ic[1])==7) S_Dc=ior(S_Dc,2); + if(type(S_Ec=getopt(exp))!=1) S_Ec=0; + if(S_Ec<=0){ + S_EC=-S_Ec; + if(S_EC==0) S_EC=1; + if(S_Dc==3) S_EC*=2; + else S_EC/=4; + if(type(F=X[0])==3&&vars(F)==[x]&&(D=deg(nm(F),x))==deg(dn(F),x)-2){ + S_Lc=S_EC*coef(nm(F),D,x)/coef(dn(F),D+2,x); + } + }else{ + S_EC=S_Ec; + if(S_Dc==3) S_EC*=12; + else S_EC/=6; + } + if(type(S_Fc)==3) S_Fc=red(S_Fc); + S_EC=1/S_EC; + return [z_,[z_,os_md.cmpf,x]]; + } + if(X<=0 && iand(S_Dc,1)) return S_Lc; + if(X>=1 && iand(S_Dc,2)) return S_Lc; + if(S_Dc==3){ + if(S_Ec>0){ + Y0=dexp(1/X)*S_EC; + Y1=dexp(1/(1-X))*S_EC; + return myfeval(S_Fc,Y1-Y0)*(Y0/X^2+Y1/(1-X)^2); + } + return myfeval(S_Fc,S_EC/(1-X)-S_EC/X)*(S_EC/(1-X)^2+S_EC/X^2); + } + if(S_Dc==1){ + if(S_Ec>0){ + Y=dexp(1-1/X); + R=myfeval(S_Fc,S_EC*(Y-1)+I[1])*Y; + } + else R=myfeval(S_Fc,I[1]+(1-1/X)*S_EC); + return R*S_EC/X^2; + } + if(S_Dc==2){ + if(S_Ec>0){ + Y=dexp(X/(1-X)); + R=myfeval(S_Fc,S_EC*(Y-1)+S_Ic[0])*Y; + }else R=myfeval(S_Fc,S_EC*X/(1-X)+S_Ic[0]); + return R*S_EC/(1-X)^2; + } + X=S_Ic[0]+(S_Ic[1]-S_Ic[0])*X; + return myfeval(S_Fc,X)/(S_Ic[1]-Ic[0]); +} + +def fresidue(P,Q) +{ + if(iscoef(Q,os_md.israt)) S=fctr(Q); + else S=[[Q,1]]; + for(R=[];S!=[];S=cdr(S)){ + T=car(S); + if((D=mydeg(T[0],z))==0) continue; + L=[]; + if(iscoef(T[0],os_md.iscrat)) L=getroot(T[0],z|cpx=2); + if(findin(z,vars(L))>=0) L=[]; + if(L==[]) L=polroots(T[0],z|comp=-1); + for(;L!=[];L=cdr(L)){ + QQ=Q; + for(I=T[1]; I>1;I--) QQ=mydiff(QQ,z); + for(U=0,W=I=T[1];I>0;I--,W++){ + QQ=diff(QQ,z); + U+=subst(QQ,z,L[0])*(z-L[0])^(W-T[1])/fac(W); + } + UD=mydiff(U,z); + for(I=T[1],K=1,PP=P; I>1;I--,K++) + PP=diff(PP,z)*U-K*PP*UD; + QQ=subst(PP,z,L[0])/subst(U,z,L[0])^K; +/* if(D==2) QQ=sqrt2rat(QQ); */ + R=cons([L[0],sqrt2rat(QQ)],R); + } + } + if(type(L=getopt(cond))==4){ + for(S=[];R!=[];R=cdr(R)){ + Z=car(R); + for(LL=L;LL!=[];LL=cdr(LL)){ + X=real(car(Z));Y=imag(car(Z)); + if(myf3eval(car(LL),X,Y,car(Z))<=0) break; + } + if(LL==[]) S=cons(Z,S); + } + R=reverse(S); + } + if((Sum=getopt(sum))==1||Sum==2){ + for(S=0;R!=[];R=cdr(R)) S+=car(R)[1]; + if(Sum==2) S*=2*@pi*@i; + return sqrt2rat(S); + } + return R; +} + +def fint(F,D,V) +{ + if(((L=length(V))==2 || (L==3&&isvar(V[0])<3)) + && (type(V[L-1])==7||(type(V[L-1])<3&&type(eval(V[L-1]))<2))) + /* real integral */ + return areabezier([F,D,V]|option_list=getopt()); + /* complex integral */ + if(L>1&&type(V[1])==4&&type(V[1][1])<4){ + if(type(V[0])==4&&type(V[0][0])<2){ + for(R=[],VT=car(V),VV=cdr(V);VV!=[];VV=cdr(VV),VT=VU){ + if((VU=car(VV))==-1) VU=car(V); + R=cons([ptcommon([VT,VU],[t,1-t]|in=1),[0,1]],R); + } + V=reverse(R); + } + else if(L==2) V=[V]; + } + Opt=cons(["cpx",1],getopt()); + for(R=0;V!=[];V=cdr(V)){ + VT=car(V); + X=car(VT)[0];XD=red(diff(X,t)); + Y=car(VT)[1];YD=red(diff(Y,t)); + F=mysubst(F,[[x,X],[y,Y],[z,X+@i*Y]]); + if(type(F)==4) + FF=cons(F[0]*(XD+@i*YD),cdr(F)); + else FF=red(F*(XD+@i*YD)); + R+=areabezier([FF,D,cons(t,VT[1])]|option_list=Opt); + } + return R; +} + +def areabezier(V) +{ + if(getopt(cpx)==1){ + Opt=delopt(getopt(),"cpx"); + F=V[0]; + if(!isvar(Var=V[2][0])) Var=x; + if(type(F)==3 && vars(F)==[Var] && imag(dn(F))!=0){ + F=(nm(F)*conj(dn(F)))/(dn(F)*conj(dn(F))); + V0=red(real(nm(F))/dn(F)); + R=areabezier([V0,V[1],V[2]]|option_list=Opt); + V0=red(imag(nm(F))/dn(F)); + return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt); + } + if(getopt(Acc)!=1) F=f2df(F); + V0=compdf([o,[o,real,o_]],o_,F); + R=areabezier([V0,V[1],V[2]]|option_list=Opt); + V0=compdf([o,[o,imag,o_]],o_,F); + return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt); + } + if(type(V[0])!=4 || vars(V[0][0])!=0){ + Mx=[-2.0^(512),2.0^(512)]; + I=length(V[2]); + if(type(V[2][I-1])==7||type(V[2][I-2])==7){ /* infinite interval */ + if(type(Ec=getopt(exp))==1) R=cmpf([V[0],V[2]]|exp=Ec); + else R=cmpf([V[0],V[2]]); + V=[R,V[1],[0,1]]; + } + if(type((Int=getopt(int)))==1 && type(V[0])<4 && (V1=V[1])>=0){ + if(Int==2&&iand(V1,1)) V1++; + if(!V1) V1=32; + Opt=cons(["raw",1],getopt()); + W=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt); + SS=W[0][1]; + for(S0=S1=0,I=0,L=W;L!=[] && I<=V1;I++, L=cdr(L)){ + if(iand(I,1)) S1+=car(L)[1]; + else S0+=car(L)[1]; + if (I==V1) SS+=car(L)[1]; + } + VV=deval(V[2][1]-V[2][0]); + if(Int==2) + return (2*S0+4*S1-SS)*VV/(3*V1); + else + return (2*S0+2*S1-SS)*VV/(2*V1); + } + Opt=cons(["opt",0],getopt()); + V=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt); + } + if(type(V[0][0])!=4) V=os_md.lbezier(V); + for(S=0; V!=[]; V=cdr(V)){ + B=tobezier(car(V)); + P=intpoly(B[1]*diff(B[0],t),t); + S+=mysubst(P,[t,1]); + } + return S; +} + +def velbezier(V,L) +{ + if(L==0) L=[t,0,1]; + else L=[(length(L)==3)?L[2]:t,L[0],L[1]]; + for(R=[],II=length(V)-1;II>=0;II--){ + S=fmmx(diff(V[II],L[0]|dif=1),L|dif=1); + for(U=0;S!=[];S=cdr(S)) if((T=abs(car(S)[1]))>U) U=T; + R=cons(U,R); + } + return R; +} + +def ptbezier(V,L) +{ + if(type(V[0])==4&&type(V[0][0])!=4) V=lbezier(V); + K=length(V); + if(type(L)<2){ + if(L<0) return K; + if(L>=K-1) L=[K-1,1]; + else{ + L0=floor(L); + if(L0>=K-1) L0=K-1; + L=[L0,L-L0]; + } + } + if(L[0]>=0) B=V[L[0]]; + else B=V[K+L[0]]; + B=tobezier(B); + BB=[diff(B[0],t),diff(B[1],t)]; + return [subst(B,t,L[1]),subst(BB,t,L[1])]; +} + +def ptcombezier(P,Q,T) +{ + if(type(T)<2){ + if(T<2) T=20; /* default */ + return ptcombezier(P,Q,[0,0,1,T]); + } + V=T[2]/2;; + PB=tobezier(P|div=1); + PP=[ptbbox(PB[0]),ptbbox(PB[1])]; + QB=tobezier(Q|div=1); + QQ=[ptbbox(QB[0]),ptbbox(QB[1])]; + for(L=[],I=0;I<2;I++){ + for(J=0;J<2;J++){ + if(!iscombox(PP[I],QQ[J])) continue; + if(T[3]<=1) return + [[T[0]+(I+0.5)*V,T[1]+(J+0.5)*V, + [(PP[I][0][0]+PP[I][0][1])/2,(PP[I][1][0]+PP[I][1][1])/2]]]; + else{ +#if 0 + U=PB[I][0];V=PB[I][length(PB[I])-1]; + if(abs(A=(U[0]-V[0]))>abs(B=(U[1]-V[I]))) + M=mat([1,0],[-B/A,1]); + else if(U!=V) + M=mat([1,-A/B],[0,1]); + else continue; + if(!iscombox(ptbox(ptaffine(M,PB[I])),ptbox(ptaffine(M,QB[J])))) continue; +#endif + + LN=ptcombezier(PB[I],QB[J],[T[0]+I*V,T[1]+J*V,V,T[3]-1]); +#if 0 + L=append(LN,L); +#else + if(LN!=[]){ + if(L==[]) L=LN; + else for(VV=3*V/2^T[3];LN!=[];LN=cdr(LN)){ + for(LT=L;LT!=[];LT=cdr(LT)){ + if(abs(car(LN)[0]-car(LT)[0])32){ /* Too many points */ + I=J=2; + } +#endif + } + } + } + return L; +} + + +def ptcombz(P,Q,T) +{ + if(P==Q) Q=0; + if(type(P[0][0])!=4) P=P0=lbezier(P); + if(Q==0){ + Q=P;F=1; + } + else if(type(Q[0][0])!=4) Q=lbezier(Q); + for(R=[],I=0,Q0=Q;P!=[];P=cdr(P),I++){ + for(J=0,Q=Q0;Q!=[];Q=cdr(Q),J++){ + if(F==1&&IX1) X1=ST[0]; + if(ST[1]Y1) Y1=ST[1]; + } + } + } + } + V0=(X1-X0)/2^M;V1=(Y1-Y2)/2^M; + for(RR=[],RT=R;RT!=[];RT=cdr(RT)) + for(S=cdr(car(RT));S!=[];S=cdr(S)) RR=cons(car(S)[2],RR); + RR=ltov(RR);L=length(RR); + for(I=0;I=0;I--) if(RR[I]!=0) R0=cons(RR[I],R0); + }else{ + for(RT=R;RT!=[];RT=cdr(RT)){ + R00=[car(RT)[0]]; + for(S=cdr(car(RT));S!=[];S=cdr(S),I--) + if(RR[L-I-1]!=0) R00=cons(car(S),R00); + if(length(R00)>1) R0=cons(reverse(R00),R0); + } + } + return R0; + } + return reverse(R); +} + +def draw_bezier(ID,IDX,B) +{ + if(getopt(init)==1){ + S_FDot=0; + return; + } + if(type(Col=getopt(col))!=1&&Col!=0) Col=0; + Dot=0; + if(type(Opt=getopt(opt))==7){ + if(!Col){ + Col=drawopt(Opt,0); + if(Col==-1) Col=0; + } + T=drawopt(Opt,3); + if(iand(T,2)){ + M=iand(T,1)?1/8:1/4; + for(C=Col,Col=I=0;I<20;I+=8) + Col+=ishift(0xff-(floor((0xff-iand(0xff,ishift(C,I)))*M)),-I); + } + if(iand(T,4)) Dot=2; /* 2 or 3 or 4 or 6 */ + else if(iand(T,8)) Dot=4; + } + if(type(B)==4 && (type(B[0])==4||type(B[0])==5) && type(B[0][0])<2) B=lbezier(B); + else if(type(B)==5) B=[vtol(B)]; + for(;B!=[];B=cdr(B)){ + if(vars(F=car(B))==[]){ +#if 1 + if(length(F)<3&&!Dot){ /* line or point */ + if(length(F)>0){ + G=[rint(F[0][0]),rint(F[0][1])]; + if(length(F)==1) draw_obj(ID,IDX,G,Col); + else{ + G=[G[0],G[1],rint(F[1][0]),rint(F[1][1])]; + draw_obj(ID,IDX,G,Col); + } + } + continue; + } +#endif + if(length(F)<2) continue; + F=tobezier(F); + } + N=velbezier(F,0); + N=(N[0]>N[1])?N[0]:N[1]; + if(!N) N=1; + for(I=0;I<=N;I++,S_FDot++){ + if(Dot!=iand(S_FDot,Dot)) continue; + G=subst(F,t,I/N); + G=[rint(G[0]),rint(G[1])]; + if(G!=G0){ + draw_obj(ID,IDX,G,Col); + G0=G; + } + } + } + if(S_FDot-->=2^32) S_FDot=0; + return 0; +} + + +/* +def redbezier(L) +{ + V=newvect(4);ST=0; + for(R=[],I=0,T=L;T=[];T=cdr(T){ + if(type(car(T))<4){ + F=0; + if(I==3) + if(car(T)==0){ + }else if(car(T)==1){ + }else if(car(T)==-1){ + if(I<3) V[I++]=ST; + } + }else if(I==3){ + if(R==[] || car(R)!=1){ + R=cons(V[0],R); + if(ST==0) ST=V[0]; + } + for(J=1;J<3;J++) R=cons(V[J],R); + while((T=cdr(T))!=[]){ + R=cons(car(T),R); + if(type(car(R))<4) + } + }else{ + if(ST==0) ST=car(T); + V[I++]= car(T); + } + } +} +*/ + +def lbezier(L) +{ + if((In=getopt(inv))==1||In==2||In==3){ + for(F=0,R=[];L!=[];L=cdr(L)){ + LT=car(L); + if(F==car(LT)) R=cons(1,R); + else{ + if(R!=[]&&F!=0) R=cons(0,R); + R=cons(G=car(LT),R); + if(In==3) In==2; + } + for(LT=cdr(LT);LT!=[];LT=cdr(LT)) + R=cons(car(LT),R); + if((F=car(R))==G&&In==1){ + R=cons(-1,cdr(R)); + F=0; + } + } + if(In==3 && car(R)==G) R=cons(-1,cdr(R)); + return reverse(R); + } + for(F=0,RT=R=[];L!=[];L=cdr(L)){ + if(type(T=car(L))==4||type(T)==5){ + if(F==0){ + FT=T;F=1; + } + RT=cons(T,RT); + }else if(T==0){ + if(RT==[]) R=cons(reverse(RT),R); + RT=[];F=0; + }else if(T==1){ + if(RT!=[]){ + R=cons(reverse(RT),R); + RT=[car(RT)]; + }else{ + RT=[];F=0; + } + }else if(T==-1){ + RT=cons(FT,RT); + R=cons(reverse(RT),R); + RT=[];F=0; + } + } + if(RT!=[]) R=cons(reverse(RT),R); + return reverse(R); +} + + +def xybezier(L) +{ + if(L==0 || (LS=length(L))==0) return ""; + Out=str_tb(0,0); + if(type(VF=getopt(verb))==4){ + if(type(car(VF))>3){ + VFS=VF;VF=1; + }else{ + VFS=cdr(VF);VF=car(VF); + } + }else VFS=["$\\bullet$","$\\times$"]; + if(VF!=1 && VF!=2) VF=0; + if(!TikZ){ + if(VF) Ob=str_tb(0,0); + T="\n**\\crv{"; + if(type(Opt=getopt(opt))==7 && Opt!="") T=T+Opt; + L00=Q=L[I0=0];S=S1=""; + for(F=0,I=1;I<=LS;I++){ + P=Q;Q=(I==LS)?0:L[I]; + if(type(Q)==4){ + if(F==0){ + S1="";L0=P;F=1; + continue; + }else if(F==1) + F=2; + else if(F==2){ + S1=S1+"&"; + } + S1=S1+xypos(P); + if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob); + }else{ + if(Q==0){ + if(F>0){ + str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out); + if(VF){ + str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob); + if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob); + } + F=0; + } + }else if(Q==1){ + str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out); + if(VF){ + str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob); + if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob); + } + F=1; + }else if(Q==-1){ + if(F==2) + S1=S1+"&"; + str_tb("{"+xypos(L0)+";"+xypos(L00)+T+S1+xypos(P)+"}};\n",Out); + if(VF) str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob); + F=0; + } + if(F==1){ + if(I=LS) break; + if(F==1){ + Q=P;I--;F=0; + }else L00=Q=L[I]; + } + } + }else{ + if(type(T=getopt(cmd))==7){ + if(T!="") T="\\"+T; + }else T="\\draw"; + if((Rel=getopt(relative))==1) VF=0; + if(VF) Ob=str_tb(0,0); + if(type(Opt=getopt(opt))==7 && Opt!="") T=T+"["+Opt+"]"; + Out=str_tb(T,0); + Q=L[0]; + for(F=M=0,I=1;I<=LS;I++){ + P=Q; Q=(I==LS)?0:L[I]; + if(++M>XYLim){ + str_tb("\n",Out);M=1; + } + if(type(Q)==4 || type(Q)==5 || type(Q)==7){ + if(F==0){ + str_tb(" ",Out); + F=1; + }else if(F==1){ + str_tb(" .. controls ",Out); + F=2; + }else if(F==2){ + str_tb(" and ",Out); + F=2; + } + PP=xypos(P); + if(Rel==1 && F==2) PP="+"+PP; + str_tb(PP,Out); + if(VF&&((F<2)||length(VFS)>1)) + str_tb(xyput([P[0],P[1],(F<2)?VFS[0]:VFS[1]]),Ob); + }else{ +/* if(I1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob); + F=0; + } + if(F==1){ + if(I=LS) break; + Q=L[I]; + } + } + str_tb(";\n",Out); + } + if(VF) str_tb(str_tb(0,Ob),Out); + return str_tb(0,Out); +} + +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]] ]; + } + Opt=getopt(); + SS=getopt(opt); + FL=getopt(color); + if(TikZ&&type(SS)<1&&K==2){ + if(type(FL)==4){ + F=FL[0]; + if(length(FL)>1) CMD=FL[1]; + }else if(type(FL)==7) F=FL; + else F=""; + F=cons(F,["rectangle"]); + if(CMD) return xyarrow(P,Q|opt=F,cmd=CMD); + else return xyarrow(P,Q|opt=F); + } + if(type(SS)!=7&&!TikZ) Opt=cons(["opt","@{-}"],Opt); + Opt=cons(["close",1],Opt); + return xylines(LL|option_list=Opt); +} + +def xyang(S,P,Q,R) +{ + Opt=getopt(); + if(type(Prec=getopt(prec))!=1) Prec=0; + if(type(Q)>2){ + if(R==1||R==-1){ /* 直角 */ + P1=ptcommon([Q,P],[-S,0]); + S*=R; + P2=ptcommon([P,P1],[S,@pi/2]); + P3=ptcommon([P1,P2],[S,@pi/2]); + return xylines([P1,P2,P3]|option_list=Opt); + }else if((AR=abs(R))==0||AR==2||AR==3||AR==4){ /* 矢印 */ + Ang=myarg([Q[0]-P[0],Q[1]-P[1]]); + if(R<0) Ang+=3.14159; + ANG=[0.7854,0.5236,1.0472]; + X=(AR==0)?1.5708:ANG[AR-2]; + U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)]; + V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; /* 矢先 */ + V=(X==0)?[U,V]:[U,P,V]; + if(getopt(ar)==1) V=append([Q,P,0],V); /* 心棒 */ + return xylines(V|option_list=Opt); + }else if(AR>4&&AR<9){ + Ang=myarg([Q[0]-P[0],Q[1]-P[1]]); + ANG=[0.7854,0.5236,0.3927,0.2618]; + X=ANG[AR-5]; + U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)]; + V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; + W=ptcommon([P,U],[P,Q]|in=-2); + W1=[(U[0]+P[0]+W[0])/3,(U[1]+P[1]+W[1])/3]; + W2=[(V[0]+P[0]+W[0])/3,(V[1]+P[1]+W[1])/3]; + L=[U,W1,P,1,W2,V]; + if(getopt(ar)==1) L=append([Q,P,0],L); + if(type(Sc=getopt(scale))>0){ + if(type(Sc)==1) Sc=[Sc,Sc]; + L=ptaffine(diagm(2,Sc),L); + } + Opt=getopt(opt); + if(type(Opt)>0) OL=[["opt",Opt]]; + else OL=[]; + if(getopt(proc)==1) return append([2,OL],L); + S=xybezier(L|optilon_list=OL); + if(getopt(dviout)!=1) return S; + dviout(S); + return 1; + } + } + if(type(Q)<3){ + X=deval(Q); Y=deval(R); + }else{ + X=myarg([Q[0]-P[0],Q[1]-P[1]]); + Y=myarg([R[0]-P[0],R[1]-P[1]]); + } + if(Prec>2) N=8; + else if(Prec==2) N=6; + else if(Prec==1) N=4; + else N=3; + U=deval(@pi)*2/N; + if(X==Y||Y-X>6.28318){ + for(L=[],I=N-1;I>=0;I--) L=cons([P[0]+S*dcos(I*U),P[1]+S*dsin(I*U)],L); + return xylines(L|option_list=append([["curve",1],["close",1]],Opt)); + } + for(M=1;(Y-X)/M>U;M++); + for(L=[],I=M+1;I>-2;I--){ + Ang=X+(Y-X)*I/M; + L=cons([P[0]+S*dcos(Ang),P[1]+S*dsin(Ang)],L); + } + if(getopt(ar)!=1) return xylines(L|option_list=append([["curve",1],["close",-1]],Opt)); + OL=delopt(Opt,["dviout","opt","proc"]); + S=xylines(L|option_list=append([["curve",1],["close",-1],["opt",0]],OL)); + T=xylines([P,L[1]]|option_list=cons(["opt",0],OL)); + S=ptaffine("close",[S,T]); /* connect curves */ + if(getopt(opt)==0) return S; + OL=(type(SS=getopt(opt))>1)?[["opt",SS]]:[]; + if(type(T=getopt(proc))==1 && T>=1 && T<=3) return [1,OL,S]; + if(OL==[]) S=xybezier(S); + else S=(type(SS)==7)? xybezier(S|opt=SS):xybezier(S|opt=SS[0],cmd=SS[1]); + if(getopt(dviout)==1) return xyproc(S|dviout=1); + return S; +} + +def xyoval(P,L,R) +{ + if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){ + if(length(Arg)>2) + Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180,@pi*Arg[2]/180]; + else + Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180]; + } + if(type(Arg)==4){ + Arg0=deval(Arg[0]); Arg1=deval(Arg[1]); + if(length(Arg)>2) Arg2=deval(Arg[2]); + if(Arg11)? [["opt2",Opt]]:[]; + if(getopt(proc)==1) return [1,Opt,L]; + S=xybezier(L|option_list=getopt()); + if(getopt(dviout)==1){ + xyproc(S|dviout=1); + return 1; + } + return S; +} + +def xycirc(P,R) +{ + ST=getopt(opt); + if(type(ST)<0) ST=""; + if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){ + Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180]; + } +/* Is it OK? + if(TikZ==0 && XYcm==1){ + R*=10; P=[P[0]*10,P[1]*10]; + } +*/ + if(type(Arg)==4){ + 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; + } + if(TikZ){ + SP=""; + if(length(P)>2) SP=P[2]; + if(type(SP)!=7) SP="$"+my_tex_form(SP)+"$"; + if(R==0){ + if(ST!="") ST=ST+","; + return "\\node ["+ST+"circle,draw]"+xypos([P[0],P[1]])+ "{"+SP+"};\n"; + } + if(type(R)!=7) R=rtostr(deval(R)); + if(ST!="") ST="["+ST+"]"; + S="\\draw "+ST+xypos([P[0],P[1]])+" circle [radius="+R+"]"; + if(SP!="") S=S+" node at"+xypos([P[0],P[1]])+" {"+SP+"}"; + return S+";\n"; + } + 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=deval(R); + S=S+"<"+rtostr(R)+((XYcm)?"cm>":"mm>"); + } + S = S+"{"; + if(type(ST)==7) S=S+ST; + return S+"}};\n"; +} + +def xypoch(W,H,R1,R2) +{ + if(H>R1||2*H>R2){ + errno(0); + return; + } + if(type(Ar=getopt(ar))!=1) Ar=TikZ?0.25:2.5; + T1=dasin(H/R1);S1=R1*dcos(T1); + T2=dasin(H/R2);S2=R2*dcos(T2); + T3=dasin(2*H/R2);S3=R2*dcos(T3); + S=xyline([R1,0],[W-R1,0]); + S+=xyang(R1,[W,0],-@pi,@pi-T1); + S+=xyline([S2,H],[W-S1,H]); + S+=xyang(R2,[0,0],T2,2*@pi-T3); + S+=xylines([[S3,-2*H],[W-H-R2,-2*H],[W-H-R2,2*H],[W-S3,2*H]]); + S+=xyang(R2,[W,0],-@pi+T2,@pi-T3); + S+=xyline([W-T2,-H],[W-T2,-H]); + S+=xyang(R1,[0,0],0,2*@pi-T1); + S+=xyline([W-S2,-H],[S1,-H]); + if(Ar>0){ + S+=xyang(Ar,[W/2,0],[0,0],8); + S+=xyang(Ar,[W/2,-2*H],[0,-2*H],8); + S+=xyang(Ar,[W/2-Ar,-H],[W,-H],8); + S+=xyang(Ar,[W/2-Ar,H],[W,H],8); + S+=xyang(Ar,[W-S3,2*H],[W-H-R2,2*H],8); + } + S+=xyput([R1,0,"$\\bullet$"]); + S+=xyput([0,0,"$\\times$"]); + S+=xyput([W,0,"$\\times$"]); + if(TikZ) S=str_subst(S,";\n\\draw","\n"); + return S; +} + +def ptaffine(M,L) +{ + if(type(L)!=4&&type(L)!=5){ + erno(0);return L; + } + if(type(M)==7){ /* connect lists */ + if(M=="reverse"){ + for(LO=LR=[],F=0,LT=L; LT!=[]; LT=cdr(LT)){ + if(type(P=car(LT))==4 || type(P)==7){ + LR=cons(P,LR); + continue; + }else{ + if(P==-1){ + LL=reverse(LR); + LO=append(reverse(cons(-1,cdr(LL))),LO); + LO=cons(car(LL),LO); + LR=[]; + }else if(P==1){ + LR=cons(car(LR),cons(1,cdr(LR))); + }else if(P==0 || length(LT)==1){ + if(LO!=[] && car(LO)!=0 && (type(car(LO))==4 || car(LO)==1)) + LO=cons(0,LO); + LO=append(LR,LO); + if(length(LT)>1&&length(LO)>0&&car(LO)!=0) LO=cons(0,LO); + LR=[]; + } + } + } + return append(LR,LO); + } + if(type(L[0][0])!=4) L=[L]; + LO=[]; + if(M=="connect" || M=="close" || M=="loop"){ + Top=car(car(L)); + for(K=1,LL=L; LL!=[]; LL=cdr(LL)){ + for(F=0,LT=car(LL); LT!=[]; LT=cdr(LT),F++){ + if((LTT=car(LT))==0) LTT=1; + if(F==0 && LO!=[]){ + LO0=car(LO); + if(car(LO)!=1&&length(LO)>1) LO=cons(1,LO); + if(LTT==LO0) continue; + else LO=cons(1,cons(LTT, LO)); + }else LO=cons(LTT, LO); + } + } + if(M!="connect"){ + if(Top==car(LO) || car(LO)==1 || M=="loop") + LO=cons(-1,cdr(LO)); + else + LO=cons(-1,cons(1,LO)); + } + return reverse(LO); + } + if(M=="union"){ + for(LL=reverse(L); LL!=[]; LL=cdr(LL)){ + if(LO!=[]) LO=cons(0,LO); + LO=append(car(LL),LO); + } + L=LO; + } + return 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=ltov([0,0]); + if(type(V=getopt(shift))==4) + Sft+=ltov(V); + if(getopt(proc)==1){ + if(Sft!=0&<ov(Sft)!=[0,0]) Sft=[["shift",vtol(Sft)]]; + else Sft=[]; + for(LO=[],LT=L;LT!=[];LT=cdr(LT)){ + if(type(car(T=car(LT)))<2){ + if((P=car(T))==0){ /* exedraw 0 */ + V=[[T[1][0],T[2][0]],[T[1][0],T[2][1]],[T[1][1],T[2][0]],[T[1][1],T[2][1]]]; + V=ptbbox(ptaffine(M,V|option_list=Sft)); + L1=cdr(cdr(cdr(T))); + LO=cons(append([0,V[0],V[1]],L1),LO); + continue; + }else if(P==1){ /* exedraw 1 */ + L1=[]; + for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){ + D=car(TT); + if(type(D[0][0])==4){ + for(L2=[],DT=D;DT!=[];DT=cdr(DT)) + L2=cons(ptaffine(M,car(DT)|option_list=Sft),L2); + L1=cons(reverse(L2),L1); + }else L1=cons(ptaffine(M,D|option_list=Sft),L1); + } + LO=cons(append([1,T[1]],reverse(L1)),LO); + continue; + }else if(P>=2 && P<=5){ + L1=ptaffine(M,cdr(cdr(T))|optilon_list=Sft); + LO=cons(append([P,T[1]],L1),LO); + continue; + } + } + LO=cons(T,LO); + } + return reverse(LO); + } + F=0; + if(type(L)==4){ + for(LT=L; LT!=[]; LT=cdr(LT)){ + if((T=type(car(LT)))==4||T==5){ + 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(((T=type(P=car(LT)))!=4 && T!=5)||type(P[0])>3) LO=cons(P,LO); + else{ + if(T==4) P=ltov(P); + V=M*P; + if(Sft!=0) V+=Sft; + if(T==4) V=vtol(V); + LO=cons(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(car(C),x,P[0],y,P[1])<0) break; + if(C!=[]) continue; + 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=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=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[1] || P[1]Y[1]) + R=cons(0,R); + else R=cons(P,R); + } + return reverse(R); +} + +def lninbox(L,W) +{ + if(L[0]==L[1]) return 0; + R=newvect(2);C=newvect(2); + for(J=0;J<2;J++){ + C[J]=L[1][J]-L[0][J]; + if(C[J]!=0){ + R[J]=[(W[J][0]-L[0][J])/C[J],(W[J][1]-L[0][J])/C[J]]; + if(R[J][0]>R[J][1]) R[J]=[R[J][1],R[J][0]]; + } + } + if(R[0]==0) R[0]=R[1]; + if(R[1]==0) R[1]=R[0]; + S0=(R[0][0]1) S1=1; + } + if(S0>S1) return 0; + return [[L[0][0]+C[0]*S0,L[0][1]+C[1]*S0],[L[0][0]+C[0]*S1,L[0][1]+C[1]*S1]]; +} + +def ptbbox(L) +{ + J=length(L[0]); + if((Box=getopt(box))==1){ + for(R=[],I=0;IQ) Q=T[I][1]; + } + } + R=cons([P,Q],R); + } + }else if(type(Box)==4) return ptbbox([ptbbox(L),Box]|box=1); + else{ + for(R=[],I=0;IQ) Q=V; + } + } + R=cons([P,Q],R); + } + } + return reverse(R); +} + +def iscombox(S,T) +{ + for(;S!=[];S=cdr(S),T=cdr(T)) + if(car(S)[0]>car(T)[1] || car(S)[1]M1) M1=V; + } + SS=dsqrt(SS/I-S^2/I^2); + S=[deval(S/I),SS,I,M0,M1]; + } + if(isint(N=getopt(sint))) S=sint(S,N); + return S; +} + +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; I127) return N; + S=(iand(N,8))? "\\allowdisplaybreaks":""; + if(iand(N,2)) S=S+"\\\\"; + if(iand(N,16)) S=S+"\\pause"; + if(iand(N,1)) S=S+"\n"; + if(iand(N,4)) S=S+"& "; + else if(!iand(N,1)) S=S+" "; + if(iand(N,64)) S=S+"="; + if(iand(N,32)) S=","+S; + return S; +} + +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); + if(type(Var=getopt(var))<1) Var=0; + Cr2="\n"; + if(type(Cr=getopt(cr))==4){ + Cr2=Cr[1];Cr=Cr[0]; + } + if(isint(Cr)) Cr=texcr(Cr); + if(type(Cr)!=7) Cr="\\\\\n & "; /* Cr=7 */ + 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","coord"]); + 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 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((I0)?" + ":" ",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; I0)?" +":"\\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,var=Var),0); + }else if(Op==5 || Op==6){ /* cr or text */ + Out = str_tb(0,0); + if(type(Lim=getopt(lim))!=1) Lim=0; + else if(Lim<30&&Lim>0) Lim=TeXLim; + Str=getopt(str); + if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1) + Str=2; + for(K=I=0; L!=[]; I++, L=cdr(L)){ + LT=car(L); + if((!Lim||Op==6)&&I>0) str_tb((Op==5)?Cr:"\n",Out); + if(Op==6){ + if(type(LT)==7){ + str_tb([LT," "],Out); + I=-1; + continue; + } + str_tb("$",Out); + } + KK=0; + if(Str>0 && type(LT)==4 && Opt!=[]) + S=ltotex(LT|opt=car(Opt),lim=0,str=Str,cr=Cr2,var=Var); + else if(type(LT)==6){ + if(Lim>0){ + S=mtotex(LT|var=Var,lim=0,len=1); + KK=S[1]; + S=S[0]; + }else S=mtotex(LT|var=Var,lim=0); + }else if(type(LT)==3 || type(LT)==2) + S=fctrtos(LT|TeX=2,lim=0,var=Var); + else S=my_tex_form(LT); + if(Op!=6&&I>0&&Lim){ + if(Lim<0){ + if(I%(-Lim)==0) + str_tb((Op==5)?Cr:"\n",Out); + }else if((K+=(KK=(KK)?KK:texlen(S)))>Lim){ + str_tb((Op==5)?Cr:"\n",Out); + K=KK; + } + } + str_tb(S,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); + KK=0; + if(type(LT)==7 && Str==1) S=LT; + else if(type(LT)==3 || type(LT)==2) + S=fctrtos(LT|TeX=2,lim=0,var=Var); + else if(type(LT)==6){ + if(Lim){ + S=mtotex(LT|var=Var,lim=0,len=1); + KK=S[1]; + S=S[0]; + }else S=mtotex(LT|var=Var,lim=0); + }else + S=my_tex_form(LT); + if(Lim!=0){ + if(!KK) 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|null=Null); + L=m2ll(mtranspose(M)); + } + if(type(W=getopt(width))==1) + L=madjust(L,W|null=Null); + LV=ltov(L); + S=length(LV); +#if 1 + if(type(T=getopt(left))==4){ + T=str_times(T,S); + for(L=[],I=0;ICS) CS=length(LV[I]); + if(type(T=getopt(top))==4){ + LV=cons(str_times(T,CS),vtol(LV)); + S++; + } + if(type(T=getopt(last))==4){ + LV=append(vtol(LV),[str_times(T,CS)]); + S++; + } +#else + for(I=CS=0; ICS) CS=length(LV[I]); +#endif + if(type(Title=getopt(title))!=7) Title=""; + if(type(Vline=getopt(vline))!=4) Vline=[0,CS]; + else Vline=subst(Vline,z,CS); + for(VV=[],VT=Vline;VT!=[];VT=cdr(VT)){ + if(type(T=car(VT))==4 && T[1]>0){ + for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV); + }else VV=cons(T,VV); + } + Vline=qsort(VV); + Out=str_tb("\\begin{tabular}{",0); + if(type(Al=getopt(align))==7 && str_len(Al)>1){ + str_tb(Al,Out); + }else{ + if(type(Al)!=7 || str_len(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=subst(Hline,z,S); + for(VV=[],VT=Hline;VT!=[];VT=cdr(VT)){ + if(type(T=car(VT))==4 && T[1]>0){ + for(I=T[0];I<=S;I+=T[1]) VV=cons(I,VV); + }else VV=cons(T,VV); + } + Hline=qsort(VV); + while(Hline!=[] && car(Hline)==0){ + str_tb(" \\hline\n",Out); + Hline=cdr(Hline); + } +/* + if(type(getopt(left))==4) CS++; + if(type(getopt(right))==4) CS++; + if(type(T=getopt(top))==4){ + LV=cons(str_times(T,CS),vtol(LV)); + S++; + } + if(type(T=getopt(last))==4){ + LV=append(vtol(LV),[str_times(T,CS)]); + S++; + } + if(type(T=getopt(left))==4){ + T=str_times(T,S); + for(L=[],I=0;I=0;){ + if(REL==1){ + R=cons([MX[J],V=MX[J]+L[I][J]],R); + MX[J]=V; + }else R=cons([(!I)?0:L[I-1][J],L[I][J]],R); + } + OP=cons(["color",CL[I]],OL); + S+=ltotex([R,LL]|option_list=cons(["value",0],cons(["strip",(!I)?1:2],OP))); + T+=ltotex([R,LL]|option_list=cons(["strip",3],OP)); + } + return(!Strip)?xyproc(S+T):(S+T); + }else if(!TikZ) CL=0; + if(type(Line=getopt(line))!=1){ + if(type(Line)==4){ + if(type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){ + Opt=Line[1]; Line=Line[0]; + }else if(ML==1){ + OL=delopt(OL,"line"); + LL=L[1];L=L[0];K=length(L);S=""; + if(!MX){ + MX=newvect(length(L[0])); + for(LT=L;LT!=[];LT=cdr(LT)){ + for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){ + if(REL==1) MX[I]+=car(LTT); + else if(MX[I]2) WRet=V[2]; + if(length(V)>3) VMerg=VMerg=V[3]; + if(length(V)>4) HMerg=V[4]; + } + Val=getopt(value); + if(!isint(Val)) Val=-1; + 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((Strip>0)?0:xyproc(1),0); + if(type(CL)!=4) str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out); + for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){ + SS=S+RT[0]; + if(type(CL)==4){ + str_tb(xyang(Opt,[0,0],(0.25-SS)*6.2832,(0.25-S)*6.2832|ar=1,opt=car(CL)),Out); + if(length(CL)>0) CL=cdr(CL); + }else str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out); + T=(S+SS)/2; + S=SS; + if(LT!=[]){ + str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),car(LT)]),Out); + LT=cdr(LT); + } + } + if(!Strip) str_tb(xyproc(0),Out); + return str_tb(0,Out); + } + 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<0)?-Hight:Hight/MX; + if(LL!=[]&&length(LL)==S-1) WS2=WStep/2; + else WS2=0; + Out=str_tb((Strip>0)?0:xyproc(1),0); + Hori=getopt(horiz); + if(Strip<2){ + if(Hori==1) str_tb(xyline([0,0],[0,Width-WStep+WWStep]),Out); + else 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; + if(type(LTT=car(LT))==4){ + YP0=(car(LTT)-Shift)*HStep;YP=(LTT[1]-Shift)*HStep; + VL=LTT[1]; + if(REL) VL-=LTT[0]; + }else{ + YP0=0;YP=(LTT-Shift)*HStep;VL=LTT; + } + if(Hori==1){ + if(Line!=0){ + if(I>0) + str_tb(xyarrow([XPM,YP],[XPM-WStep,YPP]|opt=Opt),Out); + if(Val!=0) + str_tb(xyput([YP+HMerg, XPM,car(LT)]),Out); + if(Line==2) + str_tb(xyput([YP,XPM,"$\\bullet$"]),Out); + YPP=YP; + }else if(YP!=0 || Val==1){ + if(Strip!=3){ + if(CL) str_tb(xybox([[YP,XP+WWStep], [YP0,XP]]|color=CL),Out); + else str_tb(xybox([[YP,XP+WWStep],[YP0,XP]]),Out); + } + if(Val!=0) str_tb(xyput([(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),XPM,VL]),Out); + } + if(LL!=[]&&I0) + 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){ + if(Strip!=3){ + if(CL) str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]|color=CL),Out); + else str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]),Out); + } + if(Val!=0) str_tb(xyput([XPM,(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),VL]),Out); + } + if(LL!=[]&&I3 || imag(X)==0) str_tb(my_tex_form(X),Out); + else{ + XR=real(X);XI=imag(X); + S=monototex(imag(X)); + if(S=="1") S=""; + else if(S=="- 1") S="-"; + if(getopt(cpx)==2) S=S+"\\sqrt{-1}"; + else S=S+"i"; + if(XR!=0){ + if(str_char(S,0,"-")==0) S=monototex(XR)+S; + else S=monototex(XR)+"+"+S; + } + str_tb(S,Out); + } + if((LT=cdr(LT))==[]) break; + else str_tb(",",Out); + } + str_tb(")",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&&T!=9)) 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); + } + for(M0=[],MM=M;MM!=[];MM=cdr(MM)){ /* change "?" -> z_z */ + for(M1=[],Mm=car(MM);Mm!=[];Mm=cdr(Mm)){ + Mt=car(Mm); + if(type(Mt)==4 && Mt[1]=="?"){ + M1=cons([Mt[0],z_z],M1); + continue; + }else if(type(Mt)==7 && Mt=="?"){ + M1=cons(z_z,M1); + continue; + } + M1=cons(Mt,M1); + } + M0=cons(reverse(M1),M0); + } + M = fspt(reverse(M0),5); /* short -> long */ + if(findin(z_z,vars(M))>=0) + M=subst(M,z_z,lsol(chkspt(M|mat=Mat)[3],z_z)); /* Fuchs relation */ + 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 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 = 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=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; +} + +def mcop(P,M,S) +{ + for(V=[],ST=S;ST!=[];ST=cdr(ST)) + if(isvar(VT=car(ST))) V=cons(vweyl(VT),V); + V=reverse(V); + N=length(V); + for(MT=M;MT!=[];MT=cdr(MT)){ + T=car(MT); + if(T[0]!=0) + P=mc(P,V[0],T[0]); + for(TT=cdr(T),ST=cdr(S);ST!=[];TT=cdr(TT),ST=cdr(ST)) + if(car(TT)!=0) P=sftpexp(P,V,S[0]-ST[0],-car(TT)); + } + return P; +} + +/* 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; I0 && 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 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 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; +} + +/* ((1)(1)) ((1)) 111|11|21 [[ [2,[ [1,[1]],[1,[1]] ]], [1,[[1,[1]]]] ]] */ +/* (11)(1),111 111|21,111 [[[2,[1,1]],[1,[1]]],[1,1,1]] */ +def s2csp(S) +{ + if(type(S)!=7){ + U=""; + if(type(N=getopt(n))>0){ + for(D=0,S=reverse(S);S!=[];S=cdr(S),D++){ + if(D) U=","+U; + T=str_subst(rtostr(car(S)),","," "); + U=str_cut(T,1,str_len(T)-2)+U; + } + V=strtoascii(U); + for(R=[];V!=[];V=cdr(V)){ + if((CC=car(V))==91){ /* [ */ + if(length(V)>1 && V[1]==91) V=cdr(V); + for(I=1;(CC=V[I])!=91&&CC!=93;I++); + if(CC==91){ + R=cons(40,R); /* ( */ + while(I--) V=cdr(V); + }else{ + V=cdr(V); + while(--I) R=cons(car(V),R); + } + }else if(CC==93){ /* ] */ + R=cons(41,R); + if(length(V)>1 && V[1]==93) V=cdr(V); + }else R=cons(CC,R); + } + return asciitostr(reverse(R)); + } + for(;S!=[];S=cdr(S)){ + if(U!="") U=U+","; + for(D=0,TU="",T=car(S);T!=[];D++){ + if(type(car(T))==4){ + R=lpair(T,0); + T=R[0];R1=m2l(R[1]|flat=1); + }else R1=[]; + if(D) TU="|"+TU; + TU=s2sp([T])+TU; + T=R1; + } + U=U+TU; + } + return U; + } + S=strtoascii(S); + if(type(N=getopt(n))>0){ + S=ltov(S); + L=length(S); + R=""; + for(I=J=N=0, V=[];J47&&S[J]<58) N=N*10+S[J]-48; + else{ + if(N>0){ + V=cons(N,V); + N=0; + } + if(S[J]==41){ /* ) */ + + }else if(S[J]==44){ /* , */ + + } + } + } + } + for(P=TS=[],I=D=0; S!=[]; S=cdr(S)){ + if((C=car(S))==44){ /* , */ + P=cons(D,P);D=0; + }else if(C==124){ /* | */ + D++;C=44; + } + TS=cons(C,TS); + } + S=reverse(TS); + P=reverse(cons(D,P)); + U=s2sp(asciitostr(S)); + + for(R=[];P!=[];P=cdr(P),U=cdr(U)){ + D=car(P);R0=car(U); + while(D--){ + U=cdr(U); + for(U0=car(U),R2=[];U0!=[];U0=cdr(U0)){ + for(R1=[],N=car(U0);N>0;R0=cdr(R0)){ + R1=cons(car(R0),R1); + if(type(car(R0))==4) N-=car(R0)[0]; + else N-=car(R0); + } + R2=cons([car(U0),reverse(R1)],R2); + } + R0=reverse(R2); + } + R=cons(R0,R); + } + return reverse(R); +} + + +def partspt(S,T) +{ + if(length(S)>length(T)) return []; + if(type(Op=getopt(opt))!=1) Op=0; + else{ + VS=ltov(S); + L=length(S)-1; + VT=ltov(qsort(T)); + } + if(length(S)==length(T)){ + if(S==T||qsort(S)==qsort(T)) R=S; + else return []; + }else if(getopt(sort)==1){ + S0=S1=[]; + for(;S!=[]&&car(S)==car(T);S=cdr(S),T=cdr(T)) + S0=cons(car(S),S0); + if(S!=[]&&car(S)0){ + if(X=Y) R=cons(vtol(VT),R); + if(!vnext(VT)) break; + } + } + if(Op){ + for(W=[];R!=[];R=cdr(R)){ + for(I=0,S=VS[0],K=U=[],TR=car(R);TR!=[];TR=cdr(TR)){ + K=cons(car(TR),K); + if(!(S-=car(K))){ + U=cons([VS[I],reverse(K)],U); + K=[]; + S=VS[++I]; + if(I==L){ + U=cons([S,cdr(TR)],U); + break; + } + } + } + W=cons(reverse(U),W); + } + R=W; + if(iand(Op,1)){ + for(R=[];W!=[];W=cdr(W)) + R=cons(reverse(qsort(car(W))),R); + R=lsort(R,[],1); + } + if(Op==3){ + for(W=[];R!=[];R=cdr(R)){ + for(S=[],TR=car(R);TR!=[];TR=cdr(TR)) + S=append(S,car(TR)[1]); + W=cons(S,W); + } + R=reverse(W); + } + } + return R; +} + +#if 0 +def confspt(S,T) +{ + R=[]; + LS=length(S);LT=length(T); + if(LScar(TT)) return R; + if(car(ST)==car(TT){ + S0=cons(car(ST));T0=cons(car(TT)); + LS--;LT--;continue; + } + V=car(TT);D=LS-LT; + for(P=[ST],DD=D;DD>0;){ + VD=V-car(car(ST)); + } + } +} +#endif + +def mcvm(N) +{ + X=getopt(var); + if((Z=getopt(z))!=1) Z=0; + if(type(N)==4){ + if((K=length(N))==1&&isvar(X)) X=[X]; + if(type(X)!=4){ + for(X=[],I=0;I=N[1]+N[3]) return 0; + X=X[0]; + for(R=[],I=1;I=0;I--){ + C=mycoef(P,I,V); + P-=C*polbyroot(W,V); + W=cdr(W); + E=cons(red(C),E); + } + return reverse(E); +} + +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;I0){ + for(S=II=0;IISum){ + V[I++]=0; + continue; + } + } + }else{ + V[I++]=0; + continue; + } + break; + } + if(I>=K) return P; + } +} + +def diagm(M,A) +{ + return mgen(M,0,A,1); +} + +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\",\"perm\" = 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","perm"]); + Sep=(getopt(sep)==1)?1:0; + if(S < 0 || S > 2) + S = 0; + if(M+S > 30 || N+S > 30){ + erno(1); + return; + } + if(N==-5){ + NM=newmat(M,M); + for(I=0;I= -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); + if(type(car(R))!=4 && M==N && M==IM){ + for(RR=TR=[],I=0;I0){ + for(I=0;I0)?RIJ[I]:RIJ[J]; + else + M[I0+I][J0+J] = RIJ; + } + } + } + } + return M; +} + +def unim(S) +{ + if(!Rand++) random(currenttime()); + if(!isint(Wt=getopt(wt))||Wt<0||Wt>10) Wt=2; + if(!isint(Xa=getopt(abs)) || Xa<1) + Xa=9; + if((Xaa=Xa)>10) Xaa=10; + if(Xaa%2) Xaa++; + Xh=Xaa/2; + if(type(S0=SS=S)==4){ + Int=(getopt(int)==1)?1:0; + U=[1,1,1,1,1,1,1,1,1,1,1,1,2,2,3,4]; + M=newmat(S[0],S[1]); + SS=cdr(S);SS=cdr(SS); + if(Rk=length(SS)) L=SS; + else{ + L=[0]; + I=(S[0]>S[1])?S[1]:S[0]; + if(I<=2) return 0; + if(!isint(Rk=getopt(rank))||Rk<1||Rk>S[0]||Rk>S[1]) + Rk=random()%(I-1)+2; + for(I=1;IXa) P=Xa; + M[I][L[I]]=(random()%2)?P:(-P); + } + for(I=0;I1) M[K=random()%I][KK=L[I]]=1; + I0=(I==0)?1:L[I]+1; + I1=(I==Rk-1)?S[1]:L[I+1]; + for(J=I0;J20) return 0; + if(getopt(conj)==1){ + M=S+Wt; + if(M>15) M=10; + M0=floor((M-1)/2); + for(R=[],I=0;I0) M[0][0]--; + else M[S-1][S-1]++; + } + } + if(getopt(res)==1) RR=diagm(S,[1]); + S1=S; + Res=dupmat(S=M); + if(isint(I=getopt(int))&&I>1&&random()%I==0){ + K=S[0][0];L=K+1; + for(I=1;IL && S[I-1][I]==0 && (I==S1-1||S[I][I+1]==0)){ + L=S[I][I]; + if(RR){ + RR[I][I]=L-K;RR[0][I]=1; + } + S[0][I]=1; + if(!(random()%3)) break; + } + } + if(random()%3==0){ + for(I=0;I=0&&S[J][I]==0;J--); + if(J>=0) continue; + S[I][I+1]=2; + for(J=0;J3||S1>3)?100:200; + if(getopt(both)==1){ + OL=delopt(getopt(),"both"); + M=unim(mtranspose(M)|option_list=OL); + M=mtranspose(M); + } + Mx=20; + for(I=K=LL=0;ICt) T=random()%Xaa-Xh; + else if(5*K=0) T++; + if(P==Q) continue; + for(G=0,J=S1-1;J>=0;J--){ + if((H=abs(M[Q][J]+M[P][J]*T))>Xa&&(!Conj||J!=P)) break; + if(K1) J=1; + if(J>0) continue; + if(J<0&&Conj==1){ + for(J=S1-1;J>=0;J--) + if(J!=Q&&abs(M[J][P]-M[J][Q]*T)>Xa) break; + if(J<0&&abs(M[Q][P]-M[Q][Q]*T+M[P][P]*T-M[P][Q]*T^2)>Xa) J=1; + if(J<0&&M[P][P]==M[Q][Q]){ + LF=0; + for(L=S1-1;J>=0;J--) if(L!=Q&&M[J][Q]!=0) LF++; + for(L=S1-1;J>=0;J--) if(L!=P&&M[P][J]!=0) LF++; + if(!LF) J=1; + } + } + if(J<0){ + for(J=S1-1;J>=0;J--) + M[Q][J]+=M[P][J]*T; + if(Conj==1) + for(J=S1-1;J>=0;J--) M[J][P]-=M[J][Q]*T; + if(RR) for(J=S1-1;J>=0;J--) RR[Q][J]+=RR[P][J]*T; + K++; + } + if(K%5==0){ + if(!Nt) M=mtranspose(M); + else if(!Conj&&K%2==0){ + for(F=0;F1){ + for(L=0;LCt){ + for(L=S-1;L>=0;L--){ + for(F=0,J=S1-1;J>=0;J--) + if(M[L][J]!=0) F++; + if(F<2){ + F=-1;break; + } + else F=0; + } + if(F<0 && LL++<5){ + I=(CT-CT%2)/2;K=1; + } + if(I>Ct) break; + } + } + if(RR){ + for(I=F=0;I=0;K--,VN=cdr(VN)) + RR[K][J]=car(VN); + F=1; + } + } + } + K=I;I=J;J=K; + } + } + if(F&&I==S1-1){ + F=0;I=-1; + } + } + if(getopt(int)==1){ + N=mtranspose(M); + for(F=I=0;I1||lgcd(N[I])>1) F++; + if(F){ + for(F=I=0;IXa*10||abs(lmin(RR))>Xa*10)?1:0; + for(I=0;!F&&I0) V++; + else if(RR[J][I]<0) V--; + } + if(I0){ + FE=cons([C*(X+S)^2-C1^(1/2)*(X+S)+C0,car(FT)[1]],FE); + FE=cons([C*(X+S)^2+C1^(1/2)*(X+S)+C0,car(FT)[1]],FE); + RT=cons(C1,RT); + continue; + } + } + } + FE=cons(car(FT),FE); + } + FC=reverse(FE); + } + 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]; + if(P!=0) R = cons([P,FC[I][0],K],R); + } + } + for(;RT!=[];RT=cdr(RT)){ + RTT=car(RT); + R=mtransbys(os_md.substblock,R,[RTT^(1/2),(RTT^(1/2))^2,RTT]); + } + 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 sqrt2rat(X) +{ + if(type(X)>3) return X; + X=red(X); + if(getopt(mult)==1){ + for(V=vars(X);V!=[];V=cdr(V)){ + T=funargs(F=car(V)); + if(type(T)==4&&length(T)>1){ + Y=T[1]; + Z=sqrt2rat(Y); + if(Y!=Z){ + if(length(T)==2){ + T0=T[0]; + X=subst(X,F,T0(Z)); + }else if(T[0]==pow) + X=subst(X,F,Y^T[2]); + } + } + } + } + for(V=vars(X);V!=[];V=cdr(V)){ /* r(x)^(1/2+n) -> r(x)^n*r(x)^(1/2) */ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]!=1/2&&isint(T2=2*T[1])){ + if(iand(T2,1)){ + R=(T[0])^(1/2);T2--; + }else R=1; + R*=T[0]^(T2/2); + X=red(subst(X,Y,R)); + } + } + D=dn(X);N=nm(X); + if(imag(D)!=0){ + N*=conj(D); + D*=conj(D); + return sqrt2rat(N/D); + } + for(V=vars(N);V!=[];V=cdr(V)){ /* (r(x)^(n/m))^k */ + T=args(Y=car(V)); + if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){ + Dn=dn(T[1]);Nm=nm(T[1]); + N=substblock(N,Y,Y^Dn,T[0]^Nm); + } + } + for(V=vars(D);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){ + Dn=dn(T[1]);Nm=nm(T[1]); + D=substblock(D,Y,Y^Dn,T[0]^Nm); + } + } + for(V=vars(D);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]==1/2&&mydeg(D,Y)==1){ + N*=mycoef(D,0,Y)-mycoef(D,1,Y)*Y; + N=mycoef(N,0,Y)+mycoef(N,1,Y)*Y+mycoef(N,2,Y)*T[0]; + D=mycoef(D,0,Y)^2-mycoef(D,1,Y)^2*T[0]; + X=red(N/D); + D=dn(X);N=nm(X); + break; + } + } + X=red(N/D); + D=dn(X);N=nm(X); + for(V=vars(D);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]==1/2) + D=substblock(D,T[0]^T[1],(T[0]^T[1])^2,T[0]); + } + for(V=vars(N);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]==1/2) + N=substblock(N,T[0]^T[1],(T[0]^T[1])^2,T[0]); + } + for(V=vars(N);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]==1/2){ + Ag=T[0]; + R=S=1; + An=fctr(nm(Ag)); + CA=An[0][0]; + if(CA<0){ + CA=-CA;R=-1; + } + if(type(I=sqrtrat(CA))<2) S=I; + else R*=CA; + for(An=cdr(An);An!=[];An=cdr(An)){ + Pw=car(An)[1];I=iand(Pw,1); + if(I) R*=car(An)[0]; + if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q; + } + for(An=fctr(dn(Ag));An!=[];An=cdr(An)){ + Pw=car(An)[1];I=iand(Pw,1); + if(I) R/=car(An)[0]^I; + if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q; + } + if(S!=1) N=subst(N,Y,R^(1/2)*S); + } + } + for(V=vars(N);V!=[];V=cdr(V)){ + T=args(Y=car(V)); + if(functor(Y)==pow&&T[1]==1/2){ + C=mycoef(N,1,Y); + for(VC=vars(C);VC!=[];VC=cdr(VC)){ + TC=args(YC=car(VC)); + if(functor(YC)==pow&&TC[1]==1/2){ + Ag=red(T[0]*TC[0]); + R=S=1; + An=fctr(nm(Ag)); + CA=An[0][0]; + if(CA<0){ + CA=-CA;R=-1; + } + if(type(I=sqrtrat(CA))<2) S=I; + else R*=CA; + for(An=cdr(An);An!=[];An=cdr(An)){ + Pw=car(An)[1];I=iand(Pw,1); + if(I) R*=car(An)[0]; + if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q; + } + for(An=fctr(dn(Ag));An!=[];An=cdr(An)){ + Pw=car(An)[1];I=iand(Pw,1); + if(I) R/=car(An)[0]^I; + if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q; + } + CC=mycoef(C,1,YC); + N=N-CC*YC*Y+CC*R^(1/2)*S; + } + } + } + } + return red(N/D); +} + +def cfrac2n(X) +{ + if(type(L=getopt(loop))==1&&L>0) + C=x; + else{ + C=0;L=0; + } + if(L>1){ + for(Y=[];L>1;L--){ + Y=cons(car(X),Y); + X=cdr(X); + } + if(X!=[]){ + P=cfrac2n(X|loop=1); + for(V=P,Y=reverse(Y);Y!=[];Y=cdr(Y)) + V=sqrt2rat(car(Y)+1/V); + return V; + }else{ + C=0;X=reverse(Y); + } + } + for(V=C,X=reverse(X);X!=[];X=cdr(X)){ + if(V!=0) V=1/V; + V+=car(X); + } + if(C!=0){ + V=red(V);P=dn(V)*x-nm(V); + S=getroot(P,x|cpx=2); + T=map(eval,S); + V=(T[0]>0)?S[0]:S[1]; + } + return V; +} + +def s2sp(S) +{ + if(getopt(short)==1){ + if(type(F=getopt(std))==1) S=s2sp(S|std=F); + if(type(S)!=7) S=s2sp(S); + L=strtoascii(S); + for(LS=[],F=C=0;L!=[];L=cdr(L)){ + if((G=car(L))!=F){ + LS=cons(G,LS);C=0; + }else if(C<3){ + LS=cons(G,LS); + }else if(C==3){ + LS=cdr(LS);LS=cdr(LS); + LS=cons(94,LS);LS=cons(52,LS); + }else if(C==9){ + LS=cdr(LS);LS=cons(97,LS); + }else{ + K=car(LS);LS=cdr(LS);LS=cons(K+1,LS); + } + C++;F=G; + } + return asciitostr(reverse(LS)); + } + if(type(F=getopt(std))==1){ + F=(F>0)?1:-1; + if(type(S)==7) S=s2sp(S); + for(L=[];S!=[];S=cdr(S)) + L=cons(os_md.msort(car(S),[-1,0]),L); + return os_md.msort(L,[F,2]); + } + 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==60){ + for(V=[],S=cdr(S);S!=[]&&car(S)!=62;S=cdr(S)) + V=cons(car(S),V); + if(car(S)!=62) continue; + TR=cons(eval_str(asciitostr(reverse(V))),TR); + }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=[]; ; ){ + if(type(TS=car(S))!=4) return; + for(; TS!=[]; TS=cdr(TS)){ + V=car(TS); + if(type(V)>1||(type(V)==1&&ntype(V)>0)){ + V="<"+rtostr(V)+">"; + R=append(reverse(strtoascii(V)),R); + continue; + } + 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) +{ + if((T=ptype(F,X))<4){ + if(T<3){ /* polynomial */ + if(type(C=getopt(cos))>0){ + V=vars(F); + Z=makenewv(V); + W=makenewv(cons(Z,V)); + Q=intpoly(F,X|exp=Z); + Q=(subst(Q,Z,@i*C)*(Z+@i*W)+subst(Q,Z,-@i*C)*(Z-@i*W))/2; + return [mycoef(Q,1,Z),mycoef(Q,1,W)]; + } + if(type(C=getopt(sin))>0){ + Q=intpoly(F,X|cos=C); + return [-Q[1],Q[0]]; + } + if(type(C=getopt(log))>0){ + Q=intpoly(F,X); + if(C[0]==0) return [Q,0]; + if(length(C)<3) C=[C[0],C[1],1]; + Q-=subst(Q,X,-C[1]/C[0]); + if(iscoef(Q,os_md.israt)) Q=red(Q); + if(C[2]==0) return [Q]; + S=subst(-Q*C[0]*C[2],X,X-C[1]/C[0]); + for(R=0,D=mydeg(S,X);D>0;D--) R+=mycoef(S,D,X)*X^(D-1); + R=subst(R,X,X+C[1]/C[0]); + return cons(Q,intpoly(R,X|log=[C[0],C[1],C[2]-1])); + } + if(type(C=getopt(exp))>0){ + D = mydeg(F,X); + for(P=Q=F/C;D>=0;D--){ + Q=-mydiff(Q,X)/C; + P+=Q; + } + return P; + } + for(P=0,I=mydeg(F,X);I >= 0;I--) + P += mycoef(F,I,X)*X^(I+1)/(I+1); + return P; + } + R=pfrac(F,X|root=2); /* rational */ + for(P=0;R!=[];R=cdr(R)){ + if(type(V=getopt(dumb))==5){ + for(PF=[],RR=R;RR!=[];RR=cdr(RR)) + PF=cons(RR[0][0]/RR[0][1]^RR[0][2],PF); + PF=[cons(X,reverse(PF))]; + if(P) PF=cons([1,P],PF); + V[0]=cons(PF,V[0]); + } + RT=car(R); + if(mydeg(RT[1],X)==0) P+=intpoly(RT[0]*RT[2],X); + else if((Deg=mydeg(RT[1],X))==1){ + if(RT[2]>1) P+=RT[0]*RT[1]^(1-RT[2])/(1-RT[2])/mycoef(RT[1],1,X); + else P+=RT[0]*log(RT[1])/mycoef(RT[1],1,X); + P=red(P); + }else if(Deg==2){ + D1=diff(RT[1],X);C1=mycoef(D1,1,X); + B=2*C1*mycoef(RT[1],0,X)-mycoef(RT[1],1,X)^2; /* ax^2+bx+c => B=4ac-b^2 */ + B=sqrt2rat(B); + N=RT[0]; + for(I=RT[2];I>0&&N!=0;I--){ + C0=mycoef(N,1,X)/C1;N-=C0*D1; + if(C0){ + if(I>1) P-=C0/RT[1]^(I-1)/(I-1); + else P+=C0*log(RT[1]); + } + if(I>1){ + BB=B/C1; + P+=N*X/RT[1]^(I-1)/(I-1)/BB; + N*=(2*I-3)/(I-1)/BB; + }else{ + if(type(BR=sqrtrat(B))>3){ + mycat(["Cannot obtain sqare root of ",B]); + return []; + } + if(real(nm(BR))!=0){ + P+=(2*N/BR)*atan(sqrt2rat(D1/BR|mult=1)); + }else{ + BR*=@i;BRI=sqrt2rat(1/BR); + R1=(-mycoef(RT[1],1,X)+BR)/C1; + R2=(-mycoef(RT[1],1,X)-BR)/C1; + P+=N*BRI*log( /* sqrt2rat */((x-R1)/(x-R2))); + } + } + P=red(P); + } + P=sqrt2rat(P); + }else{ + mycat(["Cannot get an indefinite integral of ",F]); + return []; + } + } + Q=simplog(P,X); + if(type(V)==5&&nmono(P)!=nmono(Q)) V[0]=cons([[1,red(P)]],V[0]); + return red(Q); + } + return []; +} + +def fshorter(P,X) +{ + Q=sqrt2rat(P); + R=trig2exp(Q,X|inv=1); + if(str_len(fctrtos(R))=0){ + if(!C){ + F=car(V)[2]; + }else{ + R=red(car(V)[2]/F); + if(type(R)!=1) break; + F/=dn(R); + } + C++; + } + } + if(getopt(period)==1) return F; + if(!isint(Log=getopt(log))) Log=0; + if(V==[]&&F!=0){ + if(iand(Log,1)){ + H=append(cdr(fctr(nm(Q))),cdr(fctr(dn(Q)))); + for(L=0;H!=[];H=cdr(H)) + L+=str_len(rtostr(car(H)[0])); + }else L=str_len(fctrtos(Q)); + S=trig2exp(P,X); + for(T=[sin(F),tan(F),cos(F),sin(F/2),cos(F/2),tan(F/2)];T!=[];T=cdr(T)){ + R=trig2exp(S,X|inv=car(T)); + if(iand(Log,1)){ + H=append(cdr(fctr(nm(R))),cdr(fctr(dn(R)))); + for(K=0;H!=[];H=cdr(H)) + K+=str_len(rtostr(car(H)[0])); + }else K=str_len(fctrtos(R)); + if(Kstr_len(rtostr(-P)))?1:0; +} + +def simplog(R,X) +{ + for(V=[],Var=pfargs(R,X);Var!=[];Var=cdr(Var)){ + VT=car(Var); + if(VT[1]==log && ptype(R,VT[0])==2 && mydeg(R,VT[0])==1) + V=cons([VT[0],VT[2],mycoef(R,1,VT[0])],V); + } + for(;V!=[];V=cdr(V)){ + VT=car(V); + for(V2=cdr(V);V2!=[];V2=cdr(V2)){ + Dn=1; + if((C=red(car(V2)[2]/VT[2]))!=1&&C!=-1){ + if(getopt(mult)==1&&type(C)==1&&ntype(C)==0){ + Dn=dn(C);C*=Dn; + }else continue; + } + Log=red(VT[1]^Dn*car(V2)[1]^(Dn*C)); + L=str_len(rtostr(dn(Log)))-str_len(rtostr(nm(Log))); + if(L>0 || (L==0&&isshortneg(VT[2])) ){ + Dn=-Dn;Log=1/Log; + } + R=mycoef(R,0,VT[0]);R=mycoef(R,0,car(V2)[0]); + return(R+VT[2]*log(Log)/Dn); + } + } + return R; +} + +def integrate(P,X) +{ + Dvi=getopt(dviout); + if(type(I=getopt(I))==4){ + if((R=integrate(P,X))==[]) II="?"; + else if(type(I[0])>3||type(I[1])>3){ + R=subst(R,X,x); + V=flim(R,I[0]);VV=flim(R,I[1]); + if(V==""||VV=="") II="?"; + else if(type(V)==7||type(VV)==7){ + if(V==VV) II="?"; + else II=(VV=="+"||V=="-")?"\\infty":"-\\infty"; + }else{ + II=VV-V; + if(II>10^10) II="\\infty"; + else if(II<-10^10) II="-\\infty"; + } + }else{ + V=subst(R,X,I[1])-subst(R,X,I[0]); + VV=myval(V); + II=(type(VV)>=2||ntype(VV)<1)?VV:evalred(V); + } + if(type(Dvi)!=1) return II; + I=ltov(I); + for(J=0;J<2;J++){ + if(type(I[J])>3){ + if(type(I[J])==4&&length(I[J])>1) I[J]=I[J][1]; + else I[J]=(J==0)?"-\\infty":"\\infty"; + } + if(type(I[J])<4) I[J]=my_tex_form(I[J]); + } + S=(type(II)==7)?II:my_tex_form(II); + S="\\int_{"+I[0]+"}^{"+I[1]+"}"+monototex(P)+"\\,d"+my_tex_form(X)+"&="+S; + if(Dvi==1) dviout(texbegin("align",S)); + return S; + } + if(isint(Dvi)==1){ + if(Dvi==2||getopt(dumb)==-1){ + V=newvect(1);V[0]=[]; + }else V=0; + if((RR=integrate(P,X|dumb=V))==[]) return R; + S=fshorter(RR,X); + VV=[X]; + if(V!=0){ + R=cons([[1,RR]],V[0]); + if(S!=RR) R=cons([[1,RR=S]],R); + for(V=FR=[];R!=[];R=cdr(R)) + if(car(R)!=FR) V=cons(FR=car(R),V); + Var=varargs(V|all=2); + for(S0=[x0,x1,x2,x3],S=[t,s,u,v,w];S0!=[]&&S!=[];){ + if(findin(car(S0),Var)<0){ + S0=cdr(S0); continue; + } + if(findin(car(S),Var)>=0){ + S=cdr(S); continue; + } + V=subst(V,[car(S0),car(S)]);S0=cdr(S0);S=cdr(S); + } + if(Dvi==-2) return V; + S1="\\,dx&"; + }else{ + V=[[],[[1,RR=S]]]; + S1="\\,dx"; + } + if(type(P)>2){ + if(type(nm(P))<2){ + P=P*dx;S1=V?"&":""; + } + S=fctrtos(P|TeX=2,lim=0);SV0=my_tex_form(P); + if(str_len(SV0)2) CT=cdr(CT); + S0=["\\qquad(",CT[0],"=",CT[1],")"]; + break; + }else{ + for(FT=0,S2=[],CT=cdr(CT);CT!=[];CT=cdr(CT),FT++){ + SV=fctrtos(car(CT)|TeX=2,lim=0);SV0=my_tex_form(car(CT)); + if(str_len(SV0)1){ + if(length(S2)>1){ + S1="\\int\\left(";S3="\\right)\\,d"; + }else{ + S1="\\int";S3="\\,d"; + } + S2=cons(S1,append(S2,[S3,Y])); + if(findin(Y,VV)<0) VV=cons(Y,VV); + } + if(FL) S0=append(S0,cons("+",S2)); + else S0=append(S0,S2); + } + } + L=append([S0],L); + }; + V=pfargs(RR,X|level=1); + for(Var=[];V!=[];V=cdr(V)) Var=cons(car(V)[0],Var); + Var=reverse(Var); + if(!isint(J=getopt(frac))) J=0;; + if(!iand(J,4)&&(!iand(J,2)||length(Var)==1)&&(iand(J,8)==8||ptype(RR,Var)==2)){ + F=1; + if(iand(J,1)){ + K=str_len(fctrtos(RR)); + I=str_len(fctrtos(RR|var=Var)); + if(I>=K) F=0; + } + if(F){ + V=[fctrtos(RR|var=Var,TeX=2)]; + if(Dvi!=-2) V=cons("=",V); + if(length(L)>0) L=cdr(L); + L=append([V],L); + } + }else if(ptype(RR,X)==2){ + L=cdr(L); + V=[fctrtos(RR|var=X,TeX=2)]; + if(Dvi!=-2) V=cons("=",V); + L=append([V],L); + } + S=texket(S+ltotex(reverse(L)|opt=["cr","spts0"],str=1)); + if(getopt(log)!=1){ + for(V=[];VV!=[];VV=cdr(VV)) + V=cons(strtoascii(my_tex_form(car(VV))),V); + S1=strtoascii("\\log"); + for(F=1;F;){ /* log(log(x)) */ + F=FT=0; + S0=strtoascii(S); /* log(x) -> log|x| */ + L=length(S0); + S2=str_tb(0,0); + for(I=0;;){ + if(I>=L||(J=str_str(S0,S1|top=I+FT))<0){ + S=str_tb(0,S2)+str_cut(S0,I,100000); + break; + } + if((K=str_str(S0,40|top=J+4))<0 + ||(K!=J+4&&K!=J+9)||(N=str_pair(S0,K+1,40,41))<0){ + FT=J-I+4;continue; + } + FT=0; + if(str_str(S0,V|top=K+1,end=N-1)[0]<0) S2=str_tb(str_cut(S0,I,N),S2); + else{ + /* log(a) -> log(a) */ + F=1; + if(N (log|x|)^2 */ + S2=str_tb([str_cut(S0,I,J-1),"\\left(",str_cut(S0,J,K-1), + "|",str_cut(S0,K+1,N-1),"|\\right)"],S2); + } + else S2=str_tb([str_cut(S0,I,K-1),"|",str_cut(S0,K+1,N-1),"|"],S2); + } + I=N+1; + } + } + } + if(Dvi>0){ + dviout(texbegin("align*",S)); + return 1; + } + return S; + } /* end of dviout */ + SM=["Cannot integrate",P,"at present"]; + P=sqrt2rat(P|mult=1); + Dumb2=1;Dumb3=0;W=newvect(1);W[0]=[]; + if(type(Dumb=getopt(dumb))==5){ + Dumb2=Dumb3=Dumb;D2=W; + }else if(!isint(Dumb)) Dumb=0; + if(Dumb==-1){ + Dumb2=Dumb3=-1; + } + if(type(Dumb)!=5) D2=Dumb2; + if(!isint(Mul=getopt(mult))) Mul=0; + else Mul++; + if(type(VAR=getopt(var))!=4) VAR=[]; + if(type(P)>4) return []; + if(iand(T=ptype(P=red(P),X),63)>3||Mul>4){ + if(Dumb!=1) mycat(SM); + return []; + } + if(Dumb==-1) mycat(["integrate", P]); + else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]); + if(T<4 && (T<3||iscoef(P,os_md.israt))){ + if(Dumb==-1) mycat(["rational function",P]); + else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]); + return intpoly(P,X|dumb=Dumb); /* rational function */ + } + Var=pfargs(P,X); + for(F=0,VV=Var;VV!=[];VV=cdr(VV)){ + /* p(x)*log(x^2-1), @e^x, a^x, f(x)^(m/n) etc.->simplify */ + V=car(VV); + if(V[1]==log && (T=ptype(V[2],X))>1 && T<4){ + if(mydeg(dn(V[2]),X)>0||mydeg(nm(V[2]),X)>1){ + FC=pfctr(V[2],X);RV=1; + if(length(FC)>2){ + RR=0;RV=1; + if((F0=car(FC)[0])!=1){ + if(type(F0)!=1 && F0<0){ + for(FT=cdr(FT);FT!=[];FT=cdr(FT)){ + if(iand(car(FT)[1],1)){ + RV=-1;F0=-F0;break; + } + } + } + } + if(F0!=1) RR=log(F0); + for(FC=cdr(FC);FC!=[];FC=cdr(FC)){ + if(RV==-1&&iand(car(FC)[1],1)==1){ + RR+=car(FC)[1]*log(-car(FC)[0]); + RV=1; + }else + RR+=car(FC)[1]*log(car(FC)[0]); + } + P=subst(P,V[0],RR); + F=1; + } + } + F=1; + }else if(V[1]==pow){ + if(ptype(V[2],X)==1){ + F=1; + if(V[2]==@e){ /* @e^(f(x)) */ + P=subst(P,V[0],exp(V[3])); + }else P=subst(P,V[0],exp(log(V[2])*V[3])); + }else if(type(V[3])<=1 && ntype(V[3])==0){ /* r(x)^(m/n) */ + if((Pw=floor(V[3]))!=0){ + R=V[2]^Pw; + if((PF=V[3]-Pw)!=0) R*=V[2]^PF; + P=subst(P,V[0],R); + F=1; + V=[V[2]^PF,V[1],V[2],PF]; + } + if(ptype(nm(V[2]),X)<2&&V[3]>0){ /* (1/p(x))^(m/n) */ + P=subst(P,V[0],V[2]*red(1/V[2])^(1-V[3])); + F=0;VV=cons(0,Var=pfargs(P,X));continue; + } + if(ptype(V[2],X)<4&&(K=dn(V[3]))>1){ + V2=red(V[2]); + DN=mydeg(nm(V2),X);DD=mydeg(dn(V2),X); + if(DN+DD>1){ + VF=pfctr(V2,X); + R=car(VF)[0]^(car(VF)[1]);RR=0; + for(VF=cdr(VF);VF!=[];VF=cdr(VF)){ + TV=car(VF);TM=TV[1]; + while(abs(TM)>=K){ + RR=1; + if(TM>0){ + TM-=K; + RR*=TV[0]^nm(V[3]); + }else{ + TM+=K; + RR/=TV[0]^nm(V[3]); + } + } + if(TM!=0) R*=TV[0]^TM; + } + if(RR){ + P=subst(P,V[0],RR*red(R)^(V[3]));F=1; + F=0;VV=cons(0,Var=pfargs(P,X));continue; + } + } + } + } + } + } + if(F){ + P=sqrt2rat(P|mult=1); + Var=pfargs(P=red(P),X);T=ptype(P,X); + if(T<4 && (T<3||iscoef(P,os_md.israt))){ + if(Dumb==-1) mycat(["rational function",P]); + else if(type(Dumb)==5){ + Dumb[0]=cons([[X,P]],Dumb[0]); + return intpoly(P,X|dumb=Dumb3); + } + return intpoly(P,X); /* rational function */ + } + } +#if 1 + for(P0=P,V=pfargs(P,X|level=1);V!=[];V=cdr(V)) /* P:tan(x) -> P0:sin(x)/cos(x) */ + if(car(V)[1]==tan) P0=red(subst(P0,car(V)[0],sin(car(V)[2])/cos(car(V)[2]))); + if(iand(ptype(P0,X),128)){ /* (log f)'=f'/f */ + for(Df=cdr(fctr(dn(P0)));Df!=[];Df=cdr(Df)){ + if(!iand(ptype(car(Df)[0],X),64)) continue; + Q=car(Df)[0]^(car(Df)[1]);QQ=red(dn(P0)/Q); + DQ=red(diff(Q,X)*QQ); + if(type(C=DQ/nm(P0))<2&&C!=0){ + PP=0;DN=[1]; + }else for(DN=cdr(fctr(DQ));DN!=[];DN=cdr(DN)){ + Y=car(DN)[0]; + if(!iand(ptype(Y,X),64)||(I=mydeg(nm(P0),Y))!=mydeg(DQ,Y) + || ptype((C=red(mycoef(nm(P0),I,Y)/mycoef(DQ,I,Y))),X)>1||C==0) continue; + PP=red(P0-C*diff(Q,X)/Q); + if(nmono(P0)>nmono(PP)) break; + } + if(DN!=[]){ + R=C*log(Q); + if(PP==0){ + if(P!=P0&&type(Dumb)==5) Dumb[0]=cons([[X,P0]],Dumb[0]); + return R; + } + W[0]=[]; + S=integrate(PP,X|dumb=D2); + if(S!=[]){ + if(type(Dumb)==5){ + Dumb[0]=cons([[X,red(P0-PP),PP]],Dumb[0]); + TD=W[0]; + for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){ + if(car(TD)[0][0]){ + WL=cons([1,R],car(TD)); + Dumb[0]=cons(WL,Dumb[0]); + } + else Dumb[0]=cons(car(TD),Dumb[0]); + } + } + return red(R+S); + } + } + } + } +#endif + if((length(Var)==1||getopt(exe)==1) && /* p(x)*atan(q(x))^m+r(x), etc */ + findin((VT=car(Var))[1],[atan,asin,acos,log])>=0 && ptype(P,VT[0])==2 && + (VT[1]!=log||(T!=65&&T!=66)||mydeg(VT[2],X)!=1)){ /* exclude x*log(x+1)^2 */ + for(R=0,D=mydeg(P,VT[0]);D>=0;D--){ + Q=S=mycoef(P,D,VT[0]); + if(S){ + if(D>0){ + if((Q=integrate(S,X|mult=Mul))==[]) return Q; + }else{ + W[0]=[]; + if((Q=integrate(S,X|dumb=D2,var=VAR,mult=Mul))==[]) return Q; + if(type(Dumb)==5){ + TD=W[0]; + for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){ + if(car(TD)[0][0]){ + WL=cons([1,R],car(TD)); + Dumb[0]=cons(WL,Dumb[0]); + } + else Dumb[0]=cons(car(TD),Dumb[0]); + } + if(car(Dumb[0])!=[[1,R],[1,Q]]) + Dumb[0]=cons([[1,R,Q]],Dumb[0]); + } + return red(R+Q); + } + }else if(D>0) continue; + if(D==0){ + if(Q!=0&&type(Dumb)==5) Dumb[0]=cons([[1,R,Q]],Dumb[0]); + return red(Q+R); + } + R0=Q*VT[0]^D; + P=(P0=P)-S*VT[0]^D-Q*diff(VT[0]^D,X); + if(mydeg(P,VT[0])>=D){ /* (x+1)*log(x)/x^2 */ + if(mydeg(P,VT[0])==D && + ptype(C=red(mycoef(P,D,VT[0])/diff(VT[0],X)),VT[0])<2){ + P=P0-(S*VT[0]^D+Q*diff(VT[0]^D,X)+C*diff(VT[0]^(D+1),X)/(D+1)); + R0+=C*VT[0]^(D+1)/(D+1); + }else{ + P=P0; + if(Dumb!=1) mycat(SM); + return []; + } + } + if(type(Dumb)==5){ + if(P) Dumb[0]=cons([R?[1,R,R0]:[1,R0],[X,P]],Dumb[0]); + else if(R!=0) Dumb[0]=cons([[1,R,R0]],Dumb[0]); + } + R+=R0; + } + } + if(length(Var)==1 && (VT=car(Var))[1]==pow && mydeg(P,VT[0])==1 && (PT=ptype(VT[2],X))<4){ + PR=mycoef(P,0,VT[0]); + if(RR!=0){ + RR=integrate(RR,X|dumb=Dumb3,var=Var); + if(RR==[]) return RR; + } + PW=VT[3]; + if((D=mydeg(nm(V2=VT[2]),X))==2&&PT==2){ /* f(x)*(ax^2+bx+c)^(m/2)+r(x) */ + if(isint(2*PW)){ + C2=mycoef(V20=V2,2,X);F=1; + if((C21=sqrtrat(C2))==[]) return []; + if(imag(C21)!=0){ + if(real(C21)!=0) return []; + C21=C21/@i;F=-1; + } + if(type(C21)>3) return []; + P=subst(P,X,X/C21);VT=mysubst(VT,[X,X/C21]);V2=VT[2]; + C1=mycoef(V2,1,X)/F/2; + if(C1!=0){ + P=subst(P,X,X-C1);VT=mysubst(VT,[X,X-C1]);V2=VT[2]; + } + C0=mycoef(V2,0,X); + if((C01=sqrtrat(C0))==[]) return []; + if(imag(nm(C01))!=0){ + if(real(nm(C01))!=0) return []; + C01=C01/@i;G=-1; + }else G=1; + if(type(C01)>3||(F==-1&&G==-1)) return []; + Y=makenewv([P,VAR]|var=x); + if(F==-1){ /* (c^2-x^2)^(1/2) */ + Q=subst(P,VT[0],(C01*cos(Y))^(2*PW),X,YX=C01*sin(Y)) + *C01*cos(Y)/C21; + SY=(C21*X+C1);CY=V20;YY=asin(sqrt2rat((C21*X+C1)/C01|mult=1)); + }else if(G==-1){ /* (x^2-c^2)^(1/2) */ + Q=subst(P,VT[0],(C01*sin(Y)/cos(Y))^(2*PW),X,YX=C01/cos(Y)) + *C01*sin(Y)/cos(Y)^2/C21; + SY=V20;CY=1/(C21*X+C1);YY=acos(sqrt2rat(C01*(C21*X+C1)|mult=1)); + }else{ /* (x^2+c^2)^(1/2) */ + Q=subst(P,VT[0],(C01/cos(Y))^(2*PW),X,YX=C01*sin(Y)/cos(Y)) + *C01/cos(Y)^2/C21; + CY=V20; YY=atan(sqrt2rat((C21*X+C1)/C01|mult=1)); + } + if(Dumb==-1) mycat([C21*X+C1,"=",YX]); + else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,C21*X+C1,YX]],Dumb[0]); + Q=sqrt2rat(Q); + QQ=red(substblock(nm(Q),sin(Y),sin(Y)^2,1-cos(Y)^2) + /substblock(dn(Q),sin(Y),sin(Y)^2,1-cos(Y)^2)); + if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ; + QQ=red(substblock(nm(Q),cos(Y),cos(Y)^2,1-sin(Y)^2) + /substblock(dn(Q),cos(Y),cos(Y)^2,1-sin(Y)^2)); + if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ; + if((Q=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var)))==[]) return []; + Q=trig2exp(Q,Y|inv=cos(Y)); + for(V=vars(Q);V!=[];V=cdr(V)){ + FA=funargs(car(V)); + if(type(FA)==4&&FA[0]==log){ + QQ=trig2exp(FA[1],Y|inv=cos(Y)); + Q=mycoef(Q,0,car(V))+mycoef(Q,1,car(V))*log(QQ); + } + } + if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]); + if(F==-1) Q=subst(Q,sin(Y),SY/C01,cos(Y),CY^(1/2)/C01,Y,YY); + else if(G==-1){ + Q=red(subst(Q,sin(Y),SY^(1/2)*cos(Y)/C01)); + Q=red(subst(Q,cos(Y),C01*CY,Y,YY)); + }else{ + Q=red(subst(Q,sin(Y),(C21*X+C1)*cos(Y)/C01)); + Nm=substblock(nm(Q),cos(Y),C01^2/CY,cos(Y)^2); + Nm=subst(Nm,cos(Y),C01/CY^(1/2)); + Dn=substblock(dn(Q),cos(Y),C01^2/CY,cos(Y)^2); + Dn=subst(Dn,cos(Y),C01/CY^(1/2)); + Q=red(subst(Nm/Dn,Y,YY)); + } + if(findin(Y,vars(Q))>=0) return []; + for(R=[],Var=vars(Q);Var!=[];Var=cdr(Var)){ + VT=funargs(V=car(Var)); + if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60&&mydeg(Q,V)==1) + R=cons([mycoef(Q,1,V),V],R); + } + if(length(R)==2 && (R[0][0]==R[1][0]||R[0][0]+R[1][0]==0)){ + R0=args(R[0][1])[0];R1=args(R[1][1])[0]; + if(R[0][0]==R[1][0]) S=R0*R1; + else S=R1/R0; + Q=mycoef(Q,0,R[0][1]);Q=mycoef(Q,0,R[1][1]); + Q+=R[1][0]*log(red(S)); + } + for(Var=vars(Q);Var!=[];Var=cdr(Var)){ + VT=funargs(car(Var)); + if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60){ + S=trig2exp(VT[1],X|inv=cos(X),arc=1); + if(ptype(dn(S),X)<2 && mydeg(Q,car(Var))==1 + && ptype(mycoef(Q,1,car(Var)),X)<2){ + S=nm(S); + SF=fctr(S); + S/=SF[0][0]; + } + if(cmpsimple(S,-S)>0) S=-S; + Q=subst(Q,car(Var),log(S)); + } + } /* x/(1-x^2)^(1/2) */ + if(type(Q=red(Q+RR))==2&&type(Dumb)!=5) Q-=cterm(Q); + if(Dumb==-1) mycat(["->",Q]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]); + return Q; + } + }else if(D==1 && mydeg(Dn=dn(V2),X)<2 && type(PW)==1 && ntype(PW)==0 && + (V2!=X||ptype(mycoef(P,1,VT[0]),X)>2)){ /* p(x)((ax+b)/(cx+d))^(m/n) */ + PN=nm(PW);PD=dn(PW); + Y=makenewv([P,VAR]|var=x);Q=Y^PD*Dn-nm(V2);F=-mycoef(Q,0,X)/mycoef(Q,1,X); + Q=red(subst(P,VT[0],Y^PN,X,F)*diff(F,Y)); + if(Dumb==-1) mycat([Y,"=",V2^(1/PD)]); + else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,V2^(1/PD)]],Dumb[0]); + if((Q=integrate(Q,Y|dumb=Dumb3,var=cons(X,Var)))==[]) return []; + Q=red(Q); + QN=subst(substblock(nm(Q),Y,Y^PD,V2),Y,V2^(1/PD)); + QD=subst(substblock(dn(Q),Y,Y^PD,V2),Y,V2^(1/PD)); + Q=red(QN/QD+RR); + if(Dumb==-1) mycat(["->",Q]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]); + return Q; + } + }else if(length(Var)==2 && /* r(x,(ax+b)^(1/2),(cx+d)^(1/2)) */ + (VT=car(Var))[1]==pow && ptype(VT[2],X)==1 && mydeg(VT[2],X)==1 && VT[3]==1/2 && + (VS=car(car(Var)))[1]==pow && ptype(VS[2],X)==1 && mydeg(VS[2],X)==1 && VS[3]==1/2){ + Y=makenewv([P,VAR]|var=x);R=(Y^2-myceof(VS[0],0,X))/(C=mycoef(VS[0],1,X)); + if(Dumb==-1) mycat([Y,"=",VS[0]]); + else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,VD[0]]],Dumb[0]); + R=integrate(subst(P,VS[0],Y,X,R)*2*Y/C,Y|dumb=Dumb3,var=cons(X,Var)); + if(R!=[]){ + R=subst(substblock(R,Y,VS[0],Y^2),Y,VS[0]); + if(Dumb==-1) mycat(["->",R]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]); + } + return R; + } + if(T==65||T==66){ /* polynomial including sin, exp etc */ + for(F=0,VT=Var;VT!=[];VT=cdr(VT)){ + VTT=car(VT); + if(ptype(VTT[2],X)>2||mydeg(VTT[2],X)>1) F=ior(F,256); /* compos. or rat. or nonlin. */ + K=findin(VTT[1],[cos,sin,tan,exp,log,pow]); + F=ior(F,2^(K+1)); /* 1:other,2:cos,4:sin,8:tan,16:exp,32:log,64:pow */ + if((Deg=mydeg(P,VTT[0]))>1&&K!=4) F=ior(F,1024); /* nonlinear */ + if(K==5 && (ptype(VTT[3],X)!=0 || VTT[2]!=x||Deg>1)) F=ior(F,8192); /* pow */ + for(;Deg>0;Deg--){ /* coef */ + if(ptype(mycoef(P,Deg,VTT[0]),X)>2){ + if(K==4||K==5) F=ior(F,2048); /* exp, log */ + else F=ior(F,4096); + } + } + } + if(!iand(F,1+8+64+256+512+2048+8192)){ /* cos,sin,exp,log^n,x^c */ + if(iand(F,1024+4096)&&!iand(F,32+64)){ /* cos,sin,exp */ + if(type(Dumb)==5){ + S=trig2exp(P,X|inv=1); + if(P!=S) Dumb[0]=cons([[X,S]],Dumb[0]); + } + R=integrate(trig2exp(P,X),X); + if(R!=[]) S=trig2exp(R,X|inv=1); + R=fshorter(S,X); + if(type(Dumb)==5&&R!=S){ + Dumb[0]=cons([[1,S]],Dumb[0]); + } + return R; + } + for(R=0,VT=Var;VT!=[];VT=cdr(VT)){ + CV=car(VT); + C0=mycoef(CV[2],0,X);C1=mycoef(CV[2],1,X); + Q=mycoef(P,1,CV[0]); + if(CV[1]==sin||CV[1]==cos){ + TR=(CV[1]==sin)?intpoly(Q,X|sin=C1):intpoly(Q,X|cos=C1); + R+=TR[0]*cos(CV[2])+TR[1]*sin(CV[2]); + }else if(CV[1]==exp){ + QT=exp(CV[2]); + for(V2=vars(C1);V2!=[];V2=cdr(V2)){ /* exp(2*log(a)*x) => a^(2*x) */ + if(vtype(VA=car(V2))==2&&functor(VA)==log){ + if(ptype(C1,VA)!=2||mydeg(C1,VA)==1&&mycoef(C1,0,VA)==0){ + QT=args(VA)[0]^(red(C1/VA)*X); + if(C0!=0) QT*=exp(C0); + break; + } + } + } + R+=intpoly(Q,X|exp=C1)*QT; + }else if(CV[1]==pow) + R+=intpoly(Q,X|pow=CV[2])*x^CV[2]; + else if(CV[1]==log){ + for(Deg=mydeg(P,CV[0]);Deg>0; Deg--){ + Q=mycoef(P,Deg,CV[0]); + TR=intpoly(Q,X|log=[C1,C0,Deg]); + for(I=0;TR!=[];I++,TR=cdr(TR)){ + if(I==Deg) R+=car(TR)-subst(car(TR),X,0); + else R+=car(TR)*CV[0]^(Deg-I); + } + } + } + P=mycoef(P,0,CV[0]); + } + R+=intpoly(P,X); + return R; + } + } + for(K=0,VX=[],VT=Var;VT!=[];VT=cdr(VT)){ /* contain only both pow and trig */ + VTT=car(VT); + if(findin(VTT[1],[cos,sin,tan])>=0){ + if(ptype(VTT[2],X)!=2||mydeg(VTT[2],X)!=1) break; + VX=cons(VTT,VX); + }else if(VTT[1]==pow) K=1; + else break; + } + if(VT==[]&&K==1&&VX!=[]){ + D=VX[0][2]; + if(VX[0][1]==tan) D*=2; + for(VT=cdr(VX);VT!=[];VT=cdr(VT)){ + K=VT[0][2]/D; + if(VT[0][1]==tan) K*=2; + if(type(K)!=1||ntype(K)!=0) break; + D/=dn(K); + } + if(VT==[]){ + Y=makenewv([P,VAR]|var=x); + for(Q=P,VT=VX;VT!=[];VT=cdr(VT)){ + VTT=car(VT); + if(VTT[1]==cos||VTT[1]==sin){ + VV=trig2exp(VTT[0],X|inv=cos(D)); + VV=subst(VV,cos(D),(1-Y^2)/(1+Y^2),sin(D),2*Y/(Y^2+1)); + }else if(VTT[1]==tan){ + VV=trig2exp(VTT[0],X|inv=tan(D/2)); + VV=subst(VV,tan(D),Y); + } + Q=subst(Q,VTT[0],VV); + } + Q*=2/(Y^2+1); + if(diff(Q,X)==0){ + if(Dumb==-1) mycat([Y,"=",tan(D/2)]); + else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,tan(D/2)]],Dumb[0]); + R=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var)); + if(R!=[]){ + if(Dumb==-1) mycat(["->",R]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]); + return sqrt2rat(subst(R,Y,tan(D/2))|mult=1); + } + } + } + } + if(T>65||iand(F,8)){ /* rational for functions or tan */ + if(findin(X,vars(P))<0){ + for(XV=XE=0,VT=Var;VT!=[];VT=cdr(VT)){ + VTT=car(VT); + if(mydeg(VTT[2],X)!=1) break; + if(VTT[1]==cos||VTT[1]==sin||VTT[1]==tan){ + K=red(VTT[2]/X); + if(type(K)>1||ntype(K)>0) break; + if(XV==0) XV=K; + else XV/=dn(K/XV); + if(VTT[1]==tan) P=red(subst(P,VTT[0],sin(VTT[2])/cos(VTT[2]))); + }else if(VTT[1]==exp){ + K=red(VTT[2]/X); + if(type(K)>1||ntype(K)>0) break; + if(XE==0) XE=K; + else XE/=dn(K/XE); + }else break; + } + if(VT==[]&&XE*XV==0){ + if(XE){ + if(XE<0) XE=-XE; + Y=makenewv([P,VAR]|var=x); + for(F=0,VT=Var;VT!=[];VT=cdr(VT),F++){ + VTT=car(VT);C=red(VTT[2]/X/XE); + P=subst(P,VTT[0],Y^C); + if(!F){ + if(Dumb==-1) mycat([Y^C,"=",VTT[0]]); + else if(type(Dumb)==5) Dumb[0]=cons([[0,Y^C,VTT[0]]],Dumb[0]); + } + } + P/=XE*Y; + Q=integrate(P,Y|dumb=Dumb3,var=cons(X,VAR)); + if(Q==[]) return []; + Q=subst(Q,Y,exp(XE*X)); + Q=trig2exp(Q,X); + if(Dumb==-1) mycat(["->",Q]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]); + return Q; + } + P=trig2exp(nm(P),X|inv=cos(XV*X))/trig2exp(dn(P),X|inv=cos(XV*X)); + Y=makenewv([P,VAR]|var=x); + Q=red(subst(P,sin(XV*X),Y*cos(XV*X))); + Q=substblock(nm(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))/ + (substblock(dn(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))*(Y^2+1)); + Q=red(Q); + if(ptype(Q,X)<2){ + XV*=2;P=Q; + }else{ + P=subst(P,cos(XV*X),(1-Y^2)/(1+Y^2),sin(XV*X),2*Y/(1+Y^2))*2/K/(1+Y^2); + P=red(P); + } + if(Dumb==-1){ + mycat([Y,"=",tan(XV*X/2)]); + mycat(["integrate",P]); + }else if(type(Dumb)==5) Dumb[0]=cons([[Y,P]],cons([[0,Y,tan(XV*X/2)]],Dumb[0])); + R=intpoly(P,Y|dumb=Dumb); + if(R==[]) return R; + if(Dumb==-1) mycat(["->",R]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]); + for(Log=1,K=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){ + VTT=car(Var); + if(VTT[1]==log){ + C=mycoef(R,1,VTT[0]); + VT2=VTT[2]; + if(K==0){ + K=C;Log=VT2; + if(K<0){ + K=-K;Log=1/Log; + } + }else{ + if((V=red(C/K))<0){ + VT2=1/VT2;V=-V; + } + if(type(V)>1||ntype(V)>0){ + Log=1;break; + } + if(isint(V)) Log*=VT2^V; + else{ + D=dn(V);K/=D; + Log=Log^D*VT2^nm(V); + } + } + RR=mycoef(RR,0,VTT[0]); + } + } + if(Log!=1){ + R=RR; + if(type(Dumb)==5){ + if(RR) Dumb[0]=cons([[1,K*log(Log),RR]],Dumb[0]); + else Dumb[0]=cons([[1,K*log(Log)]],Dumb[0]); + } + Log=red(subst(red(Log),Y,sin(XV*X/2)/cos(XV*X/2))); + Log=fshorter(Log,X|log=1); /* log(cos(2*x)+1)=-2*log(cos(x)) */ + Nm=fctr(nm(Log)); + for(T=[];Nm!=[];Nm=cdr(Nm)){ + if(ptype(car(Nm)[0],X)>1) T=cons(car(Nm),T); + } + Nm=fctr(dn(Log)); + for(;Nm!=[];Nm=cdr(Nm)){ + if(ptype(car(Nm)[0],X)>1) T=cons([car(Nm)[0],-car(Nm)[1]],T); + } + for(I=0,Nm=T;T!=[];T=cdr(T)){ + if(I=0) I=abs(car(T)[1]); + else I=igcd(I,car(T)[1]); + } + for(Log=1;Nm!=[];Nm=cdr(Nm)) Log*=car(Nm)[0]^(car(Nm)[1]/I); + K*=I; + if(cmpsimple(nm(Log),dn(Log))<0){ + K=-K;Log=red(1/Log); + } + Log=K*log(Log); + if(type(Dumb)==5){ + if(RR) Dumb[0]=cons([[1,Log,RR]],Dumb[0]); + else Dumb[0]=cons([[1,Log]],Dumb[0]); + } + }else Log=0; + for(Atan=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){ + VTT=car(Var); + if(VTT[1]==atan){ + W=subst(VTT[2],Y,sin(XV*X/2)/cos(XV*X/2)); + W=trig2exp(W,X|inv=1); + V2=funargs(dn(W)); + if(type(V2)==4&&length(V2)==2){ + V3=V2[1]*mycoef(R,1,VTT[0]); + Z=0; + if(V2[0]==cos) + Z=red(W*cos(V2[1])/sin(V2[1])); + else if(V2[0]==sin){ + Z=red(W*sin(V2[1])/cos(V2[1])); + V3=-V3; + } + if(Z==1){ + Atan+=V3;W=0; + }else if(Z==-1){ + Atan-=V3;W=0; + } + } + R0=mycoef(R,0,VTT[0]); + if(W!=0) Atan+=subst(R-R0,VTT[0],atan(W)); /* atan(W); */ + R=R0; + } + } + if(R!=0){ + R=subst(R,Y,sin(XV*X/2)/cos(XV*X/2)); + R=red(R); + R=trig2exp(nm(R),X|inv=1)/trig2exp(dn(R),X|inv=1); + } + if(type(Dumb)==5){ + F=0;WL=[]; + if(R){ + WL=cons(R,WL); + F++; + } + if(Atan){ + WL=cons(Atan,WL); + F++; + } + if(Log){ + WL=cons(Log,WL); + F++; + } + WL=cons(1,WL); + if(F>1) Dumb[0]=cons([WL],Dumb[0]); + } + R=red(R+Log+Atan); + if(Dumb==-1) mycat(["->",R]); + else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]); + return fshorter(R,X); + } + } + } + VT=pfargs(Q=P,X|level=1); + V=(iand(ptype(P,X),7)<3)?[X]:[]; + for(;VT!=[];VT=cdr(VT)) + if(ptype(P,car(VT)[0])<3) V=cons(car(VT)[0],V); + if(length(V)>0){ /* 1/x+tan(x)+... etc.: sums */ + for(R=0;V!=[];V=cdr(V)){ + T=mycoef(Q,0,car(V)); + W[0]=[]; + S=integrate(TD=red(Q-T),X|dumb=D2,mult=Mul,exe=1); + if(S==[]) continue; + if(type(Dumb)==5){ + WL=0; + if(T!=0) WL=[[X,TD,T]]; + if(R!=0) WL=cons([1,R],WL); + if(WL) Dumb[0]=cons(WL,Dumb[0]); + TD=W[0]; + if(R!=0||T!=0){ + for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){ + if(car(TD)[0][0]){ + WL=(!T)?[]:[[X,T]]; + WL=append(car(TD),WL); + if(R!=0) WL=cons([1,R],WL); + }else WL=car(TD); + Dumb[0]=cons(WL,Dumb[0]); + } + }else Dumb[0]=append(TD,Dumb[0]); + } + R+=S;Q=T; + if(!Q) return red(R); + } + W[0]=[]; + if(P!=Q&&type(S=integrate(Q,X|dumb=D2,mult=Mul))<4){ + RR=red(R+S); + if(type(Dumb)==5){ + TD=W[0]; + for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){ + if(car(TD)[0][0]){ + WL=cons([1,R],car(TD)); + Dumb[0]=cons(WL,Dumb[0]); + } + else Dumb[0]=append(TD,Dumb[0]); + } + if(nmono(R)+nmono(S)!=nmono(RR)) Dumb[0]=cons([[1,R,S]],Dumb[0]); + } + return RR; + } + } + if(Dumb!=1) mycat(SM); + return []; +} + +def fimag(P) +{ + for(V=vars(P);V!=[];V=cdr(V)){ + Q=[]; + if(vtype(VF=car(V))==2){ + VAA=args(VF); + if(VAA==[]) continue; + VA=sqrt2rat(VAA[0]); + if(functor(VF)==exp){ + if(imag(VA)!=0){ + R=(real(VA)!=0)?exp(real(VA)):1; + Q=subst(P,VF,R*(cos(imag(VA))+sin(imag(VA))*@i)); + } + }else if(functor(VF)==pow){ + VA=sqrt2rat(VAA[1]); + if(imag(VA)!=0){ + R=(real(VA)!=0)?VAA[0]^(real(VA)):1; + L=(VAA[0]!=@e)?log(VAA[0]):1; + Q=subst(P,VAA[0]^(VAA[1]),R*(cos(L*imag(VA))+sin(L*imag(VA))*@i)); + }else if(VAA[1]!=(V0=fimag(VA))) + Q=subst(P,VAA[0]^(VAA[1]),VAA[0]^(V0)); + } + V0=VA; + if(length(VAA)==1&&(VAA[0]!=V0||VA!=(V0=fimag(VA)))) + Q=subst(P,VF,subst(VF,VAA[0],V0)); + } + if(Q!=[]&&P!=Q){ + P=Q;V=cons(0,vars(P)); + } + } + return P; +} + + +def trig2exp(P,X) +{ + if(iand(ptype(P,X),128)){ + OL=getopt(); + Nm=trig2exp(nm(P),X|option_list=OL); + Dn=trig2exp(dn(P),X|option_list=OL); + R=red(Nm/Dn); + if(getopt(arc)==1) return sqrt2rat(R); + } + if((Inv=getopt(inv))==1||type(Inv)==2){ + for(VT=T=vars(P);T!=[];T=cdr(T)){ + if(findin(functor(car(T)),[cos,sin,tan])>=0){ + P=trig2exp(P,X);VT=vars(P);break; + } + } + for(;VT!=[];VT=cdr(VT)){ + if(functor(CT=car(VT))==exp){ + if((Re=real(args(CT)[0]))!=0){ + if(isint(Re)) S=@e^Re; + else S=exp(Re); + }else S=1; + if((Im=imag(args(CT)[0]))!=0){ + Q=nm(Im);Q=mycoef(Q,mydeg(Q,X),X); + if(-Q>Q) S*=cos(-Im)-@i*sin(-Im); + else S*=cos(Im)+@i*sin(Im); + } + P=subst(P,CT,S); + } + } + P=red(P); + U=vars(Inv); + if(length(U)!=1||((F=functor(car(U)))!=sin&&F!=cos&&F!=tan)) return P; + XX=args(car(U))[0]; + if(mydeg(XX,X)!=1) return P; + if(!isvar(XX)) P=subst(P,X,(X-mycoef(XX,0,X))/mycoef(XX,1,X)); + for(VT=vars(P);VT!=[];VT=cdr(VT)){ + if(vtype(CT=car(VT))<2) continue; + TX=args(CT)[0]; + if(mydeg(TX,X)!=1) continue; + if(!isint(C1=mycoef(TX,1,X))) continue; + if((C0=mycoef(TX,0,X))==0){ + CC=1;CS=0; + }else if(vars(C0)==[@pi]){ + CC=myval(cos(C0)); + if(CC!=0&&type(CC)==1&&ntype(CC)!=0){ + CC=cos(C0);CS=sin(C0); + }else CS=myval(sin(C0)); + }else{ + CC=cos(C0);CS=sin(C0); + } + K=C1; + if(K<0) K=-K; + for(CC1=0,I=K;I>=0;I-=2) CC1+=(-1)^((K-I)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I); + for(CS1=0,I=K-1;I>=0;I-=2) CS1+=(-1)^((K-I-1)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I); + if(C1<0) CS1=-CS1; + if((TF=functor(CT))==cos) P=subst(P,cos(TX),CC1*CC-CS1*CS); + else if(TF==sin) P=subst(P,sin(TX),CS1*CC+CC1*CS); + } + if(F==sin) + P=substblock(P,cos(X),cos(X)^2,1-sin(X)^2); + else{ + P=substblock(P,sin(X),sin(X)^2,1-cos(X)^2); + if(F==tan){ + P=subst(P,sin(X),cos(X)*tan(X)); + P=substblock(P,cos(X),cos(X)^2,1/(tan(X)^2+1)); + } + } + if(!isvar(XX)) P=subst(P,X,XX); + + if(getopt(arc)==1){ + for(VT=vars(P);VT!=[];VT=cdr(VT)){ + FA=funargs(car(VT)); + if(type(FA)==4&&(FA[0]==cos||FA[0]==sin)&&ptype(FA[1],X)>60){ + VTT=vars(FA[1]); + if(type(FA[1])!=2||length(VTT)!=1) break; + FB=funargs(VTT[0]); + if(type(FB)!=4||(FF=findin(FB[0],[asin,acos,atan]))<0) break; + if(!isint(2*(C=mycoef(FA[1],1,VTT[0])))||mycoef(FA[1],0,VTT[0])!=0) break; + if(C==1/2){ + if(FF==1){ + U=(FA[0]==cos)?(1+FB[1])/2:(1-FB[1])/2; + P=subst(P,car(VT),red(U)^(1/2)); + }else if(FF==2){ + if(FA[0]==sin){ + FB1=red(FB[1]); + Nm=nm(FB1);CC=fctr(Nm)[0][0];Dn=dn(FB1); + if(CC<0) CC=-CC; + Nm/=CC;Dn/=CC; + NN=Nm^2+Dn^2; + P=subst(P,car(VT),((NN)^(1/2)-Dn)/Nm*cos(FA[1])); + } + } + P=red(P); + }else if(C==1){ + if(FF==1){ + if(FA[0]==cos) P=subst(P,car(VT),FB[1]); + else P=subst(P,car(VT),(1-FB[1])^(1/2)); + }else if(FF==0){ + if(FA[0]==sin) P=subst(P,car(VT),FB[1]); + else P=subst(P,car(VT),(1-FB[1])^(1/2)); + } + P=red(P); + } + } + } + P=sqrt2rat(P); + } + return red(P); + } + Var=pfargs(P,X); + for(VT=Var;VT!=[];VT=cdr(VT)){ + CT=car(VT); + if(CT[1]==cos) + P=subst(P,CT[0],exp(CT[2]*@i)/2+exp(-CT[2]*@i)/2); + else if(CT[1]==sin) + P=subst(P,CT[0],exp(-CT[2]*@i)*@i/2-exp(CT[2]*@i)*@i/2); + else if (CT[1]==tan) + P=subst(P,CT[0],(exp(-CT[2]*@i)*@i-exp(CT[2]*@i)*@i)/(exp(CT[2]*@i)+exp(-CT[2]*@i))); + else if(CT[1]==pow){ + if(ptype(CT[2],X)>1) continue; + if(CT[2]==@e) P=subst(P,CT[0],exp(CT[3])); + else P=subst(P,CT[0],exp(log(CT[2])*exp(CT[3]))); + } + } + P=red(P); + for(PP=1,Lp=(dn(P)==1)?1:0;Lp<2;Lp++){ + PP=1/PP; + U=(Lp==0)?dn(P):nm(P); + if(U==1) continue; + Var=vars(U); + for(R=[],VT=Var;VT!=[];VT=cdr(VT)) + if(functor(car(VT))==exp) R=cons(car(VT),R); + RR=os_md.terms(U,R); + for(Q=0,RRT=RR;RRT!=[];RRT=cdr(RRT)){ + for(S=0,CT=cdr(car(RRT)),CR=R,UT=U;CR!=[];CR=cdr(CR),CT=cdr(CT)){ + UT=mycoef(UT,car(CT),car(CR));S+=car(CT)*args(car(CR))[0]; + } + if(S==0) Q+=UT; + else Q+=UT*exp(S); + } + PP*=Q; + } + return PP; +} + +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;I3 && 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; I1){ + if(L<2 &&(ptype(VT[1],X)>1 || (length(VT)>2 && ptype(VT[2],X)>1))) + Var=cons(cons(car(V),VT),Var); + if(L!=1 && (R=pfargs(VT[1],X|level=L-1))!=[]) Var=append(R,Var); + } + } + } + return reverse(Var); +} + +def ptype(P,L) +{ + if((T=type(P))<2 || T>3) return T; + if(type(L)!=4) L=[L]; + F=0; + if(lsort(L,varargs(dn(P))[1],2)!=[]) F=128; + if(lsort(L,varargs(nm(P))[1],2)!=[]) F+=64; + if(lsort(L,vars(dn(P)),2)!=[]) return F+3; + return (lsort(L,vars(nm(P)),2)==[])?(F+1):(F+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 iscoef(P,F) +{ + if(P==0) return 1; + if(type(P)==1) return F(P); + if(type(P)==2) { + X=var(P); + for(I=deg(P,X); I>=0; I--){ + if(!iscoef(mycoef(P,I,X),F)) return 0; + } + }else if(type(P)==3){ + if(!iscoef(nm(P),F)||!iscoef(dn(P),F)) return 0; + }else if(type(P)==4){ + for(;P!=[];P=cdr(P)) if(!iscoef(P,F)) return 0; + }else if(type(P)>4 && type(P)<7) return iscoef(m2l(PP),F); + else return 0; + return 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=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; I1 && 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; I0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P); + return (M=P) break; + L0=cons(PP, L0); + } + L0=reverse(L0); + } + if(FE==0) All=getopt(all); + for(I=0, PP=P, LL=[]; I=0){ + if(J==0) VV=str_cut(VV,1,10000); + else VV=str_cut(VV,0,J-1)+str_cut(VV,J+1,10000); + } + V1=eval_str(VV); + if(I++) LT=cons(V1-V0,LT); + V0=V1; + } + DT=cons(LT,DT); + if((RT=cdr(RT))==[]){ + VE=rint(myfdeval(F,II[1])*10^Str[1]); + DT=cons([VE-V0],DT); + } + } + for(I=0,D=[],TT=DT;TT!=[];TT=cdr(TT)){ + if(!I++) V=car(TT)[0]; + else{ + T1=reverse(cons(V,car(TT))); + V=car(T1); + if(length(TT)>1) T1=cdr(T1); + D=cons(T1,D); + } + } + for(DD=[],TT=D;TT!=[];TT=cdr(TT)) + DD=cons([os_md.lmin(car(TT)),os_md.lmax(car(TT))],DD); + DD=reverse(DD); + L=lsort(L,DD,"append"); + } + } + L=lsort(L,L0,"cons"); + if(type(Top=getopt(top))==4||getopt(TeX)==1){ + if(type(Top)==4){ + K=length(L[0])-length(Top); + if(K>0&&K<4){ + if(K>1){ + Top=append(Top,["",""]); + K-=2; + } + if(K) Top=cons("",Top); + } + L=cons(Top,L); + } + if(type(H=getopt(hline))!=4) H=[0,1,z]; + if(type(V=getopt(vline))!=4) V=[0,1,(DF)?z-2:z]; + if(type(T=getopt(title))!=7) Out=ltotex(L|opt="tab",hline=H,vline=V); + else Out=ltotex(L|opt="tab",hline=H,vline=V,title=T); + if(Df) Out=str_subst(Out,"\\hline","\\cline{1-"+rtostr(length(L[0])-2)+"}"); + return Out; + } + return L; + } + for(L=[],I=0;I<=D;I++){ + X=II[0]+I*T/D; + L=cons([X,myfdeval(F,X)],L); + } + if(Df==1){ + for(LD=[],LL=L;LL!=[];LL=cdr(LL)){ + if(LD==[]) LD=cons([car(LL)[0],car(LL)[1],0],LD); + else LD=cons([car(LL)[0],car(LL)[1],abs(car(LL)[1]-car(LD)[1])],LD); + } + L=reverse(LD); + } + if(type(Str)==4){ + if(length(Str)==1) Str=[Str[0],Str[0]]; + if(Df==1 && length(Str)==2) Str=[Str[0],Str[1],Str[1]]; + for(S=Str,Str=[];S!=[];S=cdr(S)){ + if(type(car(S))!=4) Str=cons([car(S),3],Str); + else Str=cons(car(S),Str); + } + Str=reverse(Str); + for(LD=[],LL=L;LL!=[];LL=cdr(LL)){ + for(K=[],J=length(Str); --J>=0; ) + K=cons(sint(car(LL)[J],Str[J][0]|str=Str[J][1]),K); + LD=cons(K,LD); + } + L=LD; + }else + L=reverse(L); + if(type(M=getopt(mult))==1){ + Opt=[["opt","tab"],["vline",[[0,2+Df]]],["width",-M]]; + if(type(T=getopt(title))==7) + Opt=cons(["title",T],Opt); + if(type(Tp=getopt(top))==4) + Opt=cons(["top",Tp],Opt); + L=ltotex(L|option_list=Opt); + } + return L; +} + +def distpoint(L) +{ + L=m2l(L|flat=1); + if(getopt(div)==5) Div=5; + else Div=10; + V=newvect(100/Div); + for(LT=L,LL=[],N=0; LT!=[]; LT=cdr(LT)){ + if(type(K=car(LT))>1||K<0){ + N++; continue; + } + LL=cons(K,LL); + T=idiv(K,Div); + if(Div==10 && T>=9) T=9; + else if(Div==5 && T>=19) T=19; + V[T]++; + } + V=vtol(V); + if((Opt=getopt(opt))=="data") return V; + Title=getopt(title); + OpList=[["opt","tab"]]; + if(type(Title=getopt(title)) == 7) + OpList=cons(["title",Title],OpList); + if(Opt=="average"){ + T=isMs()?["平均点","標準偏差","最低点","最高点","受験人数"]: + ["average","deviation","min","max","examinees"]; + L=average(LL); + L=[sint(L[0],1),sint(L[1],1),L[3],L[4],L[2]]; + if(N>0){ + T=append(T,[isMs()?"欠席者":"absentees"]);L=append(L,[N]); + } + OpList=cons(["align","c"],OpList); + return ltotex([T,L]|option_list=OpList); + } + + if(getopt(opt)=="graph"){ + Mul=getopt(size); + if(Div==5){ + V0=["00","05","10","15","20","25","30","35","40","45","50","55", + "60","65","70","75","80","85","90","95"]; + if(type(Mul)!=4){ + Size = (TikZ)?[12,3,1/2,0.2]:[120,30,1/2,2]; + } + }else{ + V0=["00-","10-","20-","30-","40-","50-","60-","70-","80-","90-"]; + if(type(Mul)!=4){ + Size = (TikZ)?[8,3,1/2,0.2]:[80,30,1/2,2]; + } + } + return ltotex([V,V0]|opt="graph",size=Size); + } + if(Div==5) + V0=["00--04","05--09","10--14","15--19", "20--24", "25--29", "30--34", "35-39", + "40--44", "45--49","50--54", "55--59","60--64", "65--69", + "70--74", "75--79","80--84", "85--89","90--94", "95--100"]; + else + V0=["00--09","10--19","20--29","30--39","40--49","50--59","60--69", + "70--79","80--89","90--100"]; + Title=getopt(title); + return ltotex([V0,V]|option_list=OpList); +} + +def keyin(S) +{ + mycat0(S,0); + purge_stdin(); + S=get_line(); + L=length(S=strtoascii(S)); + if(L==0) return ""; + return str_cut(S,0,L-2); +} + +def init() { + LS=["DIROUT","DVIOUTA","DVIOUTB","DVIOUTH","DVIOUTL","TeXLim","TeXEq","TikZ", + "XYPrec","XYcm","Canvas"]; + 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,[["\\","/"],[".bat",".sh"]],0); + DVIOUTB=str_subst(DVIOUTB,[["\\","/"],[".bat",".sh"]],0); + DVIOUTL=str_subst(DVIOUTL,[["\\","/"],[".bat",".sh"]],0); + DVIOUTH="%ASIRROOT%/help/os_muldif.pdf"; + } + Home=getenv("HOME"); + if(type(Home)!=7) Home=""; + for(Id=-7, 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){ + if(type(P=str_str(S,LS))==4 && (P0=str_char(S,P[1]+4,"="))>0){ + if(P[0]<5){ + 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) DVIOUTB=SS; + else if(P[0]==3) DVIOUTH=SS; + else if(P[0]==4) DVIOUTL=SS; + } + } + if(P0<0 || P1