![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to os_muldif.rr CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / asir-contrib / packages / src|
Return to os_muldif.rr CVS log | Up to [local] / OpenXM / src / asir-contrib / packages / src |
1.40 ! takayama 1: /* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.39 2018/10/17 01:37:10 takayama Exp $ */
1.6 takayama 2: /* The latest version will be at ftp://akagi.ms.u-tokyo.ac.jp/pub/math/muldif
3: scp os_muldif.[dp]* ${USER}@lemon.math.kobe-u.ac.jp:/home/web/OpenXM/Current/doc/other-docs
4: */
5: #define USEMODULE 1
6: /* #undef USEMODULE */
7:
8: /* os_muldif.rr (Library for Risa/Asir)
1.35 takayama 9: * Toshio Oshima (Nov. 2007 - Sep. 2018)
1.6 takayama 10: *
11: * For polynomials and differential operators with coefficients
12: * in rational funtions (See os_muldif.pdf)
13: *
14: * "Tab = 4 column" is best
15: */
16:
17: ord([zz,dz,dy,dx])$
18:
19: #ifdef USEMODULE
20: module os_md;
21: static Muldif.rr$
22: static TeXEq$
23: static TeXLim$
24: static DIROUT$
1.16 takayama 25: static DIROUTD$
1.6 takayama 26: static DVIOUTL$
27: static DVIOUTA$
28: static DVIOUTB$
29: static DVIOUTH$
30: static DVIOUTF$
31: static LCOPT$
32: static COLOPT$
33: static LPOPT$
34: static LFOPT$
35: static ErMsg$
36: static FLIST$
37: static IsYes$
38: static XYPrec$
39: static XYcm$
40: static TikZ$
41: static XYLim$
42: static Canvas$
43: static ID_PLOT$
44: static Rand$
45: static LQS$
46: localf spType2$
47: localf erno$
48: localf chkfun$
49: localf makev$
50: localf shortv$
51: localf makenewv$
52: localf vweyl$
53: localf mycat$
54: localf mycat0$
1.9 takayama 55: localf fcat$
1.6 takayama 56: localf findin$
57: localf countin$
58: localf mycoef$
59: localf mydiff$
60: localf myediff$
61: localf m2l$
62: localf m2ll$
63: localf mydeg$
64: localf pfctr$
65: localf mymindeg$
66: localf m1div$
67: localf mulsubst$
68: localf cmpsimple$
69: localf simplify$
70: localf monotos$
71: localf minustos$
72: localf monototex$
73: localf vnext$
74: localf ldict$
75: localf ndict$
76: localf nextsub$
77: localf nextpart$
78: localf transpart$
79: localf trpos$
80: localf sprod$
81: localf sinv$
82: localf slen$
83: localf sord$
84: localf vprod$
85: localf dvangle$
86: localf dvprod$
87: localf dnorm$
88: localf mulseries$
89: localf pluspower$
90: localf vtozv$
91: localf dupmat$
92: localf matrtop$
93: localf mytrace$
94: localf mydet$
95: localf mperm$
96: localf mtranspose$
97: localf mtoupper$
98: localf mydet2$
99: localf myrank$
100: localf meigen$
101: localf transm$
102: localf vgen$
103: localf mmc$
104: localf lpgcd$
105: localf mdivisor$
106: localf mdsimplify$
107: localf m2mc$
108: localf easierpol$
109: localf paracmpl$
110: localf mykernel$
111: localf myimage$
112: localf mymod$
113: localf mmod$
114: localf ladd$
115: localf lchange$
116: localf llsize$
117: localf llbase$
118: localf lsort$
1.22 takayama 119: localf lpair$
1.6 takayama 120: localf lmax$
121: localf lmin$
122: localf lgcd$
123: localf llcm$
124: localf ldev$
125: localf lsol$
126: localf lnsol$
127: localf l2p$
128: localf m2v$
129: localf lv2m$
130: localf m2lv$
131: localf s2m$
132: localf c2m$
133: localf m2diag$
134: localf myinv$
135: localf madjust$
136: localf mpower$
137: localf mrot$
138: localf texlen$
139: localf isdif$
140: localf fctrtos$
141: localf texlim$
142: localf fmult$
143: localf radd$
144: localf getel$
145: localf ptol$
146: localf rmul$
147: localf mtransbys$
148: localf drawopt$
149: localf execdraw$
150: localf execproc$
151: localf myswap$
152: localf mysubst$
153: localf evals$
154: localf myval$
155: localf myeval$
156: localf mydeval$
157: localf myfeval$
158: localf myf2eval$
159: localf myf3eval$
160: localf myfdeval$
161: localf myf2deval$
162: localf myf3deval$
163: localf myexp$
164: localf mycos$
165: localf mysin$
166: localf mytan$
167: localf myarg$
168: localf myasin$
169: localf myacos$
170: localf myatan$
171: localf mylog$
172: localf mypow$
1.13 takayama 173: localf scale$
1.6 takayama 174: localf arg$
175: localf sqrt$
176: localf gamma$
177: localf lngamma$
178: localf digamma$
179: localf dilog$
180: localf zeta$
181: localf eta$
182: localf jell$
183: localf frac$
184: localf erfc$
1.20 takayama 185: localf orthpoly$
186: localf schurpoly$
1.6 takayama 187: localf fouriers$
188: localf todf$
189: localf f2df$
190: localf df2big$
191: localf compdf$
192: localf fzero$
193: localf fmmx$
194: localf flim$
195: localf fcont$
196: localf fresidue$
197: localf mmulbys$
198: localf appldo$
199: localf appledo$
200: localf muldo$
201: localf jacobian$
202: localf hessian$
203: localf wronskian$
204: localf adj$
205: localf laplace1$
206: localf laplace$
207: localf mce$
208: localf mc$
209: localf rede$
210: localf ad$
211: localf add$
212: localf vadd$
213: localf addl$
214: localf cotr$
215: localf rcotr$
216: localf muledo$
217: localf mulpdo$
218: localf transpdosub$
219: localf transpdo$
220: localf translpdo$
221: localf rpdiv$
222: localf mygcd$
223: localf mylcm$
224: localf sftpexp$
225: localf applpdo$
226: localf tranlpdo$
227: localf divdo$
228: localf qdo$
229: localf sqrtdo$
230: localf ghg$
231: localf ev4s$
232: localf b2e$
233: localf sftpow$
234: localf sftpowext$
235: localf polinsft$
236: localf pol2sft$
237: localf polroots$
238: localf fctri$
239: localf binom$
240: localf expower$
241: localf seriesHG$
242: localf seriesMc$
243: localf seriesTaylor$
1.27 takayama 244: localf mulpolyMod$
1.26 takayama 245: localf taylorODE$
1.6 takayama 246: localf evalred$
247: localf toeul$
248: localf fromeul$
249: localf sftexp$
250: localf fractrans$
251: localf soldif$
252: localf chkexp$
253: localf sqrtrat$
254: localf getroot$
255: localf expat$
256: localf polbyroot$
257: localf polbyvalue$
258: localf pcoef$
259: localf prehombf$
260: localf prehombfold$
261: localf sub3e$
262: localf fuchs3e$
263: localf okubo3e$
264: localf eosub$
265: localf even4e$
266: localf odd5e$
267: localf extra6e$
268: localf rigid211$
269: localf solpokuboe$
270: localf stoe$
271: localf dform$
272: localf polinvsym$
273: localf polinsym$
274: localf tohomog$
275: localf substblock$
276: localf okuboetos$
277: localf heun$
278: localf fspt$
279: localf abs$
1.20 takayama 280: localf sgn$
1.6 takayama 281: localf calc$
282: localf isint$
283: localf israt$
284: localf iscrat$
285: localf isalpha$
286: localf isnum$
287: localf isalphanum$
1.8 takayama 288: localf isdecimal$
1.6 takayama 289: localf isvar$
290: localf isyes$
291: localf isall$
292: localf iscoef$
293: localf iscombox$
294: localf sproot$
295: localf spgen$
296: localf chkspt$
297: localf cterm$
298: localf terms$
299: localf polcut$
300: localf redgrs$
301: localf cutgrs$
302: localf mcgrs$
303: localf mc2grs$
304: localf mcmgrs$
1.38 takayama 305: localf spslm$
1.6 takayama 306: localf anal2sp$
307: localf delopt$
308: localf str_char$
309: localf str_pair$
310: localf str_cut$
311: localf str_str$
312: localf str_subst$
313: localf str_times$
314: localf str_tb$
315: localf strip$
316: localf i2hex$
317: localf sjis2jis$
318: localf jis2sjis$
319: localf s2os$
320: localf l2os$
321: localf r2os$
322: localf s2euc$
323: localf s2sjis$
324: localf r2ma$
325: localf evalma$
326: localf ssubgrs$
327: localf verb_tex_form$
328: localf tex_cuteq$
329: localf my_tex_form$
330: localf texket$
331: localf smallmattex$
332: localf divmattex$
333: localf dviout0$
334: localf myhelp$
335: localf isMs$
336: localf showbyshell$
337: localf readcsv$
338: localf tocsv$
339: localf getbyshell$
340: localf show$
341: localf dviout$
342: localf rtotex$
343: localf mtotex$
344: localf ltotex$
345: localf texbegin$
346: localf texcr$
347: localf texsp$
348: localf getbygrs$
349: localf mcop$
350: localf shiftop$
351: localf conf1sp$
1.34 takayama 352: localf confexp$
1.36 takayama 353: localf confspt$
1.38 takayama 354: localf partspt$
1.6 takayama 355: localf pgen$
356: localf diagm$
357: localf mgen$
358: localf madj$
359: localf newbmat$
360: localf unim$
361: localf pfrac$
362: localf cfrac$
363: localf cfrac2n$
364: localf sqrt2rat$
365: localf s2sp$
366: localf sp2grs$
367: localf fimag$
368: localf trig2exp$
369: localf intpoly$
370: localf integrate$
1.22 takayama 371: localf rungeKutta$
1.6 takayama 372: localf simplog$
373: localf fshorter$
374: localf isshortneg$
375: localf intrat$
376: localf powsum$
377: localf bernoulli$
378: localf lft01$
379: localf linfrac01$
380: localf nthmodp$
381: localf issquaremodp$
382: localf rootmodp$
383: localf rabin$
384: localf primroot$
385: localf varargs$
386: localf ptype$
387: localf pfargs$
388: localf average$
1.23 takayama 389: localf tobig$
1.6 takayama 390: localf sint$
391: localf frac2n$
392: localf xyproc$
393: localf xypos$
394: localf xyput$
395: localf xybox$
396: localf xyline$
397: localf xylines$
398: localf xycirc$
399: localf xybezier$
400: localf lbezier$
401: localf draw_bezier$
402: localf tobezier$
403: localf velbezier$
404: localf ptbezier$
405: localf cutf$
406: localf fsum$
407: localf fint$
408: localf periodicf$
409: localf cmpf$
410: localf areabezier$
411: localf saveproc$
412: localf xygraph$
413: localf xy2graph$
1.22 takayama 414: localf addIL$
1.19 takayama 415: localf xy2curve$
1.18 takayama 416: localf xygrid$
1.6 takayama 417: localf xyarrow$
418: localf xyarrows$
419: localf xyang$
420: localf xyoval$
1.33 takayama 421: localf xypoch$
1.6 takayama 422: localf ptcommon$
423: localf ptcopy$
424: localf ptaffine$
425: localf ptlattice$
426: localf ptpolygon$
427: localf ptwindow$
428: localf ptbbox$
429: localf lninbox$
430: localf ptcombezier$
431: localf ptcombz$
432: localf lchange$
433: localf init$
434: localf powprimroot$
435: localf distpoint$
436: localf ntable$
437: localf keyin$
438: localf mqsub$
439: localf msort$
440: #else
441: extern Muldif.rr$
442: extern TeXEq$
443: extern TeXLim$
444: extern DIROUT$
1.16 takayama 445: extern DIROUTD$
1.6 takayama 446: extern DVIOUTL$
447: extern DVIOUTA$
448: extern DVIOUTB$
449: extern DVIOUTH$
450: extern DVIOUTF$
451: static LCOPT$
452: static COLOPT$
453: static LPOPT$
454: static LFOPT$
455: extern TikZ$
456: extern ErMsg$
457: extern FLIST$
458: extern IsYes$
459: extern XYPrec$
460: extern XYcm$
461: extern TikZ$
462: extern XYLim$
463: extern Canvas$
464: extern ID_PLOT$
465: extern Rand$
466: extern LQS$
467: #endif
468: static S_Fc,S_Dc,S_Ic,S_Ec,S_EC,S_Lc$
1.16 takayama 469: static S_FDot$
1.6 takayama 470: extern AMSTeX$
1.38 takayama 471: Muldif.rr="00181008"$
1.6 takayama 472: AMSTeX=1$
473: TeXEq=5$
474: TeXLim=80$
475: TikZ=0$
476: XYcm=0$
477: XYPrec=3$
478: XYLim=4$
479: Rand=0$
480: DIROUT="%HOME%\\tex"$
481: DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$
482: DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$
483: DVIOUTB="%ASIRROOT%\\bin\\risatex1%TikZ%.bat"$
484: DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$
485: DVIOUTF=0$
486: LCOPT=["red","green","blue","yellow","cyan","magenta","black","white","gray"]$
487: COLOPT=[0xff,0xff00,0xff0000,0xffff,0xffff00,0xff00ff,0,0xffffff,0xc0c0c0]$
488: LPOPT=["above","below","left","right"]$
489: LFOPT=["very thin","thin","dotted","dashed"]$
490: Canvas=[400,400]$
491: LQS=[[1,0]]$
492:
493: ErMsg = newvect(3,[
494: "irregal argument", /* 0 */
495: "too big size", /* 1 */
496: "irregal option" /* 2 */
497: ])$
498: FLIST=0$
499: IsYes=[]$
500: ID_PLOT=-1$
501:
502: def erno(N)
503: {
504: /* extern ErMsg; */
505: print(ErMsg[N]);
506: }
507:
508: def chkfun(Fu, Fi)
509: {
510: /* extern FLIST; */
511: /* extern Muldif.rr; */
512:
513: if(type(Fu) <= 1){
514: if(Fu==1)
515: mycat(["Loaded os_muldif Ver.", Muldif.rr, "(Toshio Oshima)"]);
516: else
517: mycat(["Risa/Asir Ver.", version()]);
518: return 1;
519: }
520: if(type(FLIST) < 4)
521: FLIST = flist();
522: if(type(Fu) == 4){
523: for(; Fu != [] ;Fu = cdr(Fu))
524: if(chkfun(car(Fu),Fi) == 0) return 0;
525: return 1;
526: }
527: if(findin(Fu, FLIST) >= 0)
528: return 1;
529: FLIST = flist();
530: if(findin(Fu, FLIST) >= 0)
531: return 1;
532: if(type(Fi)==7){
533: mycat0(["load(\"", Fi,"\") -> try again!\n"],1);
534: load(Fi);
535: }
536: return 0;
537: /*
538: if(type(Fi) == 7)
539: Fi = [Fi];
540: for( ; Fi != []; Fi = cdr(Fi))
541: load(car(Fi));
542: FLIST = flist();
543: return (findin(Fu,FLIST)>=0)?1:0;
544: */
545: }
546:
547: def makev(L)
548: {
549: S = "";
550: Num=getopt(num);
551: while(length(L) > 0){
552: VL = car(L); L = cdr(L);
553: if(type(VL) == 7)
554: S = S+VL;
555: else if(type(VL) == 2 || VL < 10)
556: S = S+rtostr(VL);
557: else if(VL<46 && Num!=1)
558: S = S+asciitostr([VL+87]);
559: else
560: S = S+rtostr(VL);
561: }
562: return strtov(S);
563: }
564:
565: def makenewv(L)
566: {
567: if((V=getopt(var))<2) V="z_";
568: else if(isvar(V)) V=rtostr(V);
569: if(type(N=getopt(num))!=1) N=0;
1.21 takayama 570: Var=varargs(L|all=2);
1.6 takayama 571: for(XX=[],I=J=0;;I++){
572: X=strtov(V+rtostr(I));
573: if(findin(X,Var)<0){
574: XX=cons(X,XX);
575: if(++J>N) return X;
576: else if(J==N) return reverse(XX);
577: }
578: }
579: }
580:
581: def shortv(P,L)
582: {
583: V=vars(P);
584: if(type(T=getopt(top))==2) T=strtoascii(rtostr(T))[0]-87;
585: else T=10;
586: for(;L!=[];L=cdr(L)){
587: for(J=0;J<36;J++){
588: if(findin(X=makev([car(L),J]|num=1),V)>=0){
589: while(findin(Y=makev([T]),V)>=0) T++;
590: if(T>35) return P;
591: P=subst(P,X,Y);
592: T++;
593: }else if(J>0) break;
594: }
595: }
596: return P;
597: }
598:
599: def vweyl(L)
600: {
601: if(type(L) == 4){
602: if(length(L) == 2)
603: return L;
604: else
605: return [L[0],makev(["d",L[0]])];
606: }
607: /* else if(type(L)<2) return L; */
608: return [L,makev(["d", L])];
609: }
610:
611: def mycat(L)
612: {
613: if(type(L) != 4){
614: print(L);
615: return;
616: }
617: Opt = getopt(delim);
618: Del = (type(Opt) >= 0)?Opt:" ";
619: Opt = getopt(cr);
620: CR = (type(Opt) >= 0)?0:1;
621: while(L != []){
622: if(Do==1)
623: print(Del,0);
624: print(car(L),0);
625: L=cdr(L);
626: Do = 1;
627: }
628: if(CR) print("");
629: }
630:
1.9 takayama 631: def fcat(S,X)
632: {
633: if(type(S)!=7){
1.18 takayama 634: if(type(DIROUTD)!=7){
635: DIROUTD=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],
636: [getenv("HOME"),get_rootdir(),"/"])+"/";
637: if(isMs()) DIROUTD=str_subst(DIROUTD,"/","\\"|sjis=1);
638: }
639: if(S==-1) return;
1.16 takayama 640: T="fcat";
641: if(S>=2&&S<=9) T+=rtostr(S);
642: T=DIROUTD+T+".txt";
643: if(S==-1) return T;
644: if(S!=0&&access(T)) remove_file(T);
645: S=T;
1.9 takayama 646: }
1.19 takayama 647: R=output(S);
1.9 takayama 648: print(X);
649: output();
1.16 takayama 650: if(getopt(exe)==1) shell("\""+S+"\"");
1.19 takayama 651: return R;
1.9 takayama 652: }
653:
1.6 takayama 654: def mycat0(L,T)
655: {
656: Opt = getopt(delim);
657: Del = (type(Opt) >= 0)?Opt:"";
1.20 takayama 658: if(type(L)!=4) L=[L];
1.6 takayama 659: while(L != []){
660: if(Do==1)
661: print(Del,0);
662: print(car(L),0);
663: L=cdr(L);
664: Do = 1;
665: }
666: if(T) print("");
667: }
668:
669: def findin(M,L)
670: {
671: if(type(L)==4){
672: for(I = 0; L != []; L = cdr(L), I++)
673: if(car(L) == M) return I;
674: }else if(type(L)==5){
675: K=length(L);
676: for(I = 0; I < K; I++)
677: if(L[I] == M) return I;
678: }else return -2;
679: return -1;
680: }
681:
682: def countin(S,M,L)
683: {
1.10 takayama 684: Step=getopt(step);
685: if(type(Step)==1){
686: N=(Step>0)?Step:-Step;
1.7 takayama 687: if(type(L)==5) L=vtol(L);
688: L=qsort(L);
689: while(car(L)<S&&L!=[]) L=cdr(L);
690: S+=M;
1.10 takayama 691: for(R=[],C=I=0;L!=[];){
692: if(car(L)<S||(Step>0&&car(L)==S)){
1.7 takayama 693: C++;
694: L=cdr(L);
695: }else{
696: R=cons(C,R);C=0;S+=M;
1.10 takayama 697: if(N>1&&++I>=N) break;
1.7 takayama 698: }
699: }
700: if(C>0) R=cons(C,R);
1.10 takayama 701: if(N>1&&(N-=length(R))>0) while(N-->0) R=cons(0,R);
1.7 takayama 702: return reverse(R);
703: }
1.6 takayama 704: if(type(L)==4){
705: for(N=0; L!=[]; L=cdr(L))
706: if(car(L)>=S && car(L)<=M) N++;
707: }else if(type(L)==5){
708: K=length(L);
709: for(I = 0; I < K; I++)
710: if(L[I]>=S && L[I]<=M) N++;
711: }else return -2;
712: return N;
713: }
714:
715: def mycoef(P,N,X)
716: {
717: if(type(P)<3 && type(N)<3)
718: return coef(P,N,X);
719: if(type(P) >= 4)
720: #ifdef USEMODULE
721: return map(os_md.mycoef,P,N,X);
722: #else
723: return map(mycoef,P,N,X);
724: #endif
725: if(type(N)==4){
726: for(;N!=[];N=cdr(N),X=cdr(X))
727: P=mycoef(P,car(N),car(X));
728: return P;
729: }
730: if(deg(dn(P), X) > 0){
731: P = red(P);
732: if(deg(dn(P), X) > 0)
733: return 0;
734: }
735: return red(coef(nm(P),N,X)/dn(P));
736: }
737:
738: def mydiff(P,X)
739: {
740: if(X == 0)
741: return 0;
742: if(type(P)<3 && type(X)<3)
743: return diff(P,X);
744: if(type(P) >= 4)
745: #ifdef USEMODULE
746: return map(os_md.mydiff,P,X);
747: #else
748: return map(mydiff,P,X);
749: #endif
750: if(type(X)==4){
751: for(;X!=[];X=cdr(X)) P=mydiff(P,car(X));
752: return P;
753: }
1.19 takayama 754: if(ptype(dn(P),X)<2)
1.6 takayama 755: return red(diff(nm(P),X)/dn(P));
756: return red(diff(P,X));
757: }
758:
759: def myediff(P,X)
760: {
761: if(X == 0)
762: return 0;
763: if(type(P) < 3)
764: return ediff(P,X);
765: if(type(P) >= 4)
766: #ifdef USEMODULE
767: return map(os_md.myediff,P,X);
768: #else
769: return map(myediff,P,X);
770: #endif
771: if(deg(dn(P),X) == 0)
772: return red(ediff(nm(P),X)/dn(P));
773: return red(X*diff(P,X));
774: }
775:
776: def m2l(M)
777: {
778: if(type(M) < 4)
779: return [M];
780: if(type(M) == 4){
781: if(type(car(M))==4 && getopt(flat)==1){
782: for(MM = []; M!=[]; M=cdr(M))
783: MM = append(MM,car(M));
784: return MM;
785: }
786: return M;
787: }
788: if(type(M) == 5)
789: return vtol(M);
790: S = size(M);
791: for(MM = [], I = S[0]-1; I >= 0; I--)
792: MM = append(vtol(M[I]), MM);
793: return MM;
794: }
795:
796: def mydeg(P,X)
797: {
798: if(type(P) < 3)
799: return deg(P,X);
800: II = -1;
801: Opt = getopt(opt);
802: if(type(P) >= 4){
803: S=(type(P) == 6)?size(P)[0]:0;
804: P = m2l(P);
805: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
806: if( (DT = mydeg(car(P),X)) == -2)
807: return -2;
808: if(DT > Deg){
809: Deg = DT;
810: II = I;
811: }
812: }
813: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
814: }
815: P = red(P);
816: if(deg(dn(P),X) == 0)
817: return deg(nm(P),X);
818: return -2;
819: }
820:
821: def pfctr(P,X)
822: {
823: P=red(P);
824: if((T=ptype(P,X))>3) return [];
825: if(T==3){
826: G=pfctr(dn(P),X);
827: F=pfctr(nm(P),X);
828: R=[[car(F)[0]/car(G)[0],1]];
829: for(F=cdr(F);F!=[];F=cdr(F)) R=cons(car(F),R);
830: for(G=cdr(G);G!=[];G=cdr(G)) R=cons([car(G)[0],-car(G)[1]],R);
831: return reverse(R);
832: }
833: F=fctr(nm(P));
834: for(R=[],C=1/dn(P);F!=[];F=cdr(F))
835: if(mydeg(car(F)[0],X)>0) R=cons(car(F),R);
836: else C*=car(F)[0]^car(F)[1];
837: return cons([C,1],reverse(R));
838: }
839:
840: def mymindeg(P,X)
841: {
842: if(type(P) < 3)
843: return mindeg(P,X);
844: II = -1;T=60;
845: Opt = getopt(opt);
846: if(type(P) >= 4){
847: S=(type(P) == 6)?size(P)[0]:0;
848: P = m2l(P);
849: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
850: if(car(P) == 0)
851: continue;
852: if( (DT = mydeg(car(P),X)) == -2)
853: return -2;
854: if(DT < Deg || Deg == -3){
855: if(DT==0){
856: if(type(car(P))>=T) continue;
857: T=type(car(P));
858: }
859: Deg = DT;
860: II = I;
861: }
862: }
863: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
864: }
865: P = red(P);
866: if(deg(dn(P),X) == 0)
867: return mindeg(nm(P),X);
868: return -2;
869: }
870:
871: def m1div(M,N,L)
872: {
873: L = (type(L) <= 3)?[0,L]:vweyl[L];
874: DX = L[1]; X = L[0];
875: if(mydeg(N,DX) != 0)
876: return 0;
877: DD = mydeg(M,DX);
878: MM = M;
879: while( (Deg=mydeg(MM,DX)) > 0){
880: MC = mycoef(MM,Deg,DX)*DX^(Deg-1);
881: MS = radd(MC, MS);
882: MM = radd(MM, muldo(MC,radd(-DX,N),L));
883: }
884: return [MM, MS];
885: }
886:
887:
888: def mulsubst(F,L)
889: {
890: N = length(L);
891: if(N == 0)
892: return F;
893: if(type(L[0])!=4) L=[L];
894: if(getopt(inv)==1){
895: for(R=[];L!=[];L=cdr(L)) R=cons([car(L)[1],car(L)[0]],R);
896: L=reverse(R);
897: }
898: if(length(L)==1) return mysubst(F,L);
899: L1 = newvect(N);
900: for(J = 0; J < N ; J++)
901: L1[J] = uc();
902: L2 = newvect(N);
903: for(J = 0; J < N; J++){
904: S = L[J][1];
905: for(I = 0; I < N; I++)
906: S = mysubst(S,[L[I][0],L1[I]]);
907: L2[J] = S;
908: }
909: for(J = 0; J < N; J++)
910: F = mysubst(F, [L[J][0],L2[J]]);
911: for(J = 0; J < N; J++)
912: F = mysubst(F, [L1[J],L[J][0]]);
913: return F;
914: }
915:
916: def cmpsimple(P,Q)
917: {
918: T = getopt(comp);
919: if(P == Q)
920: return 0;
921: D = 0;
922: if(type(T) < 0)
923: T = 7;
924: if(iand(T,1))
925: D = length(vars(P)) - length(vars(Q));
926: if(!D && iand(T,2))
927: D = nmono(P) - nmono(Q);
928: if(!D && iand(T,4))
929: D = str_len(rtostr(P)) - str_len(rtostr(Q));
930: if(!D){
931: if(P > Q) D++;
932: else D--;
933: }
934: return D;
935: }
936:
937: def simplify(P,L,T)
938: {
939: if(type(P) > 3)
940: #ifdef USEMODULE
941: return map(os_md.simplify,P,L,T);
942: #else
943: return map(simplify,P,L,T);
944: #endif
945: if(type(L[0]) == 4){
946: if(length(L[0]) > 1)
947: #if USEMODULE
948: return fmult(os_md.simplify,P,L,[T]);
949: #else
950: return fmult(simplify,P,L,[T]);
951: #endif
952: L = L[0];
953: }
954: if(type(Var=getopt(var)) == 4 && Var!=[]){
955: if(type(P) == 3)
956: return simplify(nm(P),P,L,T|var=Var)/simplify(dn(P),P,L,T|var=Var);
957: V = car(Var);
958: if((I = mydeg(P,V)) > 0){
959: Var = cdr(Var);
960: for(Q=0; I>=0 ; I--)
961: Q += simplify(mycoef(P,I,V), L, T|var=Var)*V^I;
962: return Q;
963: }
964: }
965: if(length(L) == 1){
966: L = car(L);
967: for(V = vars(L); V != []; V = cdr(V)){
968: VT = car(V);
969: if(deg(L,VT) != 1) continue;
970: P = simplify(P, [VT, -red(coef(L,0,VT)/coef(L,1,VT))], T);
971: }
972: return P;
973: }
974: Q = mysubst(P,[L[0],L[1]]);
975: return (cmpsimple(P,Q|comp=T) <= 0)?P:Q;
976: }
977:
978: def monotos(P)
979: {
980: if(nmono(P) <= 1)
981: return rtostr(P);
982: return "("+rtostr(P)+")";
983: }
984:
985:
986: def monototex(P)
987: {
988: Q=my_tex_form(P);
989: if(nmono(P)<2 && (getopt(minus)!=1 || str_str(Q,"-"|top=0,end=0)<0))
990: return Q;
991: return "("+Q+")";
992: }
993:
994: def minustos(S)
995: {
996: if(str_str(S,"-"|top=0,end=0)<0) return S;
997: return "("+S+")";
998: }
999:
1000: def vnext(V)
1001: {
1002: S = length(V);
1003: for(I = S-1; I > 0; I--){
1004: if(V[I-1] < V[I]){
1005: V0 = V[I-1];
1006: for(J = I+1; J < S; J++)
1007: if(V0 >= V[J]) break;
1008: V[I-1] = V[--J];
1009: V[J] = V0;
1010: for(J = S-1; I < J; I++, J--){
1011: V0 = V[I];
1012: V[I] = V[J];
1013: V[J] = V0;
1014: }
1015: return 1;
1016: }
1017: }
1018: return 0;
1019: }
1020:
1021: def ldict(N, M)
1022: {
1023: Opt = getopt(opt);
1024: R = S = [];
1025: for(I = 2; N > 0; I++){
1026: R = cons(irem(N,I), R);
1027: N = idiv(N,I);
1028: }
1029: L = LL = length(R);
1030: T=newvect(LL+1);
1031: while(L-- > 0){
1032: V = car(R); R = cdr(R);
1033: for(I = J = 0; J <= V ; I++){
1034: if(T[I] == 0)
1035: J++;
1036: }
1037: T[I-1] = 1;
1038: S = cons(LL-I+1, S);
1039: }
1040: for(I = 0; I <= LL; I++){
1041: if(T[I] == 0){
1042: S = cons(LL-I, S);
1043: break;
1044: }
1045: }
1046: if(M == 0)
1047: return S;
1048: if(M <= LL){
1049: print("too small size");
1050: return 0;
1051: }
1052: T = [];
1053: for(I = --M; I > LL; I--)
1054: T = cons(I,T);
1055: S = append(S,T);
1056: if(Opt == 2 || Opt == 3)
1057: S = reverse(S);
1058: if(Opt != 1 && Opt != 3)
1059: return S;
1060: for(T = []; S != []; S = cdr(S))
1061: T = cons(M-car(S),T);
1062: return T;
1063: }
1064:
1065: def ndict(L)
1066: {
1067: Opt = getopt(opt);
1068: R = [];
1069: if(Opt != 1 && Opt != 2)
1070: L = reverse(L);
1071: T = (Opt == 1 || Opt == 3)?1:0;
1072: for( ; L != []; L = cdr(L)){
1073: for(I = 0, V = car(L), LT = cdr(L); LT != []; LT = cdr(LT))
1074: if(T == 0){
1075: if(V < car(LT)) I++;
1076: }else if (V > car(LT)) I++;
1077: R = cons(I, R);
1078: }
1079: R = reverse(R);
1080: for(V = 0, I = length(R); I > 0; R = cdr(R), I--)
1081: V = V*I + car(R);
1082: return V;
1083: }
1084:
1085: def nextsub(L,N)
1086: {
1087: if(type(L) == 1){
1088: for(LL = [], I = L-1; I >= 0; I--)
1089: LL = cons(I,LL);
1090: return LL;
1091: }
1092: M = length(L = ltov(L));
1093: K = N-M;
1094: for(I = M-1; I >= 0; I--)
1095: if(L[I] < I+K) break;
1096: if(I < 0)
1097: return 0;
1098: for(J = L[I]+1; I < M; I++, J++)
1099: L[I] = J;
1100: return vtol(L);
1101: }
1102:
1103: def nextpart(L)
1104: {
1105: if(car(L) <= 1)
1106: return 0;
1107: for(I = 0, L = reverse(L); car(L) == 1; L=cdr(L))
1108: I++;
1109: I += (K = car(L));
1110: R = irem(I,--K);
1111: R = (R==0)?[]:[R];
1112: for(J = idiv(I,K); J > 0; J--)
1113: R = cons(K,R);
1114: L = cdr(L);
1115: while(L!=[]){
1116: R = cons(car(L), R);
1117: L = cdr(L);
1118: }
1119: return R;
1120: }
1121:
1122: def transpart(L)
1123: {
1124: L = reverse(L);
1125: for(I=1, R=[]; L!= []; I++){
1126: R = cons(length(L), R);
1127: while(L != [] && car(L) <= I)
1128: L = cdr(L);
1129: }
1130: return reverse(R);
1131: }
1132:
1133: def trpos(A,B,N)
1134: {
1135: S = newvect(N);
1136: for(I = 0; I < N; I++)
1137: S[I]=(I==A)?B:((I==B)?A:I);
1138: return S;
1139: }
1140:
1141: def sprod(S,T)
1142: {
1143: L = length(S);
1144: V = newvect(L);
1145: while(--L >= 0)
1146: V[L] = S[T[L]];
1147: return V;
1148: }
1149:
1150: def sinv(S)
1151: {
1152: L = length(S);
1153: V = newvect(L);
1154: while(--L >= 0)
1155: V[S[L]] = L;
1156: return V;
1157: }
1158:
1159: def slen(S)
1160: {
1161: L = length(S);
1162: for(V = 0, J = 2; J < L; i++){
1163: for(I = 0; I < J; I++)
1164: if(S[I] > S[J]) V++;
1165: }
1166: return V;
1167: }
1168:
1169: def sord(W,V)
1170: {
1171: L = length(W);
1172: W0 = nevect(L);
1173: V0 = newvect(L);
1174: for(I = F = C = 0; I < L; I++){
1175: C = 0;
1176: if( (W1 = W[I]) > (V1 = V[I]) ){
1177: if(F < 0) C = 1;
1178: else if(F==0) F = 1;
1179: }else if(W1 < V1){
1180: if(F > 0) C = 1;
1181: else if(F==0) F = -1;
1182: }
1183: for(J = I;--J >= 0 && W0[J] > W1; ) W0[J+1] = W0[J];
1184: W0[J+1] = W1;
1185: for(J = I;--J >= 0 && V0[J] > V1; ) V0[J+1] = V0[J];
1186: V0[J+1] = V1;
1187: if(C){
1188: for(J = I; J >= 0; J--){
1189: if((W1=W0[J]) == (V1=V0[J])) continue;
1190: if(W1 > V1){
1191: if(F < 0) return 2;
1192: }
1193: else if(F > 0) return 2;
1194: }
1195: }
1196: }
1197: return F;
1198: }
1199:
1200: def vprod(V1,V2)
1201: {
1202: for(R = 0, I = length(V1)-1; I >= 0; I--)
1203: R = radd(R, rmul(V1[I], V2[I]));
1204: return R;
1205: }
1206:
1207: def dnorm(V)
1208: {
1209: if(type(V)<2) return dabs(V);
1210: R=0;
1211: if(type(V)!=4)
1212: for (I = length(V)-1; I >= 0; I--) R+= V[I]^2;
1213: else{
1214: if(type(V[0])>3){
1215: V=ltov(V[0])-ltov(V[1]);
1216: return dnorm(V);
1217: }
1218: for(;V!=[]; V=cdr(V)) R+=car(V)^2;
1219: }
1220: return dsqrt(R);
1221: }
1222:
1223: def dvprod(V1,V2)
1224: {
1225: if(type(V1)<2) return V1*V2;
1226: R=0;
1227: if(type(V1)!=4)
1228: for(I = length(V1)-1; I >= 0; I--)
1229: R += V1[I]*V2[I];
1230: else{
1231: for(; V1!=[]; V1=cdr(V1),V2=cdr(V2))
1232: R+=car(V1)*car(V2);
1233: }
1234: return R;
1235: }
1236:
1237: def dvangle(V1,V2)
1238: {
1239: if(V2==0 && type(V1)==4 && length(V1)==3 &&
1240: (type(V1[0])==4 || type(V1[0])==5 || type(V1[1])==4 || type(V1[1])==5 ||
1241: type(V1[2])==4 || type(V1[2])==5) ){
1242: if(V1[0]==0 || V1[1]==0 || V1[2]==0) return 1;
1243: PV2=V1[1];
1244: if(type(PV2)==4){
1245: PV2=ltov(PV2);
1246: return dvangle(PV2-ltov(V1[0]),ltov(V1[2])-PV2);
1247: }else
1248: return dvangle(PV2-V1[0],V1[2]-PV2);
1249: }
1250: if((L1=dnorm(V1))==0 || (L2=dnorm(V2))==0) return 1;
1251: return dvprod(V1,V2)/(L1*L2);
1252: }
1253:
1254: def mulseries(V1,V2)
1255: {
1256: L = length(V1);
1257: if(size(V2) < L)
1258: L = size(V2);
1259: VV = newvect(L);
1260: for(J = 0; J < L; J++){
1261: for(K = R = 0; K <= J; K++)
1262: R = radd(R,rmul(V1[K],V2[J-K]));
1263: VV[J] = R;
1264: }
1265: return VV;
1266: }
1267:
1.13 takayama 1268: def scale(L)
1269: {
1.23 takayama 1270: T=F=0;LS=1;
1.18 takayama 1271: Pr=getopt(prec);
1.23 takayama 1272: Inv=getopt(inv);
1273: Log10=dlog(10);
1274: if(type(L)==7){
1275: V=findin(L,["CI","DI","CIF","CIF'","DIF","DIF'","SI","TI1","TI2","STI"]);
1276: if(V>=0){
1277: L=["C","D","CF","CF'","DF","DF'","S","T1","T2","ST"];
1278: Inv=1;L=L[V];
1279: }
1280: V=findin(L,["C","A","K","CF","CF'","S","T1","T2","ST","LL0","LL1","LL2","LL3","LL00",
1281: "LL01","LL02","LL03"])+1;
1282: if(V==0) V=findin(L,["D","B","K","DF","DF'"])+1;
1283: if(V>0) L=V;
1284: }
1285: if(type(OL=L)!=4){
1.15 takayama 1286: if(L==2){
1.23 takayama 1287: L=(Pr==0)?
1.18 takayama 1288: [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2]],
1.15 takayama 1289: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5]],
1.18 takayama 1290: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10]]]:
1291: [[[1,2,1/50],[2,5,1/20],[5,10,1/10], [10,20,1/5],[20,50,1/2],[50,100,1]],
1292: [[1,5,1/10],[5,10,1/2], [10,20,1],[50,100,5]],
1293: [[1,5,1/2],[5,10,1], [10,50,5],[50,100,10]]];
1.23 takayama 1294: LS=2;M2=[[1,10,1],[10,100,10]];
1.15 takayama 1295: }else if(L==3){
1.23 takayama 1296: L=(Pr==0)?
1.18 takayama 1297: [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2],
1298: [100,200,5],[200,500,10],[500,1000,20]],
1.15 takayama 1299: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5], [100,200,10],[200,500,50]],
1.18 takayama 1300: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10], [100,200,50],[200,1000,100]]]:
1301: [[[1,2,1/50],[2,5,1/20],[5,10,1/10],[10,20,1/5],[20,50,1/2],[50,100,1],
1302: [100,200,2],[200,500,5],[500,1000,10]],
1303: [[1,5,1/10],[5,10,1/2], [10,50,1],[50,100,5], [100,500,10],[500,1000,50]],
1.23 takayama 1304: [[1,5,1/2],[5,10,1],[10,50,5],[50,100,10], [100,500,50],[500,1000,100]]];
1305: LS=3;M2=[[1,5,1],[10,50,10],[100,500,100],[500,1000,500]];
1306: }else if(L>9&&L<18){
1.26 takayama 1307: if(L<18){ /* LL0 - LL3, LL00 - LL03 */
1.23 takayama 1308: if(L==10){
1309: L=[ [[1.001,1.002,0.00001],[1.002,1.005,0.00002],[1.005,1.0105,0.00005]],
1310: [[1.001,1.002,0.00005],[1.002,1.005,0.0001], [1.005,1.0105,0.0001]],
1311: [[1.001,1.002,0.0001],[1.002,1.005,0.0005], [1.005,1.0105,0.0005]]];
1312: M2=[1.001,1.0015,1.002,1.003,1.004,1.005,1.006,1.007,1.008,1.009,1.01];
1313: }
1314: if(L==11){
1315: L=[ [[1.01,1.02,0.0001],[1.02,1.05,0.0002],[1.05,1.105,0.0005]],
1316: [[1.01,1.02,0.0005],[1.02,1.05,0.001], [1.05,1.105,0.001]],
1317: [[1.01,1.02,0.001],[1.02,1.05,0.005], [1.05,1.105,0.005]]];
1318: M2=[1.01,1.015,1.02,1.03,1.04,1.05,1.06,1.07,1.08,1.09,1.10];
1319: }else if(L==12){
1320: 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],
1321: [2.5,2.72,0.02]],
1322: [[1.105,1.2,0.005],[1.2,1.4,0.01],[1.4,1.8,0.01],[1.8,2.5,0.05],
1323: [2.5,2.72,0.1]],
1324: [[1.105,1.2,0.01],[1.2,1.4,0.05],[1.4,1.8,0.05],[1.8,2.5,0.1],
1325: [2.5,2.72,0.1]]];
1.26 takayama 1326: 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];
1.23 takayama 1327: }else if(L==13){
1328: 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],
1329: [50,100,2],[100,200,5],[200,400,10],[400,500,20],[500,1000,50],
1330: [1000,2000,100],[2000,5000,200],[5000,10000,500],[10000,22000,1000]],
1331: [[2.7,4,0.1],[4,6,0.1],[6,10,0.5],[10,15,1],[15,30,1],[30,50,5],
1332: [50,100,10],[100,200,10],[200,400,50],[400,500,100],[500,1000,100],
1333: [1000,2000,500],[2000,5000,1000],[5000,10000,1000],[10000,22000,5000]],
1334: [[3,4,0.5],[4,6,0.5],[6,10,1],[10,15,5],[15,30,5],[30,50,10],
1335: [50,100,50],[100,200,50],[200,400,100],[400,500,100],[500,1000,500],
1336: [1000,2000,1000],[2000,5000,3000],[5000,10000,5000],[10000,22000,10000]]];
1337: M2=[3,4,5,6,7,8,9,10,15,20,30,40,50,100,200,500,1000,2000,5000,10000,20000];
1338: }else if(L==14){
1.26 takayama 1339: L=[ [[0.998,0.999,0.00001],[0.995,0.998,0.00002],[0.99,0.995,0.00005]],
1340: [[0.998,0.999,0.00005],[0.995,0.998,0.0001],[0.99,0.995,0.0001]],
1341: [[0.998,0.999,0.0001],[0.995,0.998,0.0005],[0.99,0.995,0.0005]]];
1.23 takayama 1342: M2=[0.999,0.9985,0.998,0.997,0.996,0.995,0.994,0.993,0.992,0.991,0.99];
1343: }else if(L==15){
1.26 takayama 1344: L=[ [[0.98,0.9901,0.0001],[0.95,0.98,0.0002],[0.905,0.95,0.0005]],
1345: [[0.98,0.99,0.0005],[0.95,0.98,0.001], [0.905,0.95,0.001]],
1.23 takayama 1346: [[0.98,0.99,0.001],[0.95,0.98,0.005], [0.91,0.95,0.005]]];
1347: M2=[0.99,0.985,0.98,0.97,0.96,0.95,0.94,0.93,0.92,0.91];
1348: }else if(L==16){
1.26 takayama 1349: L=[ [[0.8,0.906,0.001],[0.6,0.8,0.002],[0.37,0.6,0.005]],
1350: [[0.8,0.906,0.005],[0.6,0.8,0.01],[0.37,0.6,0.01]],
1351: [[0.8,0.9,0.01],[0.6,0.8,0.05],[0.4,0.6,0.05]]];
1352: M2=[0.9,0.85,0.8,0.75,0.7,0.65,0.6,0.55,0.5,0.45,0.4];
1.23 takayama 1353: }else{
1.26 takayama 1354: L=[ [[0.05,0.37,0.002],[0.02,0.05,0.001],[0.01,0.02,0.0005],
1355: [0.005,0.01,0.0002],[0.001,0.005,0.0001],
1356: [0.0005,0.001,0.00002],[0.0001,0.0005,0.00001],[0.00005,0.0001,0.000002]],
1357: [[0.05,0.37,0.01],[0.02,0.05,0.002],[0.01,0.02,0.001],
1358: [0.005,0.01,0.001],[0.001,0.005,0.0002],
1359: [0.0005,0.001,0.0001],[0.0001,0.0005,0.00002],[0.00005,0.0001,0.00001]],
1360: [[0.05,0.37,0.05],[0.02,0.05,0.01],[0.01,0.02,0.005],
1361: [0.005,0.01,0.005],[0.002,0.005,0.001],
1362: [0.0005,0.001,0.0005],[0.0001,0.0005,0.0001],[0.00005,0.0001,0.00005]]];
1363: 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];
1.23 takayama 1364: }
1365: }
1.15 takayama 1366: }else{
1.23 takayama 1367: if(L==6){ /* S */
1368: 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]],
1369: [[6-1/6,15,1/6],[15,30,1/2],[30,70,1],[70,80,5],[80,90,10]],
1370: [[6,15,1/2],[15,30,1],[30,70,5],[70,90,10]] ];
1371: M2=[6,7,8,9,10,15,20,30,40,50,60,70,90];
1372: }else if(L==7){ /* T1 */
1373: F=log(tan(x*3.1416/180))/Log10+1;
1374: L=[ [[6-1/3,15,1/12],[15,45,1/6]],
1375: [[6-1/3,15,1/6],[15,45,1/2]],
1376: [[6,45,1]] ];
1377: M2=[6,7,8,9,10,15,20,30,40,45];
1378: }else if(L==8){ /* T2 */
1379: L=[ [[45,75,1/6],[75,84+1/6,1/12]],
1380: [[45,75,1],[75,84+1/6,1/6]],
1381: [[45,84,1]] ];
1382: M2=[45,50,60,70,75,80,81,82,83,84];
1383: }else if(L==9){ /* ST */
1384: L=[ [[35/60,1,1/120],[1,2,1/60],[2,5+9/12,1/30]],
1385: [[35/60,1,1/60],[1,2,1/6],[2,5+9/12,1/6]],
1386: [[40/60,1,1/6],[1,2,1/2],[2,5+9/12,1]] ];
1387: M2=[1,2,3,4,5];
1388: }else{
1389: M2=(L==4||L==5)?[[1,2,1/2],[2,9,1]]:[[1,2,1/2],[2,10,1]];
1390: L=(Pr==0)?
1391: [ [[1,2,1/50],[2,5,1/20],[5,10,1/10]],
1392: [[1,5,1/10],[5,10,1/2]],
1393: [[1,5,1/2],[5,10,1]] ]:
1394: [[[1,2,1/100],[2,5,1/50],[5,10,1/20]],
1395: [[1,2,1/20],[2,10,1/10]],
1396: [[1,2,1/10],[2,10,1/2]] ];
1397: }
1.15 takayama 1398: }
1399: }else if(type(L[0])!=4){
1400: L=[L];
1401: if(length(L)!=3||L[0]+L[2]>L[1]) T=L;
1.13 takayama 1402: }
1.15 takayama 1403: if(T==0){
1404: if(type(L[0][0])!=4) L=[L];
1405: for(R=[];L!=[];L=cdr(L)){
1406: for(RR=[],LT=car(L);LT!=[];LT=cdr(LT))
1407: for(I=car(LT)[0];I<=car(LT)[1];I+=car(LT)[2]) RR=cons(I,RR);
1408: RR=lsort(RR,[],1);
1409: R=cons(RR,R);
1410: }
1411: R=reverse(R);
1412: for(T=[];R!=[];R=cdr(R)){
1413: if(length(R)>1) T=cons(lsort(R[0],R[1],"setminus"),T);
1414: else T=cons(R[0],T);
1415: }
1.13 takayama 1416: }
1417: V0=dlog(10);
1418: S0=S1=1;D0=D1=0;
1419: SC=getopt(scale);
1420: if(type(SC)==4){
1421: S0=SC[0];S1=SC[1];
1.18 takayama 1422: }else if(type(SC)==1){
1423: S0=SC;S1=0;
1.13 takayama 1424: }else return T;
1425: if(type(D=getopt(shift))==4){
1426: D0=D[0];D1=D[1];
1.31 takayama 1427: }else if(type(D)<2&&type(D)>=0){
1.23 takayama 1428: D0=0;D1=D;
1.31 takayama 1429: };
1.23 takayama 1430: if(Inv==1){
1431: D0+=S0;S0=-S0;
1.13 takayama 1432: }
1.23 takayama 1433: if(type(TF=getopt(f))>1) F=TF;
1434: if(F) F=f2df(F);
1435: if(type(I=getopt(ol))==1&&OL>3) OL=I;
1.18 takayama 1436: for(M=M0=[],I=length(T);T!=[];T=cdr(T),I--){
1.13 takayama 1437: for(S=car(T);S!=[];S=cdr(S)){
1.23 takayama 1438: VS=car(S);
1439: if(F) V=myfdeval(F,car(S));
1440: else if(OL==4) V=frac(dlog(VS)/Log10+0.5);
1441: else if(OL==5) V=frac(dlog(VS*3.1416)/Log10);
1442: else if(OL>5&&OL<10){
1443: VS=VS*3.1416/180;
1444: if(OL==6) V=dlog(dsin(VS))/Log10+1;
1445: else if(OL==9) V=dlog(VS)/Log10+2;
1446: else V=dlog(dtan(VS))/Log10+8-OL;
1447: }
1448: else if(OL>9&&OL<14) V=dlog(dlog(VS))/Log10+13-OL;
1449: else if(OL>13&&OL<18) V=dlog(-dlog(VS))/Log10+17-OL;
1450: else V=dlog(VS)/Log10/LS;
1451: V*=S0;
1.13 takayama 1452: if(S1!=0){
1453: M=cons([V+D0,D1],M);
1.23 takayama 1454: M=cons([V+D0,((length(SC)>2)?SC[I]:(I*S1))+D1],M);
1.13 takayama 1455: M=cons(0,M);
1.18 takayama 1456: }else M0=cons(V+D0,M0);
1.13 takayama 1457: }
1.18 takayama 1458: if(S1==0) M=cons(reverse(M0),M);
1.13 takayama 1459: }
1460: if(S1!=0) M=cdr(M);
1.18 takayama 1461: if(S1==0||getopt(TeX)!=1) return M;
1.13 takayama 1462: M=reverse(M);
1.23 takayama 1463: if(type(U=getopt(line))==4){
1464: if(Inv==1) U=[U[0]+S0,U[1]+S0];
1.18 takayama 1465: M=cons([U[0]+D0,D1],cons([U[1]+D0,D1],cons(0,M)));
1.23 takayama 1466: }
1467: if((VT=getopt(vert))==1){
1468: for(N=[];M!=[];M=cdr(M)){
1469: if(type(TM=car(M))==4) N=cons([TM[1],TM[0]],N);
1470: else N=cons(TM,N);
1471: }
1472: M=reverse(N);
1473: }
1.18 takayama 1474: if(type(Col=getopt(col))<1) S=xylines(M);
1475: else S=xylines(M|opt=Col);
1476: if(type(Mes=getopt(mes))==4){
1.23 takayama 1477: if(length(Mes)==1&&type(M2)==4) Mes=cons(car(Mes),M2);
1.18 takayama 1478: S3=car(Mes);
1479: if(type(S3)==4){
1480: Col=S3[1];
1481: S3=car(S3);
1482: }else Col=0;
1483: V=car(scale(cdr(Mes)));
1.23 takayama 1484: if(!F) Mes=scale(cdr(Mes)|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1.18 takayama 1485: else Mes=scale(cdr(Mes)|f=F,scale=[S0,0],shift=[D0,D1]);
1486: for(M=car(Mes);M!=[];M=cdr(M),V=cdr(V)){
1.23 takayama 1487: TV=deval(car(V));
1488: if(Col!=0) TV=[Col,TV];
1489: S+=(VT==1)?xyput([S3+D1,car(M),TV]):xyput([car(M),S3+D1,TV]);
1490: }
1491: }
1492: if(type(Mes=getopt(mes2))==4){
1493: if(type(car(Mes))!=4) Mes=[Mes];
1494: for(;Mes!=[];Mes=cdr(Mes)){
1495: TM=car(Mes);
1496: if(!F) V=scale([car(TM)]|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1497: else V=scale([car(TM)]|f=F,scale=[S0,0],shift=[D0,D1]);
1498: V=car(car(V));
1499: TM=cdr(TM);
1500: if(type(Col=car(TM))==4){
1501: C0=Col[0];C1=Col[1];
1502: if(length(Col)==3){
1503: S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]|opt=Col[2])
1504: :xyline([V,D1+C0],[V,D1+C1]|opt=Col[2]);
1505: }else S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]):xyline([V,D1+C0],[V,D1+C1]);
1506: }
1507: if(type(TM[1]<2)){
1508: TM=cdr(TM);
1509: S3=car(TM);
1510: }
1511: S+=(VT==1)?xyput([S3+D1,V,TM[1]]):xyput([V,S3+D1,TM[1]]);
1.13 takayama 1512: }
1513: }
1.18 takayama 1514: return S;
1.13 takayama 1515: }
1516:
1.6 takayama 1517: def pluspower(P,V,N,M)
1518: {
1519: RR = 1;
1520: for(K = R = 1; K < M-1; I++){
1521: R = R*(N-K+1)*P/K;
1522: RR = radd(RR,R);
1523: }
1524: VV = newvect(M);
1525: for(K = 0; K < M-1; K++)
1526: VV[K] = red(mycoef(RR,K,V));
1527: }
1528:
1529: def vtozv(V)
1530: {
1531: if(type(V)<4) V=newvect(1,[V]);
1532: S = length(V);
1533: VV = newvect(S);
1534: Lcm = 1;
1535: for(K = 0; K < S; K++){
1536: VV[K] = red(V[K]);
1537: Lcm = lcm(Lcm,dn(VV[K]));
1538: C = ptozp(nm(VV[K])|factor=0);
1539: if(K == 0){
1540: Dn = dn(C[1]);
1541: Nm = nm(C[1]);
1542: PNm = nm(C[0]);
1543: }else{
1544: Dn = ilcm(Dn,dn(C[1]));
1545: Nm = igcd(Nm,nm(C[1]));
1546: PNm = gcd(PNm,nm(C[0]));
1547: }
1548: }
1549: if(!(M=Nm*PNm)) return [VV,0];
1550: Mul = (Lcm*Dn)/M;
1551: for(K = 0; K < S; K++)
1552: VV[K] = rmul(VV[K],Mul);
1553: return [VV,Mul];
1554: }
1555:
1556: def dupmat(M)
1557: {
1558: if(type(M) == 6){
1559: Size = size(M);
1560: MM = newmat(Size[0],Size[1]);
1561: for(I = 0; I < Size[0]; I++){
1562: for(J = 0; J < Size[1]; J++)
1563: MM[I][J] = M[I][J];
1564: }
1565: return MM;
1566: }
1567: if(type(M) == 5)
1568: return ltov(vtol(M));
1569: return M;
1570: }
1571:
1572: def matrtop(M)
1573: {
1574: S = size(M);
1575: MM = dupmat(M);
1576: Lcm = newvect(S[0]);
1577: for(J = 0; J < S[0]; J++){
1578: U = vtozv(M[J]);
1579: for(K = -1, I = 0; I < S[1]; I++)
1580: MM[J][I] = U[0][I];
1581: Lcm[J] = U[1];
1582: }
1583: return [MM,Lcm];
1584: }
1585:
1586: def mytrace(M)
1587: {
1588: S=size(M);
1589: if(S[0]!=S[1]) return 0;
1590: for(I=V=0; I<S[0]; I++){
1591: V+=M[I][I];
1592: }
1593: return V;
1594: }
1595:
1596: def mydet(M)
1597: {
1598: MM = matrtop(M);
1599: if(type(MM[0]) == 6){
1600: S = size(M);
1601: for(Dn = 1, I = 0; I < S[0]; I++)
1602: Dn *= MM[1][I];
1603: return (!Dn)?0:red(det(MM[0])/Dn);
1604: }
1605: }
1606:
1607: def mperm(M,P,Q)
1608: {
1609: if(type(M) == 6){
1610: S = size(M);
1611: if(type(P) <= 1)
1612: P=(P==1)?Q:trpos(0,0,S[0]);
1613: if(type(P) > 3 && type(P[0]) >= 4)
1614: P = trpos(P[0][0],P[0][1],S[0]);
1615: else if(type(P) == 4){
1616: if(length(P)==2 && type(P[1])==4){
1617: P0=P[0];P1=car(P[1]);P=newvect(P1);
1618: for(I=0;I<P1;I++) P[I]=P0+I;
1619: }else P = ltov(P);
1620: }
1621: if(type(Q) <= 1)
1622: Q=(Q==1)?P:trpos(0,0,S[1]);
1623: if(type(Q) > 3 && type(Q[0]) >= 4)
1624: Q = trpos(Q[0][0],Q[0][1],S[1]);
1625: if(type(Q) == 4){
1626: if(length(Q)==2 && type(Q[1])==4){
1627: P0=Q[0];P1=car(Q[1]);Q=newvect(P1);
1628: for(I=0;I<P1;I++) Q[I]=P0+I;
1629: }else Q = ltov(Q);
1630: }
1631: MM = newmat(S0=length(P),S1=length(Q));
1632: for(I = 0; I < S0; I++){
1633: MMI = MM[I]; MPI = M[P[I]];
1634: for(J = 0; J < S1; J++)
1635: MMI[J] = MPI[Q[J]];
1636: }
1637: return MM;
1638: }
1639: if((type(M) == 5 || type(M) == 4) && type(P) >= 4){
1640: if(length(P) == 1 && type(car(P)) == 4)
1641: P = trpos(car(P)[0],car(P)[1],length(M));
1642: MM = newvect(S = length(P));
1643: for(I = 0; I < S; I++)
1644: MM[I] = M[P[I]];
1645: if(type(M) == 4)
1646: MM = vtol(MM);
1647: return MM;
1648: }
1649: return M;
1650: }
1651:
1652: def mtranspose(M)
1653: {
1654: if(type(M)==4){
1655: MV=ltov(M);
1656: II=length(MV);
1657: for(I=L=0; I<II; I++){
1658: if(type(MV[I])!=4) return M;
1659: MV[I]=ltov(MV[I]);
1660: }
1661: for(R=[],J=0; ;J++){
1662: for(T=[],I=F=0; I<II; I++){
1663: if(length(MV[I])>J){
1664: F=1;
1665: T=cons(MV[I][J],T);
1666: }
1667: }
1668: if(F==0) return reverse(R);
1669: if(F==1) R=cons(reverse(T),R);
1670: }
1671: }
1672: if(type(M) != 6)
1673: return M;
1674: S = size(M);
1675: MM = newmat(S[1],S[0]);
1676: for(I = 0; I < S[0]; I++){
1677: for(J = 0; J < S[1]; J++)
1678: MM[J][I] = M[I][J];
1679: }
1680: return MM;
1681: }
1682:
1683: def mtoupper(MM, F)
1684: {
1685: TeXs=["\\ -=\\ ","\\ +=\\ "];
1686: Lins=[" -= line"," += line"];
1687: Assume=["If","Assume"];
1688: if(type(St = getopt(step))!=1) St=0;
1689: Opt = getopt(opt);
1690: if(type(Opt)!=1) Opt=0;
1.40 ! takayama 1691: if(type(Main=getopt(main))!=1) Main=0;
1.6 takayama 1692: TeX=getopt(dviout);
1693: if(type(Tab=getopt(tab))!=1 && Tab!=0) Tab=2;
1694: Line="\\text{line}";
1695: if(type(TeX)!=1 || !St) TeX=0;
1696: Size = size(MM);
1697: if(F==-1){
1698: M = newmat(Size[0], Size[1]+1);
1699: for(I = 0; I < Size[0]; I++){
1700: for(J = 0; J < Size[1]; J++)
1701: M[I][J] = MM[I][J];
1702: M[I][Size[1]] = zz^I;
1703: }
1704: Size = size(M);
1705: F = 1;
1706: }else if(F<0){
1707: F=Size[0];
1708: M = newbmat(1,2,[[MM,mgen(F,0,[1],0)]]);
1709: Size=[Size[0],F+Size[1]];
1710: }else
1711: M = dupmat(MM);
1712: if(St){
1713: if(TeX) Lout=[[dupmat(M)]];
1714: else mycat0([M,"\n\n"],0);
1715: }
1716: Top="";
1717: if(Opt>3){
1718: for(I=Opt; I>4; I--)
1719: Top+=(TeX)?"\\ ":" ";
1720: }
1721: PC=IF=1;
1.40 ! takayama 1722: if(Opt>3){
! 1723: for(P=[1],K=0;K<Size[1]-F;K++){
! 1724: for(J=0;J<Size[0];J++)
! 1725: if(type(dn(M[J][K]))==2) P=cons(dn(M[J][K]),P);
! 1726: }
! 1727: PC=llcm(P|poly=1);
! 1728: }
1.6 takayama 1729: for(K = JJ = 0; K < Size[1] - F; K++){
1730: for(J = JJ; J < Size[0]; J++){
1731: if(M[J][K] != 0){ /* search simpler element */
1732: if(Opt>2 && (Mul=M[J][K])!=1){
1733: for(FF=0,JT=J; JT<Size[0]; JT++){
1734: if((Val=M[JT][K])==1){ /* 1 */
1735: Mul=1;J=JT; break;
1736: }
1737: if(Val==0 || type(Val)>type(Mul)) continue;
1738: if(type(Val)<type(Mul) || (Val==-1 && Mul!=-1)){
1739: Mul=Val; J=JT; /* smaller type */
1740: }
1741: else if(Opt>3){
1742: if(isint(Val)==1){ /* integer elememt */
1743: if(isint(Mul)!=1){
1744: Mul=Val; J=JT; /* integer */
1745: }
1746: if(FF<3||(FF==3&&Val>0)){
1747: for(JK=K+1;;){
1748: if(JK>=Size[1]-F){
1749: J=JT;
1750: FF=((Mul=Val)>0)?4:3;
1751: break; /* divisible int => 4: pos_int 3: neg_int */
1752: }
1753: if(isint(M[JT][JK++]/Val)!=1) break;
1754: }
1755: }
1756: }else if(!FF){
1757: for(JK=K+1; JK<Size[1]-F; JK++){
1758: if(isint(M[JT][JK]/Val)!=1) break;
1759: J=JT; FF=1; /* divisible => 1: non integer */
1760: }
1761: }
1762: }
1763: }
1764: if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){ /* FF > 0 => divisible */
1765: for(FF=0,J0=J; J0<Size[0]-1 && FF!=9; J0++){
1766: VV0=M[J0][K];
1767: if(VV0==0 || isint(VV0)==0) continue;
1768: for(J1=J0+1;J1<Size[0] && FF!=9; J1++){
1769: VV1=M[J1][K];
1770: if(VV1==0 || isint(VV1)==0) continue;
1771: for(C=FT=0,V0=VV0,V1=VV1; C<2 && FF!=10; C++,V1=V0,V0=VV1){
1772: for(CC=0,RC=ceil(V0/V1);CC<2;CC++,RC--){
1773: if((CD=V0-RC*V1)==0 && (RC==1 || RC==-1)){
1774: FT=1; FF=10; /* 10: vanish by +- */
1775: }else if(CD==1){
1776: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1777: if((RC==1 || RC==-1) && FF<8+FV){
1778: FT=1; FF=8+FV; /* 8/9: 1 by +- */
1779: }else if(FF<6+VF){
1780: FT=1; FF=6+FV; /* 6/7: 1 by times */
1781: }
1782: }else if(CD==-1){
1783: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1784: if((RC==1 || RC==-1) && FF<4+FV){
1785: FT=1; FF=4+FV; /* 4/5: 1 by +- */
1786: }else if(FF<2+VF){
1787: FT=1; FF=2+FV; /* 2/3: 1 by times */
1788: }
1789: }
1790: if(FT==1){
1791: FT=0; KRC=RC;
1792: if(C==0){
1793: KJ0=J0; KJ1=J1;
1794: }else{
1795: KJ0=J1; KJ1=J0;
1796: }
1797: }
1798: }
1799: }
1800: }
1801: }
1802: if(FF>0){
1803: for(I=K;I<Size[1];I++)
1804: M[KJ0][I]=radd(M[KJ0][I],rmul(M[KJ1][I],-KRC));
1805: if(KRC<0){
1806: KRC=-KRC;Sgn=1;
1807: }else
1808: Sgn=0;
1.40 ! takayama 1809: if(St&&!Main){
1.6 takayama 1810: if(TeX){
1811: if(KRC==1)
1812: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1813: Line,KJ1+1,"}",dupmat(M)],Lout);
1814: else
1815: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1816: Line,KJ1+1,"\\times\\left(",KRC,"\\right)}",
1817: dupmat(M)],Lout);
1818:
1819: }else{
1820: if(KRC==1)
1821: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1,"\n",M,"\n"]); else
1822: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1," * (",KRC,")\n",M,"\n"]);
1823: }
1824: }
1825: Mul=M[KJ0][K]; J=KJ0;
1826: if(FF==10){
1827: J--; continue;
1828: }
1829: }
1830: }
1831: }
1832: /* a parameter Var */
1833: Var=0;
1.40 ! takayama 1834: /* mycat(["start",J,K]); */
1.6 takayama 1835: if(St && Opt>4 && length(Var=vars(nm(M[J][K])))==1){
1836: J0=J;Jv=mydeg(nm(M[J0][K]),car(Var));
1837: for(I=JJ;I<Size[0]; I++){
1838: if((MIK=M[I][K])==0) continue;
1839: if((T=vars(MIK=nm(MIK)))==[]){ /* 1/poly */
1840: J=I;Var=[]; break;
1841: }
1842: if(length(T)>1) continue;
1843: if(mydeg(MIK,T[0])<Jv){
1.39 takayama 1844: J0=I;Jv=mydeg(MIK,T[0]);Var=T; /* search minimal degree */
1.6 takayama 1845: }
1846: }
1847: if(length(Var)==1){
1848: Var=car(Var);
1849: Q=nm(M[J0][K]);
1.40 ! takayama 1850: /* mycat(["min",Q,M[J0][K],"J0=",J0,"J=",J,"JJ=",JJ,K,M]); */
! 1851: J=J0;
1.6 takayama 1852: for(I=JJ; I<Size[0]; I++){
1853: if(I==J0 || mydeg(nm(M[I][K]),Var)<0) continue;
1854: T=rpdiv(nm(M[I][K]),Q,Var);
1855: if(T[0]!=0 && (vars(T)==[] || vars(T)==[Var])) break; /* dec. deg */
1856: }
1857: }
1858: }
1859: if(type(Var)==2){ /* 1 variable */
1860: if(I==Size[0]){
1861: for(QF=0,Q0=1,QR=getroot(Q,Var|mult=1);QR!=[];QR=cdr(QR)){
1.40 ! takayama 1862: /* mycat(["root",Q,QR,PC]); */
1.6 takayama 1863: if(deg(T=QR[0][1],Var)>0){
1864: QF=1;Q0*=T; continue;
1865: }
1866: if(subst(PC,Var,T)==0) continue;
1867: Q0*=(Var-(T=QR[0][1]));
1868: if(type(T)<2){
1869: M0=subst(M,Var,T);
1870: if(TeX){
1871: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1872: Var,"=",T,","] ,Lout);
1.40 ! takayama 1873: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),Lout);
1.6 takayama 1874: }else{
1875: mycat([str_times(" ",St-1)+"If",Var,"=",T,","]);
1.40 ! takayama 1876: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 1877: }
1878: }
1879: }
1880: if(Q0!=1){
1881: if(TeX)
1882: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[QF]+" }",
1883: Q0/=fctr(Q0)[0][0],"\\ne0,"],Lout);
1884: else
1885: mycat([str_times(" ",St-1)+Assume[QF],Q0,"!=0,"]);
1886: PC*=Q0;
1887: }
1888: IF=0;St++;
1889: }else{
1890: KRC=-red((T[2]*dn(M[J0][K]))/(T[1]*dn(M[I][K])));
1891: for(II=K;II<Size[1];II++)
1892: M[I][II]=radd(M[I][II],rmul(M[J0][II],KRC));
1.40 ! takayama 1893: if(!Main){
! 1894: if(TeX)
! 1895: Lout=cons([Top+"\\xrightarrow{", Line,I+1,"\\ +=\\ ",Line,
! 1896: J0+1,"\\times\\left(",KRC,"\\right)}",dupmat(M)],Lout);
! 1897: else
! 1898: mycat([Top+"line",I+1,"+=",Line,J0+1," * (",KRC,")\n",M,"\n"]);
! 1899: }
1.6 takayama 1900: J=JJ-1;
1901: continue;
1902: }
1903: }
1904: if(J != JJ){
1905: for(I = K; I < Size[1]; I++){
1906: Temp = M[JJ][I];
1907: M[JJ][I] = M[J][I];
1908: M[J][I] = (Opt>=2)?Temp:-Temp;
1909: }
1910: if(St){
1911: if(TeX)
1912: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\leftrightarrow\\ ",
1913: Line,J+1,"}",dupmat(M)],Lout);
1914: else
1915: mycat0([Top+"line",JJ+1," <-> line",J+1,"\n",M,"\n\n"],0);
1916: }
1917: }
1918: /* Assume PC != 0 */
1919: if(Opt>1){
1920: Mul = M[JJ][K];
1921: if(Opt > 5 && St && IF && (Var=vars(MIK=nm(Mul)))!=[]){
1922: TF=fctr(MIK);
1923: for(FF=0,Q0=1,TP=cdr(TF);TP!=[];TP=cdr(TP)){
1924: if(type(dn(red(PC/(TP0=car(car(TP))))))<2) continue; /* divisible */
1925: Q0*=TP0;
1926: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
1927: if(mydeg(TP0,X=car(Var))==1 && type(dn(red(PC/mycoef(TP0,1,X))))<2){
1928: /* TP0=A*X+B with non-vanishing A */
1929: T=red(-mycoef(TP0,0,X)/mycoef(TP0,1,X));
1930: M0=mysubst(M,[X,T]);
1931: if(TeX){
1932: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1933: X,"=",T,","] ,Lout);
1.40 ! takayama 1934: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 1935: Lout);
1936: }else{
1937: mycat([str_times(" ",St-1)+"If",X,"=",T,","]);
1.40 ! takayama 1938: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 1939: }
1940: break;
1941: }
1942: }
1943: if(Var==[] && Opt>6){
1944: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
1945: if(mydeg(TP0,X=car(Var))==1){
1946: /* TP0=A*X+B, A is a poly of X0 with rational funct */
1947: T=nm(mycoef(TP0,1,X));
1948: for(Var0=vars(T);Var0!=[]; Var0=cdr(Var0)){
1949: X0=car(Var0);
1950: if(type(dn(red(PC/type(mycoef(T,mydeg(T,X0),X0)))))>1) continue;
1951: TR=getroot(T,X0|mult=1);
1952: if(findin(X0,vars(TR))<0) break;
1953: }
1954: if(Var0==[]) continue;
1955: for(;TR!=[0];TR=cdr(TR)){
1956: if(TR==[]){
1957: TR=[0,0];
1958: T0=-mycoef(TP0,0,X)/mycoef(TP0,1,X);
1959: X0=X;
1960: }else T0=car(TR)[1];
1961: M0=mysubst(M,[X0,T0]);
1962: if(TeX){
1963: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1964: X0,"=",T0,","] ,Lout);
1.40 ! takayama 1965: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 1966: Lout);
1967: }else{
1968: mycat([str_times(" ",St-1)+"If",X0,"=",T0,","]);
1.40 ! takayama 1969: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 1970: }
1971: }
1972:
1973: }
1974: break;
1975: }
1976: }
1977: if(Var==[]){
1978: FF=1;
1979: }
1980: }
1981: if(Q0!=1){
1982: if(FF) FF=1;
1983: if(TeX) Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[FF]+" }",Q0/=fctr(Q0)[0][0],"\\ne0,"],
1984: Lout);
1985: else mycat([str_times(" ",St-1)+Assume[FF],Q0,"!=0,"]);
1986: PC*=Q0;St++;
1987: }
1988: }
1989: IF=M[JJ][K]=1;
1990: if(Mul!=1){
1991: for(L=K+1; L<Size[1]; L++)
1992: M[JJ][L]=red(M[JJ][L]/Mul);
1993: if(St){
1994: if(TeX)
1995: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,
1996: "\\ \\times=\\ \\left(",red(1/Mul),"\\right)}",
1997: dupmat(M)],Lout);
1998: else
1999: mycat0([Top+"line",JJ+1, " *= (",red(1/Mul), ")\n",M,"\n\n"],0);
2000: }
2001: }
2002:
2003: }
2004: for(J = (Opt>0)?0:(JJ+1); J < Size[0]; J++){
2005: if(J == JJ)
2006: continue;
2007: Mul = -M[J][K];
2008: if(Mul!=0){
2009: if(Opt!=2) Mul=rmul(Mul,1/M[JJ][K]);
2010: for(I = K+1; I < Size[1]; I++)
2011: M[J][I] = radd(M[J][I],rmul(M[JJ][I],Mul));
2012: M[J][K] = 0;
1.40 ! takayama 2013: if(St&&!Main){
1.6 takayama 2014: if(Mul<0){
2015: Mul=-Mul;Sgn=0;
2016: }else Sgn=1;
2017: if(TeX){
2018: if(Mul==1)
2019: Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2020: "}",dupmat(M)],Lout);
2021: else Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2022: "\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout);
2023: }else{
2024: if(Mul==1)
2025: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1,"\n",M,"\n\n"],0);
2026: else
2027: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1," * (",Mul,")\n",M,"\n\n"],0);
2028: }
2029: }
2030: }
2031: }
2032: JJ++;
2033: }
2034: }
2035: }
2036: if(TeX){
2037: if(TeX==-2) return Lout;
2038: Lout=reverse(Lout);
2039: Br="\\allowdisplaybreaks";
2040: Cr="\\\\\n &";
2041: if(getopt(pages)==1) Cr=Br+Cr;
2042: if(type(S=getopt(cr))==7) Cr=S;
2043: if(type(Lim=getopt(lim))==1){
2044: if(Lim>0){
2045: if(Lim<30) Lim=TeXLim;
2046: Lim*=2;
2047: }
2048: }else Lim=0;
2049: Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr,lim=Lim);
2050: if(TeX<0) return Out;
2051: dviout(Out|eq=(str_str(Cr,Br)>=0)?6:5,keep=(TeX==1)?0:1);
2052: }
2053: return M;
2054: }
2055:
2056: def mydet2(M)
2057: {
2058: S = size(M);
2059: Det = 1;
2060: MM = mtoupper(M,0);
2061: for(I = 0; I < S[0]; I++)
2062: Det = rmul(Det,MM[I][I]);
2063: return Det;
2064: }
2065:
2066: def myrank(MM)
2067: {
2068: S = size(MM);
2069: M = dupmat(MM);
2070: M = mtoupper(M,0);
2071: C = 0;
2072: for(I = K = 0; I < S[0]; I++){
2073: for(J = K; J < S[1]; J++){
2074: if(M[I][J] != 0){
2075: C++; K++;
2076: break;
2077: }
2078: }
2079: }
2080: return C;
2081: }
2082:
2083: def meigen(M)
2084: {
2085: F = getopt(mult);
2086: if(type(M)==4 || type(M)==5){
2087: II=length(M);
2088: for(R=[],I=II-1; I>=0; I--){
2089: if(F==1)
2090: R=cons(meigen(M[I]|mult=1),R);
2091: else
2092: R=cons(meigen(M[I]),R);
2093: }
2094: return R;
2095: }
2096: S = size(M)[0];
2097: P = mydet2(mgen(S,0,[zz],0)-M);
2098: return (F==1)?getroot(P,zz|mult=1):getroot(P,zz);
2099: }
2100:
2101: def transm(M)
2102: {
2103: if(type(M)!=6) M=s2m(M);
2104: if(type(M)!=6){
2105: errno(0);
2106: return 0;
2107: }
2108: L=[M];TeX="";
2109: Line=["\\text{line}","\\text{col}"];
2110: if((DVI=getopt(dviout)) !=1) DVI=0;
2111: else dviout(M);
2112: for(;;){
2113: print(L0=dupmat(car(L)));
2114: Sz=size(L0);
2115: S=keyin("? ");
2116: N=0;
2117: if(str_len(S)<=1){
2118: if(S=="q") return L;
2119: if(S=="t"){
2120: N=mtranspose(L0);
2121: TeX=["\\text{transpose}"];
2122: }
2123: else if(S=="f"){
2124: if(length(L)>1){
2125: if(LF!=0) TeX="";
2126: L=cdr(L);LF=L0;
2127: if(DVI){
2128: dviout0(-1);
2129: dviout(" ");
2130: }
2131: }
2132: }else if(S=="g"){
2133: if(LF!=0) N=LF;
2134: }else if(S=="0"){
2135: N=M;L=[];TeX=[];
2136: }else if(S=="a"||S=="A"){
2137: if(DVI&&S=="A") mtoupper(L0,0|step=1,opt=10,dviout=1);
2138: else mtoupper(L0,0|step=1,opt=10);
2139: }else{
2140: mycat0([
2141: "2,5 : line2 <-> line5",
2142: "2,5,-2 ; line2 += (-2)*line5",
2143: "2,2,-2 : line2 *= -2",
2144: "2,5,0 : line2 += (?)*line5 for reduction",
2145: "r,2,5 : raw2 <-> raw5 (r,2,5,-2 etc.)",
2146: "s,x,2 : subst(*,x,2)",
2147: "t : transpose",
2148: "0 : first matrix",
2149: "f : previous matrix",
2150: "g : next matrix (only after f)",
2151: "A : auto (a : without TeX)",
2152: "q : quit"
2153: ],1|delim="\n");
2154: }
2155: }else{
2156: FR=0;
2157: S=evals(S|del=",");
2158: if(S[0]==r){
2159: FR=1; S=cdr(S);
2160: }
2161: if((LL=length(S))>=2){
2162: S0=S[0]-1;S1=S[1]-1;
2163: if(S[0]==s){
2164: if(length(S)==3) N=subst(L0,S[1],S[2]);
2165: if(DVI) TeX=[S[1],"\\mapsto",S[2]];
2166: }else if(FR==0){
2167: if(S0<0 || S0>=Sz[0] || S1<0 || S1>=Sz[0]) continue;
2168: if(LL==2){
2169: N=rowx(L0,S0,S1);
2170: if(DVI) TeX=[Line[0],S[0],"\\ \\leftrightarrow\\ ",Line[0],S[1]];
2171: }else{
2172: S2=S[2];
2173: if(S0==S1){
2174: N=rowm(L0,S0,S2);
2175: if(DVI) TeX=[Line[0],S[0],"\\ \\times=\\ ",S2];
2176: }else{
2177: if(S2==0){
2178: for(J=0;J<Sz[1] && L0[S1][J]==0;J++);
2179: if(J<Sz[1]) S2=-L0[S0][J]/L0[S1][J];
2180: }
2181: if(S2!=0){
2182: N=rowa(L0,S0,S1,S2);
2183: if(DVI) TeX=[Line[0],S[0],"\\ +=\\ ",Line[0],
2184: S[1],"\\ \\times\\ (",S2,")"];
2185: }
2186: }
2187: }
2188: }else{
2189: if(S0<0 || S0>=Sz[1] || S1<0 && S1>=Sz[1]) continue;
2190: if(LL==2){
2191: N=colx(L0,S0,S1);
2192: if(DVI) TeX=[Line[1],S[0],"\\ \\leftrightarrow\\ ",Line[1],S[1]];
2193: }else{
2194: S2=S[2];
2195: if(S0==S1){
2196: N=colm(L0,S0,S2);
2197: if(DVI) TeX=[Line[1],S[0],"\\ \\times=\\ ",S[2]];
2198: }else{
2199: if(S2!=0){
2200: for(J=0; I1<Sz[0] && L0[I1][J]==0; J++);
2201: if(J<Sz[0]) S2=-L0[J][S0]/L0[J][S1];
2202: }if(S2!=0){
2203: N=cola(L0,S0,S1,S2);
2204: if(DVI) TeX=[Line[1],S[0],"\\ +=\\ ",Line[1],
2205: S[1],"\\ \\times\\ (",S2,")"];
2206: }
2207: }
2208: }
2209: }
2210: }
2211: }
2212: if(N!=0){
2213: LF=0;L=cons(N,L);
2214: if(DVI) dviout("\\xrightarrow{"+ltotex(TeX|opt="spts0",str=1)+"}"+mtotex(N)|eq=8);
2215: }
2216: }
2217: }
2218:
2219: def vgen(V,W,S)
2220: {
2221: IM=length(V);
2222: I=(getopt(opt)==0)?IM:0;
2223: for(SS=0; I<IM && (SS==0 || V[I]<=W[I]); I++)
2224: SS += W[I];
2225: if(I<IM){
2226: W[I]++;
2227: SS--;
2228: }else
2229: SS=S;
2230: for(J=0;J<I;J++){
2231: W[J] = (SS<=V[J])?SS:V[J];
2232: SS -= W[J];
2233: }
2234: if(SS>0)
2235: return -1;
2236: return(I==IM)?0:I;
2237: }
2238:
2239: def mmc(M,X)
2240: {
2241: Mt=getopt(mult);
2242: if(type(M)==7) M=os_md.s2sp(M);
2243: if(type(M)!=4||type(M[0])!=6) return 0;
2244: if(type(M[0])!=6){ /* spectre type -> GRS */
2245: G=s2sp(M|std=1);
2246: L=length(G);
2247: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
2248: V=cons(makev([L+9]),V);
2249: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
2250: if(getopt(short)!=0){
2251: V=append(cdr(V),[V[0]]);
2252: G=shortv(G,V);
2253: }
2254: R=chkspt(G|mat=1);
2255: if(Mt!=1) Mt=0;
2256: if(R[2]!=2 || R[3]!=0 || !(R=getbygrs(G,1|mat=1))) return 0;
2257: MZ=newmat(1,1);
2258: SS=length(G);
2259: if(Mt==1) SS=SS*(SS-1)/2;
2260: for(M=[],I=0;I<SS;I++) M=cons(MZ,M);
2261: for(RR=R; RR!=[]; RR=cdr(RR)){
2262: RT=car(RR)[0];
2263: if(type(RT)==4){
2264: if(RT[0]!=0) M=mmc(M,[RT[0]]|simplify=Simp);
2265: M=mmc(M,[cdr(RT)]);
2266: }
2267: }
2268: /* for(R=cdr(R);R!=[];R=cdr(R)) M=mmc(M,[car(R)[0]]|mult=Mt); */
2269: }
2270: if(X==0) return M;
2271: L=length(M);
2272: if((L>=6 && Mt!=0)||(L==3&&Mt==1)){
2273: for(SS=2,I=3; I<L; I+=(++SS));
2274: if(I!=L) return -1;
2275: Mt=1;
2276: }else{
2277: SS=L;Mt=0;
2278: }
2279: if(length(X)==SS+1){
2280: if(car(X)!=0&&(M=mmc(M,[car(X)]|mult=Mt))==0) return M;
2281: return mmc(M,cdr(X)|mult=Mt);
2282: }
2283: for(I=X;I!=[];I=cdr(I)) if(I[0]!=0) break;
2284: if(I==[]) return M;
2285: Simp=getopt(simplify);
2286: if(Simp!=0 && type(Simp)!=1) Simp=2;
2287: N=newvect(L);
2288: for(I=0;I<L;I++) N[I]=dupmat(M[I]);
2289: S=size(N[0])[0];
2290: if(type(X)==4&&length(X)>SS){ /* addition */
2291: for(I=0;I<SS;I++,X=cdr(X)) if(X[I] != 0) N[I] = radd(N[I],car(X));
2292: }
2293: if(length(X)!=1) return 0;
2294: X=X[0];
2295: MZ = newmat(S,S);
2296: MM = newvect(L);
2297: for(M1=J=0; J<SS; J++){
2298: for(R=[],I=SS-1; I>=0; I--){
2299: if(I==J){
2300: for(RR=[],K=SS-1; K>=0; K--)
2301: RR=cons((K==I)?N[K]+diagm(S,[X]):N[K],RR);
2302: R=cons(RR,R);
2303: }else R=cons([MZ],R);
2304: }
2305: MM[J]=newbmat(SS,SS,R);
2306: if(J==0) M1=MM[0];
2307: else M1=radd(M1,MM[J]);
2308: }
2309: /* middle convolution */
2310: for(P=0,Q=1;J<L;J++){ /* A_{P,Q} */
2311: for(R=[],I=SS-1; I>=0; I--){
2312: for(RR=[],K=SS-1;K>=0;K--){
2313: MT=MZ;
2314: if(I==K){
2315: MT=N[J];
2316: if(I==P) MT-=N[Q];
2317: else if(I==Q) MT-=N[P];
2318: }else if(I==P && K==Q) MT=N[Q];
2319: else if(I==Q && K==P) MT=N[P];
2320: RR=cons(MT,RR);
2321: }
2322: R=cons(RR,R);
2323: }
2324: MM[J]=newbmat(SS,SS,R);
2325: if(++Q==SS){
2326: P++;Q=P+1;
2327: }
2328: }
2329: for(R=[],I=SS-1; I>=0; I--){
2330: for(RR=[N[I]],J=0; J<I; J++) RR=cons(MZ,RR);
2331: R=cons(RR,R);
2332: }
2333: M0 = newbmat(SS,SS,R);
2334: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
2335: if(length(KE) == 0) return MM;
2336: KK = mtoupper(lv2m(KE),0);
2337: for(I=0;I<L;I++) MM[I] = mmod(MM[I],KK);
2338: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
2339: return MM;
2340: }
2341:
2342: def lpgcd(L)
2343: {
2344: for(F=[]; L!=[]; L=cdr(L)){
2345: if((P=car(L))==0) continue;
2346: if(F==[]){
2347: F=fctr(P);
2348: S=length(F);
2349: S--;
2350: V=newvect(S);
2351: M=newvect(S);
2352: for(I=0; I<S; I++){
2353: M[I] = F[I+1][1];
2354: V[I] = F[I+1][0];
2355: }
2356: N=nm(ptozp(P|factor=1)[1]);
2357: continue;
2358: }
2359: N=igcd(ptozp(P|factor=1)[1],N);
2360: for(I=0; I<S; I++){
2361: for(Q=P,CT=0; CT<M[I]; CT++)
2362: if((Q=tdiv(Q,V[I])) == 0) break;
2363: if(CT<M[I]) M[I]=CT;
2364: }
2365: }
2366: if(F==[]) return 0;
2367: for(Q=N,I=0;I<S; I++){
2368: while(M[I]>0){
2369: Q *= V[I];
2370: M[I]--;
2371: }
2372: }
2373: return Q;
2374: }
2375:
2376: def mdivisor(M,X)
2377: {
2378: S=size(M=dupmat(M));
2379: XX=(type(X)==4||X==0)?X:[0,X];
2380: S0=S[0]; S1=S[1];
2381: if((Tr=getopt(trans))==1||Tr==2){
2382: Tr0=1;
2383: GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0);
2384: }else Tr=Tr0=0;
2385: /* 0,a,b : (a,b)->(1,1)
2386: 1 : (1,1) invertible
2387: 2,i,M : line 0,i by M
2388: 3,j,M : col 0,j by M
2389: 4,j : col 1 += col j
2390: 5,j,T : line j by T
2391: 6,j,T : col 1 += col j by T (non-com)
2392: 7,j : line 2<->j (non-com)
2393: */
2394: if(type(V=getopt(dviout))==1){
2395: if(type(XX)==4 && type(XX[0])>1) Var=[XX[1],"\\partial"];
2396: else Var=0;
2397: Tr=(abs(V)==3)?0:1;
2398: MM=dupmat(M);
2399: II=((S[0]>S[1])?S[1]:S[0])+1;
2400: if(abs(V)>1){
2401: Is1=Js1=S[0]+S[1];
2402: Is=Js=[0,[Is1]];
2403: }else{
2404: Is=[0,[Is1=S[0]]];Js=[0,[Js1=S[1]]];
2405: }
2406: VV=V;
2407: V=newvect(II);
2408: for(I=0;I<II;I++) V[I]=[];
2409: N=newbmat(2,2,[[M,mgen(S[0],0,[1],0)],[mgen(S[1],0,[1],0)]]);
2410: mdivisor(M,X|step=1,dviout=V);
2411: L=S[0]+S[1];
2412: if(Tr){
2413: NN=mperm(N,Is1,Js1);
2414: for(K=S[0];K<Is1;K++){
2415: for(L=S[1];L<Js1;L++)
2416: NN[K][L]=" ";
2417: }
2418: Out=[[mperm(NN,Is,Js)]];
2419: }
2420: for(I=1;I<II;I++){
2421: I0=I-1;
2422: if(V[I]==[]) continue;
2423: for(T=reverse(V[I]);T!=[];T=cdr(T)){
2424: St=[];
2425: C=car(R=car(T));
2426: if(C==0){
2427: N=mperm(N,(R[1]==0)?0:[[R[1]+I0,I0]],(R[2]==0)?0:[[R[2]+I0,I0]]);
2428:
2429: if(Tr){
2430: if(R[2]!=0) St=append(["C",I,"\\leftrightarrow C",R[2]+I],St);
2431: if(R[1]!=0){
2432: if(R[2]!=0) St=cons(",\\ ",St);
2433: St=append(["L",I,"\\leftrightarrow L",R[1]+I],St);
2434: }
2435: Out=cons(St,Out);
2436: }
2437: }else if(C==1){
2438: P=1/N[I0][I0];N[I0][I0]=1;
2439: if(P!=1){
2440: for(J=I;J<L;J++)
2441: N[I0][J]=muldo(P,N[I0][J],XX);
2442:
2443: if(Tr){
2444: St=append(["L",I,"\\leftarrow(",P,")","\\times L",I],St);
2445: Out=cons(St,Out);
2446: NN=mperm(N,Is1,Js1);
2447: for(K=S[0];K<Is1;K++){
2448: for(L=S[1];L<Js1;L++)
2449: NN[K][L]=" ";
2450: }
2451: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2452: }
2453: }
2454: for(F=0,J=I;J<S[0];J++){
2455: if((P=N[J][I0])==0) continue;
2456: F++;
2457: N[J][I0]=0;
2458: for(K=I;K<L;K++)
2459: N[J][K]=red(N[J][K]-muldo(P,N[I0][K],XX));
2460:
2461: }
2462: if(F){
2463: if(Tr){
2464: Out=cons(["Li\\ -\\!=\\ \\circ\\times L",I,"\\quad(i>",I,")"],Out);
2465: NN=mperm(N,Is1,Js1);
2466: for(K=S[0];K<Is1;K++){
2467: for(L=S[1];L<Js1;L++)
2468: NN[K][L]=" ";
2469: }
2470: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2471: }
2472: }
2473: for(F=0,J=I;J<S[1];J++){
2474: if((P=N[I0][J])==0) continue;
2475: F++;
2476: N[I0][J]=0;
2477: for(K=I;K<L;K++)
2478: N[K][J]=red(N[K][J]-muldo(N[K][I0],P,XX));
2479: }
2480: if(F&&Tr) Out=cons(["Cj\\ -\\!=\\ C",I,"\\times\\circ\\quad(j>",I,")"],Out);
2481: else continue;
2482: }else if(C==2){
2483: C=mat(N[I0],N[R[1]+I0]);C=muldo(R[2],C,XX);
2484: for(J=0;J<L;J++){
2485: N[I0][J]=C[0][J];N[R[1]+I0][J]=C[1][J];
2486: }
2487: if(Tr) Out=cons([dupmat(R[2]),"\\begin{pmatrix}L",I,"\\\\L",R[1]+I,
2488: "\\end{pmatrix}"],Out);
2489: }else if(C==3){
2490: C=newmat(L,2);
2491: for(J=0;J<L;J++){
2492: C[J][0]=N[J][I0];C[J][1]=N[J][R[1]+I0];
2493: }
2494: C=muldo(C,R[2],XX);
2495: for(J=0;J<L;J++){
2496: N[J][I0]=C[J][0];N[J][R[1]+I0]=C[J][1];
2497: }
2498: if(Tr) Out=cons(["\\begin{pmatrix}C",I,"&C",R[1]+I,"\\end{pmatrix}",
2499: dupmat(R[2])],Out);
2500: }else if(C==4){
2501: for(J=0;J<L;J++)
2502: N[J][I0]=red(N[J][I0]+N[J][R[1]+I0]);
2503: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",R[1]+I],Out);
2504: }else if(C==5){
2505: for(J=0;J<L;J++)
2506: N[I0+R[1]][J]=red(R[2]*N[I0+R[1]][J]);
2507: if(Tr) Out=cons(["L",I+R[1],"\\leftarrow(", R[2],")\\times L",I+R[1]],
2508: Out);
2509: }else if(C==6){
2510: for(J=0;J<L;J++)
2511: N[J][I0]=N[J][I0]+muldo(N[J][I0+R[1]],R[2],XX);
2512: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",I+R[1],"\\times(", R[2],")"],
2513: Out);
2514: }else if(C==7){
2515: mycat(["line",I+1,"\\leftrightarrow",R[1]+I]);
2516: for(J=0;J<L;J++){
2517: C=N[I][J];N[I][J]=N[R[1]+I0][J];N[R[1]+I0][J]=C;
2518: }
2519: if(Tr) Out=cons(["L",I+1,"\\leftrightarrow L",R[1]+I],Out);
2520: }
2521: if(Tr){
2522: NN=mperm(N,Is,Js);
2523: for(K=S[0];K<Is1;K++){
2524: for(L=S[1];L<Js1;L++)
2525: NN[K][L]=" ";
2526: }
2527: Out=cons(["\\to",NN],Out);
2528: }
2529: }
2530: }
2531: if(!Tr){
2532: NN=mperm(N,Is,Js);
2533: Out=[];
2534: }
2535: if(S[0]+S[1]==Is1){
2536: N1=mperm(NN,[0,[S[0]]],[S[1],[S[0]]]);
2537: N2=mperm(NN,[S[0],[S[1]]],[0,[S[1]]]);
2538: N3=mperm(NN,[0,[S[0]]],[0,[S[1]]]);
2539: R1=mdivisor(N1,X|trans=1)[1];
2540: R2=mdivisor(N2,X|trans=1)[1];
2541: if(Tr){
2542: Out=cons(["\\text{As a result,}"],Out);
2543: Out=cons([N3,"=",N1,MM,N2],Out);
2544: if(S[0]==S[1] && N3==mgen(S[0],0,1,0)){
2545: Out=cons(["=",muldo(N2,N1,XX),MM,"."],Out);
2546: }else{
2547: Out=cons([N1,"^{-1}=",R1,","],Out);
2548: Out=cons([N2,"^{-1}=",R2,"."],Out);
2549: }
2550: }else{
2551: Out=cons([N3,"=P",MM,"Q,"],Out);
2552: Out=cons(["P=",N1,"=",R1,"^{-1},"],Out);
2553: Out=cons(["Q=",N2,"=",R2,"^{-1}."],Out);
2554: }
2555: }
2556: Out = ltotex(reverse(Out)|opt=["cr","spts0"],str=1,cr=15,var=Var);
2557: if(S[0]+S[1]==Is1)
2558: Out=str_subst(Out,"\\texttt{ }","");
2559: if(VV>0){
2560: dviout(Out|eq=6);
2561: return NN;
2562: }
2563: return Out;
2564: }else if(type(V)!=5) V=0;
2565:
2566: if(type(St=getopt(step))!=1) St=0;
2567: for(FF=": start";;){
2568: if(St && V==0){
2569: if(Tr){
2570: mycat0([St,FF,"\n"],0);
2571: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2572: }
2573: else mycat0([St,FF,"\n",M,"\n"],0);
2574: }
2575: if(X==0||X==[0,0]){ /* search minimal non-zero element */
2576: for(K=F=I=0; I<S0; I++){
2577: for(J=0; J<S1; J++){
2578: if((P=abs(M[I][J]))!=0 && (K>P || K==0)){
2579: K=P; R=[I,J];
2580: }
2581: }
2582: }
2583: R=cons(K-1,[R]);
2584: }
2585: else R=mymindeg(M,XX[1]|opt=1);
2586: if(R[0]<0){ /*zero matrix */
2587: if(Tr) return [[],mgen(S0,0,1,0),mgen(S1,0,1,0)];
2588: return [];
2589: }
2590: R0=R[1][0];R1=R[1][1];
2591: if(R0!=0){
2592: M=rowx(M,0,R0);
2593: if(Tr) GR=rowx(GR,0,R0);
2594: }
2595: if(R1!=0){
2596: M=colx(M,0,R1);
2597: if(Tr) GC=colx(GC,0,R1);
2598: }
2599: if(St>0 && (R0!=0 || R1!=0))
2600: if(type(V)==5) V[St]=cons([0,R0,R1],V[St]);
2601: else if(Tr){
2602: mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n"],0);
2603: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2604: }else mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n",M,"\n"],0);
2605: if(R[0]==0){ /* (1,1) : invertible */
2606: if(type(V)==5) V[St]=cons([1],V[St]);
2607: P=M[0][0]; M[0][0]=1;
2608: for(J=0;J<S1;J++){ /* (1,1) -> 1 */
2609: if(J>0) M[0][J]= red(M[0][J]/P);
2610: if(Tr) GR[0][J]=red(GR[0][J]/P);
2611: }
2612: if(S0>1 && S1>1) N=newmat(S0-1,S1-1);
2613: else N=0;
2614: for(I=1;I<S0;I++){
2615: P=M[I][0]; M[I][0]=0;
2616: for(J=1;J<S1;J++)
2617: N[I-1][J-1]=M[I][J]=red(M[I][J] - muldo(P,M[0][J],XX));
2618: if(Tr){
2619: for(J=0;J<S0;J++)
2620: GR[I][J] = red(GR[I][J] -muldo(P,GR[0][J],XX));
2621: }
2622: }
2623: if(Tr){
2624: for(J=1;J<S1; J++){
2625: for(I=0;I<S1;I++) GC[I][J]=red(GC[I][J]-muldo(GC[I][0],M[0][J],XX));
2626: M[0][J]=0;
2627: }
2628: }
2629: if(St>0 && V==0){
2630: if(Tr){
2631: mycat0([St,": unit\n"],0);
2632: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2633: }
2634: else mycat0([St,": unit\n",M,"\n"],0);
2635: }
2636: if(N==0){
2637: if(!Tr) return [1];
2638: if(Tr==2){
2639: GR0=mdivisor(GR,X|trans=1)[1];
2640: GC0=mdivisor(GC,X|trans=1)[1];
2641: return [[1],GR,GC,GR0,GC0];
2642: }
2643: return [[1],GR,GC];
2644: }
2645: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2646: if(!Tr) return cons(1,R);
2647: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2648: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2649: if(S0==S1 && countin(1,1,R[0])==S0-1){
2650: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2651: }
2652: if(Tr==2){
2653: GR0=mdivisor(GR,X|trans=1)[1];
2654: GC0=mdivisor(GC,X|trans=1)[1];
2655: return [cons(1,R[0]),GR,GC,GR0,GC0];
2656: }
2657: return [cons(1,R[0]),GR,GC];
2658: }
2659: for(I=1;I<S0;I++){
2660: if(M[I][0]!=0){
2661: /* Error! when mygcd(A,B,0) with A<=0 or B<=0 */
2662: R=mygcd(M[I][0],M[0][0],XX); /* R[0]=R[1]*M[I][0]+R[2]*M[0][0] */
2663: M[0][0]=R[0]; M[I][0]=0; /* 0=R[3]*M[I][0]+R[4]*M[0][0] */
2664: for(J=1;J<S1;J++){
2665: T=red(muldo(R[1],M[I][J],XX)+muldo(R[2],M[0][J],XX));
2666: M[I][J]=red(muldo(R[3],M[I][J],XX)+muldo(R[4],M[0][J],XX));
2667: M[0][J]=T;
2668: }
2669: if(Tr){
2670: for(J=0;J<S0;J++){
2671: T=red(muldo(R[1],GR[I][J],XX)+muldo(R[2],GR[0][J],XX));
2672: GR[I][J]=red(muldo(R[3],GR[I][J],XX)+muldo(R[4],GR[0][J],XX));
2673: GR[0][J]=T;
2674: }
2675: }
2676: if(St && V==0){
2677: mycat([" [",R[2],R[1],"]*"]);
2678: mycat([" [",R[4],R[3],"]"]);
2679: }
2680: if(type(V)==5) V[St]=cons([2,I,mat([R[2],R[1]],[R[4],R[3]])],V[St]);
2681: FF=": line 1 & "+rtostr(I+1); I=S0;
2682: }
2683: }
2684: if(I>S0) continue;
2685: for(J=1;J<S1;J++){
2686: if(M[0][J]!=0){
2687: R=mygcd(M[0][J],M[0][0],XX|rev=1); /* R[0]=M[0][J]*R[1]+M[0][0]*R[2] */
2688: M[0][0]=R[0]; M[0][J]=0; /* 0=M[0][J]*R[3]+M[0][0]*R[4] */
2689: for(I=1;I<S0;I++){
2690: T=red(muldo(M[I][J],R[1],XX)+muldo(M[I][0],R[2],XX));
2691: M[I][J]=red(muldo(M[I][J],R[3],XX)+muldo(M[I][0],R[4],XX));
2692: M[I][0]=T;
2693: }
2694: if(Tr){
2695: for(I=0;I<S1;I++){
2696: T=red(muldo(GC[I][J],R[1],XX)+muldo(GC[I][0],R[2],XX));
2697: GC[I][J]=red(muldo(GC[I][J],R[3],XX)+muldo(GC[I][0],R[4],XX));
2698: GC[I][0]=T;
2699: }
2700: }
2701: if(type(V)==5) V[St]=cons([3,J,mat([R[2],R[4]],[R[1],R[3]])],V[St]);
2702: FF=": column 1 & "+rtostr(J+1);J=S1;
2703: if(St && V==0){
2704: mycat([" *[",R[2],R[4],"]"]);
2705: mycat([" [",R[1],R[3],"]"]);
2706: }
2707: }
2708: }
2709: if(J>S1) continue;
2710: if(S0==1 || S1==1){
2711: P=M[0][0];
2712: if(X==0){
2713: if(P<0){
2714: P=-P;
2715: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2716: if(type(V)==5) V[St]=cons([5,0,-1],V[St]);
2717: }
2718: }else{
2719: P=nm(P);
2720: if((R=fctr(P)[0][0])!=1){
2721: P/=R;
2722: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=R;
2723: if(type(V)==5) V[St]=cons([5,0,1/R],V[St]);
2724: }
2725: }
2726: if(!Tr) return [P];
2727: if(Tr==2){
2728: GR0=mdivisor(GR,X|trans=1)[1];
2729: GC0=mdivisor(GC,X|trans=1)[1];
2730: return [[P],GR,GC,GR0,GC0];
2731: }
2732: return [[P],GR,GC];
2733: }
2734: if(XX==0 || (type(XX)==4 && XX[0]==0)){ /* commutative case */
2735: P=M[0][0];
2736: for(I=1; I<S0; I++){
2737: for(J=1; J<S1; J++)
2738: if(divdo(M[I][J],P,XX)[1]!=0) break;
2739: if(J<S1){
2740: if(type(V)==5) V[St]=cons([4,J],V[St]);
2741: FF=": column 1 += col"+rtostr(J+1);
2742: for(I=1;I<S0;I++) M[I][0]=M[I][J];
2743: if(Tr) for(I=0;I<S1;I++) GC[I][0]=red(GC[I][0]+GC[I][J]);
2744: break;
2745: }
2746: }
2747: if(J<S1) continue;
2748: N=newmat(S0-1,S1-1);
2749: for(I=1;I<S0;I++)
2750: for(J=1;J<S1;J++) N[I-1][J-1]=red(M[I][J]/P);
2751: if(X==0){
2752: if(P<0) P=-P;
2753: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2754: }else{
2755: P=M[0][0];
2756: P=nm(P);
2757: P/=fctr(P)[0][0];
2758: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=fctr(P)[0][0];
2759: }
2760: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2761: RT=(Tr)?R[0]:R;
2762: for(RR=[],L=reverse(RT);L!=[];L=cdr(L))
2763: RR=cons(red(P*car(L)),RR);
2764: RR=cons(P,RR);
2765: if(!Tr) return RR;
2766: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2767: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2768: if(S0==S1 && countin(1,1,RR)==S0){
2769: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2770: }
2771: if(Tr==2){
2772: GR0=mdivisor(GR,X|trans=1)[1];
2773: GC0=mdivisor(GC,X|trans=1)[1];
2774: return [RR,GR,GC,GR0,GC0];
2775: }
2776: return [RR,GR,GC];
2777: } /* End of commutative case */
2778: for(I=1; I<S0; I++){
2779: for(J=1; J<S1; J++){
2780: if(M[I][J] != 0){
2781: for(T=1;I<S0;T*=XX[0]){
2782: R=divdo(muldo(M[I][J],T,XX),M[0][0],XX);
2783: if(R[1]!=0){
2784: if(type(V)==5) V[St]=cons([6,J,T],V[St]);
2785: FF=": column 1 += col"+rtostr((J+1)*T);
2786: if(I>1){
2787: M=rowx(M,1,I);
2788: if(Tr) GR=rowx(GR,1,I);
2789: if(type(V)==5) V[St]=cons([7,I],V[St]);
2790: FF+=", line 2<->"+rtostr(I+1);
2791: }
2792: for(I=1;I<S0;I++) M[I][0]=muldo(M[I][J],T,XX);
2793: if(Tr)
2794: for(I=1;I<S1;I++) GC[I][0]=red(GC[I][0]+muldo(GC[I][J],T,XX));
2795: I=S0+1; J=S1;
2796: break;
2797: }
2798: }
2799: }
2800: }
2801: if(I>S0) break;
2802: }
2803: if(I==S0) return []; /* zero matrix : never happen */
2804: }
2805: }
2806:
2807: def mdsimplify(L)
2808: {
2809: T=getopt(type);
2810: SS=0;
2811: if(type(L)==6){
2812: L=[L]; SS=1;
2813: }
2814: if(type(L)==5){
2815: SS=2;
2816: L = vtol(L);
2817: }
2818: M=car(L);
2819: S=size(M)[0];
2820: #if 0
2821: MN=newmat(S,S);
2822: MD=newmat(S,S);
2823: for(I=0;I<S;I++){
2824: for(J=0;J<S;J++){
2825: TN=0;TD=1;
2826: for(PL=L;PL!=[];PL=cdr(PL)){
2827: TM=red(car(PL)[I][J]);
2828: TN=lgcd([TN,nm(TM)]|pol=1);
2829: TD=llcm([TD,dn(TM)]|pol=1);
2830: }
2831: MN[I][J]=TM;
2832: MD[I][J]=TN;
2833: }
2834: }
2835: for(I=0;I<S;I++){
2836: for(J=0;J<S;J++){
2837: if(I==J||type(TD[I][J])<2||type(TN[J][I])<2) continue;
2838: for(FC=cdr(fctr(TD[I][J]));FC!=[];){
2839: TFC=car(FC);
2840: if(type(red(TN[J][I]/TFC[0]))>2) continue;
2841: }
2842: }
2843: }
2844: #endif
2845: DD=newvect(S);
2846: for(I=0; I<S; I++){
2847: LN=RN=[];
2848: LD=RD=1;
2849: for(LL=L; LL!=[]; LL=cdr(LL)){
2850: M = car(LL);
2851: for(J=0; J<S; J++){
2852: if(J==I) continue;
2853: if((MM=M[I][J]) != 0){
2854: LN = cons(nm(MM),LN);
2855: if(type(MM)==3 && tdiv(LD,P=dn(MM))==0)
2856: LD=tdiv(LD*P,gcd(LD,P));
2857: }
2858: if((MM=M[J][I]) != 0){
2859: RN = cons(nm(MM),RN);
2860: if(type(MM)==3 && tdiv(RD,P=dn(MM))==0)
2861: RD=tdiv(RD*P,gcd(RD,P));
2862: }
2863: }
2864: }
2865: if(T==1 || T==3) LQ=RD;
2866: else{
2867: P=lpgcd(LN);
2868: LQ=gcd(P,RD);
2869: if(P!=0) LQ *= nm(fctr(P)[0][0]);
2870: }
2871: if(T==1 || T==2) RQ=LD;
2872: else{
2873: P=lpgcd(RN);
2874: RQ=gcd(P,LD);
2875: if(P!=0) RQ *= nm(fctr(P)[0][0]);
2876: }
2877: if((P=gcdz(LQ,RQ))!=1){
2878: LQ = red(LQ/P); RQ=red(RQ/P);
2879: }
2880: DD[I]=red(LQ/RQ);
2881: if(LQ!=1 || RQ!=1){
2882: for(LA=[],LL=L; LL!=[]; LL=cdr(LL)){
2883: M = car(LL);
2884: for(J=0; J<S; J++){
2885: if(I!=J){
2886: if(LQ!=1){
2887: M[I][J] = red(M[I][J]/LQ);
2888: M[J][I] = red(M[J][I]*LQ);
2889: }
2890: if(RQ!=1){
2891: M[J][I] = red(M[J][I]/RQ);
2892: M[I][J] = red(M[I][J]*RQ);
2893: }
2894: }
2895: }
2896: }
2897: }
2898: }
2899: if(SS==2) L=ltov(L);
2900: if(SS==1) L=L[0];
2901: if(getopt(show)==1) L=[L,DD];
2902: return L;
2903: }
2904:
2905: def m2mc(M,X)
2906: {
2907: if(type(M)<2){
2908: mycat([
2909: "m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
2910: " m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
2911: " t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
2912: " s : TeX, dviout, GRSC\n",
2913: " option : swap, small, simplify, operator, int\n",
2914: " Ex: m2mc(\"21,21,21,21\",\"All\")\n"
2915: ]);
2916: return 0;
2917: }
2918: if(type(M)==7) M=s2sp(M);
2919: if(type(X)==7) X=[X];
2920: Simp=getopt(simplify);
2921: if(Simp!=0 && type(Simp)!=1) Simp=2;
2922: Small=(getopt(small)==1)?1:0;
2923: if(type(M[0])==4){
2924: if(type(M[0][0])==1){ /* spectral type */
2925: XX=getopt(dep);
2926: if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
2927: M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
2928: if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
2929: if(getopt(int)!=0){
2930: T=M[XX[0]-1][XX[1]-1][1];
2931: for(V=vars(T);V!=[];V=cdr(V)){
2932: F=coef(T,1,car(V));
2933: if(type(F)==1 && dn(F)>1)
2934: M = subst(M,car(V),dn(F)*car(V));
2935: }
2936: }
2937: V=vars(M);
2938: if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
2939: M=subst(M,d1,d);
2940: }
2941: RC=chkspt(M|mat=1);
2942: if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
2943: erno(0);return 0;
2944: }
2945: R=getbygrs(M,1|mat=1);
2946: if(getopt(anal)==1) return R; /* called by mc2grs() */
2947: Z=newmat(1,1,[[0]]);
2948: N=[Z,Z,Z,Z,Z];
2949: for(RR=R; RR!=[]; RR=cdr(RR)){
2950: RT=car(RR)[0];
2951: if(type(RT)==4){
2952: if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
2953: N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
2954: }
2955: }
2956: if(type(X)==4 && type(X[0])==7)
2957: return m2mc(N,X|keep=Keep,small=Small);
2958: return N;
2959: }
2960: if(type(X)==4 && type(X[0])==7){
2961: Keep=(getopt(keep)==1)?1:0;
2962: if(X[0]=="All"){
2963: dviout("Riemann scheme"|keep=1);
2964: m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
2965: dviout("Spectral types : "|keep=1);
2966: m2mc(M,["sp","dviout"]|keep=1);
2967: dviout("\\\\\nBy the decompositions"|keep=1);
2968: R=m2mc(M,["pairs","dviout"]|keep=1);
2969: for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
2970: for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
2971: if(S==0) R0=cons(I,R0);
2972: else if(S<0) R1=cons(I,R1);
2973: }
2974: S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
2975: +"\\ \\emptyset=\\mathbb Z\\cap$";
2976: dviout(S|keep=1);
2977: m2mc(M,["irreducible","dviout"]|keep=1);
2978: if(R0!=[])
2979: dviout(ltotex(reverse(R0))|eq=0,keep=1,
2980: title="The following conditions may not be necessary for the irreducibility.");
2981: if(R1!=[])
2982: dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
2983: if(getopt(operator)!=0){
2984: dviout("The equation in a Pfaff form is"|keep=1);
2985: m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
2986: }
2987: else if(Keep!=1) dviout(" ");
2988: return M;
2989: }
2990: Show=0;
2991: if(length(X)>1){
2992: if(X[1]=="dviout") Show=2;
2993: if(X[1]=="TeX") Show=1;
2994: }
2995: if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"){
2996: Y=radd(-M[0],-M[1]-M[2]);
2997: if(X[0]!="GRSC"){
2998: 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);
2999: if(X[0]=="sp"){
3000: L=chkspt(L|opt="sp");
3001: V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
3002: if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
3003: return [V,W];
3004: }
3005: S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
3006: }else{
3007: 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]),
3008: radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
3009: 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";
3010: }
3011: T=ltotex(L|opt="GRS",pre=S,small=Small);
3012: if(Show==2) dviout(T|eq=0,keep=Keep);
3013: if(Show==1) L=T;
3014: return L;
3015: }
3016: if(X[0]=="Pfaff"){
3017: S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
3018: if(Show==2) dviout(S|eq=0,keep=Keep);
3019: return S;
3020: }
3021: if(X[0]=="irreducible"){
3022: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3023: S=getbygrs(L,10|mat=1);
3024: if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
3025: return S;
3026: }
3027: if(X[0]=="pairs"||X[0]=="pair"){
3028: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3029: S=chkspt(L|opt=0);
3030: V=(Show==2)?1:0;
3031: S=sproot(L,X[0]|dviout=V,keep=Keep);
3032: return S;
3033: }
3034: if(X[0]=="swap"){
3035: Swap=getopt(swap);
3036: if(type(Swap)<1 || Swap==1)
3037: return newvect(5,[M[3],M[1],M[4],M[0],M[2]]);
3038: if(Swap==2)
3039: return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
3040: if(type(Swap)==4 && length(Swap)==3){
3041: MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
3042: if(Swap[0]==1){
3043: MX0=M[2];MY0=M[4];
3044: }
3045: else if(Swap[0]==2){
3046: MX0=MX;MY0=MY;
3047: }else{
3048: MX0=M[0];MY0=M[3];
3049: }
3050: if(Swap[1]==1){
3051: MX1=M[2];MY1=M[4];
3052: }
3053: else if(Swap[1]==2){
3054: MX1=MX;MY1=MY;
3055: }else{
3056: MX1=M[0];MY1=M[3];
3057: }
3058: return newvect(5,MX0,M[1],MX1,MY0,MY1);
3059: }
3060: }
3061: return 0;
3062: }
3063: if(getopt(swap)==1)
3064: return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
3065: N=newvect(5);
3066: for(I=0;I<5;I++)
3067: N[I]=M[I];
3068: S=size(N[0])[0];
3069: if(type(X)==4){
3070: for(I=0;I<3;I++){
3071: if(X[I] != 0)
3072: N[I] = radd(N[I],X[I]);
3073: }
3074: if(length(X)==3) return N;
3075: X=X[3];
3076: }
3077: MZ = newmat(S,S);
3078: ME = mgen(S,0,[X],0);
3079: MM = newvect(5);
3080: MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]);
3081: MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]);
3082: MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]);
3083: MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]);
3084: MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]);
3085: M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
3086: M1 = radd(MM[0],MM[1]+MM[2]);
3087: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
3088: if(length(KE) == 0) return MM;
3089: KK = mtoupper(lv2m(KE),0);
3090: for(I=0;I<5;I++)
3091: MM[I] = mmod(MM[I],KK);
3092: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
3093: return MM;
3094: }
3095:
3096: def easierpol(P,X)
3097: {
3098: if(type(X) == 4){
3099: for( Y = [] ; X != []; X = cdr(X) )
3100: Y = cons([0,car(X)], Y);
3101: }else
3102: Y = [0,X];
3103: return rede(P,Y);
3104: }
3105:
3106: def l2p(L,V)
3107: {
3108: if(type(L)==4){
3109: for(S=I=0;L!=[];L=cdr(L),I++)
3110: S+=car(L)*V^I;
3111: return S;
3112: }else if(type(L)==5){
3113: for(S=0,I=size(L)-1;I>=0;I--)
3114: S+=L[I]*V^I;
3115: return S;
3116: }else{
3117: if(type(D=getopt(size))==1) D--;
3118: else D=mydeg(L,V);
3119: for(S=[];D>=0;D--)
3120: S=cons(mycoef(L,D,V),S);
3121: return S;
3122: }
3123: }
3124:
3125: def paracmpl(L,V)
3126: {
3127: if(type(L)==4) L=ltov(L);
3128: S=length(L);
3129: Lim=getopt(lim);Low=getopt(low);
3130: if((F=type(L[0]))>3){
3131: SV=length(L[0]);
3132: V0=makenewv(L);
3133: for(LL=[];S>0;S--)
3134: LL=cons(l2p(L[S-1],V0),LL);
3135: G=paracmpl(LL,V|option_list=getopt());
3136: H=(Lim==1)?G:G[0];
3137: for(HH=[];H!=[];H=cdr(H)){
3138: HT=l2p(car(H),V0|size=SV);
3139: if(F==5) HT=ltov(HT);
3140: HH=cons(HT,HH);
3141: }
3142: H=reverse(HH);
3143: return (Lim==1)?H:[H,G[1]];
3144: }
3145: H=newvect(S);D=newvect(S);
3146: for(Dn=1,I=0;I<S;I++){
3147: P=dn(L[I]=red(L[I]));
3148: Dn=red(Dn*P/gcd(Dn,P));
3149: }
3150: if(Dn!=1){
3151: for(I=0;I<S;I++) L[I]=red(Dn*L[I]);
3152: }
3153: G=diagm(S,[1]);
3154: if(type(V)<4) V=[V];
3155: VV=lsort(vars(L),V,1);
3156: V=car(V);
3157: for(I=0;I<S;I++){
3158: P=L[I];
3159: for(J=0,C=P;J<I;J++){
3160: if(D[J]!=[]){
3161: C=mycoef(C,DT,VV);
3162: P-=C*H[J];
3163: G=cola(G,I,J,-C);
3164: }
3165: }
3166: if(P==0){
3167: D[I]=[];continue;
3168: }
3169: P0=nm(red(P));
3170: K=mymindeg(P0,V);
3171: C=mycoef(P0,K,V);
3172: if(K>0){
3173: P=red(P/V^K);
3174: G=colm(G,I,1/V^K);
3175: }
3176: for(DT=[],VT=VV;VT!=[];VT=cdr(VT)){
3177: K=(Low==1)?mymindeg(C,car(VT)):mydeg(C,car(VT));
3178: C=mycoef(C,K,car(VT));
3179: DT=cons(K,DT);
3180: }
3181: D[I]=DT=reverse(DT);
3182: for(C=P,VT=VV;VT!=[];VT=cdr(VT),DT=cdr(DT))
3183: C=mycoef(C,car(DT),car(VT));
3184: H[I]=P=red(P/C);
3185: G=colm(G,I,1/C);
3186: }
3187: if(Dn!=1){
3188: for(I=0;I<S;I++){
3189: TH=red(H[I]/Dn);
3190: F=fctr(dn(TH));F=cdr(F);
3191: if(Lim!=1||subst(Dn,V,0)==0){
3192: for(;F!=[];F=cdr(F)){
3193: if(lsort(vars(car(F)[0]),VV,2)==[]){
3194: C=car(F)[0]^car(F)[1];
3195: TH=red(TH*C);
3196: G=colm(G,I,C);
3197: }
3198: }
3199: }
3200: H[I]=TH;
3201: }
3202: }
3203: H=vtol(H);
3204: if(Lim==1){
3205: H=subst(H,V,0);
3206: return map(red,H);
3207: }
3208: return [H,map(red,G)];
3209: }
3210:
3211: def mykernel(M)
3212: {
3213: if(getopt(opt) == 1)
3214: M = mtranspose(M);
3215: S = size(M);
3216: R = [];
3217: MM = mtoupper(M,-1);
3218: for(I = S[0]-1; I >= 0; I--){
3219: for(J = S[1]-1; J >= 0; J--){
3220: if(MM[I][J] != 0)
3221: return R;
3222: }
3223: P = easierpol(MM[I][S[1]],zz);
3224: RR = newvect(S[0]);
3225: for(J = 0; J < S[0]; J++)
3226: RR[J] = mycoef(P,J,zz);
3227: R = cons(RR,R);
3228: }
3229: return R;
3230: }
3231:
3232: def myimage(M)
3233: {
3234: if(getopt(opt) == 1)
3235: M = mtranspose(M);
3236: S = size(M);
3237: V = [];
3238: M0 = newvect(S[1]);
3239: M = mtoupper(M,0|opt=1);
3240: for(I = S[0]-1; I >= 0; I--)
3241: if(M0 != M[I])
3242: V = cons(vtozv(M[I])[0], V);
3243: return V;
3244: }
3245:
3246: def mymod(V,L)
3247: {
3248: Opt = getopt(opt);
3249: S = length(V);
3250: VP = newvect(S);
3251: if(type(L)==6)
3252: L=m2lv(L);
3253: CT = length(L);
3254: for(LT = L; LT != []; LT = cdr(LT)){
3255: for(VT = car(LT), I = 0; I < S; I++)
3256: if(VT[I] != 0) break;
3257: if(I >= S){
3258: CT--;
3259: continue;
3260: }
3261: VP[I] = 1;
3262: MI = -red(V[I]/VT[I]);
3263: if(MI != 0)
3264: V = radd(V,rmul(MI,VT));
3265: }
3266: if(Opt==1){
3267: for(I = 0; I < S; I++)
3268: if(V[I] != 0)
3269: return 1;
3270: return 0;
3271: }
3272: if(Opt==2){
3273: W=newvect(S-CT);
3274: for(CC = I = 0; I < S; I++){
3275: if(VP[I]==0) W[CC++] =V[I];
3276: }
3277: return W;
3278: }
3279: return V;
3280: }
3281:
3282: def mmod(M,L)
3283: {
3284: S=size(M)[1];
3285: MM=mtranspose(M);
3286: VP = newvect(S);
3287: if(type(L)==6)
3288: L=m2lv(L);
3289: for(CT = 0, LT = L; LT != []; LT = cdr(LT)){
3290: for(VT = car(LT), I = 0; I < S; I++){
3291: if(VT[I] != 0){
3292: VP[I] = 1;
3293: break;
3294: }
3295: }
3296: }
3297: if(getopt(opt)==1)
3298: NE=1;
3299: for(D=I=0; I<S; I++){
3300: if(NE != 1 && VP[I] == 1) continue;
3301: T = mymod(MM[I],L|opt=2);
3302: if(D==0){
3303: K=length(T);
3304: MN=newmat((NE==1)?S:K,K);
3305: }
3306: for(J=0;J<K;J++)
3307: MN[J][D]=T[J];
3308: D++;
3309: }
3310: return MN;
3311: }
3312:
3313: def llsize(V)
3314: {
3315: for(I=J=0;V!=[];V=cdr(V),I++)
3316: if(length(car(V))>J) J=length(car(V));
3317: return [I,J];
3318: }
3319:
3320: def llbase(VV,L)
3321: {
3322: S = length(VV);
3323: V = dupmat(VV);
3324: if(type(V) == 4)
3325: V = ltov(V);
3326: T = length(L);
3327: for(I = 0; I < S; I++)
3328: V[I] = nm(red(V[I]));
3329: LV = 0;
3330: for(J = 0; J < T; J++){
3331: X = var(L[J]); N = deg(L[J],X);
3332: for(I = LV; I < S; I++){
3333: if((C2=coef(V[I],N,X)) != 0){
3334: if(I > LV){
3335: Temp = V[I];
3336: V[I] = V[LV];
3337: V[LV] = Temp;
3338: }
3339: for(I = 0; I < S; I++){
3340: if(I == LV || (C1 = coef(V[I],N,X)) == 0)
3341: continue;
3342: Gcd = gcd(C1,C2);
3343: V[I] = V[I]*tdiv(C2,Gcd)-V[LV]*tdiv(C1,Gcd);
3344: }
3345: LV++;
3346: }
3347: }
3348: }
3349: return V;
3350: }
3351:
3352: def lsort(L1,L2,T)
3353: {
1.10 takayama 3354: C1=getopt(c1);C2=getopt(c2);
1.8 takayama 3355: if(type(T)==4){
3356: K=T;
1.10 takayama 3357: if(length(T)>0){
3358: T=K[0];
3359: K=cdr(K);
1.12 takayama 3360: }else T=0;
1.8 takayama 3361: }else K=0;
1.10 takayama 3362: if(type(TT=T)==7)
3363: T = findin(T,["cup","setminus","cap","reduce","sum","subst"]);
3364: if(type(L2)==7&&T<0)
3365: T=findin(TT,["put","get","sub"]);
3366: if(K){ /* [[..],..] */
3367: if(K!=[]) KN=K[0];
3368: if(L2==[]||L2=="sort"){ /* sort or deduce duplication */
3369: if((T!=0&&T!=3)||length(K)!=1) return L1;
1.8 takayama 3370: if(KN<0){
3371: KN=-KN-1;
3372: F=-1;
3373: }else F=1;
3374: L1=msort(L1,[F,0,KN]);
1.10 takayama 3375: if(T==3){
1.8 takayama 3376: R=[car(L1)];L1=cdr(L1);
3377: for(;L1!=[];L1=cdr(L1)){
3378: if(car(L1)[KN]!=car(R)[KN]) R=cons(car(L1),R);
3379: }
3380: L1=reverse(R);
3381: }
3382: return L1;
1.10 takayama 3383: }else if((L2==0||L2=="col")&&type(C1)==4){
1.8 takayama 3384: if(T==0||T==1){ /* extract or delete columns */
3385: for(R=[];L1!=[];L1=cdr(L1)){
1.10 takayama 3386: if(T==1&&C1==[0]){ /* delete top column */
1.8 takayama 3387: R=cons(cdr(car(L1)),R);
3388: continue;
3389: }
1.10 takayama 3390: LT=car(L1);RT=[];
1.8 takayama 3391: if(T==0){
1.10 takayama 3392: for(CT=C1;CT!=[];CT=cdr(CT)) RT=cons(LT[car(CT)],RT);
1.8 takayama 3393: }else{
1.10 takayama 3394: for(I=0;LT!=[];I++,LT=cdr(LT))
1.8 takayama 3395: if(findin(I,C1)<0) RT=cons(car(LT),RT);
3396: RT=reverse(RT);
3397: }
3398: R=cons(RT,R);
3399: }
3400: return reverse(R);
3401: }
1.10 takayama 3402: }else if(type(L2)==1||type(L2)==7){
3403: if(L2==1||L2=="num"){
3404: if(T==4) T=3;
3405: I=(length(K)<2)?(-1):K[1];
3406: if(T==0||T==1||T==2||T==3){
3407: S=F=CT=0;R=[];
3408: if(K==[] || type((S=K[0]))==1 || S==0){
3409: if(T==0||T==1||T==2){
3410: for(J;L1!=[];L1=cdr(L1),J++){
3411: if(T==0) R=cons(cons(J+S,car(L1)),R);
3412: else if(T==1){
3413: for( ;C1!=[]; C1=cdr(C1))
3414: R=cons(L1[car(C1)],R);
3415: }else{
3416: if(findin(J,C1)<0) R=cons(car(L1),R);
3417: }
3418: }
3419: return reverse(R);
3420: }else if(T==3) return length(L1);
3421: }else{
3422: if(type(S)==2&&vtype(S)>2) F=1;
3423: else if(type(S)==4) F=2;
3424: else if(S=="+") F=3;
3425: else return L1;
3426: }
3427: for(R=[];L1!=[];L1=cdr(L1)){
3428: L1T=car(L1);
3429: if(F==1) V=call(S,(I<0)?L1T:L1T[I]);
3430: else if(F==2) V=calc((I<0)?L1T:L1T[I],S);
3431: else if(F==3){
3432: for(C=C1,V=0;C!=[];C=cdr(C))
3433: if(type(X=L1T[car(C)])==1) V+=X;
3434: }
3435: if(T==0) R=cons(cons(V,L1T),R);
3436: else if(T==1){
3437: if(V) R=cons(L1T,R);
3438: }else if(T==2){
3439: if(!V) R=cons(L1T,R);
3440: }else if(T==3){
3441: if(F==3) CT+=V;
3442: else if(V) CT++;
3443: }
3444: }
3445: return (T==3)?CT:reverse(R);
3446: }else if(TT=="col"){
3447: J=(length(K)>0)?car(K):0;
3448: I=length(car(L1))+J;
3449: for(V=[];I>J;)
3450: V=cons(--I,V);
3451: return cons(V,L1);
3452: }
3453: }else if(L2=="transpose") return mtranspose(L1);
1.12 takayama 3454: else if(L2=="subst"||L2=="adjust"){
3455: Null=(!K)?"":car(K);
1.17 takayama 3456: if(L2=="adjust") C1=[];
1.12 takayama 3457: R=lv2m(L1|null="");
1.10 takayama 3458: for(;C1!=[];C1=cdr(C1)) R[car(C1)[0]][car(C1)[1]]=car(C1)[2];
3459: return m2ll(R);
3460: }
3461: return L1;
3462: }else{ /* [[..],..], [[..],..] */
3463: if(type(L2[0])<4){
3464: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3465: L2=reverse(R);
3466: }
3467: if(TT=="sum") T=3;
3468: if(TT=="over") T=4;
3469: if(findin(T,[0,1,2,3,4,5])<0) return L1;
3470: if(T==4||T==5){
3471: if(type(C1)<2) C1=[C1];
3472: if(type(C2)<2) C2=[C2];
3473: }
1.8 takayama 3474: if(type(car(L2))!=4){
3475: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3476: R=reverse(R);
3477: if(length(K)==1) K=[K[0],0];
3478: C2=0;
3479: }
1.10 takayama 3480: L1=lsort(L1,"num",["put",0]); /* insert number */
3481: K0=(length(K)>0)?K[0]+1:1;
3482: K1=(length(K)>1)?K1=K[1]:0;
3483: L1=lsort(L1,"sort",[0,K0]);
3484: if(T<4&&type(C2)==4&&length(L2[0])>1){
3485: L2=lsort(L2,"col",["put"]|c1=cons(K1,C2)); /* add key and extract columns */
3486: C2=0;K1=0;
3487: }
3488: L2=lsort(L2,"sort",[0,K1]);
3489: for(R0=[],S=S1=length(L1[0]);S>0;S--) R0=cons("",R0);
3490: for(R1=[],S=length(L2[0]);S>0;S--) R1=cons("",R1);
3491: if(!K1&&T!=3) R1=cdr(R1);
3492: for(R=[];L1!=[];L1=cdr(L1)){
3493: while(L2!=[]&&car(L1)[K0]>car(L2)[K1]){
3494: if(T==3) R=cons(append(R0,car(L2)),R);
3495: L2=cdr(L2);
3496: }
3497: if(L2==[]||car(L1)[K0]<car(L2)[K1]){
3498: if(T!=2) R=cons((T==1||T>3||R1==[])?car(L1):append(car(L1),R1),R);
3499: }else if(T==0||T==2||T==3){
3500: if(R0==[]) R=append(car(L1),R);
3501: else R=cons(append(car(L1),(!K1&&T!=3)?cdr(car(L2)):car(L2)),R);
3502: L2=cdr(L2);
3503: }else if(T==4||T==5){
3504: V1=ltov(car(L1));V2=ltov(car(L2));
3505: for(D1=C1,D2=C2;D1!=[];D1=cdr(D1),D2=cdr(D2))
3506: if((I=V2[car(D2)])!=""||T==4) V1[car(D1)+1]=I;
3507: R=cons(vtol(V1),R);
3508: }
3509: }
3510: if(T==3){
3511: while(L2!=[]){
3512: R=cons(append(R0,car(L2)),R);
3513: L2=cdr(L2);
3514: }
3515: }
3516: R=lsort(R,"sort",["put",0]); /* original order */
3517: D=(((T==0||T==2)&&!K1)||T==3)?[0]:[0,S1+K1];
3518: R=lsort(R,0,[1]|c1=D); /* delete */
3519: if(type(C1)!=4||T==1||T==4||T==5) return R;
3520: C=[];S0=size(L1[0]);
3521: for(;C1!=[];C1=cdr(C1)) C=cons(car(C1),C);
3522: for(I=0;I<S0-S1;I++) C=cons(I+S1,C);
1.8 takayama 3523: C=reverse(C);
1.10 takayama 3524: return lsort(R,"col",[1]|c1=C);
1.8 takayama 3525: }
3526: }
1.10 takayama 3527: if(L2 == []){ /* [...] */
3528: if(T==8||TT=="count") return [length(L1),length(lsort(L1,[],1))];
3529: if(T==7||TT=="cut"){
3530: K=length(L1);
3531: if(C1<0) C1=K+C1;
3532: for(R=[],I=0;I<C1&&L1!=[];I++,L1=cdr(L1))
3533: R=cons(car(L1),R);
3534: for(S=[];L1!=[];L1=cdr(L1))
3535: S=cons(car(L1),S);
3536: return [reverse(R),reverse(S)];
3537: }
3538: if(T==2) return L2;
3539: if(T==3) return [L1,L2];
1.6 takayama 3540: L1 = ltov(L1); qsort(L1);
3541: if(T != 1)
3542: return vtol(L1);
3543: L3 = [];
3544: for(I = length(L1)-1; I >= 0; I--){
3545: if(I > 0 && L1[I] == L1[I-1])
3546: continue;
3547: L3 = cons(L1[I], L3);
3548: }
3549: return L3;
3550: }
1.10 takayama 3551: if(T==8||TT=="count"){
3552: K=length(lsort(L1,L2,3)[0]);
3553: R=[length(L2),length(L1)];
3554: L1 = lsort(L1,[],1);
3555: L2 = lsort(L2,[],1);
3556: R=append([length(L2),length(L1)],R);
3557: R=cons(length(lsort(L1,L2,2)),R);
3558: return reverse(cons(K,R));
3559: }
1.12 takayama 3560: if((T==9||TT=="cons")&&type(car(L1))==4){
3561: if(type(L2)!=4) L2=[L2];
3562: for(R=[];L1!=[];L1=cdr(L1)){
3563: R=cons(cons(car(L2),car(L1)),R);
3564: if(length(L2)>1) L2=cdr(L2);
3565: }
3566: return reverse(R);
3567: }
1.13 takayama 3568: if(T==10||TT=="cmp"){
3569: if(length(L1)!=length(L2)){
3570: mycat("Different length!");
3571: return 1;
3572: }
3573: R=[];
3574: if(type(car(L1))==4){
3575: for(U=[],I=0;L1!=[];I++,L1=cdr(L1),L2=cdr(L2)){
3576: if(length(S=car(L1))!=length(T=car(L2))){
3577: mycat(["Different size : line ",I]);
3578: return 0;
3579: }
3580: for(J=0;S!=[];S=cdr(S),T=cdr(T),J++)
3581: if(car(S)!=car(T)) U=cons([[I,J],car(S),car(T)],U);
3582: }
3583: if(U!=[]) R=cons(reverse(U),R);
3584: }else{
3585: for(I=0;L1!=[];L1=cdr(L1),L2=cdr(L2),I++)
3586: if(car(L1)!=car(L2)) R=cons([I,car(L1),car(L2)],R);
3587: }
3588: return reverse(R);
3589: }
3590: if(T==11||TT=="append"){
3591: if(type(car(L1))!=4) return append(L1,L2);
3592: for(R=[];L1!=[];L1=cdr(L1),L2=cdr(L2))
3593: R=cons(append(car(L1),car(L2)),R);
3594: return reverse(R);
3595: }
1.6 takayama 3596: if(T == 1 || T == 2){
3597: L1 = lsort(L1,[],1);
3598: L2 = lsort(L2,[],1);
3599: L3 = [];
3600: if(T == 1){
3601: while(L1 != []){
3602: if(L2 == [] || car(L1) < car(L2)){
3603: L3 = cons(car(L1), L3);
3604: L1 = cdr(L1);
3605: continue;
3606: }
3607: if(car(L1) > car(L2)){
3608: L2 = cdr(L2);
3609: continue;
3610: }
3611: L1 = cdr(L1); L2 = cdr(L2);
3612: }
3613: return reverse(L3);
3614: }
3615: if(T==2){
3616: while(L1 != [] && L2 != []){
3617: if(car(L1) != car(L2)){
3618: if(car(L1) <= car(L2))
3619: L1 = cdr(L1);
3620: else L2 = cdr(L2);
3621: continue;
3622: }
3623: while(car(L1) == car(L2))
3624: L1 = cdr(L1);
3625: L3 = cons(car(L2), L3);
3626: }
3627: return reverse(L3);
3628: }
3629: }
3630: if(T==3){
3631: L1 = qsort(L1); L2 = qsort(L2);
3632: L3 = L4 = [];
3633: while(L1 != [] && L2 != []){
3634: if(car(L1) == car(L2)){
3635: L1 = cdr(L1); L2 = cdr(L2);
3636: }else if(car(L1) < car(L2)){
3637: L3 = cons(car(L1),L3);
3638: L1 = cdr(L1);
3639: }else{
3640: L4 = cons(car(L2), L4);
3641: L2 = cdr(L2);
3642: }
3643: }
3644: L4 = append(reverse(L4),L2);
3645: L3 = append(reverse(L3),L1);
3646: return [L3,L4];
3647: }
3648: L1 = append(L1,L2);
3649: return lsort(L1,[],1);
3650: }
3651:
3652: def mqsub(X,Y)
3653: {
3654: for(L=LQS;L!=[];L=cdr(L)){
3655: F=(T=car(L))[0];M=(T=cdr(T))[0];
3656: X0=X;Y0=Y;
3657: for(T=cdr(T);T!=[];T=cdr(T)){
3658: X0=X0[car(T)];Y0=Y0[car(T)];
3659: }
3660: if(type(M)==1){
3661: if(M==3){
3662: X0=type(X0);Y0=type(Y0);
3663: }else if(M==4&&type(X0)<2&&type(Y0)<2){
3664: X0=abs(X0);Y0=abs(Y0);
3665: }else if(M==5){
3666: X0=str_len(rtostr(X0));Y0=str_len(rtostr(Y0));
3667: }else if(type(X0)==type(Y0)&&type(X0)>3&&type(X0)<7){
3668: if(M==1){
3669: X0=length(X0);Y0=length(Y0);
3670: }else if(M==2){
3671: LX=length(X0);LY=length(Y0);
3672: L0=(LX<LY)?LX:LY;
3673: for(I=0;;I++){
3674: if(I==L0){
3675: X0=LX;Y0=LY;break;
3676: }
3677: if(X0[I]==Y0[I]) continue;
3678: X0=X0[I];Y0=Y0[I];break;
3679: }
3680: }
3681: }
3682: }else if(type(M)==2){
3683: X0=(*M)(X0,Y0);Y0=0;
3684: }else if(type(M)==4&&length(M)==1){
3685: X0=(*car(M))(X0);Y0=(*car(M))(Y0);
3686: }
3687: if(X0==Y0) continue;
3688: return (X0<Y0)?-F:F;
3689: }
3690: return 0;
3691: }
3692:
3693: def msort(L,S)
3694: {
3695: if(type(S)!=4) return qsort(L);
3696: if(type(S[0])!=4) S=[S];
3697: LQS=S;
3698: return qsort(L,os_md.mqsub);
3699: }
3700:
1.22 takayama 3701: def lpair(A,B)
3702: {
3703: if(B==0){
3704: for(S=T=[];A!=[];A=cdr(A)){
3705: S=cons(car(A)[0],S);T=cons(car(A)[1],T);
3706: }
3707: return [reverse(S),reverse(T)];
3708: }else{
3709: for(R=[];A!=[];A=cdr(A),B=cdr(B))
3710: R=cons([car(A),car(B)],R);
3711: return reverse(R);
3712: }
3713: }
3714:
1.6 takayama 3715: def lmax(L)
3716: {
3717: if(type(L)==4){
3718: V=car(L);
3719: while((L=cdr(L))!=[])
3720: if(V < car(L)) V=car(L);
3721: return V;
3722: }else if(type(L)==5||type(L)==6)
3723: return lmax(m2l(L));
3724: return [];
3725: }
3726:
3727: def lmin(L)
3728: {
3729: if(type(L)==4){
3730: V=car(L);
3731: while((L=cdr(L))!=[])
3732: if(V > car(L)) V=car(L);
3733: return V;
3734: }else if(type(L)==5||type(L)==6)
3735: return lmin(m2l(L));
3736: return [];
3737: }
3738:
3739: def lgcd(L)
3740: {
3741: if(type(L)==4){
3742: F=getopt(poly);
3743: V=car(L);
3744: while((L=cdr(L))!=[]&&V!=1){
3745: if(V!=0)
3746: V=(F==1)?gcd(V,car(L)):igcd(V,car(L));
3747: }
3748: return V;
3749: }else if(type(L)==5||type(L)==6)
3750: return lgcd(m2l(L)|option_list=getopt());
3751: return [];
3752: }
3753:
3754: def llcm(L)
3755: {
3756: if(type(L)==4){
3757: F=getopt(poly);
3758: V=car(L);
3759: while((L=cdr(L))!=[]){
3760: if(V!=0){
3761: if((V0=car(L))!=0)
3762: V=(F==1)?red(V*V0/gcd(V,V0)):ilcm(V,V0);
3763: }
3764: else V=car(L);
3765: }
3766: if(F!=1&&V<0) V=-V;
3767: return V;
3768: }
3769: else if(type(L)==5||type(L)==6)
3770: return llcm(m2l(L)|option_list=getopt());
3771: return [];
3772: }
3773:
3774: def ldev(L,S)
3775: {
3776: M=abs(lmax(L));N=abs(lmin(L));
3777: if(M<N) M=N;
3778: for(C=0,LT=L;;C++){
3779: LT=ladd(LT,S,1);
3780: MT=abs(lmax(LT));NT=abs(lmin(LT));
3781: if(MT<NT) MT=NT;
3782: if(MT>=M) break;
3783: M=MT;
3784: }
3785: if(!C){
3786: for(C=0,LT=L;;C--){
3787: LT=ladd(LT,S,-1);
3788: MT=abs(lmax(LT));NT=abs(lmin(LT));
3789: if(MT<NT) MT=NT;
3790: if(MT>=M) break;
3791: M=MT;
3792: }
3793: }
3794: return [C,ladd(L,S,C)];
3795: }
3796:
3797: def lchange(L,P,V)
3798: {
3799: if(getopt(flat)==1&&type(P)==4){
3800: for(L=ltov(L);P!=[];P=cdr(P),V=cdr(V))
3801: L[car(P)]=car(V);
3802: return vtol(L);
3803: }
3804: if(type(P)==4){
3805: IP=car(P); P=cdr(P);
3806: }else{
3807: IP=P; P=[];
3808: }
3809: for(I=0, LL=[], LT=L; LT!=[]; I++,LT=cdr(LT)){
3810: if(I==IP){
3811: LL=cons((P==[])?V:lchange(car(LT),P,V),LL);
3812: }else
3813: LL=cons(car(LT),LL);
3814: }
3815: return reverse(LL);
3816: }
3817:
3818: def lsol(VV,L)
3819: {
3820: if(type(VV)<4 && type(L)==2)
3821: return red(L-VV/mycoef(VV,1,L));
3822: S = length(VV);
3823: T = length(L);
3824: V = llbase(VV,L);
3825: for(J = K = 0; J < T; J++){
3826: X = var(L[J]); N = deg(L[J],X);
3827: for(I = K; I < S; I++){
3828: if((C=mycoef(V[I], N, X)) != 0){
3829: V[I] = [L[J],red(X^N-V[I]/C)];
3830: K++;
3831: break;
3832: }
3833: }
3834: }
3835: return V;
3836: }
3837:
3838: def lnsol(VV,L)
3839: {
3840: LL=lsort(vars(VV),L,1);
3841: VV=ptol(VV,LL|opt=0);
3842: return lsol(VV,L);
3843: }
3844:
3845:
3846: def ladd(X,Y,M)
3847: {
1.22 takayama 3848: if(type(Y)==4) Y=ltov(Y);
1.6 takayama 3849: if(type(X)==4) X=ltov(X);
3850: return vtol(X+M*Y);
3851: }
3852:
3853: def mrot(X)
3854: {
1.22 takayama 3855: if(type(X)==4){
3856: if(getopt(deg)==1)
3857: X=[deval(@pi*X[0]/180),deval(@pi*X[1]/180),deval(@pi*X[2]/180)];
3858: if(getopt(conj)==1)
3859: return mrot([-X[2],-X[1],0])*mrot([X[0],X[1],X[2]]);
3860: if(X[1]==0){
3861: X=[X[0]+X[2],0,0];
3862: if(X[0]==0) return diagm(3,[1]);
3863: }
3864: if(X[0]!=0){
3865: M=mat([dcos(X[0]),-dsin(X[0]),0],[dsin(X[0]),dcos(X[0]),0],[0,0,1]);
3866: if(X[1]==0) return M;
3867: }
3868: N=mat([dcos(X[1]),0,-dsin(X[1])],[0,1,0],[dsin(X[1]),0,dcos(X[1])]);
3869: if(X[0]!=0) N=M*N;
3870: if(X[2]==0) return N;
3871: return N*mrot([X[2],0,0]);
3872: }
1.6 takayama 3873: if(getopt(deg)==1) X=@pi*X/180;
3874: X=deval(X);
1.22 takayama 3875: return mat([dcos(X),-dsin(X)],[dsin(X),dcos(X)]);
1.6 takayama 3876: }
3877:
3878: def m2v(M)
3879: {
3880: S = size(M);
3881: V = newvect(S[0]*S[1]);
3882: for(I = C = 0; I < S[0]; I++){
3883: MI = M[I];
3884: for(J = 0; J < S[1]; J++)
3885: V[C++] = MI[J];
3886: }
3887: return V;
3888: }
3889:
3890: def lv2m(L)
3891: {
3892: if(type(L)==5) L=vtol(L);
3893: II=length(L);
3894: for(J=1,T=L; T!=[]; T=cdr(T))
3895: if(length(car(T))>JJ) JJ=length(car(T));
3896: M = newmat(II,JJ);
3897: N = getopt(null);
3898: if(type(N)<0) N=0;
3899: for(I=0; I<II; I++){
3900: V=car(L); L=cdr(L);
3901: for(J=length(V);--J>=0;)
3902: M[I][J] = V[J];
3903: if(N!=0){
3904: for(J=length(V); J<JJ; J++)
3905: M[I][J]=N;
3906: }
3907: }
3908: return M;
3909: }
3910:
3911: def m2lv(M)
3912: {
3913: I=size(M)[0];
3914: for(N=[],I=size(M)[0];I-->0;)
3915: N=cons(M[I],N);
3916: return N;
3917: }
3918:
3919: def s2m(S)
3920: {
3921: if(type(S)==6) return S;
3922: if(type(S)==7){
3923: if(str_chr(S,0,"[")!=0) S=s2sp(S);
3924: else if(str_chr(S,0,",")>=0) return eval_str(S);
3925: else{
3926: for(L=LL=[],I=0; ; ){
3927: II=str_chr(S,I+2,"]");
3928: if(II<0) return 0;
3929: J=str_chr(S,I+2," ");
3930: while(str_chr(S,J+1," ")==J+1) J++;
3931: if(J>II-2 || J<0) J=II;
3932: V=eval_str(sub_str(S,I+1,J-1));
3933: L=cons(V,L);
3934: I=J;
3935: if(J==II){
3936: LL=cons(ltov(reverse(L)),LL);
3937: L=[];
3938: if((I=str_chr(S,II+1,"["))<0)
3939: return lv2m(reverse(LL));
3940: }
3941: }
3942: }
3943: }
3944: if(type(S)==5) S=vtol(S);
3945: if(type(S[0])==5) return lv2m(S);
3946: I=length(S);
3947: for(J=1,T=S; T!=[]; T=cdr(T))
3948: if(length(car(T))>J) J=length(car(T));
3949: return newmat(I,J,S);
3950: }
3951:
3952: def c2m(L,V)
3953: {
3954: if(type(Pow=getopt(pow))!=1){
3955: if(isvar(V)==1){
3956: for(Pow=0,LT=L;LT!=[];LT=cdr(LT)){
3957: if(mydeg(car(LT),V)>JJ) Pow=mydeg(car(LT),V);
3958: }
3959: JJ=Pow+1;
3960: }else{
3961: Pow=-1;
3962: JJ=length(V);
3963: }
3964: }else JJ=Pow+1;
3965: M=newmat(length(L),JJ);
3966: for(I=0;L!=[];L=cdr(L),I++){
3967: for(J=0;J<JJ;J++){
3968: LT=car(L);
3969: M[I][J]=(Pow>=0)?mycoef(LT,J,V):mycoef(LT,1,V[J]);
3970: }
3971: }
3972: return M;
3973: }
3974:
3975: #if 0
3976: def m2diag(M,N)
3977: {
3978: S = size(M);
3979: MM = mtoupper(M,N);
3980: for(I = S[0]-1; I >= 0; I--){
3981: for(J = 0; I < S[1]-N; I++){
3982: if(MM[I][J] != 0){
3983: P = MM[I][J];
3984: for(K = 0; K < I; K++){
3985: Q = -rmul(MM[K][J],1/P);
3986: MM[K][J] = 0;
3987: if(Q != 0){
3988: for(L = J+1; L < S[1]; L++){
3989: if(MM[I][L] != 0)
3990: MM[K][L] = radd(MM[K][L], rmul(MM[I][L],Q));
3991: }
3992: }
3993: }
3994: }
3995: }
3996: }
3997: return MM;
3998: }
3999: #endif
4000:
4001: def myinv(M)
4002: {
4003: S = size(M);
4004: if((T=S[0]) != S[1])
4005: return 0;
4006: MM = mtoupper(M,-T|opt=2);
4007: if(MM[T-1][T-1] != 1) return 0;
4008: return mperm(MM,0,[T,[T]]);
4009: }
4010:
4011: def madj(G,M)
4012: {
4013: H=myinv(G);
4014: if(type(M)==6)
4015: return rmul(rmul(G,M),H);
4016: if(type(M)==4||type(M)==5){
4017: L=length(M);
4018: N=newvect(L);
4019: for(I=0;I<L;I++){
4020: N[I]=rmul(rmul(G,M[I]),H);
4021: }
4022: if(type(N)==4) N=vtol(N);
4023: return N;
4024: }
4025: return -1;
4026: }
4027:
4028: def mpower(M,N)
4029: {
4030: if(type(M)<=3) return (red(M))^N;
4031: S = size(M);
4032: if(S[0] != S[1])
4033: return 0;
4034: if(N == 0) return mgen(S[0],0,[1],0);
4035: if(N < 0)
4036: return(mpower(myinv(M), -N));
4037: R = dupmat(M);
4038: V=1;
4039: for(V=1;;){
4040: if(iand(N,1)){
4041: V=map(red,R*V);
4042: N--;
4043: }
4044: if((N/=2)==0) break;
4045: R=map(red,R*R);
4046: }
4047: return V;
4048: }
4049:
4050: def texlen(S)
4051: {
4052: if(type(S)!=7) return 0;
4053: LF=I=J=0;
4054: LM=str_len(S);
4055: while((I=str_str(S,"\\frac{"|top=J))>=0){
4056: if(I>J) LF+=texlen(str_cut(S,J,I-1));
4057: I+=6;
4058: for(F=L=0,J=I;F<2 && J<LM-1;F++){
4059: for(C=1;C>0 && J<LM;){
4060: if((K0=str_char(S,J,"}"))<0) K0=LM;
4061: if((K1=str_char(S,J,"{"))<0) K1=LM;
4062: if(K0<0 && K1<0){
4063: J = str_len(S)-1;
4064: break;
4065: }
4066: if(K0<K1){
4067: J=K0+1; C--;
4068: }else{
4069: J=K1+1; C++;
4070: }
4071: }
4072: T=str_cut(S,I,J-1);
4073: if(F==0){
4074: I=J=K1+1;C=1;
4075: }else J=K0+1;
4076: if(type(T)==7 && (LL=texlen(T))>L) L=LL;
4077: }
4078: LF+=L;
4079: }
4080: if(J>0) S=str_cut(S,J,str_len(S)-1);
4081: if(S==0) return LF;
4082: S=ltov(strtoascii(S));
4083: L=LL=length(S);
4084: for(I=F=0; I<L; I++){
4085: if(S[I]==92) F=1;
4086: else if(F==1){
4087: if((S[I]>96 && S[I]<123)||(S[I]>64 && S[I]<91)) LL--;
4088: else F=0;
4089: }
4090: if(S[I]<=32||S[I]==123||S[I]==125||S[I]==94||S[I]==38) LL--; /* {}^& */
4091: else if(S[I]==95){
4092: LL--;
4093: if(I+2<L && S[I+2]==94) LL--; /* x_2^3 */
4094: else if(I+6<L && S[I+1]==123 && S[I+4]==125){ /* x_{11}^2 */
4095: if(S[I+5]==94 || (S[I+5]==125 && S[I+6]==94)) LL-- ; /* x_{11}}^2 */
4096: }
4097: }
4098: }
4099: return LL+LF;
4100: }
4101:
4102: def isdif(P)
4103: {
4104: if(type(P)<1 || type(P)>3) return 0;
4105: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4106: V0=rtostr(car(R));
4107: if(V0>"d" && V0<"e"){
4108: V=sub_str(V0,1,str_len(V0)-1);
4109: if(V>="a" && V<"{") Var=cons([strtov(V),strtov(V0)],Var);
4110: }
4111: }
4112: if(Var==[]) return 0;
4113: for(V=Var; V!=[]; V=cdr(V))
4114: if(ptype(P,car(V)[1])==3) return 0;
4115: return Var;
4116: }
4117:
4118: def texsp(P)
4119: {
4120: Q=strtoascii(P);
4121: if((J=str_char(Q,0,92))<0 || (C=Q[L=str_len(P)-1])==32||C==41||C==125)
4122: return P;
4123: for(;;){
4124: if((I=str_char(Q,J+1,92))<0) break;
4125: J=I;
4126: };
4127: for(I=J+1;I<L&&isalpha(Q[I]);I++);
4128: return(I==L)?P+" ":P;
4129: }
4130:
4131: def fctrtos(P)
4132: {
4133: /* extern TeXLim; */
4134:
4135: if(!chkfun("write_to_tb", "names.rr"))
4136: return 0;
4137:
4138: TeX = getopt(TeX);
4139: if(TeX != 1 && TeX != 2 && TeX != 3)
4140: TeX = 0;
4141: if((Dvi=getopt(dviout)==1) && TeX<2) TeX=3;
4142: if(TeX>0){
4143: Lim=getopt(lim);
4144: if(Lim!=0 && TeX>1 && (type(Lim)!=1||Lim<30)) Lim=TeXLim;
4145: else if(type(Lim)!=1) Lim=0;
4146: CR=(TeX==2)?"\\\\\n":"\\\\\n&";
4147: if(TeX==1 || Lim==0) CR="";
4148: else if((Pages=getopt(pages))==1) CR="\\allowdisplaybreaks"+CR;
4149: if(!chkfun("print_tex_form", "names.rr"))
4150: return 0;
4151: Small=getopt(small);
4152: }
4153: Dif=getopt(dif);
4154: Var=getopt(var);
4155: if(Lim>0 && type(Var)<2 && TeX!=1) Var=[strtov("0"),""];
4156: Dif=0;
4157: if(Var=="dif"){
4158: Dif=DV=1;
4159: }else if (Var=="dif0") Dif=1;
4160: else if(Var=="dif1") Dif=2;
4161: else if(Var=="dif2") Dif=3;
4162: if(Dif>0){
4163: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4164: V=rtostr(car(R));
4165: if(V>"d" && V<"e"){
4166: V=sub_str(V,1,str_len(V)-1);
4167: if(V>="a" && V<"{"){
4168: if(TeX>0){
4169: V=my_tex_form(strtov(V));
4170: if(Dif>=1){
4171: if(Dif==1){
4172: if(str_len(V)==1) V="\\partial_"+V;
4173: else V="\\partial_{"+V+"}";
4174: }
4175: Var=cons([car(R),V],Var);
4176: }
4177: else Var=cons([car(R)],Var);
4178: }else Var=cons([car(R)],Var);
4179: }
4180: }
4181: }
4182: if(TeX>0){
4183: if(length(Var)==1){
4184: if(DV==1 && str_len(Var[0][1])==10) Var=[[Var[0][0],"\\partial"]];
4185: }else if(DV==1){
4186: for(V=Var;V!=[];V=cdr(V)){
4187: VV=rtostr(car(V)[0]);
4188: if(VV<"dx0" || VV>= "dx:" || str_len(VV)>4) break;
4189: }
4190: if(V==[]){
4191: for(VT=[],V=Var;V!=[];V=cdr(V)){
4192: VV=str_cut(rtostr(car(V)[0]),2,3);
4193: if(str_len(VV)==1) VT=cons([car(V)[0],"\\partial_"+VV],VT);
4194: else VT=cons([car(V)[0],"\\partial_{"+VV+"}"],VT);
4195: }
4196: Var=reverse(VT);
4197: }
4198: }else
4199: if(Dif==2 && length(Var)>1) Dif=3;
4200: }
4201: if(Dif>0) Dif--;
4202: }
4203: if(type(Var)>1 && Var!=[]){ /* as a polynomial of Var */
4204: Add=getopt(add);
4205: if(type(Add)>0){
4206: if(type(Add)!=7){
4207: Add=my_tex_form(Add);
4208: if(str_char(Add,0,"-")>=0 || str_char(Add,0,"+")>=0) Add="("+Add+")";
4209: }
4210: if(str_char(Add,0,"(")!=0) Add = " "+Add;
4211: }else Add=0;
4212: if(type(Var)!=4) Var=[Var];
4213: if(length(Var)==2 && type(Var[1]) == 7)
4214: Var = [Var];
4215: for(VV=VD=[]; Var!=[];Var=cdr(Var)){
4216: VT=(type(car(Var))==4)?car(Var):[car(Var)];
4217: VT0=var(car(VT));
4218: VV=cons(VT0,VV);
4219: if(length(VT)==1){
4220: VD=cons((TeX>=1)?my_tex_form(VT0):rtostr(VT0),VD);
4221: }else VD=cons(VT[1],VD);
4222: }
4223: VV=reverse(VV);VD=reverse(VD);
4224: Rev=(getopt(rev)==1)?1:0;
4225: Dic=(getopt(dic)==1)?1:0;
4226: TT=terms(P,VV|rev=Rev,dic=Dic);
4227: if(TeX==0){
4228: Pre="("; Post=")";
4229: }else{
4230: Pre="{"; Post="}";
4231: }
4232: Out = string_to_tb("");
4233: for(L=C=0,Tm=TT;Tm!=[];C++,Tm=cdr(Tm)){
4234: for(I=0,PC=P,T=cdr(car(Tm)),PW="";T!=[];T=cdr(T),I++){
4235: PC=mycoef(PC,D=car(T),VV[I]);
4236: if(PC==0) continue;
4237: PT="";
4238: if(D!=0 && VD[I]!=""){
4239: if(TeX==0 && PW!="") PW+="*";
4240: if(D>1){
4241: if(D>9) PT="^"+Pre+rtostr(D)+Post;
4242: else PT="^"+rtostr(D);
4243: }
4244: if(Dif>0) PW+=(Dif==1)?"d":"\\partial ";
4245: PW+=VD[I]+PT;
4246: }
4247: }
4248: D=car(Tm)[0];
4249: if(Dif>0 && D>0){
4250: Op=(Dif==1)?"\\frac{d":"\\frac{\\partial";
4251: if(D>1) Op+="^"+((D>9)?(Pre+rtostr(D)+Post):rtostr(D));
4252: PW=Op+Add+"}{"+PW+"}";
4253: }else if(Add!=0) PW=PW+Add;
4254: if(TeX>=1){
4255: if(type(PC)==1 && ntype(PC)==0 && PC<0)
4256: OC="-"+my_tex_form(-PC);
4257: else OC=fctrtos(PC|TeX=1,br=1);
4258: }else OC=fctrtos(PC|br=1);
4259: if(PW!=""){
4260: if(OC == "1") OC = "";
4261: else if(OC == "-1") OC = "-";
4262: }
4263: if(TeX==0 && D!=0 && OC!="" && OC!="-") PW= "*"+PW;
4264: if((TOC=type(OC)) == 4){ /* rational coef. */
4265: if(Lim>0 && (texlen(OC[0])>Lim || texlen(OC[0])>Lim)){
4266: OC = (Small==1)?"("+OC[0]+")/("+OC[1]+")"
4267: :"\\Bigl("+OC[0]+"\\Bigr)\\Bigm/\\Bigl("+OC[1]+"\\Bigr)";
4268: TOC = 7;
4269: }else{
4270: if(str_char(OC[0],0,"-")==0){
4271: OC = fctrtos(-PC|TeX=1,br=1);
4272: OC = "-\\frac{"+OC[0]+"}{"+OC[1]+"}";
4273: }
4274: else
4275: OC = "\\frac{"+OC[0]+"}{"+OC[1]+"}";
4276: }
4277: }
4278: if(Lim>0){
4279: LL=texlen(OC)+texlen(PW);
4280: if(LL+L>=Lim){
4281: if(L>0) str_tb(CR,Out);
4282: if(LL>Lim){
4283: if(TOC==7) OC=texlim(OC,Lim|cut=CR);
4284: PW+=CR; L=0;
4285: }else L=LL;
4286: }else L+=LL;
4287: }else if(length(Tm)!=1) PW += CR; /* not final term */
4288: if(TeX) OC=texsp(OC);
4289: if(str_chr(OC,0,"-") == 0 || C==0) str_tb([OC,PW], Out);
4290: else{
4291: str_tb(["+",OC,PW],Out);
4292: if(LL<=Lim) L++;
4293: }
4294: }
4295: S=str_tb(0,Out);
4296: if(S=="") S="0";
4297: }else{ /* Var is not specified */
4298: if((TP=type(P)) == 3){ /* rational function */
4299: P = red(P); Nm=nm(P); Dn=dn(P);
4300: Q=dn(ptozp(Nm|factor=1)[1]);
4301: if(Q>1){
4302: Nm*=Q;Dn*=Q;
4303: }
4304: if(TeX>0){
4305: return (TeX==2)?
4306: "\\frac\{"+fctrtos(Nm|TeX=1)+"\}\{"+fctrtos(Dn|TeX=1)+"\}"
4307: :[fctrtos(Nm|TeX=1),fctrtos(Dn|TeX=1)];
4308: }
4309: else{
4310: S=fctrtos(Nm);
4311: if(nmono(Nm)>1) S="("+S+")";
4312: return S+"/("+fctrtos(Dn)+")";
4313: }
4314: }
4315: if(imag(P)==0) P = fctr(P); /* usual polynomial */
4316: else P=[[P,1]];
4317: S = str_tb(0,0);
4318: for(J = N = 0; J < length(P); J++){
4319: if(type(P[J][0]) <= 1){
4320: if(P[J][0] == -1){
4321: write_to_tb("-",S);
4322: if(length(P) == 1)
4323: str_tb("1", S);
4324: }else if(P[J][0] != 1){
4325: str_tb((TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]), S);
4326: N++;
4327: }else if(length(P) == 1)
4328: str_tb("1", S);
4329: else if(getopt(br)!=1 && length(P) == 2 && P[1][1] == 1){
4330: str_tb((TeX>=1)?my_tex_form(P[1][0]):rtostr(P[1][0]), S);
4331: J++;
4332: }
4333: continue;
4334: }
4335: if(N > 0 && TeX != 1 && TeX != 2 && TeX != 3)
4336: write_to_tb("*", S);
4337: SS=(TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]);
4338: N++;
4339: if(P[J][1] != 1){ /* (log(x))^2 */
4340: if(nmono(P[J][0])>1||
4341: (!isvar(P[J][0])||vtype(P[J][0]))&&str_len(SS)>1) SS="("+SS+")";
4342: write_to_tb(SS,S);
4343: str_tb(["^", (TeX>1)?rtotex(P[J][1]):monotos(P[J][1])],S);
4344: }else{
4345: if(nmono(P[J][0])>1) SS="("+SS+")";
4346: write_to_tb(SS,S);
4347: }
4348: }
4349: S = str_tb(0,S);
4350: if((Lim>0 || TP!=2) && CR!="") S=texlim(S,Lim|cut=CR);
4351: }
4352: if(TeX>0){
4353: if(Small==1) S=str_subst(S,"\\frac{","\\tfrac{");
4354: if(Dvi==1){
4355: dviout(strip(S,"(",")")|eq=(Pages==1)?6:0); S=1;
4356: }
4357: }
4358: return S;
4359: }
4360:
4361: def strip(S,S0,S1)
4362: {
4363: SS=strtoascii(S);
4364: if(length(SS)>1){
4365: if(SS[0]==40&&SS[length(SS)-1]==41&&str_pair(SS,1,S0,S1)==length(SS)-1)
4366: S=str_cut(SS,1,length(SS)-2);
4367: }
4368: return S;
4369: }
4370:
4371: def texlim(S,Lim)
4372: {
4373: /* extern TeXLim; */
4374: if(S==1 && Lim>10){
4375: TeXLim=Lim;
4376: mycat(["Set TeXLim =",Lim]);
4377: return 1;
4378: }
4379: if(type(Out=getopt(cut))!=7) Out="\\\\\n&";
4380: if(type(Del=getopt(del))!=7) Del=Out;
4381: if(Lim<30) Lim=TeXLim;
4382: S=ltov(strtoascii(S));
4383: for(L=[0],I=F=0;F==0; ){
4384: II=str_str(S,Del|top=I)+2;
4385: if(II<2){
4386: F++;II=/* str_len(S) */ length(S)-1;
4387: }
4388: for(J=JJ=I+1;;JJ=K+1){
4389: K=str_char(S,JJ,43); /* + */
4390: if((K1=str_char(S,JJ,45))>2 && K1<K){ /* - */
4391: if(S[K1-1]!=123 && S[K1-1]!=40) K=K1; /* {, ( */
4392: }
4393: if((K1=str_char(S,JJ,40))>0 && K1-JJ>6 && K1<K && S[K1-1]!=43 && S[K1-1]!=45){ /* ( */
4394: T=str_char(S,K1-6,"\\"); /* \Big*(, \big*( */
4395: if((T==K1-6 || T==K1-5)
4396: && (str_str(S,"big"|top=T+1,end=T+1)>0 || str_str(S,"Big"|top=T+1,end=T+1)>0))
4397: K=T;
4398: else if(K1>0 && K1<K) K=K1;
4399: }
4400: if(K<0 || K>II) break;
4401: if(K-J>Lim && texlen(str_cut(S,J,K-1))>=Lim){
4402: J=K+1; L=cons(JJ-1,L); SL=0;
4403: }
4404: }
4405: I=II;
4406: }
4407: SS=str_tb(0,0);
4408: L=cons(length(S),L);
4409: L=reverse(L);
4410: for(I=0; L!=[]; I=J,L=cdr(L)){
4411: str_tb((I==0)?"":Out,SS);
4412: J=car(L);
4413: str_tb(str_cut(S,I,J-1),SS);
4414: }
4415: return str_tb(0,SS);
4416: }
4417:
4418: def fmult(FN,M,L,N)
4419: {
4420: Opt=getopt();
4421: for(I = 0; I < length(M); I++)
4422: M = call(FN, cons(M,cons(L[I],N))|option_list=Opt);
4423: return M;
4424: }
4425:
4426: def radd(P,Q)
4427: {
4428: if(type(P) <= 3 || type(Q) <= 3){
4429: if(type(P) >= 5)
4430: return radd(Q,P);
4431: if(type(Q) >= 5){
4432: R = dupmat(Q);
4433: if(P == 0)
4434: return R;
4435: if(type(Q) == 6){
4436: S = size(Q);
4437: if(S[0] != S[1])
4438: return 0;
4439: for(I = 0; I < S[0]; I++)
4440: R[I][I] = radd(R[I][I], P);
4441: }else{
4442: for(I = length(R)-1; I >= 0; I--)
4443: R[I] = radd(R[I],P);
4444: }
4445: return R;
4446: }
4447: /* P=red(P);Q=red(Q); */
4448: if((P1=dn(P)) == (Q1=dn(Q))){
4449: if(P1==1) return P+Q;
4450: return red((nm(P)+nm(Q))/P1);
4451: }
4452: R=gcd(P1,Q1);S=tdiv(P1,R);
4453: return red((nm(P)*tdiv(Q1,R)+nm(Q)*S)/(S*Q1));
4454: }
4455: if(type(P) == 5){
4456: S = length(P);
4457: R = newvect(S);
4458: for(I = 0; I < S; I++)
4459: R[I] = radd(P[I],Q[I]);
4460: return R;
4461: }
4462: if(type(P) == 6){
4463: S = size(P);
4464: R = newmat(S[0],S[1]);
4465: for(I = 0; I < S[0]; I++){
4466: for(J = 0; J < S[1]; J++)
4467: R[I][J] = radd(P[I][J],Q[I][J]);
4468: }
4469: return R;
4470: }
4471: erno(0);
4472: }
4473:
4474: def getel(M,I)
4475: {
4476: if(type(M) >= 4 && type(M) <= 6 && type(I) <= 1)
4477: return M[I];
4478: if(type(M) == 6 && type(I) == 5)
4479: return M[I][J];
4480: return M;
4481: }
4482:
4483: def ptol(P,X)
4484: {
4485: F=(getopt(opt)==0)?0:1;
4486: if(type(P) <= 3)
4487: P = [P];
4488: if(type(X) == 4){
4489: for( ; X != []; X = cdr(X))
4490: P=ptol(P,car(X)|opt=F);
4491: return P;
4492: }
4493: P = reverse(P);
4494: for(R=[]; P != []; P = cdr(P)){
4495: Q = car(P);
4496: for(I = mydeg(Q,X); I >= 0; I--){
4497: S=mycoef(Q,I,X);
4498: if(F==1 || S!=0) R = cons(S,R);
4499: }
4500: }
4501: return R;
4502: }
4503:
4504: def rmul(P,Q)
4505: {
4506: if(type(P) <= 3 && type(Q) <= 3){
4507: P=red(P);Q=red(Q);
4508: P1=dn(P);P2=nm(P);Q1=dn(Q);Q2=nm(Q);
4509: if(P1==1 && Q1==1)
4510: return P*Q;
4511: if((R=gcd(P1,Q2)) != 1){
4512: P1=tdiv(P1,R);Q2=tdiv(Q2,R);
4513: }
4514: if((R=gcd(Q1,P2)) != 1){
4515: Q1=tdiv(Q1,R);P2=tdiv(P2,R);
4516: }
4517: return P2*Q2/(P1*Q1);
4518: }
4519: #ifdef USEMODULE
4520: return mmulbys(os_md.rmul,P,Q,[]);
4521: #else
4522: return mmulbys(rmul,P,Q,[]);
4523: #endif
4524: }
4525:
4526: def mtransbys(FN,F,LL)
4527: {
4528: Opt=getopt();
4529: if(type(F) == 4){
4530: F = ltov(F);
4531: S = length(F);
4532: R = newvect(S);
4533: for(I = 0; I < S; I++)
4534: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
4535: return vtol(R);
4536: }
4537: if(type(F) == 5){
4538: S = length(F);
4539: R = newvect(S);
4540: for(I = 0; I < S; I++)
4541: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
4542: return R;
4543: }
4544: if(type(F) == 6){
4545: S = size(F);
4546: R = newmat(S[0],S[1]);
4547: for(I = 0; I < S[0]; I++){
4548: for(J = 0; J < S[1]; J++)
4549: R[I][J] = mtransbys(FN,F[I][J],LL|option_list=Opt);
4550: }
4551: return R;
4552: }
4553: if(type(F) == 7) return F;
4554: return call(FN, cons(F,LL)|option_list=Opt);
4555: }
4556:
4557: def drawopt(S,T)
4558: {
4559: if(type(S)!=7) return -1;
4560: if(T==0||T==1){
4561: for(I=0,R=LCOPT;I<7;I++,R=cdr(R))
4562: if(str_str(S,car(R))>=0) return(T==0)?COLOPT[I]:car(R);
4563: return -1;
4564: }
4565: if(T==2){
4566: V0=V1=0;
4567: for(I=0,R=LPOPT;R!=[];I++,R=cdr(R)){
4568: if(str_str(S,car(R))>=0){
4569: if(I==0) V1++;
4570: else if(I==1) V1--;
4571: else if(I==2) V0--;
4572: else V0++;
4573: }
4574: }
4575: if(V0==0&&V1==0) return -1;
4576: return [V0,V1];
4577: }
4578: if(T==3){
4579: V=0;
4580: for(I=1,R=LFOPT;R!=[];R=cdr(R),I*=2){
4581: if(str_str(S,car(R))>=0) V+=I;
4582: }
4583: return (V==0)?-1:V;
4584: }
4585: return -1;
4586: }
4587:
4588: def execdraw(L,P)
4589: {
4590: if((Proc=getopt(proc))!=1) Proc=0;
4591: if(type(P)<2) P=[P];
4592: if(L!=[]&&type(L[0])!=4) L=[L];
4593: /* special command */
4594: if(P[0]<0){
4595: if(length(P)==1&&(P[0]==-1||P[0]==-2||P[0]==-3)){ /* Bounding Box */
4596: W=WS=N=LS=0;
4597: for(LL=L;LL!=[];LL=cdr(LL)){
4598: T=car(LL);
4599: if(P[0]!=-3 && T[0]==0){
4600: if(length(T)>3) S=" by "+rtostr(T[3])+" cm";
4601: else S="";
4602: if(P[0]==-1){
4603: mycat(["Windows : ",T[1][0],"< x <",T[1][1],", ",
4604: T[2][0],"< y <",T[2][1],S]);
4605: if(length(T)>4 && type(T[4])==4) mycat(["ext :",T[4]]);
4606: if(length(T)>5) mycat(["shift :",T[5]]);
4607: }
4608: return cdr(T);
4609: }
4610: if(type(T[0])==1){
4611: if(T[0]==1){
4612: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
4613: D=car(TT);
4614: if(type(D[0][0])==4){
4615: for(DT=D;DT!=[];DT=cdr(DT)){
4616: if(N++==0) W=ptbbox(car(DT));
4617: else W=ptbbox(car(DT)|box=W);
4618: }
4619: }else{
4620: if(N++==0) W=ptbbox(D);
4621: else W=ptbbox(D|box=W);
4622: }
4623: }
4624: }else if(T[0]==2){
4625: V=T[2];
4626: if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
4627: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
4628: Sc=car(Sc)[1];
4629: if(type(Sc)==1) V=[Sc*V[0],Sc*V[1]];
4630: else V=[Sc[0]*V[0],Sc[1]*V[1]];
4631: }
4632: if(LS==0) WS=ptbbox([V]);
4633: else WS=ptbbox([V]|box=WS);
4634: if(length(T)>4) S=T[4];
4635: else if(type(S=T[3])==4){
4636: S=S[0];
4637: if(type(S)==4) S=S[length(S)-1];
4638: S=rtostr(S);
4639: }
4640: if(str_len(S)>LS) LS=str_len(S);
4641: }else if(T[0]==3||T[0]==4){
4642: if(N++==0) W=ptbbox(cdr(cdr(T)));
4643: else W=ptbbox(cdr(cdr(T))|box=W);
4644: }
4645: }
4646: }
4647: if(W!=0&&WS!=0) W=ptbbox([W,WS]|box=1);
4648: return (P[0]==-3)?[W,LS,WS]:W;
4649: }else if(length(P)>1&&P[0]==-1){ /* set Bounding Box */
4650: P=cons(0,cdr(P));
4651: Ex=Sft=[0,0];
4652: if(type(X=getopt(ext))==4) Ex=X;
4653: if(type(X=getopt(shift))==4) Sft=X;
4654: if(Ex!=Sft||Ex!=[0,0]){
4655: if(Sft==[0,0]) Sft=[Ex];
4656: else Sft=[Ex,Sft];
4657: if(length(P)==3) Sft=cons(1,Sft);
4658: if(length(P)==3||length(P)==4) P=append(P,Sft);
4659: }
4660: return cons(P,delopt(L,0));
4661: }
4662: if(P[0]==-4){
4663: for(N=0,LT=L;LT!=[];LT=cdr(LT)){ /* count coord. */
4664: T=car(LT);
4665: if(T[0]==1){
4666: for(T=cdr(cdr(T));T!=[];T=cdr(T)){
4667: if(type((S=car(T))[0][0])==4) N+=length(S);
4668: else for(;S!=[];S=cdr(S)) if(type(car(S))==4) N++;
4669: }
4670: }else if(T[0]==2) N++;
4671: else if(T[0]==3||T[0]==4) N+=2;
4672: }
4673: return N;
4674: }
4675: if(P[0]==-5){ /* functions */
4676: for(N=0,R=[],LT=L;LT!=[];LT=cdr(LT)){
4677: T=car(LT);
4678: if(T[0]==0) N=ior(N,1);
4679: else if(type(T[0])==1){
4680: if(T[0]>0) N=ior(N,2^T[0]);
4681: }
4682: else if(Type(T[0])==2){
4683: if(findin(T[0],R)<0) R=cons(T[0],R);
4684: }
4685: }
4686: for(I=5;I>=0;I--) if(iand(N,2^I)) R=cons(I,R);
4687: return R;
4688: }
4689: return 0;
4690: }
4691:
4692: if(length(P)>1){
4693: if(type(P[1])==6||(type(P[1])<2&&P[1]>0)) M=P[1];
4694: else if(type(P[1])==4&&length(P[1])==2) M=diagm(2,P[1]);
4695: }
4696: if(length(P)>2&&type(P[2])==4){
4697: Org=[["shift",P[2]]];
4698: if(M==0) M=1;
4699: }else Org=[];
4700: if(P[0]==0||(type(P[0])==4&&P[0][0]==0)){ /* Risa/Asir */
4701: PP=car(P);PPP=0;
4702: if(type(PP)!=4) PP=[PP];
4703: if(length(PP)<3){
4704: if(length(PP)==1 || type(PP[1])==4){
4705: if(ID_PLOT<0) ID_PLOT=ox_launch_nox(0,"ox_plot");
4706: Id=ID_PLOT;
4707: if(length(PP)==1&&type(Canvas)==4&&length(Canvas)==2)
4708: PP=cons(PP[0],[Canvas]);
4709: if(length(PP)>1){
4710: PPP=PP[1][0];
4711: PPQ=(length(PP[1])==2)?PP[1][1]:PPP;
4712: open_canvas(Id,[PPP,PPQ]);
4713: }else open_canvas(Id);
4714: Ind=ox_pop_cmo(Id);
4715: }else{
4716: Ind=PP[1];
4717: if(getopt(cl)==1) clear_canvas(Id,Ind);
4718: }
4719: }else{
4720: Id=PP[1];Ind=PP[2];
4721: if(length(PP)>3 && type(PP[3])==1) PPP=PP[3];
4722: if(length(PP)>4 && type(PP[4])==1) PPQ=PP[4];
4723: if(getopt(cl)==1) clear_canvas(Id,Ind);
4724: }
4725: if(L==[]) return (PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
4726: Ex0=Ex0;Sft=[0,0];
4727: if(length(P)>1&&P[1]==0&&length(P)<4){
4728: R=execdraw(L,-3);
4729: Ex0=Ex1=Ex2=10;
4730: if((U=R[1])>0){ /* string */
4731: if(U>20) U=16; /* adj 16,8,2,7,15 */
4732: if(R[0][0][0]>R[2][0][0]-(R[0][0][1]-R[0][0][0])/256) Ex0+=8*U; /* adj 256 */
4733: else Ex0+=2*U;
4734: if(R[0][0][1]<R[2][0][1]+(R[0][0][1]-R[0][0][0])/256) Ex1+=7*U;
4735: else Ex1+=2*U;
4736: if(R[0][1][1]<R[2][1][1]+(R[0][1][1]-R[0][1][0])/256) Ex2+=15;
4737: }
4738: R=[R[0][0],R[0][1],0,[Ex0,Ex1],[0,-Ex2]];
4739: if(length(P)>2 && P[2]==1)
4740: mycat0(["Box:",[R[0],R[1]], ", ext=",R[3],", shift=",R[4]],1);
4741: }else R=execdraw((length(P)>3)?P[3]:L,-2); /* Windows */
4742: XW=R[0];YW=R[1];
4743: if(length(R)>3){
4744: if(R[3]!=0 && R[3]!=[0,0]) Ex=R[3];
4745: if(length(R)>4) Sft=R[4];
4746: }
4747: if(type(X=getopt(ext))==4)
4748: Ex=(Ex0)?[X[0]+Ex[0],X[1]+Ex[1]]:X;
4749: if(type(M)<2){
4750: if(length(P)>1&&type(P[1])==1) M=P[1];
4751: else if((length(P)==1||P[1]==0||P[1]==1)&& PPP>0) M=PPP;
4752: if(M<2) M=400;
4753: if(Ex!=0 && type(Ex)==4){
4754: M-=Ex[0]+Ex[1];
4755: }
4756: M=(M/(XW[1]-XW[0]))*diagm(2,[1,-1]);
4757: }
4758: if(type(X=getopt(shift))==4) Sft=(Ex0)?[Sft[0]+X[0],Sft[1]+X[1]]:X;
4759: if(type(Sft)==4) Sft=[Sft[0],-Sft[1]];
4760: if(Ex!=0) Sft=[Sft[0]+Ex[0],Sft[1]];
4761: Org=[["shift",ptaffine(M,[-XW[0],-YW[1]]|shift=Sft)]];
4762: for(CT=0;CT<2;CT++){
4763: for(LT=L;LT!=[];LT=cdr(LT)){
4764: T=car(LT);
4765: if(!CT && T[0]!=2) continue;
4766: if(CT && T[0]==2) continue;
4767: if(T[0]==1){
4768: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
4769: D=car(TT);
4770: if(type(D[0][0])==4){
4771: for(DT=D;DT!=[];DT=cdr(DT)){
4772: V=car(DT);
4773: if(M) V=ptaffine(M,V|option_list=Org);
4774: draw_bezier(Id,Ind,V|option_list=T[1]);
4775: }
4776: }else{
4777: if(M) D=ptaffine(M,D|option_list=Org);
4778: draw_bezier(Id,Ind,D|option_list=T[1]);
4779: }
4780: }
4781: }else if(T[0]==2){ /* put */
4782: if(length(T)<4) continue;
4783: V=T[2];
4784: if(type(VLB)==4&&V[0]=="_") V=VLB;
4785: else if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
4786: if(length(T)>3&&type(T[3])==4&&length(T[3])>1&&T[3][1]==1) VLB=V;
4787: F++;MM=M;
4788: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
4789: if(!MM) MM=1;
4790: Sc=car(Sc)[1];
4791: if(type(Sc)==1) MM=MM*Sc;
4792: else if(type(Sc)==6) MM=MM*diagm(2,Sc);
4793: }
4794: if(MM) V=ptaffine(MM,V|option_list=Org);
4795: if(type(S=S0=T[3])==4) S=S0[0];
4796: if(length(T)>4) S=T[4]; /* subst. string */
4797: if(type(S0)==4&&type(S0[0])==4){
4798: if((Col=drawopt(S0[0][0],0))<0) Col=0; /* attrib. */
4799: if(type(S)!=7) S=rtostr(S0[0][1]);
4800: S=str_subst(S,[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
4801: if(type(Pos=drawopt(S0[0][0],2))==4)
4802: V=[V[0]+4*str_len(S)*Pos[0],V[1]-10*Pos[1]]; /* adjustable */
4803: }else S=str_subst(rtostr(S),[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
4804: V=[V[0]-str_len(S)*4,V[1]-8]; /* adjustable */
4805: draw_string(Id,Ind,V,S,Col);
4806: }else if(T[0]==3){ /* arrow */
4807: F++;
4808: T1=T[2];T2=T[3];
4809: if(M){
4810: T1=ptaffine(M,T1|option_list=Org);
4811: T2=ptaffine(M,T2|option_list=Org);
4812: }
4813: draw_bezier(Id,Ind,[T1,T2]|option_list=T[1]);
4814: }else if(T[0]==4){ /* line */
4815: F++;
4816: T1=T[2];T2=T[3];
4817: if(M){
4818: T1=ptaffine(M,T1|option_list=Org);
4819: T2=ptaffine(M,T2|option_list=Org);
4820: }
4821: V=delopt(T1=T[1],"opt"|inv=1);
4822: if(V!=[]&&str_str(V[1],".")>=0)
4823: T1=cons(["opt",cons("dotted,",V[1])],delopt(T1,"opt"));
4824: draw_bezier(Id,Ind,[T1,T2]|option_list=T1);
4825: }else if(T[0]==5){ /* TeX */
4826: mycat(rtostr(T[2]));
4827: if(F){
4828: S=str_tb(0,Out);
4829: Out=str_tb(0,0);
4830: F=0;
4831: if(S!=""){
4832: if(P[0]==2) dviout(xyproc(S)|keep=1);
4833: else LOut=cons(xyproc(S),LOut);
4834: }
4835: if(P[0]==2) dviout(T[2]|option_list=T[1]);
4836: else{
4837: LOut=cons(T[2],Out);
4838: }
4839: }
4840: }else if(Proc==1&&type(T[0])==2){
4841: if(length(T)<3) call(T[0],T[1]);
4842: else call(T[0],T[1]|option_list=T[2]);
4843: }
4844: }
4845: }
4846: S=(PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
4847: if(Ex==0&&Sft!=[0,0]) Ex=[0,0];
4848: return (Ex!=0&&length(P)>2&&P[2]==-1)?
4849: [S,0,0,[0,R[0],R[1],0,Ex,[Sft[0]-Ex[0],-Sft[1]]]]:S;
4850: }
4851: if(P[0]==1||P[0]==2){ /* TeX */
4852: Out=str_tb(0,0);LOut=[];F=0;
4853: if(getopt(cl)==1) dviout0(0);
4854: for(;L!=[];L=cdr(L)){
4855: T=car(L);Opt=T[1];
4856: if(type(T[0])>=2) continue;
4857: if(T[0]==0){
4858: XW=T[1];YW=T[2];
4859: if(length(P)>1&&type(P[1])==1&&P[1]<0)
4860: M=-P[1]/(XW[0]-XW[1]);
4861: }else if(T[0]==1){
4862: F++;
4863: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
4864: D=car(TT);
4865: if(type(D[0][0])==4){
4866: for(DT=D;DT!=[];DT=cdr(DT)){
4867: V=car(DT);
4868: if(M) V=ptaffine(M,V|option_list=Org);
4869: str_tb(xybezier(V|option_list=Opt),Out);
4870: }
4871: }else{
4872: if(M) D=ptaffine(M,D|option_list=Org);
4873: str_tb(xybezier(D|option_list=Opt),Out);
4874: }
4875: }
4876: }else if(T[0]==2){
4877: F++;V=T[2];
4878: Opt=delopt(Opt,"scale"|inv=1);
4879: MM=M;
4880: if(Opt!=[]){
4881: Opt=car(Opt)[1];
4882: if(type(Opt)==1) Opt=[Opt,Opt];
4883: if(Opt!=[1,1]){
4884: if(!MM) MM=1;
4885: MM=MM*diagm(2,[Opt[0],Opt[1]]);
4886: }
4887: }
4888: if(MM) V=ptaffine(MM,V|option_list=Org);
4889: if(length(T)>3) V=append(V,T[3]);
4890: str_tb(xyput(V),Out);
4891: }else if(T[0]==3){
4892: F++;
4893: T1=T[2];T2=T[3];
4894: if(M){
4895: T1=ptaffine(M,T1|option_list=Org);
4896: T2=ptaffine(M,T2|option_list=Org);
4897: }
4898: str_tb(xyarrow(T1,T2|option_list=Opt),Out);
4899: }else if(T[0]==4){
4900: F++;
4901: T1=T[2];T2=T[3];
4902: if(M){
4903: T1=ptaffine(M,T1|option_list=Org);
4904: T2=ptaffine(M,T2|option_list=Org);
4905: }
4906: str_tb(xyline(T1,T2|option_list=Opt),Out);
4907: }else if(T[0]==5){
4908: if(F){
4909: S=str_tb(0,Out);
4910: Out=str_tb(0,0);
4911: F=0;
4912: if(S!=""){
4913: if(P[0]==2) dviout(xyproc(S)|keep=1);
4914: else LOut=cons(xyproc(S),LOut);
4915: }
4916: if(P[0]==2) dviout(T[2]|option_list=T[1]);
4917: else LOut=cons(T[2],Out);
4918: }
4919: }else if(T[0]==-2)
4920: str_tb(["%",T[1],"\n"],Out);
4921: else if(Proc==1&&type(T[0])==2){
4922: if(length(T)<3) call(T[0],T[1]);
4923: else call(T[0],T[1]|option_list=T[2]);
4924: }
4925: }
4926: S=str_tb(0,Out);
4927: if(P[0]==1){
4928: if(F) LOut=cons(xyproc(S),LOut);
4929: Out=str_tb(0,0);
4930: for(L=reverse(LOut);L!=[];L=cdr(L))
4931: str_tb(car(L),Out);
4932: return str_tb(0,Out);
4933: }
4934: if(F) dviout(xyproc(S));
4935: else dviout(" ");
4936: }
4937: }
4938:
4939: def execproc(L)
4940: {
4941: if(type(N=getopt(var))!=1&&N!=0) N=2;
4942: for(R=[];L!=[];L=cdr(L)){
4943: P=car(L);
4944: if(type(P[0])==2&&vtype(P[0])==3){
4945: if((VS=vars(cdr(P)))!=[]){
4946: for(I=0;I<N;I++){
4947: V=makev(["v",I+1]);
4948: if(findin(V,VS)>=0) P=mysubst(P,[V,R[I]]);
4949: }
4950: }
4951: if(length(P)<3) R=cons(call(P[0],P[1]),R);
4952: else R=cons(call(P[0],P[1]|option_list=P[2]),R);
4953: }
4954: }
4955: return (getopt(all)==1)?R:car(R);
4956: }
4957:
4958: def myswap(P,L)
4959: {
4960: X=makenewv(P);
4961: for(L=reverse(L);length(L)>1;L=cdr(L))
4962: P=subst(P,L[0],X,L[1],L[0],X,L[1]);
4963: return P;
4964: }
4965:
4966: def mysubst(P,L)
4967: {
4968: if(P==0) return 0;
1.29 takayama 4969: if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]);
1.6 takayama 4970: Inv=getopt(inv);
4971: if(type(L[0]) == 4){
4972: while((L0 = car(L))!=[]){
4973: P = mysubst(P,(Inv==1)?[L0[1],L0[0]]:L0);
4974: L = cdr(L);
4975: }
4976: return P;
4977: }
4978: if(Inv==1) L=[L[1],L[0]];
4979: if(type(P) > 3){
4980: if(type(P)==7) return P;
4981: if(type(P)>7)
4982: return subst(P,L[0],L[1]);
4983: #ifdef USEMODULE
4984: return mtransbys(os_md.mysubst,P,[L]);
4985: #else
4986: return mtransbys(mysubst,P,[L]);
4987: #endif
4988: }
4989: P = red(P);
4990: if(type(P) == 3){
4991: A=mysubst(nm(P),L);B=mysubst(dn(P),L);
4992: return red(nm(A)/nm(B))*red(dn(B)/dn(A));
4993: }
4994: L1=(type(L[1])==3)?red(L[1]):L[1];X=L[0];
4995: if(ptype(L1,X)==3){
4996: LN=nm(L1);LD=dn(L1);
4997: Deg=mydeg(P,X);
4998: if(Deg <= 0) return P;
4999: V = newvect(Deg+1);
5000: for(V[I=Deg]=1;I >= 1;I--)
5001: V[I-1]=V[I]*LD;
5002: for(R = 0, I = Deg; I >= 0; I--)
5003: R = R*LN + mycoef(P,I,X)*V[I];
5004: return red(R/V[0]);
5005: }
5006: return subst(P,X,L1);
5007: }
5008:
5009: def mmulbys(FN,P,F,L)
5010: {
5011: Opt=getopt();
5012: if(type(F) <= 3){
5013: if(type(P) <= 3)
5014: return call(FN, cons(P,cons(F,L))|option_list=Opt);
5015: if(type(P) == 5){
5016: S = length(P);
5017: R = newvect(S);
5018: for(I = 0; I < S; I++)
5019: R[I] = call(FN, cons(P[I],cons(F,L))|option_list=Opt);
5020: return R;
5021: }else if(type(P) == 6){
5022: S = size(P);
5023: R = newmat(S[0],S[1]);
5024: for(I = 0; I < S[0]; I++){
5025: for(J = 0; J < S[1]; J++)
5026: R[I][J] = call(FN, cons(P[I][J],cons(F,L))|option_list=Opt);
5027: }
5028: return R;
5029: }
5030: }
5031: if(type(F) == 5){
5032: S = length(F);
5033: if(type(P) <= 3){
5034: R = newvect(S);
5035: for(I = 0; I < S; I++)
5036: R[I] = call(FN, cons(P,cons(F[I],L))|option_list=Opt);
5037: return R;
5038: }
5039: if(type(P) == 5){
5040: for(J=R=0; J<S; J++)
5041: R = radd(R, call(FN, cons(P[J],cons(F[J],L)))|option_list=Opt);
5042: return R;
5043: }
5044: T = size(P);
5045: R = newvect(T[0]);
5046: for(I = 0; I < T[0]; I++){
5047: for(J = 0; J < S; J++)
5048: R[I] = radd(R[I], call(FN, cons(P[I][J],cons(F[J],L))|option_list=Opt));
5049: }
5050: return R;
5051: }
5052: if(type(F) == 6){
5053: S = size(F);
5054: if(type(P) <= 3){
5055: R = newmat(S[0],S[1]);
5056: for(I = 0; I < S[0]; I++){
5057: for(J = 0; J < S[1]; J++)
5058: R[I][J] = call(FN, cons(P,cons(F[I][J],L))|option_list=Opt);
5059: }
5060: return R;
5061: }
5062: if(type(P) == 5){
5063: R = newvect(S[1]);
5064: for(J = 0; J < S[1]; J++){
5065: for(K = U = 0; K < S[0]; K++)
5066: U = radd(U, call(FN, cons(P[K],cons(F[K][J],L))|option_list=Opt));
5067: R[J] = U;
5068: }
5069: return R;
5070: }
5071: T = size(P);
5072: R = newmat(T[0],S[1]);
5073: for(I = 0; I < T[0]; I++){
5074: for(J = 0; J < S[1]; J++){
5075: for(K = U = 0; K < S[0]; K++)
5076: U = radd(U, call(FN, cons(P[I][K],cons(F[K][J],L)|option_list=Opt)));
5077: R[I][J] = U;
5078: }
5079: }
5080: return R;
5081: }
5082: erno(0);
5083: return 0;
5084: }
5085:
5086: def appldo(P,F,L)
5087: {
5088: if(type(F) <= 3){
5089: if(type(L) == 4 && type(L[0]) == 4)
5090: return applpdo(P,F,L);
5091: L = vweyl(L);
5092: X = L[0]; DX = L[1];
5093: J = mydeg(P,DX);
5094: for(I = R = 0; I <= J; I++){
5095: if(I > 0)
5096: F = mydiff(F,X);
5097: R = radd(R,mycoef(P,I,DX)*F);
5098: }
5099: return R;
5100: }
5101: #ifdef USEMODULE
5102: return mmulbys(os_md.appldo,P,F,[L]);
5103: #else
5104: return mmulbys(appldo,P,F,[L]);
5105: #endif
5106: }
5107:
5108: def appledo(P,F,L)
5109: {
5110: if(type(F) <= 3){
5111: L = vweyl(L);
5112: X = L[0]; DX = L[1];
5113: J = mydeg(P,DX);
5114: for(I = R = 0; I <= J; I++){
5115: if(I > 0)
5116: F = myediff(F,X);
5117: R = radd(R,mycoef(P,I,DX)*F);
5118: }
5119: return R;
5120: }
5121: #ifdef USEMODULE
5122: mmulbys(os_md.appledo,P,F,[L]);
5123: #else
5124: mmulbys(appledo,P,F,[L]);
5125: #endif
5126: }
5127:
5128: def muldo(P,Q,L)
5129: {
5130: if(type(Lim=getopt(lim))!=1) Lim=100;
5131: if(type(Q) <= 3){
5132: if(type(L) == 4 && type(L[0]) == 4)
5133: return mulpdo(P,Q,L|lim=Lim); /* several variables */
5134: R = rmul(P,Q);
5135: L = vweyl(L);
5136: X = L[0]; DX = L[1];
5137: if(X != 0){
5138: for(I = F = 1; ; I++){
5139: P = mydiff(P,DX);
5140: if(I>Lim){
5141: mycat(["Over", Lim,"derivations!"]);
5142: break;
5143: }
5144: if(P == 0)
5145: break;
5146: Q = mydiff(Q,X);
5147: if(Q == 0)
5148: break;
5149: F *= I;
5150: R = radd(R,P*Q/F);
5151: }
5152: }
5153: return R;
5154: }
5155: #ifdef USEMODULE
5156: return mmulbys(os_md.muldo,P,Q,[L]);
5157: #else
5158: return mmulbys(muldo,P,Q,[L]);
5159: #endif
5160: }
5161:
5162: def jacobian(F,X)
5163: {
5164: F=ltov(F);X=ltov(X);
1.30 takayama 5165: N=length(F);L=length(X);
5166: M=newmat(N,L);
1.6 takayama 5167: for(I=0;I<N;I++)
1.30 takayama 5168: for(J=0;J<L;J++) M[I][J]=red(diff(F[I],X[J]));
5169: if(N!=L||getopt(mat)==1) return M;
1.6 takayama 5170: return mydet(M);
5171: }
5172:
5173: def hessian(F,X)
5174: {
5175: X=ltov(X);
5176: N=length(X);
5177: M=newmat(N,N);
5178: for(I=0;I<N;I++){
5179: G=red(diff(F,X[I]));
5180: for(J=0;J<N;J++) M[I][J]=red(diff(G,X[J]));
5181: }
5182: if(getopt(mat)==1) return M;
5183: return mydet(M);
5184: }
5185:
5186: def wronskian(F,X)
5187: {
5188: N=length(F);
5189: M=newmat(N,N);
5190: for(I=0;F!=[];F=cdr(F),I++){
5191: M[I][0]=car(F);
5192: for(J=1;J<N;J++) M[I][J]=red(diff(M[I][J-1],X));
5193: }
5194: if(getopt(mat)==1) return M;
5195: return mydet(M);
5196: }
5197:
5198: def adj(P,L)
5199: {
5200: if(type(P) == 4)
5201: #ifdef USEMODULE
5202: return map(os_md.adj,mtranspose(P),L);
5203: #else
5204: return map(adj,mtranspose(P),L);
5205: #endif
5206: if(type(L) == 4 && type(L[0]) == 4)
5207: #ifdef USEMODULE
5208: return fmult(os_md.adj,P,L,[]);
5209: #else
5210: return fmult(adj,P,L,[]);
5211: #endif
5212: L = vweyl(L);
5213: X = L[0]; DX = L[1];
5214: P = R = subst(P, DX, -DX);
5215: for(I = 1; (R = mydiff(mydiff(R, X), DX)/I) != 0 && I < 100; I++)
5216: P = radd(P,R);
5217: return P;
5218: }
5219:
5220: def laplace1(P,L)
5221: {
5222: if(type(L) == 4 && type(L[0]) == 4)
5223: #ifdef USEMODULE
5224: return fmult(os_md.laplace,P,L,[]);
5225: #else
5226: return fmult(laplace,P,L,[]);
5227: #endif
5228: L = vweyl(L);
5229: X = L[0]; DX = L[1];
5230: P = adj(P, L);
5231: return subst(P,X,o_1,DX,X,o_1,DX);
5232: }
5233:
5234: def laplace(P,L)
5235: {
5236: if(type(L) == 4 && type(L[0]) == 4)
5237: #ifdef USEMODULE
5238: return fmult(os_md.laplace1,P,L,[]);
5239: #else
5240: return fmult(laplace1,P,L,[]);
5241: #endif
5242: L = vweyl(L);
5243: X = L[0]; DX = L[1];
5244: P = adj(P, L);
5245: return subst(P,X,o_1,DX,-X,o_1,-DX);
5246: }
5247:
5248: def mce(P,L,V,R)
5249: {
5250: L = vweyl(L);
5251: X = L[0]; DX = L[1];
5252: P = sftexp(laplace1(P,L),L,V,R);
5253: return laplace(P,L);
5254: }
5255:
5256: def mc(P,L,R)
5257: {
5258: return mce(P,L,0,R);
5259: }
5260:
5261: def rede(P,L)
5262: {
5263: Q = ltov(fctr(nm(red(P))));
5264: P = 1;
5265: if(type(L) < 4)
5266: L = [L];
5267: if(type(L[0]) < 4)
5268: L = [L];
5269: for( ; L != []; L = cdr(L)){
5270: DX = vweyl(car(L))[1];
5271: for(I = 1; I < length(Q); I++){
5272: if(mydeg(Q[I][0],DX) > 0){
5273: P *= (Q[I][0])^(Q[I][1]);
5274: Q[I]=[1,0];
5275: }
5276: }
5277: }
5278: return P;
5279: }
5280:
5281: def ad(P,L,R)
5282: {
5283: L = vweyl(L);
5284: DX = L[1];
5285: K = mydeg(P,DX);
5286: S = mycoef(P,0,DX);
5287: Q = 1;
5288: for(I=1; I <= K;I++){
5289: Q = muldo(Q,DX-R,L);
5290: S = radd(S,mycoef(P,I,DX)*Q);
5291: }
5292: return S;
5293: }
5294:
5295: def add(P,L,R)
5296: {
5297: return rede(ad(P,L,R),L);
5298: }
5299:
5300:
5301: def vadd(P,L,R)
5302: {
5303: L = vweyl(L);
5304: if(type(R) != 4)
5305: return 0;
5306: N = length(R);
5307: DN = 1; Ad = PW = 0;
5308: for( ; R != []; R = cdr(R), PW++){
5309: DN *= (T=1-car(R)[0]*L[0]);
5310: Ad = Ad*T-car(R)[1]*x^PW;
5311: }
5312: Ad /= DN;
5313: return add(P,L,Ad);
5314: }
5315:
5316: def addl(P,L,R)
5317: {
5318: return laplace1(add(laplace(P,L),L,R),L);
5319: }
5320:
5321: def cotr(P,L,R)
5322: {
5323: L = vweyl(L);
5324: X = L[0]; DX = L[1];
5325: T = 1/mydiff(P,DX);
5326: K = mydeg(P,DX);
5327: S = mysubst(mycoef(P,0,DX), [X, R]);
5328: Q = 1;
5329: for(I = 1; I <= K; I++){
5330: Q = muldo(Q, K*DX, L);
5331: S = radd(S,mysubst(mycoef(P,I,DX), [X, R])*Q);
5332: }
5333: }
5334:
5335: def rcotr(P,L,R)
5336: {
5337: return rede(cotr(P,L,R), L);
5338: }
5339:
5340: def muledo(P,Q,L)
5341: {
5342: if(type(Q)>3)
5343: #ifdef USEMODULE
5344: return mmulbys(os_md.muledo,P,Q,[L]);
5345: #else
5346: return mmulbys(muledo,P,Q,[L]);
5347: #endif
5348: R = P*Q;
5349: L = vweyl(L);
5350: X = L[0]; DX = L[1];
5351: for(I = F = 1; I < 100; I++){
5352: P = mydiff(P,DX);
5353: if(P == 0)
5354: break;
5355: Q = myediff(Q,X);
5356: if(Q == 0)
5357: break;
5358: F = rmul(F,I);
5359: R = radd(R,P*Q/F);
5360: }
5361: return R;
5362: }
5363:
5364:
5365: #if 1
5366: def mulpdo(P,Q,L)
5367: {
5368: if(type(Q)>3)
5369: #ifdef USEMODULE
5370: return mmulbys(os_md.mulpdo,P,Q,[L]);
5371: #else
5372: return mmulbys(mulpdo,P,Q,[L]);
5373: #endif
5374: if(type(Lim=getopt(lim))!=1) Lim=100;
5375: M = vweyl(car(L)); X= M[0]; DX = M[1];
5376: L = cdr(L);
5377: R = 0;
5378: for(I = 0; Q != 0 && I <= Lim; I++){
5379: if(I>Lim){
5380: mycat(["Over", Lim,"derivations!"]);
5381: break;
5382: }
5383: if(I > 0)
5384: P /= I;
5385: if(length(L)==0)
5386: R = radd(R,P*Q);
5387: else
5388: R = radd(R,mulpdo(P,Q,L));
5389: if(X==0) break;
5390: P = mydiff(P,DX);
5391: if(P == 0)
5392: break;
5393: Q = mydiff(Q,X);
5394: }
5395: if(I>Lim) mycat(["Over", Lim,"derivations!"]);
5396: return R;
5397: }
5398:
5399: #else
5400: def mulpdo(P,Q,L);
5401: {
5402: if(type(Q)>3)
5403: #ifdef USEMODULE
5404: return mmulbys(os_md.mulpdo,P,Q,[L]);
5405: #else
5406: return mmulbys(mulpdo,P,Q,[L]);
5407: #endif
5408: if(type(Lim=getopt(lim))!=1) Lim=100;
5409: N = length(L);
5410: VO = newvect(2*N);
5411: VN = newvect(2*N);
5412: for(I = J = 0; I < N; J += 2, I++){
5413: M = vweyl(L[I]);
5414: P = subst(P, VO[J]=M[0], VN[J]=strtov("o_"+rtostr(V[J])),
5415: VO[J+1]=M[1], VN[J+1] = strtov("o_"+rtostr(V[J+1])));
5416: }
5417: for(PQ = P*Q, I = 0; I < 2*N; I += 2){
5418: for(R = PQ, J = 1; J < Lim; J++){
5419: R = mydiff(R, VN[I+1])/J;
5420: if(R == 0)
5421: break;
5422: R = mydiff(R, VO[I]);
5423: if(R == 0)
5424: break;
5425: PQ = radd(PQ,R);
5426: }
5427: if(I==Lim) mycat(["Over", Lim,"derivations!"]);
5428: PQ = red(subst(PQ,VN[I],VO[I],VN[I+1],VO[I+1]));
5429: }
5430: }
5431: #endif
5432:
5433: def transpdosub(P,LL,K)
5434: {
5435: Len = length(K)-1;
5436: if(Len < 0 || P == 0)
5437: return P;
5438: KK=K[Len];
5439: if(type(KK)==4){
5440: KK0=KK[0]; KK1=KK[1];
5441: }else{
5442: L = vweyl(LL[Len]);
5443: KK0=L[1]; KK1=K[Len];
5444: }
5445: Deg = mydeg(P,KK0);
5446: K1 = reverse(cdr(reverse(K)));
5447: R = transpdosub(mycoef(P,0,KK0),LL,K1);
5448: for(I = M = 1; I <= Deg ; I++){
5449: M = mulpdo(M,KK1,LL);
5450: S = mycoef(P,I,KK0);
5451: if(Len > 0)
5452: S = transpdosub(S,LL,K1);
5453: R = radd(R,mulpdo(S,M,LL));
5454: }
5455: return R;
5456: }
5457:
5458: def transpdo(P,LL,K)
5459: {
5460: if(type(K[0]) < 4)
5461: K = [K];
5462: Len = length(K)-1;
5463: K1=K2=[];
5464: if(type(LL)!=4) LL=[LL];
5465: if(type(LL[0])!=4) LL=[LL];
5466: if(getopt(ex)==1){
5467: for(LT=LL, KT=K; KT!=[]; LT=cdr(LT), KT=cdr(KT)){
5468: L = vweyl(LL[J]);
5469: K1=cons([L[0],car(KT)[0]],K1);
5470: K2=cons([L[1],car(KT)[1]],K2);
5471: }
5472: K2=append(K1,K2);
5473: }else{
5474: for(J = length(K)-1; J >= 0; J--){
5475: L = vweyl(LL[J]);
5476: if(L[0] != K[J][0])
5477: K1 = cons([L[0],K[J][0]],K1);
5478: K2 = cons(K[J][1],K2);
5479: }
5480: P = mulsubst(P, K1);
5481: }
5482: return transpdosub(P,LL,K2);
5483: }
5484:
5485: def translpdo(P,LL,M)
5486: {
5487: S=length(LL);
5488: L0=newvect(S);L1=newvect(S);
5489: K=newvect(S);
5490: for(J=0;J<S;J++){
5491: L = vweyl(LL[J]);
5492: L0[J]=L[0];
5493: L1[J]=L[1];
5494: }
5495: K=rmul(M,L0);
5496: for(T=[],J=0;J<S;J++)
5497: T=cons([L0[J],K[J]],T);
5498: P=mulsubst(P,T);
5499: K=rmul(myinv(M),L1);
5500: for(T=[],J=0;J<S;J++)
5501: T=cons([L1[J],K[J]],T);
5502: return mulsubst(P,T);
5503: }
5504:
5505: /*
5506: return [R, M, S] : R = M*P - S*Q
5507: deg(R,X) < deg(Q,X)
5508: */
5509: def rpdiv(P,Q,X)
5510: {
5511: if(P == 0)
5512: return [0,1,0];
5513: DQ = mydeg(Q,X);
5514: CO = mycoef(Q,DQ,X);
5515: S = 0;
5516: while((DP = mydeg(P,X)) >= DQ){
5517: R = mycoef(P,DP,X)/CO;
5518: S = radd(S,R*X^(DP-DQ));
5519: P = radd(P, -R*Q*X^(DP-DQ));
5520: }
5521: Lcm = lcm(dn(S),dn(P));
5522: Gcd = gcd(nm(S),nm(P));
5523: return [red(P*Lcm/Gcd), red(Lcm/Gcd),red(S*Lcm/Gcd)];
5524: }
5525:
5526: def texbegin(T,S)
5527: {
5528: if(type(Opt=getopt(opt))==7) Opt="["+Opt+"]\n";
5529: else Opt="\n";
5530: return "\\begin{"+T+"}"+Opt+S+"%\n\\end{"+T+"}\n";
5531: }
5532:
5533: def mygcd(P,Q,L)
5534: {
5535: if((Dvi=getopt(dviout))==3 || Dvi==-3){ /* dviout=3 */
5536: if((Rev=getopt(rev))!=1) Rev=0;
5537: R=mygcd(P,Q,L|rev=Rev);
5538: if(type(L)<2) Var=0;
5539: else if(type(L)==2){
5540: Val=L;L=[0,L];
5541: }else if(type(L)==4){
5542: L=vweyl(L);
5543: Var=[[L[1],"\\partial"]];
5544: }
5545: S=mat([P],[Q]);T=mat([R[0]],[0]);
5546: M=mat([R[1],R[2]],[R[3],R[4]]);
5547: if(type(Val)==4)
5548: N=mdivisor(M,L|trans=1)[1];
5549: else N=myinv(M);
5550: Tb=str_tb(mtotex(S|var=Var),0);
5551: str_tb("&="+mtotex(N|var=Var)+mtotex(T|var=Var)+",\\\\\n",Tb);
5552: str_tb(mtotex(T|var=Var),Tb);
5553: str_tb("&="+mtotex(M|var=Var)+mtotex(S|var=Var)+".",Tb);
5554: Out=str_tb(0,Tb);
5555: if(Dvi<0) return Out;
5556: dviout(Out|eq="align*");
5557: return 1;
5558: }
5559: if((type(Dvi)==1||Dvi==0) && getopt(rev)!=1) V=[[P,Q]];
5560: else V=0;
5561: if(L==0){ /* integer case */
5562: if(type(P) > 1 || type(Q) > 1 || Q==0 /* P <= 0 || Q <= 0 */
5563: || dn(P) > 1 || dn(Q) > 1)
5564: return 0;
5565: CPP = CQQ = 1; CQP = CPQ = 0;
5566: P1 = P; Q1 = Q;
5567: /* P1 = CPP*P + CPQ*Q
5568: Q1 = CQP*P + CQQ*Q */
5569: while(Q1 != 0){
5570: Div1 = idiv(P1,Q1); Div2 = irem(P1,Q1);
5571: if(type(V)==4) V=cons([Div1,Div2],V);
5572: P1 = Q1 ; Q1 = Div2;
5573: TP = CQP; TQ = CQQ;
5574: CQP = CPP-Div1*CQP;
5575: CQQ = CPQ-Div1*CQQ;
5576: CPP = TP; CPQ = TQ;
5577: }
5578: if(V!=0){
5579: V=reverse(V);
5580: if((DVI=abs(Dvi))==0) return V;
5581: PT=P;QT=Q;
5582: if(DVI==1 || DVI==2){
5583: Tb=str_tb(0,0);
5584: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
5585: T=car(V);
5586: if(C++) str_tb(texcr(11),Tb);
5587: if(DVI==1){
5588: Qs=rtostr(QT);
5589: if(QT<0) Qs="("+Qs+")";
5590: if(T[1]>0) Qs=Qs+"+";
5591: if(T[1]!=0) Qs=Qs+rtostr(T[1]);
5592: str_tb(rtostr(PT)+"&="
5593: +rtostr(T[0])+"\\times"+Qs,Tb);
5594: }else{
5595: N=mat([T[0],1],[1,0]);
5596: if(C==1){
5597: str_tb(S0=mtotex(mat([PT],[QT])),Tb);
5598: M=N;
5599: }
5600: str_tb("&=",Tb);
5601: if(C>1) str_tb(mtotex(M),Tb);
5602: str_tb(mtotex(N),Tb);
5603: str_tb(S=mtotex(mat([QT],[T[1]])),Tb);
5604: if(C>1){
5605: str_tb("=",Tb);
5606: str_tb(mtotex(M=M*N),Tb);
5607: str_tb(S,Tb);
5608: }
5609: }
5610: PT=QT;QT=T[1];
5611: }
5612: if(DVI==2){
5613: str_tb(texcr(43)+S+"&=",Tb);
5614: str_tb(mtotex(myinv(M)),Tb);
5615: str_tb(S0,Tb);
5616: }
5617: Out=str_tb(0,Tb);
5618: if(Dvi>0){
5619: dviout(Out|eq="align*");
5620: return 1;
5621: }
5622: return Out;
5623: }
5624: }
5625: if(P1<0) return [-P1,-CPP,-CPQ,CQP,CQQ];
5626: return [P1, CPP, CPQ, CQP, CQQ];
5627: }
5628: if(type(L) == 2) /* polynomical case */
5629: L = [0,L];
5630: if(getopt(rev)==1 && L[0]!=0){
5631: R=mygcd(adj(P,L),adj(Q,L),L);
5632: return [adj(R[0],L),adj(R[1],L),adj(R[2],L),adj(R[3],L),adj(R[4],L)];
5633: }
5634: if(type(P) == 3)
5635: P = red(P);
5636: if(type(Q) == 3)
5637: Q = red(Q);
5638: CP=newvect(2,[1/dn(P),0]); CQ=newvect(2,[0,1/dn(Q)]);
5639: P=PT=nm(P); Q =QT=nm(Q);
5640: L = vweyl(L);
5641: while(Q != 0){
5642: R = divdo(P,Q,L);
5643: if(type(V)==4) V=cons(R,V);
5644: /* R[1] = R[2]*P - R[0]*Q
5645: = R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */
5646: /*
5647: P(n) |0 1 | P(n-1)
5648: = | |
5649: R[1] |R[2] -R[0]| P(n)
5650: P(n+1) = R[1], P(n) = P, P(n-1) = Q
5651: */
5652: P = Q;
5653: Q = R[1];
5654: {
5655: CT = dupmat(CQ);
5656: CQ = [R[2]*CP[0]-muldo(R[0],CQ[0],L),
5657: R[2]*CP[1]-muldo(R[0],CQ[1],L)];
5658: CP = CT;
5659: }
5660: }
5661: if(V!=0){
5662: V=reverse(V);
5663: if((DVI=abs(Dvi))==0) return V;
5664: if(type(L[0])<1) Var=L[1];
5665: else Var=[L[1],"\\partial"];
5666: if(DVI==1 || DVI==2){
5667: Tb=str_tb(0,0);
5668: PT=car(V)[0];QT=car(V)[1];
5669: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
5670: T=car(V);
5671: if(C++) str_tb(texcr(11),Tb);
5672: if(DVI==1){
5673: if(T[2]!=1){
5674: str_tb(monototex(T[2]),Tb);
5675: str_tb("(",Tb);
5676: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
5677: str_tb(")&=",Tb);
5678: }else{
5679: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
5680: str_tb("&=",Tb);
5681: }
5682: str_tb("(",Tb);
5683: str_tb(fctrtos(T[0]|var=Var,TeX=2),Tb);
5684: str_tb(")(",Tb);
5685: str_tb(fctrtos(QT|var=Var,TeX=2),Tb);
5686: if(T[1]!=0){
5687: str_tb(")+(",Tb);
5688: str_tb(fctrtos(T[1]|var=Var,TeX=2),Tb);
5689: }
5690: str_tb(")",Tb);
5691: }else{
5692: N=mat([red(T[0]/T[2]),1],[1,0]);
5693: if(C==1){
5694: str_tb(S0=mtotex(mat([PT],[QT])|var=Var),Tb);
5695: M=N;
5696: }
5697: str_tb("&=",Tb);
5698: if(C>1) str_tb(mtotex(M),Tb);
5699: str_tb(mtotex(N|var=Var),Tb);
5700: str_tb(S=mtotex(mat([QT],[T[1]])|var=Var),Tb);
5701: if(C>1){
5702: str_tb("=",Tb);
5703: str_tb(mtotex(M=muldo(M,N,L)|var=Var),Tb);
5704: str_tb(S,Tb);
5705: }
5706: }
5707: PT=QT;QT=T[1];
5708: }
5709: if(DVI==2){
5710: FT=fctr(PT);
5711: for(R=1;FT!=[];FT=cdr(FT)){
5712: if(mydeg(car(FT)[0],L[1])<1)
5713: for(J=car(FT)[1];J>0;J--) R*=car(FT)[0];
5714: }
5715: if(R!=1){
5716: str_tb(texcr(79),Tb);
5717: M=muldo(M,mat([R,0],[0,1]),L);
5718: str_tb(mtotex(M|var=Var),Tb);
5719: str_tb(S=mtotex(mat([PT/R],[QT])|var=Var),Tb);
5720: }
5721: str_tb(texcr(43)+S+"&=",Tb);
5722: if(type(Var)==4){
5723: N=mdivisor(M,L|trans=1);
5724: N=N[1];
5725: }else
5726: N=myinv(M);
5727: str_tb(mtotex(N|var=Var),Tb);
5728: str_tb(S0,Tb);
5729: }
5730: Out=str_tb(0,Tb);
5731: if(Dvi>0){
5732: dviout(Out|eq="align*");
5733: return 1;
5734: }
5735: return Out;
5736: }
5737: }
5738: Q = rede(P,L);
5739: R = red(P/Q);
5740: return [Q,red(CP[0]/R),red(CP[1]/R),red(CQ[0]/R),red(CQ[1]/R)];
5741: }
5742:
5743: def mylcm(P,Q,L)
5744: {
5745: Rev=(getopt(rev)==1)?1:0;
5746: if(Rev==1){
5747: P=adj(P); Q=adj(Q);
5748: }
5749: R = mygcd(P,Q,L);
5750: S=(type(L)<=2)?R[3]*P:muldo(R[3],P,L);
5751: S = nm(S);
5752: if(type(S) <= 1 && type(L) <= 1){
5753: if(S<0) S = -S;
5754: return S;
5755: }
5756: if(type(L) == 2)
5757: return easierpol(S,L);
5758: S=rede(easierpol(S,L[1]),L);
5759: return (Rev==1)?adj(S):S;
5760: }
5761:
5762: def sftpexp(P,LL,F,Q)
5763: {
5764: if(type(LL[0]) < 4)
5765: LL = [LL];
5766: for(L0=L1=[],LT=LL;LT!=[];LT=cdr(LT)){
5767: W=vweyl(car(LT));
5768: L0=cons(W,L0);
5769: D=mydiff(F,W[0]);
5770: if(D!=0) L1=cons(W[1]+Q*D/F,L1);
5771: else L1=cons(W[1],L1);
5772: }
5773: return rede(transpdosub(P,L0,L1),L0);
5774: }
5775:
5776: def applpdo(P,F,LL)
5777: {
5778: if(type(F)>3)
5779: #ifdef USEMODULE
5780: return mmulbys(os_md.applpdo,P,F,[LL]);
5781: #else
5782: return mmulbys(applpdo,P,F,[LL]);
5783: #endif
5784: L = vweyl(LL[0]);
5785: LL = cdr(LL);
5786: Deg = deg(P,L[1]);
5787: S = F;
5788: for(I = R = 0; I <= Deg ; I++){
5789: if(I > 0)
5790: S = mydiff(S,L[0]);
5791: if(LL == [])
5792: R = radd(R,mycoef(P,I,L[1])*S);
5793: else
5794: R = radd(R,applpdo(mycoef(P,I,L[1]), S, LL));
5795: }
5796: return R;
5797: }
5798:
5799: def tranlpdo(P,L,M)
5800: {
5801: N = length(L);
5802: R = size(M);
5803: if(R[0] != N || R[1] != N){
5804: print("Strange size");
5805: return;
5806: }
5807: InvM = M;
5808: if(InvM[1] == 0){
5809: print("Not invertible");
5810: return;
5811: }
5812: XL = newvector(N);
5813: DL = newvector(N);
5814: for(I = 0; I < 0; I++){
5815: R = vweyl(L[I]);
5816: XL[I] = R[0];
5817: DL[I] = R[1];
5818: }
5819: for(I = 0; I < N; I++){
5820: for(J = XX = D0 = 0; J < N; J++){
5821: XX = radd(XX,M[I][J]*XL[J]);
5822: DD = radd(DD, red(InvM[0][I][J]/InvM[1])*DL[J]);
5823: P = mysubst(P,[[XL[I],XX],[DL[I],DD]]);
5824: }
5825: }
5826: return P;
5827: }
5828:
5829: def divdo(P,Q,L)
5830: {
5831: if(L==0){
5832: R=P-idiv(P,Q)*Q;
5833: if(R<0){
5834: if(Q>0) R+=Q;
5835: else R-=Q;
5836: }
5837: return [(P-R)/Q,R,1];
5838: }
5839: L = vweyl(L);
5840: if(getopt(rev)==1){
5841: R=divdo(adj(P,L),adj(Q,L),L);
5842: return [adj(R[0],L),adj(R[1],L),R[2]];
5843: }
5844: X = L[0]; DX = L[1];
5845: S = 0;
5846: M = 1;
5847: I = mydeg(Q,DX);
5848: CQ = mycoef(Q,I,DX);
5849: while((J=mydeg(P,DX)) >= I){
5850: C = mycoef(P,J,DX);
5851: SR = red(C/CQ);
5852: if(dn(SR) != 1){
5853: M *= dn(SR);
5854: P *= dn(SR);
5855: S *= dn(SR);
5856: SR = nm(SR);
5857: }
5858: P -= muldo(SR*(DX)^(J-I),Q,L);
5859: S += SR*(DX)^(J-I);
5860: }
5861: return [S,P,M];
5862: }
5863:
5864: def qdo(P,Q,L)
5865: {
5866: L = vweyl(L); DX = L[1]; OD = deg(P,DX);
5867: V = newvect(OD+1);
5868: for(I = 0; I <= OD; I++){
5869: if(I)
5870: Q = muldo(DX,Q,L);
5871: S = divdo(Q,P,L);
5872: V[I] = S[1]*DX-S[2]*zz^I;
5873: }
5874: for(K = [], I = OD; I >= 0; I--)
5875: K = cons(DX^(I+1), K);
5876: R = lsol(V,K);
5877: S = length(R);
5878: for(I = P1 = 0; I < S; I++){
5879: if(type(R[I]) < 4 && mydeg(R[I],DX) == 0 && R[I] != 0
5880: && (mydeg(R[I],zz) <= mydeg(P,DX)))
5881: P1 = R[I];
5882: else if(type(R[I]) == 4 && R[I][0] == DX)
5883: P2 = R[I][1];
5884: }
5885: T=fctr(P1);
5886: for(I=0, S=length(T), P1=1; I<S; I++){
5887: if(mydeg(T[I][0],zz) > 0)
5888: P1 *= T[I][0]^(T[I][1]);
5889: }
5890: return subst([P1,P2],zz,DX);
5891: }
5892:
5893: def sqrtdo(P,L)
5894: {
5895: L = vweyl(L);
5896: P = toeul(P,L,0);
5897: V = -1;
5898: for(R = 0, Ord = mydeg(P,L[1]); Ord >= 0; Ord--){
5899: Q = coef(P,Ord,L[1]);
5900: M = mydeg(Q,L[0]);
5901: N = mymindeg(Q,L[0]);
5902: if(V < 0)
5903: V = M+N;
5904: else if(V != M+N){
5905: print("Cannot be transformed!");
5906: return;
5907: }
5908: Q = tohomog(red(Q/L[0]^N), [L[0]], z_z);
5909: if(irem(Ord,2))
5910: B = x-z_z;
5911: else
5912: B = x+z_z;
5913: Q = substblock(Q,x,B,z_zz);
5914: if(mydeg(Q,x) > 0){
5915: print("Cannot be transformed!");
5916: return;
5917: }
5918: R += mysubst(Q,[z_zz,x])*L[1]^Ord;
5919: }
5920: return fromeul(R,L,0);
5921: }
5922:
5923: def ghg(A,B)
5924: {
5925: R = dx;
5926: while(length(B)>0){
5927: R = muldo(x*dx+car(B),R,[x,dx]);
5928: B = cdr(B);
5929: }
5930: T = 1;
5931: while(length(A)>0){
5932: T = muldo(x*dx+car(A),T,[x,dx]);
5933: A = cdr(A);
5934: }
5935: return R-T;
5936: }
5937:
5938: def ev4s(A,B,C,S,T)
5939: {
5940: R4 = x^2*(x-1)^2;
5941: R3 = x*(x-1)*((2*A-2*B-8)*x-2*A+5);
5942: R2 = (-3/2*(A^2+B^2)+3*A*B+9*A-9*B-29/2+1/4*(S^2+T^2))*x^2
5943: +(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
5944: - (2*A+2*C-5)*(2*A-2*C-3)/4;
5945: 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
5946: +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
5947: #if 1
5948: + A^2*B
5949: #endif
5950: - B*C^2 - A^3/2+(2*A-3)*(S^2+T^2)/8;
5951: /* OK? for the above term added */
5952: R0 = -(A-B-1-S)*(A-B-1+S)*(A-B-1-T)*(A-B-1+T)/16;
5953: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
5954: }
5955:
5956: def b2e(A,B,C,S,T)
5957: {
5958: R4 = x^2*(x-1)^2;
5959: R3 = x*(x-1)*(2*x-1)*(2*c-5);
5960: R2 = (-6*C^2+24*C-25+1/2*S^2+1/2*T^2)*x^2
5961: +(6*C^2-24*C+25-1/2*S^2-1/2*T^2-A^2+B^2+A-B)*x
5962: +A^2-C^2-A+4*C-15/4;
5963: R1 = (2*C-3)*(2*C^2-6*C+5-1/2*S^2-1/2*T^2)*x
5964: +(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);
5965: R0 = -(2-2*C+S+T)*(2-2*C-S-T)*(2-2*C+S-T)*(2-2*C-S+T)/16;
5966: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
5967: }
5968:
5969:
5970: /*
5971: T^m = T(T-1)....(T-m+1)
5972: f(t) -> g(t)
5973:
5974: f(t) = a_mt^m + ... + a_1t+a_0
5975: g(x*dx) = a_m*x^m*dx^m + ... + a_1*x*dx+a_0
5976:
5977: ret: x(x-1)...(x-i+1)
5978: */
5979: def sftpow(X,I)
5980: {
5981: R = 1;
5982: for(J=0;J<I;J++)
5983: R *= X-J;
5984: return(R);
5985: }
5986:
5987: /*
5988: ret: x(x+K)(x+2*k)...(x+(i-1)*k)
5989: */
5990: def sftpowext(X,I,K)
5991: {
5992: R = 1;
5993: for(J=0;J<I;J++)
5994: R *= X+K*J;
5995: return(R);
5996: }
5997:
5998: def polinsft(F,A)
5999: {
6000: R = 0;
6001: while(F != 0){
6002: D = mydeg(F,A);
6003: C = mycoef(F,D,A);
6004: R += C*A^D;
6005: F -= C*sftpow(A,D);
6006: }
6007: return R;
6008: }
6009:
6010: def pol2sft(F,A)
6011: {
6012: S=getopt(sft);
6013: if(type(S)<0 || type(S)>2) S=1;
6014: R = 0;
6015: for(I = mydeg(F,A); I >= 0; I--)
6016: R = R*(A-I*S) + mycoef(F,I,A);
6017: return R;
6018: }
6019:
6020: def binom(P,N)
6021: {
1.20 takayama 6022: if(type(N)!=1 || N<=0) return 1;
1.6 takayama 6023: for(S=1;N>0;N--,P-=1) S*=P/N;
6024: return red(S);
6025: }
6026:
6027: def expower(P,R,N)
6028: {
6029: if(type(N)!=1 || N<0) return 0;
6030: for(S=S0=K=1;K<=N;K++,R-=1){
6031: S0*=P*R/K;S+=S0;
6032: }
6033: return red(S);
6034: }
6035:
6036: def seriesHG(A,B,X,N)
6037: {
1.20 takayama 6038: if(N==0) return 1;
1.6 takayama 6039: if(type(N)!=1 || N<0) return 0;
6040: if(type(X)<4){
6041: for(K=0,S=S0=1;K<N;K++){
6042: for(T=A; T!=[]; T=cdr(T)) S0*=car(T)+K;
6043: for(T=B; T!=[]; T=cdr(T)) S0/=car(T)+K;
6044: S0=red(S0*X/(K+1));
6045: DN=dn(S0);
6046: S=red((red(S*DN)+nm(S0))/DN);
6047: }
6048: return S;
6049: }
6050: S=0;
6051: for(K=0;K<=N;K++){
6052: for(I=0;I<=N-K;I++){
6053: C=1/sftpowext(1,I,1)/sftpowext(1,J,1);
6054: for(T=A[0];T!=[];T=cdr(T)) C*=sftpowext(car(T),I+K,1);
6055: for(T=A[1];T!=[];T=cdr(T)) C*=sftpowext(car(T),I,1);
6056: for(T=A[2];T!=[];T=cdr(T)) C*=sftpowext(car(T),K,1);
6057: for(T=B[0];T!=[];T=cdr(T)) C/=sftpowext(car(T),I+K,1);
6058: for(T=B[1];T!=[];T=cdr(T)) C/=sftpowext(car(T),I,1);
6059: for(T=B[2];T!=[];T=cdr(T)) C/=sftpowext(car(T),K,1);
6060: S+=red(C*X[0]^I*X[1]^K);
6061: }
6062: }
6063: return S;
6064: }
6065:
6066: def evalred(F)
6067: {
6068: Opt=getopt(opt);
6069: if(type(Opt)!=4){
6070: Opt=[];
6071: }else if(length(Opt)==2 && type(Opt[0])!=4) Opt=[Opt];
6072: for(;;){
1.17 takayama 6073: G=mysubst(F,[[tan(0),0],[asin(0),0],[atan(0),0],[sinh(0),0],[tanh(0),0],
6074: [log(1),0],[cosh(0),1],[exp(0),1]]);
1.6 takayama 6075: for(Rep=Opt; Rep!=[]; Rep=cdr(Rep))
6076: G=subst(G,car(Rep)[0],car(Rep)[1]);
6077: Var=vars(G);
6078: for(V=Var; V!=[]; V=cdr(V)){
1.17 takayama 6079: if(!(VV=args(CV=car(V)))) continue;
6080: if((functor(CV)==sin||functor(CV)==cos)){
6081: P=2*red(VV[0]/@pi);
6082: if(functor(CV)==sin) P=1-P;
6083: if(isint(P)){
6084: if(iand(P,1)) G=subst(G,CV,0);
6085: else if(!iand(P,3)) G=subst(G,CV,1);
6086: else G=subst(G,CV,-1);
6087: continue;
6088: }
6089: if(isint(P*=3/2)){
6090: if(iand(P,3)==1) G=subst(G,CV,1/2);
6091: else G=subst(G,CV,-1/2);
6092: }
6093: }
6094: for(;VV!=[];VV=cdr(VV))
6095: if(car(VV)!=(TV=evalred(car(VV)))) G=subst(G,car(VV),TV);
6096: if(functor(CV)!=pow || (args(CV)[0])!=1) continue;
6097: G=subst(G,CV,1);
1.6 takayama 6098: }
6099: if(G==F) return F;
6100: F=G;
6101: }
6102: }
6103:
6104: def seriesMc(F,N,V)
6105: {
6106: if(type(V)<4) V=[V];
6107: V=reverse(V);
6108: L=length(V);
6109: if(type(Opt=getopt(evalopt))!=4) Opt=[];
6110: P=newvect(L);
6111: G=newvect(L+1);
6112: G[0]=F;
6113: for(I=0;I<L;I++)
6114: G[I+1]=eval(evalred(subst(G[I],V[I],0)|opt=Opt));
6115: R=G[L];
6116: for(;;){
6117: for(M=0,I=0;I<L;I++){
6118: M+=P[I];
6119: if(M==N) break;
6120: }
6121: if(M<N){
6122: P[L-1]++;
6123: G[L-1]=mydiff(G[L-1],V[L-1]);
6124: G[L]=eval(evalred(mysubst(G[L-1],[V[L-1],0])|opt=Opt));
6125: }else{
6126: if(I--==0) break;
6127: P[I]++;
6128: G[I]=mydiff(G[I],V[I]);
6129: while(I++<L){
6130: G[I]=eval(evalred(mysubst(G[I-1],[V[I-1],0])|opt=Opt));
6131: if(I<L) P[I]=0;
6132: }
6133: }
6134: K=1;
6135: for(I=0;I<L;I++) K*=V[I]^P[I]/fac(P[I]);
6136: R+=G[L]*K;
6137: }
6138: return R;
6139: }
6140:
6141: def seriesTaylor(F,N,V)
6142: {
6143: G=F;
6144: if(isvar(V)) V=[V];
6145: if(length(V)==2 && type(car(V))!=4 && !isvar(V[1])) V=[V];
6146: for(V0=V1=[];V!=[];V=cdr(V)){
6147: if(type(T=car(V))!=4) T=[T];
6148: V0=cons(X=car(T),V0);
6149: if(length(T)==1 || T[1]==0){
6150: V1=cons(X,V1);continue;
6151: }
6152: S=my_tex_form(-T[1]);
6153: if(str_char(S,0,"-")!=0) S="+"+S;
6154: S="("+my_tex_form(X)+S+")";
6155: V1=cons([X,S],V1);
6156: F=red(subst(F,T[0],T[0]+T[1]));
6157: }
6158: V0=reverse(V0);V1=reverse(V1);
6159: F=seriesMc(F,N,V0|option_list=getopt());
6160: if(getopt(frac)==0) F=frac2n(F);
6161: T=getopt(dviout);
6162: if(type(T)!=1) T=0;
6163: F=fctrtos(F|var=V1,rev=1,TeX=(T==0||T==2)?2:3);
6164: if(getopt(small)==1) F=str_subst(F,"\\frac{","\\tfrac{");
6165: if(T<0 || T==1) F="\\begin{align}\\begin{split}\n"+
6166: my_tex_form(G)+"&="+F+"+\\cdots\n\\end{split}\\end{align}\n";
6167: if(T==1) dviout(F);
6168: else if(T==1) dviout(F|eq=4);
6169: return F;
6170: }
6171:
1.27 takayama 6172: def mulpolyMod(P,Q,X,N)
6173: {
6174: Red=(type(P)>2||type(Q)>2)?1:0;
6175: for(I=R=0;I<=N;I++){
6176: P0=mycoef(P,I,X);
6177: for(J=0;J<=N-I;J++){
6178: R+=P0*mycoef(Q,J,X)*X^(I+J);
6179: if(Red) R=red(R);
6180: }
6181: }
6182: return R;
6183: }
6184:
1.26 takayama 6185: def taylorODE(D){
6186: Dif=(getopt(dif)==1)?1:0;
6187: if(D==0) return Dif?f:f_00;
1.27 takayama 6188: if(type(T=getopt(runge))!=1||ntype(T)!=0) T=0;
1.26 takayama 6189: if(type(F=getopt(f))!=7&&type(F)<2) F="f_";
6190: if(type(D)!=1||ntype(D)!=0||D<0||D>30) return 0;
6191: if(type(H=getopt(taylor))==4&&length(H)==2){
1.27 takayama 6192: if(type(Lim=getopt(lim))==2) DD=D;
6193: else if(type(Lim)==4){
6194: DD=Lim[1];Lim=Lim[0];
6195: }else Lim=0;
6196: for(R=I=0;I<=D;I++){
6197: if(I){
6198: if(Lim) H0=mulpolyMod(H0,H[0],Lim,DD);
6199: else H0*=H[0];
6200: }else H0=1;
6201: if(type(F)!=7) G=I?mydiff(G,x):F;
6202: for(J=0;J<=D-I;J++){
6203: if(J){
6204: if(Lim) H1=mulpolyMod(H1,H[1],Lim,DD);
6205: else H1*=H[1];
6206: }else H1=H0;
6207: if(type(F)==7) G=makev([F,I,J]);
6208: else if(J) G=mydiff(G,y);
6209: R+=G*H1/fac(I)/fac(J);
1.26 takayama 6210: }
6211: }
1.27 takayama 6212: if(Lim) R=os_md.polcut(R,DD,Lim);
6213: return R;
1.26 takayama 6214: }else{
6215: if(type(H=getopt(series))>=0||getopt(list)==1){
6216: if(type(F)!=7){
6217: for(PP=[F],I=1;I<D;I++)
6218: PP=cons(mydiff(car(PP),x)+mydiff(car(PP),y)*F,PP);
6219: if(type(H)<0) return PP;
6220: for(R=0,DD=D;DD>=1;DD--,PP=cdr(PP)) R+=car(PP)*H^DD/fac(DD);
6221: return red(R);
6222: }
6223: if(type(H)>=0) D--;
6224: PP=taylorODE(D-1|list=1);
6225: if(type(PP)!=4) PP=[PP];
6226: P=car(PP);
6227: }else P=taylorODE(D-1);
6228: for(R=I=0;I<D;I++){
6229: for(J=0;J<D-I;J++){
6230: Q=diff(P,makev([F,I,J]));
6231: if(Q!=0) R+=Q*(f_00*makev([F,I,J+1])+makev([F,I+1,J]));
6232: }
6233: }
6234: if(getopt(list)==1){
6235: R=cons(R,PP);
6236: if(Dif!=1) return R;
6237: }else if(type(H)>=0){
6238: R=y+R*H^(D+1)/fac(D+1);
6239: for(DD=D;DD>0;PP=cdr(PP),DD--) R+=car(PP)*H^(DD)/fac(DD);
6240: if(T){
1.35 takayama 6241: if(T<0){
6242: Dif=0;TT=-T;
6243: }else TT=T;
1.26 takayama 6244: K=newvect(TT);K[0]=Dif?f:f_00;
1.35 takayama 6245: if(getopt(c1)==1) K[0]=taylorODE(D|taylor=[c_1*H,0]);
1.26 takayama 6246: for(I=1;I<TT;I++){
6247: for(S=J=0;J<I;J++) S+=makev(["a_",I+1,J+1])*K[J];
1.35 takayama 6248: K[I]=taylorODE(D|taylor=[makev(["c_",I+1])*H,S*H],lim=[H,D]);
1.26 takayama 6249: }
6250: for(S=I=0;I<TT;I++) S+=makev(["b_",I+1])*K[I];
6251: S=S*H+y;
6252: R=S-R;
6253: if(T<0){
6254: for(V=[H],I=0;I<=D;I++)
6255: for(J=0;J<=D-I;J++) V=cons(makev([F,I,J]),V);
6256: return os_md.ptol(R,reverse(V)|opt=0);
6257: }
6258: }else T=0;
6259: }
6260: }
6261: if(Dif){
6262: for(I=0;I<=D;I++){
6263: for(J=0;J<=D;J++){
6264: if(I==0&&J==0){
6265: R=subst(R,f_00,f);
6266: continue;
6267: }
6268: V=makev([F,str_times("x",I),str_times("y",J)]);
6269: R=subst(R,makev([F,I,J]),V);
6270: }
6271: }
6272: }
6273: return R;
6274: }
6275:
1.6 takayama 6276: def toeul(F,L,V)
6277: {
6278: L = vweyl(L);
6279: X = L[0]; DX = L[1];
6280: I = mydeg(F,DX);
6281: if(V == "infty"){
6282: for(II=I; II>=0; II--){
6283: J = mydeg(P=mycoef(F,I,DX),X);
6284: if(II==I) S=II-J;
6285: else if(P!=0 && II-J>S) S=II-J;
6286: }
6287: F *= X^S;
6288: R = 0;
6289: for( ; I >= 0; I--)
6290: R += red((mysubst(mycoef(F,I,DX),[X,1/X])*(x*DX)^I));
6291: return(subst(pol2sft(R,DX),DX,-DX));
6292: }
6293: F = subst(F,X,X+V);
6294: for(II=I; II>=0; II--){
6295: J = mymindeg(P=mycoef(F,II,DX),X);
6296: if(II==I) S=II-J;
6297: else if(P!=0 && II-J>S) S=II-J;
6298: }
6299: F *= X^S;
6300: R = 0;
6301: for( ; I >= 0; I--)
6302: R += (red(mycoef(F,I,DX)/X^I))*DX^I;
6303: return pol2sft(R,DX);
6304: }
6305:
6306: /*
6307: def topoldif(P,F,L)
6308: {
6309: L = vweyl(L);
6310: P = nm(red(P));
6311: while(deg(P,L[1]) > 0){
6312: R = coef(P,0,L[0]);
6313: Q = red((P-R)/(F*L[0]);
6314: P = nm(Q)*zz+F*R*dn(Q);
6315: }
6316: }
6317: */
6318:
6319: def fromeul(P,L,V)
6320: {
6321: if(P == 0)
6322: return 0;
6323: L = vweyl(L);
6324: X = L[0]; DX = L[1];
6325: I = mydeg(P,DX);
6326: if(V == "infty"){
6327: P = subst(P,DX,-DX);
6328: J = mydeg(P,X);
6329: P = red(mysubst(P,[X,1/X])*X^J);
6330: }
6331: R = mycoef(P,0,DX);
6332: S = 1;
6333: for(S = J = 1; J <= I; J++){
6334: S = DX*(S*X + mydiff(S,DX));
6335: R += mycoef(P,J,DX)*S;
6336: }
6337: while(mycoef(R,0,X) == 0)
6338: R = tdiv(R,X);
6339: if(V != "infty" && V != 0)
6340: R = mysubst(R,[X,X-V]);
6341: return R;
6342: }
6343:
6344: def sftexp(P,L,V,N)
6345: {
6346: L = vweyl(L); DX = L[1];
6347: P = mysubst(toeul(P,L,V),[DX,DX+N]);
6348: return fromeul(P,L,V);
6349: }
6350:
6351:
6352: def fractrans(P,L,N0,N1,N2)
6353: {
6354: L = vweyl(L);
6355: if(N2 != "infty"){
6356: if(N0 == "infty")
6357: N0 = 0;
6358: else
6359: N0 = red(1/(N0-N2));
6360: if(N1 == "infty")
6361: N1 = 0;
6362: else
6363: N1 = red(1/(N1-N2));
6364: P = mysubst(P,[L[0],L[0]+N2]);
6365: P = fromeul(toeul(P,L,"infty"),L,0);
6366: }
6367: if(N0 != 0){
6368: P = mysubst(P,[L[0],L[0]+N0]);
6369: N1 -= N0;
6370: }
6371: if(N1 != 1)
6372: P = mysubst(P,[[L[0],L[0]/N1],[L[1],L[1]*N1]]);
6373: return P;
6374: }
6375:
6376: def soldif(P,L,V,Q,N)
6377: {
6378: L = vweyl(L); X = L[0]; DX = L[1];
6379: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
6380: DEG = mydeg(P,X);
6381: P0 = newvect(DEG+1);
6382: for(I = 0; I <= DEG; I++)
6383: P0[I] = coef(P,I,X);
6384: if(P0[0] == 0)
6385: return 0;
6386: if(subst(P0[0],DX,0) != 0){
6387: mycat([Q,"is not the exponent at", V])$
6388: return 0;
6389: }
6390: R = newvect(N+1);
6391: R[0] = 1;
6392: for(I = 1; I <= N; I++){
6393: for(S = 0, K = 1; K <= DEG && K <= I; K++)
6394: S += mysubst(P0[K],[DX,I-K])*R[I-K];
6395: S = red(S);
6396: M = mysubst(P0[0],[DX,I]);
6397: if(M != 0){
6398: R[I] = -red(S/M);
6399: if(R1 != 0){
6400: for(S = 0, K = 1; K <= DEG && K <= I; K++)
6401: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
6402: mysubst(P1[K],[DX,I-K])*R[I-K];
6403: R1[I] = -red(S/M);
6404: }
6405: }else{
6406: if(S == 0){
6407: if(R1 != 0){
6408: for(S = 0, K = 1; K <= DEG && K <= I; K++)
6409: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
6410: mysubst(P1[K],[DX,I-K])*R[I-K];
6411: }
6412: if(S == 0)
6413: continue;
6414: }
6415: R1 = newvect(N+1);
6416: for(K = 0; K < I; K++){
6417: R1[K] = R[K];
6418: R[K] = 0;
6419: }
6420: R1[I] = 0;
6421: P1 = newvect(DEG);
6422: for(K = 0; K <= DEG; K++)
6423: P1[K] = mydiff(P0[K], DX);
6424: M = mysubst(P1[0],[DX,I]);
6425: if(M == 0){
6426: cat(["multiple log at ", I])$
6427: return 0;
6428: }
6429: R[I] = -red(S/M);
6430: }
6431: }
6432: if(R1 != 0)
6433: return [R1, R];
6434: else
6435: return R;
6436: }
6437:
6438: def chkexp(P,L,V,Q,N)
6439: {
6440: L = vweyl(L); X = L[0]; DX = L[1];
6441: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
6442: P = fromeul(P,L,0);
6443: D = mydeg(P,DX);
6444: Z = mindeg(mycoef(P,D,DX), X) - (D-N);
6445: R = [];
6446: for(I = 0; I < Z; I++){
6447: S = mycoef(P,I,X);
6448: if(S != 0){
6449: for(J = mydeg(S,DX); J >= 0; J--){
6450: T = mycoef(S,J,DX);
6451: if(T != 0)
6452: R = cons(T,R);
6453: }
6454: }
6455: }
6456: return R;
6457: }
6458:
6459:
6460: def sqrtrat(P)
6461: {
6462: if(P==0) return 0;
6463: if(type(P)==3||type(P)==2){
6464: P=red(P);
6465: if(imag(dn(P))!=0||imag(nm(P))!=0){
6466: if(imag(dn(P))==0&&real(P)!=0){
6467: F=red(imag(P)/real(P));
6468: if(F==3^(1/2)||F==-3^(1/2)){
6469: if(eval(real(P))<0)
6470: return -real(P)+imag(P)*@i;
6471: else{
6472: if(eval(imag(P))>0) return imag(P)+real(P)*@i;
6473: else return -imag(P)-real(P)*@i;
6474: }
6475: }
6476: }
6477: return [];
6478: }
6479: F=fctr(dn(P));
6480: R=sqrtrat(car(F)[0]);
6481: for(F=cdr(F);F!=[];F=cdr(F)){
6482: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
6483: else return [];
6484: }
6485: F=fctr(nm(P));
6486: R=sqrtrat(car(F)[0])/R;
6487: for(F=cdr(F);F!=[];F=cdr(F)){
6488: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
6489: else return [];
6490: }
6491: return R;
6492: }
6493: if(ntype(P)==4){
6494: P0=real(P);P1=imag(P)/2;
6495: X=makenewv(P);
6496: for(R=fctr(X^4-P0*X^2-P1^2);R!=[];R=cdr(R)){
6497: RT=car(R)[0];
6498: if(deg(RT,X)==1){
6499: X=-mycoef(RT,0,X)/mycoef(RT,1,X);
6500: return X+P1/X*@i;
6501: }
6502: if(deg(RT,X)==2){
6503: if((D=mycoef(RT,1,X)^2-4*mycoef(RT,2,X)*mycoef(RT,0,X))<0) continue;
6504: X=(-mycoef(RT,1,X)+sqrtrat(D))/(2*mycoef(RT,2,X));
6505: return X+P1*sqrt2rat(1/X)*@i;
6506: }
6507: }
6508: D=P0^2+4*P1^2;
6509: if(P1>0) return ((sqrtrat(D)+P0)/2)^(1/2)+((sqrtrat(D)-P0)/2)^(1/2)*@i;
6510: return ((sqrtrat(D)+P0)/2)^(1/2)-((sqrtrat(D)-P0)/2)^(1/2)*@i;
6511: }else if(ntype(P)!=0) return [];
6512: if(P==1) return P;
6513: Dn=dn(P);Nm=nm(P);C=R=1;
6514: N=pari(factor,Dn);
6515: if(N){
6516: for(II=car(size(N))-1;II>=0;II--){
6517: if(iand(K=N[II][1],1)){
6518: R*=N[II][0];
6519: K++;
6520: }
6521: C/=N[II][0]^(K/2);
6522: }
6523: }
6524: N=pari(factor,Nm);
6525: if(N){
6526: for(II=car(size(N))-1;II>=0;II--){
6527: if(N[II][0]==-1){
6528: C*=@i;
6529: continue;
6530: }
6531: K=N[II][1];
6532: if(iand(K,1)){
6533: R*=N[II][0];
6534: K--;
6535: }
6536: if(K!=0) C*=N[II][0]^(K/2);
6537: }
6538: }
6539: if(R!=1) C*=R^(1/2);
6540: return C;
6541: }
6542:
6543: def fctri(F)
6544: {
6545: R=(iscoef(F,os_md.israt))?fctr(F):[[1,1],[F,1]];
6546: if(!iscoef(F,os_md.iscrat)||chkfun("af_noalg",0)==0) return R;
6547: X=makenewv(vars(F));
6548: for(S=[];R!=[];R=cdr(R)){
6549: if(length(Var=vars(R0=car(R)[0])) == 1 && (D=mydeg(R0,Var=car(Var))) > 0){
6550: if(imag(T=mycoef(R0,D,Var))!=0) R0/=T;
6551: T=af_noalg(real(R0)+imag(R0)*X,[[X,X^2+1]]);
6552: if(length(T)>1||T[0][1]>1){
6553: T=subst(T,X,@i);
6554: for(; T!=[];T=cdr(T)){
6555: if(vars(T[0])!=[])
6556: S=cons([car(T)[0],car(T)[1]*car(R)[1]],S);
6557: }
6558: continue;
6559: }
6560: }
6561: S=cons(R[0],S);
6562: }
6563: return reverse(S);
6564: }
6565:
6566: def getroot(F,X)
6567: {
6568: S=[];
6569: if(type(Cpx=getopt(cpx))!=1) Cpx=0;
6570: M=getopt(mult);
6571: if(type(F) == 3)
6572: F = nm(red(F));
6573: for(R=fctri(F); length(R)>0; R = cdr(R)){
6574: T=car(R);
6575: P=car(T);
6576: I=car(cdr(T));
6577: if(mydeg(P,X)>0){
6578: if(mydeg(P,X)==1){
6579: C = mycoef(P,1,X);
6580: P = X - red(P/C);
6581: }else if(mydeg(P,X)==2 && Cpx>0){
6582: C2=mycoef(P,2,X);C1=mycoef(P,1,X);C0=mycoef(P,0,X);
6583: C=sqrt2rat(C1^2-4*C0*C2);
6584: C0=[];
6585: if(type(C)==0&&ntype(C)==0&&pari(issquare,-C)) C0=sqrt(C);
6586: else if(Cpx>1) C0=sqrtrat(C);
6587: if(C0==[]&&Cpx>2) C0=C^(1/2);
6588: if(C0!=[]){
6589: if(M==1)
6590: S=cons([I,sqrt2rat((-C1+C0)/(2*C2))],S);
6591: else{
6592: for(II=I; II>0; II--)
6593: S=cons(sqrt2rat((-C1+C0)/(2*C2)),S);
6594: }
6595: P=sqrt2rat((-C1-C0)/(2*C2));
6596: }
6597: }else if(mydeg(P,X)==3 && Cpx>1){
6598: Omg=(-1+3^(1/2)*@i)/2;
6599: PP=P/mycoef(P,3,X);
6600: C2=mycoef(PP,2,X)/3;
6601: PP=subst(PP,X,X-C2);
6602: if((C1=mycoef(PP,1,X))==0){
6603: C0=mycoef(PP,0,X);
6604: if(real(C0)==0||imag(C0)==0){
6605: if(real(C0)==0){
6606: PP=getroot(X^3+imag(C0),X);
6607: if(length(PP)==3){
6608: for(;PP!=[];PP=cdr(PP)){
6609: if(imag(PP[0])==0){
6610: C0=PP[0]*@i;
6611: break;
6612: }
6613: }
6614: if(PP==[]) C0=0;
6615: }
6616: }else{
6617: if(C0>0) C0=C0^(1/3);
6618: else C0=-(-C0)^(1/3);
6619: }
6620: if(C0!=0){
6621: if(M==1){
6622: S=cons([I,C0-C2],S);
6623: S=cons([I,C0*Omg-C2],S);
6624: S=cons([I,C0*(-1-Omg)-C2],S);
6625: }else{
6626: for(II=I; II>0; II--){
6627: S=cons(C0-C2,S);
6628: S=cons(C0*Omg-C2,S);
6629: S=cons(C0*(-1-Omg)-C2,S);
6630: }
6631: }
6632: continue;
6633: }
6634: }
6635: }
6636: if(Cpx>2){
6637: Q=X^2+(mycoef(PP,1,X)/3)*X+mycoef(PP,0,X)^3;
6638: SQ=getroot(Q,X|cpx=2);
6639: SQ=SQ[0]^(1/3);SQ2=mycoef(PP,0,X)/SQ;
6640: if(M==1){
6641: S=cons([I,SQ+SQ2-C2],S);
6642: S=cons([I,SQ*Omg+SQ2*(-1-Omg)-C2],S);
6643: S=cons([I,SQ*(-1-Omg)+SQ2*Omg-C2],S);
6644: }else{
6645: for(II=I; II>0; II--){
6646: S=cons(SQ+SQ2-C2,S);
6647: S=cons(SQ*Omg+SQ2*(-1-Omg)-C2,S);
6648: S=cons(SQ*(-1-Omg)+SQ2*Omg-C2,S);
6649: }
6650: }
6651: continue;
6652: }
6653: }else if(mydeg(P,X)==4 && Cpx>0){
6654: C2=mycoef(P,3,X)/(4*mycoef(P,4,X));
6655: PP=subst(P,X,X-C2);
6656: if(mycoef(PP,1,X)==0){
6657: PP=mycoef(PP,4,X)*X^2+mycoef(PP,2,X)*X+(SQ2=mycoef(PP,0,X));
6658: SQ=getroot(PP,X|cpx=2);
6659: if(length(SQ)==2){
6660: if((C0=sqrtrat(SQ[0]))==[]){
6661: if(mycoef(PP,1,X)==0){
6662: if(SQ2<0) C0=(-SQ2)^(1/4);
6663: else C0=SQ2^(1/4)*(1+@i)/2;
6664: }
6665: else if(Cpx>2) C0=SQ[0]^(1/2);
6666: else C0=0;
6667: }
6668: if((C1=sqrtrat(SQ[1]))==[]){
6669: if(mycoef(PP,1,X)==0) C1=-C0;
6670: else C1=SQ[1]^(1/2);
6671: }
6672: if(C0!=0){
6673: if(M==1)
6674: S=append([[I,C0-C2],[I,-C0-C2],[I,C1-C2],[I,-C1-C2]],S);
6675: else{
6676: for(II=I; II>0; II--)
6677: S=append([C0-C2,-C0-C2,C1-C2,-C1-C2],S);
6678: }
6679: continue;
6680: }
6681: }
6682: }else{
6683: PP/=mycoef(PP,4,X);
6684: CC=mycoef(PP,2,X);C1=mycoef(PP,1,X);C0=mycoef(PP,0,X);
6685: SQ=getroot(X*(CC+X)^2-4*C0*X-C1^2,X|cpx=Cpx);
6686: if(length(SQ)>1){
6687: SQ=sqrt2rat(SQ[0]);
6688: SQ2=getroot(X^2-SQ,X|cpx=Cpx);
6689: if(length(SQ2)>1){
6690: C1=SQ2[0]*X-C1/SQ2[0]/2;
6691: C0=getroot(X^2+CC/2+SQ/2+C1,X|cpx=Cpx);
6692: C1=getroot(X^2+CC/2+SQ/2-C1,X|cpx=Cpx);
6693: if(length(C0)>1&&length(C1)>1){
6694: C0=[sqrt2rat(C0[0]-C2),sqrt2rat(C0[1]-C2),
6695: sqrt2rat(C1[0]-C2),sqrt2rat(C1[1]-C2)];
6696: if(M==1) for(II=0;II<4;II++) S=cons([I,C0[II]],S);
6697: else for(II=I; II>0; II--) S=append(C0,S);
6698: continue;
6699: }
6700: }
6701: }
6702: }
6703: }
6704: if(M==1)
6705: S=cons([I,P],S);
6706: else for( ; I>0; I--) S=cons(P,S);
6707: }
6708: }
6709: S=qsort(S);
6710: if(M==1) S=reverse(S);
6711: return S;
6712: }
6713:
6714: def expat(F,L,V)
6715: {
6716: L = vweyl(L);
6717: if(V == "?"){
6718: Ans = [];
6719:
6720: F = nm(red(F));
6721: S = fromeul(toeul(F,L,"infty"),L,0);
6722: S = mycoef(S,mydeg(S,L[1]),L[1]);
6723: if(mydeg(S,L[0]) > 0)
6724: Ans = cons(["infty", expat(F,L,"infty")],Ans);
6725:
6726: S = mycoef(F,mydeg(F,L[1]), L[1]);
6727: R = getroot(S,L[0]);
6728: for(I = 0; I < length(R); I++){
6729: if(I > 0 && R[I-1] == R[I])
6730: continue;
6731: if(mydeg(R[I], L[0]) <= 0)
6732: Ans = cons([R[I], expat(F,L,R[I])], Ans);
6733: else
6734: Ans = cons([R[I]], Ans);
6735: }
6736: return Ans;
6737: }
6738: return getroot(subst(toeul(F,L,V),L[0],0),L[1]);
6739: }
6740:
6741: def polbyroot(P,X)
6742: {
6743: R = 1;
6744: while(length(P)){
6745: R *= X-car(P);
6746: if(type(R)>2) R = red(R);
6747: P = cdr(P);
6748: }
6749: return R;
6750: }
6751:
6752: def polbyvalue(P,X)
6753: {
6754: R = 1; S = 0;
6755: while(length(P)){
6756: T = car(P);
6757: V0 = T[1] - mysubst(S,[X,T[0]]);
6758: if(V0 != 0){
6759: if(type(R) > 2) R = red(R);
6760: V1 = mysubst(R,[X,T[0]]);
6761: if(V1 == 0){
6762: erno(0);
6763: return 0;
6764: }
6765: S += (V0/V1)*R;
6766: if(type(S) > 2) S = red(S);
6767: }
6768: R *= X - T[0];
6769: P = cdr(P);
6770: }
6771: return S;
6772: }
6773:
6774:
6775: def pcoef(P,L,Q)
6776: {
6777: if(L==0)
6778: return 1;
6779: Coef=TP=0;
6780: if(type(Q)>=4){
6781: TP=1;
6782: V=Q[0];
6783: if(type(V)==4)
6784: V=ltov(V);
6785: else V=dupmat(V);
6786: N=length(V);
6787: if(type(Q[1])==5) MR=dupmat(Q[1]);
6788: else{
6789: MR=newvect(N);
6790: for(K=Q[1], I=0; I< N; I++){
6791: MR[I] = car(K);
6792: K = cdr(K);
6793: }
6794: }
6795: }else{
6796: V=ltov(vars(P));
6797: N=length(V);
6798: MR=newvect(N);
6799: for(I=0;I<N;I++){
6800: MR[I]=mydeg(Q,V[I]);
6801: Q=mycoef(Q,MR[I],V[I]);
6802: }
6803: if(type(Q)>1) return 0;
6804: }
6805: if(L==1){
6806: for(I=0;I<N;I++)
6807: P=mycoef(P,MR[I],V[I]);
6808: return P;
6809: }
6810: for(I=1;I<N;I++){ /* sorted by required degrees */
6811: for(K1=MR[I],K2=V[I],J=I-1; J>=0 && MR[J]<K1; J--);
6812: for(II=I-1;II>J;II--){
6813: MR[II+1]=MR[II];V[II+1]=V[II];
6814: }
6815: MR[II+1]=K1;V[II+1]=K2;
6816: }
6817: for(NN=N; N>0 && MR[N-1]==0; N--);
6818: Mon=[];Coe=[];Q=P;
6819: while(Q!=0){
6820: M=newvect(N);
6821: for(R=Q,F=I=0,MT=1;I<NN;I++){
6822: K=mydeg(R,V[I]);
6823: R=mycoef(R,K,V[I]);
6824: if(I<N) M[I]=K;
6825: if(K>0) MT*=V[I]^K;
6826: if(K>MR[I]) F=1;
6827: }
6828: Q -= R*MT;
6829: if(F==0){
6830: Mon=cons(M,Mon);
6831: Coe=cons(R,Coe);
6832: }
6833: }
6834: Mon=ltov(reverse(Mon));
6835: Coe=ltov(reverse(Coe));
6836: Len=length(Mon);
6837: S=newvect(Len);
6838: for(JL=0; JL<Len;JL++){
6839: if(L*Mon[JL][0]<MR[0]) break;
6840: }
6841: S[0]=L;
6842:
6843: K0=Mon[0][0];
6844: K=L*K0-MR[0];
6845: for(I=II=0;II<Len && K>=0;II++){
6846: if((K1=K0-Mon[0][II])>0){
6847: while(K>K1 && S[I]>0){
6848: S[I]--;S[II]++;
6849: K-=K1;
6850: I=II;
6851: K0=Mon[0][II];
6852: }
6853: }else break;
6854: }
6855:
6856: I=0;
6857: while(1){
6858: for(T=T0=J=JP=0; J<Len; J++){
6859: if(S[J]!=0){
6860: if(T0==0 && J>=JL) return Coef;
6861: JP=J;T0=1;
6862: T+=S[J]*Mon[J][I];
6863: }
6864: }
6865: if(T==MR[I]){
6866: if(++I<N) continue;
6867: for(TT=1,J=1; J<=L; J++) /* find a solution */
6868: TT*=J;
6869: for(J=0;J<Len;J++){
6870: if(S[J]!=0){
6871: TT*=Coe[J]^S[J];
6872: for(II=S[J]; II>1; II--)
6873: TT/=II;
6874: }
6875: }
6876: Coef+=TT;
6877: if(TP==1 && type(Coef)==3) Coef=red(Coef);
6878: if(JP<Len-2 && S[JP]>1){
6879: S[JP]-=2;S[JP+1]++;S[JP+2]++;
6880: }else{
6881: for(JT=JP-1;JT>=0&&S[JT]==0;JT--);
6882: if(JT<0) break;
6883: if(JT==JP-1){
6884: S[JT]--;
6885: if(JP<Len-1)
6886: S[JP+1]++;
6887: else
6888: S[JP]++;
6889: }else{
6890: S[JT]--;
6891: S[JT+1]+=S[JP]+1;
6892: S[JP]=0;
6893: }
6894: }
6895: I=0;
6896: continue;
6897: }
6898: if(JP<Len-1){
6899: for(JP1=JP+1;JP1<Len-1;JP1++){
6900: if(Mon[JP1][I]!=Mon[JP][I]) break;
6901: }
6902:
6903: if(I>0 && Mon[JP1][0] < Mon[JP][0]){
6904: S[JP]--;S[Len-1]++;JP=JP-1;
6905: }else{
6906:
6907: S[JP]--;
6908: if(JP1<Len){
6909: S[JP1]++;
6910: }else{
6911: S[JP1-1]++;
6912: }
6913: }
6914: }
6915: if(JP==Len-1){
6916: for(JT=JP-1;JT>=0 && S[JT]==0;JT--);
6917: if(JT<0) break;
6918: S[JT]--;
6919: if(JT==JP-1){
6920: S[JP]++;
6921: }else{
6922: S[JT+1]+=S[JP]+1;
6923: S[JP]=0;
6924: }
6925: }
6926: I=0;
6927: }
6928: return Coef;
6929: }
6930:
6931: def prehombf(P,Q)
6932: {
6933: if((Mem=getopt(mem))!=1 && Mem!=-1)
6934: return prehombfold(P,Q);
6935: if(Q==0) Q=P;
6936: V=ltov(vars(P));
6937: N=length(V);
6938: for(I=1;I<N;I++){ /* sorted by required degrees */
6939: for(K=mydeg(P,V[I]),K1=V[I],J=I-1; J>=0 && mydeg(P,V[J])<K; J--);
6940: for(II=I-1;II>J;II--) V[II+1]=V[II];
6941: V[II+1]=K1;
6942: }
6943: S=newvect(N);T=newvect(N);U=newvect(N);
6944: for(R=P,M=1,Deg=I=0;I<N;I++){ /* extreme vector */
6945: Deg+=(S[I]=mydeg(R,V[I]));
6946: R=mycoef(R,S[I],V[I]);
6947: }
6948: DR=[[-1,0]];
6949: if((R1=N/Deg)!=1){
6950: DR=cons([-R1,0],DR);
6951: Sft=1;
6952: }else Sft=0;
6953: if(Deg%2==0) Sg=1;
6954: else Sg=-1;
6955: for(I=0,R=R2=1,QQ=Q; 2*I+Sft < Deg; I++){
6956: if(Mem==-1){
6957: print(I+1,0);print("/",0);print(idiv(Deg-Sft+1,2),0);print(" ",2);
6958: }
6959: Coef=0;
6960: Q=QQ;
6961: while(Q!=0){
6962: for(R=Q,J=0,RR=1;J<N;J++){
6963: T[J]=mydeg(R,V[J]);
6964: R=mycoef(R,T[J],V[J]);
6965: if(T[J]>0) RR*=V[J]^T[J];
6966: }
6967: Q-=R*RR;
6968: for(J=0,CC=R;J<N;J++){
6969: U[J]=I*S[J]+T[J];
6970: for(II=0; II<T[J]; II++)
6971: CC*=(U[J]-II);
6972: }
6973: CC*=pcoef(P,I+1,[V,U]);
6974: if(Mem==-1) print("*",2);
6975: Coef+=CC;
6976: }
6977: DR=cons([I,Coef],DR);
6978: DR=cons([-R1-1-I,Sg*Coef],DR);
6979: if(Mem==-1) print("");
6980: }
6981: P = polbyvalue(DR,s);
6982: return fctr(P);
6983: }
6984:
6985: def prehombfold(P,Q)
6986: {
6987: V = vars(P);
6988: if(Q==0) Q=P;
6989: for(Deg=0, R=P, V1=V, DD=[]; V1!=[]; V1=cdr(V1)){
6990: VT = car(V1);
6991: D = mydeg(R,VT);
6992: R = mycoef(R,D,VT);
6993: Deg += D;
6994: X = makev(["d",VT]);
6995: Q = subst(Q,VT,X);
6996: DD=cons([VT,X],DD);
6997: }
6998: DR=[[-1,0]];
6999: NV=length(V);
7000: if((R1=NV/Deg)!=1){
7001: DR=cons([-R1,0],DR);
7002: Sft=1;
7003: }else
7004: Sft=0;
7005: if(Deg%2==0)
7006: Sg=1;
7007: else Sg=-1;
7008: for(I = 0, R=R2=1; 2*I+Sft < Deg; I++){
7009: R = R2;
7010: R2 = R*P;
7011: S = appldo(Q,R2,DD);
7012: QQ = sdiv(S,R);
7013: DR=cons([I,QQ],DR);
7014: DR=cons([-R1-1-I,Sg*QQ],DR);
7015: }
7016: P = polbyvalue(DR,s);
7017: return fctr(P);
7018: }
7019:
7020: def sub3e(P0,P1,P2,N0,N1,N)
7021: {
7022: R = x^N0*(x-1)^N1*dx^N;
7023: for(V = I = 1, J = 1; I <= N; I++){
7024: S = 0;
7025: M = N-I;
7026: if(I <= N0){
7027: T = mycoef(P0,N0-I,x);
7028: S += T;
7029: R += T*x^(N0-I)*(x-1)^N1*dx^M;
7030: K1 = N0-I+1;
7031: }else
7032: K1 = 0;
7033: if(I <= N1){
7034: T = mycoef(P1,N1-I,x);
7035: S += T;
7036: R += T*x^N0*(x-1)^(N1-I)*dx^M;
7037: K2 = N0-1;
7038: }else
7039: K2 = N-I;
7040: for(K = K1; K <= K2; K++){
7041: if(K == K2){
7042: R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(M-K)*dx^M;
7043: continue;
7044: }
7045: R += strtov("r"+rtostr(V))*x^K*(x-1)^(M-K)*dx^M;
7046: S += strtov("r"+rtostr(V++));
7047: }
7048: }
7049: if(V > 1)
7050: mycat([V-1, "accessory parameters: r1,r2,..."]);
7051: return R;
7052: }
7053:
7054: def fuchs3e(P,Q,R)
7055: {
7056: return getbygrs([R,P,Q],3);
7057: }
7058:
7059: def okubo3e(P,Q,R)
7060: {
7061: if(getopt(opt)==1){
7062: N=length(R);
7063: M1=N-length(P);M2=N-length(Q);
7064: V=(M1-1)*(M2-1);
7065: if(V>0) mycat([V, "accessory parameters"]);
7066: return getbygrs([R,cons([M1,0],P),cons([M2,0],Q)],3);
7067: }
7068: S = 0;
7069: V = -1;
7070: L = newvect(3,[[],[],[]]);
7071: N = newvect(3,[0,0,0]);
7072: if(type(R) < 4){
7073: I = -1;
7074: V = 3;
7075: }else{
7076: I = 2;
7077: V = -1;
7078: }
7079: for( ; I >= 0; I--){
7080: if(I == 2)
7081: U = R;
7082: else if(I == 1)
7083: U = Q;
7084: else
7085: U = P;
7086: for( ; length(U); U = cdr(U)){
7087: T = car(U);
7088: if( T == "?"){
7089: if(V < 0)
7090: V = I;
7091: else
7092: return 0;
7093: }else{
7094: if(I == 2)
7095: L[I] = cons(-T, L[I]);
7096: else
7097: L[I] = cons(T, L[I]);
7098: S += T;
7099: }
7100: N[I]++;
7101: }
7102: }
7103: if(V == 3){
7104: N[2] = N[0] + N[1];
7105: P2 = x^N;
7106: for(I = 1; I <= N; I++)
7107: P2 += makev([R,I])*x^(N-I);
7108: }else{
7109: if(N[0]+N[1] != N[2]){
7110: print("Number of exponents are wrong",0);
7111: return -1;
7112: }
7113: S -= N[0]*N[1];
7114: if(V < 0){
7115: if(S != 0){
7116: mycat(["Viorate Fuchs relation ->",S]);
7117: return -2;
7118: }
7119: }else{
7120: if(V != 2)
7121: S = -S;
7122: L[V] = cons(S, L[V]);
7123: }
7124: P2 = polinsft(polbyroot(L[2],x),x);
7125: }
7126: P0 = polinsft(mysubst(polbyroot(L[0],x),[x,x+N[1]]),x);
7127: P1 = polinsft(mysubst(polbyroot(L[1],x),[x,x+N[0]]),x);
7128: return sub3e(P0,P1,P2,N[0],N[1],N[2]);
7129: }
7130:
7131: /* N = 2*M (N-M = M) or 2*M+1 (N-M = M+1)
7132: 0 : 0 1 ..... M-1 B B+1 ... B+N-M-2 A
7133: 1 : C C+1 ... C+M-1 0 1 .... N-M-2 N-M-1
7134: */
7135: def eosub(A,B,C,N)
7136: {
7137: M = N%2;
7138: P = [];
7139: Q = [];
7140: P = cons(A,P);
7141: for(I = 0; I < N-M-1; I++)
7142: P = cons(B+I,P);
7143: for(I = 0; I < M; I++)
7144: Q = cons(C+I,Q);
7145: P = okubo3e(P,Q,s);
7146:
7147: C = newvect(2);
7148: L = newvect(2);
7149: C[1] = chkexp(P,[x,dx],0,b,N-M-1);
7150: C[0] = chkexp(P,[x,dx],1,c,M);
7151: for(LL = K = 0; K < 2; K++){
7152: L[K] = length(C[K]);
7153: C[K] = ltov(C[K]);
7154: if(L[K] > LL)
7155: LL = L[K];
7156: }
7157: JJ = 0;
7158:
7159: for(I = 1; Do; I++){
7160: Do = 0;
7161: S = makev(["r",I]);
7162: for(J = JJ; J < LL; J++){
7163: JJ = LL;
7164: for(K = 0; K < 2; K++){
7165: if(J >= L[K] || C[K][J] == 0)
7166: continue;
7167: if(J < JJ)
7168: JJ = J;
7169: if(Do == 1){
7170: CC = C[K];
7171: CC[J] = mysubst(CC[J], [S, Var]);
7172: continue;
7173: }
7174: if(mydeg(C[K][J]) >= 1){
7175: if(mydeg(C[K][J]) > 1){
7176: print("Internal error");
7177: return;
7178: }
7179: Var = getroot(C[K][J],S);
7180: Var = Var[0];
7181: CC = C[K];
7182: CC[J] = 0;
7183: P = mysubst(P, [S, Var]);
7184: Do = 1;
7185: J = JJ - 1;
7186: K++;
7187: }
7188: }
7189: }
7190: }
7191: if(JJ != L){
7192: print("Internal error (non Rigid)");
7193: return;
7194: }
7195: return P;
7196: }
7197:
7198: def even4e(X,Y){
7199: if(length(X) != 4 || length(Y) != 2){
7200: print("Usage: even4e([a,b,c,d],[e,f])");
7201: print("0: 0 1 e f");
7202: print("1; 0 1 * *+1");
7203: print("infty: a b c d");
7204: return;
7205: }
7206: S = -3;
7207: for(I = 0; I < 4; I++){
7208: S += X[I];
7209: if(I < 2)
7210: S += Y[I];
7211: }
7212: S = -S/2;
7213: P = okubo3e(Y,[S,"?"],X);
7214: T = chkexp(P,x,1,S,2);
7215: T = getroot(T[0],r1);
7216: return mysubst(P,[r1,T[0]]);
7217: }
7218:
7219: def odd5e(X,Y)
7220: {
7221: if(length(X) != 5 || length(Y) != 2){
7222: print("Usage: spec6e([a,b,c,d,e],[f,g])");
7223: print("0: 0 1 f g g+1");
7224: print("1: 0 1 2 * *+1");
7225: print("infty: a b c d e");
7226: return;
7227: }
7228: S = -4;
7229: for(I = 0; I < 5; I++){
7230: S += X[I];
7231: if(I < 2)
7232: S += Y[I];
7233: }
7234: S = -(S + Y[1])/2;
7235: P = okubo3e([Y[0],Y[1],Y[1]+1],[S,"?"],X);
7236: T = chkexp(P,x,1,S,2);
7237: T = getroot(T[0],r1);
7238: P = mysubst(P,[r1,T[0]]);
7239: T = chkexp(P,x,0,Y[1],2);
7240: T = getroot(T[0],r2);
7241: return mysubst(P,[r2,T[0]]);
7242: }
7243:
7244: def extra6e(X,Y)
7245: {
7246: if(length(X) != 6 || length(Y) != 2){
7247: print("Usage: extra6e([a,b,c,d,e,f],[g,h])");
7248: print("0: 0 1 g g+1 h h+1");
7249: print("1: 0 1 2 3 * *+1");
7250: print("infty: a b c d e f");
7251: return;
7252: }
7253: S = -5;
7254: for(I = 0; I < 6; I++){
7255: S += X[I];
7256: if(I < 2)
7257: S += 2*Y[I];
7258: }
7259: S = -S/2;
7260: P = okubo3e([Y[0],Y[0]+1,Y[1],Y[1]+1],[S,"?"],X);
7261: T = chkexp(P,x,1,S,2);
7262: T = getroot(T[0],r1);
7263: P = mysubst(P,[r1,T[0]]);
7264: T = chkexp(P,x,0,Y[0],2);
7265: T = getroot(T[0],r3);
7266: P = mysubst(P,[r3,T[0]]);
7267: T = chkexp(P,x,0,Y[1],2);
7268: T = getroot(T[0],r2);
7269: return mysubst(P,[r2,T[0]]);
7270: }
7271:
7272: def rigid211(X,Y,Z)
7273: {
7274: if(length(X) != 2 || length(Y) != 2 || length(Z) != 2){
7275: print("Usage: rigid211([a,b],[c,d],[e,f])");
7276: print("0: 0 1 a b");
7277: print("1: 0 1 c d");
7278: print("infty: e e+1 f *");
7279: return;
7280: }
7281: P = okubo3e(X,Y,[Z[0],Z[0]+1,Z[1],"?"]);
7282: T = chkexp(P,x,"infty",Z[0],2);
7283: T = getroot(T[0],r1);
7284: return mysubst(P,[r1,T[0]]);
7285: }
7286:
7287: def solpokuboe(P,L,N)
7288: {
7289: if(type(N) > 1 || ntype(N) != 0 || dn(N) != 1){
7290: mycat(["Irrigal argument :", N]);
7291: return 0;
7292: }
7293: L = vweyl(L);
7294: DD=N+1;
7295: for(U = S = L[0]^N; U != 0; ){
7296: D = mydeg(U,L[0]);
7297: if(D>=DD){
7298: mycat(["Internal Error",D,DD]);
7299: return -1;
7300: }
7301: DD=D;
7302: UU = L[0]^D;
7303: R = appldo(P,UU,L);
7304: if(mydeg(R,L[0]) > D){
7305: printf("Bad operator\n");
7306: return 0;
7307: }
7308: CC = mycoef(R,D,L[0]);
7309: if(D == N){
7310: P -= (E = CC);
7311: U = R-E*U;
7312: continue;
7313: }
7314: if(CC == 0){
7315: printf("No polynomial\n");
7316: return 0;
7317: }
7318: CC= mycoef(U,D,L[0])/CC;
7319: S = red(S - UU*CC);
7320: U = red(U - R*CC);
7321: }
7322: return [nm(S),E];
7323: }
7324:
7325: def stoe(M,L,N)
7326: {
7327: L = vweyl(L);
7328: Size = size(M);
7329: S = Size[0];
7330: NN = 0;
7331: if(type(N) == 4){
7332: NN=N[0]; N=N[1];
7333: }else if(N < 0){
7334: NN=-N; N=0;
7335: }
7336: if(S != Size[1] || N >= S || NN >= S)
7337: return;
7338: D = newmat(S+1,S+1);
7339: MN = dupmat(M);
7340: MD = newmat(S,S);
7341: DD = D[0];
7342: DD[N] = 1; DD[S] = 1;
7343: for(Lcm = I = 1; ; ){
7344: DD = D[I];
7345: MM = MN[N];
7346: for(J = 0; J < S; J++){
7347: DD[J] = MM[J];
7348: Lcm = lcm(dn(DD[J]),Lcm);
7349: }
7350: DD[S] = L[1]^I;
7351: for(J = 0; J <= S; J++)
7352: DD[J] = red(DD[J]*Lcm);
7353: if(I++ >= S)
7354: break;
7355: if(I==S && NN>0){
7356: DD = D[I];
7357: DD[0]=-z_zz; DD[NN]=1;
7358: break;
7359: }
7360: Mm = dupmat(MN*M);
7361: for(J = 0; J < S; J++){
7362: for(K = 0; K < S; K++)
7363: MN[J][K] = red(diff(MN[J][K],L[0])+Mm[J][K]);
7364: }
7365: }
7366: #if 0
7367: P = fctr(mydet2(D));
7368: #else
7369: P = fctr(det(D));
7370: #endif
7371: for(I = R = 1; I < length(P); I++){
7372: if(mydeg(P[I][0],L[1]) > 0)
7373: R *= P[I][0]^P[I][1];
7374: }
7375: if(NN > 0)
7376: R = -red(coef(R,0,z_zz)/coef(R,1,z_zz));
7377: return R;
7378: }
7379:
7380: def dform(L,X)
7381: {
7382: if(type(X)==2) X=[X];
7383: if(type(L[0])!=4) L=[L];
7384: if(type(X)==4) X=ltov(X);
7385: M=length(X);
7386: if(length(car(L))==2){
7387: R=newvect(M);
7388: for(LL=L; LL!=[]; LL=cdr(LL)){
7389: for(I=0; I<M; I++){
7390: RT=rmul(car(LL)[0],mydiff(car(LL)[1],X[I]));
7391: R[I] = (R[I]==0)?RT:radd(R[I],RT);
7392: }
7393: }
7394: Dif=getopt(dif);
7395: for(RR=[], I=M-1; I>=0; I--){
7396: if(Dif==1) RR=cons([1,R[I],X[I]],RR);
7397: else RR=cons([R[I],X[I]],RR);
7398: }
7399: if(Dif==1) RR=dform(RR,X);
7400: return RR;
7401: }else if(length(car(L))!=3) return L;
7402: N=M*(M-1)/2;
7403: R=newvect(N);
7404: S=newvect(N);
7405: for(LL=L; LL!=[]; LL=cdr(LL)){
7406: for(I=K=0; I<M; I++){
7407: for(J=I+1; J<M; J++, K++){
7408: if(LL==L) S[K]=[X[I],X[J]];
7409: LT=car(LL);
7410: R1=mydiff(LT[2],X[J]);
7411: R2=mydiff(-LT[2],X[I]);
7412: if(R2==0){
7413: if(R1==0) continue;
7414: R1=rmul(mydiff(LT[1],X[I]),R1);
7415: }else if(R1==0){
7416: R1=rmul(mydiff(LT[1],X[J]),R2);
7417: }else
7418: R1=rmul(mydiff(LT[1],X[I]),R1)+rmul(mydiff(LT[1],X[J]),R2);
7419: R1=rmul(LT[0],R1);
7420: R[K] = (R[K]==0)?R1:radd(R[K],R1);
7421: }
7422: }
7423: }
7424: for(RR=[],I=N-1; I>=0; I--)
7425: RR=cons([R[I],S[I][0],S[I][1]],RR);
7426: return RR;
7427: }
7428:
7429: def polinvsym(P,Q,Sym)
7430: {
7431: N = length(Q);
7432: T = polbyroot(Q,zz);
7433: for(I = 1; I <= N; I++){
7434: P = mysubst(P,[makev([Sym,I]), (-1)^I*coef(T,N-I,zz)]);
7435: }
7436: return P;
7437: }
7438:
7439: def polinsym(P,Q,Sym)
7440: {
7441: if(type(P) == 3){
7442: P = red(P);
7443: if(type(P) == 3){
7444: D = polinsym(dn(P),Q,Sym);
7445: if(D == 0)
7446: return 0;
7447: return polinsym(nm(P),Q,Sym)/D;
7448: }
7449: }
7450: N = length(Q);
7451: V = newvect(N+1);
7452: S = newvect(N+1);
7453: E = newvect(N+1);
7454: E0 = newvect(N+1);
7455: T = polbyroot(Q,zzz);
7456: for(J = 1; J <= N; J++){
7457: K = coef(T,N-J,zzz);
7458: if(J % 2)
7459: K = -K;
7460: S[J] = K;
7461: V[J] = makev([Sym,J]);
7462: }
7463: K = deg(P,Q[0]);
7464: for(J = 0; J <= N; J++)
7465: E0[J] = K+1;
7466: E[0] = K+1;
7467: while(deg(P,Q[0]) > 0){
7468: for(P0 = P, J = 1; J <= N; J++){
7469: E[J] = deg(P0,Q[J-1]);
7470: P0 = coef(P0,E[J],Q[J-1]);
7471: }
7472: /* P0*Q[0]^E[1]*Q[1]^E[2]*... E[1] >= E[2} >= ... */
7473: for(J = 1; J <= N; J++){
7474: if(E[J] < E0[J])
7475: break;
7476: if(E[J-1] < E[J])
7477: J = N;
7478: }
7479: if(J > N){
7480: print("Not symmetric");
7481: return 0;
7482: }
7483: for(J = 1; J <= N; J++)
7484: E0[J] = E[J];
7485: for(J = N; J > 1; J--){
7486: if(E[J] != 0)
7487: for(K = 1; K < J; K++)
7488: E[K] -= E[J];
7489: }
7490: for(R0 = P0, K = 1; K <= N; K++){
7491: if(E[K] > 0)
7492: P0 *= S[K]^E[K];
7493: R0 *= V[K]^E[K];
7494: }
7495: P += R0 - P0;
7496: }
7497: return P;
7498: }
7499:
7500: def tohomog(P,L,V)
7501: {
7502: while(length(L)>0){
7503: P = mysubst(P,[car(L),car(L)/V]);
7504: L = cdr(L);
7505: }
7506: P = red(P);
7507: N = mindeg(dn(P),V);
7508: if(N > 0)
7509: P = red(P*V^N);
7510: N = mindeg(dn(P),V);
7511: if(N > 0)
7512: P = red(P/(V^N));
7513: return P;
7514: }
7515:
7516: def substblock(P,X,Q,Y)
7517: {
7518: P = red(P);
7519: if(deg(dn(P),X) > 0)
7520: return substblock(nm(P),X,Q,Y)/substblock(dn(P),X,Q,Y);
7521: N = mydeg(Q,X);
7522: if(N < 1)
7523: return P;
7524: R = mycoef(Q,N,X);
7525: while(M = mydeg(P,X), M >= N)
7526: P = red(P - mycoef(P,M,X)*(Q-Y)*X^(M-N)/R);
7527: return P;
7528: }
7529:
7530: def okuboetos(P,L)
7531: {
7532: L = vweyl(L); X = L[0]; DX = L[1];
7533: N = mydeg(P,DX);
7534: C = mycoef(P,N,DX);
7535: K = mydeg(C,X);
7536: if(K > N){
7537: print("Irregular singularity at infinity")$
7538: return 0;
7539: }
7540: if(N > K)
7541: P *= x^(N-K);
7542:
7543: L = getroot(mycoef(P,N,DX),x);
7544: L = ltov(reverse(L));
7545: if(length(L) != N || N == 0){
7546: print("Cannot get exponents")$
7547: return 0;
7548: }
7549: if( type(LL = getopt(diag)) == 4 ){
7550: LL = ltov(LL);
7551: if(length(LL) != N){
7552: mycat(["Length of the option should be", N]);
7553: return 0;
7554: }
7555: Tmp = newvect(N);
7556: for(I = N-1; I >= 0; I--){
7557: for(LLT = LL[I], J = N-1; J >=0 ; J--){
7558: if(LLT == L[J] && Tmp[J] == 0){
7559: Tmp[J] = 1;
7560: break;
7561: }
7562: }
7563: if(J < 0){
7564: print("option is wrong");
7565: return 0;
7566: }
7567: }
7568: L = LL;
7569: }
7570: P /= mycoef(C,N,X);
7571: A = newmat(N,N);
7572: AT = newmat(N+1,N+1);
7573: Phi= newvect(N+1);
7574: Phi[0] = 1;
7575: for(J = 0; J < N; J++)
7576: Phi[J+1] = Phi[J]*(X-L[J]);
7577: for(ATT = AT[N], J = 0; J < N; J++)
7578: ATT[J] = mycoef(P,J,DX);
7579:
7580: for(K = 1; K <= N; K++){
7581: for(J = N; J >= K; J--){
7582: Aj = A[J-1];
7583: SIG = AT[J][J-K];
7584: for(I = 0; I <= K-2; I++)
7585: SIG += Aj[J-I-1]*AT[J-I-1][J-K];
7586: if(K == 1)
7587: DAT = mydiff(Phi[J-1],X);
7588: else
7589: DAT = mydiff(AT[J-1][J-K],X);
7590: Aj[J-K] = -SIG+(X-L[J-1])*DAT;
7591: Aj[J-K] /= Phi[J-K];
7592: Aj[J-K] = mysubst(Aj[J-K],[X,L[J-1]]);
7593: if(J < K+1) continue;
7594: ATj = AT[J-1];
7595: ATj[J-K-1] = SIG+Aj[J-K]*Phi[J-K];
7596: ATj[J-K-1] /= (X - L[J-1]);
7597: ATj[J-K-1] = red(ATj[J-K-1]-DAT);
7598: }
7599: }
7600:
7601: ATT = newmat(N,N);
7602: for(J = 0; J < N; J++){
7603: for(K = 0; K < N; K++){
7604: ATj = ATT[J];
7605: ATj[K] = AT[J][K];
7606: }
7607: ATj[J] = Phi[J];
7608: if(J < N-1){
7609: ATj = A[J];
7610: ATj[J+1] = 1;
7611: }
7612: }
7613: return [L,A,ATT];
7614: }
7615:
7616: def heun(X,P,R)
7617: {
7618: if(type(X) != 4 || length(X) != 5){
7619: print("Usage: huen([a,b,c,d,e],p,r)");
7620: print("0: 0 c");
7621: print("1: 0 d");
7622: print("p: 0 e");
7623: print("infty: a b");
7624: print("Fuchs relation: a+b+1 = c+d+e");
7625: return;
7626: }
7627: S = 1;
7628: V = -1;
7629: X = ltov(X);
7630: for(I = 0; I < 5; I++){
7631: if(X[I] == "?"){
7632: if(V >= 0)
7633: return;
7634: V = I;
7635: }else if(I < 2){
7636: S += X[I];
7637: }else
7638: S -= X[I];
7639: }
7640: if(V >= 0){
7641: if(V < 2)
7642: X[V] = -S;
7643: else
7644: X[V] = S;
7645: }else if(S != 0){
7646: mycat(["Fuch relation:", S,"should be zero!"]);
7647: return;
7648: }
7649: return
7650: x*(x-1)*(x-P)*dx^2
7651: + (X[2]*(x-1)*(x-P)+X[3]*x*(x-P)+X[4]*x*(x-1))*dx
7652: + X[0]*X[1]*(x-R);
7653: }
7654:
7655: def fspt(M,T)
7656: {
7657: if(type(M)==7) M=s2sp(M);
7658: if(T == 3) /* 3: cut 0 */
7659: return cutgrs(M);
7660: if(T == 4 || T== 5){ /* 4: short 5: long */
7661: for(MN = [] ; M != []; M = cdr(M)){
7662: MT = car(M);
7663: for(MNT = []; MT != []; MT = cdr(MT)){
7664: if(type(car(MT)) <= 3){
7665: if(T == 4) MNT = cons(car(MT),MNT);
7666: else MNT = cons([1,car(MT)],MNT);
7667: }else{
7668: if(T == 5 || car(MT)[0] > 1) MNT = cons(car(MT),MNT);
7669: else if(car(MT)[0] == 1) MNT = cons(car(MT)[1],MNT);
7670: }
7671: }
7672: MN = cons(reverse(MNT), MN);
7673: }
7674: return reverse(MN);
7675: }
7676: if(type(M[0][0]) == 4){
7677: for(MN = [] ; M != []; M = cdr(M)){
7678: MT = car(M);
7679: for(MNT = []; MT != []; MT = cdr(MT))
7680: MNT = cons(car(MT)[0], MNT);
7681: MN = cons(reverse(MNT), MN);
7682: }
7683: return fspt(reverse(MN),T);
7684: }
7685: if(T == 0) /* 0: sp */
7686: return M;
7687: for(MN = [] ; M != []; M = cdr(M)){
7688: MT = qsort(ltov(car(M)));
7689: L = length(MT);
7690: for(MNT = [], I = 0; I < L; I++)
7691: MNT = cons(MT[I], MNT);
7692: MN = cons(MNT, MN);
7693: }
7694: MN = reverse(MN);
7695: if(T==6) return MN; /* 7: sort */
7696: L = length(MN);
7697: for(M = MN; M != []; M = cdr(M)){
7698: for(I = 0, MT = car(M); MT != []; MT = cdr(MT))
7699: I += car(MT);
7700: if(OD == 0)
7701: OD = I;
7702: else if(OD != I || OD == 0)
7703: return 0;
7704: }
7705: ALL = [MN];
7706: RD=[];
7707: while(OD > 0){
7708: for(S = 0, MT = MN; MT != []; MT = cdr(MT))
7709: S += car(MT)[0];
7710: S -= (L-2)*OD;
7711: if(S <= 0){
7712: if(T==7) return [ALL[0],ALL[length(ALL)-1],RD];
7713: return (T==1)?MN:ALL;
7714: }
7715: RD=cons([S,0,0],RD);
7716: for(NP=0, M = [], MT = MN; MT != []; NP++, MT = cdr(MT)){
7717: MTT = car(MT);
7718: I = MTT[0] - S;
7719: if(I < 0){
7720: if(I+OD!=0) return 0;
7721: if(T==7) return [ALL[0],ALL[length(ALL)-1],cdr(RD)];
7722: return (T==1)?MN:ALL;
7723: }
7724: MTT = cdr(MTT);
7725: NC=1; DO=0;
7726: for(MNT = []; MTT != []; MTT = cdr(MTT)){
7727: if(MTT[0] > I){
7728: if(DO==0) RD=cons([MTT[0]-I,NP,NC++],RD);
7729: MNT = cons(MTT[0], MNT);
7730: }
7731: else if(MTT[0] <= I && I != 0){
7732: DO=1;
7733: MNT = cons(I, MNT);
7734: I = 0;
7735: if(MTT[0] > 0)
7736: MNT = cons(MTT[0], MNT);
7737: }
7738: }
7739: if(I > 0)
7740: MNT = cons(I,MNT);
7741: M = cons(reverse(MNT), M);
7742: }
7743: MN = reverse(M);
7744: ALL = cons(MN,ALL);
7745: OD -= S;
7746: }
7747: }
7748:
7749: def abs(X)
7750: {
7751: if(vars(X)!=[]) return todf(os_md.abs,[X]);
7752: if(type(X)==4){
7753: P=X[1];X=X[0];
7754: }else P=0;
7755: if(type(X)==1){
7756: if((T=ntype(X))<2 || T==3){
7757: if(X<0) X=-X;
7758: }else if(T==4) X=P?pari(abs,X,P):pari(abs,X);
7759: }
7760: return X;
7761: }
7762:
1.20 takayama 7763: def sgn(X)
7764: {
7765: if(X==0) return 0;
7766: if(type(X)==1){
7767: return (X>0)?1:-1;
7768: }
7769: if(type(X)==5) X=vtol(X);
7770: if(type(X)==4){
7771: for(W=0,Y=X;Y!=[];Y=cdr(Y))
7772: for(Z=cdr(Y);Z!=[];Z=cdr(Z))
7773: if(car(Y)>car(Z)) W++;
7774: if(getopt(val)==1) return W;
7775: return (iand(W,1))?-1:1;
7776: }
7777: }
7778:
1.6 takayama 7779: def calc(X,L)
7780: {
1.10 takayama 7781: if(type(X)<4||type(X)==7){
7782: if(type(L)==4||type(L)==7){
1.6 takayama 7783: V=L[1];
1.10 takayama 7784: if(type(X)!=7){
7785: if((L0=L[0])=="+") X+=V;
7786: else if(L0=="-") X-=V;
7787: else if(L0=="*") X*=V;
7788: else if(L0=="/") X/=V;
7789: else if(L0=="^") X^=V;
7790: }
7791: if((L0=L[0])==">") X=(X>V);
7792: else if(L0=="<") X=(X<V);
7793: else if(L0=="=") X=(X==V);
1.6 takayama 7794: else if(L0==">=") X=(X>=V);
7795: else if(L0=="<=") X=(X<=V);
7796: else if(L0=="!=") X=(X!=V);
1.10 takayama 7797: }else if(type(L)==7&&type(X)<4){
1.6 takayama 7798: if(L=="neg") X=-X;
7799: else if(L=="abs") X=abs(X);
7800: else if(L=="neg") X=-X;
7801: else if(L=="sqr") X*=X;
7802: else if(L=="inv") X=1/X;
7803: else if(L=="sgn"){
7804: if(X>0)X=1;
7805: else if(X<0) X=-1;
7806: }
7807: }
7808: }
7809: return X;
7810: }
7811:
1.23 takayama 7812: def tobig(X)
7813: {
7814: if((type(X)==1 && ntype(X)==3)||type(X)>3) return X;
7815: return eval(X*exp(0));
7816: }
7817:
1.6 takayama 7818: def isint(X)
7819: {
7820: if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1;
7821: return 0;
7822: }
7823:
7824: def israt(X)
7825: {
7826: if(X==0||(type(X)==1 && ntype(X)==0)) return 1;
7827: return 0;
7828: }
7829:
7830: def iscrat(X)
7831: {
7832: if(X==0 || (type(X)==1 && israt(real(X)) && israt(imag(X)))) return 1;
7833: return 0;
7834: }
7835:
7836: def isalpha(X)
7837: {
7838: return ((X>64&&X<91)||(X>96&&X<123))?1:0;
7839: }
7840:
7841: def isnum(X)
7842: {
7843: return (X>47&&X<58)?1:0;
7844: }
7845:
7846: def isalphanum(X)
7847: {
7848: return (isalpha(X)||isnum(X))?1:0;
7849: }
7850:
1.8 takayama 7851: def isdecimal(X)
7852: {
7853: if(type(X)!=7) return 0;
7854: F=S=0;
7855: L=strtoascii(X);
7856: while(L!=[]&&car(L)==32) L=cdr(L);
7857: if(L!=[]&&car(L)==45) L=cdr(L); /* - */
7858: while(L!=[]&&isnum(car(L))){
7859: F=1; L=cdr(L);
7860: }
7861: while(L!=[]&&car(L)<33){
7862: S=1;L=cdr(L);
7863: }
7864: if(L==[]) return F;
7865: else if(S||car(L)!=46) return 0; /* . */
7866: L=cdr(L);F=0;
7867: while(L!=[]&&isnum(car(L))){
7868: F=1; L=cdr(L);
7869: }
7870: while(L!=[]&&car(L)<33) L=cdr(L);
7871: return (L==[])?F:0;
7872: }
7873:
1.6 takayama 7874: def isvar(X)
7875: {
7876: return ([X]==vars(X)&&vtype(X)<3)?1:0;
7877: }
7878:
7879: def isyes(F)
7880: {
7881: if((CC=getopt(set))==1){
7882: IsYes=(type(F[0])==4)?F:[F];
7883: return 1;
7884: }else if(CC==0) return(IsYes);
7885: if(type(CC)!=7)
7886: CC=IsYes;
7887: for(;CC!=[]; CC=cdr(CC)){
7888: C=car(CC);
7889: V=call(C[0],cons(F,C[1]));
7890: if(type(C[2])!=4){
7891: if(V!=C[2]) break;
7892: }else{
7893: if(C[2][0]!="" && V<C[2][0]) break;
7894: if(C[2][1]!="" && V>C[2][1]) break;
7895: }
7896: }
7897: return (CC==[])?1:0;
7898: }
7899:
7900: def isall(FN,M)
7901: {
7902: if(type(M)<4 || type(M)>6) return ((*FN)(M)==0)?0:1;
7903: if(type(M)==4){
7904: for(;M!=[];M=cdr(M))
7905: if((*FN)(car(M))==0) return 0;
7906: }else if(type(M)==5){
7907: K=length(M);
7908: for(I=0;I<K;I++)
7909: if((*FN)(M[I])==0) return 0;
7910: }else if(type(M)==6){
7911: K=size(M)[0];
7912: for(I=0;I<K;I++)
7913: if (isall(FN,M[I])==0) return 0;
7914: }
7915: return 1;
7916: }
7917:
7918: def sproot(MP,T)
7919: {
7920: if((I=str_chr(T,0,","))>0){
7921: if(type(MP)==7) M=s2sp(MP);
7922: else M=chkspt(MP|opt=0);
7923: if(I==length(M[0])){
7924: N=s2sp(T);S=SM=SN=K=0;
7925: for(MM=M,NN=N;MM!=[];MM=cdr(MM),NN=cdr(NN),K++){
7926: for(MT=car(MM),NT=car(NN);MT!=[];MT=cdr(MT),NT=cdr(NT)){
7927: S+=car(MT)*car(NT);
7928: if(K==0){
7929: SM+=car(MT);SN+=car(NT);
7930: }
7931: }
7932: }
7933: return S-(length(M)-2)*SM*SN;
7934: }
7935: }
7936: MM=chkspt(MP|opt=7);
7937: if(T=="base") return MM;
7938: Keep=(getopt(keep)==1)?1:0;
7939: Null=getopt(null);
7940: Only=getopt(only);
7941: if(type(Only)!=1) Only=7;
7942: M0=MM[0];
7943: M1=MM[1];
7944: M=MM[2];
7945: if(T=="length") return length(M);
7946: if(T=="height"){
7947: for(J=2,S=M1[0][0],M2=M1; M2!=[]; M2=cdr(M2)){
7948: for(MT=cdr(car(M2)); MT!=[]; J++, MT=cdr(MT)){
7949: S+= J*car(MT);
7950: }
7951: J=1;
7952: }
7953: return S;
7954: }
7955: for(OD=0, MT=M1[0]; MT!=[]; MT=cdr(MT)) OD+=car(MT);
7956: if(T=="type"){
7957: R=newvect(OD+1);
7958: for(MT=M; MT!=[]; MT=cdr(MT)) R[MT[0][0]]++;
7959: for(RR=[],I=OD; I>0; I--)
7960: if(R[I]>0) RR=cons([R[I],I],RR);
7961: return RR;
7962: }
7963: if(T=="part"||T=="pair"||T=="pairs"){
7964: NP=length(M1);
7965: LM=newvect(NP);
7966: R=newvect(length(M));
7967: for(K=0; K<NP; K++) LM[K]=length(M1[K]);
7968: for(I=0,TM=M; TM!=[]; I++, TM=cdr(TM)){
7969: V=newvect(NP);
7970: for(K=0; K<NP; K++) V[K]=newvect(LM[K]);
7971: TP=car(TM);
7972: if(TP[2]==0){
7973: for(K=0;K<NP;K++) V[K][0]=1;
7974: for(J=0; J<I; J++){
7975: VJ=R[J][1];
7976: for(S=K=0;K<NP;K++) S+=VJ[K][0];
7977: for(OD=0,K=0;K<LM[0];K++) OD+=VJ[0][K];
7978: S-=(NP-2)*OD;
7979: for(K=0;K<NP;K++) VJ[K][0]-=S;
7980: }
7981: }else{
7982: K=TP[1]; P=TP[2];
7983: V[K][P-1]=-1; V[K][P]=1;
7984: for(J=0; J<I; J++){
7985: VJ=R[J][1];
7986: S=VJ[K][P]; VJ[K][P]=VJ[K][P-1]; VJ[K][P-1]=S;
7987: }
7988: }
7989: R[I]=[TP[0],V];
7990: }
7991: if(T=="pair"||T=="pairs"){
7992: MV=ltov(M1);
7993: for(K=0; K<NP; K++) MV[K] = ltov(MV[K]);
7994: for(RR=UU=SS=[],I=0; I<length(M); I++){
7995: V=newvect(NP); W=newvect(NP); U=newvect(NP);
7996: for(K=0; K<NP; K++){
7997: U[K]=newvect(LM[K]); V[K]=newvect(LM[K]); W[K]=newvect(LM[K]);
7998: }
7999: S=R[I][0];
8000: for(K=0; K<NP; K++){
8001: for(Q=J=0; J<LM[K]; J++){
8002: V[K][J] = S*(U[K][J] = R[I][1][K][J]);
8003: Q+=(W[K][J] = MV[K][J] - V[K][J]);
8004: }
8005: }
8006: if(Q>0 && iand(Only,1)==0) continue;
8007: if(Q==0 && iand(Only,2)==0) continue;
8008: if(Q<0 && iand(Only,4)==0) continue;
8009: for(K=0; K<NP; K++){
8010: V[K] = vtol(V[K]); W[K] = vtol(W[K]); U[K]=vtol(U[K]);
8011: }
8012: V=vtol(V); W=vtol(W);U=vtol(U);
8013: if(Q<0) S=-S;
8014: RR = cons([V,W], RR); UU = cons(U,UU); SS=cons(S,SS);
8015: }
8016: RR = reverse(RR); UU=reverse(UU); SS=reverse(SS);
8017: if(getopt(dviout)==1 && (Null!=1 || RR!=[])){
8018: Out=string_to_tb("\\begin{align}\\begin{split}"+s2sp(M1)+"&=");
8019: for(I=0,R=RR, U=UU; R!=[]; I++, R=cdr(R), U=cdr(U)){
8020: if(I>0) str_tb("\\\\\n &=",Out);
8021: if(T=="pairs"){
8022: if((S=SS[I])<0) S=-S;
8023: if(S>1) str_tb([my_tex_form(S),"("],Out);
8024: str_tb(s2sp(car(U)),Out);
8025: if(S>1) str_tb(")",Out);
8026: str_tb(" \\oplus ",Out);
8027: if(SS[I]<0){
8028: #ifdef USEMODULE
8029: str_tb(["-(",s2sp(mtransbys(os_md.abs,car(R)[1],[])),")"],Out);
8030: #else
8031: str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out);
8032: #endif
8033: }else
8034: str_tb(s2sp(car(R)[1]),Out);
8035: }else
8036: str_tb([s2sp(car(R)[0])," \\oplus ",s2sp(car(R)[1])],Out);
8037: }
8038: str_tb("\n\\end{split}\\end{align}",Out);
8039: dviout(str_tb(0,Out)|keep=Keep);
8040: }
8041: return RR;
8042: }
8043: for(I=0; I<length(M); I++){
8044: for(K=0; K<NP; K++) R[I][1][K] = vtol(R[I][1][K]);
8045: R[I] = [R[I][0],vtol(R[I][1])];
8046: }
8047: R = vtol(R);
8048: return [M0,M1,R];
8049: }
8050: }
8051:
8052: def spgen(MO)
8053: {
8054: Eq=(getopt(eq)==1)?1:0;
8055: Sp=getopt(sp);
8056: if(type(Sp)==7) Sp=s2sp(Sp);
8057: St=getopt(str);
8058: LP=getopt(pt);
8059: F=getopt(std);
8060: if(F!=1&&F!=-1) F=0;
8061: if(type(LP)==4){
8062: L0=LP[0]; L1=LP[1];
1.29 takayama 8063: }else if(type(LP)==1){
8064: L0=L1=LP;
1.6 takayama 8065: }else{
8066: L0=0; L1=MO+1;
8067: }
8068: if(MO<=0){
8069: MO=-MO;
8070: if(iand(MO,1)==1) return [];
8071: if(MO>1){
8072: if(isMs()==0) return [];
8073: Cmd="okubo "+rtostr(-MO);
8074: MO/=2;
8075: if(L1>0) Cmd=Cmd+"+"+rtostr(L0)+"-"+rtostr(L1);
8076: else L1=MO+4;
8077: Cmd=Cmd+" B";
8078: Id=getbyshell(Cmd);
8079: if(Id<0) return [];
8080: B=[];
8081: while((S=get_line(Id)) !=0){
8082: P0=str_chr(S,1,":")+1;
8083: if(P0>1){
8084: P1=str_chr(S,P,"\n");
8085: if(P1<0) P1=str_len(S);
8086: B=cons(sub_str(S,P0,P1-1),B);
8087: }
8088: }
1.17 takayama 8089: close_file(Id);
1.6 takayama 8090: }else{
8091: MO/=2;
8092: if(L1<=1) L1=MO+4;
8093: BB=[
8094: ["11,11,11,11","111,111,111","1^4,1^4,22","1^6,222,33"],
8095: ["11,11,11,11,11","1^4,1^4,211","211,22,22,22","1^6,2211,33",
8096: "2211,222,222","22211,2^4,44","2^511,444,66","1^4,22,22,31",
8097: "2^5,3331,55","1^5,1^5,32","1^8,332,44","111,111,21,21","1^5,221,221"],
8098: ["11,11,11,11,11,11","1^4,1^4,1^4","1^4,22,22,22","111,111,111,21",
8099: "1^6,21^4,33","21^4,222,222","221^4,2^4,44","2^41^4,444,66",
8100: "1^5,1^5,311","1^8,3311,44","1^6,222,321","321,33,33,33",
8101: "3321,333,333","33321,3^4,66","3^721,666,99","2^5,3322,55",
8102: "1^6,1^6,42","222,33,33,42","1^a,442,55","1^6,33,33,51",
8103: "222,222,33,51","1^9,333,54","2^7,554,77","1^5,2111,221",
8104: "2^41,333,441","1^7,2221,43","211,211,22,22","2211,2211,222",
8105: "22211,22211,44","1^4,211,22,31","2^411,3331,55","1^4,1^4,31,31",
8106: "22,22,22,31,31","1^7,331,331","2221,2221,331","111,21,21,21,21"],
8107: ["11,11,11,11,11,11,11","111,111,111,111","1^6,1^6,33",
8108: "1^6,222,222","222,33,33,33","1^5,1^5,221",
8109: "1^4,211,22,22","1^4,1^4,22,31","22,22,22,22,31",
8110: "111,111,21,21,21","21^6,2^4,44","2221^6,444,66",
8111: "1^6,222,3111","3111,33,33,33","33111,333,333",
8112: "333111,3^4,66","3^5111,666,99","2^5,33211,55",
8113: "1^8,3221,44","3222,333,333","33222,3^4,66",
8114: "3^4222,666,99","1^6,1^6,411","222,33,33,411",
8115: "1^a,4411,55","2^4,2^4,431","431,44,44,44",
8116: "2^6,4431,66","4431,444,444","44431,4^4,88",
8117: "4^531,888,cc","1^a,433,55","1^7,1^7,52",
8118: "1^c,552,66","3^4,444,552","1^8,2^4,53",
8119: "1^8,44,44,71","3^5,555,771","21^4,2211,222",
8120: "221^4,22211,44","2221^4,3331,55","1^6,2211,321",
8121: "2^411,3322,55","1^7,322,331","2211,33,33,42",
8122: "3^42,4442,77","2211,222,33,51","3^51,5551,88",
8123: "2^611,554,77","2221,2221,322","2^41,2^41,54",
8124: "1^5,2111,2111","222111,333,441","1^7,22111,43",
8125: "1^5,1^5,41,41","1^9,441,441","22111,2221,331",
8126: "1^5,221,32,41","221,221,221,41","211,211,211,22",
8127: "2211,2211,2211","1^4,211,211,31","211,22,22,31,31",
8128: "1^4,22,31,31,31","1^5,32,32,32","221,221,32,32","21,21,21,21,21,21"],
8129: ["11,11,11,11,11,11,11,11","1^4,1^4,22,22","1^8,2^4,44",
8130: "1^6,2211,222","2211,33,33,33","111,111,111,21,21",
8131: "1^5,1^5,2111","1^4,211,211,22","1^4,1^4,211,31",
8132: "211,22,22,22,31","1^4,22,22,31,31","111,21,21,21,21,21",
8133: "221^8,444,66","2^5,331^4,55","1^8,32111,44",
8134: "32211,333,333","332211,3^4,66","3^42211,666,99",
8135: "2^5,32221,55","1^7,1^7,511","1^c,5511,66",
8136: "3^4,444,5511","541,55,55,55","5541,555,555",
8137: "55541,5^4,aa","5^541,aaa,ff","1^8,1^8,62",
8138: "1^a1^4,662,77","1^a,55,55,91","2^71,555,87",
8139: "21^6,22211,44","221^6,3331,55","1^6,2211,3111",
8140: "2^411,33211,55","1^7,3211,331","2211,33,33,411",
8141: "3^42,44411,77","22211,2^4,431","2^511,4431,66",
8142: "1^8,332,431","3^42,4433,77","1^8,22211,53",
8143: "2221,2221,3211","221^5,333,441","1^7,21^5,43",
8144: "1^b,443,65","21^5,2221,331","2^51,3332,65",
8145: "21^4,21^4,222","221^4,221^4,44","1^6,21^4,321",
8146: "2221^4,3322,55","21^4,33,33,42","21^4,222,33,51",
8147: "2^51^4,554,77","2^4,3311,3311","3^411,4442,77",
8148: "321,321,33,33","3321,3321,333","33321,33321,66",
8149: "222,321,33,42","1^6,321,33,51","222,222,321,51",
8150: "1^9,3321,54","1^7,322,322","3^422,5551,88",
8151: "1^6,33,42,42","1^6,222,42,51","33,33,33,42,51",
8152: "1^6,1^6,51,51","222,33,33,51,51","1^b,551,551",
8153: "1^5,221,311,41","2^41,3321,441","22111,2221,322",
8154: "2^51,443,551","222111,2^41,54","21^4,2211,2211",
8155: "1^5,311,32,32","3331,3331,442","2211,2211,33,51",
8156: "221,221,311,32","22111,22111,331","1^5,2111,32,41",
8157: "2111,221,221,41","2111,221,32,32","211,211,211,211",
8158: "211,211,22,31,31","1^4,211,31,31,31","22,22,31,31,31,31"],
8159: ["11,11,11,11,11,11,11,11,11","1^5,1^5,1^5","2^5,2^5,55",
8160: "111,111,111,111,21","2^41,333,333","1^4,1^4,211,22",
8161: "211,22,22,22,22","1^8,22211,44","1^4,1^4,1^4,31",
8162: "1^4,22,22,22,31","1^7,1^7,43","1^7,2221,331",
8163: "2221,2221,2221","1^6,21^4,222","21^4,33,33,33",
8164: "1^6,1^6,321","222,321,33,33","1^6,33,33,42",
8165: "222,222,33,42","1^6,222,33,51","222,222,222,51",
8166: "33,33,33,33,51","1^6,2211,2211","111,111,21,21,21,21",
8167: "1^5,1^5,32,41","1^5,221,221,41","1^5,221,32,32",
8168: "221,221,221,32","1^4,211,211,211","211,211,22,22,31",
8169: "1^4,211,22,31,31","1^4,1^4,31,31,31","22,22,22,31,31,31",
8170: "21,21,21,21,21,21,21","21^a,444,66","1^8,31^5,44",
8171: "321^4,333,333","3321^4,3^4,66","3^421^4,666,99",
8172: "2^5,322111,55","32^41,3^4,66","3332^41,666,99",
8173: "1^8,1^8,611","2^4,44,44,611","1^d,6611,77",
8174: "4^5,66611,aa","2^6,444,651","3^4,3^4,651",
8175: "651,66,66,66","3^6,6651,99","6651,666,666",
8176: "66651,6^4,cc","6^551,ccc,ii","2^8,655,88",
8177: "1^9,1^9,72","1^g,772,88","1^c,444,75",
8178: "2^6,3^4,75","1^c,66,66,b1","3^4,444,66,b1",
8179: "3^7,777,ba","1^7,2221,4111","2^41,333,4311",
8180: "1^9,2^41,63","21^8,3331,55","2^411,331^4,55",
8181: "1^7,31^4,331","2^411,32221,55","22211,2^4,422",
8182: "2^511,4422,66","1^8,332,422","2^5,3331,541",
8183: "22211,44,44,62","2^411,2^5,64","2^711,664,88",
8184: "1^a,3331,64","2221,2221,31^4","21^7,333,441",
8185: "333,333,441,81","2^6111,555,87","21^6,221^4,44",
8186: "221^6,3322,55","2^41^6,554,77","1^6,21^4,3111",
8187: "3111,321,33,33","33111,3321,333","333111,33321,66",
8188: "222,3111,33,42","1^6,3111,33,51","222,222,3111,51",
8189: "1^9,33111,54","2221^4,33211,55","1^7,3211,322",
8190: "3^4211,5551,88","2^4,3221,3311","333221,4442,77",
8191: "3222,3321,333","33222,33321,66","1^9,3222,54",
8192: "21^4,33,33,411","3^411,44411,77","222,321,33,411",
8193: "1^6,33,411,42","1^6,222,411,51","33,33,33,411,51",
8194: "221^4,2^4,431","2^41^4,4431,66","1^8,3311,431",
8195: "3^411,4433,77","33321,444,552","1^8,221^4,53",
8196: "3311,44,44,53","4^42,5553,99","2^4,3311,44,71",
8197: "3^421,555,771","4^52,7771,bb","3^611,776,aa",
8198: "2^41,33111,441","22111,2221,3211","2^41,3222,441",
8199: "2^61,4441,76","3331,3331,4411","22211,22211,431",
8200: "3331,3331,433","3^41,3^41,76","1^7,1^7,61,61",
8201: "1^d,661,661","21^5,2221,322","221^5,2^41,54",
8202: "2^51,33311,65","21^5,22111,331","3^41,4441,661",
8203: "1^7,331,43,61","2221,2221,43,61","2221,331,331,61",
8204: "21^4,21^4,2211","21^4,2211,33,51","22211,3311,3311",
8205: "1^5,311,311,32","2211,321,33,42","2211,222,321,51",
8206: "3322,3331,442","2211,222,42,42","2^411,442,442",
8207: "1^6,2211,42,51","2211,33,33,51,51","221,221,311,311",
8208: "1^5,2111,311,41","222111,3321,441","22111,22111,322",
8209: "222111,222111,54","2111,221,311,32","2111,2111,221,41",
8210: "1^5,221,41,41,41","2221,43,43,43","1^5,32,32,41,41",
8211: "331,331,43,43","221,221,32,41,41","221,32,32,32,41",
8212: "211,211,211,31,31","211,22,31,31,31,31","1^4,31,31,31,31,31"]];
8213: B=BB[MO];
8214: }
8215: if(St!=1){
8216: for(R=[]; B!=[]; B=cdr(B)){
8217: RT=F?s2sp(car(B)|std=F):s2sp(car(B));
8218: if(length(RT)<L0 || length(RT)>L1) continue;
8219: R=cons(RT,R);
8220: }
8221: return reverse(R);
8222: }else{
8223: if(L0<=3 && L1>=MO+4) return B;
8224: for(R=[]; B!=[]; B=cdr(B)){
8225: RT=s2sp(T=car(B));
8226: if(length(RT)<L0 || length(RT)>L1) continue;
8227: if(F) T=s2sp(s2sp(T|std=K));
8228: R=cons(T,R);
8229: }
8230: return reverse(R);
8231: }
8232: }
8233: MP=(L1<MO+1)?L1:MO+1;
8234: LL=newvect(MO+1);
8235: R=newvect(MP+2);
8236: R0=newvect(MP+2);
8237: for(I=1; I<=MO; I++) LL[I]=[];
8238: if(type(Sp)==4){
8239: if(getopt(basic)==1) Sp=chkspt(Sp[6]);
8240: R=chkspt(Sp);
8241: if(R[1]>MO) return 0;
8242: LL[R[1]]=R;
8243: K=R[1];
8244: }
8245: if(K==1||type(Sp)!=4){
8246: LL[1]=[[[1]]];
8247: for(I=2; I<=MO && I<MP;I++){
8248: for(T=[], J=0; J<I+1; J++)
8249: T=cons([I-1,1],T);
8250: LL[I]=cons(T,LL[I]);
8251: }
8252: K=2;
8253: }
8254: for(OD=K; OD<MO; OD++){
8255: for(LT=LL[OD]; LT!=[]; LT=cdr(LT)){
8256: for(II=0,L=car(LT); L!=[]; II++, L=cdr(L)){
8257: R0[II]=R[II]=car(L);
8258: }
8259: for(; ;){
8260: for(S=-2*OD, I=0; I<II; I++){
8261: S += OD;
8262: if(R[I]!=[]) S-=car(R[I]);
8263: }
8264: --I;
8265: for(;S+OD<=MO && I<=MP;S+=OD,I++){
8266: if(S<=0) continue;
8267: for(J=0;J<=I;J++){
8268: if(J>=II){
8269: if(S<OD) break;
8270: }else
8271: if(S+((R[J]==[])?0:car(R[J]))<car(R0[J])) break;
8272: }
8273: if(--J>=I){
8274: V=newvect(I);
8275: RRR=[];
8276: for(;J>=0;J--){
8277: if(J>=II) RR=[OD,S];
8278: else{
8279: K=length(R[J]);
8280: RR=[S+((K==0)?0:car(R[J]))];
8281: K=length(R0[J])-K;
8282: for(RT=R0[J]; RT!=[]; K--,RT=cdr(RT)){
8283: if(K!=0) RR=cons(car(RT),RR);
8284: }
8285: }
8286: RRR=cons(reverse(RR),RRR);
8287: }
8288: RRR=qsort(reverse(RRR));
8289: if(findin(RRR,LL[S+OD])<0)
8290: LL[S+OD]=cons(RRR,LL[S+OD]);
8291: }
8292: }
8293: for(K=0; K<II; K++){
8294: if(R[K]!=[]){
8295: S=car(R[K]);
8296: while((R[K]=cdr(R[K]))!=[] && car(R[K])==S);
8297: break;
8298: }else R[K]=R0[K];
8299: }
8300: if(K>=II) break;
8301: }
8302: }
8303: }
8304: if(L0>0 || L1<MO+1 || St==1 || F){
8305: for(J=1; J<=MO; J++){
8306: for(RT=[],R=LL[J];R!=[];R=cdr(R)){
8307: L=length(T=car(R));
8308: if(L<L0 || L>L1) continue;
8309: if(F) T=s2sp(T|std=F);
8310: RT=cons((St==1)?s2sp(T):T,RT);
8311: }
8312: LL[J] = reverse(RT);
8313: }
8314: }
8315: if(Eq==1) return LL[MO];
8316: return LL;
8317: }
8318:
8319: def spType2(L)
8320: {
8321: C=0;R=[];
8322: for(LT=L;LT!=[];LT=cdr(LT)){
8323: D=-1;LP=car(LT);
8324: for(LPT=LP;LPT!=[];LPT=cdr(LPT)){
8325: if(D==-1) D=car(LPT);
8326: else D=igcd(D,car(LPT));
8327: if(D==1){
8328: C++;break;
8329: }
8330: }
8331: if(C==2) return 0;
8332: R=cons(D,R);
8333: }
8334: if(C==0) return L;
8335: if(C==1){
8336: for(K=length(R)-1;R[K]!=1;K--);
8337: D=-1;
8338: for(I=length(R)-1;I>=0;I--){
8339: if(I==K) continue;
8340: if(D==-1) D=R[I];
8341: else D=igcd(D,R[I]);
8342: if(D==1) return 0;
8343: }
8344: }
8345: return L;
8346: }
8347:
8348:
8349: /* ret [#points, order, idx, Fuchs, reduction order, reduction exponents, fund] */
8350: def chkspt(M)
8351: {
8352: Opt= getopt(opt);
8353: Mat= getopt(mat);
8354: if(type(M)==7) M=s2sp(M);
1.28 takayama 8355: if(type(Opt) >= 0&&Opt!="idx"){
1.6 takayama 8356: if(type(Opt) == 7)
8357: Opt = findin(Opt, ["sp","basic","construct","strip","short","long","sort","root"]);
8358: if(Opt < 0){
8359: erno(2);
8360: return 0;
8361: }
8362: return fspt(M,Opt);
8363: }
8364: P = length(M);
8365: OD = -1;
8366: XM = newvect(P);
8367: Fu = 0;
8368: for( I = SM = SSM = 0; I < P; I++ ){
8369: LJ = length(M[I]);
8370: JM = JMV = 0;
8371: for(J = SM = 0; J < LJ; J++){
8372: MV = M[I][J];
8373: if(type(MV) == 4){
8374: Fu += MV[0]*MV[1];
8375: MV = MV[0];
8376: }
8377: if(MV > JMV){
8378: JM = J; JMV = MV;
8379: }
8380: SM += MV;
8381: SSM += MV^2;
8382: }
8383: if(OD < 0)
8384: OD = SM;
8385: else if(OD != SM){
1.28 takayama 8386: if(getopt(dumb)!=1) print("irregal partitions");
8387: return -1;
1.6 takayama 8388: }
8389: XM[I] = JM;
8390: }
8391: SSM -= (P-2)*OD^2;
8392: for(I = SM = JM = 0; I < P; I++){
8393: MV = M[I][XM[I]];
8394: if(type(MV) == 4){
8395: MV = MV[0]; JM = 1;
8396: }
8397: if(I == 0)
8398: SMM = MV;
8399: else if(SMM > MV)
8400: SMM = MV;
8401: SM += MV;
8402: }
8403: SM -= (P-2)*OD;
1.28 takayama 8404: if(Opt=="idx") return SSM;
1.6 takayama 8405: if(SM > SMM && SM != 2*OD){
1.28 takayama 8406: if(getopt(dumb)!=1) print("not realizable");
8407: return 0;
1.6 takayama 8408: }
8409: if(JM==1 && Mat!=1)
8410: Fu -= OD - SSM/2;
1.28 takayama 8411: return [P, OD, SSM, Fu, SM, XM, fspt(M,1)];
1.6 takayama 8412: }
8413:
8414: def cterm(P)
8415: {
8416: V = getopt(var);
8417: if(type(V) != 4)
8418: V=vars(P);
8419: for(; V !=[]; V = cdr(V))
8420: P = mycoef(P,0,car(V));
8421: return P;
8422: }
8423:
8424: def terms(P,L)
8425: {
8426: Lv=getopt(level);
8427: if(type(Lv)!=1) Lv=0;
8428: V=car(L);L=cdr(L);
8429: for(R=[],D=mydeg(P,V);D>=0; D--){
8430: if((Q=mycoef(P,D,V))==0) continue;
8431: if(L!=[]){
8432: R0=terms(Q,L|level=Lv+1);
8433: for(;R0!=[];R0=cdr(R0)) R=cons(cons(D,car(R0)),R);
8434: }else R=cons([D],R);
8435: }
8436: if(Lv>0) return R;
8437: R=qsort(R);
8438: Rev = getopt(rev); Dic=getopt(dic);
8439: if(Dic==1 && Rev==1) R=reverse(R);
8440: for(R0=[];R!=[];R=cdr(R)){
8441: for(RT=car(R),S=0;RT!=[];RT=cdr(RT)) S+=car(RT);
8442: R0=cons(cons(S,car(R)),R0);
8443: }
8444: if(Dic==1) return R0;
8445: if(Rev==1){
8446: for(R=[];R0!=[];R0=cdr(R0)){
8447: T=car(R0);
8448: R=cons(cons(-car(T),cdr(T)),R);
8449: }
8450: R0=R;
8451: }
8452: R0=qsort(R0);
8453: if(Rev==1){
8454: for(R=[];R0!=[];R0=cdr(R0)){
8455: T=car(R0);
8456: R=cons(cons(-car(T),cdr(T)),R);
8457: }
8458: R0=R;
8459: }
8460: return (Rev==1)?R0:reverse(R0);
8461: }
8462:
8463: def polcut(P,N,L)
8464: {
8465: if(type(L)==2) L=[L];
8466: M=getopt(top);
8467: if(type(M)!=1) M=0;
8468: T=terms(P,L);
8469: for(S=0;T!=[];T=cdr(T)){
8470: LT=car(T);
8471: if(LT[0]<M || LT[0]>N) continue;
8472: for(PW=1,LT=cdr(LT),V=L,Q=P;LT!=[];LT=cdr(LT),V=cdr(V)){
8473: Q=mycoef(Q,car(LT),car(V));PW*=car(V)^car(LT);
8474: }
8475: S+=Q*PW;
8476: }
8477: return S;
8478: }
8479:
8480: def redgrs(M)
8481: {
8482: Mat = getopt(mat);
8483: if(Mat!=1) Mat=0;
8484: R = chkspt(M|mat=Mat);
8485: if(type(R) < 4)
8486: return -1;
8487: if(R[4] <= 0)
8488: return 1-R[4];
8489: if(R[4] == 2*R[1])
8490: return 0;
8491: V = newvect(R[0]);
8492: Type = type(M[0][0]);
8493: if(Type > 3){
8494: Mu = Mat-1;
8495: for(I = 0; I < R[0]; I++)
8496: Mu += M[I][R[5][I]][1];
8497: }
8498: for(I = 0; I < R[0]; I++){
8499: IR = R[5][I]; L = []; MI = M[I]; MIE=MI[IR];
8500: for(J = length(MI)-1; J >= 0; J--){
8501: if(Type <= 3){
8502: VM = MI[J];
8503: if(J == IR){
8504: VM -= R[4];
8505: if(VM < 0) return -1;
8506: }
8507: L = cons(VM, L);
8508: }else{
8509: VM = MI[J][0];
8510: if(J == IR){
8511: VM -= R[4];
8512: if(VM < 0)
8513: return -1;
8514: if(I == 0)
8515: EV = 1-Mat-Mu;
8516: else
8517: EV = 0;
8518: }else{
8519: if(I == 0)
8520: EV = MI[J][1] - M[0][R[5][0]][1] + 1-Mat; /* + MX - Mu; */
8521: else
8522: EV = MI[J][1] - MIE[1] + Mu;
8523: }
8524: L = cons([VM,EV], L);
8525: /*
1.24 takayama 8526: if(R[2] >= 2){ */ /* rigid */
1.6 takayama 8527: /* P = dx^(R[1]);
8528: } */
8529: }
8530: }
8531: V[I] = L;
8532: }
8533: return [R[5], vtol(V)];
8534: }
8535:
8536: def cutgrs(A)
8537: {
8538: for(AL=[] ; A!=[]; A=cdr(A)){ /* AT: level 2 */
8539: for(ALT=[], AT=car(A); AT!=[]; AT=cdr(AT)){
8540: M = (type(car(AT)) < 4)?car(AT):car(AT)[0];
8541: if(M > 0)
8542: ALT = cons(car(AT), ALT); /* ALT: level 2 */
8543: }
8544: AL = cons(reverse(ALT), AL); /* AL: level 3 */
8545: }
8546: return reverse(AL);
8547: }
8548:
8549: def mcgrs(G, R)
8550: {
8551: NP = length(G);
8552: Mat = (getopt(mat)==1)?0:1;
1.36 takayama 8553: if(Mat==0 && type(SM=getopt(slm))==4){
1.24 takayama 8554: SM0=SM[0];SM1=anal2sp(SM[1],["*",-1]);
8555: if(findin(0,SM0)>=0){
8556: for(SM=[],I=length(G)-1;I>0;I--)
8557: if(findin(I,SM0)<0) SM=cons(I,SM);
8558: SM=[SM,SM1];
1.36 takayama 8559: G=mcgrs(G,R|mat=1,slm=SM);
1.24 takayama 8560: return [G[0],anal2sp(G[1],["*",-1])];
8561: }
8562: }else SM0=0;
1.6 takayama 8563: for(R = reverse(R) ; R != []; R = cdr(R)){
8564: GN = [];
8565: L = length(G)-1;
8566: RT = car(R);
8567: if(type(RT) == 4){
1.37 takayama 8568: if(length(RT)==L+1&&RT[0]!=0){
8569: R=cons(cdr(RT),cdr(R));
1.24 takayama 8570: R=cons(RT[0],R);
1.37 takayama 8571: R=cons(0,R);
1.24 takayama 8572: continue;
8573: } /* addition */
8574: RT = reverse(RT); S = ADS = 0;
1.37 takayama 8575: for(G = reverse(G); G != []; G = cdr(G), L--, RT=cdr(RT)){
8576: AD = car(RT);
1.24 takayama 8577: if(L > 0){
1.6 takayama 8578: S += AD;
1.24 takayama 8579: if(SM && findin(L,SM0)>=0) ADS+=AD;
8580: }else
1.6 takayama 8581: AD = -S;
8582: for(GTN = [], GT = reverse(car(G)); GT != []; GT = cdr(GT))
8583: GTN = cons([car(GT)[0],car(GT)[1]+AD], GTN);
8584: GN = cons(GTN, GN);
8585: }
8586: G = GN;
1.24 takayama 8587: if(SM0){
8588: for(ST=reverse(SM1),SM1=[]; ST!=[]; ST=cdr(ST))
8589: SM1 = cons([car(ST)[0],car(ST)[1]+ADS], SM1);
8590: }
1.6 takayama 8591: continue;
8592: }
1.24 takayama 8593: if(RT==0) continue;
8594: VP = newvect(L+1); GV = ltov(G); /* middle convolution */
1.6 takayama 8595: for(I = S = OD = 0; I <= L; I++){
8596: RTT = (I==0)?(Mat-RT):0;
8597: VP[I] = -1;
1.24 takayama 8598: for(J = M = K = 0, GT = GV[I]; GT != []; GT = cdr(GT), J++){
1.6 takayama 8599: if(I == 0)
8600: OD += car(GT)[0];
8601: if(car(GT)[1] == RTT && car(GT)[0] > M){
8602: S += car(GT)[0]-M;
1.36 takayama 8603: M=car(GT)[0];
1.6 takayama 8604: VP[I] = J;
8605: }
8606: }
1.24 takayama 8607: }
8608: S -= (L-1)*OD;
8609: for(GN = []; L >= 0; L--){
8610: GT = GV[L];
8611: RTT = (L==0)?(-RT):RT;
1.38 takayama 8612: GTN = (VP[L]>=0 || S == 0)?[]:[[-S,(L==0)?(Mat-RT):0]];
1.24 takayama 8613: for(J = 0; GT != []; GT = cdr(GT), J++){
8614: if(J != VP[L]){
8615: GTN = cons([car(GT)[0],car(GT)[1]+RTT], GTN);
8616: continue;
1.6 takayama 8617: }
1.24 takayama 8618: K = car(GT)[0] - S;
8619: if(K < 0){
8620: print("Not realizable");
8621: return;
8622: }
1.38 takayama 8623: if(K>0) GTN = cons([K,(L==0)?(Mat-RT):0], GTN);
1.24 takayama 8624: }
8625: GN = cons(reverse(GTN), GN);
8626: }
1.36 takayama 8627: if(SM0&&RT!=0){
8628: for(M0=M1=-OD,L=length(G)-1;L>=0;L--){
8629: if(findin(L,SM0)>=0){
8630: M0+=OD;
8631: if(VP[L]>=0) M0-=GV[L][VP[L]][0];
8632: }else{
8633: M1+=OD;
8634: if(VP[L]>=0) M1-=GV[L][VP[L]][0];
8635: }
8636: }
8637: SM2=[];
8638: if((Mx1=anal2sp(SM1,["max",1,-RT])[0])<0){
8639: if(M1>0) SM2=cons([M1,0],SM2);
1.38 takayama 8640: }else M1+=car(SM1[Mx1]);
1.36 takayama 8641: if((Mx0=anal2sp(SM1,["max",1,0])[0])<0){
8642: if(M0>0) SM2=cons([M0,RT],SM2);
1.38 takayama 8643: }else M0+=car(SM1[Mx0]);
1.36 takayama 8644: for(J=0;SM1!=[];J++,SM1=cdr(SM1)){
8645: if(J==Mx0){
8646: if(M0>0) SM2=cons([M0,-RT],SM2);
8647: }else if(J==Mx1){
8648: if(M1>0) SM2=cons([M1,0],SM2);
8649: }else SM2=cons([car(SM1)[0],car(SM1)[1]+RT],SM2);
1.6 takayama 8650: }
1.36 takayama 8651: SM1=reverse(SM2);
1.6 takayama 8652: }
8653: G = cutgrs(GN);
8654: }
1.36 takayama 8655: return SM0?[G,SM1]:G;
1.6 takayama 8656: }
8657:
1.38 takayama 8658: def spslm(M,TT)
8659: {
8660: R=getbygrs(M,1|mat=1);
8661: if(type(R)!=4||type(R[0])!=4||type(S=R[0][1])!=4){
8662: errno(0);return0;
8663: }
8664: if(S[1]!=[[1,0]]){
8665: print("Not rigid!");return0;
8666: }
8667: if((F=S[0][0][1])!=0){
8668: for(V=vars(F);V!=[];V=cdr(V)){
8669: if(mydeg(F,car(V))==1){
8670: T=lsol(F,car(V));
8671: break;
8672: }
8673: }
8674: if(V==[]){
8675: print("Violate Fuchs condition!");
8676: return0;
8677: }
8678: }
8679: for(P=[];R!=[];R=cdr(R))
8680: P=cons(car(R)[0],P);
8681: if(F!=0){
8682: S=mysubst(S,[car(V),T]);P=mysubst(P,[car(V),T]);
8683: }
8684: return mcgrs(S,P|mat=1,slm=[TT,[[1,0]]]);
8685: }
8686:
1.6 takayama 8687: /*
8688: F=0 : unify
8689: F=["add",S] :
8690: F=["sub",S] :
8691: F=["+",A,B] :
8692: F=["*",A,B] :
8693: F=["mul",K];
8694: F=["get",F,V] :
8695: F=["put",F,V] :
8696: F=["get1",F,V] :
8697: F=["put1",F,V] :
1.24 takayama 8698: F=["max"] :
8699: F=["max",F.V] :
1.6 takayama 8700: F=["put1"] :
8701: F=["val",F];
8702: F=["swap"];
8703: */
8704: def anal2sp(R,F)
8705: {
8706: if(type(F)==4&&type(F[0])==4){ /* multiple commands */
8707: for(;F!=[];F=cdr(F)) R=anal2sp(R,car(F));
8708: return R;
8709: }
8710: if(type(F)==7) F=[F];
8711: if(F==0){ /* unify */
8712: R=ltov(R);
8713: L=length(R);
8714: for(J=1;J<L;J++){
8715: for(I=0;I<J;I++){
8716: if(cdr(R[I])==cdr(R[J])){
8717: R[I]=cons(R[I][0]+R[J][0],cdr(R[I]));
8718: R[J]=cons(0,cdr(R[J]));
8719: break;
8720: }
8721: }
8722: }
8723: for(G=[],I=L-1;I>=0;I--)
8724: if(R[I][0]!=0) G=cons(R[I],G);
8725: if(length(G[0])==2){ /* sort by multiplicity */
8726: R=ltov(G);
8727: L=length(R);
8728: for(I=1;I<L;I++){
8729: for(J=I;J>0;J--){
8730: if(R[J-1][0]>R[J][0]) break;
8731: if(R[J-1][0]==R[J][0]){
8732: S1=rtostr(R[J-1][1]);S2=rtostr(R[J][1]);
8733: if((K=str_len(S1)-str_len(S2))<0) break;
8734: if(!K&&S1<S2) break;
8735: }
8736: S=R[J-1];R[J-1]=R[J];R[J]=S;
8737: }
8738: }
8739: G=vtol(R);
8740: }
8741: return G;
8742: }
8743: if(F[0]=="add") return append(R,F[1]);
1.24 takayama 8744: if(F[0]=="max"){
8745: if(length(F)==3) C=1;
8746: else C=0;
8747: M=-10^10;K=[-1];
8748: for(I=0;R!=[];R=cdr(R),I++){
8749: if(C>0&&car(R)[F[1]]!=F[2]) continue;
8750: if(M<car(R)[0]){
8751: M=car(R)[0];K=[I,car(R)];
8752: }
8753: }
8754: return K;
8755: }
1.6 takayama 8756: R=reverse(R);
8757: if(F[0]=="sub"){
8758: for(S=F[1];S!=[];S=cdr(S))
8759: R=cons(cons(-car(S)[0],cdr(car(S))),R);
8760: return reverse(R);
8761: }
8762: if(F[0]=="swap"){
8763: for(G=[];R!=[];R=cdr(R))
8764: G=cons([car(R)[0],car(R)[2],car(R)[1]],G);
8765: return G;
8766: }
8767: if(F[0]=="+"){
1.24 takayama 8768: L=length(F);
8769: for(G=[];R!=[];R=cdr(R)){
8770: for(S=[],I=L-1;I>0;I--) S=cons(car(R)[I]+F[I],S);
8771: G=cons(cons(car(R)[0],S),G);
8772: }
1.6 takayama 8773: return G;
8774: }
8775: if(F[0]=="*"){
1.24 takayama 8776: L=length(F);
8777: for(G=[];R!=[];R=cdr(R)){
8778: for(S=0,I=1;I<L;I++) S+=car(R)[I]*F[I];
8779: G=cons([car(R)[0],S],G);
8780: }
1.6 takayama 8781: return G;
8782: }
8783: if(F[0]=="mult"){
8784: K=F[1];
8785: for(G=[];R!=[];R=cdr(R)) G=cons(cons(K*car(R)[0],cdr(car(R))),G);
8786: return G;
8787: }
8788: if(F[0]=="get"){
8789: for(G=[];R!=[];R=cdr(R))
8790: if(car(R)[F[1]]==F[2]) G=cons(car(R),G);
8791: return G;
8792: }
8793: if(F[0]=="put"){
8794: if(F[1]==1){
8795: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[2]],G);
8796: }else{
8797: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
8798: }
8799: return G;
8800: }
8801: if(F[0]=="get1"){
8802: if(length(F)==2){
8803: for(G=[];R!=[];R=cdr(R)) G=cons([R[0][0],car(R)[F[1]]],G);
8804: return G;
8805: }
8806: for(G=[];R!=[];R=cdr(R))
8807: if(car(R)[F[1]]==F[2]) G=cons([R[0][0],car(R)[3-F[1]]],G);
8808: return G;
8809: }
8810: if(F[0]=="put1"){
8811: if(length(F)==1)
8812: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],car(R)[1]],G);
8813: else if(F[1]==1)
8814: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[1]],G);
8815: else{
8816: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
8817: }
8818: return G;
8819: }
8820: if(F[0]=="val"){
8821: V=(length(F)==1)?1:F[1];
8822: for(I=J=0;R!=[];R=cdr(R)){
8823: I+=car(R)[0];
8824: J+=car(R)[0]*car(R)[V];
8825: }
8826: return [I,J];
8827: }
8828: return 0;
8829: }
8830:
8831: /*
8832: G=0 get trivial common spct
8833: G="..,..," spectre type of 4 singular points
8834: P=["get"] all spct
8835: P=["get",L]
8836: L=n for variable x_n
8837: L=[m,n] for residue [m,n]
1.23 takayama 8838: L=[m,n,l] for residue [m,n,l]
1.6 takayama 8839: L=[[m,n],[m',n']] for common spct
1.23 takayama 8840: P=["eigen",I] decomposition of A_I
1.6 takayama 8841: P=["get0",[m,n],[m',n']] for the sum of residues
1.23 takayama 8842: P=["rest",[m,n]] restriction
1.6 takayama 8843: P=["swap",[m,n]] for symmetry
8844: P=["perm",[...]] for symmetry
8845: P=["deg"]
8846: P=["homog"]
8847: P=["sort"]
8848: P=[[[m,n],c],...] for addition
8849: P=[c] or [[c],...] for middle convolution wrt 0
8850: P=[m,c] or [[m,c],...] for general middle convolution
8851: P=[[a,b,c]] for special additions
8852: P=[[d,a,b,c]] for middle convotution and additions
8853: P=["multi",...] multiple commands
8854: P=0,1,3 : return sim. spectre of 4 singular points
8855: */
8856: def mc2grs(G,P)
8857: {
8858: if(G==0){
8859: G=[];
8860: for(I=4;I>=0;I--){
8861: V=lsort([0,1,2,3,4],[I],1);
8862: for(J=1;J<4;J++){
8863: for(T=[],K=3;K>0;K--)
8864: if(K!=J) T=cons(V[K],T);
8865: G=cons([[[V[0],V[J]],T],[1,0,0]],G);
8866: }
8867: }
8868: G=mc2grs(G,"sort");
8869: }else if(type(G)==7||(type(G)==4&&length(G)==4)){
8870: if(type(G)==7) G=s2sp(G);
8871: F=(getopt(top)==0)?1:0;
8872: K=[];
8873: if(type(P)==1&&iand(P,1)&&type(G[0][0])<4){
8874: G=s2sp(G|std=1);
8875: if(F) G=[G[1],G[2],G[3],G[0]];
8876: G=sp2grs(G,[d,c,b,a],[1,length(G[0]),-1]|mat=1);
8877: G=reverse(G);
8878: if(iand(P,3)==3){
8879: V=vars(G);
8880: for(H=L=[a,b,c,d];H!=[];H=cdr(H))
8881: if(findin(car(H),V)>=0) G=subst(G,car(H),makev([car(H),1]));
8882: G=shortv(G,[a,b,c,d]);
8883: V=vars(G);
8884: for(H=G[3];H!=[];H=cdr(H)){
8885: T=car(H)[1];
8886: if(type(T)>1&&!isvar(T)){
8887: K=[car(H)[0],T];
8888: break;
8889: }
8890: }
8891: }
8892: F=1;
8893: }
8894: if(F) G=[G[3],G[0],G[1],G[2]];
8895: S=cons(["anal",1],getopt());
8896: if(!(R=m2mc(G,0|option_list=S))) return R;
8897: for(G=0,R=cdr(R);R!=[];R=cdr(R)){
8898: TR=car(R)[0];
8899: if(TR[0]) G=mc2grs(G,[[TR[0]]]);
8900: G=mc2grs(G,[cdr(TR)]);
8901: }
8902: if(type(P)==1&&K!=[]){
8903: for(T=10;T<36;T++){
8904: if(findin(X=makev([T]),V)>=0) continue;
8905: F=K[0]*(X-K[1]);
8906: return [F,simplify(G,[F],4)];
8907: }
8908: }
8909: }
8910: if(type(P)<2) return G;
8911: F=0;
1.25 takayama 8912: if(type(P)==7||(type(P)==4&&
8913: (type(P[0])<4||(type(P[0])==4&&length(P[0])==2&&type(P[0][0])<4&&type(P[1])<4))
8914: )) P=[P];
1.6 takayama 8915: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
8916: Keep=(Dvi==2)?1:0;
8917: if(type(P)==4&&type(F=car(P))==7){
8918: if(F=="mult"){
8919: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
8920: return G;
8921: }
8922: if(F=="show"){
8923: for(R=str_tb(0,0);G!=[];){
8924: L=car(G);
8925: I=L[0][0];J=L[0][1];
8926: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1])
8927: +"}]&=\\left\\{",R);
8928: for(L=cdr(L);;){
8929: S=car(L);
8930: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
8931: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
8932: if((L=cdr(L))==[]) break;
8933: str_tb(",\\,",R);
8934: }
8935: str_tb("\\right\\}",R);
8936: if((G=cdr(G))==[]) break;
8937: str_tb(",\\\\\n",R);
8938: }
8939: R=texbegin("align*",str_tb(0,R));
8940: if(Dvi!=-1) dviout(R|keep=Keep);
8941: return R;
8942: }
8943: if(F=="show0"){
1.26 takayama 8944: if(type(Fig=getopt(fig))>0){
8945: PP=[[-1.24747,-5.86889],[1.24747,-5.86889],[3.52671,-4.8541],[5.19615,-3],
8946: [5.96713,-0.627171],[5.70634,1.8541],[4.45887,4.01478],[2.44042,5.48127],
8947: [0,6],[-2.44042,5.48127],[-4.45887,4.01478],[-5.70634,1.8541],
8948: [-5.96713,-0.627171],[-5.19615,-3],[-3.52671,-4.8541]];
8949: PL=[[1.8,-5.2],[5.7,-1.7],[3.2,5],[-3.6,4.7],[2.2,3],[-2.8,2.8],
8950: [-1.5,-1.4],[-3.2,-2.5],[0.76,-1.4],[-2,0.2]];
8951: PC=["black,dashed","green,dashed","red,dashed","blue,dashed",
8952: "black","cyan","green","blue","red","magenta"];
8953: N=["1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"];
8954: 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],
8955: [2,9,14],[3,6,13]];
8956: TB=str_tb("\\draw\n",TB);
8957: if(type(Fig)==4){
8958: if(type(car(Fig))==1){
8959: PP=ptaffine(car(Fig)/12,PP);PL=ptaffine(car(Fig)/12,PL);
8960: Fig=cdr(Fig);
8961: }
8962: if(Fig!=[]&&length(Fig)==10) PC=Fig;
8963: }
8964: for(R=mc2grs(G,"show0"|dviout=-1),I=0;R!="";I++){ /* 頂点 */
8965: J=str_chr(R,0,",");
8966: if(J>0){
8967: S=str_cut(R,0,J-1);
8968: R=str_cut(R,J+1,1000);
8969: }else{
8970: S=R;R="";
8971: }
8972: T=(str_chr(S,0,"1")==0)?"":"[red]";
8973: str_tb(["node",T,"(",N[I],") at ",xypos(PP[I]),"{$",S,"$}\n"],TB);
8974: }
8975: for(S=PC,P=PL,I=0;I<4;I++){
8976: for(J=I+1;J<5;J++,S=cdr(S),P=cdr(P)){ /* 線の番号 */
8977: SS=car(S);
8978: if((K=str_chr(SS,0,","))>0) SS=sub_str(SS,0,K-1);
8979: str_tb(["node[",SS,"] at ",xypos(car(P)),
8980: "{$[",rtostr(I),rtostr(J),"]$}\n"],TB);
8981: }
8982: }
8983: str_tb(";\n",TB);
8984: for(I=0;I<10;I++){ /* 線 */
8985: S=car(PC);P0=car(PC);L0=car(LL);PC=cdr(PC);LL=cdr(LL);
8986: C=[N[L0[0]-1],N[L0[1]-1],N[L0[2]-1]];
8987: str_tb(["\\draw[",S,"] (", C[0],")--(",C[1],") (",
8988: C[0],")--(",C[2],") (",C[1],")--(",C[2],");\n"],TB);
8989: }
8990: R=str_tb(0,TB);
8991: if(TikZ==1&&Dvi!=-1) dviout(xyproc(R)|dviout=1,keep=Keep);
8992: return R;
8993: }
1.6 takayama 8994: for(S="",L=[];G!=[];G=cdr(G)){
8995: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
8996: TL=msort(TL,[-1,0]);
8997: if(Dvi){
8998: if(S!="") S=S+",";
8999: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
9000: if(car(T)==I) J++;
9001: else{
9002: if(I>0&&J>0){
9003: if(I>9) S=S+"("+rtostr(I)+")";
9004: else S=S+rtostr(I);
9005: if(J>1){
9006: if(J>9) S=S+"^{"+rtostr(J)+"}";
9007: else S=S+"^"+rtostr(J);
9008: }
9009: }
9010: I=car(T);J=1;
9011: }
9012: }
9013: }
9014: L=cons(TL,L);
9015: }
9016: if(Dvi){
9017: if(Dvi!=-1) dviout(S|eq=0);
9018: return S;
9019: }
9020: return reverse(L);
9021: }
9022: if(F=="sort"){
9023: G=ltov(G);L=length(G);
9024: for(I=0;I<L;I++){
9025: S=G[I][0];
9026: if(S[0][0]>S[0][1]) S=[[S[0][1],S[0][0]],S[1]];
9027: if(S[1][0]>S[1][1]) S=[S[0],[S[1][1],S[1][0]]];
9028: if(S[0]>S[1]){
9029: F=0;S=[S[1],S[0]];
9030: }
9031: if(S!=G[I][0]){
9032: if(F==0) G[I]=cons(S,anal2sp(cdr(G[I]),"swap"));
9033: else G[I]=cons(S,cdr(G[I]));
9034: }
9035: for(J=I;J>0;J--){
9036: if(G[J-1][0]<G[J][0]) break;
9037: S=G[J-1];G[J-1]=G[J];G[J]=S;
9038: }
9039: }
9040: return vtol(G);
9041: }
9042: if(F=="get"||F=="get0"){
9043: if(Dvi!=0) F="get";
9044: if(length(P)==1||type(P[1])<2){
9045: L=[];
9046: if(length(P)==1){
9047: for(I=3;I>=0;I--){
9048: for(J=4;J>I;J--) L=cons(mc2grs(G,[F,[I,J]]),L);
9049: }
9050: }else{
9051: for(I=P[1],J=4;J>=0;J--){
9052: if(I==J) continue;
9053: L=cons(mc2grs(G,[F,(I<J)?[I,J]:[J,I]]),L);
9054: }
9055: }
9056: if(Dvi){
9057: if(length(L)==10){
9058: R=ltov(L);
9059: if(R[6][0]==[1,4]){
9060: S=R[6];R[6]=R[7];R[7]=S;
9061: L=vtol(R);
9062: }
9063: }
9064: for(R=S=[],L=reverse(L);L!=[];L=cdr(L)){
9065: T=car(L);
9066: R=cons(cdr(T),R);
9067: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
9068: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
9069: }
9070: L=ltotex(R|opt="GRS",pre=S);
1.26 takayama 9071: if(type(D=getopt(div))==1 || type(D)==4) L=divmattex(L,D);
1.6 takayama 9072: if(Dvi>0) dviout(L|eq=0,keep=Keep);
9073: }
9074: return L; /* get all spct */
9075: }
9076: if(type(T=P[1])==4){
9077: if(F=="get0"&&length(P)==3&&type(I=P[1])==4&&type(J=P[2])==4){
9078: if(I[0]>I[1]) I=[I[1],I[0]];
9079: if(J[0]>J[1]) J=[J[1],J[0]];
9080: if(I[0]>I[0]){S=I;I=J;J=S;};
9081: K=lsort(I,J,0);
9082: if(length(K)==4){
1.24 takayama 9083: S=mc2grs(G,["get0",[I,J]]);
1.6 takayama 9084: return anal2sp(S,[["*",1,1],0]);
9085: }
9086: I=lsort(K,lsort(I,J,2),1);
9087: S=lsort([0,1,2,3,4],K,1);
1.24 takayama 9088: D=mc2grs(G,"deg");
1.6 takayama 9089: if(findin(4,S)<0) D=-D;
1.24 takayama 9090: J=mc2grs(G,["get0",[I,S]]);
1.6 takayama 9091: if(I[0]>S[0]) J=sp2grs(J,"swap");
9092: return anal2sp(J,[["+",0,D],["*",-1,1]]);
9093: }
9094: if(type(car(T))==4){
9095: if(T[0][0]>T[0][1]) T=[[T[0][1],T[0][0]],T[1]];
9096: if(T[1][0]>T[1][1]) T=[T[0],[T[1][1],T[1][0]]];
9097: if(T[0][0]>T[1][0]) T=[T[1],T[0]];
9098: for(PG=G;PG!=[];PG=cdr(PG))
9099: if(car(PG)[0]==T) return (F=="get")?car(PG):cdr(car(PG));
9100: return []; /* get common spct */
9101: }
1.23 takayama 9102: if(length(T)==3){
9103: T0=T;T=lsort([0,1,2,3,4],T,1);
9104: if(length(T)!=2) return [];
9105: }else T0=0;
1.6 takayama 9106: if(T[0]>T[1]) T=[T[1],T[0]];
9107: for(FT=0,PG=G;PG!=[];PG=cdr(PG)){
9108: if(car(PG)[0][0]==T){
9109: FT=1;break;
9110: }
9111: if(car(PG)[0][1]==T){
9112: FT=2;break;
9113: }
9114: }
9115: if(!FT) return [];
9116: L=anal2sp(cdr(car(PG)),[["get1",FT],0]);
1.23 takayama 9117: if(T0!=0){
9118: if((K=mc2grs(G,"deg"))!=0){
9119: if(T[1]!=4) K=-K;
9120: R=reverse(L);
9121: for(L=[];R!=[];R=cdr(R)) L=cons([car(R)[0],car(R)[1]+K],L);
9122: }
9123: T=T0;
9124: }
1.6 takayama 9125: return (F=="get")?cons(T,L):L;
9126: }
9127: }
1.27 takayama 9128: if(F=="rest"||F=="eigen"||F=="rest0"||F=="rest1"){
1.23 takayama 9129: if(F!="eigen") G=mc2grs(G,"homog");
1.26 takayama 9130: if(length(P)==1){
9131: for(R=[],I=0;I<4;I++){
9132: for(J=I+1;J<5;J++){
9133: S=mc2grs(G,[F,[I,J]]);
1.27 takayama 9134: if(S!=[]) R=cons(cons([I,J],S),R);
1.26 takayama 9135: }
9136: }
9137: R=reverse(R);
9138: if(Dvi){
9139: TB=str_tb(0,0);
1.27 takayama 9140: if(F=="rest0"||F=="rest1"){
1.26 takayama 9141: for(T=R;;){
9142: TT=car(T);
9143: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
9144: str_tb(["[",S,"]","&: "],TB);
9145: for(TR=[],TT=cdr(TT);TT!=[];TT=cdr(TT))
9146: TR=cons(car(TT)[1],TR);
9147: for(TR=qsort(TR);TR!=[];TR=cdr(TR))
9148: str_tb([s2sp(car(TR)|short=1,std=-1),"\\ \\ "],TB);
9149: if((T=cdr(T))==[]) break;
9150: str_tb("\\\\\n",TB);
9151: }
9152: }else{
9153: TB=str_tb(0,0);
9154: for(T=R;;){
9155: TT=car(T);
9156: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
9157: str_tb(["[",S,"]",":\\ "],TB);
9158: for(TR=[],TT=cdr(TT);;){
9159: T0=car(TT);
9160: str_tb(["&",my_tex_form(car(T0)),"&&\\to\\ \n",
9161: ltotex(cdr(T0)|opt="GRS")],TB);
9162: if((TT=cdr(TT))==[]) break;
9163: str_tb("\\\\\n",TB);
9164: }
9165: if((T=cdr(T))==[]) break;
9166: str_tb("\\allowdisplaybreaks\\\\\n",TB);
9167: }
9168: }
9169: R=texbegin("align*",str_tb(0,TB));
9170: if(Dvi!=-1) dviout(R|keep=Keep);
9171: }
9172: return R;
9173: }
1.23 takayama 9174: I=P[1];
9175: if(I[0]>I[1]) I=[I[1],I[0]];
9176: L=lsort([0,1,2,3,4],I,1);
1.29 takayama 9177: if(F=="rest"&&length(P)==3){
9178: J=P[2];if(J[0]>J[1]) J=[J[1],J[0]];
9179: L=lsort(L,J,1);
9180: if(length(L)!=1) return 0;
9181: return [mc2grs(G,["get0",I]),mc2grs(G,["get0",[I[0],J[0]],[I[1],J[1]]]),
9182: mc2grs(G,["get0",[I[0],J[1]],[I[1],J[0]]]),mc2grs(G,["get0",[I[0],I[1],L[0]]])];
9183: }
1.23 takayama 9184: L=[[L[0],L[1]],[L[0],L[2]],[L[1],L[2]]];
1.24 takayama 9185: if(F!="eigen"){
9186: if(I==[0,4]) L=reverse(L);
9187: else{
9188: for(V=[],J=2;J>=0;J--){
9189: if(L[J][0]==0) V=cons([L[J][1],J],V);
9190: else{
9191: for(K=4;K>=0;K--){
9192: if(findin(K,L[J])<0){
9193: V=cons([K,J],V);break;
9194: }
9195: }
9196: }
9197: }
9198: V=qsort(V);
9199: L=[L[V[0][1]],L[V[1][1]],L[V[2][1]]];
9200: }
9201: }
1.23 takayama 9202: for(LL=[],T=L;T!=[];T=cdr(T))
9203: LL=cons(mc2grs(G,["get0",[I,car(T)]]),LL);
9204: LL=reverse(LL);
9205: for(R=[],Q=mc2grs(G,["get0",I]);Q!=[];Q=cdr(Q)){
1.24 takayama 9206: for(T=[],J=2;J>=0;J--){
9207: V=anal2sp(LL[J],["get1",(I[0]<L[J][0])?1:2,car(Q)[1]]);
9208: if(F=="rest"){
9209: if(I[0]==0){
9210: if(I[1]!=4){
9211: if(L[J][1]!=4) V=anal2sp(V,["+",-car(Q)[1]]);
9212: }else if (L[J][0]!=2) V=anal2sp(V,["+",-car(Q)[1]]);
9213: }else if(L[J][0]!=0) V=anal2sp(V,["+",-car(Q)[1]]);
9214: }
9215: T=cons(V,T);
9216: }
1.23 takayama 9217: R=cons(cons(car(Q)[1],T),R);
9218: }
1.27 takayama 9219: if(F=="rest0"||F=="rest1"){
9220: for(L=[];R!=[];R=cdr(R)){
9221: TR=cdr(car(R));
1.28 takayama 9222: if(F=="rest1"&&chkspt(TR|opt="idx")==2) continue;
1.27 takayama 9223: L=cons([car(R)[0],s2sp(chkspt(TR|opt=6))],L);
9224: }
1.23 takayama 9225: R=reverse(L);
9226: }
9227: return R;
9228: }
1.6 takayama 9229: if(F=="deg"){
9230: for(S=I=0;I<3;I++){
9231: for(J=I+1;J<4;J++){
9232: L=mc2grs(G,["get0",[I,J]]);
9233: L=anal2sp(L,"val");
9234: S+=L[1];
9235: }
9236: }
9237: return S/L[0];
9238: }
1.27 takayama 9239: if(F=="spct"||F=="spct1"){
9240: K=(F=="spct")?5:6;
1.6 takayama 9241: G=mc2grs(G,"get");
1.27 takayama 9242: M=newmat(5,K);
1.6 takayama 9243: for(;G!=[];G=cdr(G)){
9244: GT=car(G);I=GT[0][0];J=GT[0][1];
9245: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
9246: L=cons(car(GT)[0],L);
9247: }
9248: L=reverse(qsort(L));
9249: M[I][J]=M[J][I]=L;
9250: }
9251: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
9252: for(I=0;I<5;I++){
9253: S=-2*D^2;
9254: for(J=0;J<5;J++){
9255: if(I==J) continue;
9256: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
9257: }
9258: M[I][I]=S;
1.27 takayama 9259: if(K==6){
9260: for(S=[],J=4;J>=0;J--)
9261: if(I!=J) S=cons(M[I][J],S);
9262: R=chkspt(S|opt=2);
9263: M[I][5]=((L=length(R))>1)?s2sp(R[L-2]|short=1):"";
9264: }
1.6 takayama 9265: }
9266: if(Dvi){
9267: S=[];
9268: for(I=4;I>=0;I--){
1.27 takayama 9269: L=(K==6)?[M[I][5]]:[];
9270: L=cons(M[I][I],L);
1.6 takayama 9271: for(J=4;J>=0;J--){
9272: if(I==J) L=cons("",L);
9273: else L=cons(s2sp([M[I][J]]),L);
9274: }
9275: S=cons(L,S);
9276: }
1.27 takayama 9277: T=(K==6)?["reduction"]:[];
9278: S=cons(append([x0,x1,x2,x3,x4,"idx"],T),S);
9279: M=ltotex(S|opt="tab",hline=[0,1,z],
9280: vline=(K==6)?[0,1,z-2,z-1,z]:[0,1,z-2,z-1,z],
1.26 takayama 9281: left=["","$x_0$","$x_1$","$x_2$","$x_3$","$x_4$"]);
1.6 takayama 9282: if(Dvi>0) dviout(M|keep=Keep);
9283: }
9284: return M;
9285: }
9286: if(F=="swap"||F=="perm"){
9287: if(F=="perm") TR=P[1];
9288: else{
9289: TR=newvect(5,[0,1,2,3,4]);
9290: K=P[1][0];L=P[1][1];
9291: TR[K]=L;TR[L]=K;
9292: if(TR[4]!=4) G=mc2grs(G,"deg");
9293: }
9294: V=newvect(2);
9295: for(L=[],T=G;T!=[];T=cdr(T)){
9296: TP=car(T)[0];
9297: for(TQ=[],I=1;I>=0;I--){
9298: V=[TR[TP[I][0]],TR[TP[I][1]]];
9299: if(V[0]>V[1]) V=[V[1],V[0]];
9300: TQ=cons(V,TQ);
9301: }
9302: if(TQ[0][0]<TQ[1][0]){
9303: L=cons(cons(TQ,cdr(car(T))),L);
9304: continue;
9305: }
9306: TQ=[[TQ[1],TQ[0]]];
9307: for(TP=cdr(car(T));TP!=[];TP=cdr(TP))
9308: TQ=cons([car(TP)[0],car(TP)[2],car(TP)[1]],TQ);
9309: L=cons(reverse(TQ),L);
9310: }
9311: return mc2grs(L,"sort");
9312: }
9313: if(F=="homog"){
9314: V=mc2grs(G,"deg");
9315: return mc2grs(G,[[[2,3],-V]]);
9316: }else if(F=="deg"){
9317: R=mc2grs(G,4);
9318: for(V=0;R!=[];R++){
9319: for(TR=cdr(R);TR!=[];TR=cdr(TR))
9320: V+=car(TR)[0]*car(TR)[1];
9321: }
9322: return -V;
9323: }
9324: }
9325: if(type(F)!=4) return 0;
9326: if(type(P[0])!=4) P=[P];
9327: for(;P!=[];P=cdr(P)){
9328: if(type((S=P[0])[0])==4){ /* addition */
9329: T=P[0][0];
9330: if(T[0]>T[1]) T=[T[1],T[0]];
9331: T1=[T[0],4];T2=[T[1],4];
9332: for(L=[],PG=reverse(G);PG!=[];PG=cdr(PG)){
9333: R=car(PG);R0=R[0];F=0;K=P[0][1];
9334: if(R0[0]==T) F=1;
9335: else if(R0[1]==T) F=2;
9336: else if(getopt(unique)!=1){
9337: K=-K;
9338: if(R0[0]==T1||R0[0]==T2) F=1;
9339: else if(R0[1]==T1||R0[1]==T2) F=2;
9340: }
9341: if(F==0) L=cons(R,L);
9342: else{
9343: R1=anal2sp(cdr(R),(F==1)?["+",K,0]:["+",0,K]);
9344: L=cons(cons(R0,R1),L);
9345: }
9346: }
9347: G=L;
9348: }else if(type(S[0])<4){
9349: if(length(S)==1){ /* mc wrt0 4:cases */
9350: U=mc2grs(G,"deg");
9351: C=P[0][0];
9352: L=[];
9353: /* [[0,1],[2,3]] : [K=[0,k],J=[i,j]], S=[k,4] : 3 cases */
9354: for(K=1;K<4;K++){
9355: J=lsort([1,2,3],[K],1);
9356: K4=[K,4];K0=[0,K];
9357: G0=mc2grs(G,["get0",[K0,J]]);
9358: LT=anal2sp(G0,["+",C,0]);
9359: G0=mc2grs(G,["get0",J]);
9360: L0=anal2sp(G0,["put1",1,0]);
9361: LT=anal2sp(LT,["add",L0]);
9362: G0=mc2grs(G,["get0",K4]);
9363: L0=anal2sp(G0,[["put1",1,0],["+",0,U]]);
9364: LT=anal2sp(LT,["add",L0]);
9365: G0=mc2grs(G,["get0",[[0,J[0]],K4]]);
9366: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
9367: LT=anal2sp(LT,["sub",L0]);
9368: G0=mc2grs(G,["get0",[[0,J[1]],K4]]);
9369: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
9370: LT=anal2sp(LT,["sub",L0]);
9371: G0=mc2grs(G,["get0",[K0,J]]);
9372: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
9373: LT=anal2sp(LT,["sub",L0]);
9374: G0=mc2grs(G,["get0",[[0,4],J]]);
9375: L0=anal2sp(G0,[["+",-C,0],["get",1,0]]);
9376: LT=anal2sp(LT,[["sub",L0],0]);
9377: L=cons(cons([K0,J],LT),L);
9378: }
9379: /* [[0,1],[2,4]] : [K,I]=[[0,k],[i,4]] S=[j,k] : 6 cases */
9380: for(K=1;K<4;K++){
9381: for(I=1;I<4;I++){
9382: if(I==K) continue;
9383: for(J=1;J<4;J++) if(J!=I&&J!=K) break;
9384: I4=[I,4];S=(J<K)?[J,K]:[K,J];K0=[0,K];
9385: G0=cdr(mc2grs(G,["get",[K0,I4]]));
9386: LT=anal2sp(G0,["+",C,0]);
9387: G0=cdr(mc2grs(G,["get",I4]));
9388: L0=anal2sp(G0,["put1",1,0]);
9389: LT=anal2sp(LT,["add",L0]);
9390: G0=cdr(mc2grs(G,["get",S]));
9391: L0=anal2sp(G0,[["put1",1,0],["+",0,-C-U]]);
9392: LT=anal2sp(LT,["add",L0]);
9393:
9394: G0=cdr(mc2grs(G,["get",[[0,I],S]]));
9395: L0=anal2sp(G0,[["get",1,0],["+",0,-C-U]]);
9396: LT=anal2sp(LT,["sub",L0]);
9397: G0=cdr(mc2grs(G,["get",[[0,J],I4]]));
9398: L0=anal2sp(G0,["get",1,0]);
9399: LT=anal2sp(LT,["sub",L0]);
9400: G0=cdr(mc2grs(G,["get",[K0,I4]]));
9401: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
9402: LT=anal2sp(LT,["sub",L0]);
9403: G0=cdr(mc2grs(G,["get",[[0,4],S]]));
9404: L0=anal2sp(G0,[["get",1,C],["+",-C,-C-U]]);
9405: LT=anal2sp(LT,[["sub",L0],0]);
9406: L=cons(cons([K0,I4],LT),L);
9407: }
9408: }
9409: /* [[0,4],[2,3]] : [[0,4],J]=[[0,4],[i,j]] 3 cases */
9410: for(K=3;K>0;K--){
9411: J=lsort([1,2,3],[K],1);
9412: G0=mc2grs(G,["get0",[[0,4],J]]);
9413: LT=anal2sp(G0,["+",-C,0]);
9414: G0=mc2grs(G,["get0",J]);
9415: L0=anal2sp(G0,["put1",1,-C]);
9416: LT=anal2sp(LT,["add",L0]);
9417: G0=mc2grs(G,["get0",[K,4]]);
9418: L0=anal2sp(G0,[["put1",1,-C],["+",0,U]]);
9419: LT=anal2sp(LT,["add",L0]);
9420:
9421: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
9422: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
9423: LT=anal2sp(LT,["sub",L0]);
9424: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
9425: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
9426: LT=anal2sp(LT,["sub",L0]);
9427: G0=mc2grs(G,["get0",[[0,K],J]]);
9428: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
9429: LT=anal2sp(LT,["sub",L0]);
9430: G0=mc2grs(G,["get0",[[0,4],J]]);
9431: L0=anal2sp(G0,[["get",1,C],["put",1,0]]);
9432: LT=anal2sp(LT,[["sub",L0],0]);
9433: L=cons(cons([[0,4],J],LT),L);
9434: }
9435: /* [[1,2],[3,4]] : [J,K]=[[i,j],[k,4]] 3 cases */
9436: for(K=3;K>0;K--){
9437: J=lsort([1,2,3],[K],1);
9438: if(K>1)
9439: LT=mc2grs(G,["get0",[J,[K,4]]]);
9440: else{
9441: LT=mc2grs(G,["get0",[[K,4],J]]);
9442: LT=anal2sp(LT,"swap");
9443: }
9444: G0=mc2grs(G,["get0",J]);
9445: L0=anal2sp(G0,[["put1"],["+",0,-C-U]]);
9446: LT=anal2sp(LT,["add",L0]);
9447: G0=mc2grs(G,["get0",[K,4]]);
9448: L0=anal2sp(G0,[["put1"],["+",U,0]]);
9449: LT=anal2sp(LT,["add",L0]);
9450:
9451: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
9452: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
9453: LT=anal2sp(LT,["sub",L0]);
9454: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
9455: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
9456: LT=anal2sp(LT,["sub",L0]);
9457: G0=mc2grs(G,["get0",[[0,K],J]]);
9458: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",0,-C-U]]);
9459: LT=anal2sp(LT,["sub",L0]);
9460: G0=mc2grs(G,["get0",[[0,4],J]]);
9461: L0=anal2sp(G0,[["get1",1,C],["put1"],["+",0,-C-U]]);
9462: LT=anal2sp(LT,[["sub",L0],0]);
9463: if(K==1){
9464: LT=anal2sp(LT,"swap");
9465: L=cons(cons([[K,4],J],LT),L);
9466: }else L=cons(cons([J,[K,4]],LT),L);
9467: }
9468: G=L;
9469: }else if(length(S)==2){ /* general mc */
9470: if(S[1]!=0){
9471: I=S[0];
9472: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
9473: G=mc2grs(G,[S[1]]);
9474: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
9475: }
9476: }else if(length(S)==3||length(S)==4){ /* addition */
9477: for(I=1;I<4;I++,S=cdr(S))
9478: if(S[0]) G=mc2grs(G,[[[0,I],S[0]]]);
9479: if(length(S)==1 && S[0]) /* mc */
9480: G=mc2grs(G,[S[0]]);
9481: }
9482: }
9483: }
9484: return mc2grs(G,"sort");
9485: }
9486:
9487: def mcmgrs(G,P)
9488: {
9489: if(type(G)<2){
9490: if(G>1){
9491: N=G+2;G=[];
9492: for(I=1;I<=N;I++){
9493: for(J=1;J<N;J++){
9494: if(I==J) continue;
9495: for(K=J+1;K<=N;K++){
9496: if(I==K) continue;
9497: G=cons([[[0,I],[J,K]],[1,0,0]],G);
9498: }
9499: }
9500: }
9501: for(I=1;I<=N;I++){
9502: for(J=1;J<I;J++) G=cons([[[0,I],[0,J,I]],[1,0,0]],G);
9503: for(J=I+1;J<=N;J++) G=cons([[[0,I],[0,I,J]],[1,0,0]],G);
9504: }
9505: return reverse(G);
9506: }
9507: return 0;
9508: }
9509: if(type(G)==7) G=os_md.s2sp(G);
9510: if(type(G)!=4||type(G[0])!=4) return 0;
9511: if(type(G[0][0])!=4){ /* spectre type -> GRS */
9512: G=s2sp(G|std=1);
9513: L=length(G);
9514: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
9515: V=cons(makev([L+9]),V);
9516: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
9517: if(getopt(short)!=0){
9518: V=append(cdr(V),[V[0]]);
9519: G=shortv(G,V);
9520: }
9521: R=chkspt(G|mat=1);
9522: if(R[2] != 2 || R[3] != 0 || !(R=getbygrs(G,1|mat=1))) return 0;
9523: if(getopt(anal)==1) return R; /* called by mcmgrs() */
9524: if(!(G=mcmgrs(L-2,0))) return 0;
9525: for(R=cdr(R);R!=[];R=cdr(R)){
9526: TR=car(R)[0];
9527: if(TR[0]) G=mcmgrs(G,[[TR[0]]]);
9528: G=mcmgrs(G,[cdr(TR)]);
9529: }
9530: }
9531: L=length(G);
9532: for(N=4;N<25;N++){
9533: K=N^2*(N-1)/2;
9534: if(K>L) return 0;
9535: if(K==L) break;
9536: }
9537: if(type(P)<2) return G;
9538: F=0;
9539: if(type(P)==7||(type(P)==4&&type(P[0])<4)) P=[P];
9540: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
9541: Keep=(Dvi==2)?1:0;
9542: if(type(P)==4 && type(F=car(P))==7){
9543: if(F=="mult"){
1.24 takayama 9544: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
1.6 takayama 9545: return G;
9546: }
9547: if(F=="get"||F=="get0"){
9548: if(Dvi!=0) F="get";
9549: if(length(P)==2){
9550: if(type(P[1])==4){
9551: if(type(P[1][1])==4){ /* [[,],[,]] */
9552: for(PG=reverse(G);PG!=[];PG=cdr(PG)){
9553: TP=car(PG);
9554: if(TP[0]==P[1]) return (F=="get")?TP:cdr(TP);
9555: }
9556: return [];
9557: }
9558: if(P[1][0]==0){
9559: if(length(P[1])==2){ /* [0,] */
9560: for(J=1;J<=N;J++) if(J!=P[1][1]) break;
9561: for(K=J+1;K<=N;K++) if(K!=P[1][1]) break;
9562: L=mcmgrs(G,["get0",[P[1],[J,K]]]);
9563: L=anal2sp(L,["get1",1]);
9564: }else{ /* [0,*,*] */
9565: L=mcmgrs(G,["get0",[[P[1][0],P[1][1]],P[1]]]);
9566: L=anal2sp(L,["get1",2]);
9567: }
9568: }else{ /* [,] */
9569: for(J=1;J<=N;J++) if(J!=P[1][0]&&J!=P[1][1]) break;
9570: L=mcmgrs(G,["get0",[[0,J],P[1]]]);
9571: L=anal2sp(L,["get1",2]);
9572: }
9573: L=anal2sp(L,0);
9574: if(F=="get") L=cons(P[1],L);
9575: return L;
9576: }else{ /* I */
9577: for(L=[],I=P[1],J=0;J<=N;J++){
9578: if(I==J) continue;
9579: II=(I<J)?[I,J]:[J,I];
9580: L=cons(mcmgrs(G,[F,II]),L);
9581: }
9582: }
9583: }else{
9584: for(L=[],I=0;I<N;I++){
9585: for(J=I+1;J<=N;J++) L=cons(mcmgrs(G,[F,[I,J]]),L);
9586: }
9587: }
9588: if(Dvi){
9589: for(R=S=[];L!=[];L=cdr(L)){
9590: T=car(L);
9591: R=cons(cdr(T),R);
9592: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
9593: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
9594: }
9595: L=ltotex(R|opt="GRS",pre=S);
9596: if(type(V=getopt(div))!=4) V=[];
9597: if(V==[]&&(K=length(R))>10)
9598: for(I=9;I<K;I+=9) V=cons(I,V);
9599: V=reverse(V);
9600: if(V!=[]) L=divmattex(L,V);
9601: if(Dvi>0){
9602: if(V!=[]) dviout(L|keep=Keep);
9603: else dviout(L|eq=0,keep=Keep);
9604: }
9605: }else L=reverse(L);
9606: return L;
9607: }
9608: if(F=="show"){
9609: for(R=str_tb(0,0);G!=[];){
9610: L=car(G);
9611: I=L[0][0];J=L[0][1];
9612: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1]),R);
9613: if(length(J)==3) str_tb(rtostr(J[2]),R);
9614: str_tb("}]&=\\left\\{",R);
9615: for(L=cdr(L);;){
9616: S=car(L);
9617: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
9618: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
9619: if((L=cdr(L))==[]) break;
9620: str_tb(",\\,",R);
9621: }
9622: str_tb("\\right\\}",R);
9623: if((G=cdr(G))==[]) break;
9624: str_tb(texcr(43),R);
9625: }
9626: R=texbegin("align*",str_tb(0,R));
9627: if(Dvi!=-1) dviout(R|keep=Keep);
9628: return R;
9629: }
9630: if(F=="show0"){
9631: for(C=N*(N-1)*(N-2)/2,S="",L=[];G!=[];G=cdr(G)){
9632: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
9633: TL=msort(TL,[-1,0]);
9634: if(Dvi){
9635: if(S!=""){
9636: if(--C==0) S=S+";";
9637: else S=S+",";
9638: }
9639: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
9640: if(car(T)==I) J++;
9641: else{
9642: if(I>0&&J>0){
9643: if(I>9) S=S+"("+rtostr(I)+")";
9644: else S=S+rtostr(I);
9645: if(J>1){
9646: if(J>9) S=S+"^{"+rtostr(J)+"}";
9647: else S=S+"^"+rtostr(J);
9648: }
9649: }
9650: I=car(T);J=1;
9651: }
9652: }
9653: }
9654: L=cons(TL,L);
9655: }
9656: if(Dvi){
9657: if(Dvi!=-1) dviout(S|eq=0);
9658: return S;
9659: }
9660: return reverse(L);
9661: }
9662: if(F=="spct"){
9663: G=mcmgrs(G,"get");
9664: M=newmat(N+1,N+1);
9665: for(;G!=[];G=cdr(G)){
9666: GT=car(G);I=GT[0][0];J=GT[0][1];
9667: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
9668: L=cons(car(GT)[0],L);
9669: }
9670: L=reverse(qsort(L));
9671: M[I][J]=M[J][I]=L;
9672: }
9673: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
9674: for(I=0;I<=N;I++){
9675: S=-(N-2)*D^2;
9676: for(J=0;J<=N;J++){
9677: if(I==J) continue;
9678: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
9679: }
9680: M[I][I]=S;
9681: }
9682: if(Dvi){
9683: S=[];
9684: for(LS=[],I=N;I>=0;I--){
9685: L=[M[I][I]];
9686: for(J=N;J>=0;J--){
9687: if(I==J) L=cons("",L);
9688: else L=cons(s2sp([M[I][J]]),L);
9689: }
9690: S=cons(L,S);
9691: LS=cons("$x_"+rtostr(I)+"$",LS);
9692: }
9693: S=cons(append(LS,["idx"]),S);
9694: M=ltotex(S|opt="tab",hline=[0,1,z],vline=[0,1,z-1,z],left=cons("",LS));
9695: if(Dvi>0) dviout(M|keep=Keep);
9696: }
9697: return M;
9698: }
9699: if(F=="deg"){
9700: for(S=I=0;I<N-1;I++){
9701: for(J=I+1;J<N;J++){
9702: L=mcmgrs(G,["get0",[I,J]]);
9703: L=anal2sp(L,"val");
9704: S+=L[1];
9705: }
9706: }
9707: return S/L[0];
9708: }
9709: }
9710: L=[];
9711: if(type(F)!=4) return 0;
9712: if(type(P[0])!=4||length(P[0])==2) P=[P];
9713: for(;P!=[];P=cdr(P)){
9714: if(type(T=(S=car(P))[0])==4){ /* addition */
9715: if((K=P[0][1])!=0){
9716: if(T[0]>T[1]) T=[T[1],T[0]];
9717: T1=[T[0],N];T2=[T[1],N];
9718: T01=cons(0,T1);T02=cons(0,T2);
9719: for(PG=G;PG!=[];PG=cdr(PG)){
9720: R=car(PG);R0=R[0];K1=K2=0;
9721: TP=R0[0];
9722: if(TP==T) K1=K;
9723: else if(TP==T1||TP==T2) K1=-K;
9724: if(length(TP=R0[1])==2){
9725: if(TP==T) K2=K;
9726: else if(TP==T1||TP==T2) K2=-K;
9727: }else{
9728: S=0;
9729: if(findin(T[0],TP)>=0) S++;
9730: if(findin(T[1],TP)>=0) S++;
9731: if(S>0&&TP[2]==N) K2=-K;
9732: else if(S==2) K2=K;
9733: }
9734: R1=anal2sp(cdr(R),["+",K1,K2]);
9735: L=cons(cons(R0,R1),L);
9736: }
9737: G=reverse(L);
9738: }
9739: }else if(length(S)==1){ /* middle convolution */
9740: C=S[0];L=[];
9741: for(I=1;I<=N;I++){
9742: for(J=1;J<=N;J++){
9743: if(I==J) continue;
9744: for(K=J+1;K<=N;K++){ /* [[0,I],[J,K]] */
9745: if(I==K)continue;
9746: T=[[0,I],JK=[J,K]];
9747: if(I==N){
9748: LT=mcmgrs(G,["get0",T]);
9749: G0=mcmgrs(G,["get0",JK]);
9750: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
9751: G0=mcmgrs(G,["get0",[0,J,K]]);
9752: LT=anal2sp(LT,["add",L0]);
9753: L0=anal2sp(G0,["put1",1,0]);
9754: LT=anal2sp(LT,["add",L0]);
9755: for(V=1;V<=N;V++){
9756: if(V==I){
9757: G0=mcmgrs(G,["get0",T]);
9758: L0=anal2sp(G0,["get",1,C]);
9759: }else if(V==J||V==K){
9760: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
9761: L0=anal2sp(G0,["get",1,0]);
9762: }else{
9763: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9764: L0=anal2sp(G0,["get",1,0]);
9765: }
9766: LT=anal2sp(LT,["sub",L0]);
9767: }
9768: LT=anal2sp(LT,["+",-C,0]);
9769: }else if(K==N){
9770: LT=mcmgrs(G,["get0",T]);
9771: LT=anal2sp(LT,["+",C,0]);
9772: G0=mcmgrs(G,["get0",JK]);
9773: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
9774: LT=anal2sp(LT,["add",L0]);
9775: G0=mcmgrs(G,["get0",[0,J,K]]);
9776: L0=anal2sp(G0,[["put1",1,0],["+",0,-C]]);
9777: LT=anal2sp(LT,["add",L0]);
9778: for(V=1;V<=N;V++){
9779: if(V==I){
9780: G0=mcmgrs(G,["get0",T]);
9781: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
9782: }else if(V==J){
9783: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
9784: L0=anal2sp(G0,[["get",1,0],["+",0,-C]]);
9785: }else if(V==N){
9786: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
9787: L0=anal2sp(G0,[["get",1,C],["+",-C,-C]]);
9788: }else{
9789: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9790: L0=anal2sp(G0,["get",1,0]);
9791: }
9792: LT=anal2sp(LT,["sub",L0]);
9793: }
9794: }else{
9795: G0=mcmgrs(G,["get0",T]);
9796: LT=anal2sp(G0,["+",C,0]);
9797: G0=mcmgrs(G,["get0",JK]);
9798: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
9799: LT=anal2sp(LT,["add",L0]);
9800: G0=mcmgrs(G,["get0",[0,J,K]]);
9801: L0=anal2sp(G0,["put1",1,0]);
9802: LT=anal2sp(LT,["add",L0]);
9803: for(V=1;V<=N;V++){
9804: if(V==I){
9805: G0=mcmgrs(G,["get0",T]);
9806: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
9807: }else if(V==J||V==K){
9808: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
9809: L0=anal2sp(G0,["get",1,0]);
9810: }else if(V==N){
9811: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9812: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
9813: }else{
9814: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9815: L0=anal2sp(G0,["get",1,0]);
9816: }
9817: LT=anal2sp(LT,["sub",L0]);
9818: }
9819: }
9820: LT=anal2sp(LT,0);
9821: L=cons(cons(T,LT),L);
9822: }
9823: T=[[0,I],(I<J)?[0,I,J]:[0,J,I]]; /* [0,I], [0,I,J] */
9824: JK=(I<J)?[I,J]:[J,I];
9825: if(I==N){
9826: G0=mcmgrs(G,["get0",T]);
9827: LT=anal2sp(G0,["+",-C,0]);
9828: G0=mcmgrs(G,["get0",JK]);
9829: L0=anal2sp(G0,[["put1",1,-C],["mult",N-3]]);
9830: LT=anal2sp(LT,["add",L0]);
9831: G0=mcmgrs(G,["get0",T[1]]);
9832: L0=anal2sp(G0,["put1",1,-C]);
9833: LT=anal2sp(LT,["add",L0]);
9834: for(V=1;V<=N;V++){
9835: if(V==J){
9836: G0=mcmgrs(G,["get0",T]);
9837: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
9838: }else if(V==N){
9839: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
9840: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
9841: }else{
9842: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9843: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
9844: }
9845: LT=anal2sp(LT,["sub",L0]);
9846: }
9847: LT=anal2sp(LT,["+",0,C]);
9848: }else if(J==N){
9849: G0=mcmgrs(G,["get0",T]);
9850: LT=anal2sp(G0,["+",C,0]);
9851: G0=mcmgrs(G,["get0",T[0]]);
9852: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
9853: LT=anal2sp(LT,["add",L0]);
9854: G0=mcmgrs(G,["get0",T[1]]);
9855: L0=anal2sp(G0,["put1",1,0]);
9856: LT=anal2sp(LT,["add",L0]);
9857: for(V=1;V<=N;V++){
9858: if(V==I){
9859: G0=mcmgrs(G,["get0",T]);
9860: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
9861: }else if(V==N){
9862: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
9863: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
9864: }else{
9865: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9866: L0=anal2sp(G0,["get",1,0]);
9867: }
9868: LT=anal2sp(LT,["sub",L0]);
9869: }
9870: LT=anal2sp(LT,["+",0,-C]);
9871: }else{
9872: G0=mcmgrs(G,["get0",T]);
9873: LT=anal2sp(G0,["+",C,C]);
9874: G0=mcmgrs(G,["get0",JK]);
9875: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
9876: LT=anal2sp(LT,["add",L0]);
9877: G0=mcmgrs(G,["get0",T[1]]);
9878: L0=anal2sp(G0,[["put1",1,0],["+",0,C]]);
9879: LT=anal2sp(LT,["add",L0]);
9880: for(V=1;V<=N;V++){
9881: if(V==I){
9882: G0=mcmgrs(G,["get0",T]);
9883: L0=anal2sp(G0,[["get",1,0],["+",C,C]]);
9884: }else if(V==J){
9885: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
9886: L0=anal2sp(G0,[["get",1,0],["+",0,C]]);
9887: }else if(V==N){
9888: G0=mcmgrs(G,["get0",[[0,V],JK]]); L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
9889: }else{
9890: G0=mcmgrs(G,["get0",[[0,V],JK]]);
9891: L0=anal2sp(G0,["get",1,0]);
9892: }
9893: LT=anal2sp(LT,["sub",L0]);
9894: }
9895: }
9896: LT=anal2sp(LT,0);
9897: L=cons(cons(T,LT),L);
9898: }
9899: }
9900: for(G0=G=[];L!=[];L=cdr(L)){
9901: if(length(car(L)[0][1])==2) G0=cons(car(L),G0);
9902: else G=cons(car(L),G);
9903: }
9904: G=append(G0,G);
9905: }else{
9906: if(length(S)==N-1||length(S)==N){ /* [a_1,...,a_{N-1},c] */
9907: for(I=1;I<N;S=cdr(S),I++) G=mcmgrs(G,[[0,I],car(S)]);
9908: if(length(S)==1) G=mcmgrs(G,[S[0]]);
9909: }else return 0;
9910: }
9911: }
9912: return G;
9913: }
9914:
9915:
9916: def delopt(L,S)
9917: {
9918: if((Inv=getopt(inv))!=1) Inv=0;
9919: for(R=[];L!=[];L=cdr(L)){
9920: if(type(car(L))!=4) F=0;
9921: else if(type(S)==4) F=(findin(car(L)[0],S)<0)?0:1;
9922: else F=(car(L)[0]==S)?1:0;
9923: if(F==Inv) R=cons(car(L),R);
9924: }
9925: return reverse(R);
9926: }
9927:
9928: def str_char(S,N,L)
9929: {
9930: if(type(S)==7){
9931: if(type(L)==1) L=asciitostr([L]);
9932: return str_chr(S,N,L);
9933: }
9934: if(type(L)==7) L=strtoascii(L)[0];
9935: if(type(S)==4){
9936: M=N;
9937: while(M-->0) S=cdr(S);
9938: M=findin(L,S);
9939: return (M>=0)?findin(L,S)+N:-1;
9940: }else if(type(S)==5){
9941: K=length(S);
9942: for(I=N;I<K;I++)
9943: if(S[I]==L) return I;
9944: }
9945: return -1;
9946: }
9947:
9948: def str_pair(S,N,I,J)
9949: {
9950: if(type(I)==7) I=(II=strtoascii(I))[0];
9951: if(type(J)==7) J=(JJ=strtoascii(J))[0];
9952: if(type(S)==7) S=strtoascii(S);
9953: if(getopt(inv)==1){
9954: if(II!=0){
9955: I=asciitostr(reverse(II));
9956: IL=length(II);
9957: }else IL=1;
9958: if(JJ!=0) J=asciitostr(reverse(JJ));
9959: R=str_pair(reverse(S),length(S)-N-1,J,I);
9960: if(R>=0) R=length(S)-IL-R;
9961: return R;
9962: }
9963: if((SJIS=getopt(sjis))!=1) SJIS=0;
9964: if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){
9965: for(;;){
9966: MJ=str_str(S,N|top=JJ,sjis=SJIS);
9967: if(MJ>=0){
9968: MI=str_str(S,II|top=N,sjis=SJIS);
9969: if(MI<0 || MI>MJ){
9970: if(C==0) return MJ;
9971: C--; N=MJ+length(II);
9972: }else if(MI>=0){
9973: C++; N=MI+length(JJ);
9974: }
9975: }
9976: return -1;
9977: }
9978: }
9979: if(type(S)==4){
9980: M=N;
9981: while(M-->0) S=cdr(S);
9982: while(S!=[]){
9983: if(car(S)==I) C++;
9984: else if(car(S)==J){
9985: if(C==0) return N;
9986: C--;
9987: }
9988: S=cdr(S);N++;
9989: }
9990: }else if(type(S)==5){
9991: K=length(S);
9992: for(T=N;T<K && C>=0;T++){
9993: if(S[T]==I) C++;
9994: else if(S[T]==J){
9995: if(C==0) return T;
9996: C--;
9997: }
9998: }
9999: }
10000: return -1;
10001: }
10002:
10003:
10004: def str_cut(S,I,J)
10005: {
10006: if(type(S)==7) return sub_str(S,I,J);
10007: if((JJ=length(S))<=J) J=JJ-1;
10008: if(type(S)==5){
10009: for(L=[],K=J; K>=I; K--) L=cons(S[K],L);
10010: }else if(type(S)==4){
10011: J-=I;
10012: while(I-->0) S=cdr(S);
10013: for(L=[];J-->=0;S=cdr(S)) L=cons(car(S),L);
10014: L=reverse(L);
10015: }
10016: return asciitostr(L);
10017: }
10018:
10019: def str_str(S,T)
10020: {
10021: if(S==0) return -1;
10022: if(type(S) == 7)
10023: S = strtoascii(S);
10024: if(type(J=getopt(top))!=1 || J<0) J=0;
10025: LS=length(S);
10026: if(LS-J<1) return -1;
10027: if(type(S)==4){
10028: LS-=(J0=J);
10029: for( ; J>0 && S!=[]; S=cdr(S),J--);
10030: }
10031: if(type(JJ=getopt(end))!=1 && JJ!=0) JJ=LS;
10032: else JJ-=J0;
10033: if((SJIS=getopt(sjis))!=1) SJIS=0;
10034: if(JJ-J<0) return -1;
10035: /* search from J-th to JJ-th */
10036: if(type(T)==1) T=[T];
10037: else if(type(T)==7) T = strtoascii(T);
10038: else if(type(T)==4 && type(T[0])>3){
10039: for(K=(KF=-1)-J0; T!=[]; F++,T=cdr(T)){
10040: JK=str_str(S,car(T)|top=J,end=JJ,sjis=SJIS);
10041: if(JK>=0){
10042: JJ=(K=JK)-1; KF=F;
10043: if(J>JJ) break;
10044: }
10045: }
10046: return [KF,J0+K];
10047: }
10048: if(type(T)==4) T=ltov(T);
10049: LT = length(T);
10050: if(LT>0){
10051: LE = LS-LT;
10052: LP = T[0];
10053: if(JJ==0 ||(type(JJ)==1 && JJ<LE)) LE=JJ;
10054: if(type(S)==5){
10055: for(; J <= LE; J++){
10056: if(S[J] != LP){
10057: if(SJIS && (V=S[J])>128){
10058: if(V<160 || (V>223 && V<240)) J++;
10059: }
10060: continue;
10061: }
10062: for(I = 1; I < LT && S[I+J] == T[I]; I++);
10063: if(I >= LT) return J;
10064: }
10065: }else if(type(S)==4){
10066: for(; J<=LE; S=cdr(S),J++){
10067: if(car(S) != LP){
10068: if(SJIS && (V=S[J])>128){
10069: if(V<160 || (V>223 && V<240)) J++;
10070: }
10071: continue;
10072: }
10073: for(ST=cdr(S), I = 1; I < LT && car(ST) == T[I]; I++, ST=cdr(ST));
10074: if(I >= LT) return J0+J;
10075: }
10076: }
10077: }
10078: return -1;
10079: }
10080:
10081: def str_times(S,N)
10082: {
10083: if(!isint(N)) return "";
10084: if(type(S)==7){
10085: for(Tb=str_tb(0,0);N-->0;)
10086: str_tb(S,Tb);
10087: return str_tb(0,Tb);
10088: }
10089: if(type(S)==4){
10090: for(LT=[],I=0;I<N;I++){
10091: if(type(car(S))==7){
10092: LT=cons(car(S),LT);
10093: S=cdr(S);
10094: if(S==[]) S=[[""]];
10095: }else if(type(car(S))==4){
10096: ST=car(S);
10097: for(J=0;I<N;I++){
10098: if(J==length(ST)) J=0;
10099: LT=cons(ST[J++],LT);
10100: }
10101: }
10102: }
10103: return reverse(LT);
10104: }
10105: return S;
10106: }
10107:
10108: def ssubgrs(M,L)
10109: {
10110: if(type(L)==7) L=s2sp(L);
10111: for(S=0, L=L, M=M; L!=[]; L=cdr(L), M=cdr(M)){
10112: for(LT=car(L), MT=car(M); LT!=[]; LT=cdr(LT), MT=cdr(MT)){
10113: S += car(LT)*car(MT)[1];
10114: }
10115: }
10116: return S;
10117: }
10118:
10119: def s2os(S)
10120: {
10121: return str_subst(S,[["\\","\\\\"],["\"","\\\""]],0);
10122: }
10123:
10124: def l2os(S)
10125: {
10126: if(type(S)==6)
10127: S=m2ll(S);
10128: else if(type(S)==5)
10129: S=vtol(S);
10130: else if(type(S)==7) return "\""+s2os(S)+"\"";
10131: else if(type(S)<4) return rtostr(S);
10132: if(type(S)==4){
10133: for(F=0,Tb=str_tb("[",0);S!=[];S=cdr(S)){
10134: if(F++) str_tb(", ",Tb);
10135: str_tb(l2os(car(S)),Tb);
10136: }
10137: str_tb("]",Tb);
10138: return str_tb(0,Tb);
10139: }
10140: return 0;
10141: }
10142:
10143: def r2os(S)
10144: {
10145: if(type(S)==6){
10146: for(T="",S=m2ll(S);S!=[];S=cdr(S)){
10147: if(T!="") T=T+","+r2os(car(S));
10148: else T=r2os(car(S));
10149: }
10150: return "mat("+T+")\n";
10151: }else if(type(S)==5){
10152: for(T="",S=v2l(S);S!=[];S=cdr(S)){
10153: if(T!="") T=T+","+r2os(car(S));
10154: else T=r2os(car(S));
10155: }
10156: return "vect("+T+")\n";
10157: }else if(type(S)<4) return rtostr(S);
10158: else if(type(S)==4){
10159: for(T="";S!=[];S=cdr(S)){
10160: if(T!="") T=T+","+r2os(car(S));
10161: else T=r2os(car(S));
10162: }
10163: return "["+T+"]";
10164: }else if(type(S)==7) return "\""+s2os(S)+"\"";
10165: return "";
10166: }
10167:
10168: def s2euc(S)
10169: {
10170: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
10171: if((C=car(L)) == 0x1b && length(L)>1) {
10172: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
10173: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
10174: Mode = 1;
10175: } else return 0;
10176: }else if(C == 0x28 && length(L)>1) { /* ( */
10177: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
10178: Mode = 0;
10179: }else if(C == 0x49) { /* I */
10180: Mode = 2;
10181: }else{
10182: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
10183: }
10184: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
10185: L=cdr(L);
10186: }else{
10187: R=cons(0x1b,R);R=cons(C,R);
10188: }
10189: }else if(C == 0x0e) {
10190: Mode = 2;
10191: }else if(C == 0x0f) {
10192: Mode = 0;
10193: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
10194: D=car(L=cdr(L));
10195: if(D>0x20 && D<0x7f) {
10196: R=cons(ior(C,0x80),R);R=cons(ior(D,0x80),R);
10197: } else return 0;
10198: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
10199: R=cons(0x8e,R); R=cons(ior(C,0x80),R);
10200: }else if(((C>0x80 && C<0xa0) || (C>0xdf && C<0xf0)) && length(L)>1) { /* ShiftJIS */
10201: D=car(L=cdr(L));
10202: if(D>0x3f && D<0xfd && D!=0x7f) {
10203: T=sjis2jis([C,D]);
10204: R=cons(ior(T[0],0x80),R); R=cons(ior(T[1],0x80),R);
10205: }else return 0;
10206: }else if(C>0x9f && C<0xe0) { /* HanKana */
10207: R=cons(0x8e,R); R=cons(C,R);
10208: }else if(C == 0x0a){
10209: CR++;
10210: }else if(C == 0x0d){
10211: R=cons(0x0d,R);
10212: CR=0;
10213: }else{
10214: while(CR-->0) R=cons(0x0d,R);
10215: R=cons(C,R);
10216: }
10217: }
10218: while(CR-->0) R=cons(0x0d,R);
10219: return asciitostr(reverse(R));
10220: }
10221:
10222: def s2sjis(S)
10223: {
10224: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
10225: if((C=car(L)) == 0x1b && length(L)>1) {
10226: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
10227: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
10228: Mode = 1;
10229: } else return 0;
10230: }else if(C == 0x28 && length(L)>1) { /* ( */
10231: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
10232: Mode = 0;
10233: }else if(C == 0x49) { /* I */
10234: Mode = 2;
10235: }else{
10236: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
10237: }
10238: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
10239: L=cdr(L);
10240: }else{
10241: R=cons(0x1b,R);R=cons(C,R);
10242: }
10243: }else if(C == 0x0e) {
10244: Mode = 2;
10245: }else if(C == 0x0f) {
10246: Mode = 0;
10247: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
10248: D=car(L=cdr(L));
10249: if(D>0x20 && D<0x7f) {
10250: T=jis2sjis([C,D]);
10251: R=cons(T[0],R);R=cons(T[1],R);
10252: } else return 0;
10253: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
10254: R=cons(ior(C,0x80),R);
10255: }else if(C>0xa0 && C<0xff && length(L)>1) { /* EUC */
10256: D=car(L=cdr(L));
10257: if(D>0xa0 && D<0xff) {
10258: T=jis2sjis([iand(C,0x7f),iand(D,0x7f)]);
10259: R=cons(T[0],R);R=cons(T[1],R);
10260: }else return 0;
10261: }else if(C == 0x0a){
10262: CR++;
10263: }else if(C == 0x0d){
10264: R=cons(0x0a,R);R=cons(0x0d,R);
10265: CR=0;
10266: }else{
10267: while(CR-->0){
10268: R=cons(0x0a,R);R=cons(0x0d,R);
10269: }
10270: R=cons(C,R);
10271: }
10272: }
10273: while(CR-->0){
10274: R=cons(0x0a,R);R=cons(0x0d,R);
10275: }
10276: return asciitostr(reverse(R));
10277: }
10278:
10279: def r2ma(S)
10280: {
10281: return evalma(S|inv=1);
10282: }
10283:
10284: def evalma(S)
10285: {
10286: L0=["\n","\d","{","}","[","]","Log","Exp","Sinh","Cosh","Tanh","Sin","Cos","Tan",
10287: "ArcSin","ArcCos","ArcTan"];
10288: L1=["", "" ,"[","]","(",")","log","exp","sinh","cosh","tanh","sin","cos","tan",
10289: "asin", "acos", "atan"];
10290: if(getopt(inv)==1){
10291: if(type(S)==6) S=m2ll(S);
10292: else if(type(S)==5) S=vtol(S);
10293: if(type(S)==4){
10294: for(L=[];S!=[];S=cdr(S)){
10295: if(type(car(S))==6) L=cons(m2ll(car(S)),L);
10296: else if(type(car(S))==5) L=cons(vtol(car(S)),L);
10297: else L=cons(car(S),L);
10298: }
10299: S=reverse(L);
10300: }else return 0;
10301: return str_subst(rtostr(S),cdr(cdr(L1)),cdr(cdr(L0)));
10302: }
10303: if(S==0){
10304: print("Mathematica text (terminated by ;) ?");
10305: purge_stdin();
10306: Tb=str_tb(0,0);
10307: for(;;){
10308: S=get_line();
10309: str_tb(S,Tb);
10310: if(str_char(S,0,";")>=0) break;
10311: }
10312: S=str_tb(0,Tb);
10313: }
10314: /*
10315: while((P=str_chr(S,0,";"))>=0){
10316: V0=evalma(str_cut(S,0,P+1));
10317: S=str_cut(S,P+1,length(S));
10318: }
10319: if((P=str_char(S,0,"="))>=0){
10320: X=strtoascii(str_cut(S,0,P));
10321: L=length(X);
10322: for(P0=P1=-1,I=0;I<L;I++){
10323: if(L(I)<=32) continue;
10324: if(isalphanum(L[I])){
10325: if(P0<0){
10326: if(isnum(L[I])) break;
10327: P0=I;
10328: }
10329: else if(P1!=I+1) break;
10330: P1=I;
10331: }
10332: }
10333: if(I==L && P0>=0){
10334: for(I==P0;I-->0;) X=cdr(X);
10335: if((X0=car(X))>96) X0-=32;
10336: Y=[X0];X=cdr(X);
10337: for(I=P1-P0;I-->0;X=cdr(X))
10338: Y=cons(car(X),Y);
10339: Y=cons(61,Y);
10340: Var=asciitostr(reverse(Y));
10341: S=str_cut(S,P,length(S));
10342: }
10343: }
10344: */
10345: S=eval_str(str_subst(S,L0,L1));
10346: if(type(S)==4){
10347: for(L=-1,T=S;T!=[];T=cdr(T)){
10348: if(type(T0=car(T))>4) break;
10349: if(type(T0)<4){
10350: if(L>=0) break;
10351: L=-2;continue;
10352: }
10353: if(L<-2) break;
10354: if(L==-1) L=length(T0);
10355: else if(L!=length(T0)) break;
10356: }
10357: if(T==[]){
10358: if(L>0) S=s2m(S);
10359: else S=ltov(S);
10360: }
10361: }
10362: /*
10363: if(S==0 && V0!=0) return V0;
10364: if(type(Var)==7){
10365: T=rtostr(S);
10366: if(type(S)==7) T="\""+T+"\"";
10367: S=eval_str(Var+T);
10368: mycat(["Define",Var]);
10369: }
10370: */
10371: return S;
10372: }
10373:
10374: def i2hex(N)
10375: {
10376: Opt=getopt();
10377: if(type(N)==4 && isint(car(N))){
10378: #ifdef USEMODULE
10379: L=mtransbys(os_md.i2hex,N,[]|option_list=Opt);
10380: #else
10381: L=mtransbys(i2hex,N,[]|option_list=Opt);
10382: #endif
10383: return rtostr(L);
10384: }
10385: if(!isint(N) || N<0) return 0;
10386: if(!N) L=[];
10387: else{
10388: Cap=(getopt(cap)==1)?32:0;
10389: for(L=[];N!=0;N=ishift(N,4)){
10390: J=iand(N,15);
10391: L=cons(((J>9)?(87-Cap):48)+J,L);
10392: }
10393: }
10394: if(!isint(Min=getopt(min))) Min=2;
10395: for(Min-=length(L);Min-->0;)
10396: L=cons(48,L);
10397: if(getopt(num)==1){
10398: L=cons(120,L);L=cons(48,L);
10399: }
10400: return asciitostr(L);
10401: }
10402:
10403: def sjis2jis(L)
10404: {
10405: L1=L[1];
10406: if((L0=L[0])<=0x9f){
10407: if(L1<0x9f) L0=L0*2-0xe1;
10408: else L0=(L0*2)-0xe0;
10409: }else{
10410: if(L1<0x9f) L0=L0*2-0x161;
10411: else L0=L0*2-0x160;
10412: }
10413: if(L1<0x7f) return [L0,L1-0x1f];
10414: else if(L1<0x9f) return [L0,L1-0x20];
10415: return [L0,L1-0x7e];
10416: }
10417:
10418: def jis2sjis(L)
10419: {
10420: L1=L[1];
10421: if(iand(L0=L[0],1)){
10422: if(L1<0x60) L=[L1+0x1f];
10423: else L=[L1+0x20];
10424: }else L=[L1+0x7e];
10425: if(L0<0x5f) return cons(ishift(L0+0xe1,1),L);
10426: return cons(ishift(L0+0x161,1),L);
10427: }
10428:
10429: def verb_tex_form(P)
10430: {
10431: L = reverse(strtoascii(rtostr(P)));
10432: for(SS = []; L != []; L = cdr(L)){
10433: Ch = car(L); /* ^~\{} */
10434: if(Ch == 92 || Ch == 94 || Ch == 123 || Ch == 125 || Ch == 126){
10435: SS = append([92,Ch,123,125],SS); /* \Ch{} */
10436: if(Ch != 94 && Ch != 126) /* \char` */
10437: SS = append([92,99,104,97,114,96],SS);
10438: continue;
10439: }
10440: SS = cons(Ch, SS);
10441: if((Ch >= 35 && Ch <= 38) || Ch == 95) /* #$%&_ */
10442: SS = cons(92, SS); /* \Ch */
10443: }
10444: return asciitostr(SS);
10445: }
10446:
10447: def tex_cuteq(S,P)
10448: {
10449: if(P==0) return 0;
10450: if(S[P]==125){ /* } */
10451: if((Q=str_pair(S,P-1,"{","}"|inv=1))<0) return -1;
10452: if(Q<2||S[Q-1]!=95) return Q;
10453: return tex_cuteq(S,Q-2);
10454: }
10455: if(!isalphanum(S[Q=P--])) return -1;
10456: while(P>0&&isalphanum(S[P])) P--;
10457: if(S[P]==92){ /* \ */
10458: if(P==0) return P;
10459: else P--;
10460: }
10461: if(S[P]!=95||P==0) return Q; /* _ */
10462: return tex_cuteq(S,P-1);
10463: }
10464:
10465:
10466: def texket(S)
10467: {
10468: if(!isint(F=getopt(all))) F=0;
10469: if(type(S)==7){
10470: L=str_len(S);
10471: SS=strtoascii(S);
10472: }else{
10473: L=length(S);
10474: SS=S;
10475: }
10476: for(T="",I=I0=0;I<L-1;){
10477: J=str_char(SS,I,"(");
10478: if(J<0) break;
10479: if(J<L-1 && J>4 && str_str(SS,"\\left"|top=J-5,end=J-1)>=0){
10480: I=J+1;continue;
10481: }
10482: if((K=str_pair(SS,J+1,"(",")"))>=0){
10483: KK=str_char(SS,J+2,"(");
10484: if(KK>K||KK<0){
10485: if(F!=1){
10486: if(!F){
10487: for(N=J+1;N<K;N++) /* + - _ { } */
10488: if(!isalphanum(P=SS[N])&&findin(P,[32,43,45,95,123,125])<0) break;
10489: }else N=K;
10490: if(N==K){
10491: I=K+1;continue;
10492: }
10493: }
10494: T=T+str_cut(SS,I0,J-1)+"\\left"+str_cut(SS,J,K-1)+"\\right)";
10495: I0=I=K+1;
10496: }else{
10497: T=T+str_cut(SS,I0,J-1)+"\\left("+texket(str_cut(SS,J+1,K-1)|all=F) +"\\right)";
10498: I0=I=K+1;
10499: }
10500: }else break;
10501: }
10502: return T+str_cut(SS,I0,L);
10503: }
10504:
10505:
10506: def my_tex_form(S)
10507: {
10508: if(getopt(skip) != 1){
10509: if(type(S)==1 && S<0) return "-"+print_tex_form(-S);
10510: if(type(S)==6) return mtotex(S);
10511: S = print_tex_form(S);
10512: for(F=Top=0;(L=str_str(S,"\\verb`"|top=Top))>=0;Top=LV+1){
10513: F++;
10514: if(Top==0) Tb = string_to_tb("");
10515: LV = str_chr(S, L+6, "`");
10516: if(LV<0) LV=str_len(S);
10517: str_tb([my_tex_form(sub_str(S, Top, L-1)|skip=1), "\\texttt{"], Tb);
10518: str_tb([verb_tex_form(sub_str(S,L+6, LV-1)),"}"], Tb);
10519: Top=LV+1;
10520: }
10521: if(F>0){
10522: str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb);
10523: return tb_to_string(Tb);
10524: }
10525: }
10526: if(S==0) return "";
10527: S = ltov(strtoascii(S));
10528: L = length(S)-1;
10529: while(L >= 1 && S[L] == 10)
10530: L--;
10531: if((Fr=getopt(frac))!=0 && Fr!=1) Fr=2;
10532: for(I = L+1, T = K = 0, SS = []; --I >= 0; ){
10533: if(S[I] == 32 && I!=L){
10534: if(I==L) continue;
10535: if(findin(S[I+1], [32,40,41,43,45,123,125]) >= 0 /* " ()+-{}" */
10536: || (S[I+1] >= 49 && S[I+1] <= 57)) /* 1 - 9 */
10537: if(I == 0 || S[I-1] >= 32) continue;
10538: }
10539: if(Fr && S[I]>=48 && S[I]<=57){ /* 2/3 -> \tfrac{2}{3} */
10540: for(K=0,II=I; II>=0; II--){
10541: if(S[II]>=48 && S[II]<=57) continue;
10542: if(S[II]==47){ /* / */
10543: if(K>0) break;
10544: K=II;
10545: }else break;
10546: }
10547: if(K>II+1){
10548: SS=cons(125,SS);
10549: for(J=I; J>K; J--) SS=cons(S[J],SS);
10550: if(AMSTeX){
10551: SS=cons(123,SS);SS=cons(125,SS);
10552: }else{
10553: for(J=[114,101,118,111,92];J!=[];J=cdr(J)) /* \over */
10554: SS=cons(car(J),SS);
10555: }
10556: for(J=K-1;J>II;J--) SS=cons(S[J],SS);
10557: SS=cons(123,SS);
10558: if(AMSTeX){
10559: J=(Fr==2)?[99,97,114,102,116,92]:[99,97,114,102,92];
10560: for(;J!=[];J=cdr(J)) /* \tfrac */
10561: SS=cons(car(J),SS);
10562: }
10563: I=II+1;
10564: }else{
10565: for(;I>II;I--) SS = cons(S[I], SS);
10566: I++;
10567: }
10568: continue;
10569: }
10570: SS = cons(S[I], SS);
10571: }
10572: SS=str_subst(SS,"\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
10573: Subst=getopt(subst);
10574: Sub0=["{asin}","{acos}","{atan}"];
10575: Sub1=["\\arcsin ","\\arccos","\\arctan "];
10576: if(type(Subst) == 4){
10577: Sub0=append(Sub0,Subst[0]);Sub1=append(Sub1,Subst[1]);
10578: }
10579: SS = str_subst(SS,Sub0,Sub1|raw=1);
10580: S = ltov(SS);
10581: L = length(S);
10582: SS = [];
10583: while(--L >= 0){
10584: if(S[I=L] == 125){
10585: while(--I >= 0 && S[I] == 125);
10586: J = 2*I - L;
10587: if(J >= 0 && S[I] != 123){
10588: for(K = J; K < I && S[K] == 123; K++);
10589: if(K == I){
10590: if(J-- <= 0 || S[J] < 65 || S[J] > 122 || (S[J] > 90 && S[J] < 97)){
10591: SS = cons(S[I],SS);
10592: L = J+1;
10593: continue;
10594: }
10595: }
10596: }
10597: }
10598: SS = cons(S[L],SS);
10599: }
10600: RT=getopt(root);
10601: for(Top=0;;Top++){ /* ((x+1))^{y} , 1/y=2,3,...,9 */
10602: #if 1
10603: P=str_str(SS,["))^","^{\\tfrac{1}"]|top=Top);
10604: if(P[0]<0) break;
10605: Sq=0;
10606: if(P[0]==0){
10607: P=P[1];
10608: if((Q=str_pair(SS,P,"(",")"|inv=1))<0||SS[Q+1]!=40) continue;
10609: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
10610: && SS[P+14]==125){
10611: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
10612: }
10613: F=2;
10614: }else{
10615: P=P[1];
10616: if(SS[P+12]!=125||(Sq=(SS[P+11]-48))<2||Sq>9) break;
10617: if(SS[P-1]==125){
10618: if((Q=str_pair(SS,P-2,"{","}"|inv=1))<0) break;
10619: if(Q>1&&SS[Q-1]==95){
10620: if((Q=tex_cuteq(SS,Q-2))<0) break;
10621: F=0;
10622: }else F=1;
10623: }else{
10624: if(!isalphanum(SS[Q=P-1]) || (Q=tex_cuteq(SS,Q))<0) break;
10625: F=0;
10626: }
10627: if(RT!=2&&P-Q>32) break;
10628: }
10629: #else
10630: if((P=str_str(SS,"))^"|top=Top))<0 || (Q=str_pair(SS,P,"(",")"|inv=1))<0) break;
10631: else F=2;
10632: Sq=0;
10633: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
10634: && SS[P+14]==125){
10635: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
10636: }
10637: #endif
10638: for(I=0,S=[];SS!=[];SS=cdr(SS),I++){
10639: if(I==Q){
10640: if(Sq){
10641: S=append([116,114,113,115,92],S);
10642: if(Sq>2) S=append([93,Sq+48,91],S);
10643: S=cons(123,S);
10644: if(F==2) SS=cdr(SS);
10645: else if(F==0) S=cons(car(SS),S);
10646: }else if(F==2&&P-Q==3){ /* (2)^x -> 2^x*/
10647: SS=cdr(SS);SS=cdr(SS);
10648: S=cons(123,S);S=cons(car(SS),S);S=cons(125,S);
10649: SS=cdr(SS);SS=cdr(SS);
10650: I+=3;
10651: }
10652: continue;
10653: }else if(I==P){
10654: if(Sq){
10655: if(F>0) S=cdr(S);
10656: S=cons(125,S);
10657: if(F==2) SS=cdr(SS);
10658: for(J=0;J<12;J++) SS=cdr(SS);
10659: }
10660: continue;
10661: }
10662: S=cons(car(SS),S);
10663: }
10664: SS=reverse(S);
10665: Top=P;
10666: }
10667: S=asciitostr(SS);
10668: if((K=getopt(ket))==1) S=texket(S);
10669: else if(K==2) S=texket(S|all=1);
10670: return S;
10671: }
10672:
10673: def smallmattex(S)
10674: {
10675: return str_subst(S,[["\\begin{pmatrix}","\\left(\\begin{smallmatrix}"],
10676: ["\\end{pmatrix}","\\end{smallmatrix}\\right)"],
10677: ["\\begin{Bmatrix}","\\left\\{\\begin{smallmatrix}"],
10678: ["\\end{Bmatrix}","\\end{smallmatrix}\\right\\}"],
10679: ["\\begin{bmatrix}","\\left[{\\begin{smallmatrix}"],
10680: ["\\end{bmatrix}","\\end{smallmatrix}\\right]"],
10681: ["\\begin{vmatrix}","\\left|\\begin{smallmatrix}"],
10682: ["\\end{vmatrix}","\\end{smallmatrix}\\right|"],
10683: ["\\begin{Vmatrix}","\\left\\|\\begin{smallmatrix}"],
10684: ["\\end{Vmatrix}","\\end{smallmatrix}\\right\\|"],
10685: ["\\begin{matrix}","\\begin{smallmatrix}"],
10686: ["\\end{matrix}","\\end{smallmatrix}"]],0);
10687: }
10688:
10689:
10690: def divmattex(S,T)
10691: {
10692: TF=["matrix","pmatrix","Bmatrix","bmatrix","vmatrix","Vmatrix"];
10693: TG=[0,"(","\\{","[","|","\\|"];
10694: TH=[0,")","\\}","]","|","\\|"];
10695: if(type(S)!=7) S=mtotex(S);
10696: S=strtoascii(S0=S);
10697: if((P0=str_str(S,"\\begin{"))<0 || (P1=str_str(S,"}"|top=P0+7))<0)
10698: return S0;
10699: F=str_cut(S,P0+7,P1-1);
10700: if((K=findin(F,TF))<0) return S0;
10701: Q=str_str(S,"\\end{"+F+"}");
10702: if(Q<0) return S0;
10703: for(J=P1+1;S[J]<33;J++);
10704: for(L0=L=[],I=J;J<Q;J++){
10705: if(S[J]==38){ /* & */
10706: if(I>=J) L0=cons(0,L0);
10707: else L0=cons(str_cut(S,I,J-1),L0);
10708: I=J+1;
10709: }
10710: if(S[J]==92&&S[J+1]==92){ /* \\ */
10711: if(I>=J) L0=cons(0,L0);
10712: else L0=cons(str_cut(S,I,J-1),L0);
10713: L=cons(reverse(L0),L);
10714: L0=[];
10715: J++;
10716: for(I=J+1;S[I]<33;I++);
10717: }
10718: }
10719: J--;
10720: if(S[J]<33) J--;
10721: if(I<=J) L0=cons(str_cut(S,I,J),L0);
10722: if(length(L0)>0) L=cons(reverse(L0),L);
10723: L=lv2m(reverse(L)); /* get matrix */
10724: if(T==0) return L;
1.26 takayama 10725: if(type(T)==1) T=[T];
1.6 takayama 10726: Size=size(L);S0=Size[0];
10727: if(type(T[0])!=4){
10728: S1=Size[1];
10729: T=append(T,[S1]);
10730: for(TT=[],I=0;T!=[];T=cdr(T)){
10731: J=car(T);
10732: if(J>S1) J=S1;
10733: for(T0=[];J>I;J--) T0=cons(J-1,T0);
10734: if(T0!=[]) TT=cons(T0,TT);
10735: I=car(T);
10736: }
10737: T=reverse(TT);
10738: }
10739: SS=length(T);
10740: St=str_tb(0,0);
10741: if(SS==1) St=str_tb("\\begin{"+F+"}\n",St);
10742: else{
10743: if(K>0) St=str_tb("&\\left"+TG[K],St);
10744: St=str_tb("\\begin{matrix}\n",St);
10745: }
10746: for(;T!=[];T=cdr(T)){
10747: for(I=0;I<S0;I++){
10748: for(J=0,TT=car(T);TT!=[];TT=cdr(TT),J++){
10749: if(J>0) St=str_tb("&",St);
10750: if(L[I][car(TT)]!=0) St=str_tb(L[I][car(TT)],St);
10751: }
10752: if(I<S0-1) St=str_tb("\\\\",St);
10753: St=str_tb("\n",St);
10754: }
10755: if(length(T)>1)
10756: St=str_tb("\\end{matrix}\\right.\\\\\n&\\quad\\left.\\begin{matrix}\n",St);
10757: else{
10758: if(SS==1) St=str_tb("\\end{"+F+"}\n",St);
10759: else St=str_tb("\\end{matrix}\\right"+TH[K]+"\n",St);
10760: }
10761: }
10762: S=str_tb(0,St);
10763: if(SS==1) return S;
10764: return texbegin("align*",S);
10765: }
10766:
10767: def str_subst(S, L0, L1)
10768: {
10769: if(type(S) == 7)
10770: S = strtoascii(S);
10771: if(type(S) == 4)
10772: S = ltov(S);
10773: SE = length(S);
10774: if(L1 == 0){
10775: for(L1 = L = [], L0 = reverse(L0); L0 != []; L0 = cdr(L0)){
10776: L = cons(car(L0)[0], L);
10777: L1 = cons(car(L0)[1], L1);
10778: }
10779: L0 = L;
10780: }
10781: if(type(L0)==7) L0 = [strtoascii(L0)];
10782: else{
10783: for(LT = []; L0 != []; L0 = cdr(L0))
10784: LT = cons(strtoascii(car(L0)), LT);
10785: L0 = ltov(LT);
10786: }
10787: E0 = length(L0);
10788: if(type(L1)==7) L1 = [strtoascii(L1)];
10789: else{
10790: for(LT = []; L1 != []; L1 = cdr(L1))
10791: LT = cons(strtoascii(car(L1)), LT);
10792: L1 = ltov(LT);
10793: }
10794: if(getopt(inv)==1){
10795: L2=L0;L0=L1;L0=L2;
10796: }
10797: if((SJIS=getopt(sjis))!=1) SJIS=0;
10798: for(J = JJ = 0, ST = []; J < SE; J++){
10799: SP = S[J];
10800: for(I = E0-1; I >= 0; I--){
10801: if(SP != L0[I][0] || J + (K = length(L0[I])) > SE)
10802: continue;
10803: while(--K >= 1)
10804: if(L0[I][K] != S[J+K]) break;
10805: if(K > 0) continue;
10806: for(KE = length(L1[I]), K = 0 ;K < KE; K++)
10807: ST = cons(L1[I][K],ST);
10808: J += length(L0[I])-1;
10809: break;
10810: }
10811: if(I < 0){
10812: ST = cons(S[J],ST);
10813: if(SJIS && (V=S[J])>128){
10814: if(V<160 || (V>223 && V<240)) ST = cons(S[J++],ST);
10815: }
10816: }
10817: }
10818: if(getopt(raw)==1) return reverse(ST);
10819: return asciitostr(reverse(ST));
10820: }
10821:
10822: def dviout0(L)
10823: {
10824: Cmd=["TikZ","TeXLim","TeXEq","DVIOUT","XYPrec","XYcm","XYLim","Canvas"];
10825: if(type(Opt=getopt(opt))==7){
10826: if((F=findin(Opt,Cmd)) < 0) return -1;
10827: if(L==-1){
10828: if(F<=3){
10829: if(F==0) V=TikZ;
10830: else if(F==1) V=TeXLim;
10831: else if(F==2) V=TeXEq;
10832: else V=iand(DVIOUTF,1);
10833: }else{
10834: if(F==4) V=XYPrec;
10835: else if(F==5) V=XYcm;
10836: else if(F==6) V=XYLim;
10837: else V=Canvas;
10838: }
10839: return V;
10840: }
10841: if(F==0) TikZ=L;
10842: else if(F==2) TeXEq=L;
10843: else if(F==3){
10844: if(iand(DVIOUTF,1)==L)
10845: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
10846: else dviout0(4);
10847: return 1;
10848: }else if(F==7&&type(L)==4)
10849: Canvas=L;
10850: else if(L>0){
10851: if(F==1) TeXLim=L;
10852: else if(F==4) XYPrec=L;
10853: else if(F==5) XYcm=L;
10854: else if(F==6) XYLim=L;
10855: }
10856: mycat0([Cmd[F],"=",L],1);
10857: return 1;
10858: }
10859: if(type(L) == 4){
10860: for( ; L != []; L = cdr(L)) dviout0(car(L));
10861: return 1;
10862: }
10863: if(type(L) == 7){
10864: if(L=="") dviout(" \n"|keep=1);
10865: else if(L=="cls") dviout0(0);
10866: else if(L=="show") dviout(" ");
10867: else if(L=="?") dviout0(3);
10868: else dviout("\\"+L+"\n"|keep=1);
10869: return 1;
10870: }
10871: if(L == 0)
10872: dviout(" "|keep=1,clear=1);
10873: else if(L == 1)
10874: dviout(" ");
10875: else if(L == 2)
10876: dviout(" "|clear=1);
10877: else if(L>10)
10878: dviout("\\setcounter{MaxMatrixCols}{"+rtostr(L)+"}%"|keep=1);
10879: else if(L < 0)
10880: dviout(" "|delete=-L,keep=1);
10881: else if(L == 3){
10882: mycat0(["DIROUT =\"", DIROUT,"\""],1);
10883: mycat0(["DVIOUTH=\"", DVIOUTH,"\""],1);
10884: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
10885: mycat0(["DVIOUTB=\"", DVIOUTB,"\""],1);
10886: mycat0(["DVIOUTL=\"", DVIOUTL,"\""],1);
10887: mycat(["Canvas =", Canvas]);
10888: mycat(["TeXLim =", TeXLim]);
10889: mycat(["TeXEq =", TeXEq]);
10890: mycat(["AMSTeX =", AMSTeX]);
10891: mycat(["TikZ =", TikZ]);
10892: mycat(["XYPrec =", XYPrec]);
10893: mycat(["XYcm =", XYcm]);
10894: mycat(["XYLim =", XYLim]);
10895: }else if(L==4){
10896: Tmp=DVIOUTA; DVIOUTA=DVIOUTB; DVIOUTB=Tmp;
10897: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
10898: DVIOUTF++;
10899: }else if(L==5){
10900: if(!iand(DVIOUTF,1)) dviout0(4);
10901: }else if(L==6){
10902: TikZ=1;mycat("TikZ=1");
10903: }else if(L==7){
10904: TikZ=0;mycat("TikZ=0");
10905: }
10906: return 1;
10907: }
10908:
10909: def myhelp(T)
10910: {
10911: /* extern DVIOUT; */
10912: /* extern HDVI; */
10913: /* extern DVIOUTH; */
10914:
10915: if(type(T)==2){
10916: if(T==getbygrs){
10917: getbygrs(0,0);
10918: return 0;
10919: }
10920: else if(T==m2mc){
10921: m2mc(0,0);
10922: return 0;
10923: }
10924: else if(T==mgen){
10925: mgen(0,0,0,0);
10926: return 0;
10927: }
10928: else T=rtostr(T);
10929: }
10930: if(type(T)==4 && typeT[0]==7){
10931: if(length(T)==2 && type(T[1])==1){
10932: DVIOUTH="start "+T[0]+" -"+rtostr(T[1])+"-hyper:0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #r:%LABEL%";
10933: }else if(str_len(T[0])>2) DVIOUTH=T[0];
10934: mycat(["DVIOUTH="+DVIOUTH,"\nmyhelp(fn) is set!"]);
10935: return 0;
10936: }
10937: if(T==0){
10938: mycat([
10939: "myhelp(t) : show help\n",
10940: #ifdef USEMODULE
10941: " t : -1 (dvi), 1 (pdf) or os_md.getbygrs, os_md.m2mc, os_md.mgen\n",
10942: #else
10943: " t : -1 (dvi), 1 (pdf) or getbygrs, m2mc, mgen\n",
10944: #endif
10945: " \"fn\" : Help of the function fn\n",
10946: " [path,n] : path of dviout, n = # dviout\n",
10947: " [DVIOUTH] : Way to jump to the help of a function\n",
10948: " default: start dviout -2 \"%ASIRTOOT%\\help\\os_muldif.dvi\" #r:%LABEL%"
10949: ]);
10950: return 0;
10951: }
10952: if(type(T)==7){
10953: if(str_str(T,"os_md.")==0) T=str_cut(T,6,str_len(T)-1);
10954: Dr=str_subst(DVIOUTH,["%ASIRROOT%","%LABEL%"],[get_rootdir(),"r:"+str_subst(T,"_","")]);
10955: shell(Dr);
10956: return 0;
10957: }
10958: Dr=get_rootdir();
10959: if(T==-1) Dr+="\\help\\os_muldif.dvi";
10960: else Dr+="\\help\\os_muldif.pdf";
10961: if(!isMs()) Dr=str_subst(Dr,"\\","/");
10962: shell(Dr);
10963: return 0;
10964: }
10965:
10966: def isMs()
10967: {
10968: if(type(Tmp=getenv("TEMP"))!=7) {
10969: if (type(Tmp=getenv("TMP")) != 7) Tmp=getenv("HOME");
10970: }
10971: if(type(Tmp)==7 && str_chr(Tmp,0,"\\")==2) return 1;
10972: else return 0;
10973: }
10974:
10975: def tocsv(L)
10976: {
10977: if(type(L)==6) L=m2ll(L);
10978: else if(type(L)==5) L=vtol(L);
10979: Null=getopt(null);
10980: Tb=str_tb(0,0);
10981: for(LL=L; LL!=[]; LL=cdr(LL)){
10982: LT=car(LL);
10983: if(type(LT)==5) LT=vtol(LT);
10984: if(type(LT)<4) LT=[LT];
10985: for(N=0; LT!=[]; LT=cdr(LT),N++){
10986: if(N) str_tb(", ",Tb);
10987: if((T=car(LT))==Null) continue;
10988: if(type(T)==7){
10989: K=str_len(T);
10990: T=str_subst(T,["\""],["\"\""]);
10991: if(str_len(T)>K||str_char(T,0,",")>=0) T="\""+T+"\"";
10992: str_tb(T,Tb);
10993: }else str_tb(rtostr(T),Tb);
10994: }
10995: str_tb("\n",Tb);
10996: }
1.16 takayama 10997: S=str_tb(0,Tb);
10998: if(type(EXE=getopt(exe))!=1&&EXE!=0&&type(EXE)!=7) return S;
10999: if(type(F)!=7){
1.18 takayama 11000: fcat(-1,0);
1.16 takayama 11001: F="risaout";
11002: if(EXE>=2&&EXE<=9) F+=rtostr(EXE);
11003: F=DIROUTD+F+".csv";
11004: }else F=S;
11005: if(EXE!=0 && access(F)) remove_file(F);
11006: fcat(F,S|exe=1);
11007: return 1;
1.6 takayama 11008: }
11009:
11010: def readcsv(F)
11011: {
11012: if((ID=open_file(F))<0) return -1;
11013: SJIS=isMs();
11014: L=[];
11015: if(type(V=getopt(eval))!=4){
11016: if(V=="all") V=1;
11017: else if(type(V)==1) V=[V];
11018: else V=[];
11019: }
1.9 takayama 11020: Eq=getopt(eq);
1.6 takayama 11021: Sp=getopt(sp);
11022: if(type(T=getopt(col))!=1) T=0;
11023: Null=getopt(null);
1.9 takayama 11024: if(type(Null)<0) Null=(Eq==1)?0:"";
1.6 takayama 11025: while((S=get_line(ID))!=0){
11026: S=strtoascii(S);
11027: N=length(S);
11028: for(I=J=F=0,LL=LT=[];I<N;I++){
11029: C=S[I];
11030: if(F==0){
11031: if(C<=32) continue;
11032: if(C==34){F=2;continue;}
11033: F=1;
11034: }
11035: if(F==2 && C==34){
11036: if(I<N-1&& S[I+1]==34){
11037: LT=cons(34,LT);I++;continue;
11038: }
11039: F=-2;
11040: }
11041: if(F==1){
11042: if((C==44&&Sp!=1)||(C<=32&&Sp==1)) F=-1;
11043: else if(C<32 && C!=9) continue;
11044: }
11045: if(SJIS && I<N-1 && ((C>128 && C<160)||(C>223 && C<240))){
11046: LT=cons(C,LT);LT=cons(S[++I],LT);continue;
11047: }
11048: if(F>0){
11049: LT=cons(C,LT);continue;
11050: }
11051: LS=asciitostr(reverse(LT));
1.9 takayama 11052: if(V==1||findin(++J,V)>=0){
11053: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
11054: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
11055: }
1.6 takayama 11056: if(!T || T==J) LL=cons(LS,LL);
11057: if(F==-2) while(++I<N && Sp!=1 && S[I]!=44);
11058: F=0;LT=[];
11059: }
11060: if(I<=N && (Sp!=1 || length(LT)>0)){ /* lastline */
11061: LS=asciitostr(reverse(LT));
1.9 takayama 11062: if(V==1||findin(++J,V)>=0){
11063: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
11064: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
11065: }
1.6 takayama 11066: if(!T || T==J) LL=cons(LS,LL);
11067: }
11068: L=cons(reverse(LL),L);
11069: }
11070: close_file(ID);
11071: if(T) L=m2l(L|flat=1);
1.16 takayama 11072: L=reverse(L);
11073: return L;
1.6 takayama 11074: }
11075:
11076: def showbyshell(S)
11077: {
11078: Id = getbyshell(S);
11079: if(Id<0) return Id;
11080: while((S=get_line(Id))!=0) print(S,2);
11081: return close_file(Id);
11082: }
11083:
11084:
11085: def getbyshell(S)
11086: {
11087: /* extern DIROUT; */
11088:
11089: Home=getenv("HOME");
11090: if(type(Home)!=7) Home="";
11091: if(type(Tmp=getenv("TEMP"))!=7 && type(Tmp=getenv("TMP")) != 7)
11092: Tmp=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
11093: Sep=isMs()?"\\":"/";
11094: F=Tmp+Sep+"muldif.tmp";
1.16 takayama 11095: if(type(S)<=1 && S>=0) close_file(S);
1.6 takayama 11096: remove_file(F);
11097: if(type(S)<=1) return -1;
11098: shell(S+" > \""+F+"\"");
11099: return open_file(F);
11100: }
11101:
11102: def show(P)
11103: {
11104: T=type(P);
11105: S=P;
11106: Var=getopt(opt);
11107: if(Var=="verb"){
11108: dviout("{\\tt"+verb_tex_form(T)+"}\n\n");
11109: return;
11110: }
11111: if(type(Var)<0) Var=getopt(var);
11112: if(T==6){
11113: if((Sp=getopt(sp))==1 || Sp==2)
11114: S=mtotex(P|lim=1,small=2,sp=Sp,null=1,mat="B");
11115: else if(type(Var)==4 || type(Var)==7)
11116: S=mtotex(P|lim=1,small=2,var=Var);
11117: else
11118: S=mtotex(P|lim=1,small=2);
11119: Size=size(P);
11120: Size=(Size[0]>Size[1])?Size[0]:Size[1];
11121: if(Size>10) dviout0(Size);
11122: }else if(T<=3){
11123: X=0;
11124: if(Var=="pfrac") X=var(P);
11125: else X=getopt(pfrac);
11126: if(isvar(X)){
11127: pfrac(P,X|dviout=1);
11128: return;
11129: }
11130: Opt=cons(["dviout",1],getopt());
11131: if(type(Var)==2||type(Var)==4||type(Var)==7) fctrtos(P|option_list=Opt);
11132: else{
11133: if(isdif(P)!=0) Opt=cons(["var","dif"],Opt);
11134: else Opt=cons(["br",1],Opt);
11135: fctrtos(P|option_list=Opt);
11136: }
11137: return;
11138: }else if(T==4){
11139: if(type(Var)==4 || type(Var)==7){
11140: S=ltotex(P|option_list=getopt());
11141: if(Var=="text"){
11142: dviout(S);
11143: return;
11144: }
11145: }else{
11146: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
11147: LL=car(L);
11148: if(type(LL)==4){
11149: if(F==0){
11150: T=type(LL[0]);
11151: if(T==4) F=2; /* [[[? */
11152: else if(T==1 || T==0) F=1; /* [[num,.. */
11153: }
11154: if(F==1){
11155: if(length(LL)!=2 || !isint(LL[0]) || LL[0]<0 || type(LL[1])>3)
11156: F=-1; /* [[num,rat],[num,rat],...] */
11157: }else if(F==2){
11158: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
11159: LLL=car(LLT); /* [[[num,rat],[num,rat],...],[[..],..]],....] */
11160: if(length(LLL)!=2 || !isint(LLL[0]) || LLL[0]<0 || type(LLL[1])>3)
11161: F=-1;
11162: }
11163: }
11164: }else if((F==0 || F==7) && type(LL)==7){
11165: F=7;
11166: }else F=-1;
11167: }
11168: if(F==1) S=ltotex(P|opt="spt");
11169: else if(F==2){
11170: M=mtranspose(lv2m(S));
11171: show(M|sp=1); /* GRS */
11172: return;
11173: }else if(F==7) S=ltotex(P|opt="spts");
11174: else{
11175: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
11176: LL=car(L);
11177: if(type(LL)!=4){
11178: F=-1; break;
11179: }
11180: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
11181: T=type(LLL=car(LLT));
11182: if(T<7 && T!=4) F0++;
11183: else if(T==7){
11184: if(str_char(LLL,0,"\\")<0) F1++;
11185: else F2++;
11186: }else F=-1;
11187: }
11188: }
11189: }
11190: if(F==0 && F0>0 && (F1+F2)>0){ /* list of list of eq and str */
11191: if(F2>0) S=ltotex(P|opt=["cr","spts0"],str=1);
11192: else S=ltotex(P|opt=["cr","spts"]);
11193: }else{
11194: for(S="[";;){
11195: S+=my_tex_form(car(P));
11196: if((P=cdr(P))==[]){
11197: S+="]";break;
11198: }
11199: S+=",";
11200: }
11201: }
11202: }
11203: }else if(T==7){
11204: if(Var=="raw" ||
11205: (Var !="eq" && str_chr(P,0,"\\")<0 && str_char(P,0,"^")<0 && str_char(P,0,"_")<0
11206: && str_char(P,0,"&")<0)){
11207: dviout(P+"\n\n");
11208: return;
11209: }
11210: }
11211: dviout(S|eq=5);
11212: }
11213:
11214:
11215: /* options : eq = 1 - 8, clear=1, keep=1, delete=1, title=s,
11216: fctr=1, begin=s */
11217: def dviout(L)
11218: {
11219: /* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTB, DVIOUTL; */
11220:
11221: MyEq = [
11222: ["\\[\n ","\\]"],
11223: ["\\begin{align}\n","\\end{align}"],
11224: ["\\begin{gather}\n ","\\end{gather}"],
11225: ["\\begin{multline}\n ","\\\\[-15pt]\\end{multline}"],
11226: ["\\begin{align}\\begin{split}\n &","\\end{split}\\end{align}"],
11227: ["\\begin{align*}\n &","\\end{align*}"],
11228: ["\\begin{gather*}\n ","\\end{gather*}"],
11229: ["\\begin{equation}\n ","\\end{equation}"]
11230: ];
11231: if(!chkfun("print_tex_form", "names.rr"))
11232: return 0;
11233: Home=getenv("HOME");
11234: if(type(Home)!=7) Home="";
11235: Dir=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],[Home,get_rootdir(),"/"]);
11236: Dirout=Dir+(AMSTeX?"/out.tex":"/out0.tex");
11237: Risaout=(AMSTeX)?"risaout":"risaout0";
11238: Dirisa=Dir+"/"+Risaout+".tex";
11239: Viewer="dviout";
11240: SV=["c:/w32tex/dviout","c:/dviout"];
11241: Risatex=str_subst(AMSTeX?DVIOUTA:DVIOUTL,
11242: ["%HOME%","%ASIRROOT%","%TikZ%"],[Home,get_rootdir(),rtostr(TikZ)]);
11243: if(isMs() && !access(Risatex)){
11244: for(TV=SV; TV!=[]; TV=cdr(TV)){
11245: VV=car(TV)+"/dviout.exe";
11246: if(access(VV)){
11247: Viewer=str_subst(VV,"/","\\");
11248: break;
11249: }
11250: }
11251: output(Risatex);
11252: print("cd \""+str_subst(Dir,"/","\\")+"\"");
11253: print("latex -src=cr,display,hbox,math,par "+Risaout);
11254: print("start "+Viewer+" -1 \""+Dr+"\\tex\\"+Risaout+"\" 1000");
11255: output();
11256: }
11257: if(access(Dirisa) == 0){
11258: D0="\""+(isMs()?str_subst(Dir,"/","\\")+"\"":Dir);
11259: shell("mkdir "+D0);
11260: output(Dirisa);
11261: if(AMSTeX){
11262: print("\\documentclass[a4paper]{amsart}");
11263: print("\\usepackage{amsmath,amssymb,amsfonts}");
11264: }else
11265: print("\\documentclass[a4paper]{article}");
11266: print("\\pagestyle{empty}\n\\begin{document}\n\\thispagestyle{empty}");
11267: print(AMSTeX?"\\input{out}\n\\end{document}":"\\input{out0}\n\\end{document}");
11268: output();
11269: }
11270: if((K = getopt(delete)) >= 1){ /* delete */
11271: LC = 0;
11272: if(type(K) == 1 && K > 10) K = 10;
11273: if(type(K) == 4){
11274: K = qsort(K);
11275: LC = 1; /* specific lines */
11276: }
11277: Done = 1;
11278: Id = open_file(Dirout);
11279: if(Id >= 0){
11280: Buf = Buf0 = Buf1 = Key = "";
11281: PE = 0;
11282: if(type(K) == 1)
11283: BufE = newvect(K--);
11284: Dout = Dirout+"0";
11285: remove_file(Dout);
11286: output(Dout);
11287: while((S = get_line(Id)) != 0){
11288: if(LC){
11289: while(K != [] && car(K) < LC)
11290: K = cdr(K);
11291: if(K == [] || car(K) > LC)
11292: output(S);
11293: }
11294: if(Key == ""){
11295: if((P0 = str_str(S,"\\begin{")) == 0){
11296: Key = sub_str(S,7,str_str(S,"}")-1);
11297: if(findin(Key,["align", "gather","multline", "equation","align*"]) < 0)
11298: Key = "";
11299: else{
11300: Key = "\\end{"+Key+"}";
11301: if(!LC){
11302: if(Buf != ""){
11303: if(PE < K)
11304: BufE[PE++] = Buf1+Buf;
11305: else{
11306: if(K > 0){
11307: print(BufE[0]);
11308: for(I = 1; I < K; I++)
11309: BufE[I-1]=BufE[I];
11310: BufE[K-1] = Buf1+Buf;
11311: }else
11312: print(Buf1+Buf);
11313: Done = 0;
11314: }
11315: Buf1 = Buf0;
11316: Buf = Buf0 ="";
11317: }
11318: }
11319: }
11320: }
11321: if(Key == "" && !LC) Buf0 += S;
11322: }
11323: if(Key != ""){
11324: if(!LC) Buf += S;
11325: if(str_str(S,Key) >= 0){
11326: Key = "";
11327: if(LC) LC++;
11328: }
11329: }
11330: }
11331: output();
11332: close_file(Id);
11333: }
11334: if(Done==0){
11335: Id = open_file(Dout);
11336: if(Id >= 0){
11337: remove_file(Dirout);
11338: output(Dirout);
11339: while((S = get_line(Id)) != 0)
11340: print(S,0);
11341: output();
11342: close_file(Id);
11343: }
11344: remove_file(Dout);
11345: }else L=" ";
11346: }
11347: if(getopt(clear) == 1 || Done == 1){ /* clear */
11348: remove_file(Dirout);
11349: if(L == "" || L == " "){
11350: output(Dirout);
11351: print("\\centerline{Risa/Asir}");
11352: output();
11353: }
11354: }
11355: if(L != " "){
11356: Eq=1;
11357: Eqo = getopt(eq);
11358: Fc = getopt(fctr);
11359: if(Fc == 1 && (type(L) == 2 || type(L) == 3)){
11360: L = fctrtos(L|TeX=1);
11361: if(type(L) == 4)
11362: L = "\\fact{"+L[0]+"}{"+L[1]+"}";
11363: if(type(Eqo) != 0 && type(Eqo) !=7){
11364: Eqo=0;
11365: }
11366: }
11367: if(type(L) != 4 || getopt(mult) != 1)
11368: L = [L];
11369: if(type(Eqo)!=7 && (Eqo<1 || Eqo>8))
11370: Eqo = (AMSTeX==1)?TeXEq:1;
11371: Title = getopt(title);
11372: if(type(Title) == 7){
11373: output(Dirout);
11374: print(Title);
11375: output();
11376: }
11377: Sb = getopt(subst);
11378: for( ; L != []; L = cdr(L)){
11379: Eq = 1;
11380: if(type(LT=car(L)) != 7 && type(LT) != 21)
11381: LT = my_tex_form(LT);
11382: else if(type(getopt(eq)) < 0)
11383: Eq = 0;
11384: if(type(Sb) == 4)
11385: LT = str_subst(LT,Sb[0],Sb[1]);
11386: output(Dirout);
11387: if(Eq == 1){
11388: if(type(Eqo)==7)
11389: print(texbegin(Eqo,LT));
11390: else if(Eqo >= 1 && Eqo <= 8){
11391: mycat0([MyEq[Eqo-1][0],LT,"%"],1);
11392: print(MyEq[Eqo-1][1]);
11393: }else print(LT);
11394: }else print(LT);
11395: output();
11396: }
11397: }
11398: if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTB,0," ")<0
11399: && str_char(DVIOUTL,0," ")<0)
11400: Risatex="\""+Risatex+"\"";
11401: if(getopt(keep) != 1) shell(Risatex);
11402: return 1;
11403: }
11404:
11405: def rtotex(P)
11406: {
11407: S = my_tex_form(P);
11408: return (str_len(S) == 1)?S:"{"+S+"}";
11409: }
11410:
11411: def mtotex(M)
11412: {
11413: /* extern TexLim; */
11414:
11415: MB=mat(["(",")","p"],["\\{","\\}","B"],["[","]","b"],["|","|","v"],
11416: ["\\|","\\|","V"], [".",".",""]);
11417: if(type(MT=getopt(mat))==7){
11418: MT=findin(MT,["p","B","b","v","V",""]);
11419: if(MT<0) MT=0;
11420: }
11421: else MT=0;
11422: MT=MB[MT];
11423: if((F=getopt(small))!=1 && F!=2) F=0;
11424: Lim=getopt(lim);
11425: if(type(Lim)==1){
11426: if(Lim<30 && Lim!=0) Lim = TexLim;
11427: }else Lim=0;
11428: FL=getopt(len);
11429: Rw=getopt(raw);
11430: Sp=getopt(sp);
11431: Idx=getopt(idx);
11432: if(type(Idx)==4) Idx=ltov(Idx);
11433: if(type(Idx)==6 && length(Idx)==0) Idx=-1;
11434: Var=getopt(var);
11435: if(Lim>0) FL=1;
11436: Null=getopt(null);
11437: if(Null!=1 && Null!=2) Null=0;
11438: if(type(M)==5) M=lv2m([V]);
11439: else if(type(M)!=6) return monototex(M);
11440: S=size(M);
11441: if(FL==1){
11442: L=newmat(S[0],S[1]); LL=newvect(S[1]);
11443: }
11444: SS=newmat(S[0],S[1]);
11445: for(I=0; I<S[0]; I++){
11446: for(J=0; J<S[1]; J++){
11447: if(type(P=M[I][J])<=3){
11448: if(P!=0 || Null == 0 || (Null==2 && I==J)){
11449: SS[I][J]=(type(Var)>1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0);
11450: if(type(P)==1 && str_str(SS[I][J],"\\frac{-"|end=0)==0)
11451: SS[I][J]="-\\frac{"+str_cut(SS[I][J],7,100000);
11452: }
11453: }else if(type(P)==6){
11454: ST= mtotex(P|small=1,len=1);
11455: SS[I][J]=ST[0];
11456: L[I][J]=ST[1];
11457: }else if(type(P)==7){
11458: if(Rw==1) SS[I][J]=P;
11459: else SS[I][J]="\\text{"+P+"\}";
11460: }else if(type(P)==4 && length(P)==2 && P[0]>0 && (Sp==1 || Sp==2)){
11461: if(P[0]==1){
11462: SS[I][J]=fctrtos(P[1]|TeX=2,lim=0);
11463: }else{
11464: ST=my_tex_form(P[0]);
11465: if(Sp==2) ST="("+ST+")";
11466: SS[I][J]="["+fctrtos(P[1]|TeX=2,lim=0)+"]_";
11467: if(str_len(ST)<2) SS[I][J]+=ST;
11468: else SS[I][J]+="{"+ST+"}";
11469: }
11470: }else
11471: SS[I][J]=my_tex_form(P);
11472: if(FL==1) L[I][J]=texlen(SS[I][J]);
11473: }
11474: }
11475: if(Lim>0 || FL==1){
11476: for(LLL=J=0; J<S[1];J++){
11477: for(I=K=0; I<S[0];I++){
11478: if(K<L[I][J]) K=L[I][J];
11479: }
11480: LLL+=(LL[J]=K);
11481: }
11482: }
11483: if(Lim>0){
11484: if(F==2 && LLL>Lim-2*S[1]-2) F=1;
11485: if(F==1)
11486: Lim=idiv(Lim*6,5);
11487: if(LLL<=Lim-(2-F)*S[I]-2) Lim=0;
11488: }
11489: Mat=(F==1)?"smallmatrix}":"matrix}";
11490: if(F==1) Out=str_tb("\\left"+MT[0]+"\\begin{",0);
11491: else Out=str_tb((Lim==0)?"\\begin{"+MT[2]:"\\left"+MT[0]+"\\begin{",0);
11492: Out = str_tb(Mat,Out);
11493: for(I=II=LT=0; II<=S[0]; II++){
11494: if(Lim==0) II=S[0];
11495: if(II<S[0]){
11496: K=LL[II]+(2-F);
11497: if(I==II){
11498: LT+=K;
11499: continue;
11500: }
11501: if(LT+K<Lim-2) continue;
11502: LT=K;
11503: }
11504: for(I0=I; I<II; I++){
11505: if(I==I0){
11506: str_tb((I==0)?
11507: "\n ":
11508: "\\right.\\\\\n \\allowdisplaybreaks\\\\\n &\\ \\left.\\begin{"+Mat+"\n ", Out);
11509: if(Idx==1||Idx==0||type(Idx)==5){
11510: for(J=I; J<II; J++){
11511: if(type(Idx)!=4)
11512: str_tb("("+rtostr(J+Idx)+")",Out);
11513: else{
11514: JJ=length(Idx)-1;
11515: if(J<JJ) JJ=J;
11516: str_tb(my_tex_form(Idx[JJ]),Out);
11517: }
11518: if(J<II) str_tb(" & ",Out);
11519: }
11520: str_tb("\\\\\n ",Out);
11521: }
11522: }
11523: else str_tb("\\\\\n ",Out);
11524: for(J=0; J<S[1]; J++){
11525: if(J!=0) str_tb(" & ",Out);
11526: if(type(SS[I][J])==7) str_tb(SS[I][J],Out);
11527: }
11528: }
11529: Out=str_tb("\n\\end{", Out);
11530: if(II==S[0]) Out=str_tb((Lim==0&&F!=1)?MT[2]+Mat:Mat+"\\right"+MT[1],Out);
11531: else Out=str_tb(Mat+"\\right.",Out);
11532: }
11533: SS = str_tb(0,Out);
11534: if(FL!=1) return SS;
11535: if(F==1) LLL=idiv((LLL+S[1])*5+13,6);
11536: else LLL+=2*(1+S[1]);
11537: return [SS,LLL];
11538: }
11539:
11540: def sint(N,P)
11541: {
1.11 takayama 11542: if( type(N)==1 || N==0 ) {
1.6 takayama 11543: NT=ntype(N);
11544: if((type(Opt=getopt(str))==1 || Opt==0) && Opt>=0 && P>=0){
11545: if(Opt==2 || Opt==4 || Opt==0){
1.11 takayama 11546: if(N==0) return (Opt>0)?"0":0;
1.6 takayama 11547: Pw=0;
11548: if(NT==4){
11549: NN=abs(real(N));N1=abs(imag(N));
11550: if(NN<N1) NN=N1;
11551: }else NN=abs(N);
11552: while(NN<1 && NN>-1){
11553: Pw--;
11554: N*=10;NN*=10;
11555: }
11556: while(N>=10 || N<=-10){
11557: Pw++;
11558: N/=10;NN/=10;
11559: }
11560: if(Opt==0) return sint(N*10^Pw,P-Pw-1);
11561: S=(getopt(sqrt)==1)?sint(N,P|str=(Opt==4)?3:1,sqrt=1):sint(N,P|str=(Opt==4)?3:1);
11562: if(Pw==0) return S;
11563: if(NT==4)
11564: S="("+S+")";
11565: if(Pw==1){
11566: if(Opt==2)
11567: return S+"*10";
11568: else
11569: return S+"\\times10";
11570: }
11571: if(Opt==2)
11572: return S+"*10^("+rtostr(Pw)+")";
11573: else
11574: return S+"\\times10^{"+rtostr(Pw)+"}";
11575: }
11576: if(NT==4){
11577: NN=real(N);
11578: if(NN!=0){
11579: S=sint(NN,P|str=1);
11580: if(imag(N)>0) S=S+"+";
11581: }
11582: else S="";
11583: S=S+sint(imag(N),P|str=1)+((Opt==3)?((getopt(sqrt)==1)?"\\sqrt{-1}":"i"):"@i");
11584: return S;
11585: }
11586: if(N<0){
11587: N=-N;
11588: Neg="-";
11589: }else Neg="";
1.11 takayama 11590: N=rint(N*10^P)/10^P;
1.6 takayama 11591: NN=floor(N);
1.11 takayama 11592: NV=(N-NN+1)*10^P;
1.6 takayama 11593: NS=rtostr(NN);
11594: if(P<=0) return Neg+NS;
11595: if(NN==0 && getopt(zero)==0) NS="";
1.11 takayama 11596: return Neg+NS+"."+str_cut(rtostr(NV),1,P);
1.6 takayama 11597: }
11598: if(NT==4)
11599: return sint(real(N),P)+sint(imag(N),P)*@i;
11600: X = rint( N*10^P );
1.11 takayama 11601: return deval(X/10^P);
1.6 takayama 11602: }
11603: if( (type(N)==2) || (type(N)==3) ){
11604: NN = eval(N);
11605: if( type(NN)==1 )
11606: return sint(NN,P|option_list=getopt());
11607: else return N;
11608: }
1.8 takayama 11609: if( type(N)>3 && type(N) < 7)
1.6 takayama 11610: #ifdef USEMODULE
11611: return mtransbys(os_md.sint,N,[P]|option_list=getopt());
11612: #else
11613: return mtransbys(sint,N,[P]|option_list=getopt()));
11614: #endif
1.8 takayama 11615: return N;
1.6 takayama 11616: }
11617:
11618: def frac2n(N)
11619: {
11620: if((T=type(N))<0) return N;
11621: E=(getopt(big)==1)?eval(@e):0.1;
11622: if(T==1){
1.15 takayama 11623: if(ntype(N)==0) return (E*N)/E;
1.6 takayama 11624: else if(ntype(N)!=4) return N;
1.15 takayama 11625: else return (E*(1+@i)*N)/(E*(1+@i));
1.6 takayama 11626: }
11627: if(T==3||T==2){
11628: N=red(N);
11629: Nm=nm(N);Var=vars(Nm);V=car(Var);K=length(Var);
11630: for(S=0,I=mydeg(Nm,V);I>=0;I--) S+=frac2n(mycoef(Nm,I,V))*V^I;
11631: return S/dn(N);
11632: }
1.15 takayama 11633: if(T<4) return (E*N)/E;
1.6 takayama 11634: #ifdef USEMODULE
11635: return mtransbys(os_md.frac2n,N,[]|option_list=getopt());
11636: #else
11637: return mtransbys(frac2n,N,[]|option_list=getopt());
11638: #endif
11639: }
11640:
11641: def xyproc(F)
11642: {
11643: if(type(Opt=getopt(opt))!=7) Opt="";
11644: if(type(Env=getopt(env))!=7)
11645: Env=(!TikZ)?"xy":"tikzpicture";
11646: if(F==1)
11647: return(Opt=="")?"\\begin{"+Env+"}\n":"\\begin{"+Env+"}["+Opt+"]\n";
11648: if(F==0) return "\\end{"+Env+"}\n";
11649: if(type(F)==7){
11650: F=xyproc(1|opt=Opt,env=Env)+F+xyproc(0|env=Env);
11651: if(getopt(dviout)==1) dviout(F);
11652: else return F;
11653: }
11654: }
11655:
11656: def xypos(P)
11657: {
11658: if(type(P[0])==7){
11659: if(P[0]=="") S="";
11660: else S=(!TikZ)?"\""+P[0]+"\"":"("+P[0]+")";
11661: }
11662: else{
11663: if(TikZ==0 && XYcm==1){
11664: X=sint(P[0]*10,XYPrec); Y=sint(P[1]*10,XYPrec);
11665: }else{
11666: X=sint(P[0],XYPrec); Y=sint(P[1],XYPrec);
11667: }
11668: S="("+rtostr(X)+","+rtostr(Y)+")";
11669: }
11670: if(!TikZ){
11671: if(length(P)>2 && (PP=P[2])!=""){
11672: S=S+" *";
11673: if(type(PP)==4 && length(PP)==2 && type(PP[0])==7){
11674: S=S+PP[0];
11675: PP=PP[1];
11676: }
11677: if(type(PP)==7){
11678: L=str_len(PP);
11679: if(str_chr(PP,0,"$")==0 && str_chr(PP,L-1,"$")==L-1){
11680: PP=str_cut(PP,1,L-2);
11681: }else S+="\\txt";
11682: }
11683: else PP=my_tex_form(PP);
11684: S=S+"{"+PP+"}";
11685: }
11686: if(length(P)>3){
11687: if(type(P[3])==7 && P[3]!="") S=S+"=\""+P[3]+"\"";
11688: if(length(P)>4 && type(P[4])==7) S=S+P[4];
11689: }
11690: }else{
11691: T="";
11692: if(length(P)>2 && (PP=P[2])!=""){
11693: F=1;
11694: if(type(PP)==4){
11695: if(length(PP)==2 && type(PP[0])==7){
11696: T="["+PP[0]+"]";
11697: PP=PP[1];
11698: }
11699: }
11700: if(type(PP)!=7) PP="$"+my_tex_form(PP)+"$";
11701: S=S+"{"+PP+"}";
11702: }else F=0;
11703: if(length(P)>3){
11704: if(type(P[3])==7 && P[3]!="") T=T+"("+P[3]+")";
11705: else if(P[3]==1) T=T+"(_)";
11706: if(length(P)>4 && type(P[4])==7) S=S+P[4];
11707: }
11708: if(length(P)>2){
11709: if(F) S="node"+T+" at"+S;
11710: else S="coordinate"+T+" at"+S;
11711: }
11712: }
11713: return S;
11714: }
11715:
11716: def xyput(P)
11717: {
11718: if((type(Sc=getopt(scale))==1 && Sc!=1) || type(Sc)==4){
11719: if(type(Sc)==1) Sc=[Sc,Sc];
11720: Sx=Sc[0];Sy=Sc[1];
11721: if(length(P)>2)
11722: P1=cons(Sy*P[1],cdr(cdr(P)));
11723: else P1=[Sy*P[1]];
11724: P=cons((type(P[0])==7)?P[0]:(Sx*P[0]),P1);
11725: }
11726: if(!TikZ) return "{"+xypos(P)+"};\n";
11727: return "\\"+xypos(P)+";\n";
11728: }
11729:
11730: def xyline(P,Q)
11731: {
11732: if(!TikZ) return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n";
11733: if(type(T=getopt(opt))!=7) T="";
11734: else T="["+T+"]";
11735: if(length(P)<3 && length(Q)<3)
11736: return "\\draw"+T+xypos(P)+"--"+xypos(Q)+";\n";
11737: if(length(P)==2) P=[P[0],P[1],"","_0"];
11738: else if(length(P)==3 || (length(P)==4 && P[3]==""))
11739: P=[P[0],P[1],P[2],"_0"];
11740: else if(length(P)>4 && P[3]=="")
11741: P=[P[0],P[1],P[2],"_0",P[4]];
11742: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
11743: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
11744: Q=[Q[0],Q[1],Q[2],"_1"];
11745: else if(length(Q)>4 && Q[3]=="")
11746: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
11747: return "\\draw "+T+xypos(P)+" "+xypos(Q)+"("+P[3]+")--("+Q[3]+");\n";
11748: }
11749:
11750: def xylines(P)
11751: {
11752: Lf=getopt(curve);
11753: if(type(Lf)!=1) Lf=0;
11754: SS=getopt(opt);
11755: SF=(SS==0)?1:0;
11756: if((Proc=getopt(proc))==1||Proc==2||Proc==3){
11757: OL=cons(["opt",0],delopt(getopt(),["opt","proc"]));
11758: R=xylines(P|option_list=OL);
11759: OP=(type(SS)<0)?[]:((type(SS)==4)?[["opt",SS[0]],["cmd",SS[1]]]:[["opt",SS]]);
11760: return [1,OP,R];
11761: }
11762: if(type(SS)!=7 && type(SS)!=4){
11763: if(Lf==0 && !TikZ) SS="@{-}";
11764: else SS="";
11765: }
11766: if(type(Sc=getopt(scale))==1 || type(Sc)==4){
11767: if(type(Sc)==1) Sc=[Sc,Sc];
11768: Sx=Sc[0];Sy=Sc[1];
11769: if(Sx!=1 || Sy!=1){
11770: for(PP=[], P0=P; P0!=[]; P0=cdr(P0)){
11771: PT=car(P0);
11772: if((type(PT)!=4 && type(PT)!=5) || (type(PT[0])!=1 && PT[0]!=0))
11773: PP=cons(PT,PP);
11774: else{
11775: if(length(PT)>2 && type(PT)==4)
11776: P1=cons(Sy*PT[1],cdr(cdr(PT)));
11777: else P1=[Sy*PT[1]];
11778: PP=cons(cons(Sx*PT[0],P1),PP);
11779: }
11780: }
11781: P=reverse(PP);
11782: }
11783: }
11784: if(type(Cl=CL0=getopt(close))!=1) Cl=0;
11785: if((Vb=getopt(verb))!=1&&type(Vb)!=4) Vb=0;
11786: if(type(Lf)!=1 || Lf==0){ /* lines */
11787: if(TikZ||SF){
11788: for(L=[],F=0,PT=P;PT!=[];PT=cdr(PT)){
11789: if(type(car(PT))<4){
11790: L=cons(car(PT),L);
11791: F=0;
11792: }else{
11793: if(F++>1) L=cons(1,L);
11794: L=cons(car(PT),L);
11795: }
11796: }
11797: if(Cl==1){
11798: L=cons(1,L);L=cons(-1,L);
11799: }
11800: if(L) L=reverse(L);
11801: if(SF) return L;
11802: if(type(SS)!=4) S=xybezier(L|opt=SS);
11803: else S=xybezier(L|opt=SS[0],cmd=SS[1]);
11804:
11805: }else{
11806: Out = str_tb(0,0);
11807: for(PT=P; PT!=[]; ){
11808: PS1=car(PT);
11809: PT=cdr(PT);
11810: if(PT==[]){
11811: if(Cl==1) PS2=car(P);
11812: else PS2=0;
11813: }else PS2=car(PT);
11814: str_tb(xyarrow(PS1,PS2|opt=SS),Out);
11815: }
11816: S=str_tb(0,Out);
11817: }
11818: }else if(Lf==2){ /* B-spline */
11819: if(SF) return P;
11820: if(!TikZ){
11821: Out = str_tb("{\\curve{",0);
11822: for(PT=P;PT!=[];PT=cdr(PT)){
11823: if(car(PT)==0){
11824: str_tb("}};\n{\\curve{",Out);
11825: continue;
11826: }
11827: if(PT!=P) str_tb("&",Out);
11828: str_tb(xypos([car(PT)[0],car(PT)[1]]),Out);
11829: }
11830: str_tb("}};\n",Out);
11831: S=str_tb(0,Out);
11832: }else Out=str_tb(xybezier(P|opt=SS),0);
11833: for(I=0;I<2;I++){
11834: Q=car(P);
11835: if(length(Q)>2)
11836: str_tb(xyput(Q),Out);
11837: P=reverse(P);
11838: }
11839: S=str_tb(0,Out);
11840: }else{ /* extended Bezier */
11841: RTo=getopt(ratio);
11842: if(type(Acc=getopt(Acc))!=1) Acc=0;
11843: if(type(RTo)!=1 || RTo>1.5 || RTo<0.001) RTo=0;
11844: if(Cl==1){
11845: PR=reverse(P);
11846: PT=car(PR);
11847: PR=cons(P[0],PR);
11848: PR=cons(P[1],PR);
11849: P=cons(PT,reverse(PR));
11850: }else if(Cl==-1) Cl=1;
11851: for(L=P2=P3=0,PT=P;;){
11852: P1=P2;P2=P3;P3=P4;
11853: P4=(PT==[])?0:car(PT);
11854: if(PT==[] && (Cl==1 || P3==0)) break;
11855: PT=cdr(PT);
11856: if(P3==0) str_tb("%\n", Out);
11857: if(P2==0 || P3==0 || (Cl==1 && P1==0)) continue;
11858: if(L!=0){
11859: if(car(L)==P2)
11860: L=cons(1,L);
11861: else{
11862: L=cons(0,L); L=cons(P2,L);
11863: }
11864: }else L=[P2];
11865: X=P3[0]-P2[0];Y=P3[1]-P2[1];
11866: DL1=DL2=0;DL=Acc?sqrt(X^2+Y^2):dsqrt(X^2+Y^2);
11867: if(P4!=0){
11868: XD1=P4[0]-P2[0];YD1=P4[1]-P2[1];DL1=Acc?sqrt(XD1^2+YD1^2):dsqrt(XD1^2+YD1^2);
11869: }
11870: if(P1!=0){
11871: XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];DL2=Acc?sqrt(XD2^2+YD2^2):dsqrt(XD2^2+YD2^2);
11872: }
11873: if(RTo!=0)
11874: R=RTo;
11875: else if(DL1>0 && DL2>0){
11876: Cos=(XD1*XD2+YD1*YD2)/(DL1*DL2);
11877: RT=4/(3*(Acc?sqrt((1+Cos)/2):dsqrt((1+Cos)/2))+3);
11878: R=DL*RT/(DL1+DL2);
11879: }else if(DL1!=0)
11880: R=DL/(2*DL1);
11881: else if(DL2!=0)
11882: R=DL/(2*DL2);
11883: if(DL2!=0) L=cons([P2[0]+R*XD2,P2[1]+R*YD2],L);
11884: if(DL1!=0) L=cons([P3[0]-R*XD1,P3[1]-R*YD1],L);
11885: L=cons([P3[0],P3[1]],L);
11886: }
11887: if(CL0==1) L=cons(-1,cdr(L));
11888: if(L!=0) L=reverse(L);
11889: if(SF) return L;
11890: if(type(SS)==4)
11891: S=xybezier(L|opt=SS[0],cmd=SS[1],verb=Vb);
11892: else
11893: S=xybezier(L|opt=SS,verb=Vb);
11894: }
11895: if(getopt(dviout)!=1) return S;
11896: xyproc(S|dviout=1);
11897: }
11898:
11899: def saveproc(S,Out)
11900: {
11901: if(type(Out)==4){
11902: Out=cons(S,Out);
11903: return Out;
11904: }else{
11905: str_tb(S,Out);
11906: return Out;
11907: }
11908: }
11909:
1.18 takayama 11910: def xygrid(X,Y)
11911: {
11912: for(RR=[],I=0,Z=X;I<2;I++){
1.19 takayama 11913: U=Z[2];L=LL=[];M=Z[3];
11914: if(Z[1]==1||Z[1]==-1){
1.18 takayama 11915: if(type(M)==4) L=M;
11916: else{
1.19 takayama 11917: if(U*(-dlog(1-1/20)/dlog(10))>=M){
1.18 takayama 11918: L=cons([1,2,1/10],L);
1.19 takayama 11919: LL=cons([1,2,1/2],LL);
11920: }else if(U*(-dlog(1-1/10)/dlog(10))>=M)
1.18 takayama 11921: L=cons([1,2,1/5],L);
11922: else if(U*(-dlog(1-1/4)/dlog(10))>=M)
11923: L=cons([1,2,1/2],L);
1.19 takayama 11924: if(U*(-dlog(1-1/50)/dlog(10))>=M){
1.18 takayama 11925: L=cons([2,5,1/10],L);
1.19 takayama 11926: LL=cons([2,5,1/2],LL);
11927: }else if(U*(-dlog(1-1/25)/dlog(10))>=M)
1.18 takayama 11928: L=cons([2,5,1/5],L);
11929: else if(U*(-dlog(1-1/10)/dlog(10))>=M)
11930: L=cons([2,5,1/2],L);
1.19 takayama 11931: if(U*(-dlog(1-1/100)/dlog(10))>=M){
1.18 takayama 11932: L=cons([5,10,1/10],L);
1.19 takayama 11933: LL=cons([5,10,1/2],LL);
11934: }
1.18 takayama 11935: else if(U*(-dlog(1-1/50)/dlog(10))>=M)
11936: L=cons([5,10,1/5],L);
11937: else if(U*(-dlog(1-1/20)/dlog(10))>=M)
11938: L=cons([5,10,1/2],L);
1.19 takayama 11939: L=cons(L,cons(LL,[[[1,10,1]]]));
1.18 takayama 11940: }
11941: R=scale(L|scale=U);
1.19 takayama 11942: if(Z[1]==-1){
11943: for(LL=[];R!=[];R=cdr(R)){
11944: for(L=[],T=car(R);T!=[];T=cdr(T)) L=cons(U-car(T),L);
11945: LL=cons(reverse(L),LL);
11946: }
11947: R=reverse(LL);
11948: }
1.18 takayama 11949: }else if(Z[1]==0){
11950: if(type(M)==4){
11951: R=scale(M|f=x,scale=U);
11952: }else{
11953: V=0;
11954: if(U/10>=M) V=1/10;
11955: else if(U/5>=M) V=1/5;
11956: else if(U/2>=M) V=1/2;
11957: R=[];
11958: if(V>0){
11959: UU=U*V;
11960: for(R=[],J=UU;J<U;J+=UU) R=cons(J,R);
11961: }
1.19 takayama 11962: if(V==1/10) L=[U/2];
11963: else L=[];
11964: R=cons(R,cons(L,[[0,U]]));
1.18 takayama 11965: }
11966: }else if(type(Z[1])==4){
11967: R=Z[1];
1.19 takayama 11968: if(length(R)==0||type(R[0])!=4) R=[[],[],R];
1.18 takayama 11969: }else return 0;
1.19 takayama 11970: K=length(R);
11971: S=newvect(K);
11972: for(J=0;J<K;J++){
11973: for(S[J]=[],JJ=0;JJ<=Z[0];JJ+=U){
11974: for(P=R[J];P!=[];P=cdr(P))
11975: if(car(P)+JJ<=Z[0]) S[J]=cons(car(P)+JJ,S[J]);
11976: }
11977: }
11978: for(J=0;J<K;J++) S[J]=lsort(S[J],[],1);
11979: for(U=[],J=K-1;J>0;J--){
11980: U=lsort(S[J],U,0);S[J-1]=lsort(S[J-1],U,1);
1.18 takayama 11981: }
1.19 takayama 11982: RR=cons(vtol(S),RR);
1.18 takayama 11983: Z=Y;
11984: }
11985: if((Raw=getopt(raw))==1) return RR;
11986: SS=[];
11987: if(type(Sf=getopt(shift))==7){
11988: Sx=Sf[0];Sy=Sf[1];
11989: }else Sx=Sy=0;
11990: for(I=0;I<2;I++){
11991: for(S0=[],L=RR[I];L!=[];L=cdr(L)){
11992: for(S=[],T=car(L);T!=[];T=cdr(T)){
11993: if(S!=[]) S=cons(0,S);
11994: if(I==0){
11995: S=cons([X[0]+Sx,car(T)+Sy],S);
11996: S=cons([Sx,car(T)+Sy],S);
11997: }else{
11998: S=cons([car(T)+Sx,Y[0]+Sy],S);
11999: S=cons([car(T)+Sx,Sy],S);
12000: }
12001: }
12002: S0=cons(S,S0);
12003: }
12004: SS=cons(reverse(S0),SS);
12005: }
12006: SS=reverse(SS);
12007: if(Raw==2) return SS;
12008: if(length(Y)<5) T=[["",""]];
12009: else if(type(Y[4])==4) T=[Y[4]];
12010: else T=[Y[4],Y[4]];
12011: if(length(X[4])==4) T=cons([""],T);
12012: else if(type(X[4])==4) T=cons(X[4],T);
12013: else T=cons([X[4]],T);
12014: for(Sx=Sy=[],I=0;I<2;I++){
12015: TT=T[I];
12016: for(V=SS[I];V!=[];V=cdr(V)){
12017: Op=car(TT);
12018: if(length(TT)>1) TT=cdr(TT);
12019: if(car(V)==[]) continue;
12020: if(Op=="") S=xylines(car(V));
12021: else S=xylines(car(V)|opt=Op);
12022: if(I==0) Sx=cons(S,Sx);
12023: else Sy=cons(S,Sy);
12024: }
12025: }
12026: for(S="",Sx=reverse(Sx), Sy=reverse(Sy);Sx!=[]&&Sy!=[];){
12027: if(Sx!=[]){
12028: S+=car(Sx);Sx=cdr(Sx);
12029: }
12030: if(Sy!=[]){
12031: S+=car(Sy);Sy=cdr(Sy);
12032: }
12033: }
12034: return S;
12035: }
12036:
12037:
1.22 takayama 12038: def addIL(I,L)
1.18 takayama 12039: {
1.22 takayama 12040: if(I==0){
12041: for(R=[];L!=[];L=cdr(L)) R=addIL(car(L),R);
12042: return reverse(R);
1.18 takayama 12043: }
1.22 takayama 12044: if(type(In=getopt(in))==1){
12045: if(In==-1){
12046: J=JJ=I[1];I=I[0];
12047: for(R=[];L!=[];L=cdr(L)){
12048: J=lmin([car(L)[0],JJ]);
12049: if(J>I) R=cons([I,J],R);
12050: I=lmax([car(L)[1],I]);
12051: }
12052: if(I<JJ) R=cons([I,JJ],R);
12053: return reverse(R);
12054: }else{
12055: for(;L!=[];L=cdr(L)){
12056: if(car(L)[0]>I) return 0;
12057: if(car(L)[1]>=I){
12058: if(In==3) return car(L);
12059: if(In==1||(I!=car(L)[0]&&I!=car(L)[1])) return 1;
12060: return 2;
12061: }
12062: }
12063: return 0;
12064: }
12065: }
12066: I0=car(I);I1=I[1];
12067: for(F=0,R=[];L!=[];L=cdr(L)){
12068: if(I0>car(L)[1]){
12069: R=cons(car(L),R);
12070: continue;
12071: }
12072: if(I0<=car(L)[1]){
12073: I0=lmin([I0,car(L)[0]]);
12074: if(I1<car(L)[0]){
12075: R=cons([I0,I1],R);
12076: for( ;L!=[];L=cdr(L)) R=cons(car(L),R);
12077: F=1;
12078: break;
12079: }
12080: I1=lmax([I1,car(L)[1]]);
12081: }
12082: }
12083: if(!F) R=cons([I0,I1],R);
12084: return reverse(R);
1.18 takayama 12085: }
12086:
12087: def xy2curve(F,N,Lx,Ly,Lz,A,B)
12088: {
1.22 takayama 12089: Raw=getopt(raw);
12090: if(type(Gap=getopt(gap))==4){
12091: MG=Gap[1];Gap=car(Gap);
12092: }else MG=3;
12093: if(type(Gap)!=1 && Gap!=0) Gap=0.7;
12094: if(type(Dvi=getopt(dviout))<1) Dvi=0;
12095: OL=[["dviout",Dvi]];
12096: if(type(Opt=getopt(opt))<1) Opt=0;
12097: else OL=cons(["opt",Opt],OL);
12098: if(type(Sc=getopt(scale))!=1 && type(Sc)!=4) Sc=[1,1,1];
12099: else if(type(Sc)!=4) Sc=[Sc,Sc,Sc];
12100: else if(length(Sc)!=3) Sc=[Sc[0],Sc[1],Sc[1]];
12101: M=diagm(3,Sc);
12102: if(A!=0||B!=0){
12103: if(type(A)==6) M=A;
12104: else M=mrot([0,-B,-A]|deg=1)*M;
12105: V=M*newvect(3,[x,y,z]);
12106: Fx=compdf(V[0],[x,y,z],F);Fy=compdf(V[1],[x,y,z],F);Fz=compdf(V[2],[x,y,z],F);
12107: }else{
12108: for(I=0;I<3;I++){
12109: if(type(T=F[I])!=4) T=f2df(T);
12110: if(type(T)==4) T=cons(car(T)*Sc[I],cdr(T));
12111: else T*=Sc[I];
12112: if(I==0) Fx=T;
12113: else if(I==1) Fy=T;
12114: else Fz=T;
12115: }
12116: }
12117: if(Raw==5||!Gap)
12118: return (Dvi||!Gap)? xygraph([Fy,Fz],N,Lx,Ly,Lz|option_list=OL):[Fx,Fy,Fz];
1.18 takayama 12119: R=xygraph([Fy,Fz],N,Lx,Ly,Lz|raw=2);
1.22 takayama 12120: R0=cdr(car(R));R1=R[1];
12121: for(LT=[];R0!=[];R0=cdr(R0),R1=cdr(R1))
12122: if(car(R0)!=0) LT=cons([R1[0],R1[1]],LT);
12123: LT=reverse(LT);
1.19 takayama 12124: if(N<0){
12125: Be=xylines(car(R)|curve=1,proc=3,close=-1);
12126: LT=reverse(cdr(LT));
12127: LT=reverse(cdr(LT));
12128: }
12129: else Be=xylines(car(R)|curve=1,proc=3);
1.18 takayama 12130: Be=cdr(cdr(Be));
1.22 takayama 12131: Be=lbezier(car(Be));
12132: if(Raw==4) return [Be,LT,Lx];
12133: X=ptcombz(Be,0,0);
12134: Var=(length(Lx)==3)?car(Lx):x;
12135: if(type(Eq=getopt(eq))!=1) Eq=0.01;
12136: if(TikZ==1){
12137: Gap/=10;Eq/=10;
1.18 takayama 12138: }
12139: for(R=[],XT=X;XT!=[];XT=cdr(XT)){
12140: V=car(XT);
1.22 takayama 12141: U=LT[V[0][0]];
12142: T=U[0]*V[1][0]+U[1]*(1-V[1][0]);
12143: VV=myfdeval(Fx,[Var,T]);
12144: U=LT[V[0][1]];
1.18 takayama 12145: T=U[0]*V[1][1]+U[1]*(1-V[1][1]);
1.22 takayama 12146: VV-=myfdeval(Fx,[Var,T]);
12147: if(abs(VV)<Eq) continue;
12148: I=(VV<0)?0:1;
12149: R=cons([V[0][I],V[1][I],V[0][1-I],V[1][1-I]],R);
1.18 takayama 12150: }
12151: R=qsort(R);
1.22 takayama 12152: if(Raw==3) return [Be,R];
12153: Db=newvect(L=length(Be));
12154: for(I=0;I<L;I++) Db[I]=[];
12155: for(TR=R;TR!=[];TR=cdr(TR)){
12156: V1=ptbezier(Be,[I=car(TR)[0],P=car(TR)[1]])[1];
12157: V2=ptbezier(Be,[car(TR)[2],car(TR)[3]])[1];
12158: T=dsqrt(1-dvangle(V1,V2)^2);
12159: if(T<1/MG) T=MG;
12160: GP=Gap/T;
12161: W=GP/dnorm(V1);
12162: Db[I]=addIL([P-W,P+W],Db[I]);
12163: if(P-W<0 && I>0) Db[I-1]=addIL([P-W+1,1],Db[I-1]);
12164: if(P+W>1 && I+1<L) Db[I+1]=addIL([0,P+W-1],Db[I+1]);
12165: }
12166: Db=vtol(Db);
12167: for(Bf=[];Be!=[];Be=cdr(Be),Db=cdr(Db)){
12168: if(car(Db)==[]) Bf=cons(car(Be),Bf);
12169: else{
12170: D=addIL([0,1],car(Db)|in=-1);
12171: for(;D!=[];D=cdr(D))
12172: Bf=cons(tobezier(car(Be)|inv=car(D)),Bf);
12173: }
12174: }
12175: Bf=reverse(Bf);
12176: if(Raw==2) return Bf;
12177: OL=[];
12178: if(Opt){
12179: if(type(Opt)==4&&length(Opt)>1) OL=[["opt",Opt[0]],["cmd",Opt[1]]];
12180: else OL=[["opt",Opt]];
12181: }else OL=[];
12182: S=xybezier(lbezier(Bf|inv=1)|option_list=OL);
12183: if(Raw==1||!Dvi) return S;
12184: return xyproc(S|dviout=Dvi);
12185: }
12186:
12187: def rungeKutta(F,N,Lx,Y,IY)
12188: {
12189: if((Pr=getopt(prec))==1){
12190: One=eval(exp(0));
12191: }else{
12192: One=1;Pr=0;
12193: }
12194: if((FL=getopt(last))!=1) FL=0;
12195: if(length(Lx)>2){
12196: V=car(Lx);Lx=cdr(Lx);
12197: }else V=x;
12198: if(Pr==0) Lx=[deval(Lx[0]),deval(Lx[1])];
12199: else Lx=[eval(Lx[0]),eval(Lx[1])];
12200: if(type(Y)==4){
12201: if((Sing=getopt(single))==1||type(F)!=4)
12202: F=append(cdr(Y),[F]);
12203: L=length(Y);
12204: for(TF=[];F!=[];F=cdr(F))
12205: TF=cons(f2df(car(F)),TF);
12206: F=reverse(TF);
12207: }else{
12208: L=1;
12209: F=f2df(F);
12210: }
12211: if(getopt(val)==1) V1=1;
12212: else V1=0;
12213: H=(Lx[1]-Lx[0])/N;H2=H/2;
12214: FV=findin(V,vars(F));
12215: K=newvect(4);
12216: if(L==1){
12217: R=[[T=Lx[0],S=IY]];
12218: if(!H) return R;
12219: for(;;){
12220: for(I=0;I<4;I++){
12221: if(I==0) W=[[V,T],[Y,S]];
12222: else if(I==3) W=[[V,T+H],[Y,S+H*K[2]]];
12223: else W=[[V,T+H2],[Y,S+H2*K[I-1]]];
12224: if(FV<0) W=cdr(W);
12225: K[I]=Pr?myfeval(F,W)*One:myfdeval(F,W);
12226: }
12227: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
12228: if(!FL) R=cons([deval(T),S],R);
12229: if((T+H-Lx[1])*H>0) break;
12230: }
12231: }else{
12232: T=Lx[0];
12233: R=[cons(T,V1?[car(IY)]:IY)];
12234: S=ltov(IY);
12235: if(!H) return R;
12236: for(;;){
12237: for(I=0;I<4;I++){
12238: if(I==0) W=cons([V,T ],lpair(Y,vtol(S)));
12239: else if(I==3) W=cons([V,T+H ],lpair(Y,vtol(S+H*K[2])));
12240: else W=cons([V,T+H2],lpair(Y,vtol(S+H2*K[I-1])));
12241: if(FV<0) W=cdr(W);
12242: for(TK=[],TF=F;TF!=[];TF=cdr(TF)){
12243: TK=cons(Pr?myfeval(car(TF),W)*One:myfdeval(car(TF),W),TK);
12244: }
12245: K[I]=ltov(reverse(TK));
12246: }
12247: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
12248: TS=vtol(S);
12249: if(V1) TS=[car(TS)];
12250: if(!FL) R=cons(cons(deval(T),TS),R);
12251: if((T+H-Lx[1])*H>0) break;
12252: }
12253: }
12254: return FL?(V1?S[0]:S):reverse(R);
1.18 takayama 12255: }
12256:
1.6 takayama 12257: def xy2graph(F0,N,Lx,Ly,Lz,A,B)
12258: {
1.18 takayama 12259: /* (x,y,z) -> (z sin B + x cos A cos B + y sin A cos B,
12260: -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */
1.6 takayama 12261: if((Proc=getopt(proc))==1||Proc==2){
12262: OPT0=[["proc",3]];
12263: }else{
12264: Proc=0;OPT0=[];
12265: }
12266: if(type(DV=getopt(dviout))==4){
12267: S=["ext","shift","cl","dviout"];
12268: OL=delopt(getopt(),S);
12269: OL=cons(["proc",1],OL);
12270: R=xy2graph(F0,N,Lx,Ly,Lz,A,B|option_list=OL);
12271: OL=delopt(getopt(),S|inv=1);
12272: return execdraw(R,DV|optilon_list=OL);
12273: }
12274: if(N==0 || N>100 || N<-100) N=-16;
12275: if(N<0){
12276: N=-N;N1=-1;N2=NN+1;
12277: }else{
12278: N1=0;N2=NN=N;
12279: }
12280:
12281: Ratio=Ratio2=1;
12282: if(type(Sc=Sc0=getopt(scale))!=1 && type(Sc)!=4) Sc=1;
12283: if(type(Sc)==4){
12284: Ratio=Sc[1]/Sc[0];
12285: if(length(Sc)>2) Ratio2=Sc[2]/Sc[0];
12286: Sc=Sc[0];
12287: }
12288: if(type(Vw=getopt(view))!=1) Vw=0;
12289: if(type(Raw=getopt(raw))!=1) Raw=0;
12290: if(type(M1=getopt(dev))==1) M2=M1;
12291: else if(type(M1)==4){
12292: M2=M1[1];M1=M1[0];
12293: }else M1=0;
12294: if(type(M3=getopt(acc))!=1 || (M3<0.5 && M3>100)) M3=1;
12295: if(M1<=0) M1=16;
12296: if(M2<=0) M2=16;
12297: OL=[["para",1],["scale",Sc]];
12298: if(Raw==1) OL=cons(["raw",1],OL);
12299: if(type(Prec=getopt(prec))>=0) OL=cons(["prec",Prec],OL);
12300: L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]);
12301: Lx=[deval(Lx[0]),deval(Lx[1])];
12302: Ly=[deval(Ly[0]),deval(Ly[1])];
12303: Lz=[deval(Lz[0]),deval(Lz[1])];
12304: A=(A0=A)%360;
12305: F00=F0;
12306: if(type(F0)<4){
12307: FC=f2df(F0);
12308: if(findin(z,Vars=vars(FC))>=0 && findin(x,Vars)<0 && findin(y,Vars)<0)
12309: F0=[w,[z,0,x+y*@i],[w,os_md.abs,FC]];
12310: }
12311: if(type(Org=getopt(org))==4){ /* shift origin */
12312: Lx=[Lx[0]-Org[0],Lx[1]-Org[0]];
12313: Ly=[Ly[0]-Org[1],Ly[1]-Org[1]];
12314: Lz=[Lz[0]-Org[2],Lz[1]-Org[2]];
12315: F0=mysubst(F0,[[x,x+Org[0]],[y,y+Org[1]]]);
12316: if(type(F0)==4){
12317: F0=cons(F0[0]-Org[2],cdr(F0));
12318: }
12319: else F0-=Org[2];
12320: }else Org=[0,0,0];
12321: Cpx=getopt(cpx);
12322: if(type(Cpx)<0){
12323: if(str_str(rtostr(F0),"@i")>=0) Cpx=1;
12324: else Cpx=0;
12325: }
12326: if(A<0) A+=360;
12327: if(A<90){
12328: Sh=1;F1=F0;Cx=x-Org[0];Cy=y-Org[1];
12329: }else if(A<180){ /* x -> y, y -> -x */
12330: Sh=2;A-=90; F1=mulsubst(F0,[[x,-y],[y,x]]);
12331: LL=Ly;Ly=[-Lx[1],-Lx[0]];Lx=LL;Cx=y-Org[1];Cy=-x+Org[0];
12332: }else if(A<270){
12333: Sh=3;A-=180; F1=subst(F0,[[x,-x],[y,-y]]);
12334: Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];Cx=-x+Org[0];Cy=-y+Org[1];
12335: }else{
12336: Sh=4;A-=270;F1=mulsubst(F0,[[x,y],[y,-x]]);
12337: LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;Cx=-y+Org[1];Cy=x-Org[0];
12338: }
12339: A=@pi*A/180; B=@pi*B/180;
12340: if(A==0) A=@pi/3;
12341: if(B==0) B=@pi/12;
12342: NN=N*M2;
12343: Ac=dcos(deval(A)); As=dsin(deval(A));
12344: if(Ac<=0.087 || As<=0.087){
12345: mycat(["Unsuitable angle",A0,"(6-th argument)!"]);
12346: return -1;
12347: }
12348: Bc=Ratio*dcos(deval(B)); Bs=dsin(deval(B));
12349: if(Bc<0){
12350: mycat("Unsuitable angle (7-th argument)!");
12351: return -1;
12352: }
12353: /*
12354: z = f(x,y) => X=-As*x+Ac*y, Y= Bc*f(x,y)-Bsc*x-Bss*y
12355: Out X-coord is in [X0,X1], dvided by Dev segments
12356: J-th segment of Y-coord : ZF[J]==1 => [Z0[0],Z1[J]]
12357: */
12358: Bsc=Bs*Ac;Bss=Bs*As;
12359: if(Ratio2!=1){
12360: if(Sh%2==1){
12361: Ac*=Ratio2;Bss*=Ratio2;
12362: }else{
12363: As*=Ratio2;Bsc*=Ratio2;
12364: }
12365: }
12366: CX=-As*Cx+Ac*Cy;CY=Bc*(z-Org[2])-Bsc*Cx-Bss*Cy;
12367: if(type(Dvi=getopt(dviout))!=1 && getopt(trans)==1) return [CX*Sc,CY*Sc];
12368: if(type(N1=getopt(inf))==1){
12369: if(Proc) Dvi=N1;
12370: else if(Dvi<=0) Dvi=-N1;
12371: }
12372: X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1];
12373: F1=mysubst(F1,[@pi,deval(@pi)]);
12374: Tf=type(F1=f2df(F1|opt=0));
12375: if(Tf!=4) F=Bc*F1-Bsc*x-Bss*y;
12376: else F=append([Bc*F1[0]-Bsc*x-Bss*y],cdr(F1));
12377: Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN;
12378: if(type(Err=getopt(err))==1)
12379: F=mysubst(F,[[x,x+Err*Dx/1011.23],[y,y+Err*Dy/1101.34]]);
12380: Out=(Proc)?[]:str_tb(0,0);
12381: Dev=N*M1;
12382: XD=(X1-X0)/Dev;
12383: OLV=newvect(2,[OL,OL]);
12384: if(type(Ura=getopt(opt))==4 || type(Ura)==7){
12385: if(type(Ura)==7) Ura=[Ura,Ura];
12386: else{
12387: OLV[0]=cons(["opt",Ura[0]],OL);
12388: OLV[1]=cons(["opt",Ura[1]],OL);
12389: }
12390: }
12391: for(KC=0; KC<=1; KC++){ /* draw curves */
12392: Z0=newvect(Dev+1); Z1=newvect(Dev+1); ZF=newvect(Dev+1);
12393: for(I=0; I<=NN; I++){
12394: FV=I%M2;
12395: if(KC==0){
12396: X=x; Y=Ly[1]-I*Dy; LX=Lx; DD=Dx; G=mysubst(F,[y,Y]);
12397: if(!FV){
12398: if(!Proc) str_tb(["%y=",rtostr(Y),"\n"],Out);
12399: else Out=cons([-2,"y="+rtostr(Y)],Out);
12400: }
12401: }else{
12402: X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=mysubst(F,[[x,X],[y,Y]]);
12403: if(!FV){
12404: if(!Proc) str_tb(["%x=",rtostr(X),"\n"],Out);
12405: else Out=cons([-2,"x="+rtostr(X)],Out);
12406: }
12407: }
12408: XX=-As*X+Ac*Y; A1=coef(XX,1,x); A0=coef(XX,0,x); /* XX = A1*x + A0, x = (XX-A0)/A1 */
12409: if(!FV && Vw==1){
12410: if(Proc) Out=cons(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1,proc=3),Out);
12411: else str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1),Out);
12412: continue;
12413: }
12414: V=VT=LX[1];
12415: J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD;
12416: if(J0<J1){
12417: J0=ceil(J0); J1=floor(J1); JD=1; /* fixed x: y: dec => (x,z):(dec,inc) */
12418: }else{
12419: J0=floor(J0); J1=ceil(J1); JD=-1; /* fixed y: x: dec => (x,z):(inc,inc) */
12420: }
12421: for(FF=1,J=J1;;J-=JD){
12422: V1=VT;
12423: VT=(X0+J*XD-A0)/A1;GG=mysubst(G,[x,VT]);
12424: if(Cpx>=1) VV=myeval(GG);
12425: else VV=(Tf==4)? mydeval(GG):deval(GG); /* J -> V */
12426: if(ZF[J]==0 || VV<=Z0[J] || VV>=Z1[J]){ /* visible */
12427: if(FF==0){
12428: V0=(VT+V1)/2;
12429: if(!FV && Vw==-1 && Raw!=1){ /* draw doted line */
12430: K=ceil(M3*(V-V0)/(M2*DD));
12431: if(N1<0) K=-K;
12432: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"],["scale",Sc],["para",1]]);
12433: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|
12434: option_list=OPT),Out);
12435: }
12436: V=V0;
12437: }
12438: if(ZF[J]==0){
12439: ZF[J]=1; Z0[J]=Z1[J]=VV;
12440: }else if(VV<=Z0[J]) Z0[J]=VV;
12441: else Z1[J]=VV;
12442:
12443: if(VV>=Z1[J]) FF=1;
12444: else if(VV<=Z0[J]) FF=-1;
12445: }else{
12446: if(FF!=0){
12447: V0=(VT+V1)/2;
12448: K=ceil(M3*(V-V0)/(M2*DD));
12449: if(N1<0) K=-K;
12450: if(!FV){
12451: OPT=append(OPT0,OLV[(1-FF)/2]);
12452: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
12453: }
12454: V=V0;
12455: }
12456: FF=0;
12457: }
12458: if(J==J0) break;
12459: }
12460: if(FV) continue;
12461: V0=LX[0];K=ceil(M3*(V-V0)/(M2*DD));
12462: if(N1<0) K=-K;
12463: if(FF!=0){
12464: if(Raw!=1){
12465: OPT=append(OPT0,OLV[(1-FF)/2]);
12466: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
12467: }else if(Vw==-1 && Raw!=1){
12468: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"]]);
12469: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
12470: }
12471: }
12472: }
12473: }
12474: OptSc=(Sc==1)?[]:[["scale",Sc]];
12475: if(type(LZ=getopt(ax))==4){ /* draw box */
12476: FC=0;
12477: if(length(LZ)==3) FC=LZ[2];
12478: P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*(LZ[0]-Org[0])-Bsc*Lx[1]-Bss*Ly[1]]);
12479: Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]);
12480: Vy=newvect(2,[Ac*(Ly[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]);
12481: Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]);
12482: OL=OL0=append(OPT0,OL);
12483: if(TikZ && type(Ura)==4 && length(Ura)>2) OL0=cons(["opt",Ura[2]],OL);
12484: LL=[[P0+Vz,P0+Vx+Vz],[P0,P0+Vx]];
12485: if(Bs>0){
12486: LL=cons([P0+Vy+Vz,Pz=P0+Vx+Vy+Vz],LL);
12487: LL=cons([P0+Vx+Vz,Pz],LL);
12488: PP=Pz-Vz;
12489: }
12490: else{
12491: LL=cons([P0+Vy,Pz=P0+Vx+Vy+Vz],LL);
12492: LL=cons([P0+Vx,Pz],LL);
12493: PP=Pz+Vz;
12494: }
12495: J=ceil((PP[0]-X0)/XD+0.5);
12496: LL=append([[P0+Vy,P0+Vy+Vz],[P0+Vy,P0+Vy+Vz],[P0+Vx,P0+Vx+Vz],[P0,P0+Vz],
12497: [P0+Vz,P0+Vy+Vz],[P0,P0+Vy]],LL);
12498: for(LL=reverse(LL);LL!=[];LL=cdr(LL)) Out=saveproc(xylines(car(LL)|option_list=OL0),Out);
12499: if(Dev>4) Dev2=ceil(Dev/2);
12500: if(FC<0 && Raw!=1){
12501: if(TikZ){
12502: if(type(Ura)==4 && length(Ura)>2)
12503: OL1=cons(["opt",Ura[2]+",dotted"],OL);
12504: else OL1=cons(["opt","dotted"],OL);
12505: }else OL1=cons(["opt","@{.}"],OL);
12506: if(FC==-8) FC=0;
12507: }
12508: for(I=0;I<3;I++){ /* box with hidden part */
12509: if(I==1) Pz=PP-Vx;
12510: else if(I==2) Pz=PP-Vy;
12511: LP=Pz-PP;
12512: for(FV=-1,K=0;K<=Dev2; K++){
12513: PPx=PP[0]+(K/Dev2)*LP[0]; PPy=PP[1]+(K/Dev2)*LP[1];
12514: J=ceil((PPx-X0)/XD);
12515: if(K!=Dev2 && (J<0||J>Dev)) continue;
12516: if(K!=Dev2 && (ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){ /* visible */
12517: if(FV!=1){
12518: FV=1;
12519: PPP=[PPx,PPy];
12520: }
12521: }else{
12522: if(FV!=0){
12523: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
12524: FV=0;
12525: }
12526: }
12527: }
12528: }
12529: if(FC!=0 && Raw!=1){ /* show coordinate*/
12530: if(iand(FC,4)){
12531: Sub=1;
12532: if(TikZ){
12533: S0="\\scriptsize";S1="";
12534: }else{
12535: S0="{}_{"; S1="}";
12536: }
12537: }else Sub=0;
12538: if(iand(FC,2))
12539: LLL=[[1,0,P0+Vx,(TikZ)?"right":"+!L"],[3,0,P0+Vy,(TikZ)?"left":"+!R"]];
12540: else LL=[];
12541: if(Bs>0){
12542: LLL=cons([0,0,P0,(TikZ)?"below":"+!U"],LLL);
12543: LLL=cons([2,1,P0+Vx+Vy+Vz,(TikZ)?"above":"+!D"],LLL);
12544: }else{
12545: LLL=cons([2,0,P0+Vx+Vy,(TikZ)?"below":"+!U"],LLL);
12546: LLL=cons([0,1,P0+Vz,(TikZ)?"above":"+!D"],LLL);
12547: }
12548: for(TLL=LLL;TLL!=[];TLL=cdr(TLL)){
12549: TL=car(TLL);LL=L[(Sh+TL[0])%4];
12550: if(Cpx==0 || Cpx==3){
12551: S=ltotex([LL[0],LL[1],LZ[TL[1]]]|opt="coord");
12552: SS="("+rtostr(LL[0]) +","+rtostr(LL[1])+","+rtostr(LZ[TL[1]])+")";
12553: }else{
12554: S=ltotex([LL[0]+LL[1]*@i,LZ[TL[1]]]|opt="coord",cpx=Cpx);
12555: SS="("+rtostr(LL[0])+"+"+rtostr(LL[1])+"i,"+ rtostr(LZ[TL[1]])+")";
12556: }
12557: if(TikZ) S="$"+S+"$";
12558: if(Sub) S=S0+S+S1;
12559: if(!TikZ) S="$"+S+"$";
12560: if(Proc) Out=cons([2,OptSc,[TL[2][0],TL[2][1]],[[TL[3],S]],SS],Out);
12561: else str_tb(xyput([TL[2][0],TL[2][1],[TL[3],S]]|option_list=OptSc),Out);
12562: }
12563: }
12564: }
12565: if(type(Pt=getopt(pt))==4){ /* option pt=[] */
12566: if(type(Pt[0])<4) Pt=[[Pt]];
12567: if(length(Pt)>1&&type(Pt[1])!=4) Pt=[Pt];
12568: for(PT=Pt;PT!=[];PT=cdr(PT)){
12569: PP=car(PT);
12570: if(type(PP)==4 && length(PP)==3 && type(PP[0])<2 && type(PP[2])<2) PP=[PP];
12571: P=car(PP);
12572: if(type(P)==7) Q=[P,0];
12573: else if(P==1) Q=["_",0];
12574: else Q=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
12575: if(length(PP)>1 && type(PP[1])==4 && length(PP[1])==3){ /* draw line */
12576: PP=cdr(PP);P=car(PP);
12577: if(type(P)==7) Q1=P;
12578: else if(P==1) Q="_";
12579: else Q1=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
12580: if(length(PP)<2 || PP[1]==0 || iand(PP[1],1)) OL2="";
12581: else OL2=(TikZ)?"dotted":"@{.}";
12582: if(length(PP)>2 && type(PP[2])==7){
12583: if(OL2=="") OL2=PP[2];
12584: else{
12585: if(TikZ) OL2=OL2+",";
12586: OL2=OL2+PP[2];
12587: }
12588: }
12589: OL1=OL;
12590: if(OL2!="") OL1=cons(["opt",OL2],OL1);
12591: if(length(PP)<2 || PP[1]>=0)
12592: Out=saveproc(xylines([Q,Q1]|option_list=OL1),Out);
12593: else{
12594: LP0=Q1[0]-Q[0];LP1=Q1[1]-Q[1];
12595: for(FV=-1,K=0;K<=Dev2; K++){
12596: PPx=Q[0]+(K/Dev2)*LP0; PPy=Q[1]+(K/Dev2)*LP1;
12597: J=ceil((PPx-X0)/XD);
12598: if(K!=Dev2 && (J<0 || J>Dev || ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){
12599: /* visible */
12600: if(FV!=1){
12601: FV=1;
12602: PPP=[PPx,PPy];
12603: }
12604: }else{
12605: if(FV!=0){
12606: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
12607: FV=0;
12608: }
12609: }
12610: }
12611: }
12612: continue;
12613: }
12614: if(length(PP)==1) S="$\\bullet$";
12615: else if(type(PP[1])==7) S=PP[1];
12616: else if(type(PP[1])==4){
12617: if(length(PP[1])>1 && type(PP[1][1])!=7)
12618: S=cons(car(PP),cons("$\\bullet$",cdr(cdr(PP))));
12619: else S=PP[1];
12620: }else S="$\\bullet$";
12621: if(length(PP)<=2){
12622: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S]],Out);
12623: else str_tb(xyput([Q[0],Q[1],S]|option_list=OptSc),Out);
12624: }else if(!TikZ){
12625: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S,"",PP[2]]],Out);
12626: else str_tb(xyput([Q[0],Q[1],S,"",PP[2]]|option_list=OptSc),Out);
12627: }else{
12628: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],cons(S,cdr(cdr(PP)))],Out);
12629: else str_tb(xyput(append([Q[0],Q[1],S],cdr(cdr(PP)))|option_list=OptSc),Out);
12630: }
12631: }
12632: }
12633: if(Proc){
12634: S=reverse(Out);
12635: if(Proc==1||Proc==3){
12636: for(W=[],I=0;I<2;I++) for(J=0;J<2;J++) for(K=0;K<2;K++)
12637: W=cons(mysubst([CX*Sc,CY*Sc],[[x,Lx[I]],[y,Ly[J]],[z,Lz[K]]]),W);
12638: W=ptbbox(W);
12639: S=cons([0,W[0],W[1],(TikZ)?1:1/10],S);
12640: }
12641: }else S=str_tb(0,Out);
12642: if(type(Dvi)!=1||(Proc&&abs(Dvi)<2)) return S;
12643: Lout=[];
12644: if(abs(Dvi)>=2){
12645: /* show title */
12646: L0=[];
12647: Title=getopt(title);
12648: if(type(Title)!=7)
12649: Title=(type(F00)==4)?("\\texttt{"+verb_tex_form(F00)+"}"):my_tex_form(F00);
12650: if(type(Title)==7){
12651: T=my_tex_form(L[3][0])+"\\le x\\le "+my_tex_form(L[1][0])+",\\,"+
12652: my_tex_form(L[3][1])+"\\le y\\le "+my_tex_form(L[1][1])+")";
12653: if(Proc){
12654: if(Cpx>=1) L0=[[5,[["eq",1]],"|"+Title+"|\\quad(z=x+yi,\\ "+T]];
12655: else L0=[[5,[["eq",1]],"z="+Title+"\\ \\ ("+T]];
12656: }else{
12657: if(Cpx>=1) dviout("|"+Title+"|\\quad(z=x+yi,\\ "+T|eq=1,keep=1);
12658: else dviout("z="+Title+"\\ \\ ("+T|eq=1,keep=1);
12659: }
12660: }
12661: A=rint(deval(180*A/@pi))+90*(Sh-1);
12662: if(A>=180) A-=180;
12663: B=rint(deval(180*B/@pi));
12664: if(abs(Dvi)>=3){
12665: T="\\text{angle } ("+my_tex_form(A)+"^\\circ,"+my_tex_form(B)+"^\\circ)";
12666: if(Ratio!=1 || Ratio2!=1) T=T+"\\quad\\text{ratio }1:"
12667: +my_tex_form(sint(Ratio2,2))+":"+my_tex_form(sint(Ratio,2));
12668: if(Proc) L0=cons([5,[["eq",1]],T],L0);
12669: else dviout(T|eq=1,keep=1);
12670: }
12671: SS="% range "+rtostr([L[3][0],L[1][0]])+"x"+rtostr([L[3][1],L[1][1]])+
12672: " angle ("+ rtostr(A) +","+ rtostr(B)+") dev=";
12673: if(M1==M2) SS=SS+rtostr(M1);
12674: else SS=SS+rtostr([M1,M2]);
12675: if(M3!=1) SS=SS+" acc="+rtostr(M3);
12676: if(type(Sc0)>=0) SS=SS+" scale="+rtostr(Sc0);
12677: if(Proc){
12678: S=cons([5,[],SS],S);
12679: for(;L0!=[];L0=cdr(L0)) S=cons(car(L0),S);
12680: return S;
12681: }
12682: if(Dvi>0){
12683: dviout(SS|keep=1);
12684: dviout(xyproc(S)|eq=8);
12685: }else Lout=[SS,S];
12686: }else{
12687: if(Dvi>0) dviout(xyproc(S));
12688: else Lout=[S];
12689: }
12690: if(getopt(trans)==1) return cons([CX*Sc,CY*Sc],Lout);
12691: if(Dvi<0) return Lout;
12692: }
12693:
1.20 takayama 12694: def orthpoly(N)
12695: {
12696: F=0;
12697: if(type(P=getopt(pol))==7){
12698: for(L=["Le","Ge","Tc","2T","Ja","He","La","Se"];L!=[];L=cdr(L),F++)
12699: if(str_str(P,car(L)|end=2)==0) break;
12700: }else P=0;
12701: if(type(D=N)==4) D=N[0];
12702: if(!isint(D)||D<0) return 0;
12703: if(F==0) return seriesHG([-D,D+1],[1],(1-x)/2,D);
12704: 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));
12705: if(F==2) return seriesHG([-D,D],[1/2],(1-x)/2,D);
12706: if(F==3){
12707: if(D==0) return 0;
12708: return orthpoly([D-1,1]|pol="Ge");
12709: }
12710: if(F==4) return red(seriesHG([-D,D+N[1]],[N[2]],x,D));
12711: if(F==5){
12712: for(S=I=1;I<=D;I+=2) S*=I;
12713: if(iand(D,1)) return seriesHG([-(D-1)/2],[3/2],x^2/2,D-1)*x*S*(-1)^((D-1)/2);
12714: else return seriesHG([-D/2],[1/2],x^2/2,D)*S*(-1)^(D/2);
12715: }
12716: if(F==6){
12717: NN=(type(N)==4)?N[1]:0;
12718: return red(seriesHG([-D],[NN+1],x,D)*binom(D+NN,D));
12719: }
12720: if(F==7){
12721: NN=N[1];
12722: for(S=1,I=1;I<=D;I++) S+=(-1)^I*binom(D,I)*binom(D+I,I)*sftpow(x,I)/sftpow(NN,I);
12723: return S;
12724: }
12725: return 0;
12726: }
12727:
12728: def schurpoly(L)
12729: {
12730: N=length(L);
12731: for(R=[],I=1;L!=[];L=cdr(L),I++) R=cons(car(L)+N-I,R);
12732: L=reverse(R);
12733: if(type(X=getopt(var))!=4){
12734: V=(type(X)>1)?X:"x";
12735: for(X=[],I=0;I<N;I++) X=cons(makev([V,N-I]),X);
12736: }
12737: M=newmat(N,N);
12738: for(I=0;I<N;I++)
12739: for(J=0;J<N;J++) M[I][J]=X[I]^L[J];
12740: P=det(M);
12741: for(I=0;I<N;I++)
12742: for(J=I+1;J<N;J++) P=sdiv(P,X[I]-X[J]);
12743: return P;
12744: }
12745:
1.6 takayama 12746: def fouriers(A,B,X)
12747: {
1.20 takayama 12748: if((Y=getopt(y))==0||type(Y)>0) Y=deval(Y);
12749: else Y=0;
12750: if((V=getopt(const))==0||type(V)>0){
12751: V=myfeval(V,Y);
12752: K=1;
12753: }else K=0;
1.6 takayama 12754: if(A!=[]&&type(car(A))>1){
1.20 takayama 12755: for(C=[],I=A[1];I>=K;I--) C=cons(myf2eval(car(A),I,Y),C);
12756: if(K) C=cons(0,C);
1.6 takayama 12757: A=C;
12758: }
1.20 takayama 12759: if(K){
12760: if(A!=[]) A=cdr(A);
12761: A=cons(V,A);
12762: }
1.6 takayama 12763: if(B!=[]&&type(car(B))>1){
1.20 takayama 12764: for(C=[],I=B[1];I>0;I--) C=cons(myf2eval(car(B),I,Y),C);
1.6 takayama 12765: B=C;
12766: }
1.20 takayama 12767: L=length(B)+1;
12768: if(length(A)>=L) L=length(A)+1;
12769: if(type(Sum=getopt(sum))>0){
12770: if(Sum==1) Sum=1-x;
12771: else if(Sum==2) Sum=[(z__)/(3.1416*x),[z__,os_md.mysin,3.1416*x]];
12772: else Sum=f2df(Sum);
12773: C=[];
12774: if(A!=[]){
12775: C=cons(car(A),C);
12776: A=cdr(A);
12777: }
12778: for(I=1;A!=[];A=cdr(A),I++) C=cons(car(A)*myf2eval(Sum,I/L,L),C);
12779: A=reverse(C);
12780: for(C=[],I=1;B!=[];B=cdr(B),I++) C=cons(car(B)*myf2eval(Sum,I/L,L),C);
12781: B=reverse(C);
12782: }
1.6 takayama 12783: if(getopt(cpx)==1){
1.20 takayama 12784: if(type(X=eval(X))>1) return todf([os_md.fouriers,[["cpx",1]]],[[A],[B],[X]]);
1.6 takayama 12785: V=dexp(@i*X);
12786: for(C=A,P=1,I=0;C!=[];C=cdr(C),I++){
1.20 takayama 12787: R+=S*car(C)*P;
1.6 takayama 12788: P*=V;
12789: }
12790: V=dexp(-@i*X);
12791: for(C=B,P=1,I=0;C!=[];C=cdr(C),I++){
12792: P*=V;
12793: R+=car(C)*P;
12794: }
12795: return R;
12796: }
12797: if(type(X=eval(X))>1) return todf(os_md.fouriers,[[A],[B],[X]]);
12798: for(C=A,I=0;C!=[];C=cdr(C),I++)
12799: R+=car(C)*mycos(I*X);
12800: for(C=B,I=1;C!=[];C=cdr(C),I++)
12801: R+=car(C)*mysin(I*X);
12802: return R;
12803: }
12804:
12805:
12806: def myexp(Z)
12807: {
12808: if(type(Z=eval(Z))>1) return todf(os_md.myexp,[Z]);
12809: if((Im=imag(Z))==0) return dexp(Z);
12810: return dexp(real(Z))*(dcos(Im)+@i*dsin(Im));
12811: }
12812:
12813: def mycos(Z)
12814: {
12815: if(type(Z=eval(Z))>1) return todf(os_md.mycos,[Z]);
12816: if((Im=imag(Z))==0) return dcos(Z);
12817: V=myexp(Z*@i);
12818: return (V+1/V)/2;
12819: }
12820:
12821: def mysin(Z)
12822: {
12823: if(type(Z=eval(Z))>1) return todf(os_md.mysin,[Z]);
12824: if((Im=imag(Z))==0) return dsin(Z);
12825: V=myexp(Z*@i);
12826: return (1/V-V)*@i/2;
12827: }
12828:
12829: def mytan(Z)
12830: {
12831: if(type(Z=eval(Z))>1) return todf(os_md.mytan,[Z]);
1.17 takayama 12832: if((Im=imag(Z))==0) return dtan(Z);
1.6 takayama 12833: V=myexp(2*Z*@i);
12834: return @i*(1-V)/(1+V);
12835: }
12836:
12837: def mylog(Z)
12838: {
12839: if(type(Z=eval(Z))>1) return todf(os_md.mylog,[Z]);
12840: if((Im=imag(Z))==0) return dlog(Z);
12841: return dlog(dabs(Z))+@i*myarg(Z);
12842: }
12843:
12844: def mypow(Z,R)
12845: {
12846: if(type(Z=eval(Z))>1||type(R=eval(R))>1) return todf(os_md.mypow,[Z,R]);
12847: if(Z==0) return 0;
12848: if(isint(2*R)){
12849: if(R==0) return 1;
12850: if(isint(R)) return Z^R;
12851: V=dsqrt(Z);
12852: if(R==1/2) return V;
12853: return Z^(R-1/2)*V;
12854: }
12855: return myexp(R*mylog(Z));
12856: }
12857:
12858: def myarg(Z)
12859: {
12860: if(type(Z=map(eval,Z))==4){
12861: if(length(Z)!=2) return todf(os_md.myarg,[Z]);
12862: Re=Z[0];Im=Z[1];
12863: }else if(type(Z)>1){
12864: return todf(os_md.myarg,[Z]);
12865: }else {
12866: Im=imag(Z);Re=real(Z);
12867: }
12868: if(Re==0) return (Im<0)?-deval(@pi)/2:deval(@pi)/2;
12869: V=datan(Im/Re);
12870: if(Re>0) return V;
12871: return (V>0)?(V-deval(@pi)):(V+deval(@pi));
12872: }
12873:
12874: def myatan(Z)
12875: {
12876: if(type(Z=eval(Z))>1) return todf(os_md.myatan,[Z]);
12877: if((Im=imag(Z))==0) return datan(Z);
12878: mylog((1-Z*@i)/(1+Z*@i))*@i/2;
12879: }
12880:
12881: def myasin(Z)
12882: {
12883: if(type(Z=eval(Z))>1) return todf(os_md.myasin,[Z]);
12884: return deval(@pi/2)-myacos(Z);
12885: }
12886:
12887: def frac(X)
12888: {
12889: if(type(X=eval(X))>1) return todf(os_md.frac,[X]);
12890: return (ntype(X)==3)? pari(frac,X):(X-floor(X));
12891: }
12892:
12893: def myacos(Z)
12894: {
12895: if(type(Z=eval(Z))>1) return todf(os_md.myacos,[Z]);
12896: if(imag(Z)==0 && Z<=1 && Z>=-1) return dacos(Z);
12897: return mylog(Z-dsqrt(Z^2-1))*@i;
12898: }
12899:
12900: def arg(Z)
12901: {
12902: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.arg,[Z]);
12903: return (type(Z)==4)?pari(arg,Z[0],Z[1]):arg(sqrt,Z);
12904: }
12905:
12906: def sqrt(Z){
12907: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.sqrt,[Z]);
12908: R=(type(Z)==4)?Z[1]:Z;
12909: if(ntype(R)==0){
12910: if(R==0) return 0;
12911: if(R>0){
12912: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R));
12913: }else{
12914: R=-R;
12915: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R))*@i;
12916: }
12917: }
12918: return (type(Z)==4)?pari(sqrt,Z[0],Z[1]):pari(sqrt,Z);
12919: }
12920:
12921: def gamma(Z)
12922: {
12923: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.gamma,[Z]);
12924: return (type(Z)==4)?pari(gamma,Z[0],Z[1]):pari(gamma,Z);
12925: }
12926:
12927: def lngamma(Z)
12928: {
12929: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.lngamma,[Z]);
12930: return (type(Z)==4)?pari(lngamma,Z[0],Z[1]):pari(lngamma,Z);
12931: }
12932:
12933: def digamma(Z)
12934: {
12935: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.digamma,[Z]);
12936: return (type(Z)==4)?pari(digamma,Z[0],Z[1]):pari(digamma,Z);
12937: }
12938:
12939: def dilog(Z)
12940: {
12941: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.dilog,[Z]);
12942: return (type(Z)==4)?pari(dilog,Z[0],Z[1]):pari(dilog,Z);
12943: }
12944:
12945: def erfc(Z)
12946: {
12947: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.erfc,[Z]);
12948: return (type(Z)==4)?pari(erfc,Z[0],Z[1]):pari(erfc,Z);
12949: }
12950:
12951: def zeta(Z)
12952: {
12953: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.zeta,[Z]);
12954: return (type(Z)==4)?pari(zeta,Z[0],Z[1]):pari(zeta,Z);
12955: }
12956:
12957: def eta(Z)
12958: {
12959: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.eta,[Z]);
12960: return (type(Z)==4)?pari(eta,Z[0],Z[1]):pari(eta,Z);
12961: }
12962:
12963: def jell(Z)
12964: {
12965: if(vars(Z=map(eval,V))>1) return todf(os_md.jell,[Z]);
12966: return (type(Z)==4)?pari(jell,Z[0],Z[1]):jell(jell,Z);
12967: }
12968:
12969: def evals(F)
12970: {
12971: if(type(F)==7){
12972: if(type(Del=getopt(del))!= 7) return eval_str(F);
12973: S=strtoascii(Del);K=length(S);
12974: if(K==0) return [eval_str(F)];
12975: Raw=getopt(raw);
12976: F=strtoascii(F);L=[];T1=0;
12977: do{
12978: T2=str_str(F,S|top=T1);
12979: if(T2<0) T2=10000;
12980: FT=str_cut(F,T1,T2-1);
12981: L=cons((Raw==1)?FT:evals(FT),L);
12982: T1=T2+K;
12983: }while(T2!=10000);
12984: return reverse(L);
12985: }
12986: if(type(F)==4){
12987: if(type(S=car(F))==7){
12988: S+="(";
12989: for(I=0,FT=cdr(F); FT!=[]; I++,FT=cdr(FT)){
12990: if(type(ST=car(FT))!=7) ST=rtostr(ST);
12991: if(I>0) S=S+","+ST;
12992: else S=S+ST;
12993: }
12994: S=S+")";
12995: return eval_str(S);
12996: }else return call(S,cdr(F));
12997: }
12998: return F;
12999: }
13000:
13001: def myval(F)
13002: {
13003: if(type(F)!=4){
13004: F=f2df(sqrt2rat(F));
13005: if(type(F)!=4) return F;
13006: };
13007: if(length(F)==1) V=car(F);
13008: else for(V=car(F),F=cdr(F); F!=[];){
13009: FT=car(F);
13010: if(type(G=FT[1])==2){
13011: if(length(FT)>2){
13012: FT2=myval(FT[2]);
13013: if(length(FT)>3) FT3=myval(FT[3]);
13014: };
13015: X=red(FT2/@pi);Vi=-red(FT2*@i/@pi);W=red(FT2/@e);
13016: if(G==os_md.mypow && FT3==1/2){
13017: G=os_md.sqrt;
13018: FT=[FT[0],G,FT[2]];
13019: }
13020: if((T=findin(G,
13021: [sin,os_md.mysin,cos,os_md.mycos,tan,os_md.mytan]))>=0
13022: &&(isint(6*X)||isint(4*X))){
13023: if(T==2||T==3){
13024: T=0;X=1/2-X;
13025: }
13026: X=X-floor(X/2)*2;
13027: if(T==0||T==1){
13028: if(X>1){
13029: S=-1;X-=1;
13030: }else S=1;
13031: if(X>1/2) X=1-X;
13032: if(X==0) R=0;
13033: else if(X==1/6) R=1/2;
13034: else if(X==1/4) R=2^(1/2)/2;
13035: else if(X==1/3) R=3^(1/2)/2;
13036: else R=1;
13037: R*=S;
13038: }else{
13039: if(X>1) X-=1;
13040: if(X>1/2){
13041: S=-1;V=1-X;
13042: }else S=1;
13043: if(X==0) R=0;
13044: else if(X==1/6) R=3^(1/2)/3;
13045: else if(X==1/4) R=1;
13046: else if(X==1/3) R=3^(1/2);
13047: else R=2^512;
13048: R*=S;
13049: }
13050: }else if((G==exp||G==os_md.myexp)&&(isint(FT2)||isint(6*Vi)||isint(4*Vi))){
13051: if(isint(FT2)) R=@e^FT2;
13052: else R=myval([z+w*@i,[z,cos,Vi*@pi],[w,sin,Vi*@pi]]);
13053: }else if((G==pow||G==os_md.mypow) && (isint(FT3)||FT2==1||FT2==0)){
13054: if(FT2==0) R=0;
13055: else if(FT2==1) R=1;
13056: else R=FT2^FT3;
13057: }else if(G==os_md.abs&&ntype(P=eval(FT2))<4){
13058: R=FT2;
13059: if(P<0) R=-R;
13060: }else if((G==os_md.sqrt||G==dsqrt)&&type(FT2)<2&&ntype(FT2)==0)
13061: R=sqrtrat(FT2);
13062: else if((G==os_md.mylog||G==dlog)&&(FT2==@e||FT2==1))
13063: R=(FT2==1)?0:1;
13064: else if(length(FT)==3) R=eval((*G)(myeval(FT2)));
13065: #ifdef USEMODULE
13066: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
13067: #else
13068: else R=call(G,map(myeval,cdr(cdr(FT))));
13069: #endif
13070: }
13071: else if(G==0) R=FT[2];
13072: #ifdef USEMODULE
13073: else R=eval(call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]));
13074: #else
13075: else R=eval(call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]));
13076: #endif
13077: V=mysubst(V,[FT[0],R]);
13078: F=mysubst(cdr(F),[FT[0],R]);
13079: }
13080: if(type(V)<4 && !iscoef(V,os_md.iscrat)) V=eval(V);
13081: #if 0
13082: return (type(V)<4)?myeval(V):mtransbys(os_md.myeval,V,[]);
13083: #else
13084: return V;
13085: #endif
13086: }
13087:
13088: /* -1:空 0:整数 1:有理数 2:Gauss整数 3:Gauss有理数 4:それ以外の複素数 */
13089: /* def vntype(F)
13090: {
13091: if((T=type(F))<2){
13092: if(T<0) return -1;
13093: if((Tn=ntype(F))==0){
13094: return (isint(F))?0:1;
13095: }
13096: if(Tn==4){
13097: if(ntype(real(F))==0&&ntype(real(F))==0)
13098: return (isint(F)&&isint(F))?2:3;
13099: return 4;
13100: }
13101: }
13102: if(T==2){
13103: V=vars(F);
13104: if((VV=lsort(V,[@e,@pi],1))==[]){
13105: FT=mycoef(
13106: }else{
13107: if(length(VV)==1){
13108: }else
13109: }
13110: }else if(T==3){
13111:
13112: }
13113: }
13114: */
13115:
13116:
13117: def myeval(F)
13118: {
13119: if(type(F)!=4) V=F;
13120: else if(length(F)==1) V=car(F);
13121: else for(V=car(F),F=cdr(F); F!=[];){
13122: FT=car(F);
13123: if(type(G=FT[1])==2){
13124: if(length(FT)==3) R=(*G)(myeval(FT[2]));
13125: #ifdef USEMODULE
13126: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
13127: #else
13128: else R=call(G,map(myeval,cdr(cdr(FT))));
13129: #endif
13130: }
13131: else if(G==0) R=myeval(FT[2]);
13132: #ifdef USEMODULE
13133: else R=call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]);
13134: #else
13135: else R=call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]);
13136: #endif
13137: V=mysubst(V,[FT[0],R]);
13138: F=mysubst(cdr(F),[FT[0],R]);
13139: }
13140: return (type(V)<4)?eval(V):mtransbys(eval,V,[]);
13141: }
13142:
13143: def mydeval(F)
13144: {
13145: if(type(F)!=4) V=F;
13146: else if(length(F)==1) V=car(F);
13147: else for(V=car(F),F=cdr(F); F!=[]; ){
13148: FT=car(F);
13149: if(type(G=FT[1])==2){
13150: if(length(FT)==3) R=(*G)(myeval(FT[2]));
13151: #ifdef USEMODULE
13152: else R=call(G,map(os_md.mydeval,cdr(cdr(FT))));
13153: #else
13154: else R=call(G,map(mydeval,cdr(cdr(FT))));
13155: #endif
13156: }
13157: else if(G==0) R=mydeval(FT[2]);
13158: #ifdef USEMODULE
13159: else R=call(G[0],map(os_md.mydeval,cdr(cdr(FT)))|option_list=G[1]);
13160: #else
13161: else R=call(G[0],map(mydeval,cdr(cdr(FT)))|option_list=G[1]);
13162: #endif
13163: V=mysubst(V,[FT[0],R]);
13164: F=mysubst(cdr(F),[FT[0],R]);
13165: }
13166: return (type(V)<4)?deval(V):mtransbys(deval,V,[]);
13167: }
13168:
13169: def myfeval(F,X)
13170: {
13171: if(type(X)==4){
13172: if(isvar(X[0])&&length(X)==2)
13173: return mydeval(mysubst(F,[X[0],X[1]]));
13174: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
13175: for(Y=X;Y!=[];Y=cdr(Y))
13176: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
13177: return myeval(F);
13178: }
13179: }
13180: return myeval(mysubst(F,[x,X]));
13181: }
13182:
13183: def myf2eval(F,X,Y)
13184: {
13185: return myeval(mysubst(F,[[x,X],[y,Y]]));
13186: }
13187:
13188: def myf3eval(F,X,Y,Z)
13189: {
13190: return myeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
13191: }
13192:
13193: def myfdeval(F,X)
13194: {
13195: if(type(X)==4){
13196: if(isvar(X[0])&&length(X)==2)
13197: return mydeval(mysubst(F,[X[0],X[1]]));
13198: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
13199: for(Y=X;Y!=[];Y=cdr(Y))
13200: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
13201: return mydeval(F);
13202: }
13203: }
13204: return mydeval(mysubst(F,[x,X]));
13205: }
13206:
13207: def myf2deval(F,X,Y)
13208: {
13209: return mydeval(mysubst(F,[[x,X],[y,Y]]));
13210: }
13211:
13212: def myf3deval(F,X,Y,Z)
13213: {
13214: return mydeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
13215: }
13216:
13217: def df2big(F)
13218: {
13219: AG=[[os_md.mysin,sin],[os_md.mycos,cos],[os_md.mytan,tan],[os_md.myasin,asin],
13220: [os_md.acos,acos],[os_md,atan,atan],[os_md.myexp,exp],[os_md.mylog,log],[os_md.mypow,pow]];
13221: if(getopt(inv)!=1) return mysubst(F,AG);
13222: else return mysubst(F,AG|inv=1);
13223:
13224: }
13225:
13226: def f2df(F)
13227: {
13228: if(type(Opt=getopt(opt))!=1) Opt=0;
13229: if(iand(Opt,1)){
13230: if(Opt>0) F=map(eval,F);
13231: else F=map(deval,F);
13232: }
13233: Cpx=getopt(cpx);
13234: if(type(F)==4 && iand(Opt,2)==0) return F;
13235: K=getopt(level);
13236: if(type(K)!=1) K=0;
13237: AG=[sin,cos,tan,asin,acos,atan,exp,sinh,cosh,tanh,log,pow];
13238: AGd=[os_md.mysin,os_md.mycos,os_md.mytan,os_md.myasin,os_md.myacos,
13239: os_md.myatan,os_md.myexp,os_md.myexp,os_md.myexp,os_md.myexp,
13240: os_md.mylog,os_md.sqrt,os_md.myexp];
13241: for(R=[],I=0,Arg=vars(F);Arg!=[];Arg=cdr(Arg)){
13242: Fn=functor(car(Arg));
13243: if(vtype(Fn)!=3) continue;
13244: V=args(car(Arg));
13245: for(PAG=AG,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)){
13246: if(Fn==car(PAG)){
13247: if(K==0) L="z__";
13248: else L="z"+rtostr(K)+"__";
13249: if(I==0) VC=makev([L]);
13250: else VC=makev([L,I]);
13251: I++;
13252: VC0=VC;
13253: if(Fn==sinh || Fn==cosh || Fn==tanh){
13254: VC=makev([L,I++]);
13255: if(Fn==sinh)
13256: R=cons([VC0,0,(VC^2-1)/(2*VC)],R);
13257: else if(Fn==cosh)
13258: R=cons([VC0,0,(VC^2+1)/(2*VC)],R);
13259: else
13260: R=cons([VC0,0,(VC^2-1)/(VC^2+1)],R);
13261: }
13262: if(Fn==pow && (V[1]!=1/2||Cpx==1)){
13263: #if 0
13264: R0=f2df(V[1]*((type(V[0])==1)?dlog(V[0]):log(V[0]))|level=K+1);
13265: PAGd=cdr(PAGd);
13266: #else
13267: R=cons([VC,os_md.mypow,V[0],V[1]],R);
13268: F=mysubst(F,[car(Arg),VC0]);
13269: Arg=cons(0,vars(F));
13270: break;
13271: #endif
13272: }else R0=f2df(V[0]|level=K+1);
13273: R=cons([VC,car(PAGd),R0],R);
13274: F=mysubst(F,[car(Arg),VC0]);
13275: Arg=cons(0,vars(F));
13276: break;
13277: }
13278: }
13279: }
13280: if(R==[]) return F;
13281: if(Cpx==1){
13282: for(PAG=P,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd))
13283: R=mysubst(R,[car(PADd),car(PAG)]);
13284: }
13285: return cons(F,reverse(R));
13286: }
13287:
13288: def todf(F,V)
13289: {
13290: if(type(V)!=4) V=[V];
13291: for(R=[];V!=[];V=cdr(V)){
13292: R=cons(f2df(car(V)),R);
13293: }
13294: V=reverse(R);
13295: Z=makenewv([F,V]);
13296: return [Z,cons(Z,cons(F,V))];
13297: }
13298:
13299: def compdf(F,V,G)
13300: {
13301: FL=["abs","floor","rint","zeta","gamma","arg","real","imag","conj"];
13302: FS=[os_md.abs,floor,rint,os_md.zeta,os_md.gamma,os_md.myarg,real,imag,conj];
13303: if(type(F)==7){
13304: if(str_str(F,"|")==0){
13305: F="abs("+str_cut(F,1,str_len(F)-2)+")";
13306: }else if(str_str(F,"[")==0){
13307: F="floor("+str_cut(F,1,str_len(F)-2)+")";
13308: }
13309: I=str_str(F,"(");
13310: Var=x;
13311: if(I>0){
13312: J=str_pair(F,I+1,"(",")");
13313: if(J<0) return 0;
13314: Var=eval_str(str_cut(F,I+1,J-1));
13315: Var=f2df(Var);
13316: F0=str_cut(F,0,I-1);
13317: }
13318: if((I=findin(F0,FL))<0&&(I=findin(F,FL))<0) F=f2df(eval_str(F));
13319: else F=[z__,[z__,FS[I],Var]];
13320: }
13321: if(type(F)!=4) F=f2df(F);
13322: if(type(G)!=4) G=f2df(G);
1.20 takayama 13323: if(V==G) return F; /* subst(F(V),V,G) */
1.6 takayama 13324: VF=vars(F);VG=vars(G);
1.20 takayama 13325: if(type(V)==4){
13326: for(VT=[],VV=V;VV!=[];VV=cdr(VV)){
13327: if(findin(car(VV),VF)>=0){
13328: X=makenewv(append(VF,VG));
13329: VF=cons(X,VF);
13330: F=mysubst(F,[car(VV),X]);
13331: VT=cons(X,VT);
13332: }else VT=cons(car(VV),VT);
13333: }
13334: for(V=reverse(VT);V!=[];V=cdr(V),G=cdr(G)) F=compdf(F,car(V),car(G));
13335: return F;
13336: }
1.6 takayama 13337: for(E=I=0;I<30;I++){
13338: for(J=0;J<30;J++){
13339: X=makev(["z__",I,J]);
13340: if(findin(X,VF)<0 && findin(X,VG)<0){
13341: E=1;break;
13342: }
13343: }
13344: if(E) break;
13345: }
13346: if(!E) return 0;
13347: if(type(G)<4) return mysubst(F,[V,G]);
13348: if(type(F)<4) F=[F]; /* return compdf([X,[X,0,F]],V,G); */
13349: F=mysubst(F,[V,X]);
13350: if(isvar(G[0])){
13351: G=mysubst(G,[G[0],X]);
13352: if(length(G)==2&&type(G[1])==4&&G[1][0]==X) G=G[1];
13353: G=cons(G,cdr(F));
13354: }
13355: else G=cons([X,0,G],cdr(F));
13356: return cons(car(F),G);
13357: }
13358:
13359: def fzero(F,LX)
13360: {
13361: if(length(LX)==3){
13362: V=LX[0];LX=cdr(LX);
13363: }else V=x;
13364: LX1=eval(LX[0]);LX2=eval(LX[1]);
13365: if(getopt(zero)==1){
13366: if(getopt(cont)==1) CT=1;
13367: else CT=0;
13368: if(getopt(trans)!=1 && type(F)<4) F=f2df(F);
13369: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
13370: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
13371: V1=myeval(mysubst(F,[V,X1=LX1]));
13372: V2=myeval(mysubst(F,[V,X2=LX2]));
13373: if(V1>0){
13374: V0=V1;V1=V2;V2=V0;
13375: X0=X1;X1=X2;X2=X0;
13376: }
13377: if(V1<0 && V2>0){
13378: D=(V2-V1)*1024;
13379: for(I=0; I<Dev; I++){
13380: /* mycat([D,X1,V1,X2,V2]) ; */
13381: if(iand(I,1)) X0=(X1+X2)/2;
13382: else X0=(V2*X1-V1*X2)/(V2-V1);
13383: V0=myeval(mysubst(F,[V,X0]));
13384: if(V0==0||V0==V1||V0==V2) return [X0,V0];
13385: if(V0<0){
13386: if(!CT && V0+D<0) return [];
13387: V1=V0;X1=X0;
13388: }else{
13389: if(!CT && V0>D) return [];
13390: V2=V0;X2=X0;
13391: }
13392: }
13393: X0=(V2*X1-V1*X2)/(V2-V1);
13394: return [X0,myeval(mysubst(F,[V,X0]))];
13395: }
13396: if(V0==0) return [X0,V0];
13397: if(V1==0) return [X1,V1];
13398: return [];
13399: }
13400: if(type(F)<4) F=f2df(F);
13401: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
13402: L=[];
13403: if(type(F)<4){
13404: if(type(F)==3) F=nm(red(F));
13405: if((Deg=deg(F,V))<=2){
13406: if(Deg==2){
13407: D=(C1=coef(F,1,V))^2-4*(C2=coef(F,2,V))*coef(F,0,V);
13408: if(D>=0){
13409: R=dsqrt(D);
13410: if((S=(-C1+R)/(2*C2))>=LX1&&S<=LX2) L=[[S,mysubst(F,[V,S])]];
13411: if(D!=0 && (S=(-C1-R)/(2*C2))>=LX1&&S<=LX2) L=cons([S,mysubst(F,[V,S])],L);
13412: }
13413: L=qsort(L);
13414: }else if(Deg==1&&(S=-coef(F,0,V)/coef(F,1,V))>=LX1&&S<=LX2)
13415: L=[[S,mysubst(F,[V,S])]];
13416: return L;
13417: }
13418: for(L=[];S!=[];S=cdr(S))
13419: if(car(S)>=LX1&&car(S)<=LX2) L=cons([car(S),mysubst(F,[V,car(S)])],L);
13420: return qsort(L);
13421: }
13422: if(type(Div=getopt(mesh))!=1 || Div<=0)
13423: Div = 2^(10);
13424: W=(LX2-LX1)/Div;
13425: for(I=V2=0;I<=Div;I++){
13426: X1=X2;X2=LX1+I*W;V1=V2;
13427: if((V2=myeval(mysubst(F,[V,X2])))==0)
13428: L=cons([X2,V2],L);
13429: if(V1*V2<0){
13430: L0=fzero(F,[V,X1,X2]|zero=1,trans=1);
13431: if(L0!=[]) L=cons(L0,L);
13432: }
13433: }
13434: return reverse(L);
13435: }
13436:
13437: def fmmx(F,LX)
13438: {
13439: if(length(LX)==3){
13440: V=LX[0];LX=cdr(LX);
13441: }else V=x;
13442: LX1=eval(LX[0]);LX2=eval(LX[1]);
13443: FT=F;
13444: if(getopt(trans)!=1 && type(F)<4) FT=f2df(FT);
13445: FT=mysubst(FT,[[@pi,eval(@pi)],[@e,eval(@e)]]);
13446: if(type(G=getopt(dif))>=1){
13447: if(G==1) G=os_md.mydiff(F,V);
13448: L=fzero(G,[V,LX1,LX2]|option_list=getopt());
13449: R=[[LX1,myeval(mysubst(FT,[V,LX1]))]];
13450: for(I=0;L!=[];L=cdr(L),I++){
13451: X=car(L)[0];
13452: if(X==LX1) continue;
13453: R=cons([X,myeval(mysubst(FT,[V,X]))],R);
13454: }
13455: if(X!=LX2) R=cons([LX2,myeval(mysubst(FT,[V,LX2]))],R);
13456: if(getopt(mmx)!=1) return reverse(R);
13457: for(Mi=Ma=car(R);R!=[];R=cdr(R)){
13458: if(car(R)[1]>Ma[1]) Ma=car(R);
13459: else if(car(R)[1]<Mi[1]) Mi=car(R);
13460: }
13461: return [Mi,Ma];
13462: }
13463: if(type(Div=getopt(mesh))!=1 || Div<=0)
13464: Div = 2^(10);
13465: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
13466: W=(LX2-LX1)/Div;
13467: for(I=V2=V3=0;I<=Div;I++){
13468: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
13469: V3=myeval(mysubst(FT,[V,X3]));
13470: if(I==0) L=[[X3,V3]];
13471: if(I<2) continue;
13472: if((V1-V2)*(V2-V3)<0){
13473: X02=X2;V02=V2;X03=X3;V03=V3;
13474: for(J=0; J<Dev && X1!=X3; J++){
13475: X12=(X1+X2)/2;V12=myeval(mysubst(FT,[V,X12]));
13476: if((V1-V12)*(V12-V2)<=0){
13477: X3=X2;V3=V2;X2=X12;V2=V12;continue;
13478: }
13479: X23=(X2+X3)/2;V23=myeval(mysubst(FT,[V,X23]));
13480: if((V12-V2)*(V2-V23)<=0){
13481: X1=X12;V1=V12;X3=X23;V3=V23;continue;
13482: }
13483: if((V2-V23)*(V23-V3)<=0){
13484: X1=X2;V1=V2;X2=X23;V2=V23;continue;
13485: }
13486: }
13487: L=cons([X2,V2],L);
13488: X2=X02;V2=V02;X3=X03;V3=V03;
13489: }
13490: }
13491: L=cons([LX2,myeval(mysubst(FT,[V,LX2]))],L);
13492: if(getopt(mmx)!=1) return L;
13493: for(Mi=Ma=car(L);L!=[];L=cdr(L)){
13494: if(car(L)[1]>Ma[1]) Ma=car(L);
13495: else if(car(L)[1]<Mi[1]) Mi=car(L);
13496: }
13497: return [Mi,Ma];
13498: }
13499:
13500: def flim(F,L)
13501: {
13502: FD=f2df(F);
13503: Lim0=4;Lim=12;FS=1;
13504: if(type(Pc=getopt(prec))==1){
13505: if((Pc>1&&Pc<31)||Pc>-5) Lim+=Pc;
13506: }
13507: if(type(Pc=getopt(init))==1 && Pc>0) FS*=Pc;
13508: if(type(L)==7) L=[L];
13509: else if(type(L)<2){
13510: K=flim(F,["+",L]|option_list=getopt());
13511: if(K=="") return K;
13512: K1=flim(F,["-",L]|option_list=getopt());
13513: if(K1=="") return K1;
13514: if(type(K)==7||type(K1)==7){
13515: if(K!=K1) return "";
13516: return K;
13517: }
13518: if(abs(K)<10^(-5)){
13519: if(abs(K1)<10^(-5)) return (K1+K)/2;
13520: else return "";
13521: }
13522: if(abs((K1-K)/K)<10^(-4)) return (K1+K)/2;
13523: return "";
13524: }
13525: if(type(L)!=4||type(L[0])!=7) return "";
13526: if(L[0]=="-"||L[0]=="-infty"){
13527: FS=-FS;
13528: }else if(L[0]!="+"&&L[0]!="infty") return "";
13529: FI=(length(L)==1)?1:0;
13530: for(Inf=0,I=Lim0;I<Lim;I++){
13531: D1=FS*8^I;D2=8*D1;
13532: if(FI==0){
13533: D1=1/D1;D2=1/D2;
13534: }
13535: if(D1>D2){
13536: D=D1;D1=D2;D1=D;
13537: X1=D1;X2=D2;
13538: }
13539: if(FI==0){
13540: D1+=L[1];D2+=L[1];
13541: }
13542: K=fmmx(FD,[D1,D2]|mmx=1,mesh=16,dev=4);
13543: if(I>Lim0){
13544: if(DF<K[1][1]-K[0][1]&&DF>10^(-8)&&DF<10^7){
13545: if(I>Lim0+1){
13546: if(Inf==0) return "";
13547: }else Inf=1;
13548: }else if(Inf==1) return "";
13549: }
13550: DF=K[1][1]-K[0][1];
13551: }
13552: if(Inf==1){
13553: if(K[0][1]>10^8) return "+";
13554: else if(K[1][1]<-10^8) return "-";
13555: return "";
13556: }
13557: V=(myfeval(FD,D1)+1.0)-1.0;
13558: if(V!=0 && abs(V)<10^(-9)) return 0;
13559: return V;
13560: }
13561:
13562: def fcont(F,LX)
13563: {
13564: if(length(LX)==3){
13565: V=LX[0];LX=cdr(LX);
13566: }else V=x;
13567: LX1=eval(LX[0]);LX2=eval(LX[1]);
13568: if(getopt(trans)!=1 && type(F)<4) FT=f2df(F);
13569: if(type(Div=getopt(mesh))!=1 || Div<=0)
13570: Div = 2^(10);
13571: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
13572: W=(LX2-LX1)/Div;
13573: if((Df=getopt(dif))!=1){
13574: Df=0;
13575: }else{
13576: if(Dev==16) Dev=6;
13577: WD=W/2^(Dev+1);
13578: }
13579: F=FT;
13580: C=2;
13581: for(I=V2=V3=0;I<=Div;I++){
13582: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
13583: V3=myeval(mysubst(F,[V,X3]));
13584: if(Df){
13585: if(I==Div) break;
13586: V3=(myeval(mysubst(F,[V,X3+WD]))-V3)/WD;
13587: }
13588: if(I==0) L=[[X3,V3]];
13589: if(I<2) continue;
13590: if(C*dabs(2*V2-V1-V3) > dabs(V1-V3)){
13591: X01=X1;V01=V1;X02=X2;V02=V2;X03=X3;V03=V3;
13592: for(J=0; X01!=X03; J++){
13593: if(dabs(V01-V02)>dabs(V02-V03)){
13594: X03=X02;V03=V02;
13595: }else{
13596: X01=X02;V01=V02;
13597: }
13598: if(J==Dev) break;
13599: X02=(X01+X02)/2;
13600: V02=myeval(mysubst(F,[V,X02]));
13601: if(Df) V02=(myeval(mysubst(F,[V,WD]))-V02)/WD;
13602: if(C*dabs(2*V02-V01-V03) < dabs(V01-V03)) break;
13603: }
13604: if(J==Dev||X01==X03) L=cons([X01,X03,V03-V01],L);
13605: }
13606: }
13607: return reverse(L);
13608: }
13609:
13610: def xygraph(F,N,LT,LX,LY)
13611: {
13612: if((Proc=getopt(proc))!=1&&Proc!=2&&Proc!=3) Proc=0;
13613: if(type(DV=getopt(dviout))==4){
13614: OL=delopt(getopt(),["dviout","shift","ext","cl"]);
13615: OL=cons(["proc",1],OL);
13616: R=xygraph(F,N,LT,LX,LY|option_list=OL);
13617: OL=delopt(getopt(),["shift","ext","cl"]|inv=1);
13618: return execdraw(R,DV|optilon_list=OL);
13619: }
13620: if(N==0) N=32;
13621: if(N<0){
13622: N=-N;
13623: N1=-1; N2=N+1;
13624: }else{
13625: N1=0; N2=N;
13626: }
13627: if(length(LT)==3 && isvar(LT[0])==1){
13628: TT=LT[0]; LT=cdr(LT);
13629: F=mysubst(F,[TT,x]);
13630: }
13631: if(LX==0) LX=LT;
13632: if((Acc=getopt(Acc))!=1) Acc=0;
13633: if(Acc){
13634: LX=[eval(LX[0]),eval(LX[1])];
13635: LY=[eval(LY[0]),eval(LY[1])];
13636: LT=[eval(LT[0]),eval(LT[1])];
13637: }else{
13638: LX=[deval(LX[0]),deval(LX[1])];
13639: LY=[deval(LY[0]),deval(LY[1])];
13640: LT=[deval(LT[0]),deval(LT[1])];
13641: }
13642: TD=(LT[1]-LT[0])/N;
13643: if(type(Mul=getopt(scale))!=1){
13644: if(type(Mul)==4){
13645: MulX=Mul[0]; MulY=Mul[1];
13646: }else MulX=MulY=1;
13647: }else MulX=MulY=Mul;
13648: if(type(Org=getopt(org))==4){
13649: Orgx=Org[0];Orgy=Org[1];
13650: }else Orgx=Orgy=0;
13651: if(type(F)!=4 || (getopt(para)!=1 && length(F)>1 && type(F[0])<4 && type(F[1])==4)) {
13652: if(getopt(rev)!=1){
13653: F1=x; /* LX[0]+(LX[1]-LX[0])*(x-LT[0])/(TD*N); */
13654: F2=F;
13655: }else{
13656: F1=F;
13657: F2=x; /* LY[0]+(LY[1]-LY[0])*(x-LT[0])/(TD*N); */
13658: }
13659: }else{
13660: F1=F[0]; F2=F[1];
13661: }
13662: if(F1==0 || F2==0) LT=[];
13663: if(length(LT)==2){
13664: if(Acc){
13665: for(LTT=[],I=N2;I>=N1;I--)
13666: LTT=cons(eval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
13667: }else{
13668: for(LTT=[],I=N2;I>=N1;I--)
13669: LTT=cons(deval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
13670: }
13671: LT=LTT;
13672: }
13673: Cpx=getopt(cpx);
13674: if(Cpx!=1 && (str_str(rtostr(F1),"@i")>=0 || str_str(rtostr(F2),"@i")>=0))
13675: Cpx=1;
13676: if(type(Cpx)<0) Cpx=0;
13677: if(!Acc){
13678: if(type(F1)<4) F1=f2df(F1);
13679: if(type(F2)<4) F2=f2df(F2);
13680: }
13681: if(type(Err=getopt(err))==1){
13682: F1=mysubst(F1,[x,x+Err*TD/1001.23]);
13683: F2=mysubst(F2,[x,x+Err*TD/1001.23]);
13684: }
13685: if(type(F1)==4 || type(F2)==4){
13686: Dn=1;
13687: }else Dn=dn(F1)*dn(F2);
13688: for(V=[],PT=LT;PT!=[]; PT=cdr(PT)){
13689: T=car(PT);
13690: if(myfeval(Dn,T)==0){
13691: V=cons(0,V); continue;
13692: }
13693: if(Cpx>0||Acc){
13694: X=myfeval(F1,T);Y=myfeval(F2,T);
13695: }else{
13696: X=myfdeval(F1,T);Y=myfdeval(F2,T);
13697: }
13698: if((N1==0||(PT!=LT&&length(PT)!=1)) && (X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1]))
13699: V=cons(0,V);
13700: else
13701: V=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],V);
13702: }
13703: V=reverse(V);
13704: Gap0=Gap=Arg=0;
13705: if(type(Prec=getopt(prec))<0)
13706: Level=0;
13707: else if(Prec==0) Level=4;
13708: else if(type(Prec)==1){
13709: Level=Prec;
13710: if(Level<0){
13711: Level=-Level;
13712: Gap0=1;
13713: }
13714: }else if(type(Prec)==4){
13715: Level=Prec[0];
13716: if(length(Prec)>1) Arg=Prec[1];
13717: if(length(Prec)>2) Gap0=Prec[2];
13718: }
13719: if(Level>0){
13720: if(Level>16) Level=16;
13721: if(Arg<=0) Arg=30;
13722: else if(Arg>120) Arg=120;
13723: Arg=Acc?eval(@pi*Arg/180):deval(@pi*Arg/180);
13724: SL=dcos(Arg);
13725: }
13726: if(Gap0>0){
13727: if(Gap0<2) Gap0=16;
13728: else if(Gap0>512) Gap0=512;
13729: Gap=((MulX*(LX[1]-LX[0]))^2+(MulY*(LY[1]-LY[0]))^2)/(Gap0^2);
13730: }
13731: for(I=0;I<Level;I++){
13732: for(F=K=G=0,NV=NLT=[],PLT=LT,PV=V;PLT!=[];K++,PLT=cdr(PLT),PV=cdr(PV)){
13733: TG=0;D0=D1;CLT0=CLT;CV0=CV;CV=car(PV);CLT=car(PLT);
13734: if(length(PV)>1){
13735: if((CV1=car(cdr(PV)))!=0 && CV!=0)
13736: D1=[CV[0]-CV1[0],CV[1]-CV1[1]];
13737: else D1=0;
13738: }else K=-1; /* ? */
13739: if(K>0 &&(((D1==0||D0==0)&&(CV0!=0||CV!=0||CV1!=0)) || dvangle(D0,D1)<SL ||
13740: (Gap>0 && type(D0)==4 && (TG=(D0[0]^2+D0[1]^2-Gap)>0)))){
13741: G++;T1=(CLT0+CLT)/2;
13742: if(F==0 && (CV0!=0 || CV!=0)){
13743: if(myfdeval(Dn,T1)==0){
13744: NV=cons(0,NV); NLT=cons(T1,NLT);
13745: }
13746: if(Cpx>0||Acc){
13747: X=myfeval(F1,T1);Y=myfeval(F2,T1);
13748: }else{
13749: X=myfdeval(F1,T1);Y=myfdeval(F2,T1);
13750: }
13751: if(K==1 && N1<0){
13752: NV=[];NLT=[];
13753: }
13754: if((K>1||N1==0)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
13755: NV=cons(0,NV);NLT=cons(T1,NLT);F=0;
13756: }else{
13757: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T1,NLT);
13758: }
13759: }
13760: NV=cons(CV,NV);NLT=cons(CLT,NLT);
13761: if(!TG&&(CV0!=0||CV1!=0)){
13762: T2=(car(cdr(PLT))+CLT)/2;
13763: if(myfdeval(Dn,T2)==0){
13764: NV=cons(0,NV); NLT=cons(CLT,NLT);
13765: }
13766: if(Cpx>0||Acc){
13767: X=myfeval(F1,T2);Y=myfeval(F2,T2);
13768: }else{
13769: X=myfdeval(F1,T2);Y=myfdeval(F2,T2);
13770: }
13771: if((N1==0||length(PV)!=2)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
13772: NV=cons(0,NV);NLT=cons(T1,NLT);
13773: }else{
13774: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T2,NLT);
13775: }
13776: }
13777: if(length(PV)==2 && N1==-1) break;
13778: F=1;
13779: }else{
13780: F=0;NV=cons(CV,NV);NLT=cons(CLT,NLT);
13781: }
13782: }
13783: V=reverse(NV);LT=reverse(NLT);
13784: if(G==0) break;
13785: }
13786: if(Gap>0){
13787: for(NV=[],PV=V;PV!=[];PV=cdr(PV)){
13788: NV=cons(P0=car(PV),NV);
13789: if(length(PV)>1 && P0!=0 && PV[1]!=0
13790: && (P0[0]-PV[1][0])^2+(P0[1]-PV[1][1])^2>Gap) NV=cons(0,NV);
13791: }
13792: V=reverse(NV);
13793: }
1.18 takayama 13794: if((Raw=getopt(raw))==1) return V;
13795: if(Raw==2) return [V,LT];
1.6 takayama 13796: OL=[["curve",1]];OLP=[];
13797: if(type(C=getopt(ratio))==1){
13798: OL=cons(["ratio",C],OL);OLP=cons(["ratio",C],OLP);
13799: }
13800: if(Acc==1) OL=cons(["Acc",1],OL);
13801: if(N1<0) OL=cons(["close",-1],OL);
13802: if(type(Opt=getopt(opt))!=7 && type(Opt)!=4){
13803: if(Opt==0) return xylines(V|option_list=cons(["opt",0],OL));
13804: }
13805: OL=cons(["opt",(Proc)?0:Opt],OL);
13806: if(type(Opt)>=0) OLP=cons(["opt",Opt],OLP);
13807: if(type(Vb=getopt(verb))==1||type(Vb)==4){
13808: OL=cons(["verb",Vb],OL);OLP=cons(["verb",Vb],OL);
13809: }
13810: if(Proc){
13811: S=(Proc==1)?
13812: [[0,[MulX*(LX[0]-Orgx),MulX*(LX[1]-Orgx)],[MulY*(LY[0]-Orgy),MulY*(LY[1]-Orgy)],
13813: (TikZ)?1:1/10]]:[];
13814: S=cons([1,OLP,xylines(V|option_list=OL)],S);
13815: if(Proc==3) return car(S);
13816: }else S=xylines(V|option_list=OL);
13817: if(type(Pt=getopt(pt))==4){
13818: if(type(Pt[0])!=4) Pt=[Pt];
13819: if(length(Pt)>1 && type(Pt[1])!=4) Pt=[Pt];
13820: for(PT=Pt;PT!=[];PT=cdr(PT)){
13821: PP=car(PT);
13822: if(type(PP[0])!=4) PP=[PP];
13823: P=car(PP);PP=cdr(PP);
13824: Qx=MulX*(P[0]-Orgx);Qy=MulY*(P[1]-Orgy);
13825: if(length(PP)>0 && type(PP[0])==4){ /* draw line */
13826: P=car(PP);
13827: Q1x=MulX*(P[0]-Orgx);Q1y=MulY*(P[1]-Orgy);
13828: if(length(PP)<1 || car(PP)==0 || iand(car(PP),1))
13829: OL=["opt",(TikZ)?"-":"@{-}"];
13830: else OL=["opt",(TikZ)?".":"@{.}"];
13831: if(Proc) S=cons([1,OL,[[Qx,Qy],[Q1x,Q1y]]],S);
13832: else S=S+xylines([[Qx,Qy],[Q1x,Q1y]]|optilon_list=OL);
13833: continue;
13834: }
13835: if(length(PP)==0 || type(car(PP))!=7) SS="$\\bullet$";
13836: else SS=car(PP);
13837: if(length(PP)<=1){
13838: if(Proc) S=cons([2,[],[Qx,Qy],[SS]],S);
13839: else S=S+xyput([Qx,Qy,SS]);
13840: }else{
13841: if(Proc) S=cons([2,[],[Qx,Qy],[[SS],"",PP[1]]],S);
13842: S=S+xyput([Qx,Qy,SS,"",PP[1]]);
13843: }
13844: }
13845: }
13846: if(type(Ax=getopt(ax))==4){ /* draw axis */
13847: Adx0=Ady0=0; Adx1=Ady1=0.1;
13848: if(!TikZ){
13849: if(!XYcm) Adx1=Ady1=1;
13850: LOp="@{-}"; LxOp="+!U"; LyOp="+!R";
13851: }else{
13852: LOp="-"; LxOp="below"; LyOp="left";
13853: }
13854: LOp0=LOp1=LOp;
13855: LxOO=(Ax[1]==LY[0])?LxOp:(TikZ)?"below left":"+!UR";
13856: if(type(AxOp=getopt(axopt))>0){
13857: if(type(AxOp)==1){
13858: if(AxOp>0) Adx1=Ady1=AxOp;
13859: else if(AxOp<0){
13860: Adx1=Ady1=0; Adx0=Ady0=AxOp;
13861: }
13862: }else if(type(AxOp)==4){
13863: if(type(T=car(AxOp))==4 && length(AxOp)>1){
13864: if(type(T)==7){
13865: LxOp=T; LyOp=AxOp[1];
13866: }else if(type(T)==4){
13867: Ay0=T[0]; Ay1=T[1]; Ax0=AxOp[1][0]; Ax1=AxOp[1][1];
13868: if(length(T)>2) LxOp=T[2];
13869: if(length(AxOp[1])>2) LyOp=AxOp[1][2];
13870: }
13871: }
13872: if(length(AxOp)>2 && type(AxOp[2])==7) LxOO=AxOp[2];
13873: if(length(AxOp)>3 && type(AxOp[3])==7) LOp0=AxOp[3];
13874: if(length(AxOp)>4 && type(AxOp[4])==7) LOp1=AxOp[4];
13875: }
13876: if(type(AxOp)==7) LOp0=AxOp;
13877: }
13878: if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */
13879: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp0]]:[],
13880: [MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],[MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]],S);
13881: else S=S+xyarrow([MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],
13882: [MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]|opt=LOp0);
13883: if(length(Ax)>2){
13884: D=Ax[2];
13885: if(type(D)==1 && D>0){
13886: I0=ceil((LX[0]-Ax[0])/D); I1=floor((LX[1]-Ax[0])/D);
13887: for(DD=[],I=I0; I<=I1; I++){
13888: if(length(Ax)<5) DD=cons(I*D,DD);
13889: else if(Ax[4]==0) DD=cons([I*D,I*D+Ax[0]],DD);
13890: else if(Ax[4]==1) DD=cons([I*D,I*D],DD);
13891: else if(Ax[4]==2) DD=cons([I*D,I],DD);
13892: }
13893: D=DD;
13894: }
13895: if(type(D)==4){
13896: for(;D!=[]; D=cdr(D)){
13897: T=car(D);
13898: if(type(T)==4) T=car(T);
13899: X=MulX*(T+Ax[0]-Orgx); Y=MulY*(Ax[1]-Orgy);
13900: if(T!=0){
13901: if(Proc) S=cons([3,(type(LOp1)>=0)?[["opt",LOp1]]:[],[X,Y+Ady0],[X,Y+Ady1]],S);
13902: else S=S+xyarrow([X,Y+Ady0],[X,Y+Ady1]|opt=LOp1);
13903: }
13904: if(type(car(D))==4){
13905: Arg=[(T==0)?LxOO:LxOp,D[0][1]];
13906: if(Proc) S=cons([2,[],[X,Y+Ady0],[Arg]],S);
13907: else S=S+xyput([X,Y+Ady0,Arg]);
13908: }
13909: }
13910: }
13911: }
13912: }
13913: if(Ax[1]>=LY[0] && Ax[1]<=LY[1]){ /* draw marks on y-axis */
13914: if(Proc) S=cons([3,[["opt",LOp0]],
13915: [MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
13916: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]],S);
13917: else S=S+xyarrow([MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
13918: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]|opt=LOp0);
13919: if(length(Ax)>3){
13920: D=Ax[3];
13921: if(type(D)==1 && D>0){
13922: I0=ceil((LY[0]-Ax[1])/D); I1=floor((LY[1]-Ax[0])/D);
13923: for(DD=[],I=I0; I<=I1; I++){
13924: if(length(Ax)<5) DD=cons(I*D,DD);
13925: else if(I!=0){
13926: if(Ax[4]==0) DD=cons([I*D,I*D+Ax[1]],DD);
13927: if(Ax[4]==1) DD=cons([I*D,I*D],DD);
13928: if(Ax[4]==2) DD=cons([I*D,I],DD);
13929: }
13930: }
13931: D=DD;
13932: }
13933: if(type(D)==4){
13934: for(;type(D)==4&&D!=[]; D=cdr(D)){
13935: T=car(D);
13936: if(type(T)==4) T=car(T);
13937: X=MulX*(Ax[0]-Orgx); Y=MulY*(T+Ax[1]-Orgy);
13938: if(T!=0){
13939: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp1]]:[],
13940: [X+Adx0,Y],[X+Adx1,Y]],S);
13941: else S=S+xyarrow([X+Adx0,Y],[X+Adx1,Y]|opt=LOp1);
13942: }
13943: if(type(car(D))==4){
13944: if(Proc) S=cons([2,[],[X,Y+Ady0],[[LyOp,D[0][1]]]],S);
13945: else S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]);
13946: }
13947: }
13948: }
13949: }
13950: }
13951: }
13952: if(Proc) return reverse(S);
13953: if(getopt(dviout)!=1) return S;
13954: xyproc(S|dviout=1);
13955: }
13956:
13957: def xyarrow(P,Q)
13958: {
13959: Cmd = ["fill","filldaw","shade","shadedraw","clip ","pattern","path ","node","coordinate"];
13960: if(type(P)<4) return "%\n";
13961: SS=getopt(opt);
13962: if(!TikZ){
13963: if(type(Q)<4) return "";
13964: S="{"+xypos(P)+" \\ar";
13965: if(type(SS)==7) S=S+SS;
13966: return S+" "+xypos(Q)+"};\n";
13967: }
13968: if(type(SS)==4 && length(SS)>1){
13969: if(length(SS)>2) SU=SS[2];
13970: ST=SS[1];
13971: SS=SS[0];
13972: }
13973: if(type(SS)!=7) SS="->";
13974: if(type(ST)!=7) ST=" -- ";
13975: if(type(SU)!=7) SU="";
13976: if(type(S=getopt(cmd))==7) S="\\"+S;
13977: else S="\\draw";
13978: if(type(Q)!=4){
13979: if(Q>0 && Q<=length(Cmd)) S="\\"+Cmd[Q-1]+"";
13980: if(SS!="-") S=S+"["+SS+"]";
13981: if(SU!="") SU="["+SU+"]";
13982: return S+xypos(P)+ST+SU+";\n";
13983: }
1.8 takayama 13984: if(SS!="-"&&SS!="") S=S+"["+SS+"]";
1.6 takayama 13985: if(length(P)<3 && length(Q)<3)
13986: return S+xypos(P)+ST+xypos(Q)+SU+";\n";
13987: if(length(P)==2) P=[P[0],P[1],"","_0"];
13988: else if(length(P)==3 || (length(P)==4 && P[3]==""))
13989: P=[P[0],P[1],P[2],"_0"];
13990: else if(P[3]=="")
13991: P=[P[0],P[1],P[2],"_0",P[4]];
13992: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
13993: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
13994: Q=[Q[0],Q[1],Q[2],"_1"];
13995: else if(Q[3]=="")
13996: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
13997: return S+xypos(P)+" "+xypos(Q)+"("+P[3]+")"+ST+"("+Q[3]+")"+SU+";\n";
13998: }
13999:
14000: def xyarrows(P,Q,R)
14001: {
14002: PQ=newvect(4);
14003: PQ[0]=(type(P[0])!=4)?f2df(P[0]):P[0];
14004: PQ[1]=(type(P[1])!=4)?f2df(P[1]):P[1];
14005: PQ[2]=(type(Q[0])!=4)?f2df(Q[0]):Q[0];
14006: PQ[3]=(type(Q[1])!=4)?f2df(Q[1]):Q[1];
14007: if(type(R[0])!=4) R=[R];
14008: TR=R[0];NX=TR[2];X=X0=TR[0];DX=(TR[1]-TR[0])/NX;
14009: if(length(R)==2){
14010: TR=R[1];NY=TR[2];Y=TR[0];DY=(TR[1]-TR[0])/NY;
14011: }else{
14012: NY=1;Y=DY=0;
14013: }
14014: if(type(L=getopt(abs))!=1) L=0;
14015: if(type(Sc=getopt(scale))!=1) Sc=0;
14016: OL=[];
14017: if(type(Opt=getopt(opt))==7) OL=cons(["opt",Opt],OL);
14018: Tb=str_tb(0,0);
14019: for(J=0;J<NY;Y+=DY,J++){
14020: for(I=0,X=X0;I<NX;I++,X+=DX){
14021: PX=myf2eval(PQ[0],X,Y);PY=myf2eval(PQ[1],X,Y);
14022: VX=myf2eval(PQ[2],X,Y);VY=myf2eval(PQ[3],X,Y);
14023: if(L>0){
14024: C=dnorm([VX,VY]);
14025: if(C!=0){
14026: VX*=L/C;VY*=L/C;
14027: }
14028: }
14029: if(Sc){
14030: VX*=Sc;VY*=Sc;
14031: }
14032: if(VX||VY) str_tb(xyarrow([PX,PY],[PX+VX,PY+VY]|optilon_list=OL),Tb);
14033: }
14034: }
14035: return str_tb(0,Tb);
14036: }
14037:
14038: def polroots(L,V)
14039: {
14040: INIT=1;
14041: if(type(CF=getopt(comp))!=1) CF=0;
14042: OL=getopt();
14043: if(CF>32){
14044: CF-=64;
14045: INIT=0;
14046: }else OL=cons(["comp",CF+64],delopt(OL,"comp"));
14047: if(type(V)==4&&length(V)==1){
14048: L=L[0];V=V[0];
14049: }
14050: Lim=Lim2=[];
14051: if(type(L)<4){
14052: if(type(Lim=getopt(lim))==4){
1.17 takayama 14053: if(type(Lim[0])!=4){
14054: if(!isvar(Lim[0])) Lim=cons(V,[Lim]);
14055: Lim=[Lim];
14056: }
14057: if(!isvar(Lim[0][0])) Lim=[cons(V,Lim)];
1.6 takayama 14058: Lim=delopt(Lim,V|inv=1);
14059: if(Lim!=[]){
14060: Lim=Lim[0];
14061: if(length(Lim)==3) Lim2=Lim[2];
14062: Lim=Lim[1];
14063: }
14064: }else{
14065: Lim=Lim2=[];
14066: }
14067: if((CF==-2||CF==-1||CF==2)&&iscoef(L,os_md.israt)){ /* Rat+Comp, Rat+Real or Rat */
14068: S=(CF==-1)?getroot(L,V|cpx=1):getroot(L,V);
14069: for(RR=[],F=x;S!=[];S=cdr(S)){
14070: if(findin(V,vars(C=car(S)))<0){ /* Rational solution */
14071: if(type(C)<2){
14072: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
14073: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
14074: }
14075: if(F!=C) RR=cons(F=C,RR);
14076: }else if(CF<0){ /* Irrational solution */
14077: if((R=pari(roots,mysubst(C,[V,x])))!=0){
14078: for(R=vtol(R);R!=[];R=cdr(R))
14079: if((C=car(R))!=F && ntype(C)<CF+6){
14080: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
14081: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
14082: RR=cons(F=C,RR);
14083: }
14084: }
14085: }
14086: }
14087: return qsort(RR);
14088: }
14089: R=pari(roots,subst(L,V,x));
14090: if(R==0){
14091: R=[0];
14092: if(CF==1){
14093: for(R=[0],I=mydeg(L,V);I>1; I--)
14094: R=cons(0,R);
14095: }
14096: return R;
14097: }
14098: if(CF==1){ /* Complex */
14099: if(Lim==[]&&Lim2==[]) return vtol(R);
14100: for(L=[],I=length(R)-1;I>=0;I--){
14101: C=R[I];
14102: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
14103: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
14104: L=cons(C,L);
14105: }
14106: return L;
14107: }
14108: for(L=[],F=x,I=length(R)-1;I>=0;I--){ /* Real */
14109: if(ntype(R[I])<4 && F!=R[I]){
14110: if(Lim!=[] && (R[I]<Lim[0]||R[I]>Lim[1])) continue;
14111: L=cons(F=R[I],L);
14112: }
14113: }
14114: return qsort(L);
14115: }
14116: if(SS==0&&INIT==1){
14117: SS=polroots(L,V|option_list=OL);
14118: if(SS!=0) return SS;
1.18 takayama 14119: for(C=0;SS==0&&C<5;C++){
1.6 takayama 14120: I=(C==0)?1:(iand(random(),0xff)-0x80);
14121: for(LL=[],K=length(L)-1;K>=0;K--){
14122: for(Q=0,J=length(L)-1;J>=0;J--)
14123: Q+=L[J]*(I+K)^J;
14124: LL=cons(Q,LL);
14125: }
14126: SS=polroots(LL,V|option_list=OL);
14127: if(SS!=0) return SS;
14128: }
14129: return SS;
14130: }
14131: C=2^(-32);
14132: if(type(getopt(err))==1) C=err;
14133: if((N=length(V))!=length(L)) return [];
14134: if(N==1) return polroots(L[0],V[0]|option_list=OL);
14135: for(L1=[],I=1;I<N;I++){
14136: Res=res(V[0],L[I-1],L[I]);
14137: if(type(Res)<2) return Res;
14138: L1=cons(res(V[0],L[I-1],L[I]),L1);
14139: }
14140: R=polroots(L1,V1=cdr(V)|option_list=OL);
14141: if(type(R)<2) return R;
14142: for(SS=[];R!=[];R=cdr(R)){
14143: RS=(N==2)?[car(R)]:car(R);
14144: for(I=0,L0=L[0];I<N-1;I++) L0=mysubst(L0,[V1[I],RS[I]]);
1.17 takayama 14145: if(L0==0) return 0;
1.6 takayama 14146: S0=polroots(L0,V[0]|option_list=OL);
14147: if(type(S0)<2) return S0;
14148: for(S=S0;S!=[];S=cdr(S)){
14149: S0=cons(car(S),RS);
14150: for(LT=cdr(L);LT!=[];LT=cdr(LT)){
14151: for(I=0,TV=car(LT);I<N;I++) TV=mysubst(TV,[V[I],S0[I]]);
14152: if(abs(TV)>C) break;
14153: }
14154: if(LT==[]) SS=cons(S0,SS);
14155: }
14156: }
14157: return reverse(SS);
14158: }
14159:
14160: def ptcommon(X,Y)
14161: {
14162: if(length(X)!=2 || length(Y)!=2) return 0;
14163: if(type(X[1])==4){ /* X is a line */
14164: if((In=getopt(in))==-1||In==-2||In==-3){
14165: X0=(X[0][0]+X[1][0])/2;X1=(X[0][1]+X[1][1])/2;
14166: X=[[X0,X1],[X0+X[1][1]-X[0][1],X1-X[1][0]+X[0][0]]];
14167: if(In==-1&&type(Y[1])==4) return ptcommon(Y,X|in=-2);
14168: /* for the second line */
14169: if(In==-3) In=1;
14170: else In=0;
14171: }else if(In==2||In==3){
14172: X=(X[1][0]-X[0][0])+(X[1][1]-X[0][1])*@i;
14173: if(X==0) return 0;
14174: Y=(Y[1][0]-Y[0][0])+(Y[1][1]-Y[0][1])*@i;
14175: X=myarg(Y/X);
14176: return (In==2)?X:(X*180/deval(@pi));
14177: }else if(In!=1) In=0;
14178: if(type(Y[0])<=3){
14179: if(In==1){
14180: return [(Y[1]*X[0][0]+Y[0]*X[1][0])/(Y[0]+Y[1]),
14181: (Y[1]*X[0][1]+Y[0]*X[1][1])/(Y[0]+Y[1])];
14182: }
14183: XX=X[1][0]-X[0][0];YY=X[1][1]-X[0][1];
14184: Arg=(length(Y)<2)?0:Y[1];
14185: Arg=deval(Arg);
14186: if(Arg!=0){
14187: S=dcos(Arg)*XX-dsin(Arg)*YY;
14188: YY=dsin(Arg)*XX+dcos(Arg)*YY;
14189: XX=S;
14190: }
14191: S=dnorm([XX,YY]);
14192: if(S!=0){
14193: XX*=Y[0]/S;YY*=Y[0]/S;
14194: }
14195: return [X[1][0]+XX,X[1][1]+YY];
14196: }
14197: S=[X[0][0]+(X[1][0]-X[0][0])*x_,X[0][1]+(X[1][1]-X[0][1])*x_];
14198: if(type(Y[1])==4){ /* Y is a line */
14199: T=[Y[0][0]+(Y[1][0]-Y[0][0])*y_-S[0],
14200: Y[0][1]+(Y[1][1]-Y[0][1])*y_-S[1]];
14201: R=lsol(T,[x_,y_]);
14202: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
14203: if(!In || (R[0][1]>=0&&R[0][1]<=1&&R[1][1]>=0&&R[1][1]<=1) )
14204: return subst(S,x_,R[0][1],y_,R[1][1]);
14205: }
14206: if((type(R[0])>0&&type(R[0])<4)||(type(R[1])>0&&type(R[1])<4)) return 0;
14207: if(!In) return 1;
14208: I=(X[0][0]==X[1][0]&&Y[0][0]==Y[1][0]&&X[0][0]==Y[0][0])?1:0;
14209: if(X[0][I]<=X[1][I]){
14210: X0=X[0][I];X1=X[1][I];
14211: }else{
14212: X1=X[0][I];X0=X[1][I];
14213: }
14214: return ((Y[0][I]<X0 && Y[1][I]<X0)||(Y[0][I]>X1&&Y[1][I]>X1))?0:1;
14215: }else if(Y[1]==0){ /* orth */
14216: T=[Y[0][0]+(X[1][1]-X[0][1])*y_-S[0],
14217: Y[0][1]-(X[1][0]-X[0][0])*y_-S[1]];
14218: R=lsol(T,[x_,y_]);
14219: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
14220: if(!In||(R[0][1]>=0&&R[0][1]<=1))
14221: return subst(S,x_,R[0][1],y_,R[1][1]);
14222: }
14223: return (X[0]==X[1])?0:1;
14224: }else if(type(Y[1])==1 && Y[1]>0){ /* circle */
14225: T=(S[0]-Y[0][0])^2+(S[1]-Y[0][1])^2-Y[1]^2;
14226: D=mycoef(T,1,x_)^2-4*mycoef(T,0,x_)*mycoef(T,2,x_);
14227: if(D==0){
14228: V=mycoef(T,1,x_)/(2*mycoef(T,2,x_));
14229: if(!in||(V>=0&&V<=1)) return [subst(S,x_,V)];
14230: }
14231: else if((type(D)==1&&D>0)){
14232: D=dsqrt(D);
14233: V=-(mycoef(T,1,x_)+D)/(2*mycoef(T,2,x_));
14234: if(!In||(V>=0&&V<=1)) L=[subst(S,x_,V)];
14235: else L=[];
14236: V=(D-mycoef(T,1,x_))/(2*mycoef(T,2,x_));
14237: if(!In||(V>=0&&V<=1)) L=cons(subst(S,x_,V),L);
14238: if(length(L)>0) return L;
14239: }
14240: }
14241: return 0;
14242: }
14243: if(type(Y[1])==4 || X[1]==0) return ptcommon(Y,X);
14244: /* X is a circle */
14245: if(Y[1]==0){ /* tangent line */
14246: if(Y[0][0]==X[0][0]+X[1] || Y[0][0]==X[0][0]-X[1]) L=[[Y[0][0],X[0][1]]];
14247: else L=[];
14248: P=(Y[0][0]+x_-X[0][0])^2+(Y[0][1]+x_*y_-X[0][1])^2-X[1]^2;
14249: Q=mycoef(P,1,x_)^2-4*mycoef(P,2,x_)*mycoef(P,0,x_);
14250: for(R=polroots(Q,y_);R!=[];R=cdr(R)){
14251: X0=-subst(mycoef(P,1,x_)/(2*mycoef(P,2,x_)),y_,car(R));
14252: L=cons([Y[0][0]+X0,Y[0][1]+car(R)*X0],L);
14253: }
14254: }else{ /* Y is a circle */
14255: P=(x_-X[0][0])^2+(y_-X[0][1])^2-X[1]^2;
14256: Q=(x_-Y[0][0])^2+(y_-Y[0][1])^2-Y[1]^2;
14257: V=(X[0][0]!=Y[0][0])?[x_,y_]:[y_,x_];
14258: R=subst(P,V[0],T=lsol(P-Q,V[0]));
14259: if(type(T[0])<4) return (T[0]==0)?1:0;
14260: S=polroots(R,V[1]);
14261: for(L=[];S!=[];S=cdr(S)){
14262: R=subst(T,V[1],car(S));
14263: if(V[0]==x_) L=cons([R,car(S)],L);
14264: else L=cons([S,R],L);
14265: }
14266: }
14267: if(length(L)!=0) return L;
14268: return 0;
14269: }
14270:
14271: def tobezier(L)
14272: {
14273: if((Div=getopt(div))==1||Div==2){
14274: if(length(L)!=4) return [tobezier(L|inv=[0,1/2]),tobezier(L|inv=[1/2,1])];
14275: if(type(L)==4) L=ltov(L);
14276: if(type(L[0])==4)
14277: L=[ltov(L[0]),ltov(L[1]),ltov(L[2]),ltov(L[3])];
14278: S=[(L[0]+3*L[1]+3*L[2]+L[3])/8];
14279: T=[L[3]];
14280: S=cons((L[0]+2*L[1]+L[2])/4,S);
14281: T=cons((L[2]+L[3])/2,T);
14282: S=cons((L[0]+L[1])/2,S);
14283: T=cons((L[1]+2*L[2]+L[3])/4,T);
14284: S=cons(L[0],S);
14285: T=cons((L[0]+3*L[1]+3*L[2]+L[3])/8,T);
14286: return [S,T];
14287: }
14288: if(Div>2&&Div<257){
14289: L=tobezier(L);
14290: for(R=[],I=Div-1;I>=0;I--)
14291: R=cons(tobezier(L|inv=[I/Div,(I+1)/Div]),R);
14292: return R;
14293: }
14294: if((V=getopt(inv))==1 || type(V)>3){
14295: if(type(L[0])>3 && type(V)>3) L=tobezier(L);
14296: if(type(V)>3 && length(V)>2) V2=V[2];
14297: if(type(V2)!=2) V2=t;
14298: if(type(V)>3) L=subst(L,V2,(V[1]-V[0])*V2+V[0]);
14299: N=mydeg(L,V2);
14300: for(R=[],I=0;I<=N;I++){
14301: RT=mycoef(L,I,V2);
14302: R=cons(RT/binom(N,I),R);
14303: L-=RT*V2^I*(1-V2)^(N-I);
14304: }
14305: return reverse(R);
14306: };
14307: N=length(L)-1;
14308: V=newvect(2);
14309: for(I=0;I<=N;I++,L=cdr(L)){
14310: if(type(X=car(L))==4) X=ltov(X);
14311: V+=X*binom(N,I)*t^I*(1-t)^(N-I);
14312: }
14313: return V;
14314: }
14315:
14316: def cutf(F,X,VV)
14317: {
14318: if(type(car(V=VV))==2){
14319: Y=[car(V),X];
14320: V=cdr(V);
14321: }else Y=X;
14322: if(type(X)>1){
14323: Y=(type(Y)==4)?Y[0]:x;
14324: V1=makenewv(F);
14325: if(X==Y||Y==x){
14326: V2=makenewv([F,V1]);
14327: F=mysubst(F,[Y,V2]);
14328: V=cons(V2,V);
14329: }
14330: return [V1,[V1,os_md.cutf,[F],X,[V]]];
14331: }
14332: if(car(V)!=[] && X<car(V)[0]) return myfeval(car(V)[1],Y);
14333: for(V=cdr(V); ;V=R){
14334: if((R=cdr(V))==[]){
14335: if(car(V)!=[] && car(V)[0]<X) return myfeval(car(V)[1],Y);
14336: return myfeval(F,Y);
14337: }
1.20 takayama 14338: if(car(V)==[]||X>car(V)[0]) continue;
1.6 takayama 14339: if(X==car(V)[0]) return car(V)[1];
14340: return myfeval(F,Y);
14341: }
14342: }
14343:
1.12 takayama 14344: def fsum(F,L)
1.6 takayama 14345: {
1.12 takayama 14346: if(getopt(df)==1){
14347: F=f2df(F);
14348: }else Sub=getopt(subst);
1.6 takayama 14349: if(type(L[0])==2){
14350: X=L[0];
14351: L=cdr(L);
14352: }else X=0;
14353: V=(length(L)>2)?L[2]:1;
14354: for(R=0,I=L[0];;I+=V){
14355: if(V==0||(I-L[1])*V>0) return R;
1.12 takayama 14356: R+=(Sub==1)?subst(F,X?X:x,I):os_md.myfeval(F,X?[X,I]:I);
1.6 takayama 14357: }
14358: }
14359:
14360: def periodicf(F,L,X)
14361: {
14362: if(type(L)==4) L=[eval(L[0]),eval(L[1])];
14363: else L=eval(L);
14364: if(isvar(X)){
1.20 takayama 14365: Y=makenewv([X,F]);
14366: Z=makenewv([X,Y,F]);
1.16 takayama 14367: return [Z,[Z,os_md.periodicf,[mysubst(F,[x,Y])],(type(L)==4)?[L]:L,[[Y,X]]]];
14368: }
14369: if(type(X)==4){
14370: V=X[0];
14371: X=X[1];
14372: }else V=x;
14373: if(type(F)==5){
14374: X=eval(X);
14375: return myfeval(F[floor(X/L)%length(F)],[V,X-floor(X/L)*L]);
1.6 takayama 14376: }
14377: if(type(L)==4){
14378: X-=floor((X-L[0])/(L[1]-L[0]))*(L[1]-L[0]);
14379: return myfeval(F,[V,X]);
14380: }
14381: }
14382:
14383: def cmpf(X)
14384: {
14385: if(type(X)>3){
14386: if(type(L)==7) return [S_Fc,Dx,S_Ic,S_Ec,S_EC,S_Lc];
14387: S_Lc=0;
14388: if(type(S_Fc=X[0])!=4) S_Fc=f2df(S_Fc);
14389: S_Ic=X[1];
14390: if(length(S_Ic)>2){
14391: S_Fc=mysubst(S_Fc,[S_Ic[0],x]);
14392: S_Ic=cdr(S_Ic);
14393: }
14394: S_Dc=(type(S_Ic[0])==7)?1:0;
14395: if(type(S_Ic[1])==7) S_Dc=ior(S_Dc,2);
14396: if(type(S_Ec=getopt(exp))!=1) S_Ec=0;
14397: if(S_Ec<=0){
14398: S_EC=-S_Ec;
14399: if(S_EC==0) S_EC=1;
14400: if(S_Dc==3) S_EC*=2;
14401: else S_EC/=4;
14402: if(type(F=X[0])==3&&vars(F)==[x]&&(D=deg(nm(F),x))==deg(dn(F),x)-2){
14403: S_Lc=S_EC*coef(nm(F),D,x)/coef(dn(F),D+2,x);
14404: }
14405: }else{
14406: S_EC=S_Ec;
14407: if(S_Dc==3) S_EC*=12;
14408: else S_EC/=6;
14409: }
14410: if(type(S_Fc)==3) S_Fc=red(S_Fc);
14411: S_EC=1/S_EC;
14412: return [z_,[z_,os_md.cmpf,x]];
14413: }
14414: if(X<=0 && iand(S_Dc,1)) return S_Lc;
14415: if(X>=1 && iand(S_Dc,2)) return S_Lc;
14416: if(S_Dc==3){
14417: if(S_Ec>0){
14418: Y0=dexp(1/X)*S_EC;
14419: Y1=dexp(1/(1-X))*S_EC;
14420: return myfeval(S_Fc,Y1-Y0)*(Y0/X^2+Y1/(1-X)^2);
14421: }
14422: return myfeval(S_Fc,S_EC/(1-X)-S_EC/X)*(S_EC/(1-X)^2+S_EC/X^2);
14423: }
14424: if(S_Dc==1){
14425: if(S_Ec>0){
14426: Y=dexp(1-1/X);
14427: R=myfeval(S_Fc,S_EC*(Y-1)+I[1])*Y;
14428: }
14429: else R=myfeval(S_Fc,I[1]+(1-1/X)*S_EC);
14430: return R*S_EC/X^2;
14431: }
14432: if(S_Dc==2){
14433: if(S_Ec>0){
14434: Y=dexp(X/(1-X));
14435: R=myfeval(S_Fc,S_EC*(Y-1)+S_Ic[0])*Y;
14436: }else R=myfeval(S_Fc,S_EC*X/(1-X)+S_Ic[0]);
14437: return R*S_EC/(1-X)^2;
14438: }
14439: X=S_Ic[0]+(S_Ic[1]-S_Ic[0])*X;
14440: return myfeval(S_Fc,X)/(S_Ic[1]-Ic[0]);
14441: }
14442:
14443: def fresidue(P,Q)
14444: {
14445: if(iscoef(Q,os_md.israt)) S=fctr(Q);
14446: else S=[[Q,1]];
14447: for(R=[];S!=[];S=cdr(S)){
14448: T=car(S);
14449: if((D=mydeg(T[0],z))==0) continue;
14450: L=[];
14451: if(iscoef(T[0],os_md.iscrat)) L=getroot(T[0],z|cpx=2);
14452: if(findin(z,vars(L))>=0) L=[];
14453: if(L==[]) L=polroots(T[0],z|comp=-1);
14454: for(;L!=[];L=cdr(L)){
14455: QQ=Q;
14456: for(I=T[1]; I>1;I--) QQ=mydiff(QQ,z);
14457: for(U=0,W=I=T[1];I>0;I--,W++){
14458: QQ=diff(QQ,z);
14459: U+=subst(QQ,z,L[0])*(z-L[0])^(W-T[1])/fac(W);
14460: }
14461: UD=mydiff(U,z);
14462: for(I=T[1],K=1,PP=P; I>1;I--,K++)
14463: PP=diff(PP,z)*U-K*PP*UD;
14464: QQ=subst(PP,z,L[0])/subst(U,z,L[0])^K;
14465: /* if(D==2) QQ=sqrt2rat(QQ); */
14466: R=cons([L[0],sqrt2rat(QQ)],R);
14467: }
14468: }
14469: if(type(L=getopt(cond))==4){
14470: for(S=[];R!=[];R=cdr(R)){
14471: Z=car(R);
14472: for(LL=L;LL!=[];LL=cdr(LL)){
14473: X=real(car(Z));Y=imag(car(Z));
14474: if(myf3eval(car(LL),X,Y,car(Z))<=0) break;
14475: }
14476: if(LL==[]) S=cons(Z,S);
14477: }
14478: R=reverse(S);
14479: }
14480: if((Sum=getopt(sum))==1||Sum==2){
14481: for(S=0;R!=[];R=cdr(R)) S+=car(R)[1];
14482: if(Sum==2) S*=2*@pi*@i;
14483: return sqrt2rat(S);
14484: }
14485: return R;
14486: }
14487:
14488: def fint(F,D,V)
14489: {
14490: if(((L=length(V))==2 || (L==3&&isvar(V[0])<3))
14491: && (type(V[L-1])==7||(type(V[L-1])<3&&type(eval(V[L-1]))<2)))
14492: /* real integral */
14493: return areabezier([F,D,V]|option_list=getopt());
14494: /* complex integral */
14495: if(L>1&&type(V[1])==4&&type(V[1][1])<4){
14496: if(type(V[0])==4&&type(V[0][0])<2){
14497: for(R=[],VT=car(V),VV=cdr(V);VV!=[];VV=cdr(VV),VT=VU){
14498: if((VU=car(VV))==-1) VU=car(V);
14499: R=cons([ptcommon([VT,VU],[t,1-t]|in=1),[0,1]],R);
14500: }
14501: V=reverse(R);
14502: }
14503: else if(L==2) V=[V];
14504: }
14505: Opt=cons(["cpx",1],getopt());
14506: for(R=0;V!=[];V=cdr(V)){
14507: VT=car(V);
14508: X=car(VT)[0];XD=red(diff(X,t));
14509: Y=car(VT)[1];YD=red(diff(Y,t));
14510: F=mysubst(F,[[x,X],[y,Y],[z,X+@i*Y]]);
14511: if(type(F)==4)
14512: FF=cons(F[0]*(XD+@i*YD),cdr(F));
14513: else FF=red(F*(XD+@i*YD));
14514: R+=areabezier([FF,D,cons(t,VT[1])]|option_list=Opt);
14515: }
14516: return R;
14517: }
14518:
14519: def areabezier(V)
14520: {
14521: if(getopt(cpx)==1){
14522: Opt=delopt(getopt(),"cpx");
14523: F=V[0];
14524: if(!isvar(Var=V[2][0])) Var=x;
14525: if(type(F)==3 && vars(F)==[Var] && imag(dn(F))!=0){
14526: F=(nm(F)*conj(dn(F)))/(dn(F)*conj(dn(F)));
14527: V0=red(real(nm(F))/dn(F));
14528: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
14529: V0=red(imag(nm(F))/dn(F));
14530: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
14531: }
14532: if(getopt(Acc)!=1) F=f2df(F);
14533: V0=compdf([o,[o,real,o_]],o_,F);
14534: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
14535: V0=compdf([o,[o,imag,o_]],o_,F);
14536: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
14537: }
14538: if(type(V[0])!=4 || vars(V[0][0])!=0){
14539: Mx=[-2.0^(512),2.0^(512)];
14540: I=length(V[2]);
14541: if(type(V[2][I-1])==7||type(V[2][I-2])==7){ /* infinite interval */
14542: if(type(Ec=getopt(exp))==1) R=cmpf([V[0],V[2]]|exp=Ec);
14543: else R=cmpf([V[0],V[2]]);
14544: V=[R,V[1],[0,1]];
14545: }
14546: if(type((Int=getopt(int)))==1 && type(V[0])<4 && (V1=V[1])>=0){
14547: if(Int==2&&iand(V1,1)) V1++;
14548: if(!V1) V1=32;
14549: Opt=cons(["raw",1],getopt());
14550: W=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
14551: SS=W[0][1];
14552: for(S0=S1=0,I=0,L=W;L!=[] && I<=V1;I++, L=cdr(L)){
14553: if(iand(I,1)) S1+=car(L)[1];
14554: else S0+=car(L)[1];
14555: if (I==V1) SS+=car(L)[1];
14556: }
14557: VV=deval(V[2][1]-V[2][0]);
14558: if(Int==2)
14559: return (2*S0+4*S1-SS)*VV/(3*V1);
14560: else
14561: return (2*S0+2*S1-SS)*VV/(2*V1);
14562: }
14563: Opt=cons(["opt",0],getopt());
14564: V=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
14565: }
14566: if(type(V[0][0])!=4) V=os_md.lbezier(V);
14567: for(S=0; V!=[]; V=cdr(V)){
14568: B=tobezier(car(V));
14569: P=intpoly(B[1]*diff(B[0],t),t);
14570: S+=mysubst(P,[t,1]);
14571: }
14572: return S;
14573: }
14574:
14575: def velbezier(V,L)
14576: {
14577: if(L==0) L=[t,0,1];
14578: else L=[(length(L)==3)?L[2]:t,L[0],L[1]];
14579: for(R=[],II=length(V)-1;II>=0;II--){
14580: S=fmmx(diff(V[II],L[0]|dif=1),L|dif=1);
14581: for(U=0;S!=[];S=cdr(S)) if((T=abs(car(S)[1]))>U) U=T;
14582: R=cons(U,R);
14583: }
14584: return R;
14585: }
14586:
14587: def ptbezier(V,L)
14588: {
14589: if(type(V[0])==4&&type(V[0][0])!=4) V=lbezier(V);
14590: K=length(V);
14591: if(type(L)<2){
14592: if(L<0) return K;
14593: if(L>=K-1) L=[K-1,1];
14594: else{
14595: L0=floor(L);
14596: if(L0>=K-1) L0=K-1;
14597: L=[L0,L-L0];
14598: }
14599: }
14600: if(L[0]>=0) B=V[L[0]];
14601: else B=V[K+L[0]];
14602: B=tobezier(B);
14603: BB=[diff(B[0],t),diff(B[1],t)];
14604: return [subst(B,t,L[1]),subst(BB,t,L[1])];
14605: }
14606:
14607: def ptcombezier(P,Q,T)
14608: {
14609: if(type(T)<2){
14610: if(T<2) T=20; /* default */
14611: return ptcombezier(P,Q,[0,0,1,T]);
14612: }
14613: V=T[2]/2;;
14614: PB=tobezier(P|div=1);
14615: PP=[ptbbox(PB[0]),ptbbox(PB[1])];
14616: QB=tobezier(Q|div=1);
14617: QQ=[ptbbox(QB[0]),ptbbox(QB[1])];
14618: for(L=[],I=0;I<2;I++){
14619: for(J=0;J<2;J++){
14620: if(!iscombox(PP[I],QQ[J])) continue;
14621: if(T[3]<=1) return
14622: [[T[0]+(I+0.5)*V,T[1]+(J+0.5)*V,
14623: [(PP[I][0][0]+PP[I][0][1])/2,(PP[I][1][0]+PP[I][1][1])/2]]];
14624: else{
14625: #if 0
14626: U=PB[I][0];V=PB[I][length(PB[I])-1];
14627: if(abs(A=(U[0]-V[0]))>abs(B=(U[1]-V[I])))
14628: M=mat([1,0],[-B/A,1]);
14629: else if(U!=V)
14630: M=mat([1,-A/B],[0,1]);
14631: else continue;
14632: if(!iscombox(ptbox(ptaffine(M,PB[I])),ptbox(ptaffine(M,QB[J])))) continue;
14633: #endif
14634:
14635: LN=ptcombezier(PB[I],QB[J],[T[0]+I*V,T[1]+J*V,V,T[3]-1]);
14636: #if 0
14637: L=append(LN,L);
14638: #else
14639: if(LN!=[]){
14640: if(L==[]) L=LN;
14641: else for(VV=3*V/2^T[3];LN!=[];LN=cdr(LN)){
14642: for(LT=L;LT!=[];LT=cdr(LT)){
14643: if(abs(car(LN)[0]-car(LT)[0])<VV&&abs(car(LN)[1]-car(LT)[1])<VV) break;
14644: }
14645: }
14646: }
14647: if(length(L)>32){ /* Too many points */
14648: I=J=2;
14649: }
14650: #endif
14651: }
14652: }
14653: }
14654: return L;
14655: }
14656:
14657:
14658: def ptcombz(P,Q,T)
14659: {
14660: if(P==Q) Q=0;
14661: if(type(P[0][0])!=4) P=P0=lbezier(P);
14662: if(Q==0){
14663: Q=P;F=1;
14664: }
14665: else if(type(Q[0][0])!=4) Q=lbezier(Q);
14666: for(R=[],I=0,Q0=Q;P!=[];P=cdr(P),I++){
14667: for(J=0,Q=Q0;Q!=[];Q=cdr(Q),J++){
14668: if(F==1&&I<J+2) break;
14669: if((RT=ptcombezier(car(P),car(Q),T))!=[]){
14670: RT=cons([I,J],RT);
14671: R=cons(RT,R);
14672: }
14673: }
14674: }
14675: if((Red=getopt(red))==1||Red==2){
14676: if(type(M=getopt(prec))!=1) M=12;
14677: for(F=0,T=P0;T!=[];T=cdr(T)){
14678: for(S=car(T);S!=[];S=cdr(S)){
14679: if(type(ST=car(S))==4 && type(ST[0])<2){
14680: if(F++==0){
14681: X0=X1=ST[0];Y0=Y1=ST[1];
14682: }else{
14683: if(ST[0]<X0) X0=ST[0];
14684: if(ST[0]>X1) X1=ST[0];
14685: if(ST[1]<Y0) Y0=ST[1];
14686: if(ST[1]>Y1) Y1=ST[1];
14687: }
14688: }
14689: }
14690: }
14691: V0=(X1-X0)/2^M;V1=(Y1-Y2)/2^M;
14692: for(RR=[],RT=R;RT!=[];RT=cdr(RT))
14693: for(S=cdr(car(RT));S!=[];S=cdr(S)) RR=cons(car(S)[2],RR);
14694: RR=ltov(RR);L=length(RR);
14695: for(I=0;I<L;I++)
14696: for(K=1,J=I+1;K!=0&&J<L;J++)
14697: if(abs(RR[I][0]-RR[J][0])<V0 && abs(RR[I][1]-RR[J][1])<V1) RR[I]=K=0;
14698: R0=[];
14699: I=L-1;
14700: if(Red==2){
14701: for(;I>=0;I--) if(RR[I]!=0) R0=cons(RR[I],R0);
14702: }else{
14703: for(RT=R;RT!=[];RT=cdr(RT)){
14704: R00=[car(RT)[0]];
14705: for(S=cdr(car(RT));S!=[];S=cdr(S),I--)
14706: if(RR[L-I-1]!=0) R00=cons(car(S),R00);
14707: if(length(R00)>1) R0=cons(reverse(R00),R0);
14708: }
14709: }
14710: return R0;
14711: }
14712: return reverse(R);
14713: }
14714:
14715: def draw_bezier(ID,IDX,B)
14716: {
14717: if(getopt(init)==1){
14718: S_FDot=0;
14719: return;
14720: }
14721: if(type(Col=getopt(col))!=1&&Col!=0) Col=0;
14722: Dot=0;
14723: if(type(Opt=getopt(opt))==7){
14724: if(!Col){
14725: Col=drawopt(Opt,0);
14726: if(Col==-1) Col=0;
14727: }
14728: T=drawopt(Opt,3);
14729: if(iand(T,2)){
14730: M=iand(T,1)?1/8:1/4;
14731: for(C=Col,Col=I=0;I<20;I+=8)
14732: Col+=ishift(0xff-(floor((0xff-iand(0xff,ishift(C,I)))*M)),-I);
14733: }
14734: if(iand(T,4)) Dot=2; /* 2 or 3 or 4 or 6 */
14735: else if(iand(T,8)) Dot=4;
14736: }
14737: if(type(B)==4 && (type(B[0])==4||type(B[0])==5) && type(B[0][0])<2) B=lbezier(B);
14738: else if(type(B)==5) B=[vtol(B)];
14739: for(;B!=[];B=cdr(B)){
14740: if(vars(F=car(B))==[]){
14741: #if 1
14742: if(length(F)<3&&!Dot){ /* line or point */
14743: if(length(F)>0){
14744: G=[rint(F[0][0]),rint(F[0][1])];
14745: if(length(F)==1) draw_obj(ID,IDX,G,Col);
14746: else{
14747: G=[G[0],G[1],rint(F[1][0]),rint(F[1][1])];
14748: draw_obj(ID,IDX,G,Col);
14749: }
14750: }
14751: continue;
14752: }
14753: #endif
14754: if(length(F)<2) continue;
14755: F=tobezier(F);
14756: }
14757: N=velbezier(F,0);
14758: N=(N[0]>N[1])?N[0]:N[1];
14759: if(!N) N=1;
14760: for(I=0;I<=N;I++,S_FDot++){
14761: if(Dot!=iand(S_FDot,Dot)) continue;
14762: G=subst(F,t,I/N);
14763: G=[rint(G[0]),rint(G[1])];
14764: if(G!=G0){
14765: draw_obj(ID,IDX,G,Col);
14766: G0=G;
14767: }
14768: }
14769: }
14770: if(S_FDot-->=2^32) S_FDot=0;
14771: return 0;
14772: }
14773:
1.29 takayama 14774:
14775: /*
14776: def redbezier(L)
14777: {
14778: V=newvect(4);ST=0;
14779: for(R=[],I=0,T=L;T=[];T=cdr(T){
14780: if(type(car(T))<4){
14781: F=0;
14782: if(I==3)
14783: if(car(T)==0){
14784: }else if(car(T)==1){
14785: }else if(car(T)==-1){
14786: if(I<3) V[I++]=ST;
14787: }
14788: }else if(I==3){
14789: if(R==[] || car(R)!=1){
14790: R=cons(V[0],R);
14791: if(ST==0) ST=V[0];
14792: }
14793: for(J=1;J<3;J++) R=cons(V[J],R);
14794: while((T=cdr(T))!=[]){
14795: R=cons(car(T),R);
14796: if(type(car(R))<4)
14797: }
14798: }else{
14799: if(ST==0) ST=car(T);
14800: V[I++]= car(T);
14801: }
14802: }
14803: }
14804: */
14805:
1.6 takayama 14806: def lbezier(L)
14807: {
14808: if((In=getopt(inv))==1||In==2||In==3){
14809: for(F=0,R=[];L!=[];L=cdr(L)){
14810: LT=car(L);
14811: if(F==car(LT)) R=cons(1,R);
14812: else{
14813: if(R!=[]&&F!=0) R=cons(0,R);
14814: R=cons(G=car(LT),R);
14815: if(In==3) In==2;
14816: }
14817: for(LT=cdr(LT);LT!=[];LT=cdr(LT))
14818: R=cons(car(LT),R);
14819: if((F=car(R))==G&&In==1){
14820: R=cons(-1,cdr(R));
14821: F=0;
14822: }
14823: }
14824: if(In==3 && car(R)==G) R=cons(-1,cdr(R));
14825: return reverse(R);
14826: }
14827: for(F=0,RT=R=[];L!=[];L=cdr(L)){
14828: if(type(T=car(L))==4||type(T)==5){
14829: if(F==0){
14830: FT=T;F=1;
14831: }
14832: RT=cons(T,RT);
14833: }else if(T==0){
14834: if(RT==[]) R=cons(reverse(RT),R);
14835: RT=[];F=0;
14836: }else if(T==1){
14837: if(RT!=[]){
14838: R=cons(reverse(RT),R);
14839: RT=[car(RT)];
14840: }else{
14841: RT=[];F=0;
14842: }
14843: }else if(T==-1){
14844: RT=cons(FT,RT);
14845: R=cons(reverse(RT),R);
14846: RT=[];F=0;
14847: }
14848: }
14849: if(RT!=[]) R=cons(reverse(RT),R);
14850: return reverse(R);
14851: }
14852:
14853:
14854: def xybezier(L)
14855: {
14856: if(L==0 || (LS=length(L))==0) return "";
14857: Out=str_tb(0,0);
14858: if(type(VF=getopt(verb))==4){
14859: if(type(car(VF))>3){
14860: VFS=VF;VF=1;
14861: }else{
14862: VFS=cdr(VF);VF=car(VF);
14863: }
14864: }else VFS=["$\\bullet$","$\\times$"];
14865: if(VF!=1 && VF!=2) VF=0;
14866: if(!TikZ){
14867: if(VF) Ob=str_tb(0,0);
14868: T="\n**\\crv{";
14869: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+Opt;
14870: L00=Q=L[I0=0];S=S1="";
14871: for(F=0,I=1;I<=LS;I++){
14872: P=Q;Q=(I==LS)?0:L[I];
14873: if(type(Q)==4){
14874: if(F==0){
14875: S1="";L0=P;F=1;
14876: continue;
14877: }else if(F==1)
14878: F=2;
14879: else if(F==2){
14880: S1=S1+"&";
14881: }
14882: S1=S1+xypos(P);
14883: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
14884: }else{
14885: if(Q==0){
14886: if(F>0){
14887: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
14888: if(VF){
14889: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
14890: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
14891: }
14892: F=0;
14893: }
14894: }else if(Q==1){
14895: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
14896: if(VF){
14897: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
14898: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
14899: }
14900: F=1;
14901: }else if(Q==-1){
14902: if(F==2)
14903: S1=S1+"&";
14904: str_tb("{"+xypos(L0)+";"+xypos(L00)+T+S1+xypos(P)+"}};\n",Out);
14905: if(VF) str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
14906: F=0;
14907: }
14908: if(F==1){
14909: if(I<LS-1 && type(L[I+1])<2){
14910: if(L[I+1]==-1){
14911: str_tb("{"+xypos(P)+";"+xypos(L00)+T+"}};\n",Out);
14912: }
14913: if(VF) str_tb(xyput([P[0][0],P[0][1],VFS[0]]),Ob);
14914: F=0;
14915: }
14916: }
14917: while(++I<LS && type(L[I])<2);
14918: if(I>=LS) break;
14919: if(F==1){
14920: Q=P;I--;F=0;
14921: }else L00=Q=L[I];
14922: }
14923: }
14924: }else{
14925: if(type(T=getopt(cmd))==7){
14926: if(T!="") T="\\"+T;
14927: }else T="\\draw";
14928: if((Rel=getopt(relative))==1) VF=0;
14929: if(VF) Ob=str_tb(0,0);
14930: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+"["+Opt+"]";
14931: Out=str_tb(T,0);
14932: Q=L[0];
14933: for(F=M=0,I=1;I<=LS;I++){
14934: P=Q; Q=(I==LS)?0:L[I];
14935: if(++M>XYLim){
14936: str_tb("\n",Out);M=1;
14937: }
14938: if(type(Q)==4 || type(Q)==5 || type(Q)==7){
14939: if(F==0){
14940: str_tb(" ",Out);
14941: F=1;
14942: }else if(F==1){
14943: str_tb(" .. controls ",Out);
14944: F=2;
14945: }else if(F==2){
14946: str_tb(" and ",Out);
14947: F=2;
14948: }
14949: PP=xypos(P);
14950: if(Rel==1 && F==2) PP="+"+PP;
14951: str_tb(PP,Out);
14952: if(VF&&((F<2)||length(VFS)>1))
14953: str_tb(xyput([P[0],P[1],(F<2)?VFS[0]:VFS[1]]),Ob);
14954: }else{
14955: /* if(I<LS-1) VF=0; */
14956: if(Q==0||Q==1){
14957: PP=xypos(P);
14958: if(Rel==1) PP="+"+PP;
14959: str_tb(((F==0)?" ":((F==1)?" -- ":" .. "))+PP,Out);
14960: if(VF) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
14961: F=Q;
14962: }else if(Q==-1){
14963: PP=xypos(P);
14964: if(Rel==1) PP="+"+PP;
14965: if(F==1)
14966: str_tb("..controls "+PP+" .. cycle",Out);
14967: else if(F==2)
14968: str_tb(" and "+PP+" .. cycle",Out);
14969: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
14970: F=0;
14971: }
14972: if(F==1){
14973: if(I<LS-1){
14974: if(L[I+1]==-1){
14975: str_tb(" -- cycle",Out);
14976: I=I+1;
14977: F=0;
14978: }
14979: else if(type(L[I+1])<2) F=0;
14980: }
14981: }
14982: while(++I<LS && type(L[I])<2);
14983: if(I>=LS) break;
14984: Q=L[I];
14985: }
14986: }
14987: str_tb(";\n",Out);
14988: }
14989: if(VF) str_tb(str_tb(0,Ob),Out);
14990: return str_tb(0,Out);
14991: }
14992:
14993: def xybox(L)
14994: {
14995: K=length(L);
14996: P=L[0];Q=L[1];
14997: if(K==2)
14998: LL=[ P, [P[0],Q[1]], Q, [Q[0],P[1]] ];
14999: else{
15000: R=L[2];
15001: LL=[ P, R, Q, [P[0]+Q[0]-R[0],P[1]+Q[1]-R[1]] ];
15002: }
15003: Opt=getopt();
15004: SS=getopt(opt);
1.8 takayama 15005: FL=getopt(color);
15006: if(TikZ&&type(SS)<1&&K==2){
15007: if(type(FL)==4){
15008: F=FL[0];
15009: if(length(FL)>1) CMD=FL[1];
15010: }else if(type(FL)==7) F=FL;
15011: else F="";
15012: F=cons(F,["rectangle"]);
15013: if(CMD) return xyarrow(P,Q|opt=F,cmd=CMD);
15014: else return xyarrow(P,Q|opt=F);
15015: }
1.6 takayama 15016: if(type(SS)!=7&&!TikZ) Opt=cons(["opt","@{-}"],Opt);
15017: Opt=cons(["close",1],Opt);
15018: return xylines(LL|option_list=Opt);
15019: }
15020:
15021: def xyang(S,P,Q,R)
15022: {
15023: Opt=getopt();
15024: if(type(Prec=getopt(prec))!=1) Prec=0;
15025: if(type(Q)>2){
15026: if(R==1||R==-1){ /* 直角 */
15027: P1=ptcommon([Q,P],[-S,0]);
15028: S*=R;
15029: P2=ptcommon([P,P1],[S,@pi/2]);
15030: P3=ptcommon([P1,P2],[S,@pi/2]);
15031: return xylines([P1,P2,P3]|option_list=Opt);
15032: }else if((AR=abs(R))==0||AR==2||AR==3||AR==4){ /* 矢印 */
15033: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
15034: if(R<0) Ang+=3.14159;
15035: ANG=[0.7854,0.5236,1.0472];
15036: X=(AR==0)?1.5708:ANG[AR-2];
15037: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
15038: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; /* 矢先 */
15039: V=(X==0)?[U,V]:[U,P,V];
15040: if(getopt(ar)==1) V=append([Q,P,0],V); /* 心棒 */
15041: return xylines(V|option_list=Opt);
15042: }else if(AR>4&&AR<9){
15043: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
15044: ANG=[0.7854,0.5236,0.3927,0.2618];
15045: X=ANG[AR-5];
15046: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
15047: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)];
15048: W=ptcommon([P,U],[P,Q]|in=-2);
15049: W1=[(U[0]+P[0]+W[0])/3,(U[1]+P[1]+W[1])/3];
15050: W2=[(V[0]+P[0]+W[0])/3,(V[1]+P[1]+W[1])/3];
15051: L=[U,W1,P,1,W2,V];
15052: if(getopt(ar)==1) L=append([Q,P,0],L);
15053: if(type(Sc=getopt(scale))>0){
15054: if(type(Sc)==1) Sc=[Sc,Sc];
15055: L=ptaffine(diagm(2,Sc),L);
15056: }
15057: Opt=getopt(opt);
15058: if(type(Opt)>0) OL=[["opt",Opt]];
15059: else OL=[];
15060: if(getopt(proc)==1) return append([2,OL],L);
15061: S=xybezier(L|optilon_list=OL);
15062: if(getopt(dviout)!=1) return S;
15063: dviout(S);
15064: return 1;
15065: }
15066: }
15067: if(type(Q)<3){
15068: X=deval(Q); Y=deval(R);
15069: }else{
15070: X=myarg([Q[0]-P[0],Q[1]-P[1]]);
15071: Y=myarg([R[0]-P[0],R[1]-P[1]]);
15072: }
15073: if(Prec>2) N=8;
15074: else if(Prec==2) N=6;
15075: else if(Prec==1) N=4;
15076: else N=3;
15077: U=deval(@pi)*2/N;
15078: if(X==Y||Y-X>6.28318){
15079: for(L=[],I=N-1;I>=0;I--) L=cons([P[0]+S*dcos(I*U),P[1]+S*dsin(I*U)],L);
15080: return xylines(L|option_list=append([["curve",1],["close",1]],Opt));
15081: }
15082: for(M=1;(Y-X)/M>U;M++);
15083: for(L=[],I=M+1;I>-2;I--){
15084: Ang=X+(Y-X)*I/M;
15085: L=cons([P[0]+S*dcos(Ang),P[1]+S*dsin(Ang)],L);
15086: }
15087: if(getopt(ar)!=1) return xylines(L|option_list=append([["curve",1],["close",-1]],Opt));
15088: OL=delopt(Opt,["dviout","opt","proc"]);
15089: S=xylines(L|option_list=append([["curve",1],["close",-1],["opt",0]],OL));
15090: T=xylines([P,L[1]]|option_list=cons(["opt",0],OL));
15091: S=ptaffine("close",[S,T]); /* connect curves */
15092: if(getopt(opt)==0) return S;
15093: OL=(type(SS=getopt(opt))>1)?[["opt",SS]]:[];
15094: if(type(T=getopt(proc))==1 && T>=1 && T<=3) return [1,OL,S];
15095: if(OL==[]) S=xybezier(S);
15096: else S=(type(SS)==7)? xybezier(S|opt=SS):xybezier(S|opt=SS[0],cmd=SS[1]);
15097: if(getopt(dviout)==1) return xyproc(S|dviout=1);
15098: return S;
15099: }
15100:
15101: def xyoval(P,L,R)
15102: {
15103: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
15104: if(length(Arg)>2)
15105: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180,@pi*Arg[2]/180];
15106: else
15107: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
15108: }
15109: if(type(Arg)==4){
15110: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
15111: if(length(Arg)>2) Arg2=deval(Arg[2]);
15112: if(Arg1<Arg0 || Arg0<-7) return 0;
15113: }
15114: if(type(Prec=getopt(prec))!=0) Prec=0;
15115: if((Ar=getopt(ar))!=1) Ar=0;
15116: L=xyang(L,[0,0],Arg0,Arg1|prec=Prec,opt=0,ar=Ar);
15117: Sc=getopt(scale);
15118: if(type(Sc=getopt(scale))<1) Sc=[1,1];
15119: else if(type(Sc)==1) Sc=[Sc,Sc];
15120: M=mat([1,0],[0,R]);
15121: L=ptaffine(M,L|shift=P);
15122: M=mat([Sc[0],0],[0,Sc[1]]);
15123: L=ptaffine(M,L|arg=Arg2);
15124: if((Opt=getopt(opt))==0) return L;
15125: Opt=(type(Opt)>1)? [["opt2",Opt]]:[];
15126: if(getopt(proc)==1) return [1,Opt,L];
15127: S=xybezier(L|option_list=getopt());
15128: if(getopt(dviout)==1){
15129: xyproc(S|dviout=1);
15130: return 1;
15131: }
15132: return S;
15133: }
15134:
15135: def xycirc(P,R)
15136: {
15137: ST=getopt(opt);
15138: if(type(ST)<0) ST="";
15139: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
15140: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
15141: }
15142: /* Is it OK?
15143: if(TikZ==0 && XYcm==1){
15144: R*=10; P=[P[0]*10,P[1]*10];
15145: }
15146: */
15147: if(type(Arg)==4){
15148: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
15149: if(Arg1<=Arg0 || Arg0<-7 || Arg1-Arg0>7) return 0;
15150: if(type(ST)==7)
15151: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
15152: [P[1]-R-1,P[1]+R+1]|opt=ST);
15153: else
15154: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
15155: [P[1]-R-1,P[1]+R+1]);
15156: if(getopt(close)==1){
15157: S=S+xyline([0,0],
15158: [deval(subst(R*cos(x)+P[0],x,Arg0)),deval(subst(R*sin(x)+P[0],x,Arg0))]);
15159: S=S+xyline([0,0],
15160: [deval(subst(R*cos(x)+P[0],x,Arg1)),deval(subst(R*sin(x)+P[0],x,Arg1))]);
15161: }
15162: return S;
15163: }
15164: if(TikZ){
15165: SP="";
15166: if(length(P)>2) SP=P[2];
15167: if(type(SP)!=7) SP="$"+my_tex_form(SP)+"$";
15168: if(R==0){
15169: if(ST!="") ST=ST+",";
15170: return "\\node ["+ST+"circle,draw]"+xypos([P[0],P[1]])+ "{"+SP+"};\n";
15171: }
1.8 takayama 15172: if(type(R)!=7) R=rtostr(deval(R));
1.6 takayama 15173: if(ST!="") ST="["+ST+"]";
15174: S="\\draw "+ST+xypos([P[0],P[1]])+" circle [radius="+R+"]";
15175: if(SP!="") S=S+" node at"+xypos([P[0],P[1]])+" {"+SP+"}";
15176: return S+";\n";
15177: }
15178: S="{"+xypos([P[0],P[1]]);
15179: if(length(P)>2){
15180: SP=P[2];
15181: if(type(P)!=7) SP=my_tex_form(SP);
15182: S=S+" *+{"+SP+"}";
15183: }
15184: S =S+" *\\cir";
15185: if(R!=0){
1.8 takayama 15186: R=deval(R);
1.6 takayama 15187: S=S+"<"+rtostr(R)+((XYcm)?"cm>":"mm>");
15188: }
15189: S = S+"{";
15190: if(type(ST)==7) S=S+ST;
15191: return S+"}};\n";
15192: }
15193:
1.33 takayama 15194: def xypoch(W,H,R1,R2)
15195: {
15196: if(H>R1||2*H>R2){
15197: errno(0);
15198: return;
15199: }
15200: if(type(Ar=getopt(ar))!=1) Ar=TikZ?0.25:2.5;
15201: T1=dasin(H/R1);S1=R1*dcos(T1);
15202: T2=dasin(H/R2);S2=R2*dcos(T2);
15203: T3=dasin(2*H/R2);S3=R2*dcos(T3);
15204: S=xyline([R1,0],[W-R1,0]);
15205: S+=xyang(R1,[W,0],-@pi,@pi-T1);
15206: S+=xyline([S2,H],[W-S1,H]);
15207: S+=xyang(R2,[0,0],T2,2*@pi-T3);
15208: S+=xylines([[S3,-2*H],[W-H-R2,-2*H],[W-H-R2,2*H],[W-S3,2*H]]);
15209: S+=xyang(R2,[W,0],-@pi+T2,@pi-T3);
15210: S+=xyline([W-T2,-H],[W-T2,-H]);
15211: S+=xyang(R1,[0,0],0,2*@pi-T1);
15212: S+=xyline([W-S2,-H],[S1,-H]);
15213: if(Ar>0){
15214: S+=xyang(Ar,[W/2,0],[0,0],8);
15215: S+=xyang(Ar,[W/2,-2*H],[0,-2*H],8);
15216: S+=xyang(Ar,[W/2-Ar,-H],[W,-H],8);
15217: S+=xyang(Ar,[W/2-Ar,H],[W,H],8);
15218: S+=xyang(Ar,[W-S3,2*H],[W-H-R2,2*H],8);
15219: }
15220: S+=xyput([R1,0,"$\\bullet$"]);
15221: S+=xyput([0,0,"$\\times$"]);
15222: S+=xyput([W,0,"$\\times$"]);
15223: if(TikZ) S=str_subst(S,";\n\\draw","\n");
15224: return S;
15225: }
15226:
1.6 takayama 15227: def ptaffine(M,L)
15228: {
15229: if(type(L)!=4&&type(L)!=5){
15230: erno(0);return L;
15231: }
15232: if(type(M)==7){ /* connect lists */
15233: if(M=="reverse"){
15234: for(LO=LR=[],F=0,LT=L; LT!=[]; LT=cdr(LT)){
15235: if(type(P=car(LT))==4 || type(P)==7){
15236: LR=cons(P,LR);
15237: continue;
15238: }else{
15239: if(P==-1){
15240: LL=reverse(LR);
15241: LO=append(reverse(cons(-1,cdr(LL))),LO);
15242: LO=cons(car(LL),LO);
15243: LR=[];
15244: }else if(P==1){
15245: LR=cons(car(LR),cons(1,cdr(LR)));
15246: }else if(P==0 || length(LT)==1){
15247: if(LO!=[] && car(LO)!=0 && (type(car(LO))==4 || car(LO)==1))
15248: LO=cons(0,LO);
15249: LO=append(LR,LO);
15250: if(length(LT)>1&&length(LO)>0&&car(LO)!=0) LO=cons(0,LO);
15251: LR=[];
15252: }
15253: }
15254: }
15255: return append(LR,LO);
15256: }
15257: if(type(L[0][0])!=4) L=[L];
15258: LO=[];
15259: if(M=="connect" || M=="close" || M=="loop"){
15260: Top=car(car(L));
15261: for(K=1,LL=L; LL!=[]; LL=cdr(LL)){
15262: for(F=0,LT=car(LL); LT!=[]; LT=cdr(LT),F++){
15263: if((LTT=car(LT))==0) LTT=1;
15264: if(F==0 && LO!=[]){
15265: LO0=car(LO);
15266: if(car(LO)!=1&&length(LO)>1) LO=cons(1,LO);
15267: if(LTT==LO0) continue;
15268: else LO=cons(1,cons(LTT, LO));
15269: }else LO=cons(LTT, LO);
15270: }
15271: }
15272: if(M!="connect"){
15273: if(Top==car(LO) || car(LO)==1 || M=="loop")
15274: LO=cons(-1,cdr(LO));
15275: else
15276: LO=cons(-1,cons(1,LO));
15277: }
15278: return reverse(LO);
15279: }
15280: if(M=="union"){
15281: for(LL=reverse(L); LL!=[]; LL=cdr(LL)){
15282: if(LO!=[]) LO=cons(0,LO);
15283: LO=append(car(LL),LO);
15284: }
15285: L=LO;
15286: }
15287: return L;
15288: }
15289: if(type(Arg=getopt(deg))==1)
15290: Arg=@pi*Arg/180;
15291: else Arg=getopt(arg);
15292: if(type(Arg)==2) Arg=deval(Arg);
15293: if(type(Arg)==1)
15294: M=M*mat([dcos(Arg),-dsin(Arg)],[dsin(Arg),dcos(Arg)]);
15295: if(type(Sft=getopt(org))==4){
15296: Sft=ltov(Sft);
15297: Sft-=M*Sft;
15298: }else Sft=ltov([0,0]);
15299: if(type(V=getopt(shift))==4)
15300: Sft+=ltov(V);
15301: if(getopt(proc)==1){
15302: if(Sft!=0&<ov(Sft)!=[0,0]) Sft=[["shift",vtol(Sft)]];
15303: else Sft=[];
15304: for(LO=[],LT=L;LT!=[];LT=cdr(LT)){
15305: if(type(car(T=car(LT)))<2){
15306: if((P=car(T))==0){ /* exedraw 0 */
15307: 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]]];
15308: V=ptbbox(ptaffine(M,V|option_list=Sft));
15309: L1=cdr(cdr(cdr(T)));
15310: LO=cons(append([0,V[0],V[1]],L1),LO);
15311: continue;
15312: }else if(P==1){ /* exedraw 1 */
15313: L1=[];
15314: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
15315: D=car(TT);
15316: if(type(D[0][0])==4){
15317: for(L2=[],DT=D;DT!=[];DT=cdr(DT))
15318: L2=cons(ptaffine(M,car(DT)|option_list=Sft),L2);
15319: L1=cons(reverse(L2),L1);
15320: }else L1=cons(ptaffine(M,D|option_list=Sft),L1);
15321: }
15322: LO=cons(append([1,T[1]],reverse(L1)),LO);
15323: continue;
15324: }else if(P>=2 && P<=5){
15325: L1=ptaffine(M,cdr(cdr(T))|optilon_list=Sft);
15326: LO=cons(append([P,T[1]],L1),LO);
15327: continue;
15328: }
15329: }
15330: LO=cons(T,LO);
15331: }
15332: return reverse(LO);
15333: }
15334: F=0;
15335: if(type(L)==4){
15336: for(LT=L; LT!=[]; LT=cdr(LT)){
15337: if((T=type(car(LT)))==4||T==5){
15338: F=1; break;
15339: }
15340: }
15341: }
15342: if(F==0) return (Sft==0)?ptaffine(M,[L])[0]:ptaffine(M,[L]|shift=vtol(Sft))[0];
15343: for(LO=[],LT=L; LT!=[]; LT=cdr(LT)){
15344: if(((T=type(P=car(LT)))!=4 && T!=5)||type(P[0])>3) LO=cons(P,LO);
15345: else{
15346: if(T==4) P=ltov(P);
15347: V=M*P;
15348: if(Sft!=0) V+=Sft;
15349: if(T==4) V=vtol(V);
15350: LO=cons(V,LO);
15351: }
15352: }
15353: return reverse(LO);
15354: }
15355:
15356: def ptlattice(M,N,X,Y)
15357: {
15358: if(type(S=getopt(scale))!=1) S=1;
15359: if(type(Cond=getopt(cond))!=4) Cond=[];
15360: Line=getopt(line);
15361: if(Line==1 || Line==2) F=newmat(M,N);
15362: else Line=0;
15363: if(type(Org=getopt(org))==4) Org=ltov(Org);
15364: else Org=newvect(length(X));
15365: X=ltov(X); Y=ltov(Y);
15366: for(L=[],I=M-1;I>=0;I--){
15367: for(P0=P1=0,J=N-1;J>=0;J--){
15368: P=Org+I*X+J*Y;
15369: for(C=Cond; C!=[]; C=cdr(C))
15370: if(subst(car(C),x,P[0],y,P[1])<0) break;
15371: if(C!=[]) continue;
15372: if(Line) F[I][J]=1;
15373: else L=cons(vtol(S*P),L);
15374: }
15375: }
15376: if(Line==0) return L;
15377: for(I=M-1;I>=0;I--){
15378: for(T0=0,T1=J=N-1;J>=0;J--){
15379: if((K=F[I][J])!=0){
15380: if(T0==0) T0=J;
15381: else T1=J;
15382: }
15383: if(K==0 || T1==0){
15384: if(T1<T0){
15385: L=cons(vtol(S*(Org+I*X+T0*Y)), L);
15386: L=cons(vtol(S*(Org+I*X+T1*Y)), L);
15387: L=cons(0,L);
15388: }
15389: T0=0; T1=N-1;
15390: }
15391: }
15392: }
15393: for(J=N-1;J>=0;J--){
15394: for(T0=0,T1=I=M-1;I>=0;I--){
15395: if((K=F[I][J])!=0){
15396: if(T0==0) T0=I;
15397: else T1=I;
15398: }
15399: if(K==0 || T1==0){
15400: if(T1<T0){
15401: L=cons(vtol(S*(Org+T0*X+J*Y)), L);
15402: L=cons(vtol(S*(Org+T1*X+J*Y)), L);
15403: L=cons(0,L);
15404: }
15405: T0=0; T1=M-1;
15406: }
15407: }
15408: }
15409: return cdr(L);
15410: }
15411:
15412: def ptpolygon(N,R)
15413: {
15414: if(type(S=getopt(scale))!=1) S=1;
15415: if(type(Org=getopt(org))!=4) Org=[0,0];
15416: Pi=deval(@pi);
15417: if(type(Arg=getopt(deg))==1)
15418: Arg=Pi*Arg/180;
15419: else Arg=getopt(arg);
15420: if(type(Arg)==2) Arg=deval(Arg);
15421: if(type(Arg)!=1) Arg=0;
15422: Arg -= Pi*(1/2+1/N);
15423: D=Pi*2/N;
15424: for(L=[],I=N-1; I>=0; I--)
15425: L=cons([S*(Org[0]+R*dcos(Arg+I*D)),S*(Org[1]+R*dsin(Arg+I*D))],L);
15426: return L;
15427: }
15428:
15429: def ptwindow(L,X,Y)
15430: {
15431: if(type(S=getopt(scale))==1){
15432: X=[S*X[0],S*X[1]]; Y=[S*Y[0],S*Y[1]];
15433: }
15434: for(R=[],LT=L;LT!=[];LT=cdr(LT)){
15435: P=car(LT);
15436: if(P[0]<X[0] || P[0]>X[1] || P[1]<Y[0] || P[1]>Y[1])
15437: R=cons(0,R);
15438: else R=cons(P,R);
15439: }
15440: return reverse(R);
15441: }
15442:
15443: def lninbox(L,W)
15444: {
15445: if(L[0]==L[1]) return 0;
15446: R=newvect(2);C=newvect(2);
15447: for(J=0;J<2;J++){
15448: C[J]=L[1][J]-L[0][J];
15449: if(C[J]!=0){
15450: R[J]=[(W[J][0]-L[0][J])/C[J],(W[J][1]-L[0][J])/C[J]];
15451: if(R[J][0]>R[J][1]) R[J]=[R[J][1],R[J][0]];
15452: }
15453: }
15454: if(R[0]==0) R[0]=R[1];
15455: if(R[1]==0) R[1]=R[0];
15456: S0=(R[0][0]<R[1][0])?R[1][0]:R[0][0];
15457: S1=(R[0][1]<R[1][1])?R[0][1]:R[1][1];
15458: if(getopt(in)==1){
15459: if(S0<0) S0=0;
15460: if(S1>1) S1=1;
15461: }
15462: if(S0>S1) return 0;
15463: 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]];
15464: }
15465:
15466: def ptbbox(L)
15467: {
15468: J=length(L[0]);
15469: if((Box=getopt(box))==1){
15470: for(R=[],I=0;I<J;I++){
15471: P=car(LT=L)[I][0];Q=car(LT)[I][1];
15472: for(;LT!=[];LT=cdr(LT)){
15473: if((type(T=car(LT))==4 || type(T)==5) && length(T)==J){
15474: if(T[I][0]<P) P=T[I][0];
15475: if(T[I][1]>Q) Q=T[I][1];
15476: }
15477: }
15478: R=cons([P,Q],R);
15479: }
15480: }else if(type(Box)==4) return ptbbox([ptbbox(L),Box]|box=1);
15481: else{
15482: for(R=[],I=0;I<J;I++){
15483: P=Q=car(LT=L)[I];LT=cdr(LT);
15484: for(;LT!=[];LT=cdr(LT)){
15485: if((type(T=car(LT))==4||type(T)==5) && type(T[0])<2 && length(T)==J){
15486: if((V=T[I])<P) P=V;
15487: else if(V>Q) Q=V;
15488: }
15489: }
15490: R=cons([P,Q],R);
15491: }
15492: }
15493: return reverse(R);
15494: }
15495:
15496: def iscombox(S,T)
15497: {
15498: for(;S!=[];S=cdr(S),T=cdr(T))
15499: if(car(S)[0]>car(T)[1] || car(S)[1]<car(T)[0]) return 0;
15500: return 1;
15501: }
15502:
15503: def ptcopy(L,V)
15504: {
15505: if(type(V[0])!=4) V=[V];
15506: for(F=0,LL=[]; V!=[]; V=cdr(V)){
15507: if(F) LL=append(LL,[0]);
15508: F++;
15509: LL=append(LL,ptaffine(1,L|shift=car(V)));
15510: }
15511: }
15512:
15513: def average(L)
15514: {
1.32 takayama 15515: if(getopt(opt)=="co"){
15516: S0=average(L[0]);V0=car(S0);
15517: S1=average(L[1]);V1=car(S1);
15518: L0=os_md.m2l(L[0]|flat=1);
15519: L1=os_md.m2l(L[1]|flat=1);
15520: for(S=0;L0!=[];L0=cdr(L0),L1=cdr(L1))
15521: S+=(car(L0)-V0)*(car(L1)-V1);
15522: S/=S0[1]*S1[1]*S0[2];
15523: S=[S,S0,S1];
15524: }else{
15525: L=os_md.m2l(L|flat=1);
15526: M0=M1=car(L);
15527: for(I=SS=0, LT=L; LT!=[]; LT=cdr(LT), I++){
15528: S+=(V=car(LT));
15529: SS+=V^2;
15530: if(V<M0) M0=V;
15531: else if(V>M1) M1=V;
15532: }
15533: SS=dsqrt(SS/I-S^2/I^2);
15534: S=[deval(S/I),SS,I,M0,M1];
1.6 takayama 15535: }
1.8 takayama 15536: if(isint(N=getopt(sint))) S=sint(S,N);
15537: return S;
1.6 takayama 15538: }
15539:
15540: def m2ll(M)
15541: {
15542: for(R=[],I=size(M)[0]-1; I>=0; I--)
15543: R=cons(vtol(M[I]),R);
15544: return R;
15545: }
15546:
15547: def madjust(M,W)
15548: {
15549: if(type(Null=getopt(null))<0) Null=0;
15550: if(type(M)==4 && type(M[0])==4){
15551: M=lv2m(M|null=Null);
15552: return m2ll(madjust(M,W|null=Null));
15553: }
15554: S=size(M);
15555: if(W<0){
15556: W=-W;
15557: T0=ceil(S[0]/W);
15558: T1=S[1]*W;
15559: N=newmat(T0,T1);
15560: for(I=0; I<T0; I++){
15561: for(K=0; K<W; K++){
15562: II=K*T0+I;
15563: for(J=0; J<S[1]; J++)
15564: N[I][S[1]*K+J]=(II<S[0])?M[II][J]:Null;
15565: }
15566: }
15567: }else{
15568: T1=W;
15569: T0=S[0]*(D=ceil(S[1]/T1));
15570: N=newmat(T0,T1);
15571: for(K=0; K<D; K++){
15572: for(J=0; J<W;J++){
15573: JJ=W*K+J;
15574: for(I=0; I<S[0]; I++)
15575: N[S[0]*K+I][J]=(JJ<S[1])?M[I][JJ]:Null;
15576: }
15577: }
15578: }
15579: return N;
15580: }
15581:
15582: def texcr(N)
15583: {
15584: if(!isint(N) || N<0 || N>127) return N;
15585: S=(iand(N,8))? "\\allowdisplaybreaks":"";
15586: if(iand(N,2)) S=S+"\\\\";
15587: if(iand(N,16)) S=S+"\\pause";
15588: if(iand(N,1)) S=S+"\n";
15589: if(iand(N,4)) S=S+"& ";
15590: else if(!iand(N,1)) S=S+" ";
15591: if(iand(N,64)) S=S+"=";
15592: if(iand(N,32)) S=","+S;
15593: return S;
15594: }
15595:
15596: def ltotex(L)
15597: {
15598: /* extern TeXLim; */
15599:
15600: if(type(L)==5)
15601: L = vtol(L);
15602: if(type(L) != 4)
15603: return my_tex_form(L);
15604: Opt=getopt(opt);
15605: Pre=getopt(pre);
15606: if(type(Var=getopt(var))<1) Var=0;
15607: Cr2="\n";
15608: if(type(Cr=getopt(cr))==4){
15609: Cr2=Cr[1];Cr=Cr[0];
15610: }
15611: if(isint(Cr)) Cr=texcr(Cr);
15612: if(type(Cr)!=7) Cr="\\\\\n & "; /* Cr=7 */
15613: if(type(Opt)==7) Opt=[Opt];
15614: if(type(Opt)!=4)
15615: Op = -1;
15616: else{
15617: Op=findin(Opt[0],["spt","GRS","Pfaff","Fuchs","vect","cr","text","spts","spts0",
15618: "dform","tab", "graph","coord"]);
15619: Opt=cdr(Opt);
15620: }
15621: if(Op==0){ /* spt */
15622: Out = str_tb("\\left\\{\n ",0);
15623: for(CC=0; L!=[]; L=cdr(L), CC++){
15624: if(CC>0) str_tb(",\\, ",Out);
15625: TP=car(L);
15626: if(Op!=0)
15627: str_tb(my_tex_form(TP),Out);
15628: else if(TP[0]==1)
15629: str_tb(my_tex_form(TP[1]),Out);
15630: else
15631: str_tb(["[", my_tex_form(TP[1]), "]_", rtotex(TP[0])],Out);
15632: }
15633: str_tb("%\n\\right\\}\n",Out);
15634: }else if(Op==1){ /* GRS */
15635: Out = string_to_tb("\\begin{Bmatrix}\n");
15636: if(type(Pre)==7) str_tb(Pre,Out);
15637: MC=length(M=ltov(L));
15638: for(ML=0, I=length(M); --I>=0; ){
15639: if(length(M[I]) > ML) ML=length(M[I]);
15640: }
15641: for(I=0; I<ML; I++){
15642: for(CC=J=0; J<MC; J++, CC++){
15643: if(length(M[J]) <= I){
15644: if(CC > 0) str_tb(" & ",Out);
15645: }else if(M[J][I][0] <= 1){
15646: if(M[J][I][0] == 0) str_tb(" & ",Out);
15647: else
15648: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
15649: }else
15650: str_tb([((!CC)?" [":" & ["), my_tex_form(M[J][I][1]), "]_",
15651: rtotex(M[J][I][0])], Out);
15652: }
15653: str_tb((I<ML-1)?"\\\\\n":"\n", Out);
15654: }
15655: str_tb("\\end{Bmatrix}",Out);
15656: }else if(Op==2){ /* Pfaff */
15657: V=monototex(Opt[0]);
15658: Out = string_to_tb("d"+V+"= \\Biggl(");
15659: Opt=cdr(Opt);
15660: II=length(Opt);
15661: for(I=0; I<II; I++){
15662: str_tb([(I>0)?" + ":" ",mtotex(L[I]),"\\frac{d",monototex(Opt[I]),"}{",
15663: my_tex_form(Opt[I]),(I==II-1)?"}\n":"}\n\\\\&\n"],Out);
15664: }
15665: str_tb(["\\Biggr)",V,"\n"],Out);
15666: }else if(Op==3){ /* Fuchs */
15667: Out = string_to_tb("\\frac{d");
15668: V=my_tex_form(Opt[0]);
15669: str_tb([V,"}{d",my_tex_form(Opt[1]),"}="] ,Out);
15670: Opt=cdr(Opt); Opt=cdr(Opt);
15671: II=length(Opt);
15672: for(I=0; I<II; I++){
15673: str_tb([(I>0)?" +":"\\Biggl(", " \\frac{",
15674: my_tex_form(L[I]),"}{", my_tex_form(Opt[I]),"}\n"],Out);
15675: }
15676: str_tb(["\\Biggr)",V,"\n"],Out);
15677: }else if(Op==4){ /* vect */
15678: Out=str_tb(mtotex(matc(L)|lim=0,var=Var),0);
15679: }else if(Op==5 || Op==6){ /* cr or text */
15680: Out = str_tb(0,0);
15681: if(type(Lim=getopt(lim))!=1) Lim=0;
15682: else if(Lim<30&&Lim>0) Lim=TeXLim;
15683: Str=getopt(str);
15684: if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1)
15685: Str=2;
15686: for(K=I=0; L!=[]; I++, L=cdr(L)){
15687: LT=car(L);
15688: if((!Lim||Op==6)&&I>0) str_tb((Op==5)?Cr:"\n",Out);
15689: if(Op==6){
15690: if(type(LT)==7){
15691: str_tb([LT," "],Out);
15692: I=-1;
15693: continue;
15694: }
15695: str_tb("$",Out);
15696: }
15697: KK=0;
15698: if(Str>0 && type(LT)==4 && Opt!=[])
15699: S=ltotex(LT|opt=car(Opt),lim=0,str=Str,cr=Cr2,var=Var);
15700: else if(type(LT)==6){
15701: if(Lim>0){
15702: S=mtotex(LT|var=Var,lim=0,len=1);
15703: KK=S[1];
15704: S=S[0];
15705: }else S=mtotex(LT|var=Var,lim=0);
15706: }else if(type(LT)==3 || type(LT)==2)
15707: S=fctrtos(LT|TeX=2,lim=0,var=Var);
15708: else S=my_tex_form(LT);
15709: if(Op!=6&&I>0&&Lim){
15710: if(Lim<0){
15711: if(I%(-Lim)==0)
15712: str_tb((Op==5)?Cr:"\n",Out);
15713: }else if((K+=(KK=(KK)?KK:texlen(S)))>Lim){
15714: str_tb((Op==5)?Cr:"\n",Out);
15715: K=KK;
15716: }
15717: }
15718: str_tb(S,Out);
15719: if(Op==6) str_tb("$",Out);
15720: }
15721: }else if(Op==7||Op==8){ /* spts, spts0 */
15722: if(type(Lim=getopt(lim))!=1 || (Lim<30 && Lim!=0))
15723: Lim=TeXLim;
15724: Str=getopt(str);
15725: Out = str_tb(0,0);
15726: for(K=0; L!=[]; L=cdr(L)){
15727: LT=car(L);
15728: KK=0;
15729: if(type(LT)==7 && Str==1) S=LT;
15730: else if(type(LT)==3 || type(LT)==2)
15731: S=fctrtos(LT|TeX=2,lim=0,var=Var);
15732: else if(type(LT)==6){
15733: if(Lim){
15734: S=mtotex(LT|var=Var,lim=0,len=1);
15735: KK=S[1];
15736: S=S[0];
15737: }else S=mtotex(LT|var=Var,lim=0);
15738: }else
15739: S=my_tex_form(LT);
15740: if(Lim!=0){
15741: if(!KK) KK=texlen(S);
15742: if(K>0 && K+KK>Lim){
15743: str_tb(Cr,Out);
15744: K=0;
15745: }
15746: }
15747: if(K>0){
15748: str_tb((Op==7)?"\\ ":" ",Out);
15749: if(type(LT)>3 && type(LT)<7) str_tb("%\n",Out);
15750: }
15751: str_tb(S,Out);
15752: K+=KK;
15753: if(OP==7) K++;
15754: }
15755: }else if(Op==9){ /* dform */
15756: Out=str_tb(0,0);
15757: for(I=0;L!=[];L=cdr(L),I++){
15758: for(J=0,LT=car(L); LT!=[]; LT=cdr(LT),J++){
15759: if(J==0){
15760: if((V=car(LT))==0) continue;
15761: if(I>0){
15762: if(type(V)==1){
15763: if(V<0){
15764: str_tb("-",Out);
15765: V=-V;
15766: }
15767: else str_tb("+",Out);
15768: if(V==1 && length(LT)>1) continue;
15769: str_tb(monototex(V),Out);
15770: continue;
15771: }
15772: else str_tb("+",Out);
15773: }
15774: }else if(J>0) str_tb((J>1)?"\\wedge d":"\\,d",Out);
15775: V=monototex(car(LT));
15776: if(V<"-" || V>=".") str_tb(V,Out);
15777: else str_tb(["(",V,")"],Out);
15778: }
15779: }
15780: }else if(Op==10 && type(L)==4 && type(car(L))==4){ /* tab */
15781: if(type(Null=getopt(null))<0) Null="";
15782: if(getopt(vert)==1){
15783: M=lv2m(L|null=Null);
15784: L=m2ll(mtranspose(M));
15785: }
15786: if(type(W=getopt(width))==1)
15787: L=madjust(L,W|null=Null);
15788: LV=ltov(L);
15789: S=length(LV);
15790: #if 1
15791: if(type(T=getopt(left))==4){
15792: T=str_times(T,S);
15793: for(L=[],I=0;I<S;I++){
15794: L=cons(cons(car(T),LV[I]),L);
15795: T=cdr(T);
15796: }
15797: LV=reverse(L);
15798: }
15799: if(type(T=getopt(right))==4){
15800: T=str_times(T,S);
15801: for(L=[],I=0;I<S;I++){
15802: L=cons(append(LV[I],[car(T)]),L);
15803: T=cdr(T);
15804: }
15805: LV=reverse(L);
15806: }
15807: for(I=CS=0; I<S; I++)
15808: if(length(LV[I])>CS) CS=length(LV[I]);
15809: if(type(T=getopt(top))==4){
15810: LV=cons(str_times(T,CS),vtol(LV));
15811: S++;
15812: }
15813: if(type(T=getopt(last))==4){
15814: LV=append(vtol(LV),[str_times(T,CS)]);
15815: S++;
15816: }
15817: #else
15818: for(I=CS=0; I<S; I++)
15819: if(length(LV[I])>CS) CS=length(LV[I]);
15820: #endif
15821: if(type(Title=getopt(title))!=7) Title="";
15822: if(type(Vline=getopt(vline))!=4) Vline=[0,CS];
15823: else Vline=subst(Vline,z,CS);
15824: for(VV=[],VT=Vline;VT!=[];VT=cdr(VT)){
15825: if(type(T=car(VT))==4 && T[1]>0){
15826: for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV);
15827: }else VV=cons(T,VV);
15828: }
15829: Vline=qsort(VV);
15830: Out=str_tb("\\begin{tabular}{",0);
15831: if(type(Al=getopt(align))==7 && str_len(Al)>1){
15832: str_tb(Al,Out);
15833: }else{
15834: if(type(Al)!=7 || str_len(Al)<1) Al="r";
15835: for(I=0;I<=CS;I++){
15836: if(I!=0) str_tb(Al,Out);
15837: while(Vline!=[] && car(Vline)==I){
15838: str_tb("|",Out);
15839: Vline=cdr(Vline);
15840: }
15841: }
15842: }
15843: str_tb("}",Out);
15844: if(Title!="")
15845: str_tb("\n\\multicolumn{"+rtostr(CS)+"}{c}{"+Title+"}\\\\",Out);
15846: if(type(Hline=getopt(hline))!=4) Hline=[0,S];
15847: else Hline=subst(Hline,z,S);
15848: for(VV=[],VT=Hline;VT!=[];VT=cdr(VT)){
15849: if(type(T=car(VT))==4 && T[1]>0){
1.14 takayama 15850: for(I=T[0];I<=S;I+=T[1]) VV=cons(I,VV);
1.6 takayama 15851: }else VV=cons(T,VV);
15852: }
15853: Hline=qsort(VV);
15854: while(Hline!=[] && car(Hline)==0){
15855: str_tb(" \\hline\n",Out);
15856: Hline=cdr(Hline);
15857: }
15858: /*
15859: if(type(getopt(left))==4) CS++;
15860: if(type(getopt(right))==4) CS++;
15861: if(type(T=getopt(top))==4){
15862: LV=cons(str_times(T,CS),vtol(LV));
15863: S++;
15864: }
15865: if(type(T=getopt(last))==4){
15866: LV=append(vtol(LV),[str_times(T,CS)]);
15867: S++;
15868: }
15869: if(type(T=getopt(left))==4){
15870: T=str_times(T,S);
15871: for(L=[],I=0;I<S;I++){
15872: L=cons(cons(car(T),LV[I]),L);
15873: T=cdr(T);
15874: }
15875: LV=reverse(L);
15876: }
15877: if(type(T=getopt(right))==4){
15878: T=str_times(T,S);
15879: for(L=[],I=0;I<S;I++){
15880: L=cons(append(LV[I],[car(T)]),L);
15881: T=cdr(T);
15882: }
15883: LV=reverse(L);
15884: }
15885: */
15886: for(I=0; I<S; I++){
15887: for(C=0,LT=LV[I];C<CS; C++){
15888: if(LT!=[]){
15889: P=car(LT);
15890: if(type(P)!=7) P="$"+my_tex_form(P)+"$";
15891: if(P!="") str_tb(P,Out);
15892: LT=cdr(LT);
15893: }
15894: if(C<CS-1) str_tb("& ",Out);
15895: }
15896: str_tb("\\\\",Out);
15897: while(Hline!=[] && car(Hline)==I+1){
15898: str_tb(" \\hline",Out);
15899: Hline=cdr(Hline);
15900: }
15901: str_tb("\n",Out);
15902: }
15903: str_tb("\\end{tabular}\n",Out);
15904: }else if(Op==11){ /* graph */
1.10 takayama 15905: if(type(Strip=getopt(strip))!=1) Strip=0;
15906: if(type(MX=getopt(max))!=1) MX=0;
15907: if(type(ML=getopt(mult))!=1) ML=0;
15908: if((REL=getopt(relative))!=1) REL=0;
15909: CL=getopt(color);
15910: OL=delopt(getopt(),["color","strip","mult"]);
15911: if(ML==1&&type(CL)==4){
15912: LL=L[1];L=L[0];K=length(L);S=T="";
15913: if(!MX){
15914: MX=vector(length(L[0]));
15915: for(LT=L;LT!=[];LT=cdr(LT)){
15916: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
15917: if(REL==1) MX[I]+=car(LTT);
15918: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
15919: }
15920: }
15921: MX=lmax(MX);
15922: OL=cons(["max",MX],OL);
15923: }
15924: if(REL==1) MX=newvect(length(L[0]));
15925: for(I=0;I<K;I++){
15926: for(R=[],J=length(L[I]);--J>=0;){
15927: if(REL==1){
15928: R=cons([MX[J],V=MX[J]+L[I][J]],R);
15929: MX[J]=V;
15930: }else R=cons([(!I)?0:L[I-1][J],L[I][J]],R);
15931: }
15932: OP=cons(["color",CL[I]],OL);
15933: S+=ltotex([R,LL]|option_list=cons(["value",0],cons(["strip",(!I)?1:2],OP)));
15934: T+=ltotex([R,LL]|option_list=cons(["strip",3],OP));
15935: }
15936: return(!Strip)?xyproc(S+T):(S+T);
15937: }else if(!TikZ) CL=0;
15938: if(type(Line=getopt(line))!=1){
15939: if(type(Line)==4){
15940: if(type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
15941: Opt=Line[1]; Line=Line[0];
15942: }else if(ML==1){
15943: OL=delopt(OL,"line");
15944: LL=L[1];L=L[0];K=length(L);S="";
15945: if(!MX){
1.15 takayama 15946: MX=newvect(length(L[0]));
1.10 takayama 15947: for(LT=L;LT!=[];LT=cdr(LT)){
15948: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
15949: if(REL==1) MX[I]+=car(LTT);
15950: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
15951: }
15952: }
15953: MX=lmax(MX);
15954: OL=cons(["max",MX],OL);
15955: }
1.15 takayama 15956: for(I=0;I<K;I++)
15957: S+=ltotex([L[I],LL]|option_list
1.10 takayama 15958: =cons(["line",Line[I]],cons(["strip",(!I)?1:2],OL)));
15959: return(!Strip)?xyproc(S):S;
15960: }
15961: }else Line=0;
15962: }else Opt="@{-}";
15963: Width=8; Hight=3; WRet=1/2; HMerg=(getopt(horiz)==1)?0.3:0.2;
1.6 takayama 15964: if(!TikZ){
1.7 takayama 15965: Width*=10; Hight*=10; HMerg*=10;
1.6 takayama 15966: }
1.10 takayama 15967: VMerg=HMerg;
15968: if(type(Shift=getopt(shift))!=1)
15969: Shift=0;
1.6 takayama 15970: if(type(V=getopt(size))==4){
15971: Width=V[0];Hight=V[1];
15972: if(length(V)>2) WRet=V[2];
1.10 takayama 15973: if(length(V)>3) VMerg=VMerg=V[3];
15974: if(length(V)>4) HMerg=V[4];
1.6 takayama 15975: }
15976: Val=getopt(value);
15977: if(!isint(Val)) Val=-1;
15978: if(type(Line=getopt(line))!=1){
15979: if(type(Line)==4 && type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
15980: Opt=Line[1]; Line=Line[0];
15981: }else Line=0;
15982: }else Opt="@{-}";
15983: if(type(car(L))==4){
15984: LL=L[1]; L=L[0];
15985: }else LL=[];
15986: if(Line==-1){
15987: for(Sum=0, LT=L; LT!=[]; LT=cdr(LT)){
15988: if((S=car(LT))<=0) return 0;
15989: Sum+=S;
15990: }
1.16 takayama 15991: for(R=[],LT=L;LT!=[];LT=cdr(LT)) R=cons(car(LT)/Sum,R);
1.6 takayama 15992: R=reverse(R);
15993: Opt0=Opt*2/3;
1.10 takayama 15994: Out=str_tb((Strip>0)?0:xyproc(1),0);
1.16 takayama 15995: if(type(CL)!=4) str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out);
1.6 takayama 15996: for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){
1.16 takayama 15997: SS=S+RT[0];
15998: if(type(CL)==4){
15999: str_tb(xyang(Opt,[0,0],(0.25-SS)*6.2832,(0.25-S)*6.2832|ar=1,opt=car(CL)),Out);
16000: if(length(CL)>0) CL=cdr(CL);
16001: }else str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out);
16002: T=(S+SS)/2;
16003: S=SS;
1.6 takayama 16004: if(LT!=[]){
1.16 takayama 16005: str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),car(LT)]),Out);
1.6 takayama 16006: LT=cdr(LT);
16007: }
16008: }
1.10 takayama 16009: if(!Strip) str_tb(xyproc(0),Out);
1.6 takayama 16010: return str_tb(0,Out);
16011: }
16012: if(MX==0){
16013: for(MX=0,LT=L; LT!=[]; LT=cdr(LT))
16014: if(car(LT)>MX) MX=car(LT);
16015: }
16016: MX-=Shift;
16017: S=length(L);
16018: WStep=Width/S;
16019: WWStep=WStep*WRet;
1.10 takayama 16020: HStep=(Hight<0)?-Hight:Hight/MX;
1.7 takayama 16021: if(LL!=[]&&length(LL)==S-1) WS2=WStep/2;
16022: else WS2=0;
1.10 takayama 16023: Out=str_tb((Strip>0)?0:xyproc(1),0);
16024: Hori=getopt(horiz);
16025: if(Strip<2){
16026: if(Hori==1) str_tb(xyline([0,0],[0,Width-WStep+WWStep]),Out);
16027: else str_tb(xyline([0,0],[Width-WStep+WWStep,0]),Out);
16028: }
1.6 takayama 16029: for(I=0,LT=L;LT!=[]; LT=cdr(LT),I++){
1.10 takayama 16030: XP=WStep*I; XPM=XP+WWStep/2;
16031: if(type(LTT=car(LT))==4){
16032: YP0=(car(LTT)-Shift)*HStep;YP=(LTT[1]-Shift)*HStep;
16033: VL=LTT[1];
16034: if(REL) VL-=LTT[0];
16035: }else{
16036: YP0=0;YP=(LTT-Shift)*HStep;VL=LTT;
16037: }
16038: if(Hori==1){
16039: if(Line!=0){
16040: if(I>0)
16041: str_tb(xyarrow([XPM,YP],[XPM-WStep,YPP]|opt=Opt),Out);
16042: if(Val!=0)
16043: str_tb(xyput([YP+HMerg, XPM,car(LT)]),Out);
16044: if(Line==2)
16045: str_tb(xyput([YP,XPM,"$\\bullet$"]),Out);
16046: YPP=YP;
16047: }else if(YP!=0 || Val==1){
16048: if(Strip!=3){
16049: if(CL) str_tb(xybox([[YP,XP+WWStep], [YP0,XP]]|color=CL),Out);
16050: else str_tb(xybox([[YP,XP+WWStep],[YP0,XP]]),Out);
16051: }
16052: if(Val!=0) str_tb(xyput([(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),XPM,VL]),Out);
16053: }
16054: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([-VMerg,XPM+WS2,LL[I]]),Out);
16055: }else{
16056: if(Line!=0){
16057: if(I>0)
16058: str_tb(xyarrow([XPM-WStep,YPP],[XPM,YP]|opt=Opt),Out);
16059: if(Val!=0)
16060: str_tb(xyput([XPM,YP+HMerg,car(LT)]),Out);
16061: if(Line==2)
16062: str_tb(xyput([XPM,YP,"$\\bullet$"]),Out);
16063: YPP=YP;
16064: }else if(YP!=0 || Val==1){
16065: if(Strip!=3){
16066: if(CL) str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]|color=CL),Out);
16067: else str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]),Out);
16068: }
16069: if(Val!=0) str_tb(xyput([XPM,(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),VL]),Out);
1.6 takayama 16070: }
1.10 takayama 16071: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([XPM+WS2,-VMerg,LL[I]]),Out);
1.6 takayama 16072: }
16073: }
1.10 takayama 16074: if(!Strip)str_tb(xyproc(0),Out);
1.6 takayama 16075: }else if(Op==12){ /* coord */
16076: Out=str_tb("(",0);
16077: for(LT=L;;){
16078: X=car(LT);
16079: if(type(X)>3 || imag(X)==0) str_tb(my_tex_form(X),Out);
16080: else{
16081: XR=real(X);XI=imag(X);
16082: S=monototex(imag(X));
16083: if(S=="1") S="";
16084: else if(S=="- 1") S="-";
16085: if(getopt(cpx)==2) S=S+"\\sqrt{-1}";
16086: else S=S+"i";
16087: if(XR!=0){
16088: if(str_char(S,0,"-")==0) S=monototex(XR)+S;
16089: else S=monototex(XR)+"+"+S;
16090: }
16091: str_tb(S,Out);
16092: }
16093: if((LT=cdr(LT))==[]) break;
16094: else str_tb(",",Out);
16095: }
16096: str_tb(")",Out);
16097: }
16098: else return my_tex_form(L);
16099: S = str_tb(0,Out);
16100: return (getopt(small)==1)?smallmattex(S):S;
16101: }
16102:
16103:
16104: def str_tb(L,TB)
16105: {
16106: if(type(TB) == 0) TB = "";
16107: if(L == 0)
16108: return (type(TB) == 7)?string_to_tb(TB):tb_to_string(TB);
16109: if(type(L) == 7)
16110: L = [L];
16111: else if(type(L) != 4){
16112: erno(0);
16113: return 0;
16114: }
16115: if(type(TB) <= 7)
16116: TB = string_to_tb((type(TB)==7)?TB:"");
16117: for(; L != []; L = cdr(L))
16118: write_to_tb(car(L), TB);
16119: return TB;
16120: }
16121:
16122: /*
16123: def redgrs(M,T)
16124: {
16125: L = [zzz];
16126: for(I=S=0,Eq=[],MT=M; MT!=[]; I++, MT=cdr(MT)){
16127: for(J=LS=0, N=car(MT); N!=[]; N=cdr(N)){
16128: X = makev([z,I,z,J]);
16129: L=cons(X,L);
16130: LS += X;
16131: S += car(N)[1]*X;
16132: }
16133: Eq = cons(LS-zzz,Eq);
16134: }
16135: Eq = cons(S-T,Eq);
16136: Sol= lnsol(Eq,L);
16137: for(LS=[],S=Sol; S!=[]; S=cdr(S)){
16138: T=car(S);
16139: if(type(S)!=4) return 0;
16140: LS=cons(car(S)[0],LS);
16141: }
16142: }
16143: */
16144:
16145: /* T=0 : all reduction
16146: =1 : construction procedure
16147: =2 : connection coefficient
16148: =3 : operator
16149: =4 : series expansion
16150: =5 : expression by TeX
16151: =6 : Fuchs relation
16152: =7 : All
16153: =8 : basic
16154: =9 : ""
16155: =10: irreducible
16156: =11: recurrence */
16157: def getbygrs(M, TT)
16158: {
16159: /* extern TeXEq; */
16160:
16161: if(type(M)==7) M=s2sp(M);
16162: if(type(M) != 4 || TT =="help"){
16163: mycat(
16164: ["getbygrs(m,t) or getbygrs(m,[t,s_1,s_2,...]|perm=?,var=?,pt=?,mat=?)\n",
16165: " m: generalized Riemann scheme or spectral type\n",
16166: " t: reduction, construct, connection, series, operator, TeX, Fuchs, irreducible, basic, recurrence,\n",
16167: " All\n",
16168: " s: TeX dviout simplify short general operator irreducible top0 x1 x2 sft\n",
16169: "Ex: getbygrs(\"111,21,111\", [\"All\",\"dviout\",\"operator\",\"top0\"])\n"]);
16170: return 0;
16171: }
16172: if(type(TT) == 4){
16173: T = TT[0];
16174: T1 = cdr(TT);
16175: }else{
16176: T = TT;
16177: T1 = [];
16178: }
16179: if(type(T) == 7)
16180: T = findin(T,["reduction","construct","connection", "operator", "series",
16181: "TeX", "Fuchs", "All", "basic", "", "irreducible", "recurrence"]);
16182: TeX = findin("TeX", T1);
16183: Simp = findin("simplify", T1);
16184: Short = findin("short", T1);
16185: Dviout= findin("dviout", T1);
16186: General=findin("general", T1);
16187: Op =findin("operator", T1);
16188: Irr =findin("irreducible", T1);
16189: Top0 =findin("top0",T1);
16190: X1 =findin("x1",T1);
16191: X2 =findin("x2",T1);
16192: Sft =findin("sft",T1);
16193: Title = getopt(title);
16194: Mat = getopt(mat);
16195: if(Mat!=1 || T<0 ||(T!=0&&T!=1&&T!=5&&T!=6&&T!=8&&T!=10&&T!=9)) Mat = 0;
16196: if(findin("keep",T1) >= 0)
16197: Keep = Dviout = 1;
16198: else Keep = 0;
16199: if(Dviout >= 0 || T == 5) TeX = 1;
16200: for(J = 0, MM = M; J == 0 && MM != []; MM = cdr(MM)){
16201: for(MI = car(MM); MI != []; MI = cdr(MI)){
16202: if(type(car(MI)) != 1 || car(MI) <= 0){
16203: J = 1; break;
16204: }
16205: }
16206: }
16207:
16208: /* spectral type -> GRS */
16209: if(J == 0){
16210: for(R = [], S = J = 0, MM = M; MM != []; MM = cdr(MM), J++){
16211: MT = qsort(car(MM));
16212: R = cons(reverse(MT), R);
16213: if(J == 1){
16214: S = length(MT)-1;
16215: if(MT[S] > MT[0]) S = 0;
16216: }
16217: }
16218: M = reverse(R);
16219: R = getopt(var);
16220: if(type(R)<1){
16221: for(R = [], I = J-1; I >= 0; I--)
16222: R = cons(asciitostr([97+I]), R);
16223: }
16224: Sft=(Sft>=0)?1:0;
16225: if(General < 0)
16226: Sft=-Sft-1;
16227: M = sp2grs(M,R,Sft|mat=Mat);
16228: }
16229: for(M0=[],MM=M;MM!=[];MM=cdr(MM)){ /* change "?" -> z_z */
16230: for(M1=[],Mm=car(MM);Mm!=[];Mm=cdr(Mm)){
16231: Mt=car(Mm);
16232: if(type(Mt)==4 && Mt[1]=="?"){
16233: M1=cons([Mt[0],z_z],M1);
16234: continue;
16235: }else if(type(Mt)==7 && Mt=="?"){
16236: M1=cons(z_z,M1);
16237: continue;
16238: }
16239: M1=cons(Mt,M1);
16240: }
16241: M0=cons(reverse(M1),M0);
16242: }
16243: M = fspt(reverse(M0),5); /* short -> long */
16244: if(findin(z_z,vars(M))>=0)
16245: M=subst(M,z_z,lsol(chkspt(M|mat=Mat)[3],z_z)); /* Fuchs relation */
16246: NP = length(M);
16247: Perm = getopt(perm);
16248: if(type(Perm) == 4)
16249: M = mperm(M,Perm,0);
16250: if(T == 9){ /* "" */
16251: if(Short >= 0)
16252: M = chkspt(M|opt=4,mat=Mat);
16253: return M;
16254: }
16255: R = [0,M];
16256: ALL = [R];
16257:
16258: while(type(R = redgrs(R[1]|mat=Mat)) == 4)
16259: ALL = cons(R, ALL);
16260: if(R < 0)
16261: return 0;
16262:
16263: /* TeX */
16264: if(TeX >= 0 && !chkfun("print_tex_form", "names.rr"))
16265: return 0;
16266: if(Dviout >= 0 && type(Title) == 7)
16267: dviout(Title|keep=1);
16268: if(T == 7 && Dviout >= 0){
16269: S=["keep","simplify"];
16270: if(Top0 >= 0)
16271: S = cons("top0",S);
16272: getbygrs(M,cons(5,S)|title="\\noindent Riemann Scheme",mat=Mat);
16273: Same = 0;
16274: if(R > 0){
16275: MM = getbygrs(M,8|mat=Mat); /* basic GRS */
16276: MS = chkspt(MM|opt=0,mat=Mat); /* spectral type */
16277: if(M != MM)
16278: getbygrs(MM,cons(5,S)|title="Basic Riemann Scheme",mat=Mat);
16279: else{
16280: dviout("This is a basic Riemann Scheme.\n\n\\noindent"|keep=1);
16281: Same = 1;
16282: }
16283: dviout(MS|keep=1);
16284: }
16285: if(chkspt(ALL[0][1]|mat=Mat)[3] != 0)
16286: getbygrs(M,cons(6,S)|title="Fuchs condition",mat=Mat);
16287: if(Same == 0){
16288: M1 = M[1];
16289: if(M1[length(M1)-1][0]==1 && Mat!=1){
16290: M1=M[2];
16291: if(M1[length(M1)-1][0] == 1){
16292: getbygrs(M,cons(2,S)|title="Connection formula");
16293: if(M1[length(M[0][0])-1][0] == 1 && R==0)
16294: getbygrs(M,cons(11,S)|title="Recurrence relation shifting the last exponents at $\\infty$, 0, 1");
16295: }
16296: getbygrs(M,cons(1,S)|title="Integral representation");
16297: getbygrs(M,cons(4,S)|title="Series expansion");
16298: }
16299: if(Irr < 0){
16300: TI="Irreduciblity $\\Leftrightarrow$ any value of the following linear forms $\\notin\\mathbb Z$";
16301: if(R > 0)
16302: TI += " + fundamental irreducibility";
16303: getbygrs(M,cons(10,S)|title=TI,mat=Mat);
16304: dviout("which coorespond to the decompositions"|keep=1);
16305: sproot(chkspt(M|opt=0),"pairs"|dviout=1,keep=1);
16306: }
16307: }
16308: if(Op >= 0 && Mat!=1) getbygrs(M,cons(3,S)|title="Operator");
16309: dviout(" ");
16310: return 1;
16311: }
16312: if(T == 0 && TeX >= 0){
16313: T = 1; TeX = 16;
16314: }
16315: /* Fuchs */
16316: Fuc = chkspt(ALL[0][1]|Mat=mat)[3];
16317: if(Fuc == 0) Simp = -1;
16318: if(type(Fuc) == 1){
16319: print("Violate Fuchs condition");
16320: return 0;
16321: }
16322: if(T == 6){
16323: if(Dviout >= 0) dviout(Fuc|eq=0,keep=Keep);
16324: return (TeX >= 0)?my_tex_form(Fuc):Fuc;
16325: }
16326: Fuc = [Fuc];
16327: /* Generelized Riemann scheme */
16328: if(T == 5){
16329: M = ltov(M);
16330: for(ML=0, I=0; I<NP; I++){
16331: L = length(M[I]);
16332: if(L > ML) ML = L;
16333: }
16334: Out = string_to_tb("P\\begin{Bmatrix}\nx=");
16335: if(Top0 < 0)
16336: write_to_tb("\\infty & ",Out);
16337: Pt = getopt(pt);
16338: if(type(Pt) == 4){
16339: for(J = 3; J < NP; J++){
16340: str_tb(["& ",rtotex(car(Pt))],Out);
16341: Pt = cdr(Pt);
16342: }
16343: }
16344: else if(X2>=0)
16345: str_tb("0 & x_2",Out);
16346: else
16347: str_tb((X1>=0)?"x_1 & x_2":"0 & 1",Out);
16348: for(J = 3; J < NP; J++)
16349: str_tb(["& x_",rtotex(J)],Out);
16350: if(Top0 >= 0)
16351: write_to_tb("& \\infty",Out);
16352: write_to_tb("\\\\\n",Out);
16353: for(I = 0; I < ML; I++){
16354: for(CC = 0, J = (Top0 >= 0)?1:0; ; J++, CC++){
16355: if(J == NP){
16356: if(Top0 < 0) break;
16357: J = 0;
16358: }
16359: if(length(M[J]) <= I){
16360: if(CC > 0) write_to_tb(" & ",Out);
16361: }else if(M[J][I][0] <= 1){
16362: if(M[J][I][0] == 0) str_tb(" & ",Out);
16363: else
16364: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
16365: }else{
16366: str_tb([((!CC)?"[":" & ["), my_tex_form(M[J][I][1]),
16367: (Mat==1)?"]_{":"]_{("],Out);
16368: str_tb([my_tex_form(M[J][I][0]),(Mat==1)?"}":")}"],Out);
16369: }
16370: if(Top0 >= 0 && J == 0)
16371: break;
16372: }
16373: if(I == 0)
16374: str_tb("&\\!\\!;x",Out);
16375: str_tb("\\\\\n",Out);
16376: }
16377: str_tb("\\end{Bmatrix}",Out);
16378: Out = str_tb(0,Out);
16379: if(Dviout >= 0)
16380: dviout(Out|eq=0,keep=Keep);
16381: return Out;
16382: }
16383:
16384: /* Reduction */
16385: if(T == 0){
16386: if(Simp >= 0)
16387: ALL = simplify(ALL,Fuc,4);
16388: return reverse(ALL);
16389: }
16390: LA = length(ALL) - 1;
16391: NP = length(ALL[0][1]);
16392:
16393: /* irreducible */
16394: if(T == 10){
16395: for(IR=[], I = 0; I < LA; I++){
16396: AI = ALL[I]; AIT = AI[1];
16397: K = AI[0][0];
16398: P = -AIT[0][K][1];
16399: P -= cterm(P);
16400: IR = cons(P, IR);
16401: for(J = 0; J < NP; J++){
16402: K = AI[0][J];
16403: for(L = length(AIT[J]) - 1; L >= 0 ; L--){
16404: if(L == K || AIT[J][L][0] <= AIT[J][K][0])
16405: continue;
16406: P = AIT[J][L][1] - AIT[J][K][1];
16407: Q = cterm(P);
16408: if(dn(Q)==1)
16409: P -= Q;
16410: IR = cons(P,IR);
16411: }
16412: }
16413: }
16414: P=Fuc[0];
16415: Q=cterm(P);
16416: if(type(Q)==1 && dn(Q)==1){
16417: for(F=0,V=vars(P);V!=[];V=cdr(V)){
16418: R=mycoef(P,1,car(V));
16419: if(type(R)!=1 || Q%R!=0){
16420: F=1; break;
16421: }
16422: }
16423: if(F==0){
16424: P-=Q;
16425: Simp=0;
16426: }
16427: }
16428: if(Simp >= 0){
16429: IR=simplify(IR,[P],4);
16430: for(R=[]; IR!=[]; IR=cdr(IR)){
16431: P=car(IR);
16432: Q=cterm(P);
16433: if(dn(Q)==1) P-=Q;
16434: R=cons(P,R);
16435: }
16436: IR=R;
16437: }
16438: for(R=[]; IR!=[]; IR=cdr(IR)){
16439: P=car(IR);
16440: if(str_len(rtostr(P)) > str_len(rtostr(-P)))
16441: P = -P;
16442: R = cons(P,R);
16443: }
16444: R = ltov(R);
16445: #ifdef USEMODULE
16446: R = qsort(R,os_md.cmpsimple);
16447: #else
16448: R = qsort(R,cmpsimple);
16449: #endif
16450: R = vtol(R);
16451: if(TeX >= 0){
16452: Out = string_to_tb("");
16453: for(I=L=K=0; R!=[]; R=cdr(R),I++){
16454: K1 = K;
16455: RS = my_tex_form(car(R));
16456: K = nmono(car(R));
16457: L += K;
16458: if(I){
16459: if(K1 == K && L < 30)
16460: str_tb("\\quad ",Out);
16461: else{
16462: L = K;
16463: str_tb((TeXEq==5)?["\\\\%\n &"]:["\\\\%\n "],Out);
16464: }
16465: }
16466: str_tb(RS,Out);
16467: }
16468: R = Out;
16469: if(Dviout>=0){
16470: dviout(R|eq=0,keep=Keep);
16471: return 1;
16472: }
16473: }
16474: return R;
16475: }
16476:
16477: AL = []; SS = 0;
16478: for(I = 0; I <= LA; I++){
16479: AI = ALL[I]; AIT = AI[1]; /* AIT: GRS */
16480: if(I > 0){
16481: for(S = J = 0; J < NP; J++){
16482: GE = AIT[J][AI0[J]][1];
16483: S += GE;
16484: if(J == 0)
16485: SS = [];
16486: else
16487: SS = cons(GE,SS);
16488: }
16489: SS = cons(1-Mat-S, reverse(SS));
16490: }
16491: AI0 = AI[0];
16492: AL = cons([SS, cutgrs(AIT)], AL);
16493: }
16494: AL = reverse(AL);
16495: AD = newvect(NP);
16496: ALT = AL[0][1];
16497: for(J = 1; J < NP; J++){
16498: /* AD[J] = ALT[J][0][1]; [J][?][1] <- [J][?][0]: max */
16499: for(MMX=0, K = KM = length(ALT[J])-1; K >= 0; K--){
16500: if(MMX <= ALT[J][K][0]){
16501: if(J == 1 && MMX == ALT[J][K][0])
16502: continue;
16503: KM = K;
16504: MMX = ALT[J][K][0];
16505: }
16506: }
16507: AD[J] = ALT[J][KM][1];
16508: }
16509: AL = cdr(AL);
16510: AL = cons([vtol(AD), ALT], AL);
16511: AL = cons([0, mcgrs(ALT, [vtol(-AD)]|mat=Mat)], AL);
16512: if(Simp >= 0 && T != 3)
16513: AL = simplify(AL,Fuc,4);
16514: /* Basic */
16515: if(T == 8){
16516: ALT = AL[0][1];
16517: if(TeX >= 0){
16518: if(Dviout >= 0){
16519: return getbygrs(ALT,["TeX","dviout","keep"]);
16520: }
16521: return getbygrs(ALT,"TeX");
16522: }
16523: if(Short >= 0)
16524: ALT = chkspt(ALT|opt=4);
16525: return ALT;
16526: }
16527:
16528: /* Construct */
16529: if(T == 1){
16530: if(TeX >= 0){
16531: L = length(AL);
16532: I = Done = 0; Out0=Out1=""; NM = DN = [];
16533: if(TeX != 16){
16534: AL11=AL[L-1][1][1];
16535: AT = AL11[length(AL11)-1];
16536: if(type(AT) == 4){
16537: PW = (AT[0] > 1)?"":AT[1];
16538: }else PW = AT;
16539: }
16540: Out = string_to_tb("");
16541: while(--L >= 0){
16542: if(TeX == 16){
16543: if(Done)
16544: write_to_tb(":\\ ", Out);
16545: write_to_tb(getbygrs(AL[L][1],(Top0>=0)?["TeX", "top0"]:"TeX"|mat=Mat), Out);
16546: Done = 1;
16547: if(L != 0) write_to_tb((TeXEq==5)?
16548: "\\\\%\n&\\leftarrow ":"\\\\%\n\\leftarrow ", Out);
16549: }
16550: ALT = AL[L][0];
16551: if(TeX != 16){
16552: V1 = (I==0)?"x":V2;
16553: V2 = /* (I==0 && L<=2)?"s": */
16554: "s_"+rtotex(I);
16555: }else V1=V2="x";
16556: JJ = (type(ALT) == 4)?length(ALT):0;
16557: if(I > 0 && L > 0)
16558: write_to_tb("\n ", Out);
16559: for(Outt = "", J = 1; J < JJ; J++){
16560: if(ALT[J] == 0) continue;
16561: if(J == 1) Outt += V1;
16562: else if(J == 2) Outt += "(1-"+V1+")";
16563: else Outt += "(x_"+rtotex(J)+"-"+V1+")";
16564: Outt += "^"+ rtotex(ALT[J]);
16565: }
16566: if(TeX != 16) write_to_tb(Outt, Out);
16567: else if(Outt != "")
16568: str_tb(["\\mathrm{Ad}\\Bigl(",Outt,"\\Bigr)"], Out);
16569: if(JJ == 0){
16570: if(I != 0)
16571: Out1 = "ds_"+rtotex(I-1)+Out1;
16572: continue;
16573: }
16574: if(ALT[0] == 0) continue;
16575: Out0 += "\\int_p^{"+V1+"}";
16576: if(TeX == 16)
16577: str_tb(["mc_",rtotex(ALT[0])], Out);
16578: else{
16579: str_tb(["(",V1,"-",V2,")^",rtotex(-1+ALT[0])], Out);
16580: AL11=AL[L-1][1][1];
16581: AT = AL11[length(AL11)-1];
16582: if(type(AT) == 4) AT = AT[1];
16583: DN = cons(ALT[0]+AT+1,DN);
16584: NM = cons(AT+1,cons(ALT[0],NM));
16585: }
16586: if(L != 2) Out1 += "d"+V2;
16587: I++;
16588: }
16589: if(R){
16590: if(I == 0) Ov = "x";
16591: else Ov = "s_"+rtotex(I-1);
16592: Out1 = "u_B("+Ov+")"+Out1;
16593: }
16594: if(TeX != 16){
16595: Out0 = string_to_tb(Out0);
16596: str_tb([Out, Out1], Out0);
16597: Out = Out0;
16598: NM = simplify(NM, Fuc, 4);
16599: DN = simplify(DN, Fuc, 4);
16600: DNT = lsort(NM,DN,"reduce");
16601: NMT = DNT[0]; DNT = DNT[1];
16602: if(NMT != [] && PW != ""){
16603: write_to_tb((TeXEq==5)?"\\\\\n &\\sim\\frac{\n"
16604: :"\\\\\n \\sim\\frac{\n", Out);
16605: for(PT = NMT; PT != []; PT = cdr(PT))
16606: str_tb([" \\Gamma(",my_tex_form(car(PT)), ")\n"], Out);
16607: write_to_tb(" }{\n", Out);
16608: for(PT = DNT; PT != []; PT = cdr(PT))
16609: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
16610: write_to_tb(" }", Out);
16611: if(R > 0) write_to_tb("C_0", Out);
16612: write_to_tb("x^"+rtotex(PW) +"\\ \\ (p=0,\\ x\\to0)", Out);
16613: }
16614: }else
16615: Out = str_tb(0, Out);
16616: if(Dviout >= 0){
16617: dviout(Out|eq=0,keep=Keep);
16618: return 1;
16619: }
16620: return O;
16621: }
16622: if(Short >= 0){
16623: for(ALL = [] ; AL != []; AL = cdr(AL)){
16624: AT = car(AL);
16625: ALL = cons([AT[0], chkspt(AT[1]|opt=4)], ALL);
16626: }
16627: AL = reverse(ALL);
16628: }
16629: return AL; /* AL[0][1] : reduced GRS, R==0 -> rigid */
16630: }
16631:
16632: if(T == 2 || T == 4 || T == 11){
16633: for(I = (T==2)?2:1; I >= (T==11)?0:1; I--){
16634: ALT = M[I];
16635: if(ALT[length(ALT)-1][0] != 1){
16636: mycat(["multiplicity for",I,":",ALT[length(ALT)-1][1],
16637: "should be 1"]);
16638: return;
16639: }
16640: }
16641: }
16642: LA++;
16643: NM = DN = [];
16644:
16645: /* Three term relation */
16646: if(T == 11){
16647: if(R > 0){
16648: print("This is not rigid\n");
16649: return 0;
16650: }
16651: for(I = 0; I <= LA; I++){
16652: if(I > 0){
16653: AI = AL[I][0]; /* operation */
16654: if(AI[0] != 0){
16655: DN = cons(simplify(AI1+1,Fuc,4),DN);
16656: NM = cons(simplify(AI1+AI[0]+1,Fuc,4),NM);
16657: }
16658: }
16659: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
16660: }
16661: DNT = lsort(NM,DN,"reduce");
16662: if(TeX < 0) return DNT;
16663: NMT = DNT[0]; DNT = DNT[1];
16664: Out = str_tb("u_{0,0,0}-u_{+1,0,-1}=\\frac{","");
16665: for(PT = NMT; PT != []; PT = cdr(PT))
16666: str_tb(["(",my_tex_form(car(PT)),")"], Out);
16667: str_tb(["}\n{"],Out);
16668: for(PT = DNT; PT != []; PT = cdr(PT))
16669: str_tb(["(",my_tex_form(car(PT)),")"], Out);
16670: write_to_tb("}u_{0,+1,-1}",Out);
16671: if(Dviout >= 0){
16672: dviout(Out|eq=0,keep=Keep);
16673: return 1;
16674: }
16675: return Out;
16676: }
16677:
16678: AD=newvect(NP);
16679: for(I = 0; I <= LA; I++){
16680: if(I > 0){
16681: AI = AL[I][0]; /* operation */
16682: if(T == 2 && AI[0] != 0){
16683: DN = cons(simplify(-AI2,Fuc,4), cons(simplify(AI1+1,Fuc,4),DN));
16684: NM = cons(simplify(-AI2-AI[0],Fuc,4), cons(simplify(AI1+AI[0]+1,Fuc,4),
16685: NM));
16686: }
16687: for(J = 1; J < NP; J++)
16688: AD[J] += simplify(AI[J],Fuc,4);
16689: }
16690: if(T == 2){
16691: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
16692: ALT = AL[I][1][2]; AI2 = ALT[length(ALT)-1][1];
16693: if(I == 0){
16694: C3 = AI1; C4 = AI2;
16695: }
16696: }
16697: }
16698:
16699: /* Connection */
16700: if(T == 2){
16701: DNT = lsort(NM,DN,"reduce");
16702: NMT = DNT[0]; DNT = DNT[1];
16703: if(TeX < 0) return [NMT,DNT,AD];
16704: C0 = M[1][length(M[1])-1][1];
16705: C1 = M[2][length(M[2])-1][1];
16706: M = AL[0][1];
16707: C3 = M[1][length(M[1])-1][1];
16708: C4 = M[2][length(M[2])-1][1];
16709: Out = str_tb(["c(0\\!:\\!", my_tex_form(C0),
16710: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C1),")"], "");
16711: if(R > 0 && AMSTeX == 1 && (TeXEq == 4 || TeXEq == 5)){
16712: write_to_tb("\\\\\n", Out);
16713: if(TeXEq == 5) write_to_tb(" &", Out);
16714: }
16715: write_to_tb("=\\frac{\n",Out);
16716: for(PT = NMT; PT != []; PT = cdr(PT))
16717: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
16718: write_to_tb(" }{\n",Out);
16719: for(PT = DNT; PT != []; PT = cdr(PT))
16720: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n",Out);
16721: write_to_tb(" }", Out);
16722: for(J = 3; J < length(AD); J++){
16723: if(AD[J] == 0) continue;
16724: str_tb(["\n (1-x_", rtotex(J), "^{-1})^", rtotex(AD[J])], Out);
16725: }
16726: if(R != 0)
16727: str_tb(["\n c_B(0\\!:\\!", my_tex_form(C3),
16728: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C4), ")"], Out);
16729: Out = tb_to_string(Out);
16730: if(Dviout >= 0){
16731: dviout(Out|eq=0,keep=Keep);
16732: return 1;
16733: }
16734: return Out;
16735: }
16736:
16737: /* Series */
16738: if(T == 4){
16739: AL11 = AL[0][1][1];
16740: V = AL11[length(AL11)-1][1];
16741: S00 = -V; S01 = (R==0)?[]:[[0,0]];
16742: S1 = S2 = [];
16743: for(Ix = 1, ALL = cdr(AL); ALL != []; ){
16744: ALT = ALL[0][0];
16745: if(ALT[0] != 0){ /* mc */
16746: for(Sum = [], ST = S01; ST != []; ST = cdr(ST))
16747: Sum = cons(car(ST)[0], Sum);
16748: S1 = cons(cons(S00+1,Sum), S1);
16749: S2 = cons(cons(S00+1+ALT[0],Sum),S2);
16750: S00 += ALT[0];
16751: }
16752: ALL = cdr(ALL);
16753: for(I = 1; I < length(ALT); I++){ /* addition */
16754: if(I == 1){
16755: S00 += ALT[1];
16756: if(ALL == [])
16757: S00 = [S00];
16758: }else{
16759: if(ALT[I] == 0)
16760: continue;
16761: if(ALL != []){
16762: S1 = cons([-ALT[I],Ix],S1);
16763: S2 = cons([1,Ix],S2);
16764: S01= cons([Ix,I],S01);
16765: Ix++;
16766: }else
16767: S00 = cons([ALT[I],I],S00);
16768: }
16769: }
16770: }
16771: S00 = reverse(S00);
16772: S01 = qsort(S01); S1 = qsort(S1); S2 = qsort(S2);
16773: if(Simp >= 0){
16774: S00 = simplify(S00,Fuc,4);
16775: S01 = simplify(S01,Fuc,4);
16776: S1 = simplify(S1,Fuc,4);
16777: S2 = simplify(S2,Fuc,4);
16778: SS = lsort(S1,S2,"reduce");
16779: S1 = SS[0]; S2 = SS[1];
16780: }
16781:
16782: if(TeX >= 0){
16783: /* Top linear power */
16784: TOP = Ps = Sm = "";
16785: for(TOP = Ps = Sm = "", ST = cdr(S00); ST != []; ST = cdr(ST)){
16786: SP = car(ST);
16787: if(SP[0] != 0){
16788: if(SP[1] == 2)
16789: TOP += "(1-x)^"+rtotex(SP[0]);
16790: else
16791: TOP += "(1-x/x_"+rtotex(SP[1])+")^"+rtotex(SP[0]);
16792: }
16793: }
16794: /* Top power */
16795: PW = my_tex_form(car(S00));
16796: if(PW == "0")
16797: PW = "";
16798: NP = length(AL[0][1]);
16799: PWS = newvect(NP);
16800: for(I = 0; I < NP; I++)
16801: PWS[I] = "";
16802: for(S = S01, I = 0; S != []; S = cdr(S), I++){
16803: SI = rtotex(car(S)[0]);
16804: if(I > 0) Sm += ",\\ ";
16805: Sm += "n_"+SI+"\\ge0";
16806: if(PW != "")
16807: PW += "+";
16808: PW += "n_"+SI;
16809: if(car(S)[1] > 2)
16810: PWS[car(S)[1]] += "-n_"+rtotex(car(S)[0]);
16811: else if(car(S)[1] == 0)
16812: Ps = "C_{n_0}"+Ps;
16813: }
16814: for(I = 3; I < NP; I++){
16815: if(PWS[I] != "")
16816: Ps += "x_"+rtotex(I)+"^{"+PWS[I]+"}";
16817: }
16818: Out = str_tb([TOP, Ps, "x^{", PW, "}"], "");
16819: /* Gamma factor */
16820: for(I = 0, SS = S1; I <= 1; I++, SS = S2){
16821: PW = string_to_tb("");
16822: for(PW1=""; SS != [] ; SS = cdr(SS)){
16823: for(J = 0, SST = car(SS); SST != []; SST = cdr(SST), J++){
16824: if(J == 0){
16825: JJ = (car(SST) == 1)?((length(SST)==2)?(-1):0):1;
16826: if(JJ > 0)
16827: str_tb(["(", my_tex_form(car(SST)), ")_{"], PW);
16828: else if(JJ == 0)
16829: PW1 = "(";
16830: }else{
16831: if(JJ > 0){
16832: if(J > 1) write_to_tb("+", PW);
16833: str_tb(["n_", rtotex(car(SST))], PW);
16834: }else{
16835: if(J > 1) PW1 += "+";
16836: PW1 += "n_"+rtotex(car(SST));
16837: }
16838: }
16839: }
16840: if(JJ > 0) write_to_tb("}", PW);
16841: else PW1 += (JJ == 0)?")!":"!";
16842: }
16843: if(I == 0)
16844: Out0 = "\\frac";
16845: Out0 += "{"+tb_to_string(PW)+PW1+"}";
16846: PW = string_to_tb(""); PW1 = "";
16847: }
16848: if(Out0 == "\\frac{}{}")
16849: Out0 = "";
16850: Out = "\\sum_{"+Sm+"}"+Out0 + Top + tb_to_string(Out);
16851: if(length(S01) == 1){
16852: Out = str_subst(Out, "{n_"+SI+"}", "n");
16853: Out = str_subst(Out, "n_"+SI, "n");
16854: }
16855: if(Dviout >= 0)
16856: dviout(Out|eq=0,keep=Keep);
16857: return Out;
16858: }
16859: return [cons(S00, S01), S1, S2];
16860: }
16861:
16862: /* Operator */
16863: if(T==3){
16864: Fuc0 = car(Fuc);
16865: if(Fuc0 != 0){ /* Kill Fuchs relation */
16866: for(V = vars(Fuc0); V != []; V = cdr(V)){
16867: VT = car(V);
16868: if(deg(Fuc0,VT) == 1){
16869: AL = mysubst(AL, [VT, -red(coef(Fuc0,0,VT)/coef(Fuc0,1,VT))]);
16870: break;
16871: }
16872: }
16873: if(V == []){
16874: print("Fuchs condition has no variable with degree 1");
16875: return 0;
16876: }
16877: }
16878: L = newvect(NP);
16879: Pt = getopt(pt);
16880: for(I = NP-1; I >= 1; I--){
16881: if(type(Pt) == 4)
16882: L[I] = Pt[I-1];
16883: else if(I >= 3 || X1 >= 0 || (X2 >= 0 && I >= 2))
16884: L[I] = makev(["x_", I]);
16885: else L[I] = I-1;
16886: }
16887: if(R){ /* non-rigid basic */
16888: MM = AL[0][1]; /* Riemann scheme */
16889: for(OD = 0, MT = car(MM); MT != []; MT = cdr(MT))
16890: OD += car(MT)[0];
16891: for(V = DN = [], M = MM; M != []; M = cdr(M)){
16892: MT = car(M); /* exponents */
16893: for(K = KM = 0, NT = []; ; K++){
16894: for(J = 0, P = 1, MTT = MT; MTT != []; MTT = cdr(MTT)){
16895: if(J == 0 && car(MTT)[1] == 0)
16896: KM = car(MTT)[0];
16897: for(KK = car(MTT)[0] - K -1; KK >= 0; KK--)
16898: P *= (dx-car(MTT)[1]-KK);
16899: }
16900: if(P == 1) break;
16901: NT = cons(P,NT);
16902: }
16903: V = cons(reverse(NT), V);
16904: DN = cons(KM, DN);
16905: }
16906: V = ltov(reverse(V)); /* conditions for GRS */
16907: DN = ltov(reverse(DN)); /* dims of local hol. sol. */
16908: for(J = OD; J >= 0; J--){
16909: for(I = Q = 1; I < NP; I++){
16910: if(J > DN[I])
16911: Q *= (x-L[I])^(J-DN[I]);
16912: }
16913: K = mydeg(Q,x);
16914: if(J == OD){
16915: P = Q*dx^J;
16916: DM = K;
16917: }else{
16918: for(I = DM-OD+J-K; I >= 0; I--){
16919: X = makev(["r",J,"_",I]);
16920: P += Q*x^I*X*dx^J;
16921: }
16922: }
16923: }
16924: for(R = [], I = 0; I < NP; I++){
16925: Q = toeul(P, [x,dx], (I==0)?"infty":L[I]); /* Euler at I-th pt */
16926: for(VT = V[I], J=0; VT != [] ; VT = cdr(VT), J++){
16927: if(car(VT) != 0)
16928: R = cons(rpdiv(coef(Q,J,x), car(VT), dx)[0], R); /* equations */
16929: }
16930: }
16931: for(RR = RRR = [], I = OD-1; I>=0; I--){
16932: RR = [];
16933: for(RT = R; RT != [] ; RT = cdr(RT)){
16934: if( (VT = mycoef(car(RT), I, dx)) != 0)
16935: RR = cons(VT, RR); /* real linear eqs */
16936: }
16937: J = mydeg(mycoef(P,I,dx),x);
16938: for(S = 0, VVV = []; J >= 0; J--){
16939: X = makev(["r",I,"_",J]);
16940: VVV = cons(X, VVV); /* unknowns */
16941: }
16942: RR = lsol(RR,VVV);
16943: LN = length(RR);
16944: for(K=0; K<LN; K++){
16945: RRT = RR[K];
16946: if(type(RRT) != 4) continue;
16947: R = mysubst(R,RRT);
16948: P = mysubst(P,RRT);
16949: }
16950: }
16951: }else /* Rigid case */
16952: P = dx^(AL[0][1][0][0][0]);
16953: /* additions and middle convolutions */
16954: for(ALT = AL; ALT != []; ALT = cdr(ALT)){
16955: AI = car(ALT)[0];
16956: if(type(AI) != 4) continue;
16957: V = ltov(AI);
16958: if(V[0] != 0) P = mc(P,x,V[0]);
16959: for(I = 1; I < NP; I++){
16960: if(V[I] != 0)
16961: P = sftexp(P,x,L[I],-V[I]);
16962: }
16963: }
16964: P = (Simp>=0)? simplify(P,Fuc,4|var=[dx]):simplify(P,Fuc,4);
16965: if(TeX >= 0){
16966: Val = 1;
16967: if(mydeg(P,dx) > 2 && AMSTeX == 1 && TeXEq > 3)
16968: Val = (TeXEq==5)?3:2;
16969: Out = fctrtos(P|var=[dx,"\\partial"],TeX=Val);
16970: if(Dviout < 0) return Out;
16971: dviout(Out|eq=0,keep=Keep);
16972: return 1;
16973: }
16974: return P;
16975: }
16976: return 0;
16977: }
16978:
16979: def mcop(P,M,S)
16980: {
16981: for(V=[],ST=S;ST!=[];ST=cdr(ST))
16982: if(isvar(VT=car(ST))) V=cons(vweyl(VT),V);
16983: V=reverse(V);
16984: N=length(V);
16985: for(MT=M;MT!=[];MT=cdr(MT)){
16986: T=car(MT);
16987: if(T[0]!=0)
16988: P=mc(P,V[0],T[0]);
16989: for(TT=cdr(T),ST=cdr(S);ST!=[];TT=cdr(TT),ST=cdr(ST))
16990: if(car(TT)!=0) P=sftpexp(P,V,S[0]-ST[0],-car(TT));
16991: }
16992: return P;
16993: }
16994:
16995: /* option: zero, all, raw */
16996: def shiftop(M,S)
16997: {
16998: if(type(M)==7) M=s2sp(M);
16999: if(type(S)==7) S=s2sp(S);
17000: Zero=getopt(zero);
17001: NP=length(M);
17002: for(V=L=[],I=NP-1; I>=0; I--){
17003: V=cons(strtov(asciitostr([97+I])),V);
17004: if(I>2) L=cons(makev(["y_", I-1]),L);
17005: else L=cons(I-1,L);
17006: }
17007: if(type(M[0][0])==4){
17008: F=1;RS=M;SS=S;
17009: R=chkspt(M);
17010: if(R[2]!=2 || R[3]!=0){
17011: mycat("GRS is not valid!");return 0;
17012: }
17013: for(; S!=[]; S=cdr(S)){
17014: if(nmono(S[0][0])!=1) break;
17015: if(isint(S[0][1]-S[0][0])==0) break;
17016: }
17017: if(S!=[]){
17018: mycat("Error in shift!"); return 0;
17019: }
17020: }else{
17021: F=0;
17022: RS=sp2grs(M,V,[1,length(M[0]),1]);
17023: for(SS=S0=[],I=0; I<NP; I++){
17024: for(J=F=0; J<length(M[I]); J++){
17025: if(I==0 && J==length(M[0])-1) break;
17026: if((U=S[I][J])!=0){
17027: if(isint(U)!=1){
17028: mycat("Error in shift!"); return 0;
17029: }
17030: VT=RS[I][J][1];
17031: SS=cons([VT,VT+U],SS);
17032: }else if(I>0 && Zero==1 && F==0){
17033: RS=mysubst(RS,[RS[I][J][1],0]);
17034: F=J+1;
17035: }
17036: }
17037: if((F>0 && J==2) || (I==0 && J==1)){
17038: J=(I==0)?0:2-F; VT=RS[I][J][1];
17039: S0=cons([VT,strtov(asciitostr([strtoascii(rtostr(VT))[0]]))],S0);
17040: }
17041: }
17042: }
17043: RS1=mysubst(RS,SS);
17044: if(F==1){
17045: R=chkspt(RS1);
17046: if(R[2]!=2 || R[3]!=0){
17047: mycat("Error in shift!");
17048: return 0;
17049: }
17050: }
17051: R=getbygrs(RS,1); R1=getbygrs(RS1,1);
17052: RT=R[0][1][0];
17053: if(length(RT)!=1 || RT[0][0]!=1){
17054: mycat("Not rigid!");
17055: return 0;
17056: }
17057: P=dx;Q=Q1=1;
17058: for(RT = R, RT1=R1; RT != []; RT = cdr(RT), RT1=cdr(RT1)){
17059: V=car(RT)[0]; V1=car(RT1)[0];
17060: if(type(V) != 4) continue;
17061:
17062: if(V[0] != 0){
17063: P = mc(P,x,V[0]); /* middle convolution */
17064: QT = mc(Q,x,V[0]);
17065: }else QT=Q;
17066: D0=mydeg(Q,dx);D0T=mydeg(QT,dx);
17067: C0=red(mycoef(Q,D0,dx)/mycoef(QT,D0T,dx));
17068: if(C0!=1) QT=red(C0*QT);
17069:
17070: if(V1[0] != 0) Q1T = mc(Q1,x,V1[0]);
17071: else Q1T=Q1;
17072: D1=mydeg(Q1,dx);D1T=mydeg(Q1T,dx);
17073: C1=red(mycoef(Q1,D1,dx)/mycoef(Q1T,D1T,dx));
17074: if(C1!=1) Q1T=red(C1*Q1T);
17075: DD=(V[0]-V1[0])+(D0-D0T)-(D1-D1T);
17076: if(DD>0){
17077: QT=muldo(dx^DD,QT,[x,dx]);
17078: D0T+=DD;
17079: }else if(DD<0){
17080: Q1T=muldo(dx^(-DD),Q1T,[x,dx]);
17081: D1T-=DD;
17082: }
17083: C=mylcm(dn(QT),dn(Q1T),x);
17084: if(C!=1){
17085: QT=red(C*QT); Q1T=red(C*Q1T);
17086: }
17087: Q=QT;Q1=Q1T;
17088: for(I = 1; I < NP; I++){
17089: if(V[I]!=0){
17090: P = sftexp(P,x,L[I],-V[I]); /* addition u -> (x-L[I])^V[I]u */
17091: QT = sftexp(QT,x,L[I],-V[I]);
17092: }
17093: if(V1[I]!=0)
17094: Q1T = sftexp(Q1T,x,L[I],-V1[I]);
17095: }
17096: C=red(mycoef(QT,D0T,dx)*mycoef(Q1,D1T,dx)/(mycoef(Q,D0T,dx)*mycoef(Q1T,D1T,dx)));
17097: Q=red(dn(C)*QT);Q1=red(nm(C)*Q1T);
17098: for(I = 1; I < NP; I++){
17099: if((J=V[I]-V1[I])!=0){
17100: if(J>0) Q1*=(x-L[I])^J;
17101: else Q*=(x-L[I])^(-J);
17102: }
17103: while((QT=tdiv(Q,x-L[I]))!=0){
17104: if((Q1T=tdiv(Q1,x-L[I]))!=0){
17105: Q=QT;Q1=Q1T;
17106: }else break;
17107: }
17108: }
17109: }
17110: P1=mysubst(P,SS);
17111: if(type(S0)==4 && S0!=[]){
17112: P=mysubst(P,S0); Q=mysubst(Q,S0);
17113: P1=mysubst(P1,S0); Q1=mysubst(Q1,S0);
17114: RS=mysubst(RS,S0); RS1=mysubst(RS1,S0);
17115: }
17116: R=mygcd(Q1,P1,[x,dx]);
17117: if(findin(dx,vars(R[0]))>=0){
17118: mycat("Some error!");
17119: return 0;
17120: }
17121: Q=muldo(R[1]/R[0],Q,[x,dx]);
17122: R=divdo(Q,P,[x,dx]);
17123: Q=red(R[1]/R[2]);
17124: R=fctr(nm(Q));
17125: QQ=Q/R[0][0];
17126: R1=fctr(dn(QQ));
17127: for(RR=cdr(R1); RR!=[]; RR=cdr(RR)){
17128: VT=vars(car(RR)[0]);
17129: if(findin(x,VT)<0 && findin(dx,VT)<0){
17130: for(I=car(RR)[1];I>0;I--) QQ=red(QQ*car(RR)[0]);
17131: }
17132: }
17133: Raw=getopt(raw);
17134: Dviout=getopt(dviout);
17135: if(Dviout==1) Raw=4;
17136: if(Raw!=1){
17137: for(RR=cdr(R); RR!=[]; RR=cdr(RR)){
17138: VT=vars(car(RR)[0]);
17139: if(findin(x,VT)<0 && findin(dx,VT)<0){
17140: for(I=car(RR)[1];I>0;I--) QQ=red(QQ/car(RR)[0]);
17141: }
17142: }
17143: }
17144: if(Raw==2||Raw==3||Raw==4){
17145: R=mygcd(QQ,P,[x,dx]); /* R[0]=R[1]*QQ + R[2]*P */
17146: Q1=red(R[0]/R[2]);
17147: for(Q=1,RR=cdr(fctr(nm(Q1))); RR!=[]; RR=cdr(RR)){
17148: VT=vars(car(RR)[0]);
17149: if(findin(x,VT)<0){
17150: for(I=car(RR)[1];I>0;I--) Q*=car(RR)[0];
17151: }
17152: }
17153: if(Raw==3) QQ=[QQ,Q];
17154: else if(Raw==4) /* Q=Q*R[1]/R[0]*QQ+Q/R[0]*P */
17155: QQ=[QQ,Q,red(R[1]*Q/R[0])];
17156: else QQ=Q;
17157: }
17158: F=getopt(all);
17159: if(Dviout==1){
17160: Pre = " x=\\infty & 0 & 1";
17161: for(I=3; I<NP; I++) Pre = Pre+"& "+rtostr(L[I]);
17162: Pre = Pre+"\\\\\n";
17163: PW=str_tb(ltotex(RS|opt="GRS",pre=Pre),0);
17164: str_tb(
17165: "=\\{u\\mid Pu=0\\}\\\\\n&\\underset{Q_2}{\\overset{Q_1}{\\rightleftarrows}}\n",PW);
17166: str_tb([ltotex(RS1|opt="GRS",pre=Pre),"\\\\\n"],PW);
17167: R=fctrtos(QQ[0]|TeX=3,var=[dx,"\\partial"]);
17168: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
17169: str_tb(["Q_1&=",R,"\\\\\n"],PW);
17170: R=fctrtos(QQ[2]|TeX=3,var=[dx,"\\partial"]);
17171: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
17172: str_tb(["Q_2&=",R,"\\\\\n"],PW);
17173: str_tb(["Q_2Q_1&\\equiv ",fctrtos(QQ[1]|TeX=3),"\\mod W(x)P"],PW);
17174: if(F==1)
17175: str_tb(["\\\\\nP&=",fctrtos(P|TeX=3,var=[dx,"\\partial"])],PW);
17176: dviout(str_tb(0,PW)|eq=0,title="Shift Operator");
17177: }
17178: if(F==1) return [QQ,P,RS,P1,RS1];
17179: else if(F==0) return QQ;
17180: return [QQ,P,RS];
17181: }
17182:
17183: def conf1sp(M)
17184: {
17185: if(type(M)==7) M=s2sp(M);
17186: L0 = length(M);
17187: L1 = length(M[L0-1]);
17188: X2 = getopt(x2);
17189: Conf= getopt(conf);
17190: if(Conf != 0)
17191: Conf = -1;
17192: if((X2==1 || X2==-1) && Conf != 0){
17193: X1 = 0;
17194: X = x_1;
17195: }else{
17196: X1 = 1;
17197: X = x_2;
17198: }
17199: G = sp2grs(M,a,[L0,L1]);
17200: for(I = 0; I < L0-1; I++){
17201: V = makev([a,I-Conf,0]);
17202: G = subst(G,V,0);
17203: }
17204: L2 = length(M[1]);
17205: for(I=J=S0=S1=0; I < L2; I++){
17206: S1 += G[1][I][0];
17207: while(S0 < S1){
17208: S0 += G[0][J][0];
17209: if((V=G[0][J][1]) != 0)
17210: G = mysubst(G,[V,V-G[1][I][1]]);
17211: J++;
17212: }
17213: if(S0 > S1){
17214: print("Error in data!");
17215: return 0;
17216: }
17217: }
17218: if(Conf==0){
17219: for(L=[], I=L0-2; I>=0; I--)
17220: L=cons(I,L);
17221: L=cons(L0-1,L);
17222: P = getbygrs(G,["operator","x2"]|perm=L);
17223: }else if(X1)
17224: P = getbygrs(mperm(G,[[1,2]],[]), ["operator","x2"]);
17225: else
17226: P = getbygrs(G,["operator","x1"]);
17227: if(Conf==0)
17228: P=nm(mysubst(P,[X,c]));
17229: else{
17230: P = nm(mysubst(P,[X,1/c]));
17231: if(X2==-1){
17232: for(I=2; I<L0; I++){
17233: V=makev(["x_",I]); VC=makev([c,I]);
17234: P = nm(mysubst(P,[V,1/VC]));
17235: }
17236: }
17237: }
17238: for(I = 1; I < L2; I++){
17239: X = G[1][I][1];
17240: P = nm(mysubst(P,[X,X/c]));
17241: }
17242: VS = vars(P);
17243: while(VS!=[]){
17244: V = car(VS);
17245: if(str_chr(rtostr(V),0,"r")==0){
17246: CV = mycoef(P,1,V);
17247: D = mymindeg(CV,c);
17248: if(D > 0) P = mysubst(P,[V,V/c^D]);
17249: CV = mycoef(P,1,V);
17250: DD = mydeg(CV,dx);
17251: CVV = mycoef(CV,DD,dx);
17252: CD1 = mydeg(CVV,x);
17253: CD = (X==x1)?0:CD1;
17254: while(CD>=0 && CD<=CD1){
17255: CC = mycoef(CVV,CD,x);
17256: if(type(CC)==1){
17257: VT = mycoef(mycoef(mycoef(P,DD,dx),CD,x),0,V)/CC;
17258: if(VT != 0) P = mysubst(P,[V,V-VT]);
17259: break;
17260: }
17261: if(X==x1) CD++;
17262: else CD--;
17263: }
17264: while(subst(P,c,0,V,0) == 0)
17265: P = red(mysubst(P,[V,c*V])/c);
17266: }
17267: VS =cdr(VS);
17268: }
17269: return P;
17270: }
17271:
1.36 takayama 17272: def partspt(S,T)
17273: {
1.40 ! takayama 17274: if(length(S)>length(T)) return [];
1.38 takayama 17275: if(type(Op=getopt(opt))!=1) Op=0;
1.40 ! takayama 17276: else{
! 17277: VS=ltov(S);
! 17278: L=length(S)-1;
! 17279: VT=ltov(qsort(T));
! 17280: }
1.38 takayama 17281: if(length(S)==length(T)){
1.40 ! takayama 17282: if(S==T||qsort(S)==qsort(T)) R=S;
1.38 takayama 17283: else return [];
1.40 ! takayama 17284: }else if(getopt(sort)==1){
! 17285: S0=S1=[];
! 17286: for(;S!=[]&&car(S)==car(T);S=cdr(S),T=cdr(T))
! 17287: S0=cons(car(S),S0);
! 17288: if(S!=[]&&car(S)<car(T)) return [];
! 17289: S0=reverse(S0);
! 17290: for(S=reverse(S),T=reverse(T);S!=[],car(S)==car(T);S=cdr(S),T=cdr(T))
! 17291: S1=cons(car(S),S1);
! 17292: if(car(S)!=[]&&car(S)<cat(T)) return [];
! 17293: R=partspt(reverse(S),reverse(T));
! 17294: if(S1!=[]){
! 17295: for(R0=[];R!=[];R=cdr(R))
! 17296: R0=cons(append(car(R),S1),R0);
! 17297: R=reverse(R0);
! 17298: }
! 17299: if(S0!=[]){
! 17300: for(R0=[];R!=[];R=cdr(R))
! 17301: R0=cons(append(S0,car(R)),R0);
! 17302: R=reverse(R0);
! 17303: }
1.38 takayama 17304: }else{
17305: for(R=[];;){
17306: for(I=J=P=0;I<L;I++){
17307: P=VS[I];
17308: X=100000;
17309: while((P-=(Y=VT[J++]))>0){
17310: if(X<Y) break;
17311: X=Y;
17312: }
17313: if(X<Y||P<0) break;
17314: }
17315: if(!P&&X>=Y) R=cons(vtol(VT),R);
17316: if(!vnext(VT)) break;
17317: }
1.36 takayama 17318: }
1.38 takayama 17319: if(Op){
17320: for(W=[];R!=[];R=cdr(R)){
17321: for(I=0,S=VS[0],K=U=[],TR=car(R);TR!=[];TR=cdr(TR)){
17322: K=cons(car(TR),K);
17323: if(!(S-=car(K))){
17324: U=cons([VS[I],reverse(K)],U);
17325: K=[];
17326: S=VS[++I];
17327: if(I==L){
17328: U=cons([S,cdr(TR)],U);
17329: break;
17330: }
17331: }
1.36 takayama 17332: }
1.38 takayama 17333: W=cons(reverse(U),W);
17334: }
17335: R=W;
17336: if(iand(Op,1)){
1.40 ! takayama 17337: for(R=[];W!=[];W=cdr(W))
1.38 takayama 17338: R=cons(reverse(qsort(car(W))),R);
17339: R=lsort(R,[],1);
17340: }
17341: if(Op==3){
17342: for(W=[];R!=[];R=cdr(R)){
17343: for(S=[],TR=car(R);TR!=[];TR=cdr(TR))
17344: S=append(S,car(TR)[1]);
17345: W=cons(S,W);
1.36 takayama 17346: }
1.38 takayama 17347: R=reverse(W);
1.36 takayama 17348: }
17349: }
1.38 takayama 17350: return R;
1.36 takayama 17351: }
17352:
1.38 takayama 17353: #if 0
1.36 takayama 17354: def confspt(S,T)
17355: {
17356: R=[];
17357: LS=length(S);LT=length(T);
17358: if(LS<LT) return R;
17359: if(LS==LT){
17360: return(S==T)? return [[S,T]]:R;
17361: }
17362: R=[];
17363: for(ST=S,S0=T0=[],TT=T;ST!=[];ST=cdr(ST),TT=cdr(TT)){
17364: if(car(ST)>car(TT)) return R;
17365: if(car(ST)==car(TT){
17366: S0=cons(car(ST));T0=cons(car(TT));
17367: LS--;LT--;continue;
17368: }
17369: V=car(TT);D=LS-LT;
17370: for(P=[ST],DD=D;DD>0;){
17371: VD=V-car(car(ST));
17372: }
17373: }
17374: }
17375: #endif
17376:
17377:
1.34 takayama 17378: def confexp(S)
17379: {
1.35 takayama 17380: if(type(S[0])==4){
17381: for(E=[];S!=[];S=cdr(S))
17382: E=cons(confexp(car(S),E));
17383: return reverse(E);
17384: }
1.34 takayama 17385: V=x;E=[];
17386: for(P=0,Q=[],ST=S;ST!=[];ST=cdr(ST)){
17387: Q=cons(car(ST)[0],Q);
17388: P+=car(ST)[1]/(V-car(ST)[0]);
17389: P=red(P);
17390: }
17391: P=red(P*polbyroot(Q,V));
17392: Q=cdr(reverse(Q));
17393: for(I=(length(W=Q));I>=0;I--){
17394: C=mycoef(P,I,V);
17395: P-=C*polbyroot(W,V);
17396: W=cdr(W);
17397: E=cons(red(C),E);
17398: }
17399: return reverse(E);
17400: }
17401:
1.6 takayama 17402: def pgen(L,VV)
17403: {
17404: if(type(L[0])<4) L=[L];
17405: if(type(L)==4) L=ltov(L);
17406: K=length(L);
17407: V=newvect(K);
17408: if(type(Sum=getopt(sum))!=1) Sum=0;
17409: if((Num=getopt(num))!=1) Num=0;
17410: if((Sep=getopt(sep))!=1) Sep=0;
17411: if(type(Shift=getopt(shift))!=1) Shift=0;
17412: for(;;){
17413: for(PP=1,R=[],II=K-1; II>=0; II--){
17414: R=cons(V[II]+Shift,R);
17415: if(II>0 && Sep==1) R=cons("_",R);
17416: PP*=L[II][0]^V[II];
17417: }
17418: P+=makev(cons(VV,R)|num=Num)*PP;
17419: for(I=0;I<K;){
17420: if(++V[I]<=L[I][1]){
17421: if(Sum>0){
17422: for(S=II=0;II<K;) S+=V[II++];
17423: if(S>Sum){
17424: V[I++]=0;
17425: continue;
17426: }
17427: }
17428: }else{
17429: V[I++]=0;
17430: continue;
17431: }
17432: break;
17433: }
17434: if(I>=K) return P;
17435: }
17436: }
17437:
17438: def diagm(M,A)
17439: {
17440: return mgen(M,0,A,1);
17441: }
17442:
17443: def mgen(M,N,A,S)
17444: {
17445: if(M==0 && N==0){
17446: mycat([
17447: "mgen(m,n,a,s|sep=1) : generate a matrix of size m x n\n",
17448: " n : a number or \"diagonal\", \"highdiag\", \"lowdiag\",\"skew\",\"symmetric\",\"perm\" = 0,-1,-2,..\n",
17449: " a : a symbol or list (ex. a, [a], [a,b,c], [1,2,3])\n",
17450: " s : 0 or 1 (shift of suffix)\n"
17451: ]);
17452: return 0;
17453: }
17454: if(type(N)==7) N=-findin(N,["diag","highdiag","lowdiag","skew","symmetric","perm"]);
17455: Sep=(getopt(sep)==1)?1:0;
17456: if(S < 0 || S > 2)
17457: S = 0;
17458: if(M+S > 30 || N+S > 30){
17459: erno(1);
17460: return;
17461: }
17462: if(N==-5){
17463: NM=newmat(M,M);
17464: for(I=0;I<M;I++,A=cdr(A)) NM[I][car(A)-S]=1;
17465: return NM;
17466: }
17467: if(type(A) == 4)
17468: L = length(A)-1;
17469: else
17470: L = -1;
17471: if(N <= 0 && N >= -2){
17472: MM = newmat(M,M);
17473: J = K = 0;
17474: if(N == -1){
17475: K = 1; M--;
17476: }else if(N == -2){
17477: J = 1; M--;
17478: }
17479: for(I = 0; I < M; I++){
17480: if(L >= 0)
17481: MM[I+J][I+K] = A[(I > L)?L:I];
17482: else if(type(A)==7 || isvar(A))
17483: MM[I+J][I+K] = makev([A,S+I]|sep=Sep);
17484: else
17485: MM[I+J][I+K] = A;
17486: }
17487: return MM;
17488: }
17489: K = N;
17490: if(K < 0) N = M;
17491: MM = newmat(M,N);
17492: for(I = 0; I < M; I++){
17493: if(L >= 0)
17494: AA = rtostr(A[(I > L)?L:I]);
17495: else
17496: AA = rtostr(A)+rtostr(I+S);
17497: if(AA>="0" && AA<=":"){
17498: erno(0); return;
17499: }
17500: for(J = 0; J < N; J++){
17501: if(K < 0){
17502: if(I > J) continue;
17503: if(K == -3 && I == J) continue;
17504: }
17505: MM[I][J] = makev([AA,J+S]|sep=Sep);
17506: }
17507: }
17508: if(K < 0){
17509: for(I = 0; I < M; I++){
17510: for(J = 0; J < I; J++)
17511: MM[I][J] = (K == -4)?MM[J][I]:-MM[J][I];
17512: }
17513: }
17514: return MM;
17515: }
17516:
17517: def newbmat(M,N,R)
17518: {
17519: S = newvect(M);
17520: T = newvect(N);
17521: IM = length(R);
17522: for(I = 0; I < IM; I++){
17523: RI = R[I];
17524: JM = length(RI);
17525: for(J = 0; J < JM; J++){
17526: RIJ = RI[J];
17527: if(type(RIJ) == 6){
17528: S[I] = size(RIJ)[0];
17529: T[J] = size(RIJ)[1];
17530: }
17531: }
17532: }
17533: for(I = K = 0; I < M; I++){
17534: if(S[I] == 0)
17535: S[I] = 1;
17536: K += S[I];
17537: }
17538: for(J = L = 0; J < N; J++){
17539: if(T[J] == 0)
17540: T[J] = 1;
17541: L += T[J];
17542: }
17543: M = newmat(K,L);
17544: if(type(Null=getopt(null))>0){
17545: for(I=0;I<K;I++){
17546: for(J=0;J<L;J++) M[I][J]=Null;
17547: }
17548: }
17549: for(I0 = II = 0; II < IM; I0 += S[II++]){
17550: RI = R[II];
17551: JM = length(RI);
17552: for(J0 = JJ = 0; JJ < JM; J0 += T[JJ++]){
17553: if((RIJ = RI[JJ]) == 0)
17554: continue;
17555: Type = type(RIJ);
17556: for(I = 0; I < S[II]; I++){
17557: for(J = 0; J < T[JJ]; J++){
17558: if(Type == 6)
17559: M[I0+I][J0+J] = RIJ[I][J];
17560: else if(Type == 4 || Type == 5)
17561: M[I0+I][J0+J] = (I>0)?RIJ[I]:RIJ[J];
17562: else
17563: M[I0+I][J0+J] = RIJ;
17564: }
17565: }
17566: }
17567: }
17568: return M;
17569: }
17570:
17571: def unim(S)
17572: {
17573: if(!Rand++) random(currenttime());
17574: if(!isint(Wt=getopt(wt))||Wt<0||Wt>10) Wt=2;
17575: if(!isint(Xa=getopt(abs)) || Xa<1)
17576: Xa=9;
17577: if((Xaa=Xa)>10) Xaa=10;
17578: if(Xaa%2) Xaa++;
17579: Xh=Xaa/2;
17580: if(type(S0=SS=S)==4){
17581: Int=(getopt(int)==1)?1:0;
17582: U=[1,1,1,1,1,1,1,1,1,1,1,1,2,2,3,4];
17583: M=newmat(S[0],S[1]);
17584: SS=cdr(S);SS=cdr(SS);
17585: if(Rk=length(SS)) L=SS;
17586: else{
17587: L=[0];
17588: I=(S[0]>S[1])?S[1]:S[0];
17589: if(I<=2) return 0;
17590: if(!isint(Rk=getopt(rank))||Rk<1||Rk>S[0]||Rk>S[1])
17591: Rk=random()%(I-1)+2;
17592: for(I=1;I<Rk;){
17593: P=random()%(S[1]+Wt)-Wt;
17594: if(P<=0) P=1;
17595: if(findin(P,L)!=0){
17596: L=cons(P,L);
17597: I++;
17598: }
17599: }
17600: }
17601: L=ltov(qsort(L));
17602: M[0][L[0]]=1;
17603: for(I=1;I<Rk;I++){
17604: P=Int?1:U[random()%length(U)];
17605: if(P>Xa) P=Xa;
17606: M[I][L[I]]=(random()%2)?P:(-P);
17607: }
17608: for(I=0;I<Rk;I++){
17609: if(I!=0&&abs(M[I][L[I]])>1) M[K=random()%I][KK=L[I]]=1;
17610: I0=(I==0)?1:L[I]+1;
17611: I1=(I==Rk-1)?S[1]:L[I+1];
17612: for(J=I0;J<I1;J++){
17613: for(K=1;K<=Xa;K++){
17614: P=random()%(I+1);
17615: if((random()%2)==1) M[P][J]++;
17616: else M[P][J]--;
17617: }
17618: }
17619: }
17620: S=M;
17621: Res=(getopt(res)==1)?dupmat(S):0;
17622: }
17623: Conj=0;
17624: if(type(S)<2){
17625: if(S<2||S>20) return 0;
17626: if(getopt(conj)==1){
17627: M=S+Wt;
17628: if(M>15) M=10;
17629: M0=floor((M-1)/2);
17630: for(R=[],I=0;I<S;I++) R=cons(random()%M-M0,R);
17631: R=qsort(R);
17632: M=diagm(S,R);
17633: if(getopt(diag)!=1){
17634: for(I=1;I<S;I++)
17635: if(M[I-1][I-1]==M[I][I] && random()%2) M[I-1][I]=1;
17636: }
17637: if(M[0][0]==M[S-1][S-1]){
17638: for(I=1;I<S;I++) if(M[I-1][I]==1) break;
17639: if(I==S){
17640: if(M[0][0]>0) M[0][0]--;
17641: else M[S-1][S-1]++;
17642: }
17643: }
17644: if(getopt(res)==1) RR=diagm(S,[1]);
17645: S1=S;
17646: Res=dupmat(S=M);
17647: if(isint(I=getopt(int))&&I>1&&random()%I==0){
17648: K=S[0][0];L=K+1;
17649: for(I=1;I<S1;I++){
17650: if(S[I][I]>L && S[I-1][I]==0 && (I==S1-1||S[I][I+1]==0)){
17651: L=S[I][I];
17652: if(RR){
17653: RR[I][I]=L-K;RR[0][I]=1;
17654: }
17655: S[0][I]=1;
17656: if(!(random()%3)) break;
17657: }
17658: }
17659: if(random()%3==0){
17660: for(I=0;I<S1-1;I++){
17661: if(iand(S[I][I],1)&&S[I][I+1]==1){
17662: for(J=I+2;J<S1&&S[I][J]==0;J++);
17663: if(J<S1) continue;
17664: for(J=I-1;J>=0&&S[J][I]==0;J--);
17665: if(J>=0) continue;
17666: S[I][I+1]=2;
17667: for(J=0;J<S1;J++) RR[I][J]*=2;
17668: break;
17669: }
17670: }
17671: }
17672: }
17673: }else{
17674: M=diagm(S,[1]);
17675: S1=S;
17676: }
17677: }
17678: if(type(S)==6){
17679: M=dupmat(S);
17680: S=size(S);
17681: S1=S[1];S=S[0];
17682: Nt=1;
17683: if(getopt(conj)==1&&S==S1) Conj=1;
17684: }
17685: if(!isint(Ct=getopt(time)))
17686: Ct=(S>3||S1>3)?100:200;
17687: if(getopt(both)==1){
17688: OL=delopt(getopt(),"both");
17689: M=unim(mtranspose(M)|option_list=OL);
17690: M=mtranspose(M);
17691: }
17692: Mx=20;
17693: for(I=K=LL=0;I<Ct+Mx;I++){
17694: P=random()%S;Q=random()%S;
17695: if(3*K>Ct) T=random()%Xaa-Xh;
17696: else if(5*K<Ct) T=random()%2-1;
17697: else T=random()%4-2;
17698: if(T>=0) T++;
17699: if(P==Q) continue;
17700: for(G=0,J=S1-1;J>=0;J--){
17701: if((H=abs(M[Q][J]+M[P][J]*T))>Xa&&(!Conj||J!=P)) break;
17702: if(K<Mx&&!Conj) G=igcd(G,H);
17703: }
17704: if(K<Mx && G>1) J=1;
17705: if(J>0) continue;
17706: if(J<0&&Conj==1){
17707: for(J=S1-1;J>=0;J--)
17708: if(J!=Q&&abs(M[J][P]-M[J][Q]*T)>Xa) break;
17709: if(J<0&&abs(M[Q][P]-M[Q][Q]*T+M[P][P]*T-M[P][Q]*T^2)>Xa) J=1;
17710: if(J<0&&M[P][P]==M[Q][Q]){
17711: LF=0;
17712: for(L=S1-1;J>=0;J--) if(L!=Q&&M[J][Q]!=0) LF++;
17713: for(L=S1-1;J>=0;J--) if(L!=P&&M[P][J]!=0) LF++;
17714: if(!LF) J=1;
17715: }
17716: }
17717: if(J<0){
17718: for(J=S1-1;J>=0;J--)
17719: M[Q][J]+=M[P][J]*T;
17720: if(Conj==1)
17721: for(J=S1-1;J>=0;J--) M[J][P]-=M[J][Q]*T;
17722: if(RR) for(J=S1-1;J>=0;J--) RR[Q][J]+=RR[P][J]*T;
17723: K++;
17724: }
17725: if(K%5==0){
17726: if(!Nt) M=mtranspose(M);
17727: else if(!Conj&&K%2==0){
17728: for(F=0;F<S;F++){
17729: if((V=lgcd(M[F]))>1){
17730: for(L=0;L<S1;L++) M[F][L]/=V;
17731: }
17732: }
17733: }
17734: }
17735: if(I>Ct){
17736: for(L=S-1;L>=0;L--){
17737: for(F=0,J=S1-1;J>=0;J--)
17738: if(M[L][J]!=0) F++;
17739: if(F<2){
17740: F=-1;break;
17741: }
17742: else F=0;
17743: }
17744: if(F<0 && LL++<5){
17745: I=(CT-CT%2)/2;K=1;
17746: }
17747: if(I>Ct) break;
17748: }
17749: }
17750: if(RR){
17751: for(I=F=0;I<S1;I++){
17752: V=Res[I][I];
17753: for(J=I+1;J<S1;J++){
17754: if(Res[J][J]!=V) break;
17755: for(LP=0;LP<2;LP++){
17756: if(J==S1-1||Res[J][J+1]==0){
17757: if(I==0||Res[I-1][I]==0){
17758: for(VL=VS=[],K=0;K<S1;K++){
17759: VL=cons(RR[K][J],VL);VS=cons(RR[K][I],VS);
17760: }
17761: VR=ldev(VL,VS);
17762: if(VR[0]){
17763: for(K=S1-1,VN=VR[1];K>=0;K--,VN=cdr(VN))
17764: RR[K][J]=car(VN);
17765: F=1;
17766: }
17767: }
17768: }
17769: K=I;I=J;J=K;
17770: }
17771: }
17772: if(F&&I==S1-1){
17773: F=0;I=-1;
17774: }
17775: }
17776: if(getopt(int)==1){
17777: N=mtranspose(M);
17778: for(F=I=0;I<S1;I++) if(lgcd(M[I])>1||lgcd(N[I])>1) F++;
17779: if(F){
17780: for(F=I=0;I<S1;I++){
17781: if(Res[I][I]==-1) F=ior(F,1);
17782: else if(Res[I][I]==1) F=ior(F,2);
17783: }
17784: C=0;
17785: if(!iand(F,1)) C=1;
17786: else if(!iand(F,2)) C=-1;
17787: if(C){
17788: for(I=0;I<S1;I++){
17789: M[I][I]+=C;Res[I][I]+=C;
17790: }
17791: }
17792: }
17793: }
17794: if(getopt(rep)!=1){
17795: for(Lp=0;Lp<5;Lp++){
17796: F=(M==Res||abs(lmax(RR))>Xa*10||abs(lmin(RR))>Xa*10)?1:0;
17797: for(I=0;!F&&I<S1&&Lp<4;I++){
17798: for(K=L=J=0;J<S1;J++){
17799: if(M[I][J]) K++;
17800: if(M[J][I]) L++;
17801: }
17802: if(K<2||L<2) F=1;
17803: }
17804: if(!F) break;
17805: R=unim(S0|option_list=cons(["rep",1],getopt()));
17806: M=R[0];Res=R[1];RR=R[3];
17807: }
17808: }
17809: }
17810: if(Res==0) return M;
17811: if(RR){
17812: for(I=K=V=0;I<S1;I++){
17813: for(J=0;J<S1;J++){
17814: if(RR[J][I]>0) V++;
17815: else if(RR[J][I]<0) V--;
17816: }
17817: if(I<S1-1&&Res[I][I+1]!=0) continue;
17818: if(V<0){
17819: for(;K<=I;K++) RR=colm(RR,K,-1);
17820: }
17821: K=I+1;V=0;
17822: }
17823: }
17824: if(getopt(rep)!=1){
17825: if((F=getopt(dviout))==1){
17826: if(getopt(conj)==1){
17827: if(RR) show([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
17828: }else{
17829: if(type(Lim=getopt(lim))==1)
17830: mtoupper(M,0|step=1,opt=7,dviout=1,pages=1,lim=Lim);
17831: else mtoupper(M,0|step=1,opt=7,dviout=1,pages=1);
17832: }
17833: }else if(F==-1){
17834: if(getopt(conj)==1){
17835: if(RR) return ltotex([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
17836: }else{
17837: if(type(Lim=getopt(lim))==1)
17838: return mtoupper(M,0|step=1,opt=7,pages=1,lim=Lim,dviout=-1);
17839: else return mtoupper(M,0|step=1,opt=7,pages=1,dviout=-1);
17840: }
17841: }
17842: }
17843: if(RR==0) return[M,Res];
17844: return [M,Res,myinv(RR),RR];
17845: }
17846:
17847: def pfrac(F,X)
17848: {
17849: F = red(F);
17850: FN = nm(F);
17851: FD = dn(F);
17852: if(mydeg(FD,X) == 0)
17853: return [[F,1,1]];
17854: R = rpdiv(FN,FD,X);
17855: FN = R[0]/R[1];
17856: R0 = R[2]/R[1];
17857: FC = fctr(FD);
17858: RT=[];
17859: if(getopt(root)==2){
17860: for(FE=[],FT=FC;FT!=[];FT=cdr(FT)){
17861: if(mydeg(P=car(FT)[0],X)==4 && vars(P)==[X] && pari(issquare,C=mycoef(P,4,X))){
17862: if((S=mycoef(P,3,X)/4/C)!=0) P=subst(P,X,X-S);
17863: if(mycoef(P,1,X)==0 && pari(issquare,C0=mycoef(P,0,X))){
17864: C=sqrtrat(C);C0=sqrtrat(C0);C1=2*C*C0-mycoef(P,2,X);
17865: if(C1>0){
17866: FE=cons([C*(X+S)^2-C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
17867: FE=cons([C*(X+S)^2+C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
17868: RT=cons(C1,RT);
17869: continue;
17870: }
17871: }
17872: }
17873: FE=cons(car(FT),FE);
17874: }
17875: FC=reverse(FE);
17876: }
17877: N = Q = 0;
17878: L = [];
17879: for(I = length(FC)-1; I >= 0; I--){
17880: if((D = mydeg(FC[I][0],X)) == 0) continue;
17881: for(K=1; K<=FC[I][1]; K++){
17882: for(J=P=0; J < D; J++){
17883: V = makev(["zz_",++N]);
17884: P = P*X + V;
17885: L = cons(V,L);
17886: }
17887: Q += P/(FC[I][0]^K);
17888: Q = red(Q);
17889: }
17890: }
17891: L=reverse(L);
17892: Q = nm(red(red(Q*FD)-FN));
17893: Q = ptol(Q,X);
17894: S = lsol(Q,L);
17895: R = (R0==0)?[]:[[R0,1,1]];
17896: for(N=0,I=length(FC)-1; I >= 0; I--){
17897: if((D = mydeg(FC[I][0],X)) == 0) continue;
17898: for(K=1; K<=FC[I][1]; K++){
17899: for(P=J=0; J < D; N++,J++)
17900: P = P*X + S[N][1];
17901: if(P!=0) R = cons([P,FC[I][0],K],R);
17902: }
17903: }
17904: for(;RT!=[];RT=cdr(RT)){
17905: RTT=car(RT);
17906: R=mtransbys(os_md.substblock,R,[RTT^(1/2),(RTT^(1/2))^2,RTT]);
17907: }
17908: TeX=getopt(TeX);
17909: if((Dvi=getopt(dviout))==1||TeX==1){
17910: V=strtov("0");
17911: for(S=L=0,RR=R;RR!=[];RR=cdr(RR),L++){
17912: RT=car(RR);
17913: S+=(RT[0]/RT[1]^RT[2])*V^L;
17914: }
17915: if(TeX!=1) fctrtos(S|var=[V,""],dviout=1);
17916: else return fctrtos(S|var=[V,""],TeX=3);
17917: }
17918: return reverse(R);
17919: }
17920:
17921: def cfrac(X,N)
17922: {
17923: F=[floor(X)];
17924: if(N<0){
17925: Max=N=-N;
17926: }
17927: X-=F[0];
17928: if(Max!=1)
17929: M=mat([F[0],1],[1,0]);
17930: for(;N>0 && X!=0;N--){
17931: X=1/X;
17932: F=cons(Y=floor(X),F);
17933: X-=Y;
17934: if(Max){
17935: M0=M[0][0];M1=M[1][0];
17936: M=M*mat([Y,1],[1,0]);
17937: if(M[0][0]>Max) return M0/M1;
17938: }
17939: }
17940: return (Max==0)?reverse(F):M[0][0]/M[1][0];
17941: }
17942:
17943: def sqrt2rat(X)
17944: {
17945: if(type(X)>3) return X;
17946: X=red(X);
17947: if(getopt(mult)==1){
17948: for(V=vars(X);V!=[];V=cdr(V)){
17949: T=funargs(F=car(V));
17950: if(type(T)==4&&length(T)>1){
17951: Y=T[1];
17952: Z=sqrt2rat(Y);
17953: if(Y!=Z){
17954: if(length(T)==2){
17955: T0=T[0];
17956: X=subst(X,F,T0(Z));
17957: }else if(T[0]==pow)
17958: X=subst(X,F,Y^T[2]);
17959: }
17960: }
17961: }
17962: }
17963: for(V=vars(X);V!=[];V=cdr(V)){ /* r(x)^(1/2+n) -> r(x)^n*r(x)^(1/2) */
17964: T=args(Y=car(V));
17965: if(functor(Y)==pow&&T[1]!=1/2&&isint(T2=2*T[1])){
17966: if(iand(T2,1)){
17967: R=(T[0])^(1/2);T2--;
17968: }else R=1;
17969: R*=T[0]^(T2/2);
17970: X=red(subst(X,Y,R));
17971: }
17972: }
17973: D=dn(X);N=nm(X);
17974: if(imag(D)!=0){
17975: N*=conj(D);
17976: D*=conj(D);
17977: return sqrt2rat(N/D);
17978: }
17979: for(V=vars(N);V!=[];V=cdr(V)){ /* (r(x)^(n/m))^k */
17980: T=args(Y=car(V));
17981: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
17982: Dn=dn(T[1]);Nm=nm(T[1]);
17983: N=substblock(N,Y,Y^Dn,T[0]^Nm);
17984: }
17985: }
17986: for(V=vars(D);V!=[];V=cdr(V)){
17987: T=args(Y=car(V));
17988: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
17989: Dn=dn(T[1]);Nm=nm(T[1]);
17990: D=substblock(D,Y,Y^Dn,T[0]^Nm);
17991: }
17992: }
17993: for(V=vars(D);V!=[];V=cdr(V)){
17994: T=args(Y=car(V));
17995: if(functor(Y)==pow&&T[1]==1/2&&mydeg(D,Y)==1){
17996: N*=mycoef(D,0,Y)-mycoef(D,1,Y)*Y;
17997: N=mycoef(N,0,Y)+mycoef(N,1,Y)*Y+mycoef(N,2,Y)*T[0];
17998: D=mycoef(D,0,Y)^2-mycoef(D,1,Y)^2*T[0];
17999: X=red(N/D);
18000: D=dn(X);N=nm(X);
18001: break;
18002: }
18003: }
18004: X=red(N/D);
18005: D=dn(X);N=nm(X);
18006: for(V=vars(D);V!=[];V=cdr(V)){
18007: T=args(Y=car(V));
18008: if(functor(Y)==pow&&T[1]==1/2)
18009: D=substblock(D,T[0]^T[1],(T[0]^T[1])^2,T[0]);
18010: }
18011: for(V=vars(N);V!=[];V=cdr(V)){
18012: T=args(Y=car(V));
18013: if(functor(Y)==pow&&T[1]==1/2)
18014: N=substblock(N,T[0]^T[1],(T[0]^T[1])^2,T[0]);
18015: }
18016: for(V=vars(N);V!=[];V=cdr(V)){
18017: T=args(Y=car(V));
18018: if(functor(Y)==pow&&T[1]==1/2){
18019: Ag=T[0];
18020: R=S=1;
18021: An=fctr(nm(Ag));
18022: CA=An[0][0];
18023: if(CA<0){
18024: CA=-CA;R=-1;
18025: }
18026: if(type(I=sqrtrat(CA))<2) S=I;
18027: else R*=CA;
18028: for(An=cdr(An);An!=[];An=cdr(An)){
18029: Pw=car(An)[1];I=iand(Pw,1);
18030: if(I) R*=car(An)[0];
18031: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
18032: }
18033: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
18034: Pw=car(An)[1];I=iand(Pw,1);
18035: if(I) R/=car(An)[0]^I;
18036: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
18037: }
18038: if(S!=1) N=subst(N,Y,R^(1/2)*S);
18039: }
18040: }
18041: for(V=vars(N);V!=[];V=cdr(V)){
18042: T=args(Y=car(V));
18043: if(functor(Y)==pow&&T[1]==1/2){
18044: C=mycoef(N,1,Y);
18045: for(VC=vars(C);VC!=[];VC=cdr(VC)){
18046: TC=args(YC=car(VC));
18047: if(functor(YC)==pow&&TC[1]==1/2){
18048: Ag=red(T[0]*TC[0]);
18049: R=S=1;
18050: An=fctr(nm(Ag));
18051: CA=An[0][0];
18052: if(CA<0){
18053: CA=-CA;R=-1;
18054: }
18055: if(type(I=sqrtrat(CA))<2) S=I;
18056: else R*=CA;
18057: for(An=cdr(An);An!=[];An=cdr(An)){
18058: Pw=car(An)[1];I=iand(Pw,1);
18059: if(I) R*=car(An)[0];
18060: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
18061: }
18062: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
18063: Pw=car(An)[1];I=iand(Pw,1);
18064: if(I) R/=car(An)[0]^I;
18065: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
18066: }
18067: CC=mycoef(C,1,YC);
18068: N=N-CC*YC*Y+CC*R^(1/2)*S;
18069: }
18070: }
18071: }
18072: }
18073: return red(N/D);
18074: }
18075:
18076: def cfrac2n(X)
18077: {
18078: if(type(L=getopt(loop))==1&&L>0)
18079: C=x;
18080: else{
18081: C=0;L=0;
18082: }
18083: if(L>1){
18084: for(Y=[];L>1;L--){
18085: Y=cons(car(X),Y);
18086: X=cdr(X);
18087: }
18088: if(X!=[]){
18089: P=cfrac2n(X|loop=1);
18090: for(V=P,Y=reverse(Y);Y!=[];Y=cdr(Y))
18091: V=sqrt2rat(car(Y)+1/V);
18092: return V;
18093: }else{
18094: C=0;X=reverse(Y);
18095: }
18096: }
18097: for(V=C,X=reverse(X);X!=[];X=cdr(X)){
18098: if(V!=0) V=1/V;
18099: V+=car(X);
18100: }
18101: if(C!=0){
18102: V=red(V);P=dn(V)*x-nm(V);
18103: S=getroot(P,x|cpx=2);
18104: T=map(eval,S);
18105: V=(T[0]>0)?S[0]:S[1];
18106: }
18107: return V;
18108: }
18109:
18110: def s2sp(S)
18111: {
18112: if(getopt(short)==1){
18113: if(type(F=getopt(std))==1) S=s2sp(S|std=F);
18114: if(type(S)!=7) S=s2sp(S);
18115: L=strtoascii(S);
18116: for(LS=[],F=C=0;L!=[];L=cdr(L)){
18117: if((G=car(L))!=F){
18118: LS=cons(G,LS);C=0;
18119: }else if(C<3){
18120: LS=cons(G,LS);
18121: }else if(C==3){
18122: LS=cdr(LS);LS=cdr(LS);
18123: LS=cons(94,LS);LS=cons(52,LS);
18124: }else if(C==9){
18125: LS=cdr(LS);LS=cons(97,LS);
18126: }else{
18127: K=car(LS);LS=cdr(LS);LS=cons(K+1,LS);
18128: }
18129: C++;F=G;
18130: }
18131: return asciitostr(reverse(LS));
18132: }
18133: if(type(F=getopt(std))==1){
18134: F=(F>0)?1:-1;
18135: if(type(S)==7) S=s2sp(S);
18136: for(L=[];S!=[];S=cdr(S))
18137: L=cons(os_md.msort(car(S),[-1,0]),L);
18138: return os_md.msort(L,[F,2]);
18139: }
18140: if(type(S)==7){
18141: S = strtoascii(S);
18142: if(type(S) == 5) S = vtol(S);
18143: for(N=0,R=TR=[]; S!=[]; S=cdr(S)){
18144: if(car(S)==45) /* - */
18145: N=1;
18146: else if(car(S)==47) /* / */
18147: N=2;
18148: if(N>0){
18149: while(car(S)<48&&car(S)!=40) S=cdr(S);
18150: }
18151: if((T=car(S))>=48 && T<=57) TR=cons(T-48,TR);
18152: else if(T>=97) TR=cons(T-87,TR);
18153: else if(T>=65 && T<=90) TR=cons(T-29,TR); /* A-Z */
18154: else if(T==44){
18155: R=cons(reverse(TR),R);
18156: TR=[];
18157: }else if(T==94){ /* ^ */
18158: S=cdr(S);
18159: if(car(S)==40){ /* ( */
18160: S=cdr(S);
18161: for(T=0; car(S)!=41 && S!=[]; S=cdr(S)){
18162: V=car(S)-48;
18163: if(V>=10) V-=39;
18164: T=10*T+V;
18165: }
18166: }else{
18167: while(car(S)<48) S=cdr(S);
18168: T=car(S)-48;
18169: if(T>=10) T-=39;
18170: }
18171: while(--T>=1) TR=cons(car(TR),TR);
18172: }else if(T==40){ /* ( */
18173: S=cdr(S);
18174: if(N==1){
18175: N=0; NN=1;
18176: }else NN=0;
18177: if(car(S)==45){ /* - */
18178: S=cdr(S);
18179: NN=1-NN;
18180: }
18181: for(I=0; I<2; I++){
18182: for(V=0; (SS=car(S))!=41 && SS!=47 && S!=[]; S=cdr(S)){
18183: T=SS-48;
18184: if(T>=10) T-=39;
18185: V=10*V+T;
18186: }
18187: if(NN==1){
18188: V=-V; NN=0;
18189: }
18190: TR=cons(V,TR);
18191: if(SS!=47) break;
18192: else{
18193: N=2; S=cdr(S);
18194: }
18195: }
18196: }else if(T==60){
18197: for(V=[],S=cdr(S);S!=[]&&car(S)!=62;S=cdr(S))
18198: V=cons(car(S),V);
18199: if(car(S)!=62) continue;
18200: TR=cons(eval_str(asciitostr(reverse(V))),TR);
18201: }else if(T<48) continue;
18202: if(N==1){
18203: T = car(TR);
18204: TR=cons(-T,cdr(TR));
18205: N=0;
18206: }else if(N==2){
18207: T=car(TR); TR=cdr(TR);
18208: TR=cons(car(TR)/T,cdr(TR));
18209: N=0;
18210: }
18211: }
18212: return reverse(cons(reverse(TR),R));
18213: }else if(type(S)==4){
18214: Num=getopt(num);
18215: for(R=[]; ; ){
18216: if(type(TS=car(S))!=4) return;
18217: for(; TS!=[]; TS=cdr(TS)){
18218: V=car(TS);
18219: if(type(V)>1||(type(V)==1&&ntype(V)>0)){
18220: V="<"+rtostr(V)+">";
18221: R=append(reverse(strtoascii(V)),R);
18222: continue;
18223: }
18224: if(dn(V)>1){
18225: P=reverse(strtoascii(rtostr(V)));
18226: R=append(P,cons(40,R));
18227: R=cons(41,R);
18228: continue;
18229: }
18230: if(V<0 && V>-10){
18231: V=-V;
18232: R=cons(45,R);
18233: }
18234: if(V<0 || V>35 || (V>9 && Num==1)){
18235: P=reverse(strtoascii(rtostr(V)));
18236: R=append(P,cons(40,R));
18237: V=41;
18238: }else if(V<10) V+=48;
18239: else V+=87;
18240: R=cons(V,R);
18241: }
18242: if((S=cdr(S))==[]) break;
18243: R=cons(44,R);
18244: }
18245: return asciitostr(reverse(R));
18246: }
18247: return 0;
18248: }
18249:
18250: def sp2grs(M,A,L)
18251: {
18252: MM = [];
18253: T0 = 0;
18254: Mat=getopt(mat);
18255: if(Mat!=1) Mat=0;
18256: if(type(M)==7) M=s2sp(M);
18257: if((LM = length(M)) > 10 && type(A) < 4)
18258: CK = 1;
18259: Sft = (type(L)==1)?L:0;
18260: if(type(L)==4 && length(L)>=3)
18261: Sft = L[2];
18262: if(Sft < 0){
18263: T0 = 1;
18264: Sft = -Sft-1;
18265: }
18266: for(I = LM-1; I >= 0; I--){
18267: MI = M[I]; MN = [];
18268: if(CK == 1 && length(MI) > 10){
18269: erno(1);
18270: return;
18271: }
18272: if(type(A) == 4)
18273: AA = rtostr(A[I]);
18274: else
18275: AA = rtostr(A)+rtostr(I);
18276: for(J = LM = length(MI)-1; J >= 0; J--){
18277: V = MI[J];
18278: if(type(V) > 3)
18279: V = V[0];
18280: if(T0 == 0 || I == 0)
18281: MN = cons([V, makev([AA,J+Sft])], MN);
18282: else{
18283: if(LM == 1)
18284: MN = cons([V, (J==0)?0:makev([AA])], MN);
18285: else if(I == 1 && Mat == 0)
18286: MN = cons([V, (J==length(MI)-1)?0:makev([AA,J+Sft])], MN);
18287: else
18288: MN = cons([V, (J==0)?0:makev([AA,J])], MN);
18289: }
18290: }
18291: MM = cons(MN, MM);
18292: }
18293: if(type(L) == 4 && length(L) >= 2){
18294: R = chkspt(MM|mat=Mat); /* R[3]: Fuchs */
18295: AA = var(MM[L[0]-1][L[1]-1][1]);
18296: if(AA==0) AA=var(R[3]);
18297: if(AA!=0 && (P = mycoef(R[3],1,AA))!=0){
18298: P = -mycoef(R[3], 0, AA)/P;
18299: MM = mysubst(MM,[AA,P]);
18300: }
18301: }
18302: return MM;
18303: }
18304:
18305: def intpoly(F,X)
18306: {
18307: if((T=ptype(F,X))<4){
18308: if(T<3){ /* polynomial */
18309: if(type(C=getopt(cos))>0){
18310: V=vars(F);
18311: Z=makenewv(V);
18312: W=makenewv(cons(Z,V));
18313: Q=intpoly(F,X|exp=Z);
18314: Q=(subst(Q,Z,@i*C)*(Z+@i*W)+subst(Q,Z,-@i*C)*(Z-@i*W))/2;
18315: return [mycoef(Q,1,Z),mycoef(Q,1,W)];
18316: }
18317: if(type(C=getopt(sin))>0){
18318: Q=intpoly(F,X|cos=C);
18319: return [-Q[1],Q[0]];
18320: }
18321: if(type(C=getopt(log))>0){
18322: Q=intpoly(F,X);
18323: if(C[0]==0) return [Q,0];
18324: if(length(C)<3) C=[C[0],C[1],1];
18325: Q-=subst(Q,X,-C[1]/C[0]);
18326: if(iscoef(Q,os_md.israt)) Q=red(Q);
18327: if(C[2]==0) return [Q];
18328: S=subst(-Q*C[0]*C[2],X,X-C[1]/C[0]);
18329: for(R=0,D=mydeg(S,X);D>0;D--) R+=mycoef(S,D,X)*X^(D-1);
18330: R=subst(R,X,X+C[1]/C[0]);
18331: return cons(Q,intpoly(R,X|log=[C[0],C[1],C[2]-1]));
18332: }
18333: if(type(C=getopt(exp))>0){
18334: D = mydeg(F,X);
18335: for(P=Q=F/C;D>=0;D--){
18336: Q=-mydiff(Q,X)/C;
18337: P+=Q;
18338: }
18339: return P;
18340: }
18341: for(P=0,I=mydeg(F,X);I >= 0;I--)
18342: P += mycoef(F,I,X)*X^(I+1)/(I+1);
18343: return P;
18344: }
18345: R=pfrac(F,X|root=2); /* rational */
18346: for(P=0;R!=[];R=cdr(R)){
18347: if(type(V=getopt(dumb))==5){
18348: for(PF=[],RR=R;RR!=[];RR=cdr(RR))
18349: PF=cons(RR[0][0]/RR[0][1]^RR[0][2],PF);
18350: PF=[cons(X,reverse(PF))];
18351: if(P) PF=cons([1,P],PF);
18352: V[0]=cons(PF,V[0]);
18353: }
18354: RT=car(R);
18355: if(mydeg(RT[1],X)==0) P+=intpoly(RT[0]*RT[2],X);
18356: else if((Deg=mydeg(RT[1],X))==1){
18357: if(RT[2]>1) P+=RT[0]*RT[1]^(1-RT[2])/(1-RT[2])/mycoef(RT[1],1,X);
18358: else P+=RT[0]*log(RT[1])/mycoef(RT[1],1,X);
18359: P=red(P);
18360: }else if(Deg==2){
18361: D1=diff(RT[1],X);C1=mycoef(D1,1,X);
18362: B=2*C1*mycoef(RT[1],0,X)-mycoef(RT[1],1,X)^2; /* ax^2+bx+c => B=4ac-b^2 */
18363: B=sqrt2rat(B);
18364: N=RT[0];
18365: for(I=RT[2];I>0&&N!=0;I--){
18366: C0=mycoef(N,1,X)/C1;N-=C0*D1;
18367: if(C0){
18368: if(I>1) P-=C0/RT[1]^(I-1)/(I-1);
18369: else P+=C0*log(RT[1]);
18370: }
18371: if(I>1){
18372: BB=B/C1;
18373: P+=N*X/RT[1]^(I-1)/(I-1)/BB;
18374: N*=(2*I-3)/(I-1)/BB;
18375: }else{
18376: if(type(BR=sqrtrat(B))>3){
18377: mycat(["Cannot obtain sqare root of ",B]);
18378: return [];
18379: }
18380: if(real(nm(BR))!=0){
18381: P+=(2*N/BR)*atan(sqrt2rat(D1/BR|mult=1));
18382: }else{
18383: BR*=@i;BRI=sqrt2rat(1/BR);
18384: R1=(-mycoef(RT[1],1,X)+BR)/C1;
18385: R2=(-mycoef(RT[1],1,X)-BR)/C1;
18386: P+=N*BRI*log( /* sqrt2rat */((x-R1)/(x-R2)));
18387: }
18388: }
18389: P=red(P);
18390: }
18391: P=sqrt2rat(P);
18392: }else{
18393: mycat(["Cannot get an indefinite integral of ",F]);
18394: return [];
18395: }
18396: }
18397: Q=simplog(P,X);
18398: if(type(V)==5&&nmono(P)!=nmono(Q)) V[0]=cons([[1,red(P)]],V[0]);
18399: return red(Q);
18400: }
18401: return [];
18402: }
18403:
18404: def fshorter(P,X)
18405: {
18406: Q=sqrt2rat(P);
18407: R=trig2exp(Q,X|inv=1);
18408: if(str_len(fctrtos(R))<str_len(fctrtos(Q))) Q=R;
18409: Var=pfargs(Q,X|level=1);
18410: for(C=F=0,R=1,V=Var;V!=[];V=cdr(V)){
18411: if(findin(car(V)[1],[cos,sin,tan])>=0){
18412: if(!C){
18413: F=car(V)[2];
18414: }else{
18415: R=red(car(V)[2]/F);
18416: if(type(R)!=1) break;
18417: F/=dn(R);
18418: }
18419: C++;
18420: }
18421: }
18422: if(getopt(period)==1) return F;
18423: if(!isint(Log=getopt(log))) Log=0;
18424: if(V==[]&&F!=0){
18425: if(iand(Log,1)){
18426: H=append(cdr(fctr(nm(Q))),cdr(fctr(dn(Q))));
18427: for(L=0;H!=[];H=cdr(H))
18428: L+=str_len(rtostr(car(H)[0]));
18429: }else L=str_len(fctrtos(Q));
18430: S=trig2exp(P,X);
18431: for(T=[sin(F),tan(F),cos(F),sin(F/2),cos(F/2),tan(F/2)];T!=[];T=cdr(T)){
18432: R=trig2exp(S,X|inv=car(T));
18433: if(iand(Log,1)){
18434: H=append(cdr(fctr(nm(R))),cdr(fctr(dn(R))));
18435: for(K=0;H!=[];H=cdr(H))
18436: K+=str_len(rtostr(car(H)[0]));
18437: }else K=str_len(fctrtos(R));
18438: if(K<L){
18439: Q=R;L=K;
18440: }
18441: }
18442: }
18443: return Q;
18444: }
18445:
18446: def isshortneg(P)
18447: {
18448: return(str_len(rtostr(P))>str_len(rtostr(-P)))?1:0;
18449: }
18450:
18451: def simplog(R,X)
18452: {
18453: for(V=[],Var=pfargs(R,X);Var!=[];Var=cdr(Var)){
18454: VT=car(Var);
18455: if(VT[1]==log && ptype(R,VT[0])==2 && mydeg(R,VT[0])==1)
18456: V=cons([VT[0],VT[2],mycoef(R,1,VT[0])],V);
18457: }
18458: for(;V!=[];V=cdr(V)){
18459: VT=car(V);
18460: for(V2=cdr(V);V2!=[];V2=cdr(V2)){
18461: Dn=1;
18462: if((C=red(car(V2)[2]/VT[2]))!=1&&C!=-1){
18463: if(getopt(mult)==1&&type(C)==1&&ntype(C)==0){
18464: Dn=dn(C);C*=Dn;
18465: }else continue;
18466: }
18467: Log=red(VT[1]^Dn*car(V2)[1]^(Dn*C));
18468: L=str_len(rtostr(dn(Log)))-str_len(rtostr(nm(Log)));
18469: if(L>0 || (L==0&&isshortneg(VT[2])) ){
18470: Dn=-Dn;Log=1/Log;
18471: }
18472: R=mycoef(R,0,VT[0]);R=mycoef(R,0,car(V2)[0]);
18473: return(R+VT[2]*log(Log)/Dn);
18474: }
18475: }
18476: return R;
18477: }
18478:
18479: def integrate(P,X)
18480: {
18481: Dvi=getopt(dviout);
18482: if(type(I=getopt(I))==4){
18483: if((R=integrate(P,X))==[]) II="?";
18484: else if(type(I[0])>3||type(I[1])>3){
18485: R=subst(R,X,x);
18486: V=flim(R,I[0]);VV=flim(R,I[1]);
18487: if(V==""||VV=="") II="?";
18488: else if(type(V)==7||type(VV)==7){
18489: if(V==VV) II="?";
18490: else II=(VV=="+"||V=="-")?"\\infty":"-\\infty";
18491: }else{
18492: II=VV-V;
18493: if(II>10^10) II="\\infty";
18494: else if(II<-10^10) II="-\\infty";
18495: }
18496: }else{
18497: V=subst(R,X,I[1])-subst(R,X,I[0]);
18498: VV=myval(V);
18499: II=(type(VV)>=2||ntype(VV)<1)?VV:evalred(V);
18500: }
18501: if(type(Dvi)!=1) return II;
18502: I=ltov(I);
18503: for(J=0;J<2;J++){
18504: if(type(I[J])>3){
18505: if(type(I[J])==4&&length(I[J])>1) I[J]=I[J][1];
18506: else I[J]=(J==0)?"-\\infty":"\\infty";
18507: }
18508: if(type(I[J])<4) I[J]=my_tex_form(I[J]);
18509: }
18510: S=(type(II)==7)?II:my_tex_form(II);
18511: S="\\int_{"+I[0]+"}^{"+I[1]+"}"+monototex(P)+"\\,d"+my_tex_form(X)+"&="+S;
18512: if(Dvi==1) dviout(texbegin("align",S));
18513: return S;
18514: }
18515: if(isint(Dvi)==1){
18516: if(Dvi==2||getopt(dumb)==-1){
18517: V=newvect(1);V[0]=[];
18518: }else V=0;
18519: if((RR=integrate(P,X|dumb=V))==[]) return R;
18520: S=fshorter(RR,X);
18521: VV=[X];
18522: if(V!=0){
18523: R=cons([[1,RR]],V[0]);
18524: if(S!=RR) R=cons([[1,RR=S]],R);
18525: for(V=FR=[];R!=[];R=cdr(R))
18526: if(car(R)!=FR) V=cons(FR=car(R),V);
1.21 takayama 18527: Var=varargs(V|all=2);
1.6 takayama 18528: for(S0=[x0,x1,x2,x3],S=[t,s,u,v,w];S0!=[]&&S!=[];){
18529: if(findin(car(S0),Var)<0){
18530: S0=cdr(S0); continue;
18531: }
18532: if(findin(car(S),Var)>=0){
18533: S=cdr(S); continue;
18534: }
18535: V=subst(V,[car(S0),car(S)]);S0=cdr(S0);S=cdr(S);
18536: }
18537: if(Dvi==-2) return V;
18538: S1="\\,dx&";
18539: }else{
18540: V=[[],[[1,RR=S]]];
18541: S1="\\,dx";
18542: }
18543: if(type(P)>2){
18544: if(type(nm(P))<2){
18545: P=P*dx;S1=V?"&":"";
18546: }
18547: S=fctrtos(P|TeX=2,lim=0);SV0=my_tex_form(P);
18548: if(str_len(SV0)<str_len(S)) S=SV0;
18549: }else S=monototex(P);
18550: if(Dvi!=-2) S="\\int "+S+S1;
18551: else S="";
18552: for(L=[],V=cdr(V);V!=[];V=cdr(V)){
18553: CL=car(V);S0=["="]; /* a line */
18554: for(FL=0;CL!=[];CL=cdr(CL),FL++){
18555: CT=car(CL); /* a term */
18556: if((Y=CT[0])==0){ /* a variable */
18557: CT=cdr(CT);
18558: if(length(CT)>2) CT=cdr(CT);
18559: S0=["\\qquad(",CT[0],"=",CT[1],")"];
18560: break;
18561: }else{
18562: for(FT=0,S2=[],CT=cdr(CT);CT!=[];CT=cdr(CT),FT++){
18563: SV=fctrtos(car(CT)|TeX=2,lim=0);SV0=my_tex_form(car(CT));
18564: if(str_len(SV0)<str_len(SV)) SV=SV0;
18565: if(FL||FT||(F&&type(Y)<2)) SV=minustos(SV);
18566: S2=append(["+",SV],S2);
18567: }
18568: S2=reverse(cdr(S2));
18569: if(type(Y)>1){
18570: if(length(S2)>1){
18571: S1="\\int\\left(";S3="\\right)\\,d";
18572: }else{
18573: S1="\\int";S3="\\,d";
18574: }
18575: S2=cons(S1,append(S2,[S3,Y]));
18576: if(findin(Y,VV)<0) VV=cons(Y,VV);
18577: }
18578: if(FL) S0=append(S0,cons("+",S2));
18579: else S0=append(S0,S2);
18580: }
18581: }
18582: L=append([S0],L);
18583: };
18584: V=pfargs(RR,X|level=1);
18585: for(Var=[];V!=[];V=cdr(V)) Var=cons(car(V)[0],Var);
18586: Var=reverse(Var);
18587: if(!isint(J=getopt(frac))) J=0;;
18588: if(!iand(J,4)&&(!iand(J,2)||length(Var)==1)&&(iand(J,8)==8||ptype(RR,Var)==2)){
18589: F=1;
18590: if(iand(J,1)){
18591: K=str_len(fctrtos(RR));
18592: I=str_len(fctrtos(RR|var=Var));
18593: if(I>=K) F=0;
18594: }
18595: if(F){
18596: V=[fctrtos(RR|var=Var,TeX=2)];
18597: if(Dvi!=-2) V=cons("=",V);
18598: if(length(L)>0) L=cdr(L);
18599: L=append([V],L);
18600: }
18601: }else if(ptype(RR,X)==2){
18602: L=cdr(L);
18603: V=[fctrtos(RR|var=X,TeX=2)];
18604: if(Dvi!=-2) V=cons("=",V);
18605: L=append([V],L);
18606: }
18607: S=texket(S+ltotex(reverse(L)|opt=["cr","spts0"],str=1));
18608: if(getopt(log)!=1){
18609: for(V=[];VV!=[];VV=cdr(VV))
18610: V=cons(strtoascii(my_tex_form(car(VV))),V);
18611: S1=strtoascii("\\log");
18612: for(F=1;F;){ /* log(log(x)) */
18613: F=FT=0;
18614: S0=strtoascii(S); /* log(x) -> log|x| */
18615: L=length(S0);
18616: S2=str_tb(0,0);
18617: for(I=0;;){
18618: if(I>=L||(J=str_str(S0,S1|top=I+FT))<0){
18619: S=str_tb(0,S2)+str_cut(S0,I,100000);
18620: break;
18621: }
18622: if((K=str_str(S0,40|top=J+4))<0
18623: ||(K!=J+4&&K!=J+9)||(N=str_pair(S0,K+1,40,41))<0){
18624: FT=J-I+4;continue;
18625: }
18626: FT=0;
18627: if(str_str(S0,V|top=K+1,end=N-1)[0]<0) S2=str_tb(str_cut(S0,I,N),S2);
18628: else{
18629: /* log(a) -> log(a) */
18630: F=1;
18631: if(N<L-1&&S0[N+1]==94){ /* log(x)^2 -> (log|x|)^2 */
18632: S2=str_tb([str_cut(S0,I,J-1),"\\left(",str_cut(S0,J,K-1),
18633: "|",str_cut(S0,K+1,N-1),"|\\right)"],S2);
18634: }
18635: else S2=str_tb([str_cut(S0,I,K-1),"|",str_cut(S0,K+1,N-1),"|"],S2);
18636: }
18637: I=N+1;
18638: }
18639: }
18640: }
18641: if(Dvi>0){
18642: dviout(texbegin("align*",S));
18643: return 1;
18644: }
18645: return S;
18646: } /* end of dviout */
18647: SM=["Cannot integrate",P,"at present"];
18648: P=sqrt2rat(P|mult=1);
18649: Dumb2=1;Dumb3=0;W=newvect(1);W[0]=[];
18650: if(type(Dumb=getopt(dumb))==5){
18651: Dumb2=Dumb3=Dumb;D2=W;
18652: }else if(!isint(Dumb)) Dumb=0;
18653: if(Dumb==-1){
18654: Dumb2=Dumb3=-1;
18655: }
18656: if(type(Dumb)!=5) D2=Dumb2;
18657: if(!isint(Mul=getopt(mult))) Mul=0;
18658: else Mul++;
18659: if(type(VAR=getopt(var))!=4) VAR=[];
18660: if(type(P)>4) return [];
18661: if(iand(T=ptype(P=red(P),X),63)>3||Mul>4){
18662: if(Dumb!=1) mycat(SM);
18663: return [];
18664: }
18665: if(Dumb==-1) mycat(["integrate", P]);
18666: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
18667: if(T<4 && (T<3||iscoef(P,os_md.israt))){
18668: if(Dumb==-1) mycat(["rational function",P]);
18669: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
18670: return intpoly(P,X|dumb=Dumb); /* rational function */
18671: }
18672: Var=pfargs(P,X);
18673: for(F=0,VV=Var;VV!=[];VV=cdr(VV)){
18674: /* p(x)*log(x^2-1), @e^x, a^x, f(x)^(m/n) etc.->simplify */
18675: V=car(VV);
18676: if(V[1]==log && (T=ptype(V[2],X))>1 && T<4){
18677: if(mydeg(dn(V[2]),X)>0||mydeg(nm(V[2]),X)>1){
18678: FC=pfctr(V[2],X);RV=1;
18679: if(length(FC)>2){
18680: RR=0;RV=1;
18681: if((F0=car(FC)[0])!=1){
18682: if(type(F0)!=1 && F0<0){
18683: for(FT=cdr(FT);FT!=[];FT=cdr(FT)){
18684: if(iand(car(FT)[1],1)){
18685: RV=-1;F0=-F0;break;
18686: }
18687: }
18688: }
18689: }
18690: if(F0!=1) RR=log(F0);
18691: for(FC=cdr(FC);FC!=[];FC=cdr(FC)){
18692: if(RV==-1&&iand(car(FC)[1],1)==1){
18693: RR+=car(FC)[1]*log(-car(FC)[0]);
18694: RV=1;
18695: }else
18696: RR+=car(FC)[1]*log(car(FC)[0]);
18697: }
18698: P=subst(P,V[0],RR);
18699: F=1;
18700: }
18701: }
18702: F=1;
18703: }else if(V[1]==pow){
18704: if(ptype(V[2],X)==1){
18705: F=1;
18706: if(V[2]==@e){ /* @e^(f(x)) */
18707: P=subst(P,V[0],exp(V[3]));
18708: }else P=subst(P,V[0],exp(log(V[2])*V[3]));
18709: }else if(type(V[3])<=1 && ntype(V[3])==0){ /* r(x)^(m/n) */
18710: if((Pw=floor(V[3]))!=0){
18711: R=V[2]^Pw;
18712: if((PF=V[3]-Pw)!=0) R*=V[2]^PF;
18713: P=subst(P,V[0],R);
18714: F=1;
18715: V=[V[2]^PF,V[1],V[2],PF];
18716: }
18717: if(ptype(nm(V[2]),X)<2&&V[3]>0){ /* (1/p(x))^(m/n) */
18718: P=subst(P,V[0],V[2]*red(1/V[2])^(1-V[3]));
18719: F=0;VV=cons(0,Var=pfargs(P,X));continue;
18720: }
18721: if(ptype(V[2],X)<4&&(K=dn(V[3]))>1){
18722: V2=red(V[2]);
18723: DN=mydeg(nm(V2),X);DD=mydeg(dn(V2),X);
18724: if(DN+DD>1){
18725: VF=pfctr(V2,X);
18726: R=car(VF)[0]^(car(VF)[1]);RR=0;
18727: for(VF=cdr(VF);VF!=[];VF=cdr(VF)){
18728: TV=car(VF);TM=TV[1];
18729: while(abs(TM)>=K){
18730: RR=1;
18731: if(TM>0){
18732: TM-=K;
18733: RR*=TV[0]^nm(V[3]);
18734: }else{
18735: TM+=K;
18736: RR/=TV[0]^nm(V[3]);
18737: }
18738: }
18739: if(TM!=0) R*=TV[0]^TM;
18740: }
18741: if(RR){
18742: P=subst(P,V[0],RR*red(R)^(V[3]));F=1;
18743: F=0;VV=cons(0,Var=pfargs(P,X));continue;
18744: }
18745: }
18746: }
18747: }
18748: }
18749: }
18750: if(F){
18751: P=sqrt2rat(P|mult=1);
18752: Var=pfargs(P=red(P),X);T=ptype(P,X);
18753: if(T<4 && (T<3||iscoef(P,os_md.israt))){
18754: if(Dumb==-1) mycat(["rational function",P]);
18755: else if(type(Dumb)==5){
18756: Dumb[0]=cons([[X,P]],Dumb[0]);
18757: return intpoly(P,X|dumb=Dumb3);
18758: }
18759: return intpoly(P,X); /* rational function */
18760: }
18761: }
18762: #if 1
18763: for(P0=P,V=pfargs(P,X|level=1);V!=[];V=cdr(V)) /* P:tan(x) -> P0:sin(x)/cos(x) */
18764: if(car(V)[1]==tan) P0=red(subst(P0,car(V)[0],sin(car(V)[2])/cos(car(V)[2])));
18765: if(iand(ptype(P0,X),128)){ /* (log f)'=f'/f */
18766: for(Df=cdr(fctr(dn(P0)));Df!=[];Df=cdr(Df)){
18767: if(!iand(ptype(car(Df)[0],X),64)) continue;
18768: Q=car(Df)[0]^(car(Df)[1]);QQ=red(dn(P0)/Q);
18769: DQ=red(diff(Q,X)*QQ);
18770: if(type(C=DQ/nm(P0))<2&&C!=0){
18771: PP=0;DN=[1];
18772: }else for(DN=cdr(fctr(DQ));DN!=[];DN=cdr(DN)){
18773: Y=car(DN)[0];
18774: if(!iand(ptype(Y,X),64)||(I=mydeg(nm(P0),Y))!=mydeg(DQ,Y)
18775: || ptype((C=red(mycoef(nm(P0),I,Y)/mycoef(DQ,I,Y))),X)>1||C==0) continue;
18776: PP=red(P0-C*diff(Q,X)/Q);
18777: if(nmono(P0)>nmono(PP)) break;
18778: }
18779: if(DN!=[]){
18780: R=C*log(Q);
18781: if(PP==0){
18782: if(P!=P0&&type(Dumb)==5) Dumb[0]=cons([[X,P0]],Dumb[0]);
18783: return R;
18784: }
18785: W[0]=[];
18786: S=integrate(PP,X|dumb=D2);
18787: if(S!=[]){
18788: if(type(Dumb)==5){
18789: Dumb[0]=cons([[X,red(P0-PP),PP]],Dumb[0]);
18790: TD=W[0];
18791: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
18792: if(car(TD)[0][0]){
18793: WL=cons([1,R],car(TD));
18794: Dumb[0]=cons(WL,Dumb[0]);
18795: }
18796: else Dumb[0]=cons(car(TD),Dumb[0]);
18797: }
18798: }
18799: return red(R+S);
18800: }
18801: }
18802: }
18803: }
18804: #endif
18805: if((length(Var)==1||getopt(exe)==1) && /* p(x)*atan(q(x))^m+r(x), etc */
18806: findin((VT=car(Var))[1],[atan,asin,acos,log])>=0 && ptype(P,VT[0])==2 &&
18807: (VT[1]!=log||(T!=65&&T!=66)||mydeg(VT[2],X)!=1)){ /* exclude x*log(x+1)^2 */
18808: for(R=0,D=mydeg(P,VT[0]);D>=0;D--){
18809: Q=S=mycoef(P,D,VT[0]);
18810: if(S){
18811: if(D>0){
18812: if((Q=integrate(S,X|mult=Mul))==[]) return Q;
18813: }else{
18814: W[0]=[];
18815: if((Q=integrate(S,X|dumb=D2,var=VAR,mult=Mul))==[]) return Q;
18816: if(type(Dumb)==5){
18817: TD=W[0];
18818: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
18819: if(car(TD)[0][0]){
18820: WL=cons([1,R],car(TD));
18821: Dumb[0]=cons(WL,Dumb[0]);
18822: }
18823: else Dumb[0]=cons(car(TD),Dumb[0]);
18824: }
18825: if(car(Dumb[0])!=[[1,R],[1,Q]])
18826: Dumb[0]=cons([[1,R,Q]],Dumb[0]);
18827: }
18828: return red(R+Q);
18829: }
18830: }else if(D>0) continue;
18831: if(D==0){
18832: if(Q!=0&&type(Dumb)==5) Dumb[0]=cons([[1,R,Q]],Dumb[0]);
18833: return red(Q+R);
18834: }
18835: R0=Q*VT[0]^D;
18836: P=(P0=P)-S*VT[0]^D-Q*diff(VT[0]^D,X);
18837: if(mydeg(P,VT[0])>=D){ /* (x+1)*log(x)/x^2 */
18838: if(mydeg(P,VT[0])==D &&
18839: ptype(C=red(mycoef(P,D,VT[0])/diff(VT[0],X)),VT[0])<2){
18840: P=P0-(S*VT[0]^D+Q*diff(VT[0]^D,X)+C*diff(VT[0]^(D+1),X)/(D+1));
18841: R0+=C*VT[0]^(D+1)/(D+1);
18842: }else{
18843: P=P0;
18844: if(Dumb!=1) mycat(SM);
18845: return [];
18846: }
18847: }
18848: if(type(Dumb)==5){
18849: if(P) Dumb[0]=cons([R?[1,R,R0]:[1,R0],[X,P]],Dumb[0]);
18850: else if(R!=0) Dumb[0]=cons([[1,R,R0]],Dumb[0]);
18851: }
18852: R+=R0;
18853: }
18854: }
18855: if(length(Var)==1 && (VT=car(Var))[1]==pow && mydeg(P,VT[0])==1 && (PT=ptype(VT[2],X))<4){
18856: PR=mycoef(P,0,VT[0]);
18857: if(RR!=0){
18858: RR=integrate(RR,X|dumb=Dumb3,var=Var);
18859: if(RR==[]) return RR;
18860: }
18861: PW=VT[3];
18862: if((D=mydeg(nm(V2=VT[2]),X))==2&&PT==2){ /* f(x)*(ax^2+bx+c)^(m/2)+r(x) */
18863: if(isint(2*PW)){
18864: C2=mycoef(V20=V2,2,X);F=1;
18865: if((C21=sqrtrat(C2))==[]) return [];
18866: if(imag(C21)!=0){
18867: if(real(C21)!=0) return [];
18868: C21=C21/@i;F=-1;
18869: }
18870: if(type(C21)>3) return [];
18871: P=subst(P,X,X/C21);VT=mysubst(VT,[X,X/C21]);V2=VT[2];
18872: C1=mycoef(V2,1,X)/F/2;
18873: if(C1!=0){
18874: P=subst(P,X,X-C1);VT=mysubst(VT,[X,X-C1]);V2=VT[2];
18875: }
18876: C0=mycoef(V2,0,X);
18877: if((C01=sqrtrat(C0))==[]) return [];
18878: if(imag(nm(C01))!=0){
18879: if(real(nm(C01))!=0) return [];
18880: C01=C01/@i;G=-1;
18881: }else G=1;
18882: if(type(C01)>3||(F==-1&&G==-1)) return [];
18883: Y=makenewv([P,VAR]|var=x);
18884: if(F==-1){ /* (c^2-x^2)^(1/2) */
18885: Q=subst(P,VT[0],(C01*cos(Y))^(2*PW),X,YX=C01*sin(Y))
18886: *C01*cos(Y)/C21;
18887: SY=(C21*X+C1);CY=V20;YY=asin(sqrt2rat((C21*X+C1)/C01|mult=1));
18888: }else if(G==-1){ /* (x^2-c^2)^(1/2) */
18889: Q=subst(P,VT[0],(C01*sin(Y)/cos(Y))^(2*PW),X,YX=C01/cos(Y))
18890: *C01*sin(Y)/cos(Y)^2/C21;
18891: SY=V20;CY=1/(C21*X+C1);YY=acos(sqrt2rat(C01*(C21*X+C1)|mult=1));
18892: }else{ /* (x^2+c^2)^(1/2) */
18893: Q=subst(P,VT[0],(C01/cos(Y))^(2*PW),X,YX=C01*sin(Y)/cos(Y))
18894: *C01/cos(Y)^2/C21;
18895: CY=V20; YY=atan(sqrt2rat((C21*X+C1)/C01|mult=1));
18896: }
18897: if(Dumb==-1) mycat([C21*X+C1,"=",YX]);
18898: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,C21*X+C1,YX]],Dumb[0]);
18899: Q=sqrt2rat(Q);
18900: QQ=red(substblock(nm(Q),sin(Y),sin(Y)^2,1-cos(Y)^2)
18901: /substblock(dn(Q),sin(Y),sin(Y)^2,1-cos(Y)^2));
18902: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
18903: QQ=red(substblock(nm(Q),cos(Y),cos(Y)^2,1-sin(Y)^2)
18904: /substblock(dn(Q),cos(Y),cos(Y)^2,1-sin(Y)^2));
18905: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
18906: if((Q=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var)))==[]) return [];
18907: Q=trig2exp(Q,Y|inv=cos(Y));
18908: for(V=vars(Q);V!=[];V=cdr(V)){
18909: FA=funargs(car(V));
18910: if(type(FA)==4&&FA[0]==log){
18911: QQ=trig2exp(FA[1],Y|inv=cos(Y));
18912: Q=mycoef(Q,0,car(V))+mycoef(Q,1,car(V))*log(QQ);
18913: }
18914: }
18915: if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
18916: if(F==-1) Q=subst(Q,sin(Y),SY/C01,cos(Y),CY^(1/2)/C01,Y,YY);
18917: else if(G==-1){
18918: Q=red(subst(Q,sin(Y),SY^(1/2)*cos(Y)/C01));
18919: Q=red(subst(Q,cos(Y),C01*CY,Y,YY));
18920: }else{
18921: Q=red(subst(Q,sin(Y),(C21*X+C1)*cos(Y)/C01));
18922: Nm=substblock(nm(Q),cos(Y),C01^2/CY,cos(Y)^2);
18923: Nm=subst(Nm,cos(Y),C01/CY^(1/2));
18924: Dn=substblock(dn(Q),cos(Y),C01^2/CY,cos(Y)^2);
18925: Dn=subst(Dn,cos(Y),C01/CY^(1/2));
18926: Q=red(subst(Nm/Dn,Y,YY));
18927: }
18928: if(findin(Y,vars(Q))>=0) return [];
18929: for(R=[],Var=vars(Q);Var!=[];Var=cdr(Var)){
18930: VT=funargs(V=car(Var));
18931: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60&&mydeg(Q,V)==1)
18932: R=cons([mycoef(Q,1,V),V],R);
18933: }
18934: if(length(R)==2 && (R[0][0]==R[1][0]||R[0][0]+R[1][0]==0)){
18935: R0=args(R[0][1])[0];R1=args(R[1][1])[0];
18936: if(R[0][0]==R[1][0]) S=R0*R1;
18937: else S=R1/R0;
18938: Q=mycoef(Q,0,R[0][1]);Q=mycoef(Q,0,R[1][1]);
18939: Q+=R[1][0]*log(red(S));
18940: }
18941: for(Var=vars(Q);Var!=[];Var=cdr(Var)){
18942: VT=funargs(car(Var));
18943: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60){
18944: S=trig2exp(VT[1],X|inv=cos(X),arc=1);
18945: if(ptype(dn(S),X)<2 && mydeg(Q,car(Var))==1
18946: && ptype(mycoef(Q,1,car(Var)),X)<2){
18947: S=nm(S);
18948: SF=fctr(S);
18949: S/=SF[0][0];
18950: }
18951: if(cmpsimple(S,-S)>0) S=-S;
18952: Q=subst(Q,car(Var),log(S));
18953: }
18954: } /* x/(1-x^2)^(1/2) */
18955: if(type(Q=red(Q+RR))==2&&type(Dumb)!=5) Q-=cterm(Q);
18956: if(Dumb==-1) mycat(["->",Q]);
18957: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
18958: return Q;
18959: }
18960: }else if(D==1 && mydeg(Dn=dn(V2),X)<2 && type(PW)==1 && ntype(PW)==0 &&
18961: (V2!=X||ptype(mycoef(P,1,VT[0]),X)>2)){ /* p(x)((ax+b)/(cx+d))^(m/n) */
18962: PN=nm(PW);PD=dn(PW);
18963: Y=makenewv([P,VAR]|var=x);Q=Y^PD*Dn-nm(V2);F=-mycoef(Q,0,X)/mycoef(Q,1,X);
18964: Q=red(subst(P,VT[0],Y^PN,X,F)*diff(F,Y));
18965: if(Dumb==-1) mycat([Y,"=",V2^(1/PD)]);
18966: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,V2^(1/PD)]],Dumb[0]);
18967: if((Q=integrate(Q,Y|dumb=Dumb3,var=cons(X,Var)))==[]) return [];
18968: Q=red(Q);
18969: QN=subst(substblock(nm(Q),Y,Y^PD,V2),Y,V2^(1/PD));
18970: QD=subst(substblock(dn(Q),Y,Y^PD,V2),Y,V2^(1/PD));
18971: Q=red(QN/QD+RR);
18972: if(Dumb==-1) mycat(["->",Q]);
18973: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
18974: return Q;
18975: }
18976: }else if(length(Var)==2 && /* r(x,(ax+b)^(1/2),(cx+d)^(1/2)) */
18977: (VT=car(Var))[1]==pow && ptype(VT[2],X)==1 && mydeg(VT[2],X)==1 && VT[3]==1/2 &&
18978: (VS=car(car(Var)))[1]==pow && ptype(VS[2],X)==1 && mydeg(VS[2],X)==1 && VS[3]==1/2){
18979: Y=makenewv([P,VAR]|var=x);R=(Y^2-myceof(VS[0],0,X))/(C=mycoef(VS[0],1,X));
18980: if(Dumb==-1) mycat([Y,"=",VS[0]]);
18981: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,VD[0]]],Dumb[0]);
18982: R=integrate(subst(P,VS[0],Y,X,R)*2*Y/C,Y|dumb=Dumb3,var=cons(X,Var));
18983: if(R!=[]){
18984: R=subst(substblock(R,Y,VS[0],Y^2),Y,VS[0]);
18985: if(Dumb==-1) mycat(["->",R]);
18986: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
18987: }
18988: return R;
18989: }
18990: if(T==65||T==66){ /* polynomial including sin, exp etc */
18991: for(F=0,VT=Var;VT!=[];VT=cdr(VT)){
18992: VTT=car(VT);
18993: if(ptype(VTT[2],X)>2||mydeg(VTT[2],X)>1) F=ior(F,256); /* compos. or rat. or nonlin. */
18994: K=findin(VTT[1],[cos,sin,tan,exp,log,pow]);
18995: F=ior(F,2^(K+1)); /* 1:other,2:cos,4:sin,8:tan,16:exp,32:log,64:pow */
18996: if((Deg=mydeg(P,VTT[0]))>1&&K!=4) F=ior(F,1024); /* nonlinear */
18997: if(K==5 && (ptype(VTT[3],X)!=0 || VTT[2]!=x||Deg>1)) F=ior(F,8192); /* pow */
18998: for(;Deg>0;Deg--){ /* coef */
18999: if(ptype(mycoef(P,Deg,VTT[0]),X)>2){
19000: if(K==4||K==5) F=ior(F,2048); /* exp, log */
19001: else F=ior(F,4096);
19002: }
19003: }
19004: }
19005: if(!iand(F,1+8+64+256+512+2048+8192)){ /* cos,sin,exp,log^n,x^c */
19006: if(iand(F,1024+4096)&&!iand(F,32+64)){ /* cos,sin,exp */
19007: if(type(Dumb)==5){
19008: S=trig2exp(P,X|inv=1);
19009: if(P!=S) Dumb[0]=cons([[X,S]],Dumb[0]);
19010: }
19011: R=integrate(trig2exp(P,X),X);
19012: if(R!=[]) S=trig2exp(R,X|inv=1);
19013: R=fshorter(S,X);
19014: if(type(Dumb)==5&&R!=S){
19015: Dumb[0]=cons([[1,S]],Dumb[0]);
19016: }
19017: return R;
19018: }
19019: for(R=0,VT=Var;VT!=[];VT=cdr(VT)){
19020: CV=car(VT);
19021: C0=mycoef(CV[2],0,X);C1=mycoef(CV[2],1,X);
19022: Q=mycoef(P,1,CV[0]);
19023: if(CV[1]==sin||CV[1]==cos){
19024: TR=(CV[1]==sin)?intpoly(Q,X|sin=C1):intpoly(Q,X|cos=C1);
19025: R+=TR[0]*cos(CV[2])+TR[1]*sin(CV[2]);
19026: }else if(CV[1]==exp){
19027: QT=exp(CV[2]);
19028: for(V2=vars(C1);V2!=[];V2=cdr(V2)){ /* exp(2*log(a)*x) => a^(2*x) */
19029: if(vtype(VA=car(V2))==2&&functor(VA)==log){
19030: if(ptype(C1,VA)!=2||mydeg(C1,VA)==1&&mycoef(C1,0,VA)==0){
19031: QT=args(VA)[0]^(red(C1/VA)*X);
19032: if(C0!=0) QT*=exp(C0);
19033: break;
19034: }
19035: }
19036: }
19037: R+=intpoly(Q,X|exp=C1)*QT;
19038: }else if(CV[1]==pow)
19039: R+=intpoly(Q,X|pow=CV[2])*x^CV[2];
19040: else if(CV[1]==log){
19041: for(Deg=mydeg(P,CV[0]);Deg>0; Deg--){
19042: Q=mycoef(P,Deg,CV[0]);
19043: TR=intpoly(Q,X|log=[C1,C0,Deg]);
19044: for(I=0;TR!=[];I++,TR=cdr(TR)){
19045: if(I==Deg) R+=car(TR)-subst(car(TR),X,0);
19046: else R+=car(TR)*CV[0]^(Deg-I);
19047: }
19048: }
19049: }
19050: P=mycoef(P,0,CV[0]);
19051: }
19052: R+=intpoly(P,X);
19053: return R;
19054: }
19055: }
19056: for(K=0,VX=[],VT=Var;VT!=[];VT=cdr(VT)){ /* contain only both pow and trig */
19057: VTT=car(VT);
19058: if(findin(VTT[1],[cos,sin,tan])>=0){
19059: if(ptype(VTT[2],X)!=2||mydeg(VTT[2],X)!=1) break;
19060: VX=cons(VTT,VX);
19061: }else if(VTT[1]==pow) K=1;
19062: else break;
19063: }
19064: if(VT==[]&&K==1&&VX!=[]){
19065: D=VX[0][2];
19066: if(VX[0][1]==tan) D*=2;
19067: for(VT=cdr(VX);VT!=[];VT=cdr(VT)){
19068: K=VT[0][2]/D;
19069: if(VT[0][1]==tan) K*=2;
19070: if(type(K)!=1||ntype(K)!=0) break;
19071: D/=dn(K);
19072: }
19073: if(VT==[]){
19074: Y=makenewv([P,VAR]|var=x);
19075: for(Q=P,VT=VX;VT!=[];VT=cdr(VT)){
19076: VTT=car(VT);
19077: if(VTT[1]==cos||VTT[1]==sin){
19078: VV=trig2exp(VTT[0],X|inv=cos(D));
19079: VV=subst(VV,cos(D),(1-Y^2)/(1+Y^2),sin(D),2*Y/(Y^2+1));
19080: }else if(VTT[1]==tan){
19081: VV=trig2exp(VTT[0],X|inv=tan(D/2));
19082: VV=subst(VV,tan(D),Y);
19083: }
19084: Q=subst(Q,VTT[0],VV);
19085: }
19086: Q*=2/(Y^2+1);
19087: if(diff(Q,X)==0){
19088: if(Dumb==-1) mycat([Y,"=",tan(D/2)]);
19089: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,tan(D/2)]],Dumb[0]);
19090: R=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var));
19091: if(R!=[]){
19092: if(Dumb==-1) mycat(["->",R]);
19093: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
19094: return sqrt2rat(subst(R,Y,tan(D/2))|mult=1);
19095: }
19096: }
19097: }
19098: }
19099: if(T>65||iand(F,8)){ /* rational for functions or tan */
19100: if(findin(X,vars(P))<0){
19101: for(XV=XE=0,VT=Var;VT!=[];VT=cdr(VT)){
19102: VTT=car(VT);
19103: if(mydeg(VTT[2],X)!=1) break;
19104: if(VTT[1]==cos||VTT[1]==sin||VTT[1]==tan){
19105: K=red(VTT[2]/X);
19106: if(type(K)>1||ntype(K)>0) break;
19107: if(XV==0) XV=K;
19108: else XV/=dn(K/XV);
19109: if(VTT[1]==tan) P=red(subst(P,VTT[0],sin(VTT[2])/cos(VTT[2])));
19110: }else if(VTT[1]==exp){
19111: K=red(VTT[2]/X);
19112: if(type(K)>1||ntype(K)>0) break;
19113: if(XE==0) XE=K;
19114: else XE/=dn(K/XE);
19115: }else break;
19116: }
19117: if(VT==[]&&XE*XV==0){
19118: if(XE){
19119: if(XE<0) XE=-XE;
19120: Y=makenewv([P,VAR]|var=x);
19121: for(F=0,VT=Var;VT!=[];VT=cdr(VT),F++){
19122: VTT=car(VT);C=red(VTT[2]/X/XE);
19123: P=subst(P,VTT[0],Y^C);
19124: if(!F){
19125: if(Dumb==-1) mycat([Y^C,"=",VTT[0]]);
19126: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y^C,VTT[0]]],Dumb[0]);
19127: }
19128: }
19129: P/=XE*Y;
19130: Q=integrate(P,Y|dumb=Dumb3,var=cons(X,VAR));
19131: if(Q==[]) return [];
19132: Q=subst(Q,Y,exp(XE*X));
19133: Q=trig2exp(Q,X);
19134: if(Dumb==-1) mycat(["->",Q]);
19135: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
19136: return Q;
19137: }
19138: P=trig2exp(nm(P),X|inv=cos(XV*X))/trig2exp(dn(P),X|inv=cos(XV*X));
19139: Y=makenewv([P,VAR]|var=x);
19140: Q=red(subst(P,sin(XV*X),Y*cos(XV*X)));
19141: Q=substblock(nm(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))/
19142: (substblock(dn(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))*(Y^2+1));
19143: Q=red(Q);
19144: if(ptype(Q,X)<2){
19145: XV*=2;P=Q;
19146: }else{
19147: 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);
19148: P=red(P);
19149: }
19150: if(Dumb==-1){
19151: mycat([Y,"=",tan(XV*X/2)]);
19152: mycat(["integrate",P]);
19153: }else if(type(Dumb)==5) Dumb[0]=cons([[Y,P]],cons([[0,Y,tan(XV*X/2)]],Dumb[0]));
19154: R=intpoly(P,Y|dumb=Dumb);
19155: if(R==[]) return R;
19156: if(Dumb==-1) mycat(["->",R]);
19157: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
19158: for(Log=1,K=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
19159: VTT=car(Var);
19160: if(VTT[1]==log){
19161: C=mycoef(R,1,VTT[0]);
19162: VT2=VTT[2];
19163: if(K==0){
19164: K=C;Log=VT2;
19165: if(K<0){
19166: K=-K;Log=1/Log;
19167: }
19168: }else{
19169: if((V=red(C/K))<0){
19170: VT2=1/VT2;V=-V;
19171: }
19172: if(type(V)>1||ntype(V)>0){
19173: Log=1;break;
19174: }
19175: if(isint(V)) Log*=VT2^V;
19176: else{
19177: D=dn(V);K/=D;
19178: Log=Log^D*VT2^nm(V);
19179: }
19180: }
19181: RR=mycoef(RR,0,VTT[0]);
19182: }
19183: }
19184: if(Log!=1){
19185: R=RR;
19186: if(type(Dumb)==5){
19187: if(RR) Dumb[0]=cons([[1,K*log(Log),RR]],Dumb[0]);
19188: else Dumb[0]=cons([[1,K*log(Log)]],Dumb[0]);
19189: }
19190: Log=red(subst(red(Log),Y,sin(XV*X/2)/cos(XV*X/2)));
19191: Log=fshorter(Log,X|log=1); /* log(cos(2*x)+1)=-2*log(cos(x)) */
19192: Nm=fctr(nm(Log));
19193: for(T=[];Nm!=[];Nm=cdr(Nm)){
19194: if(ptype(car(Nm)[0],X)>1) T=cons(car(Nm),T);
19195: }
19196: Nm=fctr(dn(Log));
19197: for(;Nm!=[];Nm=cdr(Nm)){
19198: if(ptype(car(Nm)[0],X)>1) T=cons([car(Nm)[0],-car(Nm)[1]],T);
19199: }
19200: for(I=0,Nm=T;T!=[];T=cdr(T)){
19201: if(I=0) I=abs(car(T)[1]);
19202: else I=igcd(I,car(T)[1]);
19203: }
19204: for(Log=1;Nm!=[];Nm=cdr(Nm)) Log*=car(Nm)[0]^(car(Nm)[1]/I);
19205: K*=I;
19206: if(cmpsimple(nm(Log),dn(Log))<0){
19207: K=-K;Log=red(1/Log);
19208: }
19209: Log=K*log(Log);
19210: if(type(Dumb)==5){
19211: if(RR) Dumb[0]=cons([[1,Log,RR]],Dumb[0]);
19212: else Dumb[0]=cons([[1,Log]],Dumb[0]);
19213: }
19214: }else Log=0;
19215: for(Atan=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
19216: VTT=car(Var);
19217: if(VTT[1]==atan){
19218: W=subst(VTT[2],Y,sin(XV*X/2)/cos(XV*X/2));
19219: W=trig2exp(W,X|inv=1);
19220: V2=funargs(dn(W));
19221: if(type(V2)==4&&length(V2)==2){
19222: V3=V2[1]*mycoef(R,1,VTT[0]);
19223: Z=0;
19224: if(V2[0]==cos)
19225: Z=red(W*cos(V2[1])/sin(V2[1]));
19226: else if(V2[0]==sin){
19227: Z=red(W*sin(V2[1])/cos(V2[1]));
19228: V3=-V3;
19229: }
19230: if(Z==1){
19231: Atan+=V3;W=0;
19232: }else if(Z==-1){
19233: Atan-=V3;W=0;
19234: }
19235: }
19236: R0=mycoef(R,0,VTT[0]);
19237: if(W!=0) Atan+=subst(R-R0,VTT[0],atan(W)); /* atan(W); */
19238: R=R0;
19239: }
19240: }
19241: if(R!=0){
19242: R=subst(R,Y,sin(XV*X/2)/cos(XV*X/2));
19243: R=red(R);
19244: R=trig2exp(nm(R),X|inv=1)/trig2exp(dn(R),X|inv=1);
19245: }
19246: if(type(Dumb)==5){
19247: F=0;WL=[];
19248: if(R){
19249: WL=cons(R,WL);
19250: F++;
19251: }
19252: if(Atan){
19253: WL=cons(Atan,WL);
19254: F++;
19255: }
19256: if(Log){
19257: WL=cons(Log,WL);
19258: F++;
19259: }
19260: WL=cons(1,WL);
19261: if(F>1) Dumb[0]=cons([WL],Dumb[0]);
19262: }
19263: R=red(R+Log+Atan);
19264: if(Dumb==-1) mycat(["->",R]);
19265: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
19266: return fshorter(R,X);
19267: }
19268: }
19269: }
19270: VT=pfargs(Q=P,X|level=1);
19271: V=(iand(ptype(P,X),7)<3)?[X]:[];
19272: for(;VT!=[];VT=cdr(VT))
19273: if(ptype(P,car(VT)[0])<3) V=cons(car(VT)[0],V);
19274: if(length(V)>0){ /* 1/x+tan(x)+... etc.: sums */
19275: for(R=0;V!=[];V=cdr(V)){
19276: T=mycoef(Q,0,car(V));
19277: W[0]=[];
19278: S=integrate(TD=red(Q-T),X|dumb=D2,mult=Mul,exe=1);
19279: if(S==[]) continue;
19280: if(type(Dumb)==5){
19281: WL=0;
19282: if(T!=0) WL=[[X,TD,T]];
19283: if(R!=0) WL=cons([1,R],WL);
19284: if(WL) Dumb[0]=cons(WL,Dumb[0]);
19285: TD=W[0];
19286: if(R!=0||T!=0){
19287: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
19288: if(car(TD)[0][0]){
19289: WL=(!T)?[]:[[X,T]];
19290: WL=append(car(TD),WL);
19291: if(R!=0) WL=cons([1,R],WL);
19292: }else WL=car(TD);
19293: Dumb[0]=cons(WL,Dumb[0]);
19294: }
19295: }else Dumb[0]=append(TD,Dumb[0]);
19296: }
19297: R+=S;Q=T;
19298: if(!Q) return red(R);
19299: }
19300: W[0]=[];
19301: if(P!=Q&&type(S=integrate(Q,X|dumb=D2,mult=Mul))<4){
19302: RR=red(R+S);
19303: if(type(Dumb)==5){
19304: TD=W[0];
19305: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
19306: if(car(TD)[0][0]){
19307: WL=cons([1,R],car(TD));
19308: Dumb[0]=cons(WL,Dumb[0]);
19309: }
19310: else Dumb[0]=append(TD,Dumb[0]);
19311: }
19312: if(nmono(R)+nmono(S)!=nmono(RR)) Dumb[0]=cons([[1,R,S]],Dumb[0]);
19313: }
19314: return RR;
19315: }
19316: }
19317: if(Dumb!=1) mycat(SM);
19318: return [];
19319: }
19320:
19321: def fimag(P)
19322: {
19323: for(V=vars(P);V!=[];V=cdr(V)){
19324: Q=[];
19325: if(vtype(VF=car(V))==2){
19326: VAA=args(VF);
19327: if(VAA==[]) continue;
19328: VA=sqrt2rat(VAA[0]);
19329: if(functor(VF)==exp){
19330: if(imag(VA)!=0){
19331: R=(real(VA)!=0)?exp(real(VA)):1;
19332: Q=subst(P,VF,R*(cos(imag(VA))+sin(imag(VA))*@i));
19333: }
19334: }else if(functor(VF)==pow){
19335: VA=sqrt2rat(VAA[1]);
19336: if(imag(VA)!=0){
19337: R=(real(VA)!=0)?VAA[0]^(real(VA)):1;
19338: L=(VAA[0]!=@e)?log(VAA[0]):1;
19339: Q=subst(P,VAA[0]^(VAA[1]),R*(cos(L*imag(VA))+sin(L*imag(VA))*@i));
19340: }else if(VAA[1]!=(V0=fimag(VA)))
19341: Q=subst(P,VAA[0]^(VAA[1]),VAA[0]^(V0));
19342: }
19343: V0=VA;
19344: if(length(VAA)==1&&(VAA[0]!=V0||VA!=(V0=fimag(VA))))
19345: Q=subst(P,VF,subst(VF,VAA[0],V0));
19346: }
19347: if(Q!=[]&&P!=Q){
19348: P=Q;V=cons(0,vars(P));
19349: }
19350: }
19351: return P;
19352: }
19353:
19354:
19355: def trig2exp(P,X)
19356: {
19357: if(iand(ptype(P,X),128)){
19358: OL=getopt();
19359: Nm=trig2exp(nm(P),X|option_list=OL);
19360: Dn=trig2exp(dn(P),X|option_list=OL);
19361: R=red(Nm/Dn);
19362: if(getopt(arc)==1) return sqrt2rat(R);
19363: }
19364: if((Inv=getopt(inv))==1||type(Inv)==2){
19365: for(VT=T=vars(P);T!=[];T=cdr(T)){
19366: if(findin(functor(car(T)),[cos,sin,tan])>=0){
19367: P=trig2exp(P,X);VT=vars(P);break;
19368: }
19369: }
19370: for(;VT!=[];VT=cdr(VT)){
19371: if(functor(CT=car(VT))==exp){
19372: if((Re=real(args(CT)[0]))!=0){
19373: if(isint(Re)) S=@e^Re;
19374: else S=exp(Re);
19375: }else S=1;
19376: if((Im=imag(args(CT)[0]))!=0){
19377: Q=nm(Im);Q=mycoef(Q,mydeg(Q,X),X);
19378: if(-Q>Q) S*=cos(-Im)-@i*sin(-Im);
19379: else S*=cos(Im)+@i*sin(Im);
19380: }
19381: P=subst(P,CT,S);
19382: }
19383: }
19384: P=red(P);
19385: U=vars(Inv);
19386: if(length(U)!=1||((F=functor(car(U)))!=sin&&F!=cos&&F!=tan)) return P;
19387: XX=args(car(U))[0];
19388: if(mydeg(XX,X)!=1) return P;
19389: if(!isvar(XX)) P=subst(P,X,(X-mycoef(XX,0,X))/mycoef(XX,1,X));
19390: for(VT=vars(P);VT!=[];VT=cdr(VT)){
19391: if(vtype(CT=car(VT))<2) continue;
19392: TX=args(CT)[0];
19393: if(mydeg(TX,X)!=1) continue;
19394: if(!isint(C1=mycoef(TX,1,X))) continue;
19395: if((C0=mycoef(TX,0,X))==0){
19396: CC=1;CS=0;
19397: }else if(vars(C0)==[@pi]){
19398: CC=myval(cos(C0));
19399: if(CC!=0&&type(CC)==1&&ntype(CC)!=0){
19400: CC=cos(C0);CS=sin(C0);
19401: }else CS=myval(sin(C0));
19402: }else{
19403: CC=cos(C0);CS=sin(C0);
19404: }
19405: K=C1;
19406: if(K<0) K=-K;
19407: for(CC1=0,I=K;I>=0;I-=2) CC1+=(-1)^((K-I)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I);
19408: 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);
19409: if(C1<0) CS1=-CS1;
19410: if((TF=functor(CT))==cos) P=subst(P,cos(TX),CC1*CC-CS1*CS);
19411: else if(TF==sin) P=subst(P,sin(TX),CS1*CC+CC1*CS);
19412: }
19413: if(F==sin)
19414: P=substblock(P,cos(X),cos(X)^2,1-sin(X)^2);
19415: else{
19416: P=substblock(P,sin(X),sin(X)^2,1-cos(X)^2);
19417: if(F==tan){
19418: P=subst(P,sin(X),cos(X)*tan(X));
19419: P=substblock(P,cos(X),cos(X)^2,1/(tan(X)^2+1));
19420: }
19421: }
19422: if(!isvar(XX)) P=subst(P,X,XX);
19423:
19424: if(getopt(arc)==1){
19425: for(VT=vars(P);VT!=[];VT=cdr(VT)){
19426: FA=funargs(car(VT));
19427: if(type(FA)==4&&(FA[0]==cos||FA[0]==sin)&&ptype(FA[1],X)>60){
19428: VTT=vars(FA[1]);
19429: if(type(FA[1])!=2||length(VTT)!=1) break;
19430: FB=funargs(VTT[0]);
19431: if(type(FB)!=4||(FF=findin(FB[0],[asin,acos,atan]))<0) break;
19432: if(!isint(2*(C=mycoef(FA[1],1,VTT[0])))||mycoef(FA[1],0,VTT[0])!=0) break;
19433: if(C==1/2){
19434: if(FF==1){
19435: U=(FA[0]==cos)?(1+FB[1])/2:(1-FB[1])/2;
19436: P=subst(P,car(VT),red(U)^(1/2));
19437: }else if(FF==2){
19438: if(FA[0]==sin){
19439: FB1=red(FB[1]);
19440: Nm=nm(FB1);CC=fctr(Nm)[0][0];Dn=dn(FB1);
19441: if(CC<0) CC=-CC;
19442: Nm/=CC;Dn/=CC;
19443: NN=Nm^2+Dn^2;
19444: P=subst(P,car(VT),((NN)^(1/2)-Dn)/Nm*cos(FA[1]));
19445: }
19446: }
19447: P=red(P);
19448: }else if(C==1){
19449: if(FF==1){
19450: if(FA[0]==cos) P=subst(P,car(VT),FB[1]);
19451: else P=subst(P,car(VT),(1-FB[1])^(1/2));
19452: }else if(FF==0){
19453: if(FA[0]==sin) P=subst(P,car(VT),FB[1]);
19454: else P=subst(P,car(VT),(1-FB[1])^(1/2));
19455: }
19456: P=red(P);
19457: }
19458: }
19459: }
19460: P=sqrt2rat(P);
19461: }
19462: return red(P);
19463: }
19464: Var=pfargs(P,X);
19465: for(VT=Var;VT!=[];VT=cdr(VT)){
19466: CT=car(VT);
19467: if(CT[1]==cos)
19468: P=subst(P,CT[0],exp(CT[2]*@i)/2+exp(-CT[2]*@i)/2);
19469: else if(CT[1]==sin)
19470: P=subst(P,CT[0],exp(-CT[2]*@i)*@i/2-exp(CT[2]*@i)*@i/2);
19471: else if (CT[1]==tan)
19472: P=subst(P,CT[0],(exp(-CT[2]*@i)*@i-exp(CT[2]*@i)*@i)/(exp(CT[2]*@i)+exp(-CT[2]*@i)));
19473: else if(CT[1]==pow){
19474: if(ptype(CT[2],X)>1) continue;
19475: if(CT[2]==@e) P=subst(P,CT[0],exp(CT[3]));
19476: else P=subst(P,CT[0],exp(log(CT[2])*exp(CT[3])));
19477: }
19478: }
19479: P=red(P);
19480: for(PP=1,Lp=(dn(P)==1)?1:0;Lp<2;Lp++){
19481: PP=1/PP;
19482: U=(Lp==0)?dn(P):nm(P);
19483: if(U==1) continue;
19484: Var=vars(U);
19485: for(R=[],VT=Var;VT!=[];VT=cdr(VT))
19486: if(functor(car(VT))==exp) R=cons(car(VT),R);
19487: RR=os_md.terms(U,R);
19488: for(Q=0,RRT=RR;RRT!=[];RRT=cdr(RRT)){
19489: for(S=0,CT=cdr(car(RRT)),CR=R,UT=U;CR!=[];CR=cdr(CR),CT=cdr(CT)){
19490: UT=mycoef(UT,car(CT),car(CR));S+=car(CT)*args(car(CR))[0];
19491: }
19492: if(S==0) Q+=UT;
19493: else Q+=UT*exp(S);
19494: }
19495: PP*=Q;
19496: }
19497: return PP;
19498: }
19499:
19500: def powsum(N)
19501: {
19502: if (N < 0) return 0;
19503: if (N == 0) return x;
19504: P = intpoly(N*powsum(N-1),x);
19505: C = subst(P,x,1);
19506: return P+(1-C)*x;
19507: }
19508:
19509: def bernoulli(N)
19510: {
19511: return mydiff(powsum(N),x) - N*x^(N-1);
19512: }
19513:
19514: /* linfrac01([x,y]) */
19515: /* linfrac01(newvect(10,[0,1,2,3,4,5,6,7,8,9]) */
19516: /* 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
19517: 10:y_2=0, 11:y_2=x, 12:y_2=y, 13: y_2=1, 14: y_2=\infty
19518: 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
19519: X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
19520: X[3],X[1],X[12],X[4],X[6]
19521:
19522: T=0 (x_2,x_1,x_3,x_4,...)
19523: T=-j (x_1,x_2,..,x_{j-1},x_{j+1},x_j,x_{j+2},...)
19524: T=1 (1-x_1,1-x_2,1-x_3,1-x_4,...)
19525: T=2 (1/x_1,1/x_2,1/x_3,1/x_4,...)
19526: T=3 (x_1,x_1/x_2,x_1/x_3,x_1/x_4,...)
19527: */
19528:
19529: def lft01(X,T)
19530: {
19531: MX=getopt();
19532: if(type(X)==4){
19533: K=length(X);
19534: if(K>=1) D=1;
19535: }
19536: if(type(X)==5){
19537: K=length(X);
19538: for(J=5, F=K-10; F>0; F-=J++);
19539: if(F==0) D=2;
19540: }
19541: if(D==0) return 0;
19542: if(T==0){ /* x <-> y */
19543: if(D==1){
19544: R=cdr(X); R=cdr(R);
19545: R=cons(X[0],R);
19546: return cons(X[1],R);
19547: }
19548: R=newvect(K,[X[3],X[1],X[4],X[0],X[2],X[6],X[5]]);
19549: for(I=7;I<K;I++) R[I]=X[I];
19550: for(I=11,J=5; I<K; I+=J++){
19551: R[I]=X[I+1]; R[I+1]=X[I];
19552: }
19553: return R;
19554: }
19555: if(T==1){
19556: if(D==1){
19557: for(R=[];X!=[];X=cdr(X)) R=cons(1-car(X),R);
19558: return reverse(R);
19559: }
19560: R=newvect(K,[X[2],X[1],X[0],X[4],X[3],X[5],X[6],X[8],X[7],X[9]]);
19561: for(I=11;I<K;I++) R[I]=X[I];
19562: for(I=10, J=5; I<K; I+=J++){
19563: R[I]=X[I+J-2]; R[I+J-2]=X[I];
19564: }
19565: return R;
19566: }
19567: if(T==2){
19568: if(D==1){
19569: for(R=[]; X!=[]; X=cdr(X)) R=cons(red(1/car(X)),R);
19570: return reverse(R);
19571: }
19572: R=newvect(K,[X[5],X[1],X[2],X[6],X[4],X[0],X[3],X[9],X[8],X[7]]);
19573: for(I=11;I<K;I++) R[I]=X[I];
19574: for(I=10,J=5; I<K; I+=J++){
19575: R[I]=X[I+J-1]; R[I+J-1]=X[I];
19576: }
19577: return R;
19578: }
19579: if(T==3){
19580: if(D==1){
19581: T=car(X);
19582: for(R=[T],X=cdr(X); X!=[]; X=cdr(X))
19583: R=cons(red(T/car(X)),R);
19584: return reverse(R);
19585: }
19586: R=newvect(K,[X[7],X[4],X[2],X[6],X[1],X[9],X[3],X[0],X[8],X[5]]);
19587: for(I=10,J=5; I<K; I+=J++){
19588: R[I]=X[I+J-1]; R[I+1]=X[I+J-2]; R[I+J-2]=X[I+1]; R[I+J-1]=X[I];
19589: }
19590: return R;
19591: }
19592: if(T==-1){
19593: if(D==1){
19594: return append([X[1],X[2],X[0]],cdr(cdr(cdr(X))));
19595: }
19596: R=newvect(K,[X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
19597: X[3],X[1],X[12],X[4],X[6]]);
19598: for(I=11;I<K;I++) R[I]=X[I];
19599: for(I=17,J=5; I<K; I+=J++){
19600: R[I]=X[I+1]; R[I+1]=X[I];
19601: }
19602: return R;
19603: }
19604: if(T<0){
19605: if(D==1){
19606: for(R=[],I=0; X!=[]; X=cdr(X),I--){
19607: if(I==T){
19608: R=cons(X[1],R);
19609: R=cons(X[0],R);
19610: X=cdr(X);
19611: }
19612: else R=cons(car(X),R);
19613: }
19614: return reverse(R);
19615: }
19616: T=3-T;
19617: R=newvect(K);
19618: for(I=0;I<K;I++) R[I]=X[I];
19619: for(I=10,J=5;J<T;I+=J++);
19620: for(II=0; II<J-2; II++){
19621: R[I]=X[I+J]; R[I+J]=R[I];
19622: }
19623: for( ; II<J; II++){
19624: R[I]=X[I+J+1]; R[I+J+1]=X[I];
19625: }
19626: return R;
19627: }
19628: return 0;
19629: }
19630:
19631: def linfrac01(X)
19632: {
19633: if(type(X)==4) K=length(X)-2;
19634: else if(type(X)==5){
19635: L=length(X);
19636: for(K=0,I=10,J=5; I<L; K++,I+=J++);
19637: if(I!=L) return 0;
19638: }
19639: if(K>3 && getopt(over)!=1) return(-1);
19640: II=(K==-1)?3:4;
19641: for(CC=C=1,L=[X]; C!=0; CC+=C){
19642: for(F=C,C=0,R=L; F>0; R=cdr(R), F--){
19643: P=car(R);
19644: for(I=-K; I<II; I++){
19645: S=lft01(P,I);
19646: if(findin(S,L) < 0){
19647: C++; L=cons(S,L);
19648: }
19649: }
19650: }
19651: }
19652: return L;
19653: }
19654:
19655:
19656: def varargs(P)
19657: {
1.21 takayama 19658: if((All=getopt(all))!=1&&All!=2) All=0;
1.6 takayama 19659: V=vars(P);
19660: for(Arg=FC=[];V!=[];V=cdr(V)){
1.21 takayama 19661: if(vtype(CV=car(V))==0&&All!=0){
1.6 takayama 19662: Arg=lsort([CV],Arg,0);
19663: }
19664: if(vtype(CV)!=2) continue;
19665: if(findin(F=functor(CV),FC)<0) FC=cons(F,FC);
19666: for(AT=vars(args(CV));AT!=[];AT=cdr(AT)){
19667: if(vtype(X=car(AT))<2){
19668: if(findin(X,Arg)<0) Arg=cons(X,Arg);
19669: }else if(vtype(X)==2){
19670: R=varargs(X);
19671: if(R[1]!=[]){
19672: Arg=lsort(R[1],Arg,0);
19673: FC=lsort(R[0],FC,0);
19674: }
19675: }
19676: }
19677: }
1.21 takayama 19678: Arg=reverse(Arg);
19679: return (All==2)?Arg:[reverse(FC),Arg];
1.6 takayama 19680: }
19681:
19682: def pfargs(P,X)
19683: {
19684: if(type(L=getopt(level))!=1) L=0;
19685: for(Var=[],V=vars(P);V!=[];V=cdr(V)){
19686: if(vtype(car(V))==2){
19687: VT=funargs(car(V));
19688: if(length(VT)>1){
19689: if(L<2 &&(ptype(VT[1],X)>1 || (length(VT)>2 && ptype(VT[2],X)>1)))
19690: Var=cons(cons(car(V),VT),Var);
19691: if(L!=1 && (R=pfargs(VT[1],X|level=L-1))!=[]) Var=append(R,Var);
19692: }
19693: }
19694: }
19695: return reverse(Var);
19696: }
19697:
19698: def ptype(P,L)
19699: {
19700: if((T=type(P))<2 || T>3) return T;
19701: if(type(L)!=4) L=[L];
19702: F=0;
19703: if(lsort(L,varargs(dn(P))[1],2)!=[]) F=128;
19704: if(lsort(L,varargs(nm(P))[1],2)!=[]) F+=64;
19705: if(lsort(L,vars(dn(P)),2)!=[]) return F+3;
19706: return (lsort(L,vars(nm(P)),2)==[])?(F+1):(F+2);
19707: }
19708:
19709: def nthmodp(X,N,P)
19710: {
19711: X=X%P;
19712: for(Z=1;;){
19713: if((W=iand(N,1))==1) Z=(Z*X)%P;
19714: if((N=(N-W)/2)<=0) return Z;
19715: X=irem(X*X,P);
19716: }
19717: }
19718:
19719: def issquaremodp(X,P)
19720: {
19721: N=getopt(power);
19722: if(!isint(N)) N=2;
19723: if(P<=1 || !isint(P) || !pari(ispsp,P) || !isint(X) || !isint(N) || N<1){
19724: errno(0);
19725: return -2;
19726: }
19727: M=(P-1)/igcd(N,P-1);
19728: if((X%=P) == 0) return 0;
19729: if(X==1 || M==P-1) return 1;
19730: return (nthmodp(X,M,P)==1)?1:-1;
19731: }
19732:
19733: def iscoef(P,F)
19734: {
19735: if(P==0) return 1;
19736: if(type(P)==1) return F(P);
19737: if(type(P)==2) {
19738: X=var(P);
19739: for(I=deg(P,X); I>=0; I--){
19740: if(!iscoef(mycoef(P,I,X),F)) return 0;
19741: }
19742: }else if(type(P)==3){
19743: if(!iscoef(nm(P),F)||!iscoef(dn(P),F)) return 0;
19744: }else if(type(P)==4){
19745: for(;P!=[];P=cdr(P)) if(!iscoef(P,F)) return 0;
19746: }else if(type(P)>4 && type(P)<7) return iscoef(m2l(PP),F);
19747: else return 0;
19748: return 1;
19749: }
19750:
19751: def rootmodp(X,P)
19752: {
19753: X%=P;
19754: if(X==0) return [0];
19755: N=getopt(power);
19756: PP=pari(factor,P);
19757: P0=PP[0][0]; P1=PP[0][1];
19758: P2=pari(phi,P);
19759: if(!isint(N)) N=2;
19760: N%=P2;
19761: if(P0==2 || size(PP)[0]>1){
19762: for(I=1,R=[]; I<P2; I++)
19763: if(nthmodp(I,N,P)==X) R=cons(I,R);
19764: return qsort(R);
19765: }
19766: Y=primroot(P);
19767: if(Y==0) return 0;
19768: Z=nthmodp(Y,N,P);
19769: G=igcd(N,P2);
19770: P3=P2/G;
19771: for(I=0, W=1; I<P3;I++){
19772: if(W==X) break;
19773: W=(W*Z)%P;
19774: }
19775: if(I==P3) return [];
19776: W=nthmodp(Y,I,P);
19777: Z=nthmodp(Y,P3,P);
19778: for(I=0,R=[];;){
19779: R=cons(W,R);
19780: if(++I>=G) break;
19781: W=(W*Z)%P;
19782: }
19783: return qsort(R);
19784: }
19785:
19786: def primroot(P)
19787: {
19788: PP=pari(factor,P);
19789: P0=PP[0][0]; P1=PP[0][1];
19790: S=size(PP);
19791: if(S[0]>1 || !isint(P) || P0<=2){
19792: print("Not odd prime(power)!");
19793: return 0;
19794: }
19795: if(isint(Ind=getopt(ind))){
19796: Ind %= P;
19797: if(Ind<=0 || igcd(Ind,P)!=1 || (Z=primroot(P))==0){
19798: print("Not exist!");
19799: return 0;
19800: }
19801: P2=P0^(P1-1)*(P0-1);
19802: for(I=1,S=1; I<P2; I++)
19803: if((S = (S*Z)%P) == Ind) return I;
19804: return 0;
19805: }
19806: if(getopt(all)==1){
19807: I=primroot(P);
19808: P2=P0^(P1-1)*(P0-1);
19809: for(L=[],J=1; J<P2; J++){
19810: if(P1>1 && igcd(P0,J)!=1) continue;
19811: if(igcd(P0-1,J)!=1) continue;
19812: L=cons(nthmodp(I,J,P),L);
19813: }
19814: return qsort(L);
19815: }
19816: if(PP[0][1]>1){
19817: I=primroot(P0);
19818: P2=P0^(P1-2)*(P0-1);
19819: if(nthmodp(I,P2,P)==1) I+=P0;
19820: return I;
19821: }
19822: F=pari(factor,P-1);
19823: SF=size(F)[0];
19824: for(I=2; I<P; I++){
19825: for(J=0; J<SF; J++)
19826: if(nthmodp(I,(P-1)/F[J][0],P)==1) break;
19827: if(J==SF) return I;
19828: }
19829: }
19830:
19831: def rabin(P,X)
19832: {
19833: for(M=0,Q=P-1;iand(Q,1)==0;M++,Q/=2);
19834: Z=nthmodp(X,Q,P);
19835: for(N=M;M>0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P);
19836: return (M<N&&(M==0||Z==1))?0:1;
19837: }
19838:
19839: def powprimroot(P,N)
19840: {
19841: if(P<3) P=3;
19842: FE=getopt(exp);
19843: if(FE!=1) FE=0;
19844: if((Log=getopt(log))==1||Log==2) FE=-1;
19845: else if(Log==3){
19846: FE=-2;
19847: for(PP=1, L0=["$r$","$p/a$"];;){
19848: PP=pari(nextprime,PP+1);
19849: if(PP>=P) break;
19850: L0=cons(PP, L0);
19851: }
19852: L0=reverse(L0);
19853: }
19854: if(FE==0) All=getopt(all);
19855: for(I=0, PP=P, LL=[]; I<N; I++,PP++){
19856: PP=pari(nextprime,PP);
19857: if(All==1){
19858: PR=primroot(PP|all=1);
19859: LL=cons(cons(PP,PR),LL);
19860: continue;
19861: }
19862: PR=primroot(PP);
19863: if(FE==-2){ /* log=3 */
19864: LT=cdr(L0);LT=cdr(L0);
19865: for(L=[PP];LT!=[];LT=cdr(LT))
19866: L=cons(primroot(PP|ind=car(LT)),L);
19867: LL=cons(reverse(L),LL);
19868: if(I<N-1) L0=append(L0,[PP]);
19869: }else if(FE){
19870: for(J=1, L=[PP], K=1; J<PP; J++){
19871: if(FE==-1){ /* log=1,2 */
19872: K=primroot(PP|ind=J);
19873: if(K==0 && Log==2) K=PP-1;
19874: }
19875: else K=(K*PR)%PP; /* exp=1 */
19876: L=cons(K,L);
19877: }
19878: LL=cons(reverse(L),LL);
19879: }else
19880: LL=cons([PP,PR],LL); /* default */
19881: }
19882: LL=reverse(LL);
19883: if(!FE) return LL;
19884: PP--;
19885: if(FE==-2) return append(LL,[L0]);
19886: for(I=1,L=["$p$"];I<PP; I++) L=cons(I,L);
19887: return cons(reverse(L),LL);
19888: }
19889:
19890: def ntable(F,II,D)
19891: {
19892: F=f2df(F|opt=-1);
19893: Df=getopt(dif);
1.16 takayama 19894: Str=getopt(str);
1.6 takayama 19895: if(Df!=1) Df=0;
1.16 takayama 19896: L=[];
19897: if(type(D)==4){
19898: if(type(II[0])==4){
19899: T1=II[0][1]-II[0][0];T2=II[1][1]-II[1][0];
19900: for(L0=[],I=0;I<D[0];I++){
19901: for(R=[],J=0;J<D[1];J++)
19902: R=cons(myf2eval(F,II[0][0]+I*T1/D[0],II[1][0]+J*T2/D[1]),R);
19903: L=cons(reverse(R),L);L0=cons(II[0][0]+I*T1/D[0],L0);
19904: }
19905: }else{
19906: for(T=II[1]-II[0],L0=[],I=0;I<D[0];I++){
19907: for(R=[],J=0;J<D[1];J++)
19908: R=cons(myfdeval(F,II[0]+I*T/D[0]+J*T/D[0]/D[1]),R);
19909: L=cons(reverse(R),L);L0=cons(II[0]+I*T/D[0],L0);
19910: }
19911: }
19912: L=reverse(L);L0=reverse(L0);
19913: if(type(Str)==4){
19914: L0=mtransbys(os_md.sint,L0,[Str[0]]|str=1,zero=0);
19915: L=mtransbys(os_md.sint,L,[Str[1]]|str=1,zero=0);
19916: if(Df==1){
19917: for(DT=[],RT=L,I=0;RT!=[];){
19918: for(LT=[],TT=car(RT);TT!=[];TT=cdr(TT)){
19919: VV=car(TT);
19920: if((J=str_char(VV,0,"."))>=0){
19921: if(J==0) VV=str_cut(VV,1,10000);
19922: else VV=str_cut(VV,0,J-1)+str_cut(VV,J+1,10000);
19923: }
19924: V1=eval_str(VV);
19925: if(I++) LT=cons(V1-V0,LT);
19926: V0=V1;
19927: }
19928: DT=cons(LT,DT);
19929: if((RT=cdr(RT))==[]){
19930: VE=rint(myfdeval(F,II[1])*10^Str[1]);
19931: DT=cons([VE-V0],DT);
19932: }
19933: }
19934: for(I=0,D=[],TT=DT;TT!=[];TT=cdr(TT)){
19935: if(!I++) V=car(TT)[0];
19936: else{
19937: T1=reverse(cons(V,car(TT)));
19938: V=car(T1);
19939: if(length(TT)>1) T1=cdr(T1);
19940: D=cons(T1,D);
19941: }
19942: }
19943: for(DD=[],TT=D;TT!=[];TT=cdr(TT))
19944: DD=cons([os_md.lmin(car(TT)),os_md.lmax(car(TT))],DD);
19945: DD=reverse(DD);
19946: L=lsort(L,DD,"append");
19947: }
19948: }
19949: L=lsort(L,L0,"cons");
19950: if(type(Top=getopt(top))==4||getopt(TeX)==1){
19951: if(type(Top)==4){
19952: K=length(L[0])-length(Top);
19953: if(K>0&&K<4){
19954: if(K>1){
19955: Top=append(Top,["",""]);
19956: K-=2;
19957: }
19958: if(K) Top=cons("",Top);
19959: }
19960: L=cons(Top,L);
19961: }
19962: if(type(H=getopt(hline))!=4) H=[0,1,z];
19963: if(type(V=getopt(vline))!=4) V=[0,1,(DF)?z-2:z];
19964: if(type(T=getopt(title))!=7) Out=ltotex(L|opt="tab",hline=H,vline=V);
19965: else Out=ltotex(L|opt="tab",hline=H,vline=V,title=T);
19966: if(Df) Out=str_subst(Out,"\\hline","\\cline{1-"+rtostr(length(L[0])-2)+"}");
19967: return Out;
19968: }
19969: return L;
19970: }
1.6 takayama 19971: for(L=[],I=0;I<=D;I++){
19972: X=II[0]+I*T/D;
19973: L=cons([X,myfdeval(F,X)],L);
19974: }
19975: if(Df==1){
19976: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
19977: if(LD==[]) LD=cons([car(LL)[0],car(LL)[1],0],LD);
19978: else LD=cons([car(LL)[0],car(LL)[1],abs(car(LL)[1]-car(LD)[1])],LD);
19979: }
19980: L=reverse(LD);
19981: }
1.16 takayama 19982: if(type(Str)==4){
1.6 takayama 19983: if(length(Str)==1) Str=[Str[0],Str[0]];
1.16 takayama 19984: if(Df==1 && length(Str)==2) Str=[Str[0],Str[1],Str[1]];
1.6 takayama 19985: for(S=Str,Str=[];S!=[];S=cdr(S)){
19986: if(type(car(S))!=4) Str=cons([car(S),3],Str);
19987: else Str=cons(car(S),Str);
19988: }
19989: Str=reverse(Str);
19990: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
19991: for(K=[],J=length(Str); --J>=0; )
19992: K=cons(sint(car(LL)[J],Str[J][0]|str=Str[J][1]),K);
19993: LD=cons(K,LD);
19994: }
19995: L=LD;
19996: }else
19997: L=reverse(L);
19998: if(type(M=getopt(mult))==1){
19999: Opt=[["opt","tab"],["vline",[[0,2+Df]]],["width",-M]];
20000: if(type(T=getopt(title))==7)
20001: Opt=cons(["title",T],Opt);
20002: if(type(Tp=getopt(top))==4)
20003: Opt=cons(["top",Tp],Opt);
20004: L=ltotex(L|option_list=Opt);
20005: }
20006: return L;
20007: }
20008:
20009: def distpoint(L)
20010: {
20011: L=m2l(L|flat=1);
20012: if(getopt(div)==5) Div=5;
20013: else Div=10;
20014: V=newvect(100/Div);
20015: for(LT=L,LL=[],N=0; LT!=[]; LT=cdr(LT)){
20016: if(type(K=car(LT))>1||K<0){
20017: N++; continue;
20018: }
20019: LL=cons(K,LL);
20020: T=idiv(K,Div);
20021: if(Div==10 && T>=9) T=9;
20022: else if(Div==5 && T>=19) T=19;
20023: V[T]++;
20024: }
20025: V=vtol(V);
20026: if((Opt=getopt(opt))=="data") return V;
20027: Title=getopt(title);
20028: OpList=[["opt","tab"]];
20029: if(type(Title=getopt(title)) == 7)
20030: OpList=cons(["title",Title],OpList);
20031: if(Opt=="average"){
20032: T=isMs()?["平均点","標準偏差","最低点","最高点","受験人数"]:
20033: ["average","deviation","min","max","examinees"];
20034: L=average(LL);
20035: L=[sint(L[0],1),sint(L[1],1),L[3],L[4],L[2]];
20036: if(N>0){
20037: T=append(T,[isMs()?"欠席者":"absentees"]);L=append(L,[N]);
20038: }
20039: OpList=cons(["align","c"],OpList);
20040: return ltotex([T,L]|option_list=OpList);
20041: }
20042:
20043: if(getopt(opt)=="graph"){
20044: Mul=getopt(size);
20045: if(Div==5){
20046: V0=["00","05","10","15","20","25","30","35","40","45","50","55",
20047: "60","65","70","75","80","85","90","95"];
20048: if(type(Mul)!=4){
20049: Size = (TikZ)?[12,3,1/2,0.2]:[120,30,1/2,2];
20050: }
20051: }else{
20052: V0=["00-","10-","20-","30-","40-","50-","60-","70-","80-","90-"];
20053: if(type(Mul)!=4){
20054: Size = (TikZ)?[8,3,1/2,0.2]:[80,30,1/2,2];
20055: }
20056: }
20057: return ltotex([V,V0]|opt="graph",size=Size);
20058: }
20059: if(Div==5)
20060: V0=["00--04","05--09","10--14","15--19", "20--24", "25--29", "30--34", "35-39",
20061: "40--44", "45--49","50--54", "55--59","60--64", "65--69",
20062: "70--74", "75--79","80--84", "85--89","90--94", "95--100"];
20063: else
20064: V0=["00--09","10--19","20--29","30--39","40--49","50--59","60--69",
20065: "70--79","80--89","90--100"];
20066: Title=getopt(title);
20067: return ltotex([V0,V]|option_list=OpList);
20068: }
20069:
20070: def keyin(S)
20071: {
20072: print(S,2);
20073: purge_stdin();
20074: S=get_line();
20075: L=length(S=strtoascii(S));
20076: if(L==0) return "";
20077: return str_cut(S,0,L-2);
20078: }
20079:
20080: def init() {
1.16 takayama 20081: LS=["DIROUT","DVIOUTA","DVIOUTB","DVIOUTH","DVIOUTL","TeXLim","TeXEq","TikZ",
1.6 takayama 20082: "XYPrec","XYcm","Canvas"];
20083: if(!access(get_rootdir()+"/help/os_muldif.dvi")||!access(get_rootdir()+"/help/os_muldif.pdf"))
20084: mycat(["Put os_muldif.dvi and os_muldif.pdf in", get_rootdir()+(isMs()?"\\help.":"/help.")]);
20085: if(!isMs()){
20086: DIROUT="%HOME%/asir/tex";
20087: DVIOUTA=str_subst(DVIOUTA,[["\\","/"],[".bat",".sh"]],0);
20088: DVIOUTB=str_subst(DVIOUTB,[["\\","/"],[".bat",".sh"]],0);
20089: DVIOUTL=str_subst(DVIOUTL,[["\\","/"],[".bat",".sh"]],0);
20090: DVIOUTH="%ASIRROOT%/help/os_muldif.pdf";
20091: }
20092: Home=getenv("HOME");
20093: if(type(Home)!=7) Home="";
20094: for(Id=-7, F=Home; Id<-1;){
20095: G = F+"/.muldif";
20096: if(access(G)) Id = open_file(G);
20097: else Id++;
20098: if(Id==-6) F+="/asir";
20099: else if(Id==-5) F=get_rootdir();
20100: else if(Id==-4) F+="/bin";
20101: else if(Id==-3) F=get_rootdir()+"/lib-asir-contrib";
20102: }
20103: if(Id>=0){
20104: while((S=get_line(Id))!=0){
1.18 takayama 20105: if(type(P=str_str(S,LS))==4 && (P0=str_char(S,P[1]+4,"="))>0){
1.6 takayama 20106: if(P[0]<5){
20107: P0=str_chr(S,P0+1,"\"");
20108: if(P0>0){
20109: for(P1=P0;(P2=str_char(S,P1+1,"\""))>0; P1=P2);
20110: if(P1>P0+1){
20111: SS=str_cut(S,P0+1,P1-1);
20112: SS=str_subst(SS,["\\\\","\\\""],["\\","\""]);
20113: if(P[0]==0) DIROUT=SS;
20114: else if(P[0]==1) DVIOUTA=SS;
20115: else if(P[0]==2) DVIOUTB=SS;
20116: else if(P[0]==3) DVIOUTH=SS;
20117: else if(P[0]==4) DVIOUTL=SS;
20118: }
20119: }
20120: if(P0<0 || P1<P0+2) mycat(["Error! Definiton of", LS[P[0]],
20121: "in .muldif"]);
20122: }else{
20123: SV=eval_str(str_cut(S,P0+1,str_len(S)-1));
1.16 takayama 20124: if(P[0]==5) TeXLim=SV;
20125: else if(P[0]==6) TeXEq=SV;
20126: else if(P[0]==7) TikZ=SV;
20127: else if(P[0]==8) XYPrec=SV;
20128: else if(P[0]==9) XYcm=SV;
1.18 takayama 20129: else if(P[0]==10) Canvas=SV;
1.6 takayama 20130: }
20131: }
20132: }
20133: close_file(Id);
20134: }
20135: chkfun(1,0);
20136: }
20137:
20138: #ifdef USEMODULE
20139: endmodule;
20140: os_md.init()$
20141: #else
20142: init()$
20143: #endif
20144:
20145: end$