![[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.74 ! takayama 1: /* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.73 2020/09/30 05:07:55 takayama Exp $ */
1.57 takayama 2: /* The latest version will be at https://www.ms.u-tokyo.ac.jp/~oshima/index-j.html
1.6 takayama 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.72 takayama 9: * Toshio Oshima (Nov. 2007 - Sep. 2020)
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$
1.70 takayama 24: static TeXPages$
1.6 takayama 25: static DIROUT$
1.16 takayama 26: static DIROUTD$
1.6 takayama 27: static DVIOUTL$
28: static DVIOUTA$
29: static DVIOUTB$
30: static DVIOUTH$
31: static DVIOUTF$
32: static LCOPT$
33: static COLOPT$
34: static LPOPT$
35: static LFOPT$
36: static ErMsg$
37: static FLIST$
38: static IsYes$
39: static XYPrec$
40: static XYcm$
41: static TikZ$
42: static XYLim$
43: static Canvas$
44: static ID_PLOT$
45: static Rand$
46: static LQS$
1.45 takayama 47: static SVORG$
1.6 takayama 48: localf spType2$
49: localf erno$
50: localf chkfun$
51: localf makev$
52: localf shortv$
53: localf makenewv$
54: localf vweyl$
55: localf mycat$
56: localf mycat0$
1.9 takayama 57: localf fcat$
1.6 takayama 58: localf findin$
59: localf countin$
60: localf mycoef$
61: localf mydiff$
62: localf myediff$
1.56 takayama 63: localf mypdiff$
64: localf pTaylor$
1.57 takayama 65: localf pwTaylor$
1.6 takayama 66: localf m2l$
67: localf m2ll$
68: localf mydeg$
69: localf pfctr$
70: localf mymindeg$
71: localf m1div$
72: localf mulsubst$
73: localf cmpsimple$
74: localf simplify$
75: localf monotos$
76: localf minustos$
77: localf monototex$
78: localf vnext$
79: localf ldict$
80: localf ndict$
81: localf nextsub$
82: localf nextpart$
83: localf transpart$
84: localf trpos$
85: localf sprod$
86: localf sinv$
87: localf slen$
88: localf sord$
89: localf vprod$
90: localf dvangle$
91: localf dvprod$
92: localf dnorm$
1.71 takayama 93: localf dext$
1.6 takayama 94: localf mulseries$
95: localf pluspower$
96: localf vtozv$
97: localf dupmat$
98: localf matrtop$
99: localf mytrace$
100: localf mydet$
1.71 takayama 101: localf permanent$
1.6 takayama 102: localf mperm$
103: localf mtranspose$
104: localf mtoupper$
105: localf mydet2$
106: localf myrank$
107: localf meigen$
108: localf transm$
109: localf vgen$
110: localf mmc$
111: localf lpgcd$
112: localf mdivisor$
113: localf mdsimplify$
114: localf m2mc$
115: localf easierpol$
116: localf paracmpl$
117: localf mykernel$
118: localf myimage$
119: localf mymod$
120: localf mmod$
121: localf ladd$
1.71 takayama 122: localf lsub$
1.6 takayama 123: localf lchange$
124: localf llsize$
125: localf llbase$
1.60 takayama 126: localf llget$
1.6 takayama 127: localf lsort$
1.44 takayama 128: localf rsort$
1.22 takayama 129: localf lpair$
1.6 takayama 130: localf lmax$
131: localf lmin$
132: localf lgcd$
133: localf llcm$
134: localf ldev$
135: localf lsol$
136: localf lnsol$
137: localf l2p$
138: localf m2v$
139: localf lv2m$
140: localf m2lv$
141: localf s2m$
142: localf c2m$
143: localf m2diag$
144: localf myinv$
145: localf madjust$
146: localf mpower$
147: localf mrot$
148: localf texlen$
149: localf isdif$
1.69 takayama 150: localf isfctr$
1.6 takayama 151: localf fctrtos$
152: localf texlim$
153: localf fmult$
154: localf radd$
155: localf getel$
156: localf ptol$
157: localf rmul$
158: localf mtransbys$
1.58 takayama 159: localf trcolor$
1.61 takayama 160: localf mcolor$
1.6 takayama 161: localf drawopt$
162: localf execdraw$
163: localf execproc$
164: localf myswap$
165: localf mysubst$
166: localf evals$
167: localf myval$
168: localf myeval$
169: localf mydeval$
170: localf myfeval$
171: localf myf2eval$
172: localf myf3eval$
173: localf myfdeval$
174: localf myf2deval$
175: localf myf3deval$
176: localf myexp$
177: localf mycos$
178: localf mysin$
179: localf mytan$
180: localf myarg$
181: localf myasin$
182: localf myacos$
183: localf myatan$
184: localf mylog$
1.57 takayama 185: localf nlog$
1.6 takayama 186: localf mypow$
1.13 takayama 187: localf scale$
1.71 takayama 188: localf iceil$
1.6 takayama 189: localf arg$
190: localf sqrt$
191: localf gamma$
192: localf lngamma$
193: localf digamma$
194: localf dilog$
195: localf zeta$
196: localf eta$
197: localf jell$
198: localf frac$
199: localf erfc$
1.20 takayama 200: localf orthpoly$
201: localf schurpoly$
1.6 takayama 202: localf fouriers$
203: localf todf$
204: localf f2df$
205: localf df2big$
206: localf compdf$
207: localf fzero$
208: localf fmmx$
209: localf flim$
210: localf fcont$
211: localf fresidue$
212: localf mmulbys$
213: localf appldo$
214: localf appledo$
215: localf muldo$
216: localf jacobian$
217: localf hessian$
218: localf wronskian$
219: localf adj$
220: localf laplace1$
221: localf laplace$
222: localf mce$
223: localf mc$
224: localf rede$
225: localf ad$
226: localf add$
227: localf vadd$
228: localf addl$
229: localf cotr$
230: localf rcotr$
231: localf muledo$
232: localf mulpdo$
233: localf transpdosub$
234: localf transpdo$
235: localf translpdo$
236: localf rpdiv$
237: localf mygcd$
238: localf mylcm$
239: localf sftpexp$
240: localf applpdo$
241: localf tranlpdo$
242: localf divdo$
243: localf qdo$
244: localf sqrtdo$
245: localf ghg$
246: localf ev4s$
247: localf b2e$
248: localf sftpow$
249: localf sftpowext$
250: localf polinsft$
251: localf pol2sft$
252: localf polroots$
1.70 takayama 253: localf sgnstrum$
254: localf polstrum$
255: localf polrealroots$
256: localf polradiusroot$
1.6 takayama 257: localf fctri$
258: localf binom$
259: localf expower$
260: localf seriesHG$
261: localf seriesMc$
262: localf seriesTaylor$
1.27 takayama 263: localf mulpolyMod$
1.46 takayama 264: localf solveEq$
1.70 takayama 265: localf res0$
266: localf eqs2tex$
1.45 takayama 267: localf baseODE$
1.70 takayama 268: localf baseODE0$
1.26 takayama 269: localf taylorODE$
1.6 takayama 270: localf evalred$
271: localf toeul$
272: localf fromeul$
273: localf sftexp$
274: localf fractrans$
275: localf soldif$
276: localf chkexp$
277: localf sqrtrat$
278: localf getroot$
279: localf expat$
280: localf polbyroot$
281: localf polbyvalue$
282: localf pcoef$
1.58 takayama 283: localf pmaj$
1.6 takayama 284: localf prehombf$
285: localf prehombfold$
286: localf sub3e$
287: localf fuchs3e$
288: localf okubo3e$
289: localf eosub$
290: localf even4e$
291: localf odd5e$
292: localf extra6e$
293: localf rigid211$
294: localf solpokuboe$
295: localf stoe$
296: localf dform$
297: localf polinvsym$
298: localf polinsym$
299: localf tohomog$
300: localf substblock$
301: localf okuboetos$
302: localf heun$
303: localf fspt$
304: localf abs$
1.20 takayama 305: localf sgn$
1.6 takayama 306: localf calc$
307: localf isint$
308: localf israt$
309: localf iscrat$
310: localf isalpha$
311: localf isnum$
312: localf isalphanum$
1.8 takayama 313: localf isdecimal$
1.6 takayama 314: localf isvar$
315: localf isyes$
316: localf isall$
317: localf iscoef$
318: localf iscombox$
319: localf sproot$
320: localf spgen$
1.53 takayama 321: localf spbasic$
1.6 takayama 322: localf chkspt$
323: localf cterm$
324: localf terms$
325: localf polcut$
326: localf redgrs$
327: localf cutgrs$
328: localf mcgrs$
329: localf mc2grs$
330: localf mcmgrs$
1.38 takayama 331: localf spslm$
1.6 takayama 332: localf anal2sp$
333: localf delopt$
334: localf str_char$
335: localf str_pair$
336: localf str_cut$
337: localf str_str$
338: localf str_subst$
339: localf str_times$
340: localf str_tb$
341: localf strip$
342: localf i2hex$
343: localf sjis2jis$
344: localf jis2sjis$
345: localf s2os$
346: localf l2os$
347: localf r2os$
348: localf s2euc$
349: localf s2sjis$
350: localf r2ma$
351: localf evalma$
1.73 takayama 352: localf evalcoord$
353: localf readTikZ$
1.6 takayama 354: localf ssubgrs$
355: localf verb_tex_form$
356: localf tex_cuteq$
357: localf my_tex_form$
358: localf texket$
359: localf smallmattex$
360: localf divmattex$
361: localf dviout0$
362: localf myhelp$
363: localf isMs$
1.55 takayama 364: localf getline$
1.6 takayama 365: localf showbyshell$
366: localf readcsv$
367: localf tocsv$
368: localf getbyshell$
369: localf show$
370: localf dviout$
371: localf rtotex$
372: localf mtotex$
373: localf ltotex$
374: localf texbegin$
375: localf texcr$
376: localf texsp$
377: localf getbygrs$
378: localf mcop$
379: localf shiftop$
1.56 takayama 380: localf shiftPfaff;
1.6 takayama 381: localf conf1sp$
1.34 takayama 382: localf confexp$
1.36 takayama 383: localf confspt$
1.50 takayama 384: localf mcvm$
1.44 takayama 385: localf s2csp$
1.38 takayama 386: localf partspt$
1.6 takayama 387: localf pgen$
388: localf diagm$
389: localf mgen$
390: localf madj$
391: localf newbmat$
392: localf unim$
393: localf pfrac$
394: localf cfrac$
395: localf cfrac2n$
396: localf sqrt2rat$
397: localf s2sp$
398: localf sp2grs$
399: localf fimag$
400: localf trig2exp$
401: localf intpoly$
402: localf integrate$
1.22 takayama 403: localf rungeKutta$
1.6 takayama 404: localf simplog$
405: localf fshorter$
406: localf isshortneg$
407: localf intrat$
408: localf powsum$
409: localf bernoulli$
410: localf lft01$
411: localf linfrac01$
412: localf nthmodp$
413: localf issquaremodp$
414: localf rootmodp$
415: localf rabin$
416: localf primroot$
417: localf varargs$
418: localf ptype$
419: localf pfargs$
1.58 takayama 420: localf regress$
1.6 takayama 421: localf average$
1.23 takayama 422: localf tobig$
1.6 takayama 423: localf sint$
424: localf frac2n$
1.58 takayama 425: localf openGlib$
1.6 takayama 426: localf xyproc$
427: localf xypos$
428: localf xyput$
429: localf xybox$
430: localf xyline$
431: localf xylines$
432: localf xycirc$
433: localf xybezier$
434: localf lbezier$
435: localf draw_bezier$
436: localf tobezier$
437: localf velbezier$
438: localf ptbezier$
439: localf cutf$
440: localf fsum$
441: localf fint$
442: localf periodicf$
443: localf cmpf$
444: localf areabezier$
445: localf saveproc$
1.57 takayama 446: localf xyplot$
1.63 takayama 447: localf xyaxis$
1.6 takayama 448: localf xygraph$
449: localf xy2graph$
1.22 takayama 450: localf addIL$
1.19 takayama 451: localf xy2curve$
1.18 takayama 452: localf xygrid$
1.6 takayama 453: localf xyarrow$
454: localf xyarrows$
455: localf xyang$
456: localf xyoval$
1.33 takayama 457: localf xypoch$
1.72 takayama 458: localf xycircuit$
1.70 takayama 459: localf ptline$
1.6 takayama 460: localf ptcommon$
1.71 takayama 461: localf ptcontain$
1.6 takayama 462: localf ptcopy$
463: localf ptaffine$
464: localf ptlattice$
465: localf ptpolygon$
466: localf ptwindow$
1.70 takayama 467: localf ptconvex$
1.6 takayama 468: localf ptbbox$
1.71 takayama 469: localf darg$
470: localf dwinding$
1.6 takayama 471: localf lninbox$
472: localf ptcombezier$
473: localf ptcombz$
474: localf lchange$
475: localf init$
476: localf powprimroot$
477: localf distpoint$
478: localf ntable$
479: localf keyin$
480: localf mqsub$
481: localf msort$
482: #else
483: extern Muldif.rr$
484: extern TeXEq$
485: extern TeXLim$
1.70 takayama 486: extern TeXPages$
1.6 takayama 487: extern DIROUT$
1.16 takayama 488: extern DIROUTD$
1.6 takayama 489: extern DVIOUTL$
490: extern DVIOUTA$
491: extern DVIOUTB$
492: extern DVIOUTH$
493: extern DVIOUTF$
494: static LCOPT$
495: static COLOPT$
496: static LPOPT$
497: static LFOPT$
498: extern TikZ$
499: extern ErMsg$
500: extern FLIST$
501: extern IsYes$
502: extern XYPrec$
503: extern XYcm$
504: extern TikZ$
505: extern XYLim$
1.70 takayama 506: extern TeXPages$
1.6 takayama 507: extern Canvas$
508: extern ID_PLOT$
509: extern Rand$
510: extern LQS$
1.57 takayama 511: extern SV=SVORG$
1.6 takayama 512: #endif
513: static S_Fc,S_Dc,S_Ic,S_Ec,S_EC,S_Lc$
1.16 takayama 514: static S_FDot$
1.6 takayama 515: extern AMSTeX$
1.58 takayama 516: extern Glib_math_coordinate$
517: extern Glib_canvas_x$
518: extern Glib_canvas_y$
1.73 takayama 519: Muldif.rr="00200928"$
1.6 takayama 520: AMSTeX=1$
521: TeXEq=5$
522: TeXLim=80$
1.70 takayama 523: TeXPages=20$
1.6 takayama 524: TikZ=0$
525: XYcm=0$
526: XYPrec=3$
527: XYLim=4$
528: Rand=0$
529: DIROUT="%HOME%\\tex"$
530: DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$
531: DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$
532: DVIOUTB="%ASIRROOT%\\bin\\risatex1%TikZ%.bat"$
533: DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$
534: DVIOUTF=0$
535: LCOPT=["red","green","blue","yellow","cyan","magenta","black","white","gray"]$
536: COLOPT=[0xff,0xff00,0xff0000,0xffff,0xffff00,0xff00ff,0,0xffffff,0xc0c0c0]$
537: LPOPT=["above","below","left","right"]$
538: LFOPT=["very thin","thin","dotted","dashed"]$
1.45 takayama 539: SVORG=["x","y","z","w","u","v","p","q","r","s"]$
1.6 takayama 540: Canvas=[400,400]$
541: LQS=[[1,0]]$
542:
543: ErMsg = newvect(3,[
544: "irregal argument", /* 0 */
545: "too big size", /* 1 */
546: "irregal option" /* 2 */
547: ])$
548: FLIST=0$
549: IsYes=[]$
550: ID_PLOT=-1$
551:
552: def erno(N)
553: {
554: /* extern ErMsg; */
555: print(ErMsg[N]);
556: }
557:
558: def chkfun(Fu, Fi)
559: {
560: /* extern FLIST; */
561: /* extern Muldif.rr; */
562:
563: if(type(Fu) <= 1){
564: if(Fu==1)
565: mycat(["Loaded os_muldif Ver.", Muldif.rr, "(Toshio Oshima)"]);
566: else
567: mycat(["Risa/Asir Ver.", version()]);
568: return 1;
569: }
570: if(type(FLIST) < 4)
571: FLIST = flist();
572: if(type(Fu) == 4){
573: for(; Fu != [] ;Fu = cdr(Fu))
574: if(chkfun(car(Fu),Fi) == 0) return 0;
575: return 1;
576: }
577: if(findin(Fu, FLIST) >= 0)
578: return 1;
579: FLIST = flist();
580: if(findin(Fu, FLIST) >= 0)
581: return 1;
582: if(type(Fi)==7){
583: mycat0(["load(\"", Fi,"\") -> try again!\n"],1);
584: load(Fi);
585: }
586: return 0;
587: /*
588: if(type(Fi) == 7)
589: Fi = [Fi];
590: for( ; Fi != []; Fi = cdr(Fi))
591: load(car(Fi));
592: FLIST = flist();
593: return (findin(Fu,FLIST)>=0)?1:0;
594: */
595: }
596:
597: def makev(L)
598: {
599: S = "";
600: Num=getopt(num);
601: while(length(L) > 0){
602: VL = car(L); L = cdr(L);
603: if(type(VL) == 7)
604: S = S+VL;
605: else if(type(VL) == 2 || VL < 10)
606: S = S+rtostr(VL);
607: else if(VL<46 && Num!=1)
608: S = S+asciitostr([VL+87]);
609: else
610: S = S+rtostr(VL);
611: }
612: return strtov(S);
613: }
614:
615: def makenewv(L)
616: {
617: if((V=getopt(var))<2) V="z_";
618: else if(isvar(V)) V=rtostr(V);
619: if(type(N=getopt(num))!=1) N=0;
1.21 takayama 620: Var=varargs(L|all=2);
1.6 takayama 621: for(XX=[],I=J=0;;I++){
622: X=strtov(V+rtostr(I));
623: if(findin(X,Var)<0){
624: XX=cons(X,XX);
625: if(++J>N) return X;
626: else if(J==N) return reverse(XX);
627: }
628: }
629: }
630:
631: def shortv(P,L)
632: {
633: V=vars(P);
634: if(type(T=getopt(top))==2) T=strtoascii(rtostr(T))[0]-87;
635: else T=10;
636: for(;L!=[];L=cdr(L)){
637: for(J=0;J<36;J++){
638: if(findin(X=makev([car(L),J]|num=1),V)>=0){
639: while(findin(Y=makev([T]),V)>=0) T++;
640: if(T>35) return P;
641: P=subst(P,X,Y);
642: T++;
643: }else if(J>0) break;
644: }
645: }
646: return P;
647: }
648:
649: def vweyl(L)
650: {
651: if(type(L) == 4){
652: if(length(L) == 2)
653: return L;
654: else
655: return [L[0],makev(["d",L[0]])];
656: }
657: /* else if(type(L)<2) return L; */
658: return [L,makev(["d", L])];
659: }
660:
661: def mycat(L)
662: {
663: if(type(L) != 4){
664: print(L);
665: return;
666: }
667: Opt = getopt(delim);
668: Del = (type(Opt) >= 0)?Opt:" ";
669: Opt = getopt(cr);
670: CR = (type(Opt) >= 0)?0:1;
671: while(L != []){
672: if(Do==1)
673: print(Del,0);
674: print(car(L),0);
675: L=cdr(L);
676: Do = 1;
677: }
678: if(CR) print("");
1.46 takayama 679: else print("",2);
1.6 takayama 680: }
681:
1.9 takayama 682: def fcat(S,X)
683: {
684: if(type(S)!=7){
1.18 takayama 685: if(type(DIROUTD)!=7){
686: DIROUTD=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],
687: [getenv("HOME"),get_rootdir(),"/"])+"/";
688: if(isMs()) DIROUTD=str_subst(DIROUTD,"/","\\"|sjis=1);
689: }
1.16 takayama 690: T="fcat";
691: if(S>=2&&S<=9) T+=rtostr(S);
692: T=DIROUTD+T+".txt";
693: if(S==-1) return T;
694: if(S!=0&&access(T)) remove_file(T);
695: S=T;
1.9 takayama 696: }
1.19 takayama 697: R=output(S);
1.9 takayama 698: print(X);
699: output();
1.16 takayama 700: if(getopt(exe)==1) shell("\""+S+"\"");
1.19 takayama 701: return R;
1.9 takayama 702: }
703:
1.6 takayama 704: def mycat0(L,T)
705: {
706: Opt = getopt(delim);
707: Del = (type(Opt) >= 0)?Opt:"";
1.20 takayama 708: if(type(L)!=4) L=[L];
1.6 takayama 709: while(L != []){
710: if(Do==1)
711: print(Del,0);
712: print(car(L),0);
713: L=cdr(L);
714: Do = 1;
715: }
716: if(T) print("");
1.46 takayama 717: else print("",2);
1.6 takayama 718: }
719:
720: def findin(M,L)
721: {
722: if(type(L)==4){
723: for(I = 0; L != []; L = cdr(L), I++)
724: if(car(L) == M) return I;
725: }else if(type(L)==5){
726: K=length(L);
727: for(I = 0; I < K; I++)
728: if(L[I] == M) return I;
729: }else return -2;
730: return -1;
731: }
732:
733: def countin(S,M,L)
734: {
1.10 takayama 735: Step=getopt(step);
736: if(type(Step)==1){
737: N=(Step>0)?Step:-Step;
1.7 takayama 738: if(type(L)==5) L=vtol(L);
739: L=qsort(L);
740: while(car(L)<S&&L!=[]) L=cdr(L);
741: S+=M;
1.10 takayama 742: for(R=[],C=I=0;L!=[];){
743: if(car(L)<S||(Step>0&&car(L)==S)){
1.7 takayama 744: C++;
745: L=cdr(L);
746: }else{
747: R=cons(C,R);C=0;S+=M;
1.10 takayama 748: if(N>1&&++I>=N) break;
1.7 takayama 749: }
750: }
751: if(C>0) R=cons(C,R);
1.10 takayama 752: if(N>1&&(N-=length(R))>0) while(N-->0) R=cons(0,R);
1.7 takayama 753: return reverse(R);
754: }
1.6 takayama 755: if(type(L)==4){
756: for(N=0; L!=[]; L=cdr(L))
757: if(car(L)>=S && car(L)<=M) N++;
758: }else if(type(L)==5){
759: K=length(L);
760: for(I = 0; I < K; I++)
761: if(L[I]>=S && L[I]<=M) N++;
762: }else return -2;
763: return N;
764: }
765:
766: def mycoef(P,N,X)
767: {
768: if(type(P)<3 && type(N)<3)
769: return coef(P,N,X);
770: if(type(P) >= 4)
771: #ifdef USEMODULE
772: return map(os_md.mycoef,P,N,X);
773: #else
774: return map(mycoef,P,N,X);
775: #endif
776: if(type(N)==4){
777: for(;N!=[];N=cdr(N),X=cdr(X))
778: P=mycoef(P,car(N),car(X));
779: return P;
780: }
781: if(deg(dn(P), X) > 0){
782: P = red(P);
783: if(deg(dn(P), X) > 0)
784: return 0;
785: }
786: return red(coef(nm(P),N,X)/dn(P));
787: }
788:
789: def mydiff(P,X)
790: {
791: if(X == 0)
792: return 0;
793: if(type(P)<3 && type(X)<3)
794: return diff(P,X);
795: if(type(P) >= 4)
796: #ifdef USEMODULE
797: return map(os_md.mydiff,P,X);
798: #else
799: return map(mydiff,P,X);
800: #endif
801: if(type(X)==4){
802: for(;X!=[];X=cdr(X)) P=mydiff(P,car(X));
803: return P;
804: }
1.19 takayama 805: if(ptype(dn(P),X)<2)
1.6 takayama 806: return red(diff(nm(P),X)/dn(P));
807: return red(diff(P,X));
808: }
809:
810: def myediff(P,X)
811: {
812: if(X == 0)
813: return 0;
814: if(type(P) < 3)
815: return ediff(P,X);
816: if(type(P) >= 4)
817: #ifdef USEMODULE
818: return map(os_md.myediff,P,X);
819: #else
820: return map(myediff,P,X);
821: #endif
822: if(deg(dn(P),X) == 0)
823: return red(ediff(nm(P),X)/dn(P));
824: return red(X*diff(P,X));
825: }
826:
1.56 takayama 827: def mypdiff(P,L)
828: {
829: if(type(P)>3) return map(os_md.mypdiff,P,L);
830: for(Q=0;L!=[];L=cdr(L)){
831: Q+=mydiff(P,car(L))*L[1];
832: L=cdr(L);
833: }
834: return red(Q);
835: }
836:
1.57 takayama 837: def pTaylor(S,X,N)
1.56 takayama 838: {
1.57 takayama 839: if(!isvar(T=getopt(time))) T=t;
840: if(type(S)<4) S=[S];
841: if(type(X)<4) X=[X];
842: if(findin(T,varargs(S|all=2))>=0){
843: S=cons(z_z,S);X=cons(z_z,X);FT=1;
844: }else FT=0;
845: LS=length(S);
846: FR=(getopt(raw)==1)?1:0;
847: if(!FR) R=newvect(LS);
1.56 takayama 848: else R=R1=[];
1.57 takayama 849: for(L=[],I=0,TS=S,TX=X;I<LS;I++,TS=cdr(TS),TX=cdr(TX)){
850: if(!FR) R[I]=car(TX)+car(TS)*T;
1.56 takayama 851: else{
1.57 takayama 852: R=cons(car(TX),R);R1=cons(car(TS),R1);
1.56 takayama 853: }
1.57 takayama 854: L=cons(car(TS),cons(car(TX),L));
1.56 takayama 855: }
1.57 takayama 856: L=reverse(L);
857: if(FR) R=[reverse(R1),reverse(R)];
1.56 takayama 858: for(K=M=1;N>1;N--){
859: S=mypdiff(S,L);
860: K*=++M;
861: for(TS=S,I=0,R1=[];TS!=[];TS=cdr(TS),I++){
1.57 takayama 862: if(!FR) R[I]+=car(TS)*t^M/K;
1.56 takayama 863: else R1=cons(car(TS)/K,R1);
864: }
1.57 takayama 865: if(FR) R=cons(reverse(R1),R);
1.56 takayama 866: }
1.57 takayama 867: if(FT){
868: if(!FR){
1.56 takayama 869: S=newvect(LS-1);
870: for(I=1;I<LS;I++) S[I-1]=R[I];
871: }else{
872: for(S=[];R!=[];R=cdr(R)){
873: S=cons(cdr(car(R)),S);
874: }
875: R=S;
876: }
877: R=subst(S,z_z,0);
878: }
1.57 takayama 879: return (FR&&!FT)?reverse(R):R;
1.56 takayama 880: }
881:
1.6 takayama 882: def m2l(M)
883: {
884: if(type(M) < 4)
885: return [M];
886: if(type(M) == 4){
887: if(type(car(M))==4 && getopt(flat)==1){
888: for(MM = []; M!=[]; M=cdr(M))
889: MM = append(MM,car(M));
890: return MM;
891: }
892: return M;
893: }
894: if(type(M) == 5)
895: return vtol(M);
896: S = size(M);
897: for(MM = [], I = S[0]-1; I >= 0; I--)
898: MM = append(vtol(M[I]), MM);
899: return MM;
900: }
901:
902: def mydeg(P,X)
903: {
1.56 takayama 904: if(type(P) < 3 && type(X)==2)
1.6 takayama 905: return deg(P,X);
1.56 takayama 906: II=(type(X)==4)?-100000:-1;
1.6 takayama 907: Opt = getopt(opt);
908: if(type(P) >= 4){
909: S=(type(P) == 6)?size(P)[0]:0;
910: P = m2l(P);
1.56 takayama 911: for(I = 0, Deg = -100000; P != []; P = cdr(P), I++){
912: if( (DT = mydeg(car(P),X)) == -2&&type(X)!=4)
1.6 takayama 913: return -2;
914: if(DT > Deg){
915: Deg = DT;
916: II = I;
917: }
918: }
919: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
920: }
921: P = red(P);
1.56 takayama 922: if(type(X)==2){
923: if(deg(dn(P),X) == 0)
924: return deg(nm(P),X);
925: }else{
926: P=nm(red(P));
927: for(D=-100000,I=deg(P,X[1]);I>=0;I--){
928: if(TP=mycoef(P,I,X[1])){
929: TD=mydeg(TP,X[0])-I;
930: if(D<TD) D=TD;
931: }
932: }
933: return D;
934: }
1.6 takayama 935: return -2;
936: }
937:
938: def pfctr(P,X)
939: {
940: P=red(P);
941: if((T=ptype(P,X))>3) return [];
942: if(T==3){
943: G=pfctr(dn(P),X);
944: F=pfctr(nm(P),X);
945: R=[[car(F)[0]/car(G)[0],1]];
946: for(F=cdr(F);F!=[];F=cdr(F)) R=cons(car(F),R);
947: for(G=cdr(G);G!=[];G=cdr(G)) R=cons([car(G)[0],-car(G)[1]],R);
948: return reverse(R);
949: }
950: F=fctr(nm(P));
951: for(R=[],C=1/dn(P);F!=[];F=cdr(F))
952: if(mydeg(car(F)[0],X)>0) R=cons(car(F),R);
953: else C*=car(F)[0]^car(F)[1];
954: return cons([C,1],reverse(R));
955: }
956:
957: def mymindeg(P,X)
958: {
959: if(type(P) < 3)
960: return mindeg(P,X);
961: II = -1;T=60;
962: Opt = getopt(opt);
963: if(type(P) >= 4){
964: S=(type(P) == 6)?size(P)[0]:0;
965: P = m2l(P);
966: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
967: if(car(P) == 0)
968: continue;
969: if( (DT = mydeg(car(P),X)) == -2)
970: return -2;
971: if(DT < Deg || Deg == -3){
972: if(DT==0){
973: if(type(car(P))>=T) continue;
974: T=type(car(P));
975: }
976: Deg = DT;
977: II = I;
978: }
979: }
980: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
981: }
982: P = red(P);
983: if(deg(dn(P),X) == 0)
984: return mindeg(nm(P),X);
985: return -2;
986: }
987:
988: def m1div(M,N,L)
989: {
990: L = (type(L) <= 3)?[0,L]:vweyl[L];
991: DX = L[1]; X = L[0];
992: if(mydeg(N,DX) != 0)
993: return 0;
994: DD = mydeg(M,DX);
995: MM = M;
996: while( (Deg=mydeg(MM,DX)) > 0){
997: MC = mycoef(MM,Deg,DX)*DX^(Deg-1);
998: MS = radd(MC, MS);
999: MM = radd(MM, muldo(MC,radd(-DX,N),L));
1000: }
1001: return [MM, MS];
1002: }
1003:
1004:
1005: def mulsubst(F,L)
1006: {
1007: N = length(L);
1008: if(N == 0)
1009: return F;
1010: if(type(L[0])!=4) L=[L];
1.46 takayama 1011: if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]);
1.6 takayama 1012: if(getopt(inv)==1){
1013: for(R=[];L!=[];L=cdr(L)) R=cons([car(L)[1],car(L)[0]],R);
1014: L=reverse(R);
1015: }
1016: if(length(L)==1) return mysubst(F,L);
1017: L1 = newvect(N);
1018: for(J = 0; J < N ; J++)
1019: L1[J] = uc();
1020: L2 = newvect(N);
1021: for(J = 0; J < N; J++){
1022: S = L[J][1];
1023: for(I = 0; I < N; I++)
1024: S = mysubst(S,[L[I][0],L1[I]]);
1025: L2[J] = S;
1026: }
1027: for(J = 0; J < N; J++)
1028: F = mysubst(F, [L[J][0],L2[J]]);
1029: for(J = 0; J < N; J++)
1030: F = mysubst(F, [L1[J],L[J][0]]);
1031: return F;
1032: }
1033:
1034: def cmpsimple(P,Q)
1035: {
1036: T = getopt(comp);
1037: if(P == Q)
1038: return 0;
1039: D = 0;
1040: if(type(T) < 0)
1041: T = 7;
1042: if(iand(T,1))
1043: D = length(vars(P)) - length(vars(Q));
1044: if(!D && iand(T,2))
1045: D = nmono(P) - nmono(Q);
1046: if(!D && iand(T,4))
1047: D = str_len(rtostr(P)) - str_len(rtostr(Q));
1048: if(!D){
1049: if(P > Q) D++;
1050: else D--;
1051: }
1052: return D;
1053: }
1054:
1055: def simplify(P,L,T)
1056: {
1057: if(type(P) > 3)
1058: #ifdef USEMODULE
1059: return map(os_md.simplify,P,L,T);
1060: #else
1061: return map(simplify,P,L,T);
1062: #endif
1063: if(type(L[0]) == 4){
1064: if(length(L[0]) > 1)
1065: #if USEMODULE
1066: return fmult(os_md.simplify,P,L,[T]);
1067: #else
1068: return fmult(simplify,P,L,[T]);
1069: #endif
1070: L = L[0];
1071: }
1072: if(type(Var=getopt(var)) == 4 && Var!=[]){
1073: if(type(P) == 3)
1074: return simplify(nm(P),P,L,T|var=Var)/simplify(dn(P),P,L,T|var=Var);
1075: V = car(Var);
1076: if((I = mydeg(P,V)) > 0){
1077: Var = cdr(Var);
1078: for(Q=0; I>=0 ; I--)
1079: Q += simplify(mycoef(P,I,V), L, T|var=Var)*V^I;
1080: return Q;
1081: }
1082: }
1083: if(length(L) == 1){
1084: L = car(L);
1085: for(V = vars(L); V != []; V = cdr(V)){
1086: VT = car(V);
1087: if(deg(L,VT) != 1) continue;
1088: P = simplify(P, [VT, -red(coef(L,0,VT)/coef(L,1,VT))], T);
1089: }
1090: return P;
1091: }
1092: Q = mysubst(P,[L[0],L[1]]);
1093: return (cmpsimple(P,Q|comp=T) <= 0)?P:Q;
1094: }
1095:
1096: def monotos(P)
1097: {
1098: if(nmono(P) <= 1)
1099: return rtostr(P);
1100: return "("+rtostr(P)+")";
1101: }
1102:
1103:
1104: def monototex(P)
1105: {
1106: Q=my_tex_form(P);
1107: if(nmono(P)<2 && (getopt(minus)!=1 || str_str(Q,"-"|top=0,end=0)<0))
1108: return Q;
1109: return "("+Q+")";
1110: }
1111:
1112: def minustos(S)
1113: {
1114: if(str_str(S,"-"|top=0,end=0)<0) return S;
1115: return "("+S+")";
1116: }
1117:
1118: def vnext(V)
1119: {
1120: S = length(V);
1121: for(I = S-1; I > 0; I--){
1122: if(V[I-1] < V[I]){
1123: V0 = V[I-1];
1124: for(J = I+1; J < S; J++)
1125: if(V0 >= V[J]) break;
1126: V[I-1] = V[--J];
1127: V[J] = V0;
1128: for(J = S-1; I < J; I++, J--){
1129: V0 = V[I];
1130: V[I] = V[J];
1131: V[J] = V0;
1132: }
1133: return 1;
1134: }
1135: }
1136: return 0;
1137: }
1138:
1139: def ldict(N, M)
1140: {
1141: Opt = getopt(opt);
1142: R = S = [];
1143: for(I = 2; N > 0; I++){
1144: R = cons(irem(N,I), R);
1145: N = idiv(N,I);
1146: }
1147: L = LL = length(R);
1148: T=newvect(LL+1);
1149: while(L-- > 0){
1150: V = car(R); R = cdr(R);
1151: for(I = J = 0; J <= V ; I++){
1152: if(T[I] == 0)
1153: J++;
1154: }
1155: T[I-1] = 1;
1156: S = cons(LL-I+1, S);
1157: }
1158: for(I = 0; I <= LL; I++){
1159: if(T[I] == 0){
1160: S = cons(LL-I, S);
1161: break;
1162: }
1163: }
1164: if(M == 0)
1165: return S;
1166: if(M <= LL){
1167: print("too small size");
1168: return 0;
1169: }
1170: T = [];
1171: for(I = --M; I > LL; I--)
1172: T = cons(I,T);
1173: S = append(S,T);
1174: if(Opt == 2 || Opt == 3)
1175: S = reverse(S);
1176: if(Opt != 1 && Opt != 3)
1177: return S;
1178: for(T = []; S != []; S = cdr(S))
1179: T = cons(M-car(S),T);
1180: return T;
1181: }
1182:
1183: def ndict(L)
1184: {
1185: Opt = getopt(opt);
1186: R = [];
1187: if(Opt != 1 && Opt != 2)
1188: L = reverse(L);
1189: T = (Opt == 1 || Opt == 3)?1:0;
1190: for( ; L != []; L = cdr(L)){
1191: for(I = 0, V = car(L), LT = cdr(L); LT != []; LT = cdr(LT))
1192: if(T == 0){
1193: if(V < car(LT)) I++;
1194: }else if (V > car(LT)) I++;
1195: R = cons(I, R);
1196: }
1197: R = reverse(R);
1198: for(V = 0, I = length(R); I > 0; R = cdr(R), I--)
1199: V = V*I + car(R);
1200: return V;
1201: }
1202:
1203: def nextsub(L,N)
1204: {
1205: if(type(L) == 1){
1206: for(LL = [], I = L-1; I >= 0; I--)
1207: LL = cons(I,LL);
1208: return LL;
1209: }
1210: M = length(L = ltov(L));
1211: K = N-M;
1212: for(I = M-1; I >= 0; I--)
1213: if(L[I] < I+K) break;
1214: if(I < 0)
1215: return 0;
1216: for(J = L[I]+1; I < M; I++, J++)
1217: L[I] = J;
1218: return vtol(L);
1219: }
1220:
1221: def nextpart(L)
1222: {
1223: if(car(L) <= 1)
1224: return 0;
1225: for(I = 0, L = reverse(L); car(L) == 1; L=cdr(L))
1226: I++;
1227: I += (K = car(L));
1228: R = irem(I,--K);
1229: R = (R==0)?[]:[R];
1230: for(J = idiv(I,K); J > 0; J--)
1231: R = cons(K,R);
1232: L = cdr(L);
1233: while(L!=[]){
1234: R = cons(car(L), R);
1235: L = cdr(L);
1236: }
1237: return R;
1238: }
1239:
1240: def transpart(L)
1241: {
1242: L = reverse(L);
1243: for(I=1, R=[]; L!= []; I++){
1244: R = cons(length(L), R);
1245: while(L != [] && car(L) <= I)
1246: L = cdr(L);
1247: }
1248: return reverse(R);
1249: }
1250:
1251: def trpos(A,B,N)
1252: {
1253: S = newvect(N);
1254: for(I = 0; I < N; I++)
1255: S[I]=(I==A)?B:((I==B)?A:I);
1256: return S;
1257: }
1258:
1259: def sprod(S,T)
1260: {
1261: L = length(S);
1262: V = newvect(L);
1263: while(--L >= 0)
1264: V[L] = S[T[L]];
1265: return V;
1266: }
1267:
1268: def sinv(S)
1269: {
1270: L = length(S);
1271: V = newvect(L);
1272: while(--L >= 0)
1273: V[S[L]] = L;
1274: return V;
1275: }
1276:
1277: def slen(S)
1278: {
1279: L = length(S);
1280: for(V = 0, J = 2; J < L; i++){
1281: for(I = 0; I < J; I++)
1282: if(S[I] > S[J]) V++;
1283: }
1284: return V;
1285: }
1286:
1287: def sord(W,V)
1288: {
1289: L = length(W);
1290: W0 = nevect(L);
1291: V0 = newvect(L);
1292: for(I = F = C = 0; I < L; I++){
1293: C = 0;
1294: if( (W1 = W[I]) > (V1 = V[I]) ){
1295: if(F < 0) C = 1;
1296: else if(F==0) F = 1;
1297: }else if(W1 < V1){
1298: if(F > 0) C = 1;
1299: else if(F==0) F = -1;
1300: }
1301: for(J = I;--J >= 0 && W0[J] > W1; ) W0[J+1] = W0[J];
1302: W0[J+1] = W1;
1303: for(J = I;--J >= 0 && V0[J] > V1; ) V0[J+1] = V0[J];
1304: V0[J+1] = V1;
1305: if(C){
1306: for(J = I; J >= 0; J--){
1307: if((W1=W0[J]) == (V1=V0[J])) continue;
1308: if(W1 > V1){
1309: if(F < 0) return 2;
1310: }
1311: else if(F > 0) return 2;
1312: }
1313: }
1314: }
1315: return F;
1316: }
1317:
1318: def vprod(V1,V2)
1319: {
1.71 takayama 1320: V1=lsub(V1);V2=lsub(V2);
1.6 takayama 1321: for(R = 0, I = length(V1)-1; I >= 0; I--)
1322: R = radd(R, rmul(V1[I], V2[I]));
1323: return R;
1324: }
1325:
1326: def dnorm(V)
1327: {
1.61 takayama 1328: if(type(V)<2) return ctrl("bigfloat")?abs(V):dabs(V);
1.58 takayama 1329: if((M=getopt(max))==1||M==2){
1330: if(type(V)==5) V=vtol(V);
1331: for(S=0;V!=[];V=cdr(V)){
1.61 takayama 1332: if(M==2) S+=ctrl("bigfloat")?abs(car(V)):dabs(car(V));
1.58 takayama 1333: else{
1.61 takayama 1334: if((T=ctrl("bigfloat")?abs(car(V)):dabs(car(V)))>S) S=T;
1.58 takayama 1335: }
1336: }
1337: return S;
1338: }
1.6 takayama 1339: R=0;
1340: if(type(V)!=4)
1.58 takayama 1341: for (I = length(V)-1; I >= 0; I--) R+= real(V[I])^2+imag(V[I])^2;
1.6 takayama 1342: else{
1343: if(type(V[0])>3){
1344: V=ltov(V[0])-ltov(V[1]);
1345: return dnorm(V);
1346: }
1.58 takayama 1347: for(;V!=[]; V=cdr(V)) R+=real(car(V))^2+imag(car(V))^2;
1.6 takayama 1348: }
1.61 takayama 1349: return ctrl("bigfloat")?pari(sqrt,R):dsqrt(R);
1.6 takayama 1350: }
1351:
1352: def dvprod(V1,V2)
1353: {
1354: if(type(V1)<2) return V1*V2;
1355: R=0;
1.71 takayama 1356: V1=lsub(V1);
1357: V2=lsub(V2);
1.6 takayama 1358: if(type(V1)!=4)
1359: for(I = length(V1)-1; I >= 0; I--)
1360: R += V1[I]*V2[I];
1361: else{
1362: for(; V1!=[]; V1=cdr(V1),V2=cdr(V2))
1363: R+=car(V1)*car(V2);
1364: }
1365: return R;
1366: }
1367:
1.70 takayama 1368: def ptline(L,R)
1369: {
1370: P=L[0];Q=L[1];
1371: return (Q[1]-P[1])*(R[0]-P[0])-(Q[0]-P[0])*(R[1]-P[1]);
1372: }
1373:
1374:
1.6 takayama 1375: def dvangle(V1,V2)
1376: {
1377: if(V2==0 && type(V1)==4 && length(V1)==3 &&
1378: (type(V1[0])==4 || type(V1[0])==5 || type(V1[1])==4 || type(V1[1])==5 ||
1379: type(V1[2])==4 || type(V1[2])==5) ){
1380: if(V1[0]==0 || V1[1]==0 || V1[2]==0) return 1;
1381: PV2=V1[1];
1382: if(type(PV2)==4){
1383: PV2=ltov(PV2);
1384: return dvangle(PV2-ltov(V1[0]),ltov(V1[2])-PV2);
1385: }else
1386: return dvangle(PV2-V1[0],V1[2]-PV2);
1387: }
1388: if((L1=dnorm(V1))==0 || (L2=dnorm(V2))==0) return 1;
1389: return dvprod(V1,V2)/(L1*L2);
1390: }
1391:
1392: def mulseries(V1,V2)
1393: {
1394: L = length(V1);
1395: if(size(V2) < L)
1396: L = size(V2);
1397: VV = newvect(L);
1398: for(J = 0; J < L; J++){
1399: for(K = R = 0; K <= J; K++)
1400: R = radd(R,rmul(V1[K],V2[J-K]));
1401: VV[J] = R;
1402: }
1403: return VV;
1404: }
1405:
1.13 takayama 1406: def scale(L)
1407: {
1.23 takayama 1408: T=F=0;LS=1;
1.18 takayama 1409: Pr=getopt(prec);
1.23 takayama 1410: Inv=getopt(inv);
1411: Log10=dlog(10);
1412: if(type(L)==7){
1413: V=findin(L,["CI","DI","CIF","CIF'","DIF","DIF'","SI","TI1","TI2","STI"]);
1414: if(V>=0){
1415: L=["C","D","CF","CF'","DF","DF'","S","T1","T2","ST"];
1416: Inv=1;L=L[V];
1417: }
1418: V=findin(L,["C","A","K","CF","CF'","S","T1","T2","ST","LL0","LL1","LL2","LL3","LL00",
1419: "LL01","LL02","LL03"])+1;
1420: if(V==0) V=findin(L,["D","B","K","DF","DF'"])+1;
1421: if(V>0) L=V;
1422: }
1423: if(type(OL=L)!=4){
1.15 takayama 1424: if(L==2){
1.23 takayama 1425: L=(Pr==0)?
1.18 takayama 1426: [[[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 1427: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5]],
1.18 takayama 1428: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10]]]:
1429: [[[1,2,1/50],[2,5,1/20],[5,10,1/10], [10,20,1/5],[20,50,1/2],[50,100,1]],
1430: [[1,5,1/10],[5,10,1/2], [10,20,1],[50,100,5]],
1431: [[1,5,1/2],[5,10,1], [10,50,5],[50,100,10]]];
1.23 takayama 1432: LS=2;M2=[[1,10,1],[10,100,10]];
1.15 takayama 1433: }else if(L==3){
1.23 takayama 1434: L=(Pr==0)?
1.18 takayama 1435: [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2],
1436: [100,200,5],[200,500,10],[500,1000,20]],
1.15 takayama 1437: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5], [100,200,10],[200,500,50]],
1.18 takayama 1438: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10], [100,200,50],[200,1000,100]]]:
1439: [[[1,2,1/50],[2,5,1/20],[5,10,1/10],[10,20,1/5],[20,50,1/2],[50,100,1],
1440: [100,200,2],[200,500,5],[500,1000,10]],
1441: [[1,5,1/10],[5,10,1/2], [10,50,1],[50,100,5], [100,500,10],[500,1000,50]],
1.23 takayama 1442: [[1,5,1/2],[5,10,1],[10,50,5],[50,100,10], [100,500,50],[500,1000,100]]];
1443: LS=3;M2=[[1,5,1],[10,50,10],[100,500,100],[500,1000,500]];
1444: }else if(L>9&&L<18){
1.26 takayama 1445: if(L<18){ /* LL0 - LL3, LL00 - LL03 */
1.23 takayama 1446: if(L==10){
1447: L=[ [[1.001,1.002,0.00001],[1.002,1.005,0.00002],[1.005,1.0105,0.00005]],
1448: [[1.001,1.002,0.00005],[1.002,1.005,0.0001], [1.005,1.0105,0.0001]],
1449: [[1.001,1.002,0.0001],[1.002,1.005,0.0005], [1.005,1.0105,0.0005]]];
1450: M2=[1.001,1.0015,1.002,1.003,1.004,1.005,1.006,1.007,1.008,1.009,1.01];
1451: }
1452: if(L==11){
1453: L=[ [[1.01,1.02,0.0001],[1.02,1.05,0.0002],[1.05,1.105,0.0005]],
1454: [[1.01,1.02,0.0005],[1.02,1.05,0.001], [1.05,1.105,0.001]],
1455: [[1.01,1.02,0.001],[1.02,1.05,0.005], [1.05,1.105,0.005]]];
1456: M2=[1.01,1.015,1.02,1.03,1.04,1.05,1.06,1.07,1.08,1.09,1.10];
1457: }else if(L==12){
1458: 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],
1459: [2.5,2.72,0.02]],
1460: [[1.105,1.2,0.005],[1.2,1.4,0.01],[1.4,1.8,0.01],[1.8,2.5,0.05],
1461: [2.5,2.72,0.1]],
1462: [[1.105,1.2,0.01],[1.2,1.4,0.05],[1.4,1.8,0.05],[1.8,2.5,0.1],
1463: [2.5,2.72,0.1]]];
1.26 takayama 1464: 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 1465: }else if(L==13){
1466: 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],
1467: [50,100,2],[100,200,5],[200,400,10],[400,500,20],[500,1000,50],
1468: [1000,2000,100],[2000,5000,200],[5000,10000,500],[10000,22000,1000]],
1469: [[2.7,4,0.1],[4,6,0.1],[6,10,0.5],[10,15,1],[15,30,1],[30,50,5],
1470: [50,100,10],[100,200,10],[200,400,50],[400,500,100],[500,1000,100],
1471: [1000,2000,500],[2000,5000,1000],[5000,10000,1000],[10000,22000,5000]],
1472: [[3,4,0.5],[4,6,0.5],[6,10,1],[10,15,5],[15,30,5],[30,50,10],
1473: [50,100,50],[100,200,50],[200,400,100],[400,500,100],[500,1000,500],
1474: [1000,2000,1000],[2000,5000,3000],[5000,10000,5000],[10000,22000,10000]]];
1475: M2=[3,4,5,6,7,8,9,10,15,20,30,40,50,100,200,500,1000,2000,5000,10000,20000];
1476: }else if(L==14){
1.26 takayama 1477: L=[ [[0.998,0.999,0.00001],[0.995,0.998,0.00002],[0.99,0.995,0.00005]],
1478: [[0.998,0.999,0.00005],[0.995,0.998,0.0001],[0.99,0.995,0.0001]],
1479: [[0.998,0.999,0.0001],[0.995,0.998,0.0005],[0.99,0.995,0.0005]]];
1.23 takayama 1480: M2=[0.999,0.9985,0.998,0.997,0.996,0.995,0.994,0.993,0.992,0.991,0.99];
1481: }else if(L==15){
1.26 takayama 1482: L=[ [[0.98,0.9901,0.0001],[0.95,0.98,0.0002],[0.905,0.95,0.0005]],
1483: [[0.98,0.99,0.0005],[0.95,0.98,0.001], [0.905,0.95,0.001]],
1.23 takayama 1484: [[0.98,0.99,0.001],[0.95,0.98,0.005], [0.91,0.95,0.005]]];
1485: M2=[0.99,0.985,0.98,0.97,0.96,0.95,0.94,0.93,0.92,0.91];
1486: }else if(L==16){
1.26 takayama 1487: L=[ [[0.8,0.906,0.001],[0.6,0.8,0.002],[0.37,0.6,0.005]],
1488: [[0.8,0.906,0.005],[0.6,0.8,0.01],[0.37,0.6,0.01]],
1489: [[0.8,0.9,0.01],[0.6,0.8,0.05],[0.4,0.6,0.05]]];
1490: 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 1491: }else{
1.26 takayama 1492: L=[ [[0.05,0.37,0.002],[0.02,0.05,0.001],[0.01,0.02,0.0005],
1493: [0.005,0.01,0.0002],[0.001,0.005,0.0001],
1494: [0.0005,0.001,0.00002],[0.0001,0.0005,0.00001],[0.00005,0.0001,0.000002]],
1495: [[0.05,0.37,0.01],[0.02,0.05,0.002],[0.01,0.02,0.001],
1496: [0.005,0.01,0.001],[0.001,0.005,0.0002],
1497: [0.0005,0.001,0.0001],[0.0001,0.0005,0.00002],[0.00005,0.0001,0.00001]],
1498: [[0.05,0.37,0.05],[0.02,0.05,0.01],[0.01,0.02,0.005],
1499: [0.005,0.01,0.005],[0.002,0.005,0.001],
1500: [0.0005,0.001,0.0005],[0.0001,0.0005,0.0001],[0.00005,0.0001,0.00005]]];
1501: 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 1502: }
1503: }
1.15 takayama 1504: }else{
1.23 takayama 1505: if(L==6){ /* S */
1506: 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]],
1507: [[6-1/6,15,1/6],[15,30,1/2],[30,70,1],[70,80,5],[80,90,10]],
1508: [[6,15,1/2],[15,30,1],[30,70,5],[70,90,10]] ];
1509: M2=[6,7,8,9,10,15,20,30,40,50,60,70,90];
1510: }else if(L==7){ /* T1 */
1511: F=log(tan(x*3.1416/180))/Log10+1;
1512: L=[ [[6-1/3,15,1/12],[15,45,1/6]],
1513: [[6-1/3,15,1/6],[15,45,1/2]],
1514: [[6,45,1]] ];
1515: M2=[6,7,8,9,10,15,20,30,40,45];
1516: }else if(L==8){ /* T2 */
1517: L=[ [[45,75,1/6],[75,84+1/6,1/12]],
1518: [[45,75,1],[75,84+1/6,1/6]],
1519: [[45,84,1]] ];
1520: M2=[45,50,60,70,75,80,81,82,83,84];
1521: }else if(L==9){ /* ST */
1522: L=[ [[35/60,1,1/120],[1,2,1/60],[2,5+9/12,1/30]],
1523: [[35/60,1,1/60],[1,2,1/6],[2,5+9/12,1/6]],
1524: [[40/60,1,1/6],[1,2,1/2],[2,5+9/12,1]] ];
1525: M2=[1,2,3,4,5];
1526: }else{
1527: M2=(L==4||L==5)?[[1,2,1/2],[2,9,1]]:[[1,2,1/2],[2,10,1]];
1528: L=(Pr==0)?
1529: [ [[1,2,1/50],[2,5,1/20],[5,10,1/10]],
1530: [[1,5,1/10],[5,10,1/2]],
1531: [[1,5,1/2],[5,10,1]] ]:
1532: [[[1,2,1/100],[2,5,1/50],[5,10,1/20]],
1533: [[1,2,1/20],[2,10,1/10]],
1534: [[1,2,1/10],[2,10,1/2]] ];
1535: }
1.15 takayama 1536: }
1537: }else if(type(L[0])!=4){
1538: L=[L];
1539: if(length(L)!=3||L[0]+L[2]>L[1]) T=L;
1.13 takayama 1540: }
1.15 takayama 1541: if(T==0){
1542: if(type(L[0][0])!=4) L=[L];
1543: for(R=[];L!=[];L=cdr(L)){
1544: for(RR=[],LT=car(L);LT!=[];LT=cdr(LT))
1545: for(I=car(LT)[0];I<=car(LT)[1];I+=car(LT)[2]) RR=cons(I,RR);
1546: RR=lsort(RR,[],1);
1547: R=cons(RR,R);
1548: }
1549: R=reverse(R);
1550: for(T=[];R!=[];R=cdr(R)){
1551: if(length(R)>1) T=cons(lsort(R[0],R[1],"setminus"),T);
1552: else T=cons(R[0],T);
1553: }
1.13 takayama 1554: }
1555: V0=dlog(10);
1556: S0=S1=1;D0=D1=0;
1557: SC=getopt(scale);
1558: if(type(SC)==4){
1559: S0=SC[0];S1=SC[1];
1.18 takayama 1560: }else if(type(SC)==1){
1561: S0=SC;S1=0;
1.13 takayama 1562: }else return T;
1563: if(type(D=getopt(shift))==4){
1564: D0=D[0];D1=D[1];
1.31 takayama 1565: }else if(type(D)<2&&type(D)>=0){
1.23 takayama 1566: D0=0;D1=D;
1.31 takayama 1567: };
1.23 takayama 1568: if(Inv==1){
1569: D0+=S0;S0=-S0;
1.13 takayama 1570: }
1.23 takayama 1571: if(type(TF=getopt(f))>1) F=TF;
1572: if(F) F=f2df(F);
1573: if(type(I=getopt(ol))==1&&OL>3) OL=I;
1.18 takayama 1574: for(M=M0=[],I=length(T);T!=[];T=cdr(T),I--){
1.13 takayama 1575: for(S=car(T);S!=[];S=cdr(S)){
1.23 takayama 1576: VS=car(S);
1577: if(F) V=myfdeval(F,car(S));
1578: else if(OL==4) V=frac(dlog(VS)/Log10+0.5);
1579: else if(OL==5) V=frac(dlog(VS*3.1416)/Log10);
1580: else if(OL>5&&OL<10){
1581: VS=VS*3.1416/180;
1582: if(OL==6) V=dlog(dsin(VS))/Log10+1;
1583: else if(OL==9) V=dlog(VS)/Log10+2;
1584: else V=dlog(dtan(VS))/Log10+8-OL;
1585: }
1586: else if(OL>9&&OL<14) V=dlog(dlog(VS))/Log10+13-OL;
1587: else if(OL>13&&OL<18) V=dlog(-dlog(VS))/Log10+17-OL;
1588: else V=dlog(VS)/Log10/LS;
1589: V*=S0;
1.13 takayama 1590: if(S1!=0){
1591: M=cons([V+D0,D1],M);
1.23 takayama 1592: M=cons([V+D0,((length(SC)>2)?SC[I]:(I*S1))+D1],M);
1.13 takayama 1593: M=cons(0,M);
1.18 takayama 1594: }else M0=cons(V+D0,M0);
1.13 takayama 1595: }
1.18 takayama 1596: if(S1==0) M=cons(reverse(M0),M);
1.13 takayama 1597: }
1598: if(S1!=0) M=cdr(M);
1.18 takayama 1599: if(S1==0||getopt(TeX)!=1) return M;
1.13 takayama 1600: M=reverse(M);
1.23 takayama 1601: if(type(U=getopt(line))==4){
1602: if(Inv==1) U=[U[0]+S0,U[1]+S0];
1.18 takayama 1603: M=cons([U[0]+D0,D1],cons([U[1]+D0,D1],cons(0,M)));
1.23 takayama 1604: }
1605: if((VT=getopt(vert))==1){
1606: for(N=[];M!=[];M=cdr(M)){
1607: if(type(TM=car(M))==4) N=cons([TM[1],TM[0]],N);
1608: else N=cons(TM,N);
1609: }
1610: M=reverse(N);
1611: }
1.18 takayama 1612: if(type(Col=getopt(col))<1) S=xylines(M);
1613: else S=xylines(M|opt=Col);
1614: if(type(Mes=getopt(mes))==4){
1.23 takayama 1615: if(length(Mes)==1&&type(M2)==4) Mes=cons(car(Mes),M2);
1.18 takayama 1616: S3=car(Mes);
1617: if(type(S3)==4){
1618: Col=S3[1];
1619: S3=car(S3);
1620: }else Col=0;
1621: V=car(scale(cdr(Mes)));
1.23 takayama 1622: if(!F) Mes=scale(cdr(Mes)|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1.18 takayama 1623: else Mes=scale(cdr(Mes)|f=F,scale=[S0,0],shift=[D0,D1]);
1624: for(M=car(Mes);M!=[];M=cdr(M),V=cdr(V)){
1.23 takayama 1625: TV=deval(car(V));
1626: if(Col!=0) TV=[Col,TV];
1627: S+=(VT==1)?xyput([S3+D1,car(M),TV]):xyput([car(M),S3+D1,TV]);
1628: }
1629: }
1630: if(type(Mes=getopt(mes2))==4){
1631: if(type(car(Mes))!=4) Mes=[Mes];
1632: for(;Mes!=[];Mes=cdr(Mes)){
1633: TM=car(Mes);
1634: if(!F) V=scale([car(TM)]|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1635: else V=scale([car(TM)]|f=F,scale=[S0,0],shift=[D0,D1]);
1636: V=car(car(V));
1637: TM=cdr(TM);
1638: if(type(Col=car(TM))==4){
1639: C0=Col[0];C1=Col[1];
1640: if(length(Col)==3){
1641: S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]|opt=Col[2])
1642: :xyline([V,D1+C0],[V,D1+C1]|opt=Col[2]);
1643: }else S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]):xyline([V,D1+C0],[V,D1+C1]);
1644: }
1645: if(type(TM[1]<2)){
1646: TM=cdr(TM);
1647: S3=car(TM);
1648: }
1649: S+=(VT==1)?xyput([S3+D1,V,TM[1]]):xyput([V,S3+D1,TM[1]]);
1.13 takayama 1650: }
1651: }
1.18 takayama 1652: return S;
1.13 takayama 1653: }
1654:
1.6 takayama 1655: def pluspower(P,V,N,M)
1656: {
1657: RR = 1;
1658: for(K = R = 1; K < M-1; I++){
1659: R = R*(N-K+1)*P/K;
1660: RR = radd(RR,R);
1661: }
1662: VV = newvect(M);
1663: for(K = 0; K < M-1; K++)
1664: VV[K] = red(mycoef(RR,K,V));
1665: }
1666:
1667: def vtozv(V)
1668: {
1669: if(type(V)<4) V=newvect(1,[V]);
1670: S = length(V);
1671: VV = newvect(S);
1672: Lcm = 1;
1673: for(K = 0; K < S; K++){
1674: VV[K] = red(V[K]);
1675: Lcm = lcm(Lcm,dn(VV[K]));
1676: C = ptozp(nm(VV[K])|factor=0);
1677: if(K == 0){
1678: Dn = dn(C[1]);
1679: Nm = nm(C[1]);
1680: PNm = nm(C[0]);
1681: }else{
1682: Dn = ilcm(Dn,dn(C[1]));
1683: Nm = igcd(Nm,nm(C[1]));
1684: PNm = gcd(PNm,nm(C[0]));
1685: }
1686: }
1687: if(!(M=Nm*PNm)) return [VV,0];
1688: Mul = (Lcm*Dn)/M;
1689: for(K = 0; K < S; K++)
1690: VV[K] = rmul(VV[K],Mul);
1691: return [VV,Mul];
1692: }
1693:
1694: def dupmat(M)
1695: {
1696: if(type(M) == 6){
1697: Size = size(M);
1698: MM = newmat(Size[0],Size[1]);
1699: for(I = 0; I < Size[0]; I++){
1700: for(J = 0; J < Size[1]; J++)
1701: MM[I][J] = M[I][J];
1702: }
1703: return MM;
1704: }
1705: if(type(M) == 5)
1706: return ltov(vtol(M));
1707: return M;
1708: }
1709:
1710: def matrtop(M)
1711: {
1712: S = size(M);
1713: MM = dupmat(M);
1714: Lcm = newvect(S[0]);
1715: for(J = 0; J < S[0]; J++){
1716: U = vtozv(M[J]);
1717: for(K = -1, I = 0; I < S[1]; I++)
1718: MM[J][I] = U[0][I];
1719: Lcm[J] = U[1];
1720: }
1721: return [MM,Lcm];
1722: }
1723:
1724: def mytrace(M)
1725: {
1726: S=size(M);
1727: if(S[0]!=S[1]) return 0;
1728: for(I=V=0; I<S[0]; I++){
1729: V+=M[I][I];
1730: }
1731: return V;
1732: }
1733:
1734: def mydet(M)
1735: {
1736: MM = matrtop(M);
1737: if(type(MM[0]) == 6){
1738: S = size(M);
1739: for(Dn = 1, I = 0; I < S[0]; I++)
1740: Dn *= MM[1][I];
1741: return (!Dn)?0:red(det(MM[0])/Dn);
1742: }
1743: }
1744:
1.71 takayama 1745: def permanent(M)
1746: {
1747: SS=size(M);
1748: if((S=SS[0]) != SS[1] || S==0) return 0;
1749: if((Red=getopt(red))!=1){
1750: MM = matrtop(M);
1751: for(Dn = 1, I = 0; I < S; I++)
1752: Dn *= MM[1][I];
1753: return (!Dn)?0:red(permanent(MM[0]|red=1)/Dn);
1754: }
1755: if(S<3){
1756: if(S==1) return M[0][0];
1757: else return M[0][0]*M[1][1]+M[0][1]*M[1][0];
1758: }
1759: LL=m2ll(M);
1760: for(V=I=0;I<S;I++){
1761: if(!(K=M[I][0])) continue;
1762: for(TL=[],SL=LL,J=0;J<S;J++,SL=cdr(SL))
1763: if(I!=J) TL=cons(cdr(car(SL)),TL);
1764: if(K) V+=K*permanent(lv2m(TL));
1765: }
1766: return V;
1767: }
1768:
1.6 takayama 1769: def mperm(M,P,Q)
1770: {
1771: if(type(M) == 6){
1772: S = size(M);
1773: if(type(P) <= 1)
1774: P=(P==1)?Q:trpos(0,0,S[0]);
1775: if(type(P) > 3 && type(P[0]) >= 4)
1776: P = trpos(P[0][0],P[0][1],S[0]);
1777: else if(type(P) == 4){
1778: if(length(P)==2 && type(P[1])==4){
1779: P0=P[0];P1=car(P[1]);P=newvect(P1);
1780: for(I=0;I<P1;I++) P[I]=P0+I;
1781: }else P = ltov(P);
1782: }
1783: if(type(Q) <= 1)
1784: Q=(Q==1)?P:trpos(0,0,S[1]);
1785: if(type(Q) > 3 && type(Q[0]) >= 4)
1786: Q = trpos(Q[0][0],Q[0][1],S[1]);
1787: if(type(Q) == 4){
1788: if(length(Q)==2 && type(Q[1])==4){
1789: P0=Q[0];P1=car(Q[1]);Q=newvect(P1);
1790: for(I=0;I<P1;I++) Q[I]=P0+I;
1791: }else Q = ltov(Q);
1792: }
1793: MM = newmat(S0=length(P),S1=length(Q));
1794: for(I = 0; I < S0; I++){
1795: MMI = MM[I]; MPI = M[P[I]];
1796: for(J = 0; J < S1; J++)
1797: MMI[J] = MPI[Q[J]];
1798: }
1799: return MM;
1800: }
1801: if((type(M) == 5 || type(M) == 4) && type(P) >= 4){
1802: if(length(P) == 1 && type(car(P)) == 4)
1803: P = trpos(car(P)[0],car(P)[1],length(M));
1804: MM = newvect(S = length(P));
1805: for(I = 0; I < S; I++)
1806: MM[I] = M[P[I]];
1807: if(type(M) == 4)
1808: MM = vtol(MM);
1809: return MM;
1810: }
1811: return M;
1812: }
1813:
1814: def mtranspose(M)
1815: {
1816: if(type(M)==4){
1817: MV=ltov(M);
1818: II=length(MV);
1819: for(I=L=0; I<II; I++){
1820: if(type(MV[I])!=4) return M;
1821: MV[I]=ltov(MV[I]);
1822: }
1823: for(R=[],J=0; ;J++){
1824: for(T=[],I=F=0; I<II; I++){
1825: if(length(MV[I])>J){
1826: F=1;
1827: T=cons(MV[I][J],T);
1828: }
1829: }
1830: if(F==0) return reverse(R);
1831: if(F==1) R=cons(reverse(T),R);
1832: }
1833: }
1834: if(type(M) != 6)
1835: return M;
1836: S = size(M);
1837: MM = newmat(S[1],S[0]);
1838: for(I = 0; I < S[0]; I++){
1839: for(J = 0; J < S[1]; J++)
1840: MM[J][I] = M[I][J];
1841: }
1842: return MM;
1843: }
1844:
1845: def mtoupper(MM, F)
1846: {
1847: TeXs=["\\ -=\\ ","\\ +=\\ "];
1848: Lins=[" -= line"," += line"];
1849: Assume=["If","Assume"];
1850: if(type(St = getopt(step))!=1) St=0;
1851: Opt = getopt(opt);
1852: if(type(Opt)!=1) Opt=0;
1.43 takayama 1853: if(type(Main=getopt(main))!=1) Main=0;
1.6 takayama 1854: TeX=getopt(dviout);
1855: if(type(Tab=getopt(tab))!=1 && Tab!=0) Tab=2;
1856: Line="\\text{line}";
1857: if(type(TeX)!=1 || !St) TeX=0;
1858: Size = size(MM);
1859: if(F==-1){
1860: M = newmat(Size[0], Size[1]+1);
1861: for(I = 0; I < Size[0]; I++){
1862: for(J = 0; J < Size[1]; J++)
1863: M[I][J] = MM[I][J];
1864: M[I][Size[1]] = zz^I;
1865: }
1866: Size = size(M);
1867: F = 1;
1868: }else if(F<0){
1869: F=Size[0];
1870: M = newbmat(1,2,[[MM,mgen(F,0,[1],0)]]);
1871: Size=[Size[0],F+Size[1]];
1872: }else
1873: M = dupmat(MM);
1874: if(St){
1875: if(TeX) Lout=[[dupmat(M)]];
1876: else mycat0([M,"\n\n"],0);
1877: }
1878: Top="";
1879: if(Opt>3){
1880: for(I=Opt; I>4; I--)
1881: Top+=(TeX)?"\\ ":" ";
1882: }
1883: PC=IF=1;
1.43 takayama 1884: if(Opt>3){
1885: for(P=[1],K=0;K<Size[1]-F;K++){
1886: for(J=0;J<Size[0];J++)
1887: if(type(dn(M[J][K]))==2) P=cons(dn(M[J][K]),P);
1888: }
1889: PC=llcm(P|poly=1);
1890: }
1.6 takayama 1891: for(K = JJ = 0; K < Size[1] - F; K++){
1892: for(J = JJ; J < Size[0]; J++){
1893: if(M[J][K] != 0){ /* search simpler element */
1894: if(Opt>2 && (Mul=M[J][K])!=1){
1895: for(FF=0,JT=J; JT<Size[0]; JT++){
1896: if((Val=M[JT][K])==1){ /* 1 */
1897: Mul=1;J=JT; break;
1898: }
1899: if(Val==0 || type(Val)>type(Mul)) continue;
1900: if(type(Val)<type(Mul) || (Val==-1 && Mul!=-1)){
1901: Mul=Val; J=JT; /* smaller type */
1902: }
1903: else if(Opt>3){
1904: if(isint(Val)==1){ /* integer elememt */
1905: if(isint(Mul)!=1){
1906: Mul=Val; J=JT; /* integer */
1907: }
1908: if(FF<3||(FF==3&&Val>0)){
1909: for(JK=K+1;;){
1910: if(JK>=Size[1]-F){
1911: J=JT;
1912: FF=((Mul=Val)>0)?4:3;
1913: break; /* divisible int => 4: pos_int 3: neg_int */
1914: }
1915: if(isint(M[JT][JK++]/Val)!=1) break;
1916: }
1917: }
1918: }else if(!FF){
1919: for(JK=K+1; JK<Size[1]-F; JK++){
1920: if(isint(M[JT][JK]/Val)!=1) break;
1921: J=JT; FF=1; /* divisible => 1: non integer */
1922: }
1923: }
1924: }
1925: }
1926: if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){ /* FF > 0 => divisible */
1927: for(FF=0,J0=J; J0<Size[0]-1 && FF!=9; J0++){
1928: VV0=M[J0][K];
1929: if(VV0==0 || isint(VV0)==0) continue;
1930: for(J1=J0+1;J1<Size[0] && FF!=9; J1++){
1931: VV1=M[J1][K];
1932: if(VV1==0 || isint(VV1)==0) continue;
1933: for(C=FT=0,V0=VV0,V1=VV1; C<2 && FF!=10; C++,V1=V0,V0=VV1){
1934: for(CC=0,RC=ceil(V0/V1);CC<2;CC++,RC--){
1935: if((CD=V0-RC*V1)==0 && (RC==1 || RC==-1)){
1936: FT=1; FF=10; /* 10: vanish by +- */
1937: }else if(CD==1){
1938: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1939: if((RC==1 || RC==-1) && FF<8+FV){
1940: FT=1; FF=8+FV; /* 8/9: 1 by +- */
1941: }else if(FF<6+VF){
1942: FT=1; FF=6+FV; /* 6/7: 1 by times */
1943: }
1944: }else if(CD==-1){
1945: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1946: if((RC==1 || RC==-1) && FF<4+FV){
1947: FT=1; FF=4+FV; /* 4/5: 1 by +- */
1948: }else if(FF<2+VF){
1949: FT=1; FF=2+FV; /* 2/3: 1 by times */
1950: }
1951: }
1952: if(FT==1){
1953: FT=0; KRC=RC;
1954: if(C==0){
1955: KJ0=J0; KJ1=J1;
1956: }else{
1957: KJ0=J1; KJ1=J0;
1958: }
1959: }
1960: }
1961: }
1962: }
1963: }
1964: if(FF>0){
1965: for(I=K;I<Size[1];I++)
1966: M[KJ0][I]=radd(M[KJ0][I],rmul(M[KJ1][I],-KRC));
1967: if(KRC<0){
1968: KRC=-KRC;Sgn=1;
1969: }else
1970: Sgn=0;
1.43 takayama 1971: if(St&&!Main){
1.6 takayama 1972: if(TeX){
1973: if(KRC==1)
1974: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1975: Line,KJ1+1,"}",dupmat(M)],Lout);
1976: else
1977: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1978: Line,KJ1+1,"\\times\\left(",KRC,"\\right)}",
1979: dupmat(M)],Lout);
1980:
1981: }else{
1982: if(KRC==1)
1983: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1,"\n",M,"\n"]); else
1984: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1," * (",KRC,")\n",M,"\n"]);
1985: }
1986: }
1987: Mul=M[KJ0][K]; J=KJ0;
1988: if(FF==10){
1989: J--; continue;
1990: }
1991: }
1992: }
1993: }
1994: /* a parameter Var */
1995: Var=0;
1.43 takayama 1996: /* mycat(["start",J,K]); */
1.6 takayama 1997: if(St && Opt>4 && length(Var=vars(nm(M[J][K])))==1){
1998: J0=J;Jv=mydeg(nm(M[J0][K]),car(Var));
1999: for(I=JJ;I<Size[0]; I++){
2000: if((MIK=M[I][K])==0) continue;
2001: if((T=vars(MIK=nm(MIK)))==[]){ /* 1/poly */
2002: J=I;Var=[]; break;
2003: }
2004: if(length(T)>1) continue;
2005: if(mydeg(MIK,T[0])<Jv){
1.39 takayama 2006: J0=I;Jv=mydeg(MIK,T[0]);Var=T; /* search minimal degree */
1.6 takayama 2007: }
2008: }
2009: if(length(Var)==1){
2010: Var=car(Var);
2011: Q=nm(M[J0][K]);
1.43 takayama 2012: /* mycat(["min",Q,M[J0][K],"J0=",J0,"J=",J,"JJ=",JJ,K,M]); */
2013: J=J0;
1.6 takayama 2014: for(I=JJ; I<Size[0]; I++){
2015: if(I==J0 || mydeg(nm(M[I][K]),Var)<0) continue;
2016: T=rpdiv(nm(M[I][K]),Q,Var);
2017: if(T[0]!=0 && (vars(T)==[] || vars(T)==[Var])) break; /* dec. deg */
2018: }
2019: }
2020: }
2021: if(type(Var)==2){ /* 1 variable */
2022: if(I==Size[0]){
2023: for(QF=0,Q0=1,QR=getroot(Q,Var|mult=1);QR!=[];QR=cdr(QR)){
1.43 takayama 2024: /* mycat(["root",Q,QR,PC]); */
1.6 takayama 2025: if(deg(T=QR[0][1],Var)>0){
2026: QF=1;Q0*=T; continue;
2027: }
2028: if(subst(PC,Var,T)==0) continue;
2029: Q0*=(Var-(T=QR[0][1]));
2030: if(type(T)<2){
2031: M0=subst(M,Var,T);
2032: if(TeX){
2033: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2034: Var,"=",T,","] ,Lout);
1.43 takayama 2035: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),Lout);
1.6 takayama 2036: }else{
2037: mycat([str_times(" ",St-1)+"If",Var,"=",T,","]);
1.43 takayama 2038: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2039: }
2040: }
2041: }
2042: if(Q0!=1){
2043: if(TeX)
2044: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[QF]+" }",
2045: Q0/=fctr(Q0)[0][0],"\\ne0,"],Lout);
2046: else
2047: mycat([str_times(" ",St-1)+Assume[QF],Q0,"!=0,"]);
2048: PC*=Q0;
2049: }
2050: IF=0;St++;
2051: }else{
2052: KRC=-red((T[2]*dn(M[J0][K]))/(T[1]*dn(M[I][K])));
2053: for(II=K;II<Size[1];II++)
2054: M[I][II]=radd(M[I][II],rmul(M[J0][II],KRC));
1.43 takayama 2055: if(!Main){
2056: if(TeX)
2057: Lout=cons([Top+"\\xrightarrow{", Line,I+1,"\\ +=\\ ",Line,
2058: J0+1,"\\times\\left(",KRC,"\\right)}",dupmat(M)],Lout);
2059: else
2060: mycat([Top+"line",I+1,"+=",Line,J0+1," * (",KRC,")\n",M,"\n"]);
2061: }
1.6 takayama 2062: J=JJ-1;
2063: continue;
2064: }
2065: }
2066: if(J != JJ){
2067: for(I = K; I < Size[1]; I++){
2068: Temp = M[JJ][I];
2069: M[JJ][I] = M[J][I];
2070: M[J][I] = (Opt>=2)?Temp:-Temp;
2071: }
2072: if(St){
2073: if(TeX)
2074: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\leftrightarrow\\ ",
2075: Line,J+1,"}",dupmat(M)],Lout);
2076: else
2077: mycat0([Top+"line",JJ+1," <-> line",J+1,"\n",M,"\n\n"],0);
2078: }
2079: }
2080: /* Assume PC != 0 */
2081: if(Opt>1){
2082: Mul = M[JJ][K];
2083: if(Opt > 5 && St && IF && (Var=vars(MIK=nm(Mul)))!=[]){
2084: TF=fctr(MIK);
2085: for(FF=0,Q0=1,TP=cdr(TF);TP!=[];TP=cdr(TP)){
2086: if(type(dn(red(PC/(TP0=car(car(TP))))))<2) continue; /* divisible */
2087: Q0*=TP0;
2088: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
2089: if(mydeg(TP0,X=car(Var))==1 && type(dn(red(PC/mycoef(TP0,1,X))))<2){
2090: /* TP0=A*X+B with non-vanishing A */
2091: T=red(-mycoef(TP0,0,X)/mycoef(TP0,1,X));
2092: M0=mysubst(M,[X,T]);
2093: if(TeX){
2094: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2095: X,"=",T,","] ,Lout);
1.43 takayama 2096: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 2097: Lout);
2098: }else{
2099: mycat([str_times(" ",St-1)+"If",X,"=",T,","]);
1.43 takayama 2100: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2101: }
2102: break;
2103: }
2104: }
2105: if(Var==[] && Opt>6){
2106: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
2107: if(mydeg(TP0,X=car(Var))==1){
2108: /* TP0=A*X+B, A is a poly of X0 with rational funct */
2109: T=nm(mycoef(TP0,1,X));
2110: for(Var0=vars(T);Var0!=[]; Var0=cdr(Var0)){
2111: X0=car(Var0);
2112: if(type(dn(red(PC/type(mycoef(T,mydeg(T,X0),X0)))))>1) continue;
2113: TR=getroot(T,X0|mult=1);
2114: if(findin(X0,vars(TR))<0) break;
2115: }
2116: if(Var0==[]) continue;
2117: for(;TR!=[0];TR=cdr(TR)){
2118: if(TR==[]){
2119: TR=[0,0];
2120: T0=-mycoef(TP0,0,X)/mycoef(TP0,1,X);
2121: X0=X;
2122: }else T0=car(TR)[1];
2123: M0=mysubst(M,[X0,T0]);
2124: if(TeX){
2125: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2126: X0,"=",T0,","] ,Lout);
1.43 takayama 2127: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 2128: Lout);
2129: }else{
2130: mycat([str_times(" ",St-1)+"If",X0,"=",T0,","]);
1.43 takayama 2131: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2132: }
2133: }
2134:
2135: }
2136: break;
2137: }
2138: }
2139: if(Var==[]){
2140: FF=1;
2141: }
2142: }
2143: if(Q0!=1){
2144: if(FF) FF=1;
2145: if(TeX) Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[FF]+" }",Q0/=fctr(Q0)[0][0],"\\ne0,"],
2146: Lout);
2147: else mycat([str_times(" ",St-1)+Assume[FF],Q0,"!=0,"]);
2148: PC*=Q0;St++;
2149: }
2150: }
2151: IF=M[JJ][K]=1;
2152: if(Mul!=1){
2153: for(L=K+1; L<Size[1]; L++)
2154: M[JJ][L]=red(M[JJ][L]/Mul);
2155: if(St){
2156: if(TeX)
2157: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,
2158: "\\ \\times=\\ \\left(",red(1/Mul),"\\right)}",
2159: dupmat(M)],Lout);
2160: else
2161: mycat0([Top+"line",JJ+1, " *= (",red(1/Mul), ")\n",M,"\n\n"],0);
2162: }
2163: }
2164:
2165: }
2166: for(J = (Opt>0)?0:(JJ+1); J < Size[0]; J++){
2167: if(J == JJ)
2168: continue;
2169: Mul = -M[J][K];
2170: if(Mul!=0){
2171: if(Opt!=2) Mul=rmul(Mul,1/M[JJ][K]);
2172: for(I = K+1; I < Size[1]; I++)
2173: M[J][I] = radd(M[J][I],rmul(M[JJ][I],Mul));
2174: M[J][K] = 0;
1.43 takayama 2175: if(St&&!Main){
1.6 takayama 2176: if(Mul<0){
2177: Mul=-Mul;Sgn=0;
2178: }else Sgn=1;
2179: if(TeX){
2180: if(Mul==1)
2181: Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2182: "}",dupmat(M)],Lout);
2183: else Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2184: "\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout);
2185: }else{
2186: if(Mul==1)
2187: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1,"\n",M,"\n\n"],0);
2188: else
2189: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1," * (",Mul,")\n",M,"\n\n"],0);
2190: }
2191: }
2192: }
2193: }
2194: JJ++;
2195: }
2196: }
2197: }
2198: if(TeX){
2199: if(TeX==-2) return Lout;
2200: Lout=reverse(Lout);
2201: Br="\\allowdisplaybreaks";
2202: Cr="\\\\\n &";
2203: if(getopt(pages)==1) Cr=Br+Cr;
2204: if(type(S=getopt(cr))==7) Cr=S;
2205: if(type(Lim=getopt(lim))==1){
2206: if(Lim>0){
2207: if(Lim<30) Lim=TeXLim;
2208: Lim*=2;
2209: }
2210: }else Lim=0;
2211: Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr,lim=Lim);
2212: if(TeX<0) return Out;
2213: dviout(Out|eq=(str_str(Cr,Br)>=0)?6:5,keep=(TeX==1)?0:1);
2214: }
2215: return M;
2216: }
2217:
2218: def mydet2(M)
2219: {
2220: S = size(M);
2221: Det = 1;
2222: MM = mtoupper(M,0);
2223: for(I = 0; I < S[0]; I++)
2224: Det = rmul(Det,MM[I][I]);
2225: return Det;
2226: }
2227:
2228: def myrank(MM)
2229: {
2230: S = size(MM);
2231: M = dupmat(MM);
2232: M = mtoupper(M,0);
2233: C = 0;
2234: for(I = K = 0; I < S[0]; I++){
2235: for(J = K; J < S[1]; J++){
2236: if(M[I][J] != 0){
2237: C++; K++;
2238: break;
2239: }
2240: }
2241: }
2242: return C;
2243: }
2244:
2245: def meigen(M)
2246: {
2247: F = getopt(mult);
2248: if(type(M)==4 || type(M)==5){
2249: II=length(M);
2250: for(R=[],I=II-1; I>=0; I--){
2251: if(F==1)
2252: R=cons(meigen(M[I]|mult=1),R);
2253: else
2254: R=cons(meigen(M[I]),R);
2255: }
2256: return R;
2257: }
2258: S = size(M)[0];
2259: P = mydet2(mgen(S,0,[zz],0)-M);
2260: return (F==1)?getroot(P,zz|mult=1):getroot(P,zz);
2261: }
2262:
2263: def transm(M)
2264: {
2265: if(type(M)!=6) M=s2m(M);
2266: if(type(M)!=6){
2267: errno(0);
2268: return 0;
2269: }
2270: L=[M];TeX="";
2271: Line=["\\text{line}","\\text{col}"];
2272: if((DVI=getopt(dviout)) !=1) DVI=0;
2273: else dviout(M);
2274: for(;;){
2275: print(L0=dupmat(car(L)));
2276: Sz=size(L0);
2277: S=keyin("? ");
2278: N=0;
2279: if(str_len(S)<=1){
2280: if(S=="q") return L;
2281: if(S=="t"){
2282: N=mtranspose(L0);
2283: TeX=["\\text{transpose}"];
2284: }
2285: else if(S=="f"){
2286: if(length(L)>1){
2287: if(LF!=0) TeX="";
2288: L=cdr(L);LF=L0;
2289: if(DVI){
2290: dviout0(-1);
2291: dviout(" ");
2292: }
2293: }
2294: }else if(S=="g"){
2295: if(LF!=0) N=LF;
2296: }else if(S=="0"){
2297: N=M;L=[];TeX=[];
2298: }else if(S=="a"||S=="A"){
2299: if(DVI&&S=="A") mtoupper(L0,0|step=1,opt=10,dviout=1);
2300: else mtoupper(L0,0|step=1,opt=10);
2301: }else{
2302: mycat0([
2303: "2,5 : line2 <-> line5",
2304: "2,5,-2 ; line2 += (-2)*line5",
2305: "2,2,-2 : line2 *= -2",
2306: "2,5,0 : line2 += (?)*line5 for reduction",
2307: "r,2,5 : raw2 <-> raw5 (r,2,5,-2 etc.)",
2308: "s,x,2 : subst(*,x,2)",
2309: "t : transpose",
2310: "0 : first matrix",
2311: "f : previous matrix",
2312: "g : next matrix (only after f)",
2313: "A : auto (a : without TeX)",
2314: "q : quit"
2315: ],1|delim="\n");
2316: }
2317: }else{
2318: FR=0;
2319: S=evals(S|del=",");
2320: if(S[0]==r){
2321: FR=1; S=cdr(S);
2322: }
2323: if((LL=length(S))>=2){
2324: S0=S[0]-1;S1=S[1]-1;
2325: if(S[0]==s){
2326: if(length(S)==3) N=subst(L0,S[1],S[2]);
2327: if(DVI) TeX=[S[1],"\\mapsto",S[2]];
2328: }else if(FR==0){
2329: if(S0<0 || S0>=Sz[0] || S1<0 || S1>=Sz[0]) continue;
2330: if(LL==2){
2331: N=rowx(L0,S0,S1);
2332: if(DVI) TeX=[Line[0],S[0],"\\ \\leftrightarrow\\ ",Line[0],S[1]];
2333: }else{
2334: S2=S[2];
2335: if(S0==S1){
2336: N=rowm(L0,S0,S2);
2337: if(DVI) TeX=[Line[0],S[0],"\\ \\times=\\ ",S2];
2338: }else{
2339: if(S2==0){
2340: for(J=0;J<Sz[1] && L0[S1][J]==0;J++);
2341: if(J<Sz[1]) S2=-L0[S0][J]/L0[S1][J];
2342: }
2343: if(S2!=0){
2344: N=rowa(L0,S0,S1,S2);
2345: if(DVI) TeX=[Line[0],S[0],"\\ +=\\ ",Line[0],
2346: S[1],"\\ \\times\\ (",S2,")"];
2347: }
2348: }
2349: }
2350: }else{
2351: if(S0<0 || S0>=Sz[1] || S1<0 && S1>=Sz[1]) continue;
2352: if(LL==2){
2353: N=colx(L0,S0,S1);
2354: if(DVI) TeX=[Line[1],S[0],"\\ \\leftrightarrow\\ ",Line[1],S[1]];
2355: }else{
2356: S2=S[2];
2357: if(S0==S1){
2358: N=colm(L0,S0,S2);
2359: if(DVI) TeX=[Line[1],S[0],"\\ \\times=\\ ",S[2]];
2360: }else{
2361: if(S2!=0){
2362: for(J=0; I1<Sz[0] && L0[I1][J]==0; J++);
2363: if(J<Sz[0]) S2=-L0[J][S0]/L0[J][S1];
2364: }if(S2!=0){
2365: N=cola(L0,S0,S1,S2);
2366: if(DVI) TeX=[Line[1],S[0],"\\ +=\\ ",Line[1],
2367: S[1],"\\ \\times\\ (",S2,")"];
2368: }
2369: }
2370: }
2371: }
2372: }
2373: }
2374: if(N!=0){
2375: LF=0;L=cons(N,L);
2376: if(DVI) dviout("\\xrightarrow{"+ltotex(TeX|opt="spts0",str=1)+"}"+mtotex(N)|eq=8);
2377: }
2378: }
2379: }
2380:
2381: def vgen(V,W,S)
2382: {
2383: IM=length(V);
2384: I=(getopt(opt)==0)?IM:0;
2385: for(SS=0; I<IM && (SS==0 || V[I]<=W[I]); I++)
2386: SS += W[I];
2387: if(I<IM){
2388: W[I]++;
2389: SS--;
2390: }else
2391: SS=S;
2392: for(J=0;J<I;J++){
2393: W[J] = (SS<=V[J])?SS:V[J];
2394: SS -= W[J];
2395: }
2396: if(SS>0)
2397: return -1;
2398: return(I==IM)?0:I;
2399: }
2400:
2401: def mmc(M,X)
2402: {
2403: Mt=getopt(mult);
1.50 takayama 2404: if(type(M)==7) M=s2sp(M);
2405: if(type(M)!=4) return 0;
2406: if(type(M[0])<=3){
2407: for(RR=[];M!=[];M=cdr(M)) RR=cons(mat([car(M)]),RR);
2408: M=reverse(RR);
2409: }
1.6 takayama 2410: if(type(M[0])!=6){ /* spectre type -> GRS */
2411: G=s2sp(M|std=1);
2412: L=length(G);
2413: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
2414: V=cons(makev([L+9]),V);
2415: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
2416: if(getopt(short)!=0){
2417: V=append(cdr(V),[V[0]]);
2418: G=shortv(G,V);
2419: }
2420: R=chkspt(G|mat=1);
2421: if(Mt!=1) Mt=0;
2422: if(R[2]!=2 || R[3]!=0 || !(R=getbygrs(G,1|mat=1))) return 0;
2423: MZ=newmat(1,1);
2424: SS=length(G);
2425: if(Mt==1) SS=SS*(SS-1)/2;
2426: for(M=[],I=0;I<SS;I++) M=cons(MZ,M);
2427: for(RR=R; RR!=[]; RR=cdr(RR)){
2428: RT=car(RR)[0];
2429: if(type(RT)==4){
2430: if(RT[0]!=0) M=mmc(M,[RT[0]]|simplify=Simp);
2431: M=mmc(M,[cdr(RT)]);
2432: }
2433: }
2434: /* for(R=cdr(R);R!=[];R=cdr(R)) M=mmc(M,[car(R)[0]]|mult=Mt); */
2435: }
2436: if(X==0) return M;
2437: L=length(M);
2438: if((L>=6 && Mt!=0)||(L==3&&Mt==1)){
2439: for(SS=2,I=3; I<L; I+=(++SS));
2440: if(I!=L) return -1;
2441: Mt=1;
2442: }else{
2443: SS=L;Mt=0;
2444: }
2445: if(length(X)==SS+1){
2446: if(car(X)!=0&&(M=mmc(M,[car(X)]|mult=Mt))==0) return M;
2447: return mmc(M,cdr(X)|mult=Mt);
2448: }
2449: for(I=X;I!=[];I=cdr(I)) if(I[0]!=0) break;
2450: if(I==[]) return M;
2451: Simp=getopt(simplify);
2452: if(Simp!=0 && type(Simp)!=1) Simp=2;
2453: N=newvect(L);
2454: for(I=0;I<L;I++) N[I]=dupmat(M[I]);
2455: S=size(N[0])[0];
2456: if(type(X)==4&&length(X)>SS){ /* addition */
2457: for(I=0;I<SS;I++,X=cdr(X)) if(X[I] != 0) N[I] = radd(N[I],car(X));
2458: }
2459: if(length(X)!=1) return 0;
2460: X=X[0];
2461: MZ = newmat(S,S);
2462: MM = newvect(L);
2463: for(M1=J=0; J<SS; J++){
2464: for(R=[],I=SS-1; I>=0; I--){
2465: if(I==J){
2466: for(RR=[],K=SS-1; K>=0; K--)
2467: RR=cons((K==I)?N[K]+diagm(S,[X]):N[K],RR);
2468: R=cons(RR,R);
2469: }else R=cons([MZ],R);
2470: }
2471: MM[J]=newbmat(SS,SS,R);
2472: if(J==0) M1=MM[0];
2473: else M1=radd(M1,MM[J]);
2474: }
2475: /* middle convolution */
2476: for(P=0,Q=1;J<L;J++){ /* A_{P,Q} */
2477: for(R=[],I=SS-1; I>=0; I--){
2478: for(RR=[],K=SS-1;K>=0;K--){
2479: MT=MZ;
2480: if(I==K){
2481: MT=N[J];
2482: if(I==P) MT-=N[Q];
2483: else if(I==Q) MT-=N[P];
2484: }else if(I==P && K==Q) MT=N[Q];
2485: else if(I==Q && K==P) MT=N[P];
2486: RR=cons(MT,RR);
2487: }
2488: R=cons(RR,R);
2489: }
2490: MM[J]=newbmat(SS,SS,R);
2491: if(++Q==SS){
2492: P++;Q=P+1;
2493: }
2494: }
2495: for(R=[],I=SS-1; I>=0; I--){
2496: for(RR=[N[I]],J=0; J<I; J++) RR=cons(MZ,RR);
2497: R=cons(RR,R);
2498: }
2499: M0 = newbmat(SS,SS,R);
2500: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
2501: if(length(KE) == 0) return MM;
2502: KK = mtoupper(lv2m(KE),0);
2503: for(I=0;I<L;I++) MM[I] = mmod(MM[I],KK);
2504: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
2505: return MM;
2506: }
2507:
2508: def lpgcd(L)
2509: {
2510: for(F=[]; L!=[]; L=cdr(L)){
2511: if((P=car(L))==0) continue;
2512: if(F==[]){
2513: F=fctr(P);
2514: S=length(F);
2515: S--;
2516: V=newvect(S);
2517: M=newvect(S);
2518: for(I=0; I<S; I++){
2519: M[I] = F[I+1][1];
2520: V[I] = F[I+1][0];
2521: }
2522: N=nm(ptozp(P|factor=1)[1]);
2523: continue;
2524: }
2525: N=igcd(ptozp(P|factor=1)[1],N);
2526: for(I=0; I<S; I++){
2527: for(Q=P,CT=0; CT<M[I]; CT++)
2528: if((Q=tdiv(Q,V[I])) == 0) break;
2529: if(CT<M[I]) M[I]=CT;
2530: }
2531: }
2532: if(F==[]) return 0;
2533: for(Q=N,I=0;I<S; I++){
2534: while(M[I]>0){
2535: Q *= V[I];
2536: M[I]--;
2537: }
2538: }
2539: return Q;
2540: }
2541:
2542: def mdivisor(M,X)
2543: {
2544: S=size(M=dupmat(M));
2545: XX=(type(X)==4||X==0)?X:[0,X];
2546: S0=S[0]; S1=S[1];
2547: if((Tr=getopt(trans))==1||Tr==2){
2548: Tr0=1;
2549: GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0);
2550: }else Tr=Tr0=0;
2551: /* 0,a,b : (a,b)->(1,1)
2552: 1 : (1,1) invertible
2553: 2,i,M : line 0,i by M
2554: 3,j,M : col 0,j by M
2555: 4,j : col 1 += col j
2556: 5,j,T : line j by T
2557: 6,j,T : col 1 += col j by T (non-com)
2558: 7,j : line 2<->j (non-com)
2559: */
2560: if(type(V=getopt(dviout))==1){
2561: if(type(XX)==4 && type(XX[0])>1) Var=[XX[1],"\\partial"];
2562: else Var=0;
2563: Tr=(abs(V)==3)?0:1;
2564: MM=dupmat(M);
2565: II=((S[0]>S[1])?S[1]:S[0])+1;
2566: if(abs(V)>1){
2567: Is1=Js1=S[0]+S[1];
2568: Is=Js=[0,[Is1]];
2569: }else{
2570: Is=[0,[Is1=S[0]]];Js=[0,[Js1=S[1]]];
2571: }
2572: VV=V;
2573: V=newvect(II);
2574: for(I=0;I<II;I++) V[I]=[];
2575: N=newbmat(2,2,[[M,mgen(S[0],0,[1],0)],[mgen(S[1],0,[1],0)]]);
2576: mdivisor(M,X|step=1,dviout=V);
2577: L=S[0]+S[1];
2578: if(Tr){
2579: NN=mperm(N,Is1,Js1);
2580: for(K=S[0];K<Is1;K++){
2581: for(L=S[1];L<Js1;L++)
2582: NN[K][L]=" ";
2583: }
2584: Out=[[mperm(NN,Is,Js)]];
2585: }
2586: for(I=1;I<II;I++){
2587: I0=I-1;
2588: if(V[I]==[]) continue;
2589: for(T=reverse(V[I]);T!=[];T=cdr(T)){
2590: St=[];
2591: C=car(R=car(T));
2592: if(C==0){
2593: N=mperm(N,(R[1]==0)?0:[[R[1]+I0,I0]],(R[2]==0)?0:[[R[2]+I0,I0]]);
2594:
2595: if(Tr){
2596: if(R[2]!=0) St=append(["C",I,"\\leftrightarrow C",R[2]+I],St);
2597: if(R[1]!=0){
2598: if(R[2]!=0) St=cons(",\\ ",St);
2599: St=append(["L",I,"\\leftrightarrow L",R[1]+I],St);
2600: }
2601: Out=cons(St,Out);
2602: }
2603: }else if(C==1){
2604: P=1/N[I0][I0];N[I0][I0]=1;
2605: if(P!=1){
2606: for(J=I;J<L;J++)
2607: N[I0][J]=muldo(P,N[I0][J],XX);
2608:
2609: if(Tr){
2610: St=append(["L",I,"\\leftarrow(",P,")","\\times L",I],St);
2611: Out=cons(St,Out);
2612: NN=mperm(N,Is1,Js1);
2613: for(K=S[0];K<Is1;K++){
2614: for(L=S[1];L<Js1;L++)
2615: NN[K][L]=" ";
2616: }
2617: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2618: }
2619: }
2620: for(F=0,J=I;J<S[0];J++){
2621: if((P=N[J][I0])==0) continue;
2622: F++;
2623: N[J][I0]=0;
2624: for(K=I;K<L;K++)
2625: N[J][K]=red(N[J][K]-muldo(P,N[I0][K],XX));
2626:
2627: }
2628: if(F){
2629: if(Tr){
2630: Out=cons(["Li\\ -\\!=\\ \\circ\\times L",I,"\\quad(i>",I,")"],Out);
2631: NN=mperm(N,Is1,Js1);
2632: for(K=S[0];K<Is1;K++){
2633: for(L=S[1];L<Js1;L++)
2634: NN[K][L]=" ";
2635: }
2636: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2637: }
2638: }
2639: for(F=0,J=I;J<S[1];J++){
2640: if((P=N[I0][J])==0) continue;
2641: F++;
2642: N[I0][J]=0;
2643: for(K=I;K<L;K++)
2644: N[K][J]=red(N[K][J]-muldo(N[K][I0],P,XX));
2645: }
2646: if(F&&Tr) Out=cons(["Cj\\ -\\!=\\ C",I,"\\times\\circ\\quad(j>",I,")"],Out);
2647: else continue;
2648: }else if(C==2){
2649: C=mat(N[I0],N[R[1]+I0]);C=muldo(R[2],C,XX);
2650: for(J=0;J<L;J++){
2651: N[I0][J]=C[0][J];N[R[1]+I0][J]=C[1][J];
2652: }
2653: if(Tr) Out=cons([dupmat(R[2]),"\\begin{pmatrix}L",I,"\\\\L",R[1]+I,
2654: "\\end{pmatrix}"],Out);
2655: }else if(C==3){
2656: C=newmat(L,2);
2657: for(J=0;J<L;J++){
2658: C[J][0]=N[J][I0];C[J][1]=N[J][R[1]+I0];
2659: }
2660: C=muldo(C,R[2],XX);
2661: for(J=0;J<L;J++){
2662: N[J][I0]=C[J][0];N[J][R[1]+I0]=C[J][1];
2663: }
2664: if(Tr) Out=cons(["\\begin{pmatrix}C",I,"&C",R[1]+I,"\\end{pmatrix}",
2665: dupmat(R[2])],Out);
2666: }else if(C==4){
2667: for(J=0;J<L;J++)
2668: N[J][I0]=red(N[J][I0]+N[J][R[1]+I0]);
2669: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",R[1]+I],Out);
2670: }else if(C==5){
2671: for(J=0;J<L;J++)
2672: N[I0+R[1]][J]=red(R[2]*N[I0+R[1]][J]);
2673: if(Tr) Out=cons(["L",I+R[1],"\\leftarrow(", R[2],")\\times L",I+R[1]],
2674: Out);
2675: }else if(C==6){
2676: for(J=0;J<L;J++)
2677: N[J][I0]=N[J][I0]+muldo(N[J][I0+R[1]],R[2],XX);
2678: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",I+R[1],"\\times(", R[2],")"],
2679: Out);
2680: }else if(C==7){
2681: mycat(["line",I+1,"\\leftrightarrow",R[1]+I]);
2682: for(J=0;J<L;J++){
2683: C=N[I][J];N[I][J]=N[R[1]+I0][J];N[R[1]+I0][J]=C;
2684: }
2685: if(Tr) Out=cons(["L",I+1,"\\leftrightarrow L",R[1]+I],Out);
2686: }
2687: if(Tr){
2688: NN=mperm(N,Is,Js);
2689: for(K=S[0];K<Is1;K++){
2690: for(L=S[1];L<Js1;L++)
2691: NN[K][L]=" ";
2692: }
2693: Out=cons(["\\to",NN],Out);
2694: }
2695: }
2696: }
2697: if(!Tr){
2698: NN=mperm(N,Is,Js);
2699: Out=[];
2700: }
2701: if(S[0]+S[1]==Is1){
2702: N1=mperm(NN,[0,[S[0]]],[S[1],[S[0]]]);
2703: N2=mperm(NN,[S[0],[S[1]]],[0,[S[1]]]);
2704: N3=mperm(NN,[0,[S[0]]],[0,[S[1]]]);
2705: R1=mdivisor(N1,X|trans=1)[1];
2706: R2=mdivisor(N2,X|trans=1)[1];
2707: if(Tr){
2708: Out=cons(["\\text{As a result,}"],Out);
2709: Out=cons([N3,"=",N1,MM,N2],Out);
2710: if(S[0]==S[1] && N3==mgen(S[0],0,1,0)){
2711: Out=cons(["=",muldo(N2,N1,XX),MM,"."],Out);
2712: }else{
2713: Out=cons([N1,"^{-1}=",R1,","],Out);
2714: Out=cons([N2,"^{-1}=",R2,"."],Out);
2715: }
2716: }else{
2717: Out=cons([N3,"=P",MM,"Q,"],Out);
2718: Out=cons(["P=",N1,"=",R1,"^{-1},"],Out);
2719: Out=cons(["Q=",N2,"=",R2,"^{-1}."],Out);
2720: }
2721: }
2722: Out = ltotex(reverse(Out)|opt=["cr","spts0"],str=1,cr=15,var=Var);
2723: if(S[0]+S[1]==Is1)
2724: Out=str_subst(Out,"\\texttt{ }","");
2725: if(VV>0){
2726: dviout(Out|eq=6);
2727: return NN;
2728: }
2729: return Out;
2730: }else if(type(V)!=5) V=0;
2731:
2732: if(type(St=getopt(step))!=1) St=0;
2733: for(FF=": start";;){
2734: if(St && V==0){
2735: if(Tr){
2736: mycat0([St,FF,"\n"],0);
2737: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2738: }
2739: else mycat0([St,FF,"\n",M,"\n"],0);
2740: }
2741: if(X==0||X==[0,0]){ /* search minimal non-zero element */
2742: for(K=F=I=0; I<S0; I++){
2743: for(J=0; J<S1; J++){
2744: if((P=abs(M[I][J]))!=0 && (K>P || K==0)){
2745: K=P; R=[I,J];
2746: }
2747: }
2748: }
2749: R=cons(K-1,[R]);
2750: }
2751: else R=mymindeg(M,XX[1]|opt=1);
2752: if(R[0]<0){ /*zero matrix */
2753: if(Tr) return [[],mgen(S0,0,1,0),mgen(S1,0,1,0)];
2754: return [];
2755: }
2756: R0=R[1][0];R1=R[1][1];
2757: if(R0!=0){
2758: M=rowx(M,0,R0);
2759: if(Tr) GR=rowx(GR,0,R0);
2760: }
2761: if(R1!=0){
2762: M=colx(M,0,R1);
2763: if(Tr) GC=colx(GC,0,R1);
2764: }
2765: if(St>0 && (R0!=0 || R1!=0))
2766: if(type(V)==5) V[St]=cons([0,R0,R1],V[St]);
2767: else if(Tr){
2768: mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n"],0);
2769: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2770: }else mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n",M,"\n"],0);
2771: if(R[0]==0){ /* (1,1) : invertible */
2772: if(type(V)==5) V[St]=cons([1],V[St]);
2773: P=M[0][0]; M[0][0]=1;
2774: for(J=0;J<S1;J++){ /* (1,1) -> 1 */
2775: if(J>0) M[0][J]= red(M[0][J]/P);
2776: if(Tr) GR[0][J]=red(GR[0][J]/P);
2777: }
2778: if(S0>1 && S1>1) N=newmat(S0-1,S1-1);
2779: else N=0;
2780: for(I=1;I<S0;I++){
2781: P=M[I][0]; M[I][0]=0;
2782: for(J=1;J<S1;J++)
2783: N[I-1][J-1]=M[I][J]=red(M[I][J] - muldo(P,M[0][J],XX));
2784: if(Tr){
2785: for(J=0;J<S0;J++)
2786: GR[I][J] = red(GR[I][J] -muldo(P,GR[0][J],XX));
2787: }
2788: }
2789: if(Tr){
2790: for(J=1;J<S1; J++){
2791: for(I=0;I<S1;I++) GC[I][J]=red(GC[I][J]-muldo(GC[I][0],M[0][J],XX));
2792: M[0][J]=0;
2793: }
2794: }
2795: if(St>0 && V==0){
2796: if(Tr){
2797: mycat0([St,": unit\n"],0);
2798: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2799: }
2800: else mycat0([St,": unit\n",M,"\n"],0);
2801: }
2802: if(N==0){
2803: if(!Tr) return [1];
2804: if(Tr==2){
2805: GR0=mdivisor(GR,X|trans=1)[1];
2806: GC0=mdivisor(GC,X|trans=1)[1];
2807: return [[1],GR,GC,GR0,GC0];
2808: }
2809: return [[1],GR,GC];
2810: }
2811: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2812: if(!Tr) return cons(1,R);
2813: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2814: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2815: if(S0==S1 && countin(1,1,R[0])==S0-1){
2816: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2817: }
2818: if(Tr==2){
2819: GR0=mdivisor(GR,X|trans=1)[1];
2820: GC0=mdivisor(GC,X|trans=1)[1];
2821: return [cons(1,R[0]),GR,GC,GR0,GC0];
2822: }
2823: return [cons(1,R[0]),GR,GC];
2824: }
2825: for(I=1;I<S0;I++){
2826: if(M[I][0]!=0){
2827: /* Error! when mygcd(A,B,0) with A<=0 or B<=0 */
2828: R=mygcd(M[I][0],M[0][0],XX); /* R[0]=R[1]*M[I][0]+R[2]*M[0][0] */
2829: M[0][0]=R[0]; M[I][0]=0; /* 0=R[3]*M[I][0]+R[4]*M[0][0] */
2830: for(J=1;J<S1;J++){
2831: T=red(muldo(R[1],M[I][J],XX)+muldo(R[2],M[0][J],XX));
2832: M[I][J]=red(muldo(R[3],M[I][J],XX)+muldo(R[4],M[0][J],XX));
2833: M[0][J]=T;
2834: }
2835: if(Tr){
2836: for(J=0;J<S0;J++){
2837: T=red(muldo(R[1],GR[I][J],XX)+muldo(R[2],GR[0][J],XX));
2838: GR[I][J]=red(muldo(R[3],GR[I][J],XX)+muldo(R[4],GR[0][J],XX));
2839: GR[0][J]=T;
2840: }
2841: }
2842: if(St && V==0){
2843: mycat([" [",R[2],R[1],"]*"]);
2844: mycat([" [",R[4],R[3],"]"]);
2845: }
2846: if(type(V)==5) V[St]=cons([2,I,mat([R[2],R[1]],[R[4],R[3]])],V[St]);
2847: FF=": line 1 & "+rtostr(I+1); I=S0;
2848: }
2849: }
2850: if(I>S0) continue;
2851: for(J=1;J<S1;J++){
2852: if(M[0][J]!=0){
2853: R=mygcd(M[0][J],M[0][0],XX|rev=1); /* R[0]=M[0][J]*R[1]+M[0][0]*R[2] */
2854: M[0][0]=R[0]; M[0][J]=0; /* 0=M[0][J]*R[3]+M[0][0]*R[4] */
2855: for(I=1;I<S0;I++){
2856: T=red(muldo(M[I][J],R[1],XX)+muldo(M[I][0],R[2],XX));
2857: M[I][J]=red(muldo(M[I][J],R[3],XX)+muldo(M[I][0],R[4],XX));
2858: M[I][0]=T;
2859: }
2860: if(Tr){
2861: for(I=0;I<S1;I++){
2862: T=red(muldo(GC[I][J],R[1],XX)+muldo(GC[I][0],R[2],XX));
2863: GC[I][J]=red(muldo(GC[I][J],R[3],XX)+muldo(GC[I][0],R[4],XX));
2864: GC[I][0]=T;
2865: }
2866: }
2867: if(type(V)==5) V[St]=cons([3,J,mat([R[2],R[4]],[R[1],R[3]])],V[St]);
2868: FF=": column 1 & "+rtostr(J+1);J=S1;
2869: if(St && V==0){
2870: mycat([" *[",R[2],R[4],"]"]);
2871: mycat([" [",R[1],R[3],"]"]);
2872: }
2873: }
2874: }
2875: if(J>S1) continue;
2876: if(S0==1 || S1==1){
2877: P=M[0][0];
2878: if(X==0){
2879: if(P<0){
2880: P=-P;
2881: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2882: if(type(V)==5) V[St]=cons([5,0,-1],V[St]);
2883: }
2884: }else{
2885: P=nm(P);
2886: if((R=fctr(P)[0][0])!=1){
2887: P/=R;
2888: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=R;
2889: if(type(V)==5) V[St]=cons([5,0,1/R],V[St]);
2890: }
2891: }
2892: if(!Tr) return [P];
2893: if(Tr==2){
2894: GR0=mdivisor(GR,X|trans=1)[1];
2895: GC0=mdivisor(GC,X|trans=1)[1];
2896: return [[P],GR,GC,GR0,GC0];
2897: }
2898: return [[P],GR,GC];
2899: }
2900: if(XX==0 || (type(XX)==4 && XX[0]==0)){ /* commutative case */
2901: P=M[0][0];
2902: for(I=1; I<S0; I++){
2903: for(J=1; J<S1; J++)
2904: if(divdo(M[I][J],P,XX)[1]!=0) break;
2905: if(J<S1){
2906: if(type(V)==5) V[St]=cons([4,J],V[St]);
2907: FF=": column 1 += col"+rtostr(J+1);
2908: for(I=1;I<S0;I++) M[I][0]=M[I][J];
2909: if(Tr) for(I=0;I<S1;I++) GC[I][0]=red(GC[I][0]+GC[I][J]);
2910: break;
2911: }
2912: }
2913: if(J<S1) continue;
2914: N=newmat(S0-1,S1-1);
2915: for(I=1;I<S0;I++)
2916: for(J=1;J<S1;J++) N[I-1][J-1]=red(M[I][J]/P);
2917: if(X==0){
2918: if(P<0) P=-P;
2919: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2920: }else{
2921: P=M[0][0];
2922: P=nm(P);
2923: P/=fctr(P)[0][0];
2924: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=fctr(P)[0][0];
2925: }
2926: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2927: RT=(Tr)?R[0]:R;
2928: for(RR=[],L=reverse(RT);L!=[];L=cdr(L))
2929: RR=cons(red(P*car(L)),RR);
2930: RR=cons(P,RR);
2931: if(!Tr) return RR;
2932: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2933: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2934: if(S0==S1 && countin(1,1,RR)==S0){
2935: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2936: }
2937: if(Tr==2){
2938: GR0=mdivisor(GR,X|trans=1)[1];
2939: GC0=mdivisor(GC,X|trans=1)[1];
2940: return [RR,GR,GC,GR0,GC0];
2941: }
2942: return [RR,GR,GC];
2943: } /* End of commutative case */
2944: for(I=1; I<S0; I++){
2945: for(J=1; J<S1; J++){
2946: if(M[I][J] != 0){
2947: for(T=1;I<S0;T*=XX[0]){
2948: R=divdo(muldo(M[I][J],T,XX),M[0][0],XX);
2949: if(R[1]!=0){
2950: if(type(V)==5) V[St]=cons([6,J,T],V[St]);
2951: FF=": column 1 += col"+rtostr((J+1)*T);
2952: if(I>1){
2953: M=rowx(M,1,I);
2954: if(Tr) GR=rowx(GR,1,I);
2955: if(type(V)==5) V[St]=cons([7,I],V[St]);
2956: FF+=", line 2<->"+rtostr(I+1);
2957: }
2958: for(I=1;I<S0;I++) M[I][0]=muldo(M[I][J],T,XX);
2959: if(Tr)
2960: for(I=1;I<S1;I++) GC[I][0]=red(GC[I][0]+muldo(GC[I][J],T,XX));
2961: I=S0+1; J=S1;
2962: break;
2963: }
2964: }
2965: }
2966: }
2967: if(I>S0) break;
2968: }
2969: if(I==S0) return []; /* zero matrix : never happen */
2970: }
2971: }
2972:
2973: def mdsimplify(L)
2974: {
2975: T=getopt(type);
2976: SS=0;
2977: if(type(L)==6){
2978: L=[L]; SS=1;
2979: }
2980: if(type(L)==5){
2981: SS=2;
2982: L = vtol(L);
2983: }
2984: M=car(L);
2985: S=size(M)[0];
2986: #if 0
2987: MN=newmat(S,S);
2988: MD=newmat(S,S);
2989: for(I=0;I<S;I++){
2990: for(J=0;J<S;J++){
2991: TN=0;TD=1;
2992: for(PL=L;PL!=[];PL=cdr(PL)){
2993: TM=red(car(PL)[I][J]);
2994: TN=lgcd([TN,nm(TM)]|pol=1);
2995: TD=llcm([TD,dn(TM)]|pol=1);
2996: }
2997: MN[I][J]=TM;
2998: MD[I][J]=TN;
2999: }
3000: }
3001: for(I=0;I<S;I++){
3002: for(J=0;J<S;J++){
3003: if(I==J||type(TD[I][J])<2||type(TN[J][I])<2) continue;
3004: for(FC=cdr(fctr(TD[I][J]));FC!=[];){
3005: TFC=car(FC);
3006: if(type(red(TN[J][I]/TFC[0]))>2) continue;
3007: }
3008: }
3009: }
3010: #endif
3011: DD=newvect(S);
3012: for(I=0; I<S; I++){
3013: LN=RN=[];
3014: LD=RD=1;
3015: for(LL=L; LL!=[]; LL=cdr(LL)){
3016: M = car(LL);
3017: for(J=0; J<S; J++){
3018: if(J==I) continue;
3019: if((MM=M[I][J]) != 0){
3020: LN = cons(nm(MM),LN);
3021: if(type(MM)==3 && tdiv(LD,P=dn(MM))==0)
3022: LD=tdiv(LD*P,gcd(LD,P));
3023: }
3024: if((MM=M[J][I]) != 0){
3025: RN = cons(nm(MM),RN);
3026: if(type(MM)==3 && tdiv(RD,P=dn(MM))==0)
3027: RD=tdiv(RD*P,gcd(RD,P));
3028: }
3029: }
3030: }
3031: if(T==1 || T==3) LQ=RD;
3032: else{
3033: P=lpgcd(LN);
3034: LQ=gcd(P,RD);
3035: if(P!=0) LQ *= nm(fctr(P)[0][0]);
3036: }
3037: if(T==1 || T==2) RQ=LD;
3038: else{
3039: P=lpgcd(RN);
3040: RQ=gcd(P,LD);
3041: if(P!=0) RQ *= nm(fctr(P)[0][0]);
3042: }
3043: if((P=gcdz(LQ,RQ))!=1){
3044: LQ = red(LQ/P); RQ=red(RQ/P);
3045: }
3046: DD[I]=red(LQ/RQ);
3047: if(LQ!=1 || RQ!=1){
3048: for(LA=[],LL=L; LL!=[]; LL=cdr(LL)){
3049: M = car(LL);
3050: for(J=0; J<S; J++){
3051: if(I!=J){
3052: if(LQ!=1){
3053: M[I][J] = red(M[I][J]/LQ);
3054: M[J][I] = red(M[J][I]*LQ);
3055: }
3056: if(RQ!=1){
3057: M[J][I] = red(M[J][I]/RQ);
3058: M[I][J] = red(M[I][J]*RQ);
3059: }
3060: }
3061: }
3062: }
3063: }
3064: }
3065: if(SS==2) L=ltov(L);
3066: if(SS==1) L=L[0];
3067: if(getopt(show)==1) L=[L,DD];
3068: return L;
3069: }
3070:
3071: def m2mc(M,X)
3072: {
3073: if(type(M)<2){
3074: mycat([
3075: "m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
3076: " m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
3077: " t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
3078: " s : TeX, dviout, GRSC\n",
3079: " option : swap, small, simplify, operator, int\n",
3080: " Ex: m2mc(\"21,21,21,21\",\"All\")\n"
3081: ]);
3082: return 0;
3083: }
3084: if(type(M)==7) M=s2sp(M);
3085: if(type(X)==7) X=[X];
3086: Simp=getopt(simplify);
3087: if(Simp!=0 && type(Simp)!=1) Simp=2;
3088: Small=(getopt(small)==1)?1:0;
3089: if(type(M[0])==4){
3090: if(type(M[0][0])==1){ /* spectral type */
3091: XX=getopt(dep);
3092: if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
3093: M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
3094: if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
3095: if(getopt(int)!=0){
3096: T=M[XX[0]-1][XX[1]-1][1];
3097: for(V=vars(T);V!=[];V=cdr(V)){
3098: F=coef(T,1,car(V));
3099: if(type(F)==1 && dn(F)>1)
3100: M = subst(M,car(V),dn(F)*car(V));
3101: }
3102: }
3103: V=vars(M);
3104: if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
3105: M=subst(M,d1,d);
3106: }
3107: RC=chkspt(M|mat=1);
3108: if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
3109: erno(0);return 0;
3110: }
3111: R=getbygrs(M,1|mat=1);
3112: if(getopt(anal)==1) return R; /* called by mc2grs() */
3113: Z=newmat(1,1,[[0]]);
3114: N=[Z,Z,Z,Z,Z];
3115: for(RR=R; RR!=[]; RR=cdr(RR)){
3116: RT=car(RR)[0];
3117: if(type(RT)==4){
3118: if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
3119: N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
3120: }
3121: }
3122: if(type(X)==4 && type(X[0])==7)
3123: return m2mc(N,X|keep=Keep,small=Small);
3124: return N;
3125: }
3126: if(type(X)==4 && type(X[0])==7){
3127: Keep=(getopt(keep)==1)?1:0;
3128: if(X[0]=="All"){
3129: dviout("Riemann scheme"|keep=1);
3130: m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
3131: dviout("Spectral types : "|keep=1);
3132: m2mc(M,["sp","dviout"]|keep=1);
3133: dviout("\\\\\nBy the decompositions"|keep=1);
3134: R=m2mc(M,["pairs","dviout"]|keep=1);
3135: for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
3136: for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
3137: if(S==0) R0=cons(I,R0);
3138: else if(S<0) R1=cons(I,R1);
3139: }
3140: S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
3141: +"\\ \\emptyset=\\mathbb Z\\cap$";
3142: dviout(S|keep=1);
3143: m2mc(M,["irreducible","dviout"]|keep=1);
3144: if(R0!=[])
3145: dviout(ltotex(reverse(R0))|eq=0,keep=1,
3146: title="The following conditions may not be necessary for the irreducibility.");
3147: if(R1!=[])
3148: dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
3149: if(getopt(operator)!=0){
3150: dviout("The equation in a Pfaff form is"|keep=1);
3151: m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
3152: }
3153: else if(Keep!=1) dviout(" ");
3154: return M;
3155: }
3156: Show=0;
3157: if(length(X)>1){
3158: if(X[1]=="dviout") Show=2;
3159: if(X[1]=="TeX") Show=1;
3160: }
3161: if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"){
3162: Y=radd(-M[0],-M[1]-M[2]);
3163: if(X[0]!="GRSC"){
3164: 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);
3165: if(X[0]=="sp"){
3166: L=chkspt(L|opt="sp");
3167: V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
3168: if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
3169: return [V,W];
3170: }
3171: S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
3172: }else{
3173: 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]),
3174: radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
3175: 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";
3176: }
3177: T=ltotex(L|opt="GRS",pre=S,small=Small);
3178: if(Show==2) dviout(T|eq=0,keep=Keep);
3179: if(Show==1) L=T;
3180: return L;
3181: }
3182: if(X[0]=="Pfaff"){
3183: S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
3184: if(Show==2) dviout(S|eq=0,keep=Keep);
3185: return S;
3186: }
3187: if(X[0]=="irreducible"){
3188: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3189: S=getbygrs(L,10|mat=1);
3190: if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
3191: return S;
3192: }
3193: if(X[0]=="pairs"||X[0]=="pair"){
3194: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3195: S=chkspt(L|opt=0);
3196: V=(Show==2)?1:0;
3197: S=sproot(L,X[0]|dviout=V,keep=Keep);
3198: return S;
3199: }
3200: if(X[0]=="swap"){
3201: Swap=getopt(swap);
3202: if(type(Swap)<1 || Swap==1)
3203: return newvect(5,[M[3],M[1],M[4],M[0],M[2]]);
3204: if(Swap==2)
3205: return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
3206: if(type(Swap)==4 && length(Swap)==3){
3207: MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
3208: if(Swap[0]==1){
3209: MX0=M[2];MY0=M[4];
3210: }
3211: else if(Swap[0]==2){
3212: MX0=MX;MY0=MY;
3213: }else{
3214: MX0=M[0];MY0=M[3];
3215: }
3216: if(Swap[1]==1){
3217: MX1=M[2];MY1=M[4];
3218: }
3219: else if(Swap[1]==2){
3220: MX1=MX;MY1=MY;
3221: }else{
3222: MX1=M[0];MY1=M[3];
3223: }
3224: return newvect(5,MX0,M[1],MX1,MY0,MY1);
3225: }
3226: }
3227: return 0;
3228: }
3229: if(getopt(swap)==1)
3230: return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
3231: N=newvect(5);
3232: for(I=0;I<5;I++)
3233: N[I]=M[I];
3234: S=size(N[0])[0];
3235: if(type(X)==4){
3236: for(I=0;I<3;I++){
3237: if(X[I] != 0)
3238: N[I] = radd(N[I],X[I]);
3239: }
3240: if(length(X)==3) return N;
3241: X=X[3];
3242: }
3243: MZ = newmat(S,S);
3244: ME = mgen(S,0,[X],0);
3245: MM = newvect(5);
3246: MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]);
3247: MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]);
3248: MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]);
3249: MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]);
3250: MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]);
3251: M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
3252: M1 = radd(MM[0],MM[1]+MM[2]);
3253: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
3254: if(length(KE) == 0) return MM;
3255: KK = mtoupper(lv2m(KE),0);
3256: for(I=0;I<5;I++)
3257: MM[I] = mmod(MM[I],KK);
3258: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
3259: return MM;
3260: }
3261:
3262: def easierpol(P,X)
3263: {
3264: if(type(X) == 4){
3265: for( Y = [] ; X != []; X = cdr(X) )
3266: Y = cons([0,car(X)], Y);
3267: }else
3268: Y = [0,X];
3269: return rede(P,Y);
3270: }
3271:
3272: def l2p(L,V)
3273: {
3274: if(type(L)==4){
3275: for(S=I=0;L!=[];L=cdr(L),I++)
3276: S+=car(L)*V^I;
3277: return S;
3278: }else if(type(L)==5){
3279: for(S=0,I=size(L)-1;I>=0;I--)
3280: S+=L[I]*V^I;
3281: return S;
3282: }else{
3283: if(type(D=getopt(size))==1) D--;
3284: else D=mydeg(L,V);
3285: for(S=[];D>=0;D--)
3286: S=cons(mycoef(L,D,V),S);
3287: return S;
3288: }
3289: }
3290:
3291: def paracmpl(L,V)
3292: {
3293: if(type(L)==4) L=ltov(L);
3294: S=length(L);
3295: Lim=getopt(lim);Low=getopt(low);
3296: if((F=type(L[0]))>3){
3297: SV=length(L[0]);
3298: V0=makenewv(L);
3299: for(LL=[];S>0;S--)
3300: LL=cons(l2p(L[S-1],V0),LL);
3301: G=paracmpl(LL,V|option_list=getopt());
3302: H=(Lim==1)?G:G[0];
3303: for(HH=[];H!=[];H=cdr(H)){
3304: HT=l2p(car(H),V0|size=SV);
3305: if(F==5) HT=ltov(HT);
3306: HH=cons(HT,HH);
3307: }
3308: H=reverse(HH);
3309: return (Lim==1)?H:[H,G[1]];
3310: }
3311: H=newvect(S);D=newvect(S);
3312: for(Dn=1,I=0;I<S;I++){
3313: P=dn(L[I]=red(L[I]));
3314: Dn=red(Dn*P/gcd(Dn,P));
3315: }
3316: if(Dn!=1){
3317: for(I=0;I<S;I++) L[I]=red(Dn*L[I]);
3318: }
3319: G=diagm(S,[1]);
3320: if(type(V)<4) V=[V];
3321: VV=lsort(vars(L),V,1);
3322: V=car(V);
3323: for(I=0;I<S;I++){
3324: P=L[I];
3325: for(J=0,C=P;J<I;J++){
3326: if(D[J]!=[]){
3327: C=mycoef(C,DT,VV);
3328: P-=C*H[J];
3329: G=cola(G,I,J,-C);
3330: }
3331: }
3332: if(P==0){
3333: D[I]=[];continue;
3334: }
3335: P0=nm(red(P));
3336: K=mymindeg(P0,V);
3337: C=mycoef(P0,K,V);
3338: if(K>0){
3339: P=red(P/V^K);
3340: G=colm(G,I,1/V^K);
3341: }
3342: for(DT=[],VT=VV;VT!=[];VT=cdr(VT)){
3343: K=(Low==1)?mymindeg(C,car(VT)):mydeg(C,car(VT));
3344: C=mycoef(C,K,car(VT));
3345: DT=cons(K,DT);
3346: }
3347: D[I]=DT=reverse(DT);
3348: for(C=P,VT=VV;VT!=[];VT=cdr(VT),DT=cdr(DT))
3349: C=mycoef(C,car(DT),car(VT));
3350: H[I]=P=red(P/C);
3351: G=colm(G,I,1/C);
3352: }
3353: if(Dn!=1){
3354: for(I=0;I<S;I++){
3355: TH=red(H[I]/Dn);
3356: F=fctr(dn(TH));F=cdr(F);
3357: if(Lim!=1||subst(Dn,V,0)==0){
3358: for(;F!=[];F=cdr(F)){
3359: if(lsort(vars(car(F)[0]),VV,2)==[]){
3360: C=car(F)[0]^car(F)[1];
3361: TH=red(TH*C);
3362: G=colm(G,I,C);
3363: }
3364: }
3365: }
3366: H[I]=TH;
3367: }
3368: }
3369: H=vtol(H);
3370: if(Lim==1){
3371: H=subst(H,V,0);
3372: return map(red,H);
3373: }
3374: return [H,map(red,G)];
3375: }
3376:
3377: def mykernel(M)
3378: {
3379: if(getopt(opt) == 1)
3380: M = mtranspose(M);
3381: S = size(M);
3382: R = [];
3383: MM = mtoupper(M,-1);
3384: for(I = S[0]-1; I >= 0; I--){
3385: for(J = S[1]-1; J >= 0; J--){
3386: if(MM[I][J] != 0)
3387: return R;
3388: }
3389: P = easierpol(MM[I][S[1]],zz);
3390: RR = newvect(S[0]);
3391: for(J = 0; J < S[0]; J++)
3392: RR[J] = mycoef(P,J,zz);
3393: R = cons(RR,R);
3394: }
3395: return R;
3396: }
3397:
3398: def myimage(M)
3399: {
3400: if(getopt(opt) == 1)
3401: M = mtranspose(M);
3402: S = size(M);
3403: V = [];
3404: M0 = newvect(S[1]);
3405: M = mtoupper(M,0|opt=1);
3406: for(I = S[0]-1; I >= 0; I--)
3407: if(M0 != M[I])
3408: V = cons(vtozv(M[I])[0], V);
3409: return V;
3410: }
3411:
3412: def mymod(V,L)
3413: {
3414: Opt = getopt(opt);
3415: S = length(V);
3416: VP = newvect(S);
3417: if(type(L)==6)
3418: L=m2lv(L);
3419: CT = length(L);
3420: for(LT = L; LT != []; LT = cdr(LT)){
3421: for(VT = car(LT), I = 0; I < S; I++)
3422: if(VT[I] != 0) break;
3423: if(I >= S){
3424: CT--;
3425: continue;
3426: }
3427: VP[I] = 1;
3428: MI = -red(V[I]/VT[I]);
3429: if(MI != 0)
3430: V = radd(V,rmul(MI,VT));
3431: }
3432: if(Opt==1){
3433: for(I = 0; I < S; I++)
3434: if(V[I] != 0)
3435: return 1;
3436: return 0;
3437: }
3438: if(Opt==2){
3439: W=newvect(S-CT);
3440: for(CC = I = 0; I < S; I++){
3441: if(VP[I]==0) W[CC++] =V[I];
3442: }
3443: return W;
3444: }
3445: return V;
3446: }
3447:
3448: def mmod(M,L)
3449: {
3450: S=size(M)[1];
3451: MM=mtranspose(M);
3452: VP = newvect(S);
3453: if(type(L)==6)
3454: L=m2lv(L);
3455: for(CT = 0, LT = L; LT != []; LT = cdr(LT)){
3456: for(VT = car(LT), I = 0; I < S; I++){
3457: if(VT[I] != 0){
3458: VP[I] = 1;
3459: break;
3460: }
3461: }
3462: }
3463: if(getopt(opt)==1)
3464: NE=1;
3465: for(D=I=0; I<S; I++){
3466: if(NE != 1 && VP[I] == 1) continue;
3467: T = mymod(MM[I],L|opt=2);
3468: if(D==0){
3469: K=length(T);
3470: MN=newmat((NE==1)?S:K,K);
3471: }
3472: for(J=0;J<K;J++)
3473: MN[J][D]=T[J];
3474: D++;
3475: }
3476: return MN;
3477: }
3478:
3479: def llsize(V)
3480: {
3481: for(I=J=0;V!=[];V=cdr(V),I++)
3482: if(length(car(V))>J) J=length(car(V));
3483: return [I,J];
3484: }
3485:
3486: def llbase(VV,L)
3487: {
3488: S = length(VV);
3489: V = dupmat(VV);
3490: if(type(V) == 4)
3491: V = ltov(V);
3492: T = length(L);
3493: for(I = 0; I < S; I++)
3494: V[I] = nm(red(V[I]));
3495: LV = 0;
3496: for(J = 0; J < T; J++){
3497: X = var(L[J]); N = deg(L[J],X);
3498: for(I = LV; I < S; I++){
3499: if((C2=coef(V[I],N,X)) != 0){
3500: if(I > LV){
3501: Temp = V[I];
3502: V[I] = V[LV];
3503: V[LV] = Temp;
3504: }
3505: for(I = 0; I < S; I++){
3506: if(I == LV || (C1 = coef(V[I],N,X)) == 0)
3507: continue;
3508: Gcd = gcd(C1,C2);
3509: V[I] = V[I]*tdiv(C2,Gcd)-V[LV]*tdiv(C1,Gcd);
3510: }
3511: LV++;
3512: }
3513: }
3514: }
3515: return V;
3516: }
3517:
1.44 takayama 3518: def rsort(L,T,K)
3519: {
3520: for(R=[];L!=[];L=cdr(L))
3521: R=cons((type(car(L))==4)?rsort(car(L),T-1,K):car(L),R);
3522: if(T>0||iand(T,iand(K,2)/2)) return reverse(R);
3523: R=qsort(R);
3524: return (iand(K,1))? reverse(R):R;
3525: }
3526:
1.60 takayama 3527: def llget(L,LL,LC)
3528: {
3529: if(type(LL)==4){
3530: LM=length(L);
3531: for(R=[];LL!=[];LL=cdr(LL)){
3532: if(isint(TL=car(LL))) R=cons(TL,R);
3533: else{
3534: IM=(length(TL)==1)?(LM-1):TL[1];
3535: for(I=car(TL);I<=IM;I++) R=cons(I,R);
3536: }
3537: }
3538: LL=reverse(R);
3539: if(LC==-1){
3540: LL=lsort(LL,[],1);
3541: return lsort(L,"num",["sub"]|c1=LL);
3542: }
3543: L=lsort(L,"num",["get"]|c1=LL);
3544: }
3545: if(type(LC)==4){
3546: LM=length(L[0]);
3547: for(R=[];LC!=[];LC=cdr(LC)){
3548: if(isint(TL=car(LC))) R=cons(TL,R);
3549: else{
3550: IM=(length(TL)==1)?(LM-1):TL[1];
3551: for(I>=car(TL);I<=IM;I++) R=cons(I,R);
3552: }
3553: }
3554: LC=reverse(R);
3555: if(LL==-1){
3556: LC=lsort(LC,[],1);
3557: return lsort(L,"col",["setminus"]|c1=LC);
3558: }
3559: L=lsort(L,"col",["put"]|c1=LC);
3560: }
1.63 takayama 3561: if(getopt(flat)==1) L=m2l(L|flat=1);
1.60 takayama 3562: return L;
3563: }
3564:
1.44 takayama 3565:
1.6 takayama 3566: def lsort(L1,L2,T)
3567: {
1.10 takayama 3568: C1=getopt(c1);C2=getopt(c2);
1.8 takayama 3569: if(type(T)==4){
3570: K=T;
1.10 takayama 3571: if(length(T)>0){
3572: T=K[0];
3573: K=cdr(K);
1.12 takayama 3574: }else T=0;
1.8 takayama 3575: }else K=0;
1.10 takayama 3576: if(type(TT=T)==7)
3577: T = findin(T,["cup","setminus","cap","reduce","sum","subst"]);
3578: if(type(L2)==7&&T<0)
3579: T=findin(TT,["put","get","sub"]);
3580: if(K){ /* [[..],..] */
3581: if(K!=[]) KN=K[0];
3582: if(L2==[]||L2=="sort"){ /* sort or deduce duplication */
3583: if((T!=0&&T!=3)||length(K)!=1) return L1;
1.8 takayama 3584: if(KN<0){
3585: KN=-KN-1;
3586: F=-1;
3587: }else F=1;
3588: L1=msort(L1,[F,0,KN]);
1.10 takayama 3589: if(T==3){
1.8 takayama 3590: R=[car(L1)];L1=cdr(L1);
3591: for(;L1!=[];L1=cdr(L1)){
3592: if(car(L1)[KN]!=car(R)[KN]) R=cons(car(L1),R);
3593: }
3594: L1=reverse(R);
3595: }
3596: return L1;
1.10 takayama 3597: }else if((L2==0||L2=="col")&&type(C1)==4){
1.8 takayama 3598: if(T==0||T==1){ /* extract or delete columns */
3599: for(R=[];L1!=[];L1=cdr(L1)){
1.10 takayama 3600: if(T==1&&C1==[0]){ /* delete top column */
1.8 takayama 3601: R=cons(cdr(car(L1)),R);
3602: continue;
3603: }
1.10 takayama 3604: LT=car(L1);RT=[];
1.8 takayama 3605: if(T==0){
1.10 takayama 3606: for(CT=C1;CT!=[];CT=cdr(CT)) RT=cons(LT[car(CT)],RT);
1.8 takayama 3607: }else{
1.10 takayama 3608: for(I=0;LT!=[];I++,LT=cdr(LT))
1.8 takayama 3609: if(findin(I,C1)<0) RT=cons(car(LT),RT);
3610: }
1.59 takayama 3611: R=cons(reverse(RT),R);
1.8 takayama 3612: }
3613: return reverse(R);
3614: }
1.10 takayama 3615: }else if(type(L2)==1||type(L2)==7){
3616: if(L2==1||L2=="num"){
3617: if(T==4) T=3;
3618: I=(length(K)<2)?(-1):K[1];
3619: if(T==0||T==1||T==2||T==3){
3620: S=F=CT=0;R=[];
3621: if(K==[] || type((S=K[0]))==1 || S==0){
3622: if(T==0||T==1||T==2){
3623: for(J;L1!=[];L1=cdr(L1),J++){
3624: if(T==0) R=cons(cons(J+S,car(L1)),R);
3625: else if(T==1){
3626: for( ;C1!=[]; C1=cdr(C1))
3627: R=cons(L1[car(C1)],R);
3628: }else{
3629: if(findin(J,C1)<0) R=cons(car(L1),R);
3630: }
3631: }
3632: return reverse(R);
3633: }else if(T==3) return length(L1);
3634: }else{
3635: if(type(S)==2&&vtype(S)>2) F=1;
3636: else if(type(S)==4) F=2;
3637: else if(S=="+") F=3;
3638: else return L1;
3639: }
3640: for(R=[];L1!=[];L1=cdr(L1)){
3641: L1T=car(L1);
3642: if(F==1) V=call(S,(I<0)?L1T:L1T[I]);
3643: else if(F==2) V=calc((I<0)?L1T:L1T[I],S);
3644: else if(F==3){
3645: for(C=C1,V=0;C!=[];C=cdr(C))
3646: if(type(X=L1T[car(C)])==1) V+=X;
3647: }
3648: if(T==0) R=cons(cons(V,L1T),R);
3649: else if(T==1){
3650: if(V) R=cons(L1T,R);
3651: }else if(T==2){
3652: if(!V) R=cons(L1T,R);
3653: }else if(T==3){
3654: if(F==3) CT+=V;
3655: else if(V) CT++;
3656: }
3657: }
3658: return (T==3)?CT:reverse(R);
3659: }else if(TT=="col"){
3660: J=(length(K)>0)?car(K):0;
3661: I=length(car(L1))+J;
3662: for(V=[];I>J;)
3663: V=cons(--I,V);
3664: return cons(V,L1);
3665: }
3666: }else if(L2=="transpose") return mtranspose(L1);
1.12 takayama 3667: else if(L2=="subst"||L2=="adjust"){
3668: Null=(!K)?"":car(K);
1.17 takayama 3669: if(L2=="adjust") C1=[];
1.12 takayama 3670: R=lv2m(L1|null="");
1.10 takayama 3671: for(;C1!=[];C1=cdr(C1)) R[car(C1)[0]][car(C1)[1]]=car(C1)[2];
3672: return m2ll(R);
3673: }
3674: return L1;
3675: }else{ /* [[..],..], [[..],..] */
3676: if(type(L2[0])<4){
3677: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3678: L2=reverse(R);
3679: }
3680: if(TT=="sum") T=3;
3681: if(TT=="over") T=4;
3682: if(findin(T,[0,1,2,3,4,5])<0) return L1;
3683: if(T==4||T==5){
3684: if(type(C1)<2) C1=[C1];
3685: if(type(C2)<2) C2=[C2];
3686: }
1.8 takayama 3687: if(type(car(L2))!=4){
3688: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3689: R=reverse(R);
3690: if(length(K)==1) K=[K[0],0];
3691: C2=0;
3692: }
1.10 takayama 3693: L1=lsort(L1,"num",["put",0]); /* insert number */
3694: K0=(length(K)>0)?K[0]+1:1;
3695: K1=(length(K)>1)?K1=K[1]:0;
3696: L1=lsort(L1,"sort",[0,K0]);
3697: if(T<4&&type(C2)==4&&length(L2[0])>1){
3698: L2=lsort(L2,"col",["put"]|c1=cons(K1,C2)); /* add key and extract columns */
3699: C2=0;K1=0;
3700: }
3701: L2=lsort(L2,"sort",[0,K1]);
3702: for(R0=[],S=S1=length(L1[0]);S>0;S--) R0=cons("",R0);
3703: for(R1=[],S=length(L2[0]);S>0;S--) R1=cons("",R1);
3704: if(!K1&&T!=3) R1=cdr(R1);
3705: for(R=[];L1!=[];L1=cdr(L1)){
3706: while(L2!=[]&&car(L1)[K0]>car(L2)[K1]){
3707: if(T==3) R=cons(append(R0,car(L2)),R);
3708: L2=cdr(L2);
3709: }
3710: if(L2==[]||car(L1)[K0]<car(L2)[K1]){
3711: if(T!=2) R=cons((T==1||T>3||R1==[])?car(L1):append(car(L1),R1),R);
3712: }else if(T==0||T==2||T==3){
3713: if(R0==[]) R=append(car(L1),R);
3714: else R=cons(append(car(L1),(!K1&&T!=3)?cdr(car(L2)):car(L2)),R);
3715: L2=cdr(L2);
3716: }else if(T==4||T==5){
3717: V1=ltov(car(L1));V2=ltov(car(L2));
3718: for(D1=C1,D2=C2;D1!=[];D1=cdr(D1),D2=cdr(D2))
3719: if((I=V2[car(D2)])!=""||T==4) V1[car(D1)+1]=I;
3720: R=cons(vtol(V1),R);
3721: }
3722: }
3723: if(T==3){
3724: while(L2!=[]){
3725: R=cons(append(R0,car(L2)),R);
3726: L2=cdr(L2);
3727: }
3728: }
3729: R=lsort(R,"sort",["put",0]); /* original order */
3730: D=(((T==0||T==2)&&!K1)||T==3)?[0]:[0,S1+K1];
3731: R=lsort(R,0,[1]|c1=D); /* delete */
3732: if(type(C1)!=4||T==1||T==4||T==5) return R;
3733: C=[];S0=size(L1[0]);
3734: for(;C1!=[];C1=cdr(C1)) C=cons(car(C1),C);
3735: for(I=0;I<S0-S1;I++) C=cons(I+S1,C);
1.8 takayama 3736: C=reverse(C);
1.10 takayama 3737: return lsort(R,"col",[1]|c1=C);
1.8 takayama 3738: }
3739: }
1.10 takayama 3740: if(L2 == []){ /* [...] */
3741: if(T==8||TT=="count") return [length(L1),length(lsort(L1,[],1))];
3742: if(T==7||TT=="cut"){
3743: K=length(L1);
3744: if(C1<0) C1=K+C1;
3745: for(R=[],I=0;I<C1&&L1!=[];I++,L1=cdr(L1))
3746: R=cons(car(L1),R);
3747: for(S=[];L1!=[];L1=cdr(L1))
3748: S=cons(car(L1),S);
3749: return [reverse(R),reverse(S)];
3750: }
3751: if(T==2) return L2;
3752: if(T==3) return [L1,L2];
1.6 takayama 3753: L1 = ltov(L1); qsort(L1);
3754: if(T != 1)
3755: return vtol(L1);
3756: L3 = [];
3757: for(I = length(L1)-1; I >= 0; I--){
3758: if(I > 0 && L1[I] == L1[I-1])
3759: continue;
3760: L3 = cons(L1[I], L3);
3761: }
3762: return L3;
3763: }
1.10 takayama 3764: if(T==8||TT=="count"){
3765: K=length(lsort(L1,L2,3)[0]);
3766: R=[length(L2),length(L1)];
3767: L1 = lsort(L1,[],1);
3768: L2 = lsort(L2,[],1);
3769: R=append([length(L2),length(L1)],R);
3770: R=cons(length(lsort(L1,L2,2)),R);
3771: return reverse(cons(K,R));
3772: }
1.12 takayama 3773: if((T==9||TT=="cons")&&type(car(L1))==4){
3774: if(type(L2)!=4) L2=[L2];
3775: for(R=[];L1!=[];L1=cdr(L1)){
3776: R=cons(cons(car(L2),car(L1)),R);
3777: if(length(L2)>1) L2=cdr(L2);
3778: }
3779: return reverse(R);
3780: }
1.13 takayama 3781: if(T==10||TT=="cmp"){
3782: if(length(L1)!=length(L2)){
3783: mycat("Different length!");
3784: return 1;
3785: }
3786: R=[];
3787: if(type(car(L1))==4){
3788: for(U=[],I=0;L1!=[];I++,L1=cdr(L1),L2=cdr(L2)){
3789: if(length(S=car(L1))!=length(T=car(L2))){
3790: mycat(["Different size : line ",I]);
3791: return 0;
3792: }
3793: for(J=0;S!=[];S=cdr(S),T=cdr(T),J++)
3794: if(car(S)!=car(T)) U=cons([[I,J],car(S),car(T)],U);
3795: }
3796: if(U!=[]) R=cons(reverse(U),R);
3797: }else{
3798: for(I=0;L1!=[];L1=cdr(L1),L2=cdr(L2),I++)
3799: if(car(L1)!=car(L2)) R=cons([I,car(L1),car(L2)],R);
3800: }
3801: return reverse(R);
3802: }
3803: if(T==11||TT=="append"){
3804: if(type(car(L1))!=4) return append(L1,L2);
3805: for(R=[];L1!=[];L1=cdr(L1),L2=cdr(L2))
3806: R=cons(append(car(L1),car(L2)),R);
3807: return reverse(R);
3808: }
1.6 takayama 3809: if(T == 1 || T == 2){
3810: L1 = lsort(L1,[],1);
3811: L2 = lsort(L2,[],1);
3812: L3 = [];
3813: if(T == 1){
3814: while(L1 != []){
3815: if(L2 == [] || car(L1) < car(L2)){
3816: L3 = cons(car(L1), L3);
3817: L1 = cdr(L1);
3818: continue;
3819: }
3820: if(car(L1) > car(L2)){
3821: L2 = cdr(L2);
3822: continue;
3823: }
3824: L1 = cdr(L1); L2 = cdr(L2);
3825: }
3826: return reverse(L3);
3827: }
3828: if(T==2){
3829: while(L1 != [] && L2 != []){
3830: if(car(L1) != car(L2)){
3831: if(car(L1) <= car(L2))
3832: L1 = cdr(L1);
3833: else L2 = cdr(L2);
3834: continue;
3835: }
3836: while(car(L1) == car(L2))
3837: L1 = cdr(L1);
3838: L3 = cons(car(L2), L3);
3839: }
3840: return reverse(L3);
3841: }
3842: }
3843: if(T==3){
3844: L1 = qsort(L1); L2 = qsort(L2);
3845: L3 = L4 = [];
3846: while(L1 != [] && L2 != []){
3847: if(car(L1) == car(L2)){
3848: L1 = cdr(L1); L2 = cdr(L2);
3849: }else if(car(L1) < car(L2)){
3850: L3 = cons(car(L1),L3);
3851: L1 = cdr(L1);
3852: }else{
3853: L4 = cons(car(L2), L4);
3854: L2 = cdr(L2);
3855: }
3856: }
3857: L4 = append(reverse(L4),L2);
3858: L3 = append(reverse(L3),L1);
3859: return [L3,L4];
3860: }
3861: L1 = append(L1,L2);
3862: return lsort(L1,[],1);
3863: }
3864:
3865: def mqsub(X,Y)
3866: {
3867: for(L=LQS;L!=[];L=cdr(L)){
3868: F=(T=car(L))[0];M=(T=cdr(T))[0];
3869: X0=X;Y0=Y;
3870: for(T=cdr(T);T!=[];T=cdr(T)){
3871: X0=X0[car(T)];Y0=Y0[car(T)];
3872: }
3873: if(type(M)==1){
3874: if(M==3){
3875: X0=type(X0);Y0=type(Y0);
3876: }else if(M==4&&type(X0)<2&&type(Y0)<2){
3877: X0=abs(X0);Y0=abs(Y0);
3878: }else if(M==5){
3879: X0=str_len(rtostr(X0));Y0=str_len(rtostr(Y0));
3880: }else if(type(X0)==type(Y0)&&type(X0)>3&&type(X0)<7){
3881: if(M==1){
3882: X0=length(X0);Y0=length(Y0);
3883: }else if(M==2){
3884: LX=length(X0);LY=length(Y0);
3885: L0=(LX<LY)?LX:LY;
3886: for(I=0;;I++){
3887: if(I==L0){
3888: X0=LX;Y0=LY;break;
3889: }
3890: if(X0[I]==Y0[I]) continue;
3891: X0=X0[I];Y0=Y0[I];break;
3892: }
3893: }
3894: }
3895: }else if(type(M)==2){
3896: X0=(*M)(X0,Y0);Y0=0;
3897: }else if(type(M)==4&&length(M)==1){
3898: X0=(*car(M))(X0);Y0=(*car(M))(Y0);
3899: }
3900: if(X0==Y0) continue;
3901: return (X0<Y0)?-F:F;
3902: }
3903: return 0;
3904: }
3905:
3906: def msort(L,S)
3907: {
3908: if(type(S)!=4) return qsort(L);
3909: if(type(S[0])!=4) S=[S];
3910: LQS=S;
3911: return qsort(L,os_md.mqsub);
3912: }
3913:
1.22 takayama 3914: def lpair(A,B)
3915: {
3916: if(B==0){
3917: for(S=T=[];A!=[];A=cdr(A)){
3918: S=cons(car(A)[0],S);T=cons(car(A)[1],T);
3919: }
3920: return [reverse(S),reverse(T)];
3921: }else{
3922: for(R=[];A!=[];A=cdr(A),B=cdr(B))
3923: R=cons([car(A),car(B)],R);
3924: return reverse(R);
3925: }
3926: }
3927:
1.6 takayama 3928: def lmax(L)
3929: {
3930: if(type(L)==4){
3931: V=car(L);
3932: while((L=cdr(L))!=[])
3933: if(V < car(L)) V=car(L);
3934: return V;
3935: }else if(type(L)==5||type(L)==6)
3936: return lmax(m2l(L));
3937: return [];
3938: }
3939:
3940: def lmin(L)
3941: {
3942: if(type(L)==4){
3943: V=car(L);
3944: while((L=cdr(L))!=[])
3945: if(V > car(L)) V=car(L);
3946: return V;
3947: }else if(type(L)==5||type(L)==6)
3948: return lmin(m2l(L));
3949: return [];
3950: }
3951:
3952: def lgcd(L)
3953: {
3954: if(type(L)==4){
3955: F=getopt(poly);
3956: V=car(L);
3957: while((L=cdr(L))!=[]&&V!=1){
3958: if(V!=0)
3959: V=(F==1)?gcd(V,car(L)):igcd(V,car(L));
3960: }
3961: return V;
3962: }else if(type(L)==5||type(L)==6)
3963: return lgcd(m2l(L)|option_list=getopt());
3964: return [];
3965: }
3966:
1.56 takayama 3967: def llcm(R)
3968: {
1.60 takayama 3969: if(type(R)==5||type(R)==6) R=m2l(R);
1.56 takayama 3970: if(type(R)<4) R=[R];
3971: if(type(R)!=4) return 0;
3972: V=getopt(poly);
3973: if(type(V)<1){
3974: for(L=R;L!=[];L=cdr(L)){
3975: if(type(car(L))>1){
3976: V=1; break;
3977: }
3978: }
3979: }
3980: if(getopt(dn)!=1){
3981: for(L=[];R!=[];R=cdr(R)) if(R!=0) L=cons(1/car(R),L);
3982: R=L;
3983: }
3984: P=1;
3985: if(type(V)<1){
3986: for(;R!=[];R=cdr(R)){
3987: if(!(TL=car(R))) continue;
3988: else P=ilcm(P,dn(TL));
3989: }
3990: return P;
3991: }
3992: for(;R!=[];R=cdr(R)){
3993: if(!car(R)) continue;
3994: D=dn(red(car(R)));
3995: N=red(P/D);
3996: if(type(V)<2){
3997: if(type(N)!=3) continue;
3998: P*=dn(N);
3999: continue;
4000: }
4001: if(ptype(N,V)>2){
4002: L=fctr(dn(N));
4003: for(;L!=[];L=cdr(L)){
4004: if(ptype(car(L)[0],V)<2) continue;
4005: P*=car(L)[0]^car(L)[1];
4006: }
4007: }
4008: }
4009: return P;
4010: }
1.6 takayama 4011:
4012: def ldev(L,S)
4013: {
4014: M=abs(lmax(L));N=abs(lmin(L));
4015: if(M<N) M=N;
4016: for(C=0,LT=L;;C++){
4017: LT=ladd(LT,S,1);
4018: MT=abs(lmax(LT));NT=abs(lmin(LT));
4019: if(MT<NT) MT=NT;
4020: if(MT>=M) break;
4021: M=MT;
4022: }
4023: if(!C){
4024: for(C=0,LT=L;;C--){
4025: LT=ladd(LT,S,-1);
4026: MT=abs(lmax(LT));NT=abs(lmin(LT));
4027: if(MT<NT) MT=NT;
4028: if(MT>=M) break;
4029: M=MT;
4030: }
4031: }
4032: return [C,ladd(L,S,C)];
4033: }
4034:
4035: def lchange(L,P,V)
4036: {
4037: if(getopt(flat)==1&&type(P)==4){
4038: for(L=ltov(L);P!=[];P=cdr(P),V=cdr(V))
4039: L[car(P)]=car(V);
4040: return vtol(L);
4041: }
4042: if(type(P)==4){
4043: IP=car(P); P=cdr(P);
4044: }else{
4045: IP=P; P=[];
4046: }
4047: for(I=0, LL=[], LT=L; LT!=[]; I++,LT=cdr(LT)){
4048: if(I==IP){
4049: LL=cons((P==[])?V:lchange(car(LT),P,V),LL);
4050: }else
4051: LL=cons(car(LT),LL);
4052: }
4053: return reverse(LL);
4054: }
4055:
4056: def lsol(VV,L)
4057: {
4058: if(type(VV)<4 && type(L)==2)
4059: return red(L-VV/mycoef(VV,1,L));
4060: S = length(VV);
4061: T = length(L);
4062: V = llbase(VV,L);
4063: for(J = K = 0; J < T; J++){
4064: X = var(L[J]); N = deg(L[J],X);
4065: for(I = K; I < S; I++){
4066: if((C=mycoef(V[I], N, X)) != 0){
4067: V[I] = [L[J],red(X^N-V[I]/C)];
4068: K++;
4069: break;
4070: }
4071: }
4072: }
4073: return V;
4074: }
4075:
4076: def lnsol(VV,L)
4077: {
4078: LL=lsort(vars(VV),L,1);
4079: VV=ptol(VV,LL|opt=0);
4080: return lsol(VV,L);
4081: }
4082:
4083:
4084: def ladd(X,Y,M)
4085: {
1.58 takayama 4086: if(Y==0){
4087: Y=X[1];X=X[0];
4088: }
1.22 takayama 4089: if(type(Y)==4) Y=ltov(Y);
1.6 takayama 4090: if(type(X)==4) X=ltov(X);
4091: return vtol(X+M*Y);
4092: }
4093:
4094: def mrot(X)
4095: {
1.22 takayama 4096: if(type(X)==4){
4097: if(getopt(deg)==1)
4098: X=[deval(@pi*X[0]/180),deval(@pi*X[1]/180),deval(@pi*X[2]/180)];
4099: if(getopt(conj)==1)
4100: return mrot([-X[2],-X[1],0])*mrot([X[0],X[1],X[2]]);
4101: if(X[1]==0){
4102: X=[X[0]+X[2],0,0];
4103: if(X[0]==0) return diagm(3,[1]);
4104: }
4105: if(X[0]!=0){
4106: M=mat([dcos(X[0]),-dsin(X[0]),0],[dsin(X[0]),dcos(X[0]),0],[0,0,1]);
4107: if(X[1]==0) return M;
4108: }
4109: N=mat([dcos(X[1]),0,-dsin(X[1])],[0,1,0],[dsin(X[1]),0,dcos(X[1])]);
4110: if(X[0]!=0) N=M*N;
4111: if(X[2]==0) return N;
4112: return N*mrot([X[2],0,0]);
4113: }
1.6 takayama 4114: if(getopt(deg)==1) X=@pi*X/180;
4115: X=deval(X);
1.22 takayama 4116: return mat([dcos(X),-dsin(X)],[dsin(X),dcos(X)]);
1.6 takayama 4117: }
4118:
4119: def m2v(M)
4120: {
4121: S = size(M);
4122: V = newvect(S[0]*S[1]);
4123: for(I = C = 0; I < S[0]; I++){
4124: MI = M[I];
4125: for(J = 0; J < S[1]; J++)
4126: V[C++] = MI[J];
4127: }
4128: return V;
4129: }
4130:
4131: def lv2m(L)
4132: {
4133: if(type(L)==5) L=vtol(L);
4134: II=length(L);
4135: for(J=1,T=L; T!=[]; T=cdr(T))
4136: if(length(car(T))>JJ) JJ=length(car(T));
4137: M = newmat(II,JJ);
4138: N = getopt(null);
4139: if(type(N)<0) N=0;
4140: for(I=0; I<II; I++){
4141: V=car(L); L=cdr(L);
4142: for(J=length(V);--J>=0;)
4143: M[I][J] = V[J];
4144: if(N!=0){
4145: for(J=length(V); J<JJ; J++)
4146: M[I][J]=N;
4147: }
4148: }
4149: return M;
4150: }
4151:
4152: def m2lv(M)
4153: {
4154: I=size(M)[0];
4155: for(N=[],I=size(M)[0];I-->0;)
4156: N=cons(M[I],N);
4157: return N;
4158: }
4159:
4160: def s2m(S)
4161: {
4162: if(type(S)==6) return S;
4163: if(type(S)==7){
4164: if(str_chr(S,0,"[")!=0) S=s2sp(S);
4165: else if(str_chr(S,0,",")>=0) return eval_str(S);
4166: else{
4167: for(L=LL=[],I=0; ; ){
4168: II=str_chr(S,I+2,"]");
4169: if(II<0) return 0;
4170: J=str_chr(S,I+2," ");
4171: while(str_chr(S,J+1," ")==J+1) J++;
4172: if(J>II-2 || J<0) J=II;
4173: V=eval_str(sub_str(S,I+1,J-1));
4174: L=cons(V,L);
4175: I=J;
4176: if(J==II){
4177: LL=cons(ltov(reverse(L)),LL);
4178: L=[];
4179: if((I=str_chr(S,II+1,"["))<0)
4180: return lv2m(reverse(LL));
4181: }
4182: }
4183: }
4184: }
4185: if(type(S)==5) S=vtol(S);
4186: if(type(S[0])==5) return lv2m(S);
4187: I=length(S);
4188: for(J=1,T=S; T!=[]; T=cdr(T))
4189: if(length(car(T))>J) J=length(car(T));
4190: return newmat(I,J,S);
4191: }
4192:
4193: def c2m(L,V)
4194: {
4195: if(type(Pow=getopt(pow))!=1){
4196: if(isvar(V)==1){
4197: for(Pow=0,LT=L;LT!=[];LT=cdr(LT)){
4198: if(mydeg(car(LT),V)>JJ) Pow=mydeg(car(LT),V);
4199: }
4200: JJ=Pow+1;
4201: }else{
4202: Pow=-1;
4203: JJ=length(V);
4204: }
4205: }else JJ=Pow+1;
4206: M=newmat(length(L),JJ);
4207: for(I=0;L!=[];L=cdr(L),I++){
4208: for(J=0;J<JJ;J++){
4209: LT=car(L);
4210: M[I][J]=(Pow>=0)?mycoef(LT,J,V):mycoef(LT,1,V[J]);
4211: }
4212: }
4213: return M;
4214: }
4215:
4216: #if 0
4217: def m2diag(M,N)
4218: {
4219: S = size(M);
4220: MM = mtoupper(M,N);
4221: for(I = S[0]-1; I >= 0; I--){
4222: for(J = 0; I < S[1]-N; I++){
4223: if(MM[I][J] != 0){
4224: P = MM[I][J];
4225: for(K = 0; K < I; K++){
4226: Q = -rmul(MM[K][J],1/P);
4227: MM[K][J] = 0;
4228: if(Q != 0){
4229: for(L = J+1; L < S[1]; L++){
4230: if(MM[I][L] != 0)
4231: MM[K][L] = radd(MM[K][L], rmul(MM[I][L],Q));
4232: }
4233: }
4234: }
4235: }
4236: }
4237: }
4238: return MM;
4239: }
4240: #endif
4241:
4242: def myinv(M)
4243: {
4244: S = size(M);
4245: if((T=S[0]) != S[1])
4246: return 0;
4247: MM = mtoupper(M,-T|opt=2);
4248: if(MM[T-1][T-1] != 1) return 0;
4249: return mperm(MM,0,[T,[T]]);
4250: }
4251:
4252: def madj(G,M)
4253: {
4254: H=myinv(G);
4255: if(type(M)==6)
4256: return rmul(rmul(G,M),H);
4257: if(type(M)==4||type(M)==5){
4258: L=length(M);
4259: N=newvect(L);
4260: for(I=0;I<L;I++){
4261: N[I]=rmul(rmul(G,M[I]),H);
4262: }
4263: if(type(N)==4) N=vtol(N);
4264: return N;
4265: }
4266: return -1;
4267: }
4268:
4269: def mpower(M,N)
4270: {
4271: if(type(M)<=3) return (red(M))^N;
4272: S = size(M);
4273: if(S[0] != S[1])
4274: return 0;
4275: if(N == 0) return mgen(S[0],0,[1],0);
4276: if(N < 0)
4277: return(mpower(myinv(M), -N));
4278: R = dupmat(M);
4279: V=1;
4280: for(V=1;;){
4281: if(iand(N,1)){
4282: V=map(red,R*V);
4283: N--;
4284: }
4285: if((N/=2)==0) break;
4286: R=map(red,R*R);
4287: }
4288: return V;
4289: }
4290:
4291: def texlen(S)
4292: {
4293: if(type(S)!=7) return 0;
4294: LF=I=J=0;
4295: LM=str_len(S);
4296: while((I=str_str(S,"\\frac{"|top=J))>=0){
4297: if(I>J) LF+=texlen(str_cut(S,J,I-1));
4298: I+=6;
4299: for(F=L=0,J=I;F<2 && J<LM-1;F++){
4300: for(C=1;C>0 && J<LM;){
4301: if((K0=str_char(S,J,"}"))<0) K0=LM;
4302: if((K1=str_char(S,J,"{"))<0) K1=LM;
4303: if(K0<0 && K1<0){
4304: J = str_len(S)-1;
4305: break;
4306: }
4307: if(K0<K1){
4308: J=K0+1; C--;
4309: }else{
4310: J=K1+1; C++;
4311: }
4312: }
4313: T=str_cut(S,I,J-1);
4314: if(F==0){
4315: I=J=K1+1;C=1;
4316: }else J=K0+1;
4317: if(type(T)==7 && (LL=texlen(T))>L) L=LL;
4318: }
4319: LF+=L;
4320: }
4321: if(J>0) S=str_cut(S,J,str_len(S)-1);
4322: if(S==0) return LF;
4323: S=ltov(strtoascii(S));
4324: L=LL=length(S);
4325: for(I=F=0; I<L; I++){
4326: if(S[I]==92) F=1;
4327: else if(F==1){
4328: if((S[I]>96 && S[I]<123)||(S[I]>64 && S[I]<91)) LL--;
4329: else F=0;
4330: }
4331: if(S[I]<=32||S[I]==123||S[I]==125||S[I]==94||S[I]==38) LL--; /* {}^& */
4332: else if(S[I]==95){
4333: LL--;
4334: if(I+2<L && S[I+2]==94) LL--; /* x_2^3 */
4335: else if(I+6<L && S[I+1]==123 && S[I+4]==125){ /* x_{11}^2 */
4336: if(S[I+5]==94 || (S[I+5]==125 && S[I+6]==94)) LL-- ; /* x_{11}}^2 */
4337: }
4338: }
4339: }
4340: return LL+LF;
4341: }
4342:
4343: def isdif(P)
4344: {
4345: if(type(P)<1 || type(P)>3) return 0;
4346: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4347: V0=rtostr(car(R));
4348: if(V0>"d" && V0<"e"){
4349: V=sub_str(V0,1,str_len(V0)-1);
4350: if(V>="a" && V<"{") Var=cons([strtov(V),strtov(V0)],Var);
4351: }
4352: }
4353: if(Var==[]) return 0;
4354: for(V=Var; V!=[]; V=cdr(V))
4355: if(ptype(P,car(V)[1])==3) return 0;
4356: return Var;
4357: }
4358:
4359: def texsp(P)
4360: {
4361: Q=strtoascii(P);
4362: if((J=str_char(Q,0,92))<0 || (C=Q[L=str_len(P)-1])==32||C==41||C==125)
4363: return P;
4364: for(;;){
4365: if((I=str_char(Q,J+1,92))<0) break;
4366: J=I;
4367: };
4368: for(I=J+1;I<L&&isalpha(Q[I]);I++);
4369: return(I==L)?P+" ":P;
4370: }
4371:
4372: def fctrtos(P)
4373: {
4374: /* extern TeXLim; */
4375: if(!chkfun("write_to_tb", "names.rr"))
4376: return 0;
4377:
4378: TeX = getopt(TeX);
4379: if(TeX != 1 && TeX != 2 && TeX != 3)
4380: TeX = 0;
1.70 takayama 4381: if((Dvi=getopt(dviout)==1) && TeX<2) TeX=3;
1.6 takayama 4382: if(TeX>0){
4383: Lim=getopt(lim);
4384: if(Lim!=0 && TeX>1 && (type(Lim)!=1||Lim<30)) Lim=TeXLim;
4385: else if(type(Lim)!=1) Lim=0;
4386: CR=(TeX==2)?"\\\\\n":"\\\\\n&";
1.70 takayama 4387: CR2="\\allowdisplaybreaks"+CR;
4388: if(TeX==1 || Lim==0) CR=CR2="";
4389: else if((Pages=getopt(pages))==1) CR2=CR;
1.6 takayama 4390: if(!chkfun("print_tex_form", "names.rr"))
4391: return 0;
4392: Small=getopt(small);
4393: }
4394: Dif=getopt(dif);
4395: Var=getopt(var);
4396: if(Lim>0 && type(Var)<2 && TeX!=1) Var=[strtov("0"),""];
4397: Dif=0;
4398: if(Var=="dif"){
4399: Dif=DV=1;
4400: }else if (Var=="dif0") Dif=1;
4401: else if(Var=="dif1") Dif=2;
4402: else if(Var=="dif2") Dif=3;
4403: if(Dif>0){
4404: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4405: V=rtostr(car(R));
4406: if(V>"d" && V<"e"){
4407: V=sub_str(V,1,str_len(V)-1);
4408: if(V>="a" && V<"{"){
4409: if(TeX>0){
4410: V=my_tex_form(strtov(V));
4411: if(Dif>=1){
4412: if(Dif==1){
4413: if(str_len(V)==1) V="\\partial_"+V;
4414: else V="\\partial_{"+V+"}";
4415: }
4416: Var=cons([car(R),V],Var);
4417: }
4418: else Var=cons([car(R)],Var);
4419: }else Var=cons([car(R)],Var);
4420: }
4421: }
4422: }
4423: if(TeX>0){
4424: if(length(Var)==1){
4425: if(DV==1 && str_len(Var[0][1])==10) Var=[[Var[0][0],"\\partial"]];
4426: }else if(DV==1){
4427: for(V=Var;V!=[];V=cdr(V)){
4428: VV=rtostr(car(V)[0]);
4429: if(VV<"dx0" || VV>= "dx:" || str_len(VV)>4) break;
4430: }
4431: if(V==[]){
4432: for(VT=[],V=Var;V!=[];V=cdr(V)){
4433: VV=str_cut(rtostr(car(V)[0]),2,3);
4434: if(str_len(VV)==1) VT=cons([car(V)[0],"\\partial_"+VV],VT);
4435: else VT=cons([car(V)[0],"\\partial_{"+VV+"}"],VT);
4436: }
4437: Var=reverse(VT);
4438: }
4439: }else
4440: if(Dif==2 && length(Var)>1) Dif=3;
4441: }
4442: if(Dif>0) Dif--;
4443: }
4444: if(type(Var)>1 && Var!=[]){ /* as a polynomial of Var */
4445: Add=getopt(add);
4446: if(type(Add)>0){
4447: if(type(Add)!=7){
4448: Add=my_tex_form(Add);
4449: if(str_char(Add,0,"-")>=0 || str_char(Add,0,"+")>=0) Add="("+Add+")";
4450: }
4451: if(str_char(Add,0,"(")!=0) Add = " "+Add;
4452: }else Add=0;
4453: if(type(Var)!=4) Var=[Var];
4454: if(length(Var)==2 && type(Var[1]) == 7)
4455: Var = [Var];
4456: for(VV=VD=[]; Var!=[];Var=cdr(Var)){
4457: VT=(type(car(Var))==4)?car(Var):[car(Var)];
4458: VT0=var(car(VT));
4459: VV=cons(VT0,VV);
4460: if(length(VT)==1){
4461: VD=cons((TeX>=1)?my_tex_form(VT0):rtostr(VT0),VD);
4462: }else VD=cons(VT[1],VD);
4463: }
4464: VV=reverse(VV);VD=reverse(VD);
4465: Rev=(getopt(rev)==1)?1:0;
1.70 takayama 4466: Rdic=0;
4467: if((Dic=getopt(dic))==2){
4468: Dic=Rdic=1;
4469: }else if(Dic!=1) Dic=0;
1.6 takayama 4470: TT=terms(P,VV|rev=Rev,dic=Dic);
4471: if(TeX==0){
4472: Pre="("; Post=")";
4473: }else{
4474: Pre="{"; Post="}";
4475: }
4476: Out = string_to_tb("");
1.70 takayama 4477: for(L=C=CC=0,Tm=TT;Tm!=[];C++,Tm=cdr(Tm)){
1.6 takayama 4478: for(I=0,PC=P,T=cdr(car(Tm)),PW="";T!=[];T=cdr(T),I++){
4479: PC=mycoef(PC,D=car(T),VV[I]);
4480: if(PC==0) continue;
4481: PT="";
4482: if(D!=0 && VD[I]!=""){
4483: if(TeX==0 && PW!="") PW+="*";
4484: if(D>1){
4485: if(D>9) PT="^"+Pre+rtostr(D)+Post;
4486: else PT="^"+rtostr(D);
4487: }
4488: if(Dif>0) PW+=(Dif==1)?"d":"\\partial ";
1.70 takayama 4489: if(Rdic) PW=VD[I]+PT+PW;
4490: else PW+=VD[I]+PT;
1.6 takayama 4491: }
4492: }
4493: D=car(Tm)[0];
4494: if(Dif>0 && D>0){
4495: Op=(Dif==1)?"\\frac{d":"\\frac{\\partial";
4496: if(D>1) Op+="^"+((D>9)?(Pre+rtostr(D)+Post):rtostr(D));
4497: PW=Op+Add+"}{"+PW+"}";
4498: }else if(Add!=0) PW=PW+Add;
1.69 takayama 4499: CD=0;
1.6 takayama 4500: if(TeX>=1){
4501: if(type(PC)==1 && ntype(PC)==0 && PC<0)
4502: OC="-"+my_tex_form(-PC);
4503: else OC=fctrtos(PC|TeX=1,br=1);
1.69 takayama 4504: if(isint(PC)&&(PC<-1||PC>1)) CD=1;
1.6 takayama 4505: }else OC=fctrtos(PC|br=1);
4506: if(PW!=""){
4507: if(OC == "1") OC = "";
4508: else if(OC == "-1") OC = "-";
4509: }
4510: if(TeX==0 && D!=0 && OC!="" && OC!="-") PW= "*"+PW;
4511: if((TOC=type(OC)) == 4){ /* rational coef. */
4512: if(Lim>0 && (texlen(OC[0])>Lim || texlen(OC[0])>Lim)){
4513: OC = (Small==1)?"("+OC[0]+")/("+OC[1]+")"
4514: :"\\Bigl("+OC[0]+"\\Bigr)\\Bigm/\\Bigl("+OC[1]+"\\Bigr)";
4515: TOC = 7;
4516: }else{
4517: if(str_char(OC[0],0,"-")==0){
4518: OC = fctrtos(-PC|TeX=1,br=1);
4519: OC = "-\\frac{"+OC[0]+"}{"+OC[1]+"}";
4520: }
4521: else
4522: OC = "\\frac{"+OC[0]+"}{"+OC[1]+"}";
4523: }
4524: }
4525: if(Lim>0){
1.70 takayama 4526: CC++;
1.6 takayama 4527: LL=texlen(OC)+texlen(PW);
4528: if(LL+L>=Lim){
4529: if(L>0) str_tb(CR,Out);
4530: if(LL>Lim){
1.70 takayama 4531: if(TOC==7) OC=texlim(OC,Lim|cut=[CR,CR2]);
1.73 takayama 4532: if(length(Tm)!=1) PW+=CR;
4533: L=0;
1.6 takayama 4534: }else L=LL;
4535: }else L+=LL;
1.70 takayama 4536: }else if(length(Tm)!=1){
4537: CC++;
4538: PW += CR; /* not final term */
4539: }
4540: if(CC>TeXPages) CR=CR2;
1.69 takayama 4541: if(TeX){
4542: OC=texsp(OC);
4543: if(CD){ /* 2*3^x */
4544: CD=strtoascii(str_cut(PW,0,1));
4545: if(length(CD)==2&&car(CD)==123&&isnum(CD[1])) OC+="\\cdots";
4546: }
4547: }
1.6 takayama 4548: if(str_chr(OC,0,"-") == 0 || C==0) str_tb([OC,PW], Out);
4549: else{
4550: str_tb(["+",OC,PW],Out);
4551: if(LL<=Lim) L++;
4552: }
4553: }
4554: S=str_tb(0,Out);
4555: if(S=="") S="0";
4556: }else{ /* Var is not specified */
4557: if((TP=type(P)) == 3){ /* rational function */
4558: P = red(P); Nm=nm(P); Dn=dn(P);
4559: Q=dn(ptozp(Nm|factor=1)[1]);
4560: if(Q>1){
4561: Nm*=Q;Dn*=Q;
4562: }
4563: if(TeX>0){
4564: return (TeX==2)?
4565: "\\frac\{"+fctrtos(Nm|TeX=1)+"\}\{"+fctrtos(Dn|TeX=1)+"\}"
4566: :[fctrtos(Nm|TeX=1),fctrtos(Dn|TeX=1)];
4567: }
4568: else{
4569: S=fctrtos(Nm);
4570: if(nmono(Nm)>1) S="("+S+")";
4571: return S+"/("+fctrtos(Dn)+")";
4572: }
4573: }
4574: if(imag(P)==0) P = fctr(P); /* usual polynomial */
4575: else P=[[P,1]];
4576: S = str_tb(0,0);
1.69 takayama 4577: for(J = N = CD = 0; J < length(P); J++){
4578: if(type(V=P[J][0]) <= 1){
4579: if(V == -1){
1.6 takayama 4580: write_to_tb("-",S);
4581: if(length(P) == 1)
4582: str_tb("1", S);
1.69 takayama 4583: }else if(V != 1){
4584: str_tb((TeX>=1)?my_tex_form(V):rtostr(V), S);
1.6 takayama 4585: N++;
4586: }else if(length(P) == 1)
4587: str_tb("1", S);
4588: else if(getopt(br)!=1 && length(P) == 2 && P[1][1] == 1){
4589: str_tb((TeX>=1)?my_tex_form(P[1][0]):rtostr(P[1][0]), S);
4590: J++;
4591: }
1.69 takayama 4592: if(J==0&&isint(V=P[J][0])&&(V<-1||V>1)) CD=1;
1.6 takayama 4593: continue;
4594: }
4595: if(N > 0 && TeX != 1 && TeX != 2 && TeX != 3)
4596: write_to_tb("*", S);
4597: SS=(TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]);
4598: N++;
4599: if(P[J][1] != 1){ /* (log(x))^2 */
4600: if(nmono(P[J][0])>1||
4601: (!isvar(P[J][0])||vtype(P[J][0]))&&str_len(SS)>1) SS="("+SS+")";
4602: write_to_tb(SS,S);
1.70 takayama 4603: str_tb(["^", (TeX>=1)?rtotex(P[J][1]):monotos(P[J][1])],S);
1.6 takayama 4604: }else{
1.70 takayama 4605: if(nmono(P[J][0])>1&&length(P)>1) SS="("+SS+")";
1.69 takayama 4606: else if(CD&&J==1){ /* 2*3^x */
4607: CD=strtoascii(str_cut(SS,0,1));
4608: if(length(CD)==2&&car(CD)==123&&isnum(CD[1])) SS="\\cdot"+SS;
4609: }
1.6 takayama 4610: write_to_tb(SS,S);
4611: }
4612: }
4613: S = str_tb(0,S);
1.70 takayama 4614: if((Lim>0 || TP!=2) && CR!="") S=texlim(S,Lim|cut=[CR,CR2]);
1.6 takayama 4615: }
4616: if(TeX>0){
4617: if(Small==1) S=str_subst(S,"\\frac{","\\tfrac{");
4618: if(Dvi==1){
1.70 takayama 4619: dviout(strip(S,"(",")")|eq=(Pages==1||Pages==2)?6:0); S=1;
1.6 takayama 4620: }
4621: }
4622: return S;
4623: }
4624:
4625: def strip(S,S0,S1)
4626: {
4627: SS=strtoascii(S);
4628: if(length(SS)>1){
4629: if(SS[0]==40&&SS[length(SS)-1]==41&&str_pair(SS,1,S0,S1)==length(SS)-1)
4630: S=str_cut(SS,1,length(SS)-2);
4631: }
4632: return S;
4633: }
4634:
4635: def texlim(S,Lim)
4636: {
4637: /* extern TeXLim; */
4638: if(S==1 && Lim>10){
4639: TeXLim=Lim;
4640: mycat(["Set TeXLim =",Lim]);
4641: return 1;
4642: }
1.70 takayama 4643: if(type(Out=getopt(cut))!=7){
4644: if(type(Out)!=4) Out=Out2="\\\\\n&";
4645: else{
4646: Out2=Out[1];Out=Out[0];
4647: }
4648: }
1.6 takayama 4649: if(type(Del=getopt(del))!=7) Del=Out;
4650: if(Lim<30) Lim=TeXLim;
4651: S=ltov(strtoascii(S));
4652: for(L=[0],I=F=0;F==0; ){
4653: II=str_str(S,Del|top=I)+2;
4654: if(II<2){
4655: F++;II=/* str_len(S) */ length(S)-1;
4656: }
4657: for(J=JJ=I+1;;JJ=K+1){
4658: K=str_char(S,JJ,43); /* + */
4659: if((K1=str_char(S,JJ,45))>2 && K1<K){ /* - */
4660: if(S[K1-1]!=123 && S[K1-1]!=40) K=K1; /* {, ( */
4661: }
4662: if((K1=str_char(S,JJ,40))>0 && K1-JJ>6 && K1<K && S[K1-1]!=43 && S[K1-1]!=45){ /* ( */
4663: T=str_char(S,K1-6,"\\"); /* \Big*(, \big*( */
4664: if((T==K1-6 || T==K1-5)
4665: && (str_str(S,"big"|top=T+1,end=T+1)>0 || str_str(S,"Big"|top=T+1,end=T+1)>0))
4666: K=T;
4667: else if(K1>0 && K1<K) K=K1;
4668: }
4669: if(K<0 || K>II) break;
4670: if(K-J>Lim && texlen(str_cut(S,J,K-1))>=Lim){
4671: J=K+1; L=cons(JJ-1,L); SL=0;
4672: }
4673: }
4674: I=II;
4675: }
4676: SS=str_tb(0,0);
4677: L=cons(length(S),L);
4678: L=reverse(L);
1.70 takayama 4679: if(length(L)>TeXPages) Out=Out2;
1.6 takayama 4680: for(I=0; L!=[]; I=J,L=cdr(L)){
4681: str_tb((I==0)?"":Out,SS);
4682: J=car(L);
4683: str_tb(str_cut(S,I,J-1),SS);
4684: }
4685: return str_tb(0,SS);
4686: }
4687:
4688: def fmult(FN,M,L,N)
4689: {
4690: Opt=getopt();
4691: for(I = 0; I < length(M); I++)
4692: M = call(FN, cons(M,cons(L[I],N))|option_list=Opt);
4693: return M;
4694: }
4695:
4696: def radd(P,Q)
4697: {
4698: if(type(P) <= 3 || type(Q) <= 3){
4699: if(type(P) >= 5)
4700: return radd(Q,P);
4701: if(type(Q) >= 5){
4702: R = dupmat(Q);
4703: if(P == 0)
4704: return R;
4705: if(type(Q) == 6){
4706: S = size(Q);
4707: if(S[0] != S[1])
4708: return 0;
4709: for(I = 0; I < S[0]; I++)
4710: R[I][I] = radd(R[I][I], P);
4711: }else{
4712: for(I = length(R)-1; I >= 0; I--)
4713: R[I] = radd(R[I],P);
4714: }
4715: return R;
4716: }
4717: /* P=red(P);Q=red(Q); */
4718: if((P1=dn(P)) == (Q1=dn(Q))){
4719: if(P1==1) return P+Q;
4720: return red((nm(P)+nm(Q))/P1);
4721: }
4722: R=gcd(P1,Q1);S=tdiv(P1,R);
4723: return red((nm(P)*tdiv(Q1,R)+nm(Q)*S)/(S*Q1));
4724: }
4725: if(type(P) == 5){
4726: S = length(P);
4727: R = newvect(S);
4728: for(I = 0; I < S; I++)
4729: R[I] = radd(P[I],Q[I]);
4730: return R;
4731: }
4732: if(type(P) == 6){
4733: S = size(P);
4734: R = newmat(S[0],S[1]);
4735: for(I = 0; I < S[0]; I++){
4736: for(J = 0; J < S[1]; J++)
4737: R[I][J] = radd(P[I][J],Q[I][J]);
4738: }
4739: return R;
4740: }
4741: erno(0);
4742: }
4743:
4744: def getel(M,I)
4745: {
4746: if(type(M) >= 4 && type(M) <= 6 && type(I) <= 1)
4747: return M[I];
4748: if(type(M) == 6 && type(I) == 5)
4749: return M[I][J];
4750: return M;
4751: }
4752:
4753: def ptol(P,X)
4754: {
4755: F=(getopt(opt)==0)?0:1;
4756: if(type(P) <= 3)
4757: P = [P];
4758: if(type(X) == 4){
4759: for( ; X != []; X = cdr(X))
4760: P=ptol(P,car(X)|opt=F);
4761: return P;
4762: }
4763: P = reverse(P);
4764: for(R=[]; P != []; P = cdr(P)){
4765: Q = car(P);
4766: for(I = mydeg(Q,X); I >= 0; I--){
4767: S=mycoef(Q,I,X);
4768: if(F==1 || S!=0) R = cons(S,R);
4769: }
4770: }
4771: return R;
4772: }
4773:
4774: def rmul(P,Q)
4775: {
4776: if(type(P) <= 3 && type(Q) <= 3){
4777: P=red(P);Q=red(Q);
4778: P1=dn(P);P2=nm(P);Q1=dn(Q);Q2=nm(Q);
4779: if(P1==1 && Q1==1)
4780: return P*Q;
4781: if((R=gcd(P1,Q2)) != 1){
4782: P1=tdiv(P1,R);Q2=tdiv(Q2,R);
4783: }
4784: if((R=gcd(Q1,P2)) != 1){
4785: Q1=tdiv(Q1,R);P2=tdiv(P2,R);
4786: }
4787: return P2*Q2/(P1*Q1);
4788: }
4789: #ifdef USEMODULE
4790: return mmulbys(os_md.rmul,P,Q,[]);
4791: #else
4792: return mmulbys(rmul,P,Q,[]);
4793: #endif
4794: }
4795:
4796: def mtransbys(FN,F,LL)
4797: {
4798: Opt=getopt();
4799: if(type(F) == 4){
4800: F = ltov(F);
4801: S = length(F);
4802: R = newvect(S);
4803: for(I = 0; I < S; I++)
4804: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
4805: return vtol(R);
4806: }
4807: if(type(F) == 5){
4808: S = length(F);
4809: R = newvect(S);
4810: for(I = 0; I < S; I++)
4811: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
4812: return R;
4813: }
4814: if(type(F) == 6){
4815: S = size(F);
4816: R = newmat(S[0],S[1]);
4817: for(I = 0; I < S[0]; I++){
4818: for(J = 0; J < S[1]; J++)
4819: R[I][J] = mtransbys(FN,F[I][J],LL|option_list=Opt);
4820: }
4821: return R;
4822: }
4823: if(type(F) == 7) return F;
4824: return call(FN, cons(F,LL)|option_list=Opt);
4825: }
4826:
1.58 takayama 4827: def trcolor(S)
4828: {
4829: if(type(S)!=7) return S;
4830: return ((I=findin(S,LCOPT))>=0)?COLOPT[I]:0;
4831: }
4832:
1.61 takayama 4833: def mcolor(L,P)
4834: {
4835: if(type(L)!=4) return L;
4836: if(!P||(S=length(L))==1){
4837: if(type(V=car(L))!=7) return V;
4838: return trcolor(V);
4839: }
4840: P-=ceil(P)-1;
4841: if(P==1){
4842: if(type(V=L[S-1])!=7) return V;
4843: return trcolor(V);
4844: }
4845: for(S=P*(S-1);S>1;S--,L=cdr(L));
4846: if(getopt(disc)==1) S=0;
4847: if(type(L0=L[0])==7) L0=trcolor(L0);
4848: if(type(L1=L[1])==7) L1=trcolor(L1);
4849: T=rint(iand(L0,0xff)*(1-S)+iand(L1,0xff)*S);
4850: TT=iand(L0,0xff00)*(1-S)+iand(L1,0xff00)*S;
4851: T+=rint(TT/0x100)*0x100;
4852: TT=iand(L0,0xff0000)*(1-S)+iand(L1,0xff0000)*S;
4853: return T+rint(TT/0x10000)*0x10000;
4854: }
4855:
1.6 takayama 4856: def drawopt(S,T)
4857: {
4858: if(type(S)!=7) return -1;
4859: if(T==0||T==1){
4860: for(I=0,R=LCOPT;I<7;I++,R=cdr(R))
4861: if(str_str(S,car(R))>=0) return(T==0)?COLOPT[I]:car(R);
4862: return -1;
4863: }
4864: if(T==2){
4865: V0=V1=0;
4866: for(I=0,R=LPOPT;R!=[];I++,R=cdr(R)){
4867: if(str_str(S,car(R))>=0){
4868: if(I==0) V1++;
4869: else if(I==1) V1--;
4870: else if(I==2) V0--;
4871: else V0++;
4872: }
4873: }
4874: if(V0==0&&V1==0) return -1;
4875: return [V0,V1];
4876: }
4877: if(T==3){
4878: V=0;
4879: for(I=1,R=LFOPT;R!=[];R=cdr(R),I*=2){
4880: if(str_str(S,car(R))>=0) V+=I;
4881: }
4882: return (V==0)?-1:V;
4883: }
4884: return -1;
4885: }
4886:
1.58 takayama 4887: def openGlib(W)
4888: {
4889: extern Glib_canvas_x;
4890: extern Glib_canvas_y;
4891: extern Glib_math_coordinate;
4892:
4893: if(W==0){
4894: glib_clear();
4895: return;
4896: }
4897: if(type(W)==4&&length(W)==2){
4898: Glib_canvas_x=W[0];
1.67 takayama 4899: Glib_canvas_y=W[1];
1.58 takayama 4900: }
4901: Glib_math_coordinate=1;
4902: if(getopt(null)!=1) return glib_open();
4903: }
4904:
1.6 takayama 4905: def execdraw(L,P)
4906: {
4907: if((Proc=getopt(proc))!=1) Proc=0;
4908: if(type(P)<2) P=[P];
4909: if(L!=[]&&type(L[0])!=4) L=[L];
4910: /* special command */
4911: if(P[0]<0){
4912: if(length(P)==1&&(P[0]==-1||P[0]==-2||P[0]==-3)){ /* Bounding Box */
4913: W=WS=N=LS=0;
4914: for(LL=L;LL!=[];LL=cdr(LL)){
4915: T=car(LL);
4916: if(P[0]!=-3 && T[0]==0){
4917: if(length(T)>3) S=" by "+rtostr(T[3])+" cm";
4918: else S="";
4919: if(P[0]==-1){
4920: mycat(["Windows : ",T[1][0],"< x <",T[1][1],", ",
4921: T[2][0],"< y <",T[2][1],S]);
4922: if(length(T)>4 && type(T[4])==4) mycat(["ext :",T[4]]);
4923: if(length(T)>5) mycat(["shift :",T[5]]);
4924: }
4925: return cdr(T);
4926: }
4927: if(type(T[0])==1){
4928: if(T[0]==1){
4929: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
4930: D=car(TT);
4931: if(type(D[0][0])==4){
4932: for(DT=D;DT!=[];DT=cdr(DT)){
4933: if(N++==0) W=ptbbox(car(DT));
4934: else W=ptbbox(car(DT)|box=W);
4935: }
4936: }else{
4937: if(N++==0) W=ptbbox(D);
4938: else W=ptbbox(D|box=W);
4939: }
4940: }
4941: }else if(T[0]==2){
4942: V=T[2];
4943: if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
4944: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
4945: Sc=car(Sc)[1];
4946: if(type(Sc)==1) V=[Sc*V[0],Sc*V[1]];
4947: else V=[Sc[0]*V[0],Sc[1]*V[1]];
4948: }
4949: if(LS==0) WS=ptbbox([V]);
4950: else WS=ptbbox([V]|box=WS);
4951: if(length(T)>4) S=T[4];
4952: else if(type(S=T[3])==4){
4953: S=S[0];
4954: if(type(S)==4) S=S[length(S)-1];
4955: S=rtostr(S);
4956: }
4957: if(str_len(S)>LS) LS=str_len(S);
4958: }else if(T[0]==3||T[0]==4){
4959: if(N++==0) W=ptbbox(cdr(cdr(T)));
4960: else W=ptbbox(cdr(cdr(T))|box=W);
4961: }
4962: }
4963: }
4964: if(W!=0&&WS!=0) W=ptbbox([W,WS]|box=1);
4965: return (P[0]==-3)?[W,LS,WS]:W;
4966: }else if(length(P)>1&&P[0]==-1){ /* set Bounding Box */
4967: P=cons(0,cdr(P));
4968: Ex=Sft=[0,0];
4969: if(type(X=getopt(ext))==4) Ex=X;
4970: if(type(X=getopt(shift))==4) Sft=X;
4971: if(Ex!=Sft||Ex!=[0,0]){
4972: if(Sft==[0,0]) Sft=[Ex];
4973: else Sft=[Ex,Sft];
4974: if(length(P)==3) Sft=cons(1,Sft);
4975: if(length(P)==3||length(P)==4) P=append(P,Sft);
4976: }
4977: return cons(P,delopt(L,0));
4978: }
4979: if(P[0]==-4){
4980: for(N=0,LT=L;LT!=[];LT=cdr(LT)){ /* count coord. */
4981: T=car(LT);
4982: if(T[0]==1){
4983: for(T=cdr(cdr(T));T!=[];T=cdr(T)){
4984: if(type((S=car(T))[0][0])==4) N+=length(S);
4985: else for(;S!=[];S=cdr(S)) if(type(car(S))==4) N++;
4986: }
4987: }else if(T[0]==2) N++;
4988: else if(T[0]==3||T[0]==4) N+=2;
4989: }
4990: return N;
4991: }
4992: if(P[0]==-5){ /* functions */
4993: for(N=0,R=[],LT=L;LT!=[];LT=cdr(LT)){
4994: T=car(LT);
4995: if(T[0]==0) N=ior(N,1);
4996: else if(type(T[0])==1){
4997: if(T[0]>0) N=ior(N,2^T[0]);
4998: }
4999: else if(Type(T[0])==2){
5000: if(findin(T[0],R)<0) R=cons(T[0],R);
5001: }
5002: }
5003: for(I=5;I>=0;I--) if(iand(N,2^I)) R=cons(I,R);
5004: return R;
5005: }
5006: return 0;
5007: }
5008:
5009: if(length(P)>1){
5010: if(type(P[1])==6||(type(P[1])<2&&P[1]>0)) M=P[1];
5011: else if(type(P[1])==4&&length(P[1])==2) M=diagm(2,P[1]);
5012: }
5013: if(length(P)>2&&type(P[2])==4){
5014: Org=[["shift",P[2]]];
5015: if(M==0) M=1;
5016: }else Org=[];
5017: if(P[0]==0||(type(P[0])==4&&P[0][0]==0)){ /* Risa/Asir */
5018: PP=car(P);PPP=0;
5019: if(type(PP)!=4) PP=[PP];
5020: if(length(PP)<3){
5021: if(length(PP)==1 || type(PP[1])==4){
5022: if(ID_PLOT<0) ID_PLOT=ox_launch_nox(0,"ox_plot");
5023: Id=ID_PLOT;
5024: if(length(PP)==1&&type(Canvas)==4&&length(Canvas)==2)
5025: PP=cons(PP[0],[Canvas]);
5026: if(length(PP)>1){
5027: PPP=PP[1][0];
5028: PPQ=(length(PP[1])==2)?PP[1][1]:PPP;
5029: open_canvas(Id,[PPP,PPQ]);
5030: }else open_canvas(Id);
5031: Ind=ox_pop_cmo(Id);
5032: }else{
5033: Ind=PP[1];
5034: if(getopt(cl)==1) clear_canvas(Id,Ind);
5035: }
5036: }else{
5037: Id=PP[1];Ind=PP[2];
5038: if(length(PP)>3 && type(PP[3])==1) PPP=PP[3];
5039: if(length(PP)>4 && type(PP[4])==1) PPQ=PP[4];
5040: if(getopt(cl)==1) clear_canvas(Id,Ind);
5041: }
5042: if(L==[]) return (PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
5043: Ex0=Ex0;Sft=[0,0];
5044: if(length(P)>1&&P[1]==0&&length(P)<4){
5045: R=execdraw(L,-3);
5046: Ex0=Ex1=Ex2=10;
5047: if((U=R[1])>0){ /* string */
5048: if(U>20) U=16; /* adj 16,8,2,7,15 */
5049: if(R[0][0][0]>R[2][0][0]-(R[0][0][1]-R[0][0][0])/256) Ex0+=8*U; /* adj 256 */
5050: else Ex0+=2*U;
5051: if(R[0][0][1]<R[2][0][1]+(R[0][0][1]-R[0][0][0])/256) Ex1+=7*U;
5052: else Ex1+=2*U;
5053: if(R[0][1][1]<R[2][1][1]+(R[0][1][1]-R[0][1][0])/256) Ex2+=15;
5054: }
5055: R=[R[0][0],R[0][1],0,[Ex0,Ex1],[0,-Ex2]];
5056: if(length(P)>2 && P[2]==1)
5057: mycat0(["Box:",[R[0],R[1]], ", ext=",R[3],", shift=",R[4]],1);
5058: }else R=execdraw((length(P)>3)?P[3]:L,-2); /* Windows */
5059: XW=R[0];YW=R[1];
5060: if(length(R)>3){
5061: if(R[3]!=0 && R[3]!=[0,0]) Ex=R[3];
5062: if(length(R)>4) Sft=R[4];
5063: }
5064: if(type(X=getopt(ext))==4)
5065: Ex=(Ex0)?[X[0]+Ex[0],X[1]+Ex[1]]:X;
5066: if(type(M)<2){
5067: if(length(P)>1&&type(P[1])==1) M=P[1];
5068: else if((length(P)==1||P[1]==0||P[1]==1)&& PPP>0) M=PPP;
5069: if(M<2) M=400;
5070: if(Ex!=0 && type(Ex)==4){
5071: M-=Ex[0]+Ex[1];
5072: }
5073: M=(M/(XW[1]-XW[0]))*diagm(2,[1,-1]);
5074: }
5075: if(type(X=getopt(shift))==4) Sft=(Ex0)?[Sft[0]+X[0],Sft[1]+X[1]]:X;
5076: if(type(Sft)==4) Sft=[Sft[0],-Sft[1]];
5077: if(Ex!=0) Sft=[Sft[0]+Ex[0],Sft[1]];
5078: Org=[["shift",ptaffine(M,[-XW[0],-YW[1]]|shift=Sft)]];
5079: for(CT=0;CT<2;CT++){
5080: for(LT=L;LT!=[];LT=cdr(LT)){
5081: T=car(LT);
5082: if(!CT && T[0]!=2) continue;
5083: if(CT && T[0]==2) continue;
5084: if(T[0]==1){
5085: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
5086: D=car(TT);
5087: if(type(D[0][0])==4){
5088: for(DT=D;DT!=[];DT=cdr(DT)){
5089: V=car(DT);
5090: if(M) V=ptaffine(M,V|option_list=Org);
5091: draw_bezier(Id,Ind,V|option_list=T[1]);
5092: }
5093: }else{
5094: if(M) D=ptaffine(M,D|option_list=Org);
5095: draw_bezier(Id,Ind,D|option_list=T[1]);
5096: }
5097: }
5098: }else if(T[0]==2){ /* put */
5099: if(length(T)<4) continue;
5100: V=T[2];
5101: if(type(VLB)==4&&V[0]=="_") V=VLB;
5102: else if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
5103: if(length(T)>3&&type(T[3])==4&&length(T[3])>1&&T[3][1]==1) VLB=V;
5104: F++;MM=M;
5105: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
5106: if(!MM) MM=1;
5107: Sc=car(Sc)[1];
5108: if(type(Sc)==1) MM=MM*Sc;
5109: else if(type(Sc)==6) MM=MM*diagm(2,Sc);
5110: }
5111: if(MM) V=ptaffine(MM,V|option_list=Org);
5112: if(type(S=S0=T[3])==4) S=S0[0];
5113: if(length(T)>4) S=T[4]; /* subst. string */
5114: if(type(S0)==4&&type(S0[0])==4){
5115: if((Col=drawopt(S0[0][0],0))<0) Col=0; /* attrib. */
5116: if(type(S)!=7) S=rtostr(S0[0][1]);
5117: S=str_subst(S,[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
5118: if(type(Pos=drawopt(S0[0][0],2))==4)
5119: V=[V[0]+4*str_len(S)*Pos[0],V[1]-10*Pos[1]]; /* adjustable */
5120: }else S=str_subst(rtostr(S),[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
5121: V=[V[0]-str_len(S)*4,V[1]-8]; /* adjustable */
5122: draw_string(Id,Ind,V,S,Col);
5123: }else if(T[0]==3){ /* arrow */
5124: F++;
5125: T1=T[2];T2=T[3];
5126: if(M){
5127: T1=ptaffine(M,T1|option_list=Org);
5128: T2=ptaffine(M,T2|option_list=Org);
5129: }
5130: draw_bezier(Id,Ind,[T1,T2]|option_list=T[1]);
5131: }else if(T[0]==4){ /* line */
5132: F++;
5133: T1=T[2];T2=T[3];
5134: if(M){
5135: T1=ptaffine(M,T1|option_list=Org);
5136: T2=ptaffine(M,T2|option_list=Org);
5137: }
5138: V=delopt(T1=T[1],"opt"|inv=1);
5139: if(V!=[]&&str_str(V[1],".")>=0)
5140: T1=cons(["opt",cons("dotted,",V[1])],delopt(T1,"opt"));
5141: draw_bezier(Id,Ind,[T1,T2]|option_list=T1);
5142: }else if(T[0]==5){ /* TeX */
5143: mycat(rtostr(T[2]));
5144: if(F){
5145: S=str_tb(0,Out);
5146: Out=str_tb(0,0);
5147: F=0;
5148: if(S!=""){
5149: if(P[0]==2) dviout(xyproc(S)|keep=1);
5150: else LOut=cons(xyproc(S),LOut);
5151: }
5152: if(P[0]==2) dviout(T[2]|option_list=T[1]);
5153: else{
5154: LOut=cons(T[2],Out);
5155: }
5156: }
1.57 takayama 5157: }else if(T[0]==6){ /* plot */
5158: F++;
5159: if((T1=findin(T[1],LCOPT))>-1) T1=COLOPT(T1);
5160: else if(type(T1)!=1 && T1!=0) T1=0xffffff;
5161: for(T2=ptaffine(M,T[2]|option_list=Org);T2!=[];T2=cdr(T2))
5162: draw_obj(Id,Ind,[rint(car(T2)[0]),rint(car(T2)[1])],T1);
1.6 takayama 5163: }else if(Proc==1&&type(T[0])==2){
5164: if(length(T)<3) call(T[0],T[1]);
5165: else call(T[0],T[1]|option_list=T[2]);
5166: }
5167: }
5168: }
5169: S=(PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
5170: if(Ex==0&&Sft!=[0,0]) Ex=[0,0];
5171: return (Ex!=0&&length(P)>2&&P[2]==-1)?
5172: [S,0,0,[0,R[0],R[1],0,Ex,[Sft[0]-Ex[0],-Sft[1]]]]:S;
5173: }
5174: if(P[0]==1||P[0]==2){ /* TeX */
5175: Out=str_tb(0,0);LOut=[];F=0;
5176: if(getopt(cl)==1) dviout0(0);
5177: for(;L!=[];L=cdr(L)){
5178: T=car(L);Opt=T[1];
5179: if(type(T[0])>=2) continue;
5180: if(T[0]==0){
5181: XW=T[1];YW=T[2];
5182: if(length(P)>1&&type(P[1])==1&&P[1]<0)
5183: M=-P[1]/(XW[0]-XW[1]);
5184: }else if(T[0]==1){
5185: F++;
5186: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
5187: D=car(TT);
5188: if(type(D[0][0])==4){
5189: for(DT=D;DT!=[];DT=cdr(DT)){
5190: V=car(DT);
5191: if(M) V=ptaffine(M,V|option_list=Org);
5192: str_tb(xybezier(V|option_list=Opt),Out);
5193: }
5194: }else{
5195: if(M) D=ptaffine(M,D|option_list=Org);
5196: str_tb(xybezier(D|option_list=Opt),Out);
5197: }
5198: }
5199: }else if(T[0]==2){
5200: F++;V=T[2];
5201: Opt=delopt(Opt,"scale"|inv=1);
5202: MM=M;
5203: if(Opt!=[]){
5204: Opt=car(Opt)[1];
5205: if(type(Opt)==1) Opt=[Opt,Opt];
5206: if(Opt!=[1,1]){
5207: if(!MM) MM=1;
5208: MM=MM*diagm(2,[Opt[0],Opt[1]]);
5209: }
5210: }
5211: if(MM) V=ptaffine(MM,V|option_list=Org);
1.74 ! takayama 5212: if(length(T)>3){
! 5213: if(type(T2=T[3])==7) T2=[T2];
! 5214: V=append(V,T2);
! 5215: }
1.6 takayama 5216: str_tb(xyput(V),Out);
5217: }else if(T[0]==3){
5218: F++;
5219: T1=T[2];T2=T[3];
5220: if(M){
5221: T1=ptaffine(M,T1|option_list=Org);
5222: T2=ptaffine(M,T2|option_list=Org);
5223: }
5224: str_tb(xyarrow(T1,T2|option_list=Opt),Out);
5225: }else if(T[0]==4){
5226: F++;
5227: T1=T[2];T2=T[3];
5228: if(M){
5229: T1=ptaffine(M,T1|option_list=Org);
5230: T2=ptaffine(M,T2|option_list=Org);
5231: }
5232: str_tb(xyline(T1,T2|option_list=Opt),Out);
5233: }else if(T[0]==5){
5234: if(F){
5235: S=str_tb(0,Out);
5236: Out=str_tb(0,0);
5237: F=0;
5238: if(S!=""){
5239: if(P[0]==2) dviout(xyproc(S)|keep=1);
5240: else LOut=cons(xyproc(S),LOut);
5241: }
5242: if(P[0]==2) dviout(T[2]|option_list=T[1]);
5243: else LOut=cons(T[2],Out);
5244: }
1.57 takayama 5245: }else if(T[0]==6){ /* plot */
5246: F++;
5247: if(type(T[1])==7) T1=[T[1],"."];
5248: else T1=".";
5249: for(T2=ptaffine(M,T[2]|option_list=Org);T2!=[];T2=cdr(T2))
5250: str_tb(xypos([car(T2)[0],car(T2)[1],T1]),Out);
1.6 takayama 5251: }else if(T[0]==-2)
5252: str_tb(["%",T[1],"\n"],Out);
1.57 takayama 5253: else if(Proc==1&&type(T[0])==2){
1.6 takayama 5254: if(length(T)<3) call(T[0],T[1]);
5255: else call(T[0],T[1]|option_list=T[2]);
5256: }
5257: }
5258: S=str_tb(0,Out);
5259: if(P[0]==1){
5260: if(F) LOut=cons(xyproc(S),LOut);
5261: Out=str_tb(0,0);
5262: for(L=reverse(LOut);L!=[];L=cdr(L))
5263: str_tb(car(L),Out);
5264: return str_tb(0,Out);
5265: }
5266: if(F) dviout(xyproc(S));
5267: else dviout(" ");
5268: }
5269: }
5270:
5271: def execproc(L)
5272: {
5273: if(type(N=getopt(var))!=1&&N!=0) N=2;
5274: for(R=[];L!=[];L=cdr(L)){
5275: P=car(L);
5276: if(type(P[0])==2&&vtype(P[0])==3){
5277: if((VS=vars(cdr(P)))!=[]){
5278: for(I=0;I<N;I++){
5279: V=makev(["v",I+1]);
5280: if(findin(V,VS)>=0) P=mysubst(P,[V,R[I]]);
5281: }
5282: }
5283: if(length(P)<3) R=cons(call(P[0],P[1]),R);
5284: else R=cons(call(P[0],P[1]|option_list=P[2]),R);
5285: }
5286: }
5287: return (getopt(all)==1)?R:car(R);
5288: }
5289:
5290: def myswap(P,L)
5291: {
5292: X=makenewv(P);
5293: for(L=reverse(L);length(L)>1;L=cdr(L))
5294: P=subst(P,L[0],X,L[1],L[0],X,L[1]);
5295: return P;
5296: }
5297:
5298: def mysubst(P,L)
5299: {
5300: if(P==0) return 0;
1.29 takayama 5301: if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]);
1.6 takayama 5302: Inv=getopt(inv);
5303: if(type(L[0]) == 4){
5304: while((L0 = car(L))!=[]){
5305: P = mysubst(P,(Inv==1)?[L0[1],L0[0]]:L0);
5306: L = cdr(L);
5307: }
5308: return P;
5309: }
5310: if(Inv==1) L=[L[1],L[0]];
5311: if(type(P) > 3){
5312: if(type(P)==7) return P;
5313: if(type(P)>7)
5314: return subst(P,L[0],L[1]);
5315: #ifdef USEMODULE
5316: return mtransbys(os_md.mysubst,P,[L]);
5317: #else
5318: return mtransbys(mysubst,P,[L]);
5319: #endif
5320: }
5321: P = red(P);
5322: if(type(P) == 3){
5323: A=mysubst(nm(P),L);B=mysubst(dn(P),L);
5324: return red(nm(A)/nm(B))*red(dn(B)/dn(A));
5325: }
5326: L1=(type(L[1])==3)?red(L[1]):L[1];X=L[0];
5327: if(ptype(L1,X)==3){
5328: LN=nm(L1);LD=dn(L1);
5329: Deg=mydeg(P,X);
5330: if(Deg <= 0) return P;
5331: V = newvect(Deg+1);
5332: for(V[I=Deg]=1;I >= 1;I--)
5333: V[I-1]=V[I]*LD;
5334: for(R = 0, I = Deg; I >= 0; I--)
5335: R = R*LN + mycoef(P,I,X)*V[I];
5336: return red(R/V[0]);
5337: }
5338: return subst(P,X,L1);
5339: }
5340:
5341: def mmulbys(FN,P,F,L)
5342: {
5343: Opt=getopt();
5344: if(type(F) <= 3){
5345: if(type(P) <= 3)
5346: return call(FN, cons(P,cons(F,L))|option_list=Opt);
5347: if(type(P) == 5){
5348: S = length(P);
5349: R = newvect(S);
5350: for(I = 0; I < S; I++)
5351: R[I] = call(FN, cons(P[I],cons(F,L))|option_list=Opt);
5352: return R;
5353: }else if(type(P) == 6){
5354: S = size(P);
5355: R = newmat(S[0],S[1]);
5356: for(I = 0; I < S[0]; I++){
5357: for(J = 0; J < S[1]; J++)
5358: R[I][J] = call(FN, cons(P[I][J],cons(F,L))|option_list=Opt);
5359: }
5360: return R;
5361: }
5362: }
5363: if(type(F) == 5){
5364: S = length(F);
5365: if(type(P) <= 3){
5366: R = newvect(S);
5367: for(I = 0; I < S; I++)
5368: R[I] = call(FN, cons(P,cons(F[I],L))|option_list=Opt);
5369: return R;
5370: }
5371: if(type(P) == 5){
5372: for(J=R=0; J<S; J++)
5373: R = radd(R, call(FN, cons(P[J],cons(F[J],L)))|option_list=Opt);
5374: return R;
5375: }
5376: T = size(P);
5377: R = newvect(T[0]);
5378: for(I = 0; I < T[0]; I++){
5379: for(J = 0; J < S; J++)
5380: R[I] = radd(R[I], call(FN, cons(P[I][J],cons(F[J],L))|option_list=Opt));
5381: }
5382: return R;
5383: }
5384: if(type(F) == 6){
5385: S = size(F);
5386: if(type(P) <= 3){
5387: R = newmat(S[0],S[1]);
5388: for(I = 0; I < S[0]; I++){
5389: for(J = 0; J < S[1]; J++)
5390: R[I][J] = call(FN, cons(P,cons(F[I][J],L))|option_list=Opt);
5391: }
5392: return R;
5393: }
5394: if(type(P) == 5){
5395: R = newvect(S[1]);
5396: for(J = 0; J < S[1]; J++){
5397: for(K = U = 0; K < S[0]; K++)
5398: U = radd(U, call(FN, cons(P[K],cons(F[K][J],L))|option_list=Opt));
5399: R[J] = U;
5400: }
5401: return R;
5402: }
5403: T = size(P);
5404: R = newmat(T[0],S[1]);
5405: for(I = 0; I < T[0]; I++){
5406: for(J = 0; J < S[1]; J++){
5407: for(K = U = 0; K < S[0]; K++)
5408: U = radd(U, call(FN, cons(P[I][K],cons(F[K][J],L)|option_list=Opt)));
5409: R[I][J] = U;
5410: }
5411: }
5412: return R;
5413: }
5414: erno(0);
5415: return 0;
5416: }
5417:
5418: def appldo(P,F,L)
5419: {
1.56 takayama 5420: if(getopt(Pfaff)==1){
5421: L = vweyl(L);
5422: X = L[0]; DX = L[1];
5423: for(I=mydeg(P,DX);I>0;I--){
5424: if(!(TP=mycoef(P,D,DX))) continue;
5425: P=red(P+TP*(muldo(D^(I-1),F,L)-D^I));
5426: }
5427: return P;
5428: }
1.6 takayama 5429: if(type(F) <= 3){
5430: if(type(L) == 4 && type(L[0]) == 4)
5431: return applpdo(P,F,L);
5432: L = vweyl(L);
5433: X = L[0]; DX = L[1];
5434: J = mydeg(P,DX);
5435: for(I = R = 0; I <= J; I++){
5436: if(I > 0)
5437: F = mydiff(F,X);
5438: R = radd(R,mycoef(P,I,DX)*F);
5439: }
5440: return R;
5441: }
5442: #ifdef USEMODULE
5443: return mmulbys(os_md.appldo,P,F,[L]);
5444: #else
5445: return mmulbys(appldo,P,F,[L]);
5446: #endif
5447: }
5448:
5449: def appledo(P,F,L)
5450: {
5451: if(type(F) <= 3){
5452: L = vweyl(L);
5453: X = L[0]; DX = L[1];
5454: J = mydeg(P,DX);
5455: for(I = R = 0; I <= J; I++){
5456: if(I > 0)
5457: F = myediff(F,X);
5458: R = radd(R,mycoef(P,I,DX)*F);
5459: }
5460: return R;
5461: }
5462: #ifdef USEMODULE
5463: mmulbys(os_md.appledo,P,F,[L]);
5464: #else
5465: mmulbys(appledo,P,F,[L]);
5466: #endif
5467: }
5468:
5469: def muldo(P,Q,L)
5470: {
5471: if(type(Lim=getopt(lim))!=1) Lim=100;
5472: if(type(Q) <= 3){
5473: if(type(L) == 4 && type(L[0]) == 4)
5474: return mulpdo(P,Q,L|lim=Lim); /* several variables */
5475: R = rmul(P,Q);
5476: L = vweyl(L);
5477: X = L[0]; DX = L[1];
5478: if(X != 0){
5479: for(I = F = 1; ; I++){
5480: P = mydiff(P,DX);
5481: if(I>Lim){
5482: mycat(["Over", Lim,"derivations!"]);
5483: break;
5484: }
5485: if(P == 0)
5486: break;
5487: Q = mydiff(Q,X);
5488: if(Q == 0)
5489: break;
5490: F *= I;
5491: R = radd(R,P*Q/F);
5492: }
5493: }
5494: return R;
5495: }
5496: #ifdef USEMODULE
5497: return mmulbys(os_md.muldo,P,Q,[L]);
5498: #else
5499: return mmulbys(muldo,P,Q,[L]);
5500: #endif
5501: }
5502:
5503: def jacobian(F,X)
5504: {
5505: F=ltov(F);X=ltov(X);
1.30 takayama 5506: N=length(F);L=length(X);
5507: M=newmat(N,L);
1.6 takayama 5508: for(I=0;I<N;I++)
1.30 takayama 5509: for(J=0;J<L;J++) M[I][J]=red(diff(F[I],X[J]));
5510: if(N!=L||getopt(mat)==1) return M;
1.6 takayama 5511: return mydet(M);
5512: }
5513:
5514: def hessian(F,X)
5515: {
5516: X=ltov(X);
5517: N=length(X);
5518: M=newmat(N,N);
5519: for(I=0;I<N;I++){
5520: G=red(diff(F,X[I]));
5521: for(J=0;J<N;J++) M[I][J]=red(diff(G,X[J]));
5522: }
5523: if(getopt(mat)==1) return M;
5524: return mydet(M);
5525: }
5526:
5527: def wronskian(F,X)
5528: {
5529: N=length(F);
5530: M=newmat(N,N);
5531: for(I=0;F!=[];F=cdr(F),I++){
5532: M[I][0]=car(F);
5533: for(J=1;J<N;J++) M[I][J]=red(diff(M[I][J-1],X));
5534: }
5535: if(getopt(mat)==1) return M;
5536: return mydet(M);
5537: }
5538:
5539: def adj(P,L)
5540: {
5541: if(type(P) == 4)
5542: #ifdef USEMODULE
5543: return map(os_md.adj,mtranspose(P),L);
5544: #else
5545: return map(adj,mtranspose(P),L);
5546: #endif
5547: if(type(L) == 4 && type(L[0]) == 4)
5548: #ifdef USEMODULE
5549: return fmult(os_md.adj,P,L,[]);
5550: #else
5551: return fmult(adj,P,L,[]);
5552: #endif
5553: L = vweyl(L);
5554: X = L[0]; DX = L[1];
5555: P = R = subst(P, DX, -DX);
5556: for(I = 1; (R = mydiff(mydiff(R, X), DX)/I) != 0 && I < 100; I++)
5557: P = radd(P,R);
5558: return P;
5559: }
5560:
5561: def laplace1(P,L)
5562: {
5563: if(type(L) == 4 && type(L[0]) == 4)
5564: #ifdef USEMODULE
5565: return fmult(os_md.laplace,P,L,[]);
5566: #else
5567: return fmult(laplace,P,L,[]);
5568: #endif
5569: L = vweyl(L);
5570: X = L[0]; DX = L[1];
5571: P = adj(P, L);
5572: return subst(P,X,o_1,DX,X,o_1,DX);
5573: }
5574:
5575: def laplace(P,L)
5576: {
5577: if(type(L) == 4 && type(L[0]) == 4)
5578: #ifdef USEMODULE
5579: return fmult(os_md.laplace1,P,L,[]);
5580: #else
5581: return fmult(laplace1,P,L,[]);
5582: #endif
5583: L = vweyl(L);
5584: X = L[0]; DX = L[1];
5585: P = adj(P, L);
5586: return subst(P,X,o_1,DX,-X,o_1,-DX);
5587: }
5588:
5589: def mce(P,L,V,R)
5590: {
5591: L = vweyl(L);
5592: X = L[0]; DX = L[1];
1.56 takayama 5593: P = sftexp(laplace1(P,L),L,V,R|option_list=getopt());
1.6 takayama 5594: return laplace(P,L);
5595: }
5596:
5597: def mc(P,L,R)
5598: {
1.56 takayama 5599: return mce(P,L,0,R|option_list=getopt());
1.6 takayama 5600: }
5601:
5602: def rede(P,L)
5603: {
5604: Q = ltov(fctr(nm(red(P))));
5605: P = 1;
5606: if(type(L) < 4)
5607: L = [L];
5608: if(type(L[0]) < 4)
5609: L = [L];
5610: for( ; L != []; L = cdr(L)){
5611: DX = vweyl(car(L))[1];
5612: for(I = 1; I < length(Q); I++){
5613: if(mydeg(Q[I][0],DX) > 0){
5614: P *= (Q[I][0])^(Q[I][1]);
5615: Q[I]=[1,0];
5616: }
5617: }
5618: }
5619: return P;
5620: }
5621:
5622: def ad(P,L,R)
5623: {
5624: L = vweyl(L);
5625: DX = L[1];
5626: K = mydeg(P,DX);
5627: S = mycoef(P,0,DX);
5628: Q = 1;
5629: for(I=1; I <= K;I++){
5630: Q = muldo(Q,DX-R,L);
5631: S = radd(S,mycoef(P,I,DX)*Q);
5632: }
5633: return S;
5634: }
5635:
5636: def add(P,L,R)
5637: {
5638: return rede(ad(P,L,R),L);
5639: }
5640:
5641:
5642: def vadd(P,L,R)
5643: {
5644: L = vweyl(L);
5645: if(type(R) != 4)
5646: return 0;
5647: N = length(R);
5648: DN = 1; Ad = PW = 0;
5649: for( ; R != []; R = cdr(R), PW++){
5650: DN *= (T=1-car(R)[0]*L[0]);
5651: Ad = Ad*T-car(R)[1]*x^PW;
5652: }
5653: Ad /= DN;
5654: return add(P,L,Ad);
5655: }
5656:
5657: def addl(P,L,R)
5658: {
5659: return laplace1(add(laplace(P,L),L,R),L);
5660: }
5661:
5662: def cotr(P,L,R)
5663: {
5664: L = vweyl(L);
5665: X = L[0]; DX = L[1];
5666: T = 1/mydiff(P,DX);
5667: K = mydeg(P,DX);
5668: S = mysubst(mycoef(P,0,DX), [X, R]);
5669: Q = 1;
5670: for(I = 1; I <= K; I++){
5671: Q = muldo(Q, K*DX, L);
5672: S = radd(S,mysubst(mycoef(P,I,DX), [X, R])*Q);
5673: }
5674: }
5675:
5676: def rcotr(P,L,R)
5677: {
5678: return rede(cotr(P,L,R), L);
5679: }
5680:
5681: def muledo(P,Q,L)
5682: {
5683: if(type(Q)>3)
5684: #ifdef USEMODULE
5685: return mmulbys(os_md.muledo,P,Q,[L]);
5686: #else
5687: return mmulbys(muledo,P,Q,[L]);
5688: #endif
5689: R = P*Q;
5690: L = vweyl(L);
5691: X = L[0]; DX = L[1];
5692: for(I = F = 1; I < 100; I++){
5693: P = mydiff(P,DX);
5694: if(P == 0)
5695: break;
5696: Q = myediff(Q,X);
5697: if(Q == 0)
5698: break;
5699: F = rmul(F,I);
5700: R = radd(R,P*Q/F);
5701: }
5702: return R;
5703: }
5704:
5705:
5706: #if 1
5707: def mulpdo(P,Q,L)
5708: {
5709: if(type(Q)>3)
5710: #ifdef USEMODULE
5711: return mmulbys(os_md.mulpdo,P,Q,[L]);
5712: #else
5713: return mmulbys(mulpdo,P,Q,[L]);
5714: #endif
5715: if(type(Lim=getopt(lim))!=1) Lim=100;
5716: M = vweyl(car(L)); X= M[0]; DX = M[1];
5717: L = cdr(L);
5718: R = 0;
5719: for(I = 0; Q != 0 && I <= Lim; I++){
5720: if(I>Lim){
5721: mycat(["Over", Lim,"derivations!"]);
5722: break;
5723: }
5724: if(I > 0)
5725: P /= I;
5726: if(length(L)==0)
5727: R = radd(R,P*Q);
5728: else
5729: R = radd(R,mulpdo(P,Q,L));
5730: if(X==0) break;
5731: P = mydiff(P,DX);
5732: if(P == 0)
5733: break;
5734: Q = mydiff(Q,X);
5735: }
5736: if(I>Lim) mycat(["Over", Lim,"derivations!"]);
5737: return R;
5738: }
5739:
5740: #else
5741: def mulpdo(P,Q,L);
5742: {
5743: if(type(Q)>3)
5744: #ifdef USEMODULE
5745: return mmulbys(os_md.mulpdo,P,Q,[L]);
5746: #else
5747: return mmulbys(mulpdo,P,Q,[L]);
5748: #endif
5749: if(type(Lim=getopt(lim))!=1) Lim=100;
5750: N = length(L);
5751: VO = newvect(2*N);
5752: VN = newvect(2*N);
5753: for(I = J = 0; I < N; J += 2, I++){
5754: M = vweyl(L[I]);
5755: P = subst(P, VO[J]=M[0], VN[J]=strtov("o_"+rtostr(V[J])),
5756: VO[J+1]=M[1], VN[J+1] = strtov("o_"+rtostr(V[J+1])));
5757: }
5758: for(PQ = P*Q, I = 0; I < 2*N; I += 2){
5759: for(R = PQ, J = 1; J < Lim; J++){
5760: R = mydiff(R, VN[I+1])/J;
5761: if(R == 0)
5762: break;
5763: R = mydiff(R, VO[I]);
5764: if(R == 0)
5765: break;
5766: PQ = radd(PQ,R);
5767: }
5768: if(I==Lim) mycat(["Over", Lim,"derivations!"]);
5769: PQ = red(subst(PQ,VN[I],VO[I],VN[I+1],VO[I+1]));
5770: }
5771: }
5772: #endif
5773:
5774: def transpdosub(P,LL,K)
5775: {
1.49 takayama 5776: if(type(P)>3) return
5777: #ifdef USEMODULE
5778: mtransbys(os_md.transpdosub,P,[LL,K]);
5779: #else
5780: mtransbys(transpdosub,P,[LL,K]);
5781: #endif
1.6 takayama 5782: Len = length(K)-1;
5783: if(Len < 0 || P == 0)
5784: return P;
5785: KK=K[Len];
5786: if(type(KK)==4){
5787: KK0=KK[0]; KK1=KK[1];
5788: }else{
5789: L = vweyl(LL[Len]);
5790: KK0=L[1]; KK1=K[Len];
5791: }
5792: Deg = mydeg(P,KK0);
5793: K1 = reverse(cdr(reverse(K)));
5794: R = transpdosub(mycoef(P,0,KK0),LL,K1);
5795: for(I = M = 1; I <= Deg ; I++){
5796: M = mulpdo(M,KK1,LL);
5797: S = mycoef(P,I,KK0);
5798: if(Len > 0)
5799: S = transpdosub(S,LL,K1);
5800: R = radd(R,mulpdo(S,M,LL));
5801: }
5802: return R;
5803: }
5804:
5805: def transpdo(P,LL,K)
5806: {
5807: Len = length(K)-1;
5808: K1=K2=[];
5809: if(type(LL)!=4) LL=[LL];
5810: if(type(LL[0])!=4) LL=[LL];
1.49 takayama 5811: if(type(car(K)) < 4 && length(LL)!=length(K)) K = [K];
1.6 takayama 5812: if(getopt(ex)==1){
5813: for(LT=LL, KT=K; KT!=[]; LT=cdr(LT), KT=cdr(KT)){
5814: L = vweyl(LL[J]);
5815: K1=cons([L[0],car(KT)[0]],K1);
5816: K2=cons([L[1],car(KT)[1]],K2);
5817: }
5818: K2=append(K1,K2);
5819: }else{
1.49 takayama 5820: if(length(LL)==length(K) && type(car(K))!=4){
5821: for(DV=V=TL=[],J=length(LL)-1;J>=0;J--){
5822: TL=cons(vweyl(LL[J]),TL);
5823: V=cons(car(TL)[0],V);
5824: DV=cons(car(TL)[1],DV);
5825: }
5826: LL=TL;
5827: if(type(RK=solveEq(K,V|inv=1))!=4) return TK;
5828: if(!isint(Inv=getopt(inv))) Inv=0;
5829: if(iand(Inv,1)){J=K;K=RK;RK=J;}
5830: M=jacobian(RK,V|mat=1);
5831: M=mulsubst(M,[V,K]|lpair=1);
5832: RK=vtol(M*ltov(DV));
5833: if(Inv>1) return RK;
5834: K=lpair(K,RK);
5835: }
1.6 takayama 5836: for(J = length(K)-1; J >= 0; J--){
5837: L = vweyl(LL[J]);
1.49 takayama 5838: if(L[0]!= K[J][0]) K1=cons([L[0],K[J][0]],K1);
1.6 takayama 5839: K2 = cons(K[J][1],K2);
5840: }
5841: P = mulsubst(P, K1);
5842: }
5843: return transpdosub(P,LL,K2);
5844: }
5845:
5846: def translpdo(P,LL,M)
5847: {
5848: S=length(LL);
5849: L0=newvect(S);L1=newvect(S);
5850: K=newvect(S);
5851: for(J=0;J<S;J++){
5852: L = vweyl(LL[J]);
5853: L0[J]=L[0];
5854: L1[J]=L[1];
5855: }
5856: K=rmul(M,L0);
5857: for(T=[],J=0;J<S;J++)
5858: T=cons([L0[J],K[J]],T);
5859: P=mulsubst(P,T);
5860: K=rmul(myinv(M),L1);
5861: for(T=[],J=0;J<S;J++)
5862: T=cons([L1[J],K[J]],T);
5863: return mulsubst(P,T);
5864: }
5865:
5866: /*
5867: return [R, M, S] : R = M*P - S*Q
5868: deg(R,X) < deg(Q,X)
5869: */
5870: def rpdiv(P,Q,X)
5871: {
5872: if(P == 0)
5873: return [0,1,0];
5874: DQ = mydeg(Q,X);
5875: CO = mycoef(Q,DQ,X);
5876: S = 0;
5877: while((DP = mydeg(P,X)) >= DQ){
5878: R = mycoef(P,DP,X)/CO;
5879: S = radd(S,R*X^(DP-DQ));
5880: P = radd(P, -R*Q*X^(DP-DQ));
5881: }
5882: Lcm = lcm(dn(S),dn(P));
5883: Gcd = gcd(nm(S),nm(P));
5884: return [red(P*Lcm/Gcd), red(Lcm/Gcd),red(S*Lcm/Gcd)];
5885: }
5886:
5887: def texbegin(T,S)
5888: {
5889: if(type(Opt=getopt(opt))==7) Opt="["+Opt+"]\n";
5890: else Opt="\n";
1.47 takayama 5891: U=(str_chr(S,str_len(S)-1,"\n")<0)?"%\n":"";
5892: return "\\begin{"+T+"}"+Opt+S+U+"\\end{"+T+"}\n";
1.6 takayama 5893: }
5894:
5895: def mygcd(P,Q,L)
5896: {
5897: if((Dvi=getopt(dviout))==3 || Dvi==-3){ /* dviout=3 */
5898: if((Rev=getopt(rev))!=1) Rev=0;
5899: R=mygcd(P,Q,L|rev=Rev);
5900: if(type(L)<2) Var=0;
5901: else if(type(L)==2){
5902: Val=L;L=[0,L];
5903: }else if(type(L)==4){
5904: L=vweyl(L);
5905: Var=[[L[1],"\\partial"]];
5906: }
5907: S=mat([P],[Q]);T=mat([R[0]],[0]);
5908: M=mat([R[1],R[2]],[R[3],R[4]]);
5909: if(type(Val)==4)
5910: N=mdivisor(M,L|trans=1)[1];
5911: else N=myinv(M);
5912: Tb=str_tb(mtotex(S|var=Var),0);
5913: str_tb("&="+mtotex(N|var=Var)+mtotex(T|var=Var)+",\\\\\n",Tb);
5914: str_tb(mtotex(T|var=Var),Tb);
5915: str_tb("&="+mtotex(M|var=Var)+mtotex(S|var=Var)+".",Tb);
5916: Out=str_tb(0,Tb);
5917: if(Dvi<0) return Out;
5918: dviout(Out|eq="align*");
5919: return 1;
5920: }
5921: if((type(Dvi)==1||Dvi==0) && getopt(rev)!=1) V=[[P,Q]];
5922: else V=0;
5923: if(L==0){ /* integer case */
5924: if(type(P) > 1 || type(Q) > 1 || Q==0 /* P <= 0 || Q <= 0 */
5925: || dn(P) > 1 || dn(Q) > 1)
5926: return 0;
5927: CPP = CQQ = 1; CQP = CPQ = 0;
5928: P1 = P; Q1 = Q;
5929: /* P1 = CPP*P + CPQ*Q
5930: Q1 = CQP*P + CQQ*Q */
5931: while(Q1 != 0){
5932: Div1 = idiv(P1,Q1); Div2 = irem(P1,Q1);
5933: if(type(V)==4) V=cons([Div1,Div2],V);
5934: P1 = Q1 ; Q1 = Div2;
5935: TP = CQP; TQ = CQQ;
5936: CQP = CPP-Div1*CQP;
5937: CQQ = CPQ-Div1*CQQ;
5938: CPP = TP; CPQ = TQ;
5939: }
5940: if(V!=0){
5941: V=reverse(V);
5942: if((DVI=abs(Dvi))==0) return V;
5943: PT=P;QT=Q;
5944: if(DVI==1 || DVI==2){
5945: Tb=str_tb(0,0);
5946: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
5947: T=car(V);
5948: if(C++) str_tb(texcr(11),Tb);
5949: if(DVI==1){
5950: Qs=rtostr(QT);
5951: if(QT<0) Qs="("+Qs+")";
5952: if(T[1]>0) Qs=Qs+"+";
5953: if(T[1]!=0) Qs=Qs+rtostr(T[1]);
5954: str_tb(rtostr(PT)+"&="
5955: +rtostr(T[0])+"\\times"+Qs,Tb);
5956: }else{
5957: N=mat([T[0],1],[1,0]);
5958: if(C==1){
5959: str_tb(S0=mtotex(mat([PT],[QT])),Tb);
5960: M=N;
5961: }
5962: str_tb("&=",Tb);
5963: if(C>1) str_tb(mtotex(M),Tb);
5964: str_tb(mtotex(N),Tb);
5965: str_tb(S=mtotex(mat([QT],[T[1]])),Tb);
5966: if(C>1){
5967: str_tb("=",Tb);
5968: str_tb(mtotex(M=M*N),Tb);
5969: str_tb(S,Tb);
5970: }
5971: }
5972: PT=QT;QT=T[1];
5973: }
5974: if(DVI==2){
5975: str_tb(texcr(43)+S+"&=",Tb);
5976: str_tb(mtotex(myinv(M)),Tb);
5977: str_tb(S0,Tb);
5978: }
5979: Out=str_tb(0,Tb);
5980: if(Dvi>0){
5981: dviout(Out|eq="align*");
5982: return 1;
5983: }
5984: return Out;
5985: }
5986: }
5987: if(P1<0) return [-P1,-CPP,-CPQ,CQP,CQQ];
5988: return [P1, CPP, CPQ, CQP, CQQ];
5989: }
5990: if(type(L) == 2) /* polynomical case */
5991: L = [0,L];
5992: if(getopt(rev)==1 && L[0]!=0){
5993: R=mygcd(adj(P,L),adj(Q,L),L);
5994: return [adj(R[0],L),adj(R[1],L),adj(R[2],L),adj(R[3],L),adj(R[4],L)];
5995: }
5996: if(type(P) == 3)
5997: P = red(P);
5998: if(type(Q) == 3)
5999: Q = red(Q);
6000: CP=newvect(2,[1/dn(P),0]); CQ=newvect(2,[0,1/dn(Q)]);
6001: P=PT=nm(P); Q =QT=nm(Q);
6002: L = vweyl(L);
6003: while(Q != 0){
6004: R = divdo(P,Q,L);
6005: if(type(V)==4) V=cons(R,V);
6006: /* R[1] = R[2]*P - R[0]*Q
6007: = R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */
6008: /*
6009: P(n) |0 1 | P(n-1)
6010: = | |
6011: R[1] |R[2] -R[0]| P(n)
6012: P(n+1) = R[1], P(n) = P, P(n-1) = Q
6013: */
6014: P = Q;
6015: Q = R[1];
6016: {
6017: CT = dupmat(CQ);
6018: CQ = [R[2]*CP[0]-muldo(R[0],CQ[0],L),
6019: R[2]*CP[1]-muldo(R[0],CQ[1],L)];
6020: CP = CT;
6021: }
6022: }
6023: if(V!=0){
6024: V=reverse(V);
6025: if((DVI=abs(Dvi))==0) return V;
6026: if(type(L[0])<1) Var=L[1];
6027: else Var=[L[1],"\\partial"];
6028: if(DVI==1 || DVI==2){
6029: Tb=str_tb(0,0);
6030: PT=car(V)[0];QT=car(V)[1];
6031: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
6032: T=car(V);
6033: if(C++) str_tb(texcr(11),Tb);
6034: if(DVI==1){
6035: if(T[2]!=1){
6036: str_tb(monototex(T[2]),Tb);
6037: str_tb("(",Tb);
6038: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
6039: str_tb(")&=",Tb);
6040: }else{
6041: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
6042: str_tb("&=",Tb);
6043: }
6044: str_tb("(",Tb);
6045: str_tb(fctrtos(T[0]|var=Var,TeX=2),Tb);
6046: str_tb(")(",Tb);
6047: str_tb(fctrtos(QT|var=Var,TeX=2),Tb);
6048: if(T[1]!=0){
6049: str_tb(")+(",Tb);
6050: str_tb(fctrtos(T[1]|var=Var,TeX=2),Tb);
6051: }
6052: str_tb(")",Tb);
6053: }else{
6054: N=mat([red(T[0]/T[2]),1],[1,0]);
6055: if(C==1){
6056: str_tb(S0=mtotex(mat([PT],[QT])|var=Var),Tb);
6057: M=N;
6058: }
6059: str_tb("&=",Tb);
6060: if(C>1) str_tb(mtotex(M),Tb);
6061: str_tb(mtotex(N|var=Var),Tb);
6062: str_tb(S=mtotex(mat([QT],[T[1]])|var=Var),Tb);
6063: if(C>1){
6064: str_tb("=",Tb);
6065: str_tb(mtotex(M=muldo(M,N,L)|var=Var),Tb);
6066: str_tb(S,Tb);
6067: }
6068: }
6069: PT=QT;QT=T[1];
6070: }
6071: if(DVI==2){
6072: FT=fctr(PT);
6073: for(R=1;FT!=[];FT=cdr(FT)){
6074: if(mydeg(car(FT)[0],L[1])<1)
6075: for(J=car(FT)[1];J>0;J--) R*=car(FT)[0];
6076: }
6077: if(R!=1){
6078: str_tb(texcr(79),Tb);
6079: M=muldo(M,mat([R,0],[0,1]),L);
6080: str_tb(mtotex(M|var=Var),Tb);
6081: str_tb(S=mtotex(mat([PT/R],[QT])|var=Var),Tb);
6082: }
6083: str_tb(texcr(43)+S+"&=",Tb);
6084: if(type(Var)==4){
6085: N=mdivisor(M,L|trans=1);
6086: N=N[1];
6087: }else
6088: N=myinv(M);
6089: str_tb(mtotex(N|var=Var),Tb);
6090: str_tb(S0,Tb);
6091: }
6092: Out=str_tb(0,Tb);
6093: if(Dvi>0){
6094: dviout(Out|eq="align*");
6095: return 1;
6096: }
6097: return Out;
6098: }
6099: }
6100: Q = rede(P,L);
6101: R = red(P/Q);
6102: return [Q,red(CP[0]/R),red(CP[1]/R),red(CQ[0]/R),red(CQ[1]/R)];
6103: }
6104:
6105: def mylcm(P,Q,L)
6106: {
6107: Rev=(getopt(rev)==1)?1:0;
6108: if(Rev==1){
6109: P=adj(P); Q=adj(Q);
6110: }
6111: R = mygcd(P,Q,L);
6112: S=(type(L)<=2)?R[3]*P:muldo(R[3],P,L);
6113: S = nm(S);
6114: if(type(S) <= 1 && type(L) <= 1){
6115: if(S<0) S = -S;
6116: return S;
6117: }
6118: if(type(L) == 2)
6119: return easierpol(S,L);
6120: S=rede(easierpol(S,L[1]),L);
6121: return (Rev==1)?adj(S):S;
6122: }
6123:
6124: def sftpexp(P,LL,F,Q)
6125: {
6126: if(type(LL[0]) < 4)
6127: LL = [LL];
6128: for(L0=L1=[],LT=LL;LT!=[];LT=cdr(LT)){
6129: W=vweyl(car(LT));
6130: L0=cons(W,L0);
6131: D=mydiff(F,W[0]);
6132: if(D!=0) L1=cons(W[1]+Q*D/F,L1);
6133: else L1=cons(W[1],L1);
6134: }
6135: return rede(transpdosub(P,L0,L1),L0);
6136: }
6137:
6138: def applpdo(P,F,LL)
6139: {
6140: if(type(F)>3)
6141: #ifdef USEMODULE
6142: return mmulbys(os_md.applpdo,P,F,[LL]);
6143: #else
6144: return mmulbys(applpdo,P,F,[LL]);
6145: #endif
6146: L = vweyl(LL[0]);
6147: LL = cdr(LL);
6148: Deg = deg(P,L[1]);
6149: S = F;
6150: for(I = R = 0; I <= Deg ; I++){
6151: if(I > 0)
6152: S = mydiff(S,L[0]);
6153: if(LL == [])
6154: R = radd(R,mycoef(P,I,L[1])*S);
6155: else
6156: R = radd(R,applpdo(mycoef(P,I,L[1]), S, LL));
6157: }
6158: return R;
6159: }
6160:
6161: def tranlpdo(P,L,M)
6162: {
6163: N = length(L);
6164: R = size(M);
6165: if(R[0] != N || R[1] != N){
6166: print("Strange size");
6167: return;
6168: }
6169: InvM = M;
6170: if(InvM[1] == 0){
6171: print("Not invertible");
6172: return;
6173: }
6174: XL = newvector(N);
6175: DL = newvector(N);
6176: for(I = 0; I < 0; I++){
6177: R = vweyl(L[I]);
6178: XL[I] = R[0];
6179: DL[I] = R[1];
6180: }
6181: for(I = 0; I < N; I++){
6182: for(J = XX = D0 = 0; J < N; J++){
6183: XX = radd(XX,M[I][J]*XL[J]);
6184: DD = radd(DD, red(InvM[0][I][J]/InvM[1])*DL[J]);
6185: P = mysubst(P,[[XL[I],XX],[DL[I],DD]]);
6186: }
6187: }
6188: return P;
6189: }
6190:
6191: def divdo(P,Q,L)
6192: {
6193: if(L==0){
6194: R=P-idiv(P,Q)*Q;
6195: if(R<0){
6196: if(Q>0) R+=Q;
6197: else R-=Q;
6198: }
6199: return [(P-R)/Q,R,1];
6200: }
6201: L = vweyl(L);
6202: if(getopt(rev)==1){
6203: R=divdo(adj(P,L),adj(Q,L),L);
6204: return [adj(R[0],L),adj(R[1],L),R[2]];
6205: }
6206: X = L[0]; DX = L[1];
6207: S = 0;
6208: M = 1;
6209: I = mydeg(Q,DX);
6210: CQ = mycoef(Q,I,DX);
6211: while((J=mydeg(P,DX)) >= I){
6212: C = mycoef(P,J,DX);
6213: SR = red(C/CQ);
6214: if(dn(SR) != 1){
6215: M *= dn(SR);
6216: P *= dn(SR);
6217: S *= dn(SR);
6218: SR = nm(SR);
6219: }
6220: P -= muldo(SR*(DX)^(J-I),Q,L);
6221: S += SR*(DX)^(J-I);
1.70 takayama 6222: }
1.6 takayama 6223: return [S,P,M];
6224: }
6225:
6226: def qdo(P,Q,L)
6227: {
6228: L = vweyl(L); DX = L[1]; OD = deg(P,DX);
6229: V = newvect(OD+1);
6230: for(I = 0; I <= OD; I++){
6231: if(I)
6232: Q = muldo(DX,Q,L);
6233: S = divdo(Q,P,L);
6234: V[I] = S[1]*DX-S[2]*zz^I;
6235: }
6236: for(K = [], I = OD; I >= 0; I--)
6237: K = cons(DX^(I+1), K);
6238: R = lsol(V,K);
6239: S = length(R);
6240: for(I = P1 = 0; I < S; I++){
6241: if(type(R[I]) < 4 && mydeg(R[I],DX) == 0 && R[I] != 0
6242: && (mydeg(R[I],zz) <= mydeg(P,DX)))
6243: P1 = R[I];
6244: else if(type(R[I]) == 4 && R[I][0] == DX)
6245: P2 = R[I][1];
6246: }
6247: T=fctr(P1);
6248: for(I=0, S=length(T), P1=1; I<S; I++){
6249: if(mydeg(T[I][0],zz) > 0)
6250: P1 *= T[I][0]^(T[I][1]);
6251: }
6252: return subst([P1,P2],zz,DX);
6253: }
6254:
6255: def sqrtdo(P,L)
6256: {
6257: L = vweyl(L);
6258: P = toeul(P,L,0);
6259: V = -1;
6260: for(R = 0, Ord = mydeg(P,L[1]); Ord >= 0; Ord--){
6261: Q = coef(P,Ord,L[1]);
6262: M = mydeg(Q,L[0]);
6263: N = mymindeg(Q,L[0]);
6264: if(V < 0)
6265: V = M+N;
6266: else if(V != M+N){
6267: print("Cannot be transformed!");
6268: return;
6269: }
6270: Q = tohomog(red(Q/L[0]^N), [L[0]], z_z);
6271: if(irem(Ord,2))
6272: B = x-z_z;
6273: else
6274: B = x+z_z;
6275: Q = substblock(Q,x,B,z_zz);
6276: if(mydeg(Q,x) > 0){
6277: print("Cannot be transformed!");
6278: return;
6279: }
6280: R += mysubst(Q,[z_zz,x])*L[1]^Ord;
6281: }
6282: return fromeul(R,L,0);
6283: }
6284:
6285: def ghg(A,B)
6286: {
6287: R = dx;
6288: while(length(B)>0){
6289: R = muldo(x*dx+car(B),R,[x,dx]);
6290: B = cdr(B);
6291: }
6292: T = 1;
6293: while(length(A)>0){
6294: T = muldo(x*dx+car(A),T,[x,dx]);
6295: A = cdr(A);
6296: }
6297: return R-T;
6298: }
6299:
6300: def ev4s(A,B,C,S,T)
6301: {
6302: R4 = x^2*(x-1)^2;
6303: R3 = x*(x-1)*((2*A-2*B-8)*x-2*A+5);
6304: R2 = (-3/2*(A^2+B^2)+3*A*B+9*A-9*B-29/2+1/4*(S^2+T^2))*x^2
6305: +(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
6306: - (2*A+2*C-5)*(2*A-2*C-3)/4;
6307: 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
6308: +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
6309: #if 1
6310: + A^2*B
6311: #endif
6312: - B*C^2 - A^3/2+(2*A-3)*(S^2+T^2)/8;
6313: /* OK? for the above term added */
6314: R0 = -(A-B-1-S)*(A-B-1+S)*(A-B-1-T)*(A-B-1+T)/16;
6315: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
6316: }
6317:
6318: def b2e(A,B,C,S,T)
6319: {
6320: R4 = x^2*(x-1)^2;
6321: R3 = x*(x-1)*(2*x-1)*(2*c-5);
6322: R2 = (-6*C^2+24*C-25+1/2*S^2+1/2*T^2)*x^2
6323: +(6*C^2-24*C+25-1/2*S^2-1/2*T^2-A^2+B^2+A-B)*x
6324: +A^2-C^2-A+4*C-15/4;
6325: R1 = (2*C-3)*(2*C^2-6*C+5-1/2*S^2-1/2*T^2)*x
6326: +(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);
6327: R0 = -(2-2*C+S+T)*(2-2*C-S-T)*(2-2*C+S-T)*(2-2*C-S+T)/16;
6328: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
6329: }
6330:
6331:
6332: /*
6333: T^m = T(T-1)....(T-m+1)
6334: f(t) -> g(t)
6335:
6336: f(t) = a_mt^m + ... + a_1t+a_0
6337: g(x*dx) = a_m*x^m*dx^m + ... + a_1*x*dx+a_0
6338:
6339: ret: x(x-1)...(x-i+1)
6340: */
6341: def sftpow(X,I)
6342: {
6343: R = 1;
6344: for(J=0;J<I;J++)
6345: R *= X-J;
6346: return(R);
6347: }
6348:
6349: /*
6350: ret: x(x+K)(x+2*k)...(x+(i-1)*k)
6351: */
6352: def sftpowext(X,I,K)
6353: {
6354: R = 1;
6355: for(J=0;J<I;J++)
6356: R *= X+K*J;
6357: return(R);
6358: }
6359:
6360: def polinsft(F,A)
6361: {
6362: R = 0;
6363: while(F != 0){
6364: D = mydeg(F,A);
6365: C = mycoef(F,D,A);
6366: R += C*A^D;
6367: F -= C*sftpow(A,D);
6368: }
6369: return R;
6370: }
6371:
6372: def pol2sft(F,A)
6373: {
6374: S=getopt(sft);
6375: if(type(S)<0 || type(S)>2) S=1;
6376: R = 0;
6377: for(I = mydeg(F,A); I >= 0; I--)
6378: R = R*(A-I*S) + mycoef(F,I,A);
6379: return R;
6380: }
6381:
6382: def binom(P,N)
6383: {
1.20 takayama 6384: if(type(N)!=1 || N<=0) return 1;
1.6 takayama 6385: for(S=1;N>0;N--,P-=1) S*=P/N;
6386: return red(S);
6387: }
6388:
6389: def expower(P,R,N)
6390: {
6391: if(type(N)!=1 || N<0) return 0;
6392: for(S=S0=K=1;K<=N;K++,R-=1){
6393: S0*=P*R/K;S+=S0;
6394: }
6395: return red(S);
6396: }
6397:
6398: def seriesHG(A,B,X,N)
6399: {
1.20 takayama 6400: if(N==0) return 1;
1.6 takayama 6401: if(type(N)!=1 || N<0) return 0;
6402: if(type(X)<4){
6403: for(K=0,S=S0=1;K<N;K++){
6404: for(T=A; T!=[]; T=cdr(T)) S0*=car(T)+K;
6405: for(T=B; T!=[]; T=cdr(T)) S0/=car(T)+K;
6406: S0=red(S0*X/(K+1));
6407: DN=dn(S0);
6408: S=red((red(S*DN)+nm(S0))/DN);
6409: }
6410: return S;
6411: }
6412: S=0;
6413: for(K=0;K<=N;K++){
6414: for(I=0;I<=N-K;I++){
6415: C=1/sftpowext(1,I,1)/sftpowext(1,J,1);
6416: for(T=A[0];T!=[];T=cdr(T)) C*=sftpowext(car(T),I+K,1);
6417: for(T=A[1];T!=[];T=cdr(T)) C*=sftpowext(car(T),I,1);
6418: for(T=A[2];T!=[];T=cdr(T)) C*=sftpowext(car(T),K,1);
6419: for(T=B[0];T!=[];T=cdr(T)) C/=sftpowext(car(T),I+K,1);
6420: for(T=B[1];T!=[];T=cdr(T)) C/=sftpowext(car(T),I,1);
6421: for(T=B[2];T!=[];T=cdr(T)) C/=sftpowext(car(T),K,1);
6422: S+=red(C*X[0]^I*X[1]^K);
6423: }
6424: }
6425: return S;
6426: }
6427:
6428: def evalred(F)
6429: {
6430: Opt=getopt(opt);
6431: if(type(Opt)!=4){
6432: Opt=[];
6433: }else if(length(Opt)==2 && type(Opt[0])!=4) Opt=[Opt];
6434: for(;;){
1.17 takayama 6435: G=mysubst(F,[[tan(0),0],[asin(0),0],[atan(0),0],[sinh(0),0],[tanh(0),0],
6436: [log(1),0],[cosh(0),1],[exp(0),1]]);
1.6 takayama 6437: for(Rep=Opt; Rep!=[]; Rep=cdr(Rep))
6438: G=subst(G,car(Rep)[0],car(Rep)[1]);
6439: Var=vars(G);
6440: for(V=Var; V!=[]; V=cdr(V)){
1.17 takayama 6441: if(!(VV=args(CV=car(V)))) continue;
6442: if((functor(CV)==sin||functor(CV)==cos)){
6443: P=2*red(VV[0]/@pi);
6444: if(functor(CV)==sin) P=1-P;
6445: if(isint(P)){
6446: if(iand(P,1)) G=subst(G,CV,0);
6447: else if(!iand(P,3)) G=subst(G,CV,1);
6448: else G=subst(G,CV,-1);
6449: continue;
6450: }
6451: if(isint(P*=3/2)){
6452: if(iand(P,3)==1) G=subst(G,CV,1/2);
6453: else G=subst(G,CV,-1/2);
6454: }
6455: }
6456: for(;VV!=[];VV=cdr(VV))
6457: if(car(VV)!=(TV=evalred(car(VV)))) G=subst(G,car(VV),TV);
6458: if(functor(CV)!=pow || (args(CV)[0])!=1) continue;
6459: G=subst(G,CV,1);
1.6 takayama 6460: }
6461: if(G==F) return F;
6462: F=G;
6463: }
6464: }
6465:
6466: def seriesMc(F,N,V)
6467: {
6468: if(type(V)<4) V=[V];
6469: V=reverse(V);
6470: L=length(V);
6471: if(type(Opt=getopt(evalopt))!=4) Opt=[];
6472: P=newvect(L);
6473: G=newvect(L+1);
6474: G[0]=F;
6475: for(I=0;I<L;I++)
6476: G[I+1]=eval(evalred(subst(G[I],V[I],0)|opt=Opt));
6477: R=G[L];
6478: for(;;){
6479: for(M=0,I=0;I<L;I++){
6480: M+=P[I];
6481: if(M==N) break;
6482: }
6483: if(M<N){
6484: P[L-1]++;
6485: G[L-1]=mydiff(G[L-1],V[L-1]);
6486: G[L]=eval(evalred(mysubst(G[L-1],[V[L-1],0])|opt=Opt));
6487: }else{
6488: if(I--==0) break;
6489: P[I]++;
6490: G[I]=mydiff(G[I],V[I]);
6491: while(I++<L){
6492: G[I]=eval(evalred(mysubst(G[I-1],[V[I-1],0])|opt=Opt));
6493: if(I<L) P[I]=0;
6494: }
6495: }
6496: K=1;
6497: for(I=0;I<L;I++) K*=V[I]^P[I]/fac(P[I]);
6498: R+=G[L]*K;
6499: }
6500: return R;
6501: }
6502:
6503: def seriesTaylor(F,N,V)
6504: {
6505: G=F;
6506: if(isvar(V)) V=[V];
6507: if(length(V)==2 && type(car(V))!=4 && !isvar(V[1])) V=[V];
6508: for(V0=V1=[];V!=[];V=cdr(V)){
6509: if(type(T=car(V))!=4) T=[T];
6510: V0=cons(X=car(T),V0);
6511: if(length(T)==1 || T[1]==0){
6512: V1=cons(X,V1);continue;
6513: }
6514: S=my_tex_form(-T[1]);
6515: if(str_char(S,0,"-")!=0) S="+"+S;
6516: S="("+my_tex_form(X)+S+")";
6517: V1=cons([X,S],V1);
6518: F=red(subst(F,T[0],T[0]+T[1]));
6519: }
6520: V0=reverse(V0);V1=reverse(V1);
6521: F=seriesMc(F,N,V0|option_list=getopt());
6522: if(getopt(frac)==0) F=frac2n(F);
6523: T=getopt(dviout);
6524: if(type(T)!=1) T=0;
6525: F=fctrtos(F|var=V1,rev=1,TeX=(T==0||T==2)?2:3);
6526: if(getopt(small)==1) F=str_subst(F,"\\frac{","\\tfrac{");
6527: if(T<0 || T==1) F="\\begin{align}\\begin{split}\n"+
6528: my_tex_form(G)+"&="+F+"+\\cdots\n\\end{split}\\end{align}\n";
6529: if(T==1) dviout(F);
6530: else if(T==1) dviout(F|eq=4);
6531: return F;
6532: }
6533:
1.27 takayama 6534: def mulpolyMod(P,Q,X,N)
6535: {
6536: Red=(type(P)>2||type(Q)>2)?1:0;
6537: for(I=R=0;I<=N;I++){
6538: P0=mycoef(P,I,X);
6539: for(J=0;J<=N-I;J++){
6540: R+=P0*mycoef(Q,J,X)*X^(I+J);
6541: if(Red) R=red(R);
6542: }
6543: }
6544: return R;
6545: }
6546:
1.46 takayama 6547: def solveEq(L,V)
6548: {
6549: Inv=0;K=length(V);
6550: H=(getopt(h)==1)?1:0;
6551: if(getopt(inv)==1){
6552: if(K!=length(L)) return -5;
6553: Inv=1;
6554: VN=makenewv(vars(L)|num=K);
6555: for(TL=[],I=K-1;I>=0;I--) TL=cons(VN[I]-L[I],TL);
6556: S=solveEq(TL,V|h=H);
6557: if(type(S)!=4) return S;
6558: return mysubst(S,[VN,V]|lpair=1);
6559: }
6560: for(TL=[];L!=[];L=cdr(L)) TL=cons(nm(red(car(L))),TL);
6561: S=gr(TL,reverse(V),2);
6562: if(length(S)!=K) return -1;
6563: for(R=[],I=F=0;I<K;I++){
6564: TS=S[I];
6565: VI=lsort(vars(TS),V,2);
6566: if(length(VI)!=1) return -2;
6567: if((VI=car(VI))!=V[I]) return -3;
6568: if(mydeg(TS,VI)!=1){
6569: F=1;R=cons([VI,TS],R);
6570: }else R=cons(-red(mycoef(TS,0,VI)/mycoef(TS,1,VI)),R);
6571: }
6572: R=reverse(R);
6573: if(!F||H==1) return R;
6574: return -4;
6575: }
6576:
1.45 takayama 6577: /* Opt: f, var, ord, to, in, TeX */
6578: def baseODE(L)
6579: {
1.47 takayama 6580: SV=SVORG;
1.45 takayama 6581: if(type(TeX=getopt(TeX))!=1) TeX=0;
6582: if(type(F=getopt(f))!=1) F=0;
1.46 takayama 6583: if(isint(In=getopt(in))!=1) In=0;
1.45 takayama 6584: if(type(Ord=getopt(ord))!=1&&Ord!=0) Ord=2;
1.70 takayama 6585: Pages=getopt(pages);
6586: if(Pages!=1&&Pages!=2) Pages=0;
1.45 takayama 6587: if(Ord>3){
6588: Ord-=4; Hgr=1;
1.47 takayama 6589: }else Hgr=0;
1.70 takayama 6590: if(type(car(L0=L))==4&&type(L[1])==7){
1.45 takayama 6591: Tt=L[1];L=car(L);
6592: }
1.47 takayama 6593: M=N=length(L); SV=SVORG;
6594: if(type(Var=getopt(var))==4&&(In>0||length(Var)==N)){
1.45 takayama 6595: SV=Var;
6596: M=length(SV);
6597: if(type(car(SV))==2){
6598: for(R=[];SV!=[];SV=cdr(SV)) R=cons(rtostr(car(SV)),R);
6599: SV=reverse(R);
6600: }
1.47 takayama 6601: }else{
6602: if(N>10){
6603: R=[];
6604: for(K=M-1;K>9;K++) R=cons(SV[floor(K/10)-1]+SV[K%10],R);
6605: SV=append(SV,R);
6606: }
6607: for(Var=[],I=M-1;I>=0;I--) Var=cons(makev([SV[I]]),Var);
6608: }
6609: if(type(To=getopt(to))<2||type(To)>4) To=0;
1.70 takayama 6610: if(Ord<0){ /* cancell y1, z1,... by baseODE0() */
1.73 takayama 6611: if(Ord==-1) Ord=2;
6612: if(type(To)==4||!isvar(To)){
6613: L=L0=baseODE(L0|to=To,f=-3)[1];
6614: To=0;
6615: }
1.70 takayama 6616: R=baseODE0(L|option_list=
6617: delopt(getopt(),[["var",Var],["ord",Ord]]|inv=1));
6618: if(TeX){
6619: if(type(R)==4&&length(R)>1&&type(R[1])==4) R=R[1];
1.73 takayama 6620: if(type(To)==2 && !isvar(To)){
6621: S0=baseODE(L0|TeX=1,f=-1,to=To);
6622: V=baseODE0(L|step=-1,to=To);
6623: }else{
6624: S0=baseODE(L0|TeX=1,f=-1);
6625: V=baseODE0(L|step=-1,to=To);
6626: }
1.70 takayama 6627: T=eqs2tex(R,[V,2,Pages]);
6628: S=((F==1)?(Tt+"\n"):S0)+texbegin("align*",T);
6629: if(TeX==2) dviout(S);
6630: return S;
6631: }
6632: return R;
6633: }
6634: if(To&&!isvar(To)){
1.49 takayama 6635: if(type(To)!=4){
6636: To=red(To);
6637: for(K=0;K<length(Var);K++){
6638: I=mydeg(nm(To),Var[K]);J=mydeg(dn(To),Var[K]);
6639: if(I+J>0&&I<2&&J<2) break;
6640: }
6641: if(K==length(Var)) return -9;
6642: J=To;
6643: for(To=[],I=length(Var)-1;I>=0;I--)
6644: if(I!=K) To=cons(Var[I],To);
6645: To=cons(J,To);
6646: }
1.47 takayama 6647: if(type(To)==4){
6648: if(type(car(To))==4){
6649: R=1;To=car(To);
6650: }else R=0;
1.48 takayama 6651: if(type(IL=solveEq(To,Var|inv=1))!=4) return IL;
1.47 takayama 6652: if(R==1){
6653: R=To;To=IL;IL=R;
6654: }
6655: L=mulsubst(L,[Var,IL]|lpair=1);
6656: if(!In){ /* X_i'=\sum_j(\p_{x_j}X_i)*x_j' */
6657: for(TL=[],I=M-1;I>=0;I--){
6658: P=To[I];Q=mydiff(P,t);
6659: for(J=0;J<M;J++) Q=red(Q+mydiff(P,Var[J])*L[J]);
6660: TL=cons(Q,TL);
6661: }
6662: L=TL;
6663: }else{ /* x_i'=\sum_j(\p_{X_j}x_i)*X_j' */
6664: for(I=M-1;I>=0;I--){
6665: P=IL[I];Q=mydiff(P,t);
6666: for(J=0;J<M;J++){
6667: V=makev([SV[J],1]);
6668: Q=red(Q+mydiff(P,V)*V);
6669: }
6670: L=mysubst(L,[makev([SV[I],1]),TL[I]]);
6671: }
6672: for(TL=L,L=[],I=M-1;I>=0;I--) L=cons(num(TL[I]),L);
6673: }
6674: }
1.45 takayama 6675: }
1.73 takayama 6676: if(F==-3&&!TeX) return [Var,L];
1.48 takayama 6677: for(I=0;I<M;I++) L=subst(L,Var[I],makev([SV[I],0]));
1.45 takayama 6678: if(TeX){
6679: for(TL=L,I=0;I<M;I++)
1.47 takayama 6680: TL=subst(TL,makev([SV[I],0]),Var[I]);
1.45 takayama 6681: for(I=0;I<N;I++){
6682: if(I) S0+=",\\\\\n";
6683: if(In) S0+=" "+my_tex_form(TL[I])+"=0";
6684: else S0+=" "+SV[I]+"'\\!\\!\\! &= "+my_tex_form(TL[I]);
6685: }
6686: S0+=".\n";
6687: S0=texbegin("cases", S0);
6688: S0=texbegin("align",S0);
6689: if(type(Tt)==7) S0=Tt+"\n"+S0;
1.47 takayama 6690: if(F<0){
1.70 takayama 6691: if(TeX==2)dviout(S0);
1.45 takayama 6692: return S0;
6693: }
6694: }
1.47 takayama 6695: for(I=0,TL=[];L!=[];L=cdr(L),I++){
6696: T=car(L);
6697: if(!In) T=makev([SV[I],1])-T;
6698: TL=cons(nm(red(T)),TL);
1.45 takayama 6699: }
1.47 takayama 6700: if(isvar(To)){
1.48 takayama 6701: T=rtostr(To);
1.45 takayama 6702: IT=findin(T,SV);
6703: if(IT>=0 && IT<M){
6704: R=[SV[IT]];
6705: for(J=0;SV!=[];SV=cdr(SV),J++){
6706: if(J==IT) continue;
6707: R=cons(car(SV),R);
6708: }
6709: SV=reverse(R);
6710: }else{
6711: IT=0;
6712: mycat(["Cannot find variable", T, "!\n"]);
6713: }
6714: }
6715: for(S=1;S<M;S++){
6716: L=append(TL,L);
6717: TL=reverse(TL);
6718: for(RL=[];TL!=[];TL=cdr(TL)){
6719: if(In==0&&S==N-1&&length(TL)!=N-IT) continue;
1.47 takayama 6720: T=car(TL);R=mydiff(V,t);
1.45 takayama 6721: for(I=0;I<M;I++){
6722: for(J=0;J<=S;J++){
6723: V=makev([SV[I],J]|num=1);
1.47 takayama 6724: if((DR=mydiff(T,V))!=0) R+=DR*makev([SV[I],J+1]|num=1);
1.45 takayama 6725: }
6726: }
6727: RL=cons(R,RL);
6728: }
6729: TL=RL;
6730: }
6731: L=append(TL,L);
1.48 takayama 6732: for(I=0;I<M;I++) L=subst(L,makev([SV[I],0]),Var[I]);
1.70 takayama 6733: if(!isint(Vl=getopt(vl))) Vl=0;
6734: if(!Vl||Vl==1){
6735: V=[makev([SV[0]])];
6736: for(VV=[],J=1;J<=M;J++)
6737: V=cons(makev([SV[0],J]),V);
6738: for(I=1;I<M;I++)
6739: V=cons(makev([SV[I]]),V);
1.45 takayama 6740: if(F==-2){
6741: VV=cons(V,VV);
6742: V=[];
6743: }
1.70 takayama 6744: for(I=1;I<M;I++){
6745: for(J=1;J<M;J++) V=cons(makev((!Vl)?[SV[I],J]:[SV[J],I]),V);
6746: if(In) V=cons(makev([SV[0],M]),V);
6747: if(F==-2){
6748: VV=cons(V,VV);
6749: V=[];
6750: }
6751: }
6752: }else{
6753: for(V=VV=[],I=0;I<M;I++){
6754: for(J=0;J<M;J++) V=cons(J?makev([SV[I],J]):makev([SV[I]]),V);
6755: if(!I||In) V=cons(makev([SV[0],M]),V);
6756: if(F==-2){
6757: VV=cons(V,VV);
6758: V=[];
6759: }
6760: }
1.45 takayama 6761: }
6762: if(F>=0&&!chkfun("gr",0)){
6763: mycat("load(\"gr\"); /* <- do! */\n");
6764: F=-1;
6765: }
6766: if(F==-2) return [VV,L];
6767: if(F<0) return [V,L];
1.70 takayama 6768: LL=(Hgr==1)?hgr(L,V,Ord):gr(L,V,Ord);
1.45 takayama 6769: if(F==2) return [V,L,LL];
6770: if(Ord==2) P=LL[0];
6771: else{
6772: P=LL[length(LL)-1];
6773: for(RV=reverse(V), I=0;I<M+1;I++) RV=cdr(RV);
6774: if(lsort(vars(P),RV,2)!=[]){
6775: LL=tolex_tl(LL,V,Ord,V,2);P=LL[0];
6776: }
6777: }
6778: if(TeX){
1.70 takayama 6779: for(V0=[],I=1;I<=M;I++) V0=cons(makev([car(SV),I]),V0);
6780: T=eqs2tex(P,[V0,2,Pages]);
6781: if(!Vl||Vl==1){
6782: for(I=1,K=0;I<length(LL);I++){
6783: TV=makev([SV[I-K]]);
6784: if(findin(TV,vars(LL[I]))<0){
6785: K++;continue;
6786: }
6787: T+=eqs2tex(LL[I],[cons(TV,V0),2,Pages,1]);
6788: }
6789: }
6790: S=((F==1)?(Tt+"\n"):S0)+texbegin("align*",T);
1.45 takayama 6791: if(TeX==2) dviout(S);
6792: return S;
6793: }
6794: return (F==1)? P:[P,V,L,LL];
6795: }
6796:
1.70 takayama 6797:
6798: def eqs2tex(P,L)
6799: {
6800: if(isvar(L)) L=[0,L];
6801: if(type(L)!=4) L=[];
6802: Sgn=0;
6803: if(L!=[]){
1.71 takayama 6804: if(car(L)==0) L=[L];
6805: else if(length(L)>1 && isvar(L[1])) L=[L];
1.70 takayama 6806: R=car(L);L=cdr(L);Sgn=1;
6807: }else R=[];
6808: if(type(R)==4&&car(R)==0){
6809: Sgn=0;R=cdr(R);
6810: }
6811: if(L!=[]){
6812: Dic=car(L);L=cdr(L);
6813: }
6814: if(L!=[]){
6815: Pages=car(L);L=cdr(L);
6816: }
6817: if(L!=[]) Cont=car(L);
6818: if(type(P)==4){
6819: for(S="";P!=[];P=cdr(P)){
6820: S+=eqs2tex(car(P),[R,Dic,Pages,Cont]);
6821: if(!Cont) Cont=1;
6822: }
1.73 takayama 6823: /* S=str_subst(S,"\\\\&,\\\\",",\\\\&"); */
1.70 takayama 6824: if(getopt(dviout)==1) dviout(S|eq=6);
6825: return S;
6826: }
6827: if(type(R)==2) R=[R];
6828: if(Sgn){
6829: for(;R!=[];R=cdr(R))
6830: if((Deg=mydeg(P,car(R)))>0) break;
6831: if(Deg>0){
6832: CP=mycoef(P,Deg,car(R));
6833: if(cmpsimple(-CP,CP)<0) P=-P;
6834: }
6835: }
6836: S="&\\!\\!\\!";
6837: if(Cont)
6838: S=(Pages?",\\allowdisplaybreaks":",")+"\\\\\n"+S;
6839: S+=fctrtos(P|var=R,dic=Dic,TeX=3,pages=Pages);
6840: if(getopt(dviout)==1) dviout(S|eq=6);
6841: return S;
6842: }
6843:
1.71 takayama 6844: /* Opt: var, opt, dbg */
1.70 takayama 6845: def res0(P,Q,X)
6846: {
1.71 takayama 6847: if(!isvar(X)){
6848: if(!isvar(P)) return -1;
6849: Y=P;P=Q;Q=X;X=Y;
6850: }
6851: if(isvar(Var=getopt(var))) Var=[Var];
1.73 takayama 6852: else if(type(Var)!=4) Var=0;
6853: if(type(W=getopt(w))!=4) W=[];
6854: if(!isint(Opt=getopt(opt))&&type(Opt)!=4) Opt=0;
1.72 takayama 6855: if(type(Dbg=getopt(dbg))==4){
6856: Fct=Dbg[1];Dbg=Dbg[0];
6857: }
6858: if(!isint(Dbg)) Dbg=0;
1.70 takayama 6859: P=nm(P);Q=nm(Q);
1.71 takayama 6860: Fctr=isfctr(P)*isfctr(Q);
1.70 takayama 6861: DP=deg(P,X);DQ=deg(Q,X);
1.71 takayama 6862: if(DP==DQ&&nmono(coef(P,DP,X))<nmono(coef(Q,DQ,X))){
6863: R=P;P=Q;Q=R;
6864: R=DP;DP=DQ;DQ=R;
6865: }
1.70 takayama 6866: while(DQ>0){
6867: if(DP<DQ){
6868: R=P;P=Q;Q=R;
6869: R=DP;DP=DQ;DQ=R;
6870: if(Opt==-1) return [P,Q,DP,DQ];
6871: if(DQ<1) break;
6872: }
1.72 takayama 6873: if(Dbg){
6874: if(Dbg>=2) mycat([DP,"(",nmono(P), nmono(coef(P,DP,X)),") :",
6875: DQ, "(",nmono(Q),nmono(coef(Q,DQ,X)), ")"]);
6876: else mycat0([DP,":",DQ,","],0);
6877: }
1.70 takayama 6878: TQ=coef(Q,DQ,X);TP=coef(P,DP,X);
1.71 takayama 6879: if(Fctr){
6880: T=gcd(TP,TQ);M=red(TQ/T);
6881: if(Var&&M!=car(W)&&type(TV=vars(M))==4&&lsort(TV,Var,2)!=[]) W=cons(M,W);
6882: P=M*(P-coef(P,DP,X)*X^DP)-red(TP/T)*X^(DP-DQ)*(Q-coef(Q,DQ,X)*X^DQ);
6883: if(Var){
1.72 takayama 6884: #if 1
6885: if(Dbg>2) mycat0(">",0);
6886: for(S=SS=fctr(P),P=1,C=0;S!=[];S=cdr(S)){
1.71 takayama 6887: TV=vars(S0=car(S)[0]);
6888: if(type(TV)==4&&lsort(TV,Var,2)!=[]){
1.72 takayama 6889: for(TW=W;TW!=[];TW=cdr(TW)){
1.71 takayama 6890: if(gcd(car(TW),S0)!=1){
6891: S0=1;break;
6892: }
1.72 takayama 6893: }
6894: if(Dbg>1){
6895: if(S0==1) mycat(["Reduced by :",nmono(car(TW))]);
6896: else if(C++>0){
6897: mycat(["Product :", nmono(P), nmono(S0)]);
6898: if(Dbg==3){
6899: if(!Fct||Fct==[]){
1.73 takayama 6900: if(C>1) P=1;
1.72 takayama 6901: }else{
6902: if(car(Fct)==C){
6903: C=10000;Fct=cdr(Fct);P=1;
6904: }else S0=1;
6905: }
6906: }else if(Dbg==4) return [SS,Q,DP,DQ,W];
6907: }
6908: }
1.71 takayama 6909: P*=S0;
6910: }
6911: }
1.72 takayama 6912: #else
6913: for(TW=W;TW!=[];TW=cdr(TW)){
6914: if((C=gcd(P,car(TW)))!=1){
6915: P=red(P/C);
6916: if(Dbg>=2&&nmono(Q)>1) mycat(["Reduce :",nmono(C)]);
6917: }
6918: }
6919: #endif
1.70 takayama 6920: }
1.71 takayama 6921: }else{
6922: if(type(TQ)==1){
6923: Q/=TQ;
6924: P=P-TP*X^(DP-DQ)*Q;
6925: }else P=TQ*P-TP*X^(DP-DQ);
6926: if(deg(P,X)==DP) P-=coef(P,DP,X)*X^DP;
1.70 takayama 6927: }
6928: DP=deg(P,X);
1.73 takayama 6929: if(Opt==-2||(type(Opt)==4&&Opt[0]==DP&&Opt[1]==DQ)) return [P,Q,DP,DQ,W];
1.72 takayama 6930: }
6931: if(Dbg){
6932: if(Dbg>1) mycat([DP,"(",nmono(P), nmono(coef(P,DP,X)),") :",
6933: DQ, "(",nmono(Q), nmono(coef(Q,DQ,X)), ")"]);
6934: else mycat0([DP,":",DQ," "],0);
1.70 takayama 6935: }
1.73 takayama 6936: if(Opt==1) Q=[P,Q,DP,DQ,W];
1.70 takayama 6937: return (DQ==0)?Q:0;
6938: }
6939:
1.72 takayama 6940: /* Opt : f, var, ord, ord, step, f, to */
1.70 takayama 6941: def baseODE0(L)
6942: {
1.73 takayama 6943: if(!isint(Ord=getopt(ord))) Ord=-1;
6944: if(Ord==-1) Ord=2;
6945: if(Ord<O) Ord++;
1.70 takayama 6946: if(!isint(F=getopt(f))) F=0;
1.73 takayama 6947: if(!isint(Dbg=getopt(dbg))) Dbg=0;
6948: if(type(Step=getopt(step))==4) Dstep=Step;
6949: else Dstep=0;
6950: if(!isint(Step)) Step=0;
1.70 takayama 6951: if(F<0) Step=1;
6952: if(Step>0&&Ord>0) Ord=-1;
6953: N=length(L);
6954: if(type(To=getopt(to))==4&&length(To)==N){
6955: V=cdr(To);To=car(To);
6956: }
1.72 takayama 6957: if(!isvar(To)) To=V=0;
1.70 takayama 6958: if(type(SV=Var=getopt(var))!=4){
6959: SV=SVORG;
6960: if(N>10){
6961: R=[];
6962: for(K=N-1;K>9;K++) R=cons(SV[floor(K/10)-1]+SV[K%10],R);
6963: SV=append(SV,R);
6964: }
6965: for(Var=[],I=N-1;I>=0;I--) Var=cons(makev([SV[I]]),Var);
6966: }
6967: if((J=findin(To,Var))>0){
6968: TV=TL=[];
6969: for(I=N-1;I>=0;I--){
6970: if(I!=J){
6971: TV=cons(Var[I],TV);TL=cons(L[I],TL);
6972: }
6973: }
6974: Var=cons(Var[J],TV);L=cons(L[J],TL);
6975: }
6976: if(!To) To=car(SV);
6977: Q=car(L);
6978: V0=makev([To,1]);
6979: R=[V0-Q];V0=[V0];
6980: for(I=2;I<=N;I++){
6981: P=diff(t,Q);
6982: if(type(P)==3) P=red(P);
6983: for(TV=Var,TL=L;TV!=[];TV=cdr(TV),TL=cdr(TL)){
6984: P+=diff(Q,car(TV))*car(TL);
6985: if(type(P)==3) P=red(P);
6986: }
6987: Q=P;
6988: TV=makev([To,I]);
6989: R=cons(nm(TV-Q),R);
6990: V0=cons(TV,V0);
6991: }
6992: if(Step==-1) return V0;
6993: if(!V) V=cdr(Var);
6994: if(Ord<0){
6995: for(C=1,R0=[];V!=[];V=cdr(V),C++){
6996: TR=R=reverse(R);
6997: if(length(R)>1){ /* reduce common factor */
6998: P=car(TR);TR=cdr(TR);
1.72 takayama 6999: for(;TR!=[]&&P!=1;TR=cdr(TR))
1.70 takayama 7000: P=gcd(P,car(TR));
7001: if(P!=1){
7002: for(TR=[];R!=[];R=cdr(R)) TR=cons(red(car(R)/P),TR);
7003: R=reverse(TR);
7004: }
7005: }
7006: TR=[];
7007: TV=car(V);
7008: if(length(V)==1) V0=[car(V0)];
7009: if(C==Step) return [append(V,V0),R];
7010: while(R!=[]&&findin(TV,vars(car(R)))<0){
7011: TR=cons(car(R),TR);
7012: R=cdr(R);
7013: }
1.72 takayama 7014: R0=(F==2)?append(R,R0):cons(car(R),R0);
1.70 takayama 7015: if(R!=[]){
1.73 takayama 7016: for(W=[],P=car(R),R=cdr(R); R!=[]; R=cdr(R)){
1.72 takayama 7017: if(Dbg) mycat0(["\nStep ",C,"-",length(R)," ",TV,
7018: (type(Dbg)==4||Dbg>=2)?"\n":" "],0);
1.70 takayama 7019: if(findin(TV,vars(car(R)))<0){
7020: TR=cons(car(R),TR);
7021: continue;
7022: }
7023: if(Ord>-3){
1.73 takayama 7024: if(Dstep&&Dstep[0]==C&&Dstep[1]==length(R))
7025: return res0(P,car(R),TV|var=V0,opt=cdr(cdr(Dstep)),dbg=Dbg);
7026: else TQ=res0(P,car(R),TV|var=V0,opt=1,dbg=Dbg,w=W);
1.72 takayama 7027: if(Dbg==4&&type(car(TQ))==4) return TQ;
1.70 takayama 7028: if(Ord==-2) P=car(TQ);
1.73 takayama 7029: W=TQ[4];TQ=TQ[1];
1.72 takayama 7030: }else{
7031: TQ=res(TV,P,car(R));
7032: Q=fctr(TQ); /* irreducible one */
7033: for(TQ=1;Q!=[];Q=cdr(Q))
7034: if(lsort(V0,vars(car(Q)[0]),2)!=[]) TQ*=car(Q)[0];
7035: }
1.70 takayama 7036: TR=cons(TQ,TR);
7037: }
7038: }
7039: R=TR;
7040: }
1.71 takayama 7041: if(Dbg==1) mycat([]);
1.72 takayama 7042: return (F==1)?car(R):(F==2?append(R,R0):cons(car(R),R0));
1.70 takayama 7043: }
7044: V=append(V,[makev([To,N])]);
7045: if(Step==1) return [R,V];
7046: R=gr(R,V,Ord);
7047: return (F==1)?car(R):R; /* hgr(R,V,Ord); */
7048: }
7049:
7050:
1.26 takayama 7051: def taylorODE(D){
7052: Dif=(getopt(dif)==1)?1:0;
7053: if(D==0) return Dif?f:f_00;
1.27 takayama 7054: if(type(T=getopt(runge))!=1||ntype(T)!=0) T=0;
1.26 takayama 7055: if(type(F=getopt(f))!=7&&type(F)<2) F="f_";
7056: if(type(D)!=1||ntype(D)!=0||D<0||D>30) return 0;
7057: if(type(H=getopt(taylor))==4&&length(H)==2){
1.27 takayama 7058: if(type(Lim=getopt(lim))==2) DD=D;
7059: else if(type(Lim)==4){
7060: DD=Lim[1];Lim=Lim[0];
7061: }else Lim=0;
7062: for(R=I=0;I<=D;I++){
7063: if(I){
7064: if(Lim) H0=mulpolyMod(H0,H[0],Lim,DD);
7065: else H0*=H[0];
7066: }else H0=1;
7067: if(type(F)!=7) G=I?mydiff(G,x):F;
7068: for(J=0;J<=D-I;J++){
7069: if(J){
7070: if(Lim) H1=mulpolyMod(H1,H[1],Lim,DD);
7071: else H1*=H[1];
7072: }else H1=H0;
7073: if(type(F)==7) G=makev([F,I,J]);
7074: else if(J) G=mydiff(G,y);
7075: R+=G*H1/fac(I)/fac(J);
1.26 takayama 7076: }
7077: }
1.27 takayama 7078: if(Lim) R=os_md.polcut(R,DD,Lim);
7079: return R;
1.26 takayama 7080: }else{
7081: if(type(H=getopt(series))>=0||getopt(list)==1){
7082: if(type(F)!=7){
7083: for(PP=[F],I=1;I<D;I++)
7084: PP=cons(mydiff(car(PP),x)+mydiff(car(PP),y)*F,PP);
7085: if(type(H)<0) return PP;
7086: for(R=0,DD=D;DD>=1;DD--,PP=cdr(PP)) R+=car(PP)*H^DD/fac(DD);
7087: return red(R);
7088: }
7089: if(type(H)>=0) D--;
7090: PP=taylorODE(D-1|list=1);
7091: if(type(PP)!=4) PP=[PP];
7092: P=car(PP);
7093: }else P=taylorODE(D-1);
7094: for(R=I=0;I<D;I++){
7095: for(J=0;J<D-I;J++){
7096: Q=diff(P,makev([F,I,J]));
7097: if(Q!=0) R+=Q*(f_00*makev([F,I,J+1])+makev([F,I+1,J]));
7098: }
7099: }
7100: if(getopt(list)==1){
7101: R=cons(R,PP);
7102: if(Dif!=1) return R;
7103: }else if(type(H)>=0){
7104: R=y+R*H^(D+1)/fac(D+1);
7105: for(DD=D;DD>0;PP=cdr(PP),DD--) R+=car(PP)*H^(DD)/fac(DD);
7106: if(T){
1.35 takayama 7107: if(T<0){
7108: Dif=0;TT=-T;
7109: }else TT=T;
1.26 takayama 7110: K=newvect(TT);K[0]=Dif?f:f_00;
1.35 takayama 7111: if(getopt(c1)==1) K[0]=taylorODE(D|taylor=[c_1*H,0]);
1.26 takayama 7112: for(I=1;I<TT;I++){
7113: for(S=J=0;J<I;J++) S+=makev(["a_",I+1,J+1])*K[J];
1.35 takayama 7114: K[I]=taylorODE(D|taylor=[makev(["c_",I+1])*H,S*H],lim=[H,D]);
1.26 takayama 7115: }
7116: for(S=I=0;I<TT;I++) S+=makev(["b_",I+1])*K[I];
7117: S=S*H+y;
7118: R=S-R;
7119: if(T<0){
7120: for(V=[H],I=0;I<=D;I++)
7121: for(J=0;J<=D-I;J++) V=cons(makev([F,I,J]),V);
7122: return os_md.ptol(R,reverse(V)|opt=0);
7123: }
7124: }else T=0;
7125: }
7126: }
7127: if(Dif){
7128: for(I=0;I<=D;I++){
7129: for(J=0;J<=D;J++){
7130: if(I==0&&J==0){
7131: R=subst(R,f_00,f);
7132: continue;
7133: }
7134: V=makev([F,str_times("x",I),str_times("y",J)]);
7135: R=subst(R,makev([F,I,J]),V);
7136: }
7137: }
7138: }
7139: return R;
7140: }
7141:
1.6 takayama 7142: def toeul(F,L,V)
7143: {
7144: L = vweyl(L);
7145: X = L[0]; DX = L[1];
7146: I = mydeg(F,DX);
1.56 takayama 7147: if(getopt(raw)!=1){
1.6 takayama 7148: for(II=I; II>=0; II--){
1.56 takayama 7149: J = mydeg(P=mycoef(F,II,DX),X);
1.6 takayama 7150: if(II==I) S=II-J;
7151: else if(P!=0 && II-J>S) S=II-J;
7152: }
7153: F *= X^S;
1.56 takayama 7154: }
7155: if(V == "infty"){
7156: for(R=0; I >= 0; I--)
1.6 takayama 7157: R += red((mysubst(mycoef(F,I,DX),[X,1/X])*(x*DX)^I));
7158: return(subst(pol2sft(R,DX),DX,-DX));
7159: }
1.56 takayama 7160: for(R=0; I >= 0; I--)
1.6 takayama 7161: R += (red(mycoef(F,I,DX)/X^I))*DX^I;
7162: return pol2sft(R,DX);
7163: }
7164:
7165: /*
7166: def topoldif(P,F,L)
7167: {
7168: L = vweyl(L);
7169: P = nm(red(P));
7170: while(deg(P,L[1]) > 0){
7171: R = coef(P,0,L[0]);
7172: Q = red((P-R)/(F*L[0]);
7173: P = nm(Q)*zz+F*R*dn(Q);
7174: }
7175: }
7176: */
7177:
7178: def fromeul(P,L,V)
7179: {
7180: if(P == 0)
7181: return 0;
7182: L = vweyl(L);
7183: X = L[0]; DX = L[1];
7184: I = mydeg(P,DX);
7185: if(V == "infty"){
7186: P = subst(P,DX,-DX);
7187: J = mydeg(P,X);
7188: P = red(mysubst(P,[X,1/X])*X^J);
7189: }
7190: R = mycoef(P,0,DX);
7191: S = 1;
7192: for(S = J = 1; J <= I; J++){
7193: S = DX*(S*X + mydiff(S,DX));
7194: R += mycoef(P,J,DX)*S;
7195: }
1.56 takayama 7196: if(getopt(raw)!=1){
7197: while(mycoef(R,0,X) == 0)
7198: R = tdiv(R,X);
7199: }
1.6 takayama 7200: if(V != "infty" && V != 0)
7201: R = mysubst(R,[X,X-V]);
7202: return R;
7203: }
7204:
7205: def sftexp(P,L,V,N)
7206: {
7207: L = vweyl(L); DX = L[1];
1.56 takayama 7208: P = mysubst(toeul(P,L,V|opt_list=getpt()),[DX,DX+N]);
1.70 takayama 7209: return fromeul(P,L,V|option_list=getopt());
1.6 takayama 7210: }
7211:
7212:
7213: def fractrans(P,L,N0,N1,N2)
7214: {
7215: L = vweyl(L);
7216: if(N2 != "infty"){
7217: if(N0 == "infty")
7218: N0 = 0;
7219: else
7220: N0 = red(1/(N0-N2));
7221: if(N1 == "infty")
7222: N1 = 0;
7223: else
7224: N1 = red(1/(N1-N2));
7225: P = mysubst(P,[L[0],L[0]+N2]);
7226: P = fromeul(toeul(P,L,"infty"),L,0);
7227: }
7228: if(N0 != 0){
7229: P = mysubst(P,[L[0],L[0]+N0]);
7230: N1 -= N0;
7231: }
7232: if(N1 != 1)
7233: P = mysubst(P,[[L[0],L[0]/N1],[L[1],L[1]*N1]]);
7234: return P;
7235: }
7236:
7237: def soldif(P,L,V,Q,N)
7238: {
7239: L = vweyl(L); X = L[0]; DX = L[1];
7240: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
7241: DEG = mydeg(P,X);
7242: P0 = newvect(DEG+1);
7243: for(I = 0; I <= DEG; I++)
7244: P0[I] = coef(P,I,X);
7245: if(P0[0] == 0)
7246: return 0;
7247: if(subst(P0[0],DX,0) != 0){
7248: mycat([Q,"is not the exponent at", V])$
7249: return 0;
7250: }
7251: R = newvect(N+1);
7252: R[0] = 1;
7253: for(I = 1; I <= N; I++){
7254: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7255: S += mysubst(P0[K],[DX,I-K])*R[I-K];
7256: S = red(S);
7257: M = mysubst(P0[0],[DX,I]);
7258: if(M != 0){
7259: R[I] = -red(S/M);
7260: if(R1 != 0){
7261: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7262: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
7263: mysubst(P1[K],[DX,I-K])*R[I-K];
7264: R1[I] = -red(S/M);
7265: }
7266: }else{
7267: if(S == 0){
7268: if(R1 != 0){
7269: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7270: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
7271: mysubst(P1[K],[DX,I-K])*R[I-K];
7272: }
7273: if(S == 0)
7274: continue;
7275: }
7276: R1 = newvect(N+1);
7277: for(K = 0; K < I; K++){
7278: R1[K] = R[K];
7279: R[K] = 0;
7280: }
7281: R1[I] = 0;
7282: P1 = newvect(DEG);
7283: for(K = 0; K <= DEG; K++)
7284: P1[K] = mydiff(P0[K], DX);
7285: M = mysubst(P1[0],[DX,I]);
7286: if(M == 0){
7287: cat(["multiple log at ", I])$
7288: return 0;
7289: }
7290: R[I] = -red(S/M);
7291: }
7292: }
7293: if(R1 != 0)
7294: return [R1, R];
7295: else
7296: return R;
7297: }
7298:
7299: def chkexp(P,L,V,Q,N)
7300: {
7301: L = vweyl(L); X = L[0]; DX = L[1];
7302: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
7303: P = fromeul(P,L,0);
7304: D = mydeg(P,DX);
7305: Z = mindeg(mycoef(P,D,DX), X) - (D-N);
7306: R = [];
7307: for(I = 0; I < Z; I++){
7308: S = mycoef(P,I,X);
7309: if(S != 0){
7310: for(J = mydeg(S,DX); J >= 0; J--){
7311: T = mycoef(S,J,DX);
7312: if(T != 0)
7313: R = cons(T,R);
7314: }
7315: }
7316: }
7317: return R;
7318: }
7319:
7320:
7321: def sqrtrat(P)
7322: {
7323: if(P==0) return 0;
7324: if(type(P)==3||type(P)==2){
7325: P=red(P);
7326: if(imag(dn(P))!=0||imag(nm(P))!=0){
7327: if(imag(dn(P))==0&&real(P)!=0){
7328: F=red(imag(P)/real(P));
7329: if(F==3^(1/2)||F==-3^(1/2)){
7330: if(eval(real(P))<0)
7331: return -real(P)+imag(P)*@i;
7332: else{
7333: if(eval(imag(P))>0) return imag(P)+real(P)*@i;
7334: else return -imag(P)-real(P)*@i;
7335: }
7336: }
7337: }
7338: return [];
7339: }
7340: F=fctr(dn(P));
7341: R=sqrtrat(car(F)[0]);
7342: for(F=cdr(F);F!=[];F=cdr(F)){
7343: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
7344: else return [];
7345: }
7346: F=fctr(nm(P));
7347: R=sqrtrat(car(F)[0])/R;
7348: for(F=cdr(F);F!=[];F=cdr(F)){
7349: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
7350: else return [];
7351: }
7352: return R;
7353: }
7354: if(ntype(P)==4){
7355: P0=real(P);P1=imag(P)/2;
7356: X=makenewv(P);
7357: for(R=fctr(X^4-P0*X^2-P1^2);R!=[];R=cdr(R)){
7358: RT=car(R)[0];
7359: if(deg(RT,X)==1){
7360: X=-mycoef(RT,0,X)/mycoef(RT,1,X);
7361: return X+P1/X*@i;
7362: }
7363: if(deg(RT,X)==2){
7364: if((D=mycoef(RT,1,X)^2-4*mycoef(RT,2,X)*mycoef(RT,0,X))<0) continue;
7365: X=(-mycoef(RT,1,X)+sqrtrat(D))/(2*mycoef(RT,2,X));
7366: return X+P1*sqrt2rat(1/X)*@i;
7367: }
7368: }
7369: D=P0^2+4*P1^2;
7370: if(P1>0) return ((sqrtrat(D)+P0)/2)^(1/2)+((sqrtrat(D)-P0)/2)^(1/2)*@i;
7371: return ((sqrtrat(D)+P0)/2)^(1/2)-((sqrtrat(D)-P0)/2)^(1/2)*@i;
7372: }else if(ntype(P)!=0) return [];
7373: if(P==1) return P;
7374: Dn=dn(P);Nm=nm(P);C=R=1;
7375: N=pari(factor,Dn);
7376: if(N){
7377: for(II=car(size(N))-1;II>=0;II--){
7378: if(iand(K=N[II][1],1)){
7379: R*=N[II][0];
7380: K++;
7381: }
7382: C/=N[II][0]^(K/2);
7383: }
7384: }
7385: N=pari(factor,Nm);
7386: if(N){
7387: for(II=car(size(N))-1;II>=0;II--){
7388: if(N[II][0]==-1){
7389: C*=@i;
7390: continue;
7391: }
7392: K=N[II][1];
7393: if(iand(K,1)){
7394: R*=N[II][0];
7395: K--;
7396: }
7397: if(K!=0) C*=N[II][0]^(K/2);
7398: }
7399: }
7400: if(R!=1) C*=R^(1/2);
7401: return C;
7402: }
7403:
7404: def fctri(F)
7405: {
7406: R=(iscoef(F,os_md.israt))?fctr(F):[[1,1],[F,1]];
7407: if(!iscoef(F,os_md.iscrat)||chkfun("af_noalg",0)==0) return R;
7408: X=makenewv(vars(F));
7409: for(S=[];R!=[];R=cdr(R)){
7410: if(length(Var=vars(R0=car(R)[0])) == 1 && (D=mydeg(R0,Var=car(Var))) > 0){
7411: if(imag(T=mycoef(R0,D,Var))!=0) R0/=T;
7412: T=af_noalg(real(R0)+imag(R0)*X,[[X,X^2+1]]);
7413: if(length(T)>1||T[0][1]>1){
7414: T=subst(T,X,@i);
7415: for(; T!=[];T=cdr(T)){
7416: if(vars(T[0])!=[])
7417: S=cons([car(T)[0],car(T)[1]*car(R)[1]],S);
7418: }
7419: continue;
7420: }
7421: }
7422: S=cons(R[0],S);
7423: }
7424: return reverse(S);
7425: }
7426:
7427: def getroot(F,X)
7428: {
7429: S=[];
7430: if(type(Cpx=getopt(cpx))!=1) Cpx=0;
7431: M=getopt(mult);
7432: if(type(F) == 3)
7433: F = nm(red(F));
7434: for(R=fctri(F); length(R)>0; R = cdr(R)){
7435: T=car(R);
7436: P=car(T);
7437: I=car(cdr(T));
7438: if(mydeg(P,X)>0){
7439: if(mydeg(P,X)==1){
7440: C = mycoef(P,1,X);
7441: P = X - red(P/C);
7442: }else if(mydeg(P,X)==2 && Cpx>0){
7443: C2=mycoef(P,2,X);C1=mycoef(P,1,X);C0=mycoef(P,0,X);
7444: C=sqrt2rat(C1^2-4*C0*C2);
7445: C0=[];
7446: if(type(C)==0&&ntype(C)==0&&pari(issquare,-C)) C0=sqrt(C);
7447: else if(Cpx>1) C0=sqrtrat(C);
7448: if(C0==[]&&Cpx>2) C0=C^(1/2);
7449: if(C0!=[]){
7450: if(M==1)
7451: S=cons([I,sqrt2rat((-C1+C0)/(2*C2))],S);
7452: else{
7453: for(II=I; II>0; II--)
7454: S=cons(sqrt2rat((-C1+C0)/(2*C2)),S);
7455: }
7456: P=sqrt2rat((-C1-C0)/(2*C2));
7457: }
7458: }else if(mydeg(P,X)==3 && Cpx>1){
7459: Omg=(-1+3^(1/2)*@i)/2;
7460: PP=P/mycoef(P,3,X);
7461: C2=mycoef(PP,2,X)/3;
7462: PP=subst(PP,X,X-C2);
7463: if((C1=mycoef(PP,1,X))==0){
7464: C0=mycoef(PP,0,X);
7465: if(real(C0)==0||imag(C0)==0){
7466: if(real(C0)==0){
7467: PP=getroot(X^3+imag(C0),X);
7468: if(length(PP)==3){
7469: for(;PP!=[];PP=cdr(PP)){
7470: if(imag(PP[0])==0){
7471: C0=PP[0]*@i;
7472: break;
7473: }
7474: }
7475: if(PP==[]) C0=0;
7476: }
7477: }else{
7478: if(C0>0) C0=C0^(1/3);
7479: else C0=-(-C0)^(1/3);
7480: }
7481: if(C0!=0){
7482: if(M==1){
7483: S=cons([I,C0-C2],S);
7484: S=cons([I,C0*Omg-C2],S);
7485: S=cons([I,C0*(-1-Omg)-C2],S);
7486: }else{
7487: for(II=I; II>0; II--){
7488: S=cons(C0-C2,S);
7489: S=cons(C0*Omg-C2,S);
7490: S=cons(C0*(-1-Omg)-C2,S);
7491: }
7492: }
7493: continue;
7494: }
7495: }
7496: }
7497: if(Cpx>2){
7498: Q=X^2+(mycoef(PP,1,X)/3)*X+mycoef(PP,0,X)^3;
7499: SQ=getroot(Q,X|cpx=2);
7500: SQ=SQ[0]^(1/3);SQ2=mycoef(PP,0,X)/SQ;
7501: if(M==1){
7502: S=cons([I,SQ+SQ2-C2],S);
7503: S=cons([I,SQ*Omg+SQ2*(-1-Omg)-C2],S);
7504: S=cons([I,SQ*(-1-Omg)+SQ2*Omg-C2],S);
7505: }else{
7506: for(II=I; II>0; II--){
7507: S=cons(SQ+SQ2-C2,S);
7508: S=cons(SQ*Omg+SQ2*(-1-Omg)-C2,S);
7509: S=cons(SQ*(-1-Omg)+SQ2*Omg-C2,S);
7510: }
7511: }
7512: continue;
7513: }
7514: }else if(mydeg(P,X)==4 && Cpx>0){
7515: C2=mycoef(P,3,X)/(4*mycoef(P,4,X));
7516: PP=subst(P,X,X-C2);
7517: if(mycoef(PP,1,X)==0){
7518: PP=mycoef(PP,4,X)*X^2+mycoef(PP,2,X)*X+(SQ2=mycoef(PP,0,X));
7519: SQ=getroot(PP,X|cpx=2);
7520: if(length(SQ)==2){
7521: if((C0=sqrtrat(SQ[0]))==[]){
7522: if(mycoef(PP,1,X)==0){
7523: if(SQ2<0) C0=(-SQ2)^(1/4);
7524: else C0=SQ2^(1/4)*(1+@i)/2;
7525: }
7526: else if(Cpx>2) C0=SQ[0]^(1/2);
7527: else C0=0;
7528: }
7529: if((C1=sqrtrat(SQ[1]))==[]){
7530: if(mycoef(PP,1,X)==0) C1=-C0;
7531: else C1=SQ[1]^(1/2);
7532: }
7533: if(C0!=0){
7534: if(M==1)
7535: S=append([[I,C0-C2],[I,-C0-C2],[I,C1-C2],[I,-C1-C2]],S);
7536: else{
7537: for(II=I; II>0; II--)
7538: S=append([C0-C2,-C0-C2,C1-C2,-C1-C2],S);
7539: }
7540: continue;
7541: }
7542: }
7543: }else{
7544: PP/=mycoef(PP,4,X);
7545: CC=mycoef(PP,2,X);C1=mycoef(PP,1,X);C0=mycoef(PP,0,X);
7546: SQ=getroot(X*(CC+X)^2-4*C0*X-C1^2,X|cpx=Cpx);
7547: if(length(SQ)>1){
7548: SQ=sqrt2rat(SQ[0]);
7549: SQ2=getroot(X^2-SQ,X|cpx=Cpx);
7550: if(length(SQ2)>1){
7551: C1=SQ2[0]*X-C1/SQ2[0]/2;
7552: C0=getroot(X^2+CC/2+SQ/2+C1,X|cpx=Cpx);
7553: C1=getroot(X^2+CC/2+SQ/2-C1,X|cpx=Cpx);
7554: if(length(C0)>1&&length(C1)>1){
7555: C0=[sqrt2rat(C0[0]-C2),sqrt2rat(C0[1]-C2),
7556: sqrt2rat(C1[0]-C2),sqrt2rat(C1[1]-C2)];
7557: if(M==1) for(II=0;II<4;II++) S=cons([I,C0[II]],S);
7558: else for(II=I; II>0; II--) S=append(C0,S);
7559: continue;
7560: }
7561: }
7562: }
7563: }
7564: }
7565: if(M==1)
7566: S=cons([I,P],S);
7567: else for( ; I>0; I--) S=cons(P,S);
7568: }
7569: }
7570: S=qsort(S);
7571: if(M==1) S=reverse(S);
7572: return S;
7573: }
7574:
7575: def expat(F,L,V)
7576: {
7577: L = vweyl(L);
7578: if(V == "?"){
7579: Ans = [];
7580:
7581: F = nm(red(F));
7582: S = fromeul(toeul(F,L,"infty"),L,0);
7583: S = mycoef(S,mydeg(S,L[1]),L[1]);
7584: if(mydeg(S,L[0]) > 0)
7585: Ans = cons(["infty", expat(F,L,"infty")],Ans);
7586:
7587: S = mycoef(F,mydeg(F,L[1]), L[1]);
7588: R = getroot(S,L[0]);
7589: for(I = 0; I < length(R); I++){
7590: if(I > 0 && R[I-1] == R[I])
7591: continue;
7592: if(mydeg(R[I], L[0]) <= 0)
7593: Ans = cons([R[I], expat(F,L,R[I])], Ans);
7594: else
7595: Ans = cons([R[I]], Ans);
7596: }
7597: return Ans;
7598: }
7599: return getroot(subst(toeul(F,L,V),L[0],0),L[1]);
7600: }
7601:
7602: def polbyroot(P,X)
7603: {
1.49 takayama 7604: if(isvar(V=getopt(var))&&length(P)>1&&isint(car(P))){
7605: for(Q=[],I=car(P);I<=P[1];I++) Q=cons(makev([V,I]),Q);
7606: P=Q;
7607: }
1.6 takayama 7608: R = 1;
7609: while(length(P)){
7610: R *= X-car(P);
7611: if(type(R)>2) R = red(R);
7612: P = cdr(P);
7613: }
7614: return R;
7615: }
7616:
7617: def polbyvalue(P,X)
7618: {
7619: R = 1; S = 0;
7620: while(length(P)){
7621: T = car(P);
7622: V0 = T[1] - mysubst(S,[X,T[0]]);
7623: if(V0 != 0){
7624: if(type(R) > 2) R = red(R);
7625: V1 = mysubst(R,[X,T[0]]);
7626: if(V1 == 0){
7627: erno(0);
7628: return 0;
7629: }
7630: S += (V0/V1)*R;
7631: if(type(S) > 2) S = red(S);
7632: }
7633: R *= X - T[0];
7634: P = cdr(P);
7635: }
7636: return S;
7637: }
7638:
7639:
7640: def pcoef(P,L,Q)
7641: {
7642: if(L==0)
7643: return 1;
7644: Coef=TP=0;
7645: if(type(Q)>=4){
7646: TP=1;
7647: V=Q[0];
7648: if(type(V)==4)
7649: V=ltov(V);
7650: else V=dupmat(V);
7651: N=length(V);
7652: if(type(Q[1])==5) MR=dupmat(Q[1]);
7653: else{
7654: MR=newvect(N);
7655: for(K=Q[1], I=0; I< N; I++){
7656: MR[I] = car(K);
7657: K = cdr(K);
7658: }
7659: }
7660: }else{
7661: V=ltov(vars(P));
7662: N=length(V);
7663: MR=newvect(N);
7664: for(I=0;I<N;I++){
7665: MR[I]=mydeg(Q,V[I]);
7666: Q=mycoef(Q,MR[I],V[I]);
7667: }
7668: if(type(Q)>1) return 0;
7669: }
7670: if(L==1){
7671: for(I=0;I<N;I++)
7672: P=mycoef(P,MR[I],V[I]);
7673: return P;
7674: }
7675: for(I=1;I<N;I++){ /* sorted by required degrees */
7676: for(K1=MR[I],K2=V[I],J=I-1; J>=0 && MR[J]<K1; J--);
7677: for(II=I-1;II>J;II--){
7678: MR[II+1]=MR[II];V[II+1]=V[II];
7679: }
7680: MR[II+1]=K1;V[II+1]=K2;
7681: }
7682: for(NN=N; N>0 && MR[N-1]==0; N--);
7683: Mon=[];Coe=[];Q=P;
7684: while(Q!=0){
7685: M=newvect(N);
7686: for(R=Q,F=I=0,MT=1;I<NN;I++){
7687: K=mydeg(R,V[I]);
7688: R=mycoef(R,K,V[I]);
7689: if(I<N) M[I]=K;
7690: if(K>0) MT*=V[I]^K;
7691: if(K>MR[I]) F=1;
7692: }
7693: Q -= R*MT;
7694: if(F==0){
7695: Mon=cons(M,Mon);
7696: Coe=cons(R,Coe);
7697: }
7698: }
7699: Mon=ltov(reverse(Mon));
7700: Coe=ltov(reverse(Coe));
7701: Len=length(Mon);
7702: S=newvect(Len);
7703: for(JL=0; JL<Len;JL++){
7704: if(L*Mon[JL][0]<MR[0]) break;
7705: }
7706: S[0]=L;
7707:
7708: K0=Mon[0][0];
7709: K=L*K0-MR[0];
7710: for(I=II=0;II<Len && K>=0;II++){
7711: if((K1=K0-Mon[0][II])>0){
7712: while(K>K1 && S[I]>0){
7713: S[I]--;S[II]++;
7714: K-=K1;
7715: I=II;
7716: K0=Mon[0][II];
7717: }
7718: }else break;
7719: }
7720:
7721: I=0;
7722: while(1){
7723: for(T=T0=J=JP=0; J<Len; J++){
7724: if(S[J]!=0){
7725: if(T0==0 && J>=JL) return Coef;
7726: JP=J;T0=1;
7727: T+=S[J]*Mon[J][I];
7728: }
7729: }
7730: if(T==MR[I]){
7731: if(++I<N) continue;
7732: for(TT=1,J=1; J<=L; J++) /* find a solution */
7733: TT*=J;
7734: for(J=0;J<Len;J++){
7735: if(S[J]!=0){
7736: TT*=Coe[J]^S[J];
7737: for(II=S[J]; II>1; II--)
7738: TT/=II;
7739: }
7740: }
7741: Coef+=TT;
7742: if(TP==1 && type(Coef)==3) Coef=red(Coef);
7743: if(JP<Len-2 && S[JP]>1){
7744: S[JP]-=2;S[JP+1]++;S[JP+2]++;
7745: }else{
7746: for(JT=JP-1;JT>=0&&S[JT]==0;JT--);
7747: if(JT<0) break;
7748: if(JT==JP-1){
7749: S[JT]--;
7750: if(JP<Len-1)
7751: S[JP+1]++;
7752: else
7753: S[JP]++;
7754: }else{
7755: S[JT]--;
7756: S[JT+1]+=S[JP]+1;
7757: S[JP]=0;
7758: }
7759: }
7760: I=0;
7761: continue;
7762: }
7763: if(JP<Len-1){
7764: for(JP1=JP+1;JP1<Len-1;JP1++){
7765: if(Mon[JP1][I]!=Mon[JP][I]) break;
7766: }
7767:
7768: if(I>0 && Mon[JP1][0] < Mon[JP][0]){
7769: S[JP]--;S[Len-1]++;JP=JP-1;
7770: }else{
7771:
7772: S[JP]--;
7773: if(JP1<Len){
7774: S[JP1]++;
7775: }else{
7776: S[JP1-1]++;
7777: }
7778: }
7779: }
7780: if(JP==Len-1){
7781: for(JT=JP-1;JT>=0 && S[JT]==0;JT--);
7782: if(JT<0) break;
7783: S[JT]--;
7784: if(JT==JP-1){
7785: S[JP]++;
7786: }else{
7787: S[JT+1]+=S[JP]+1;
7788: S[JP]=0;
7789: }
7790: }
7791: I=0;
7792: }
7793: return Coef;
7794: }
7795:
1.58 takayama 7796: def pmaj(P)
7797: {
7798: if(type(P)==4){
1.68 takayama 7799: Opt=getopt(var);
7800: Opt=(isvar(Opt))?[["var",Opt]]:[];
7801: for(Q=[];P!=[];P=cdr(P)) Q=cons(pmaj(car(P)|option_list=Opt),Q);
7802: if(Opt==[]) return reverse(Q);
1.58 takayama 7803: X=Opt[0][1];
1.68 takayama 7804: D=mydeg(Q,X);
7805: for(S=0;D>=0;D--) S+=lmax(mycoef(Q,D,X))*X^D;
1.58 takayama 7806: return S;
7807: }
7808: V=vars(P);
1.71 takayama 7809: Y=getopt(var);
7810: Abs=(Y==1)?1:0;
7811: if(!(K=length(V))) return Y==1?1:abs(P);
1.58 takayama 7812: for(R=0,D=deg(P,X=V[0]);D>=0;D--){
7813: Q=coef(P,D,X);
1.71 takayama 7814: if(Q!=0) R+=((type(Q)>1)?pmaj(Q|var=Abs):(Y==1?1:abs(Q)))*X^D;
1.58 takayama 7815: }
1.71 takayama 7816: if(isvar(Y)) for(;V!=[];V=cdr(V)) R=subst(R,car(V),Y);
1.58 takayama 7817: return R;
7818: }
7819:
1.6 takayama 7820: def prehombf(P,Q)
7821: {
7822: if((Mem=getopt(mem))!=1 && Mem!=-1)
7823: return prehombfold(P,Q);
7824: if(Q==0) Q=P;
7825: V=ltov(vars(P));
7826: N=length(V);
7827: for(I=1;I<N;I++){ /* sorted by required degrees */
7828: for(K=mydeg(P,V[I]),K1=V[I],J=I-1; J>=0 && mydeg(P,V[J])<K; J--);
7829: for(II=I-1;II>J;II--) V[II+1]=V[II];
7830: V[II+1]=K1;
7831: }
7832: S=newvect(N);T=newvect(N);U=newvect(N);
7833: for(R=P,M=1,Deg=I=0;I<N;I++){ /* extreme vector */
7834: Deg+=(S[I]=mydeg(R,V[I]));
7835: R=mycoef(R,S[I],V[I]);
7836: }
7837: DR=[[-1,0]];
7838: if((R1=N/Deg)!=1){
7839: DR=cons([-R1,0],DR);
7840: Sft=1;
7841: }else Sft=0;
7842: if(Deg%2==0) Sg=1;
7843: else Sg=-1;
7844: for(I=0,R=R2=1,QQ=Q; 2*I+Sft < Deg; I++){
7845: if(Mem==-1){
7846: print(I+1,0);print("/",0);print(idiv(Deg-Sft+1,2),0);print(" ",2);
7847: }
7848: Coef=0;
7849: Q=QQ;
7850: while(Q!=0){
7851: for(R=Q,J=0,RR=1;J<N;J++){
7852: T[J]=mydeg(R,V[J]);
7853: R=mycoef(R,T[J],V[J]);
7854: if(T[J]>0) RR*=V[J]^T[J];
7855: }
7856: Q-=R*RR;
7857: for(J=0,CC=R;J<N;J++){
7858: U[J]=I*S[J]+T[J];
7859: for(II=0; II<T[J]; II++)
7860: CC*=(U[J]-II);
7861: }
7862: CC*=pcoef(P,I+1,[V,U]);
7863: if(Mem==-1) print("*",2);
7864: Coef+=CC;
7865: }
7866: DR=cons([I,Coef],DR);
7867: DR=cons([-R1-1-I,Sg*Coef],DR);
7868: if(Mem==-1) print("");
7869: }
7870: P = polbyvalue(DR,s);
7871: return fctr(P);
7872: }
7873:
7874: def prehombfold(P,Q)
7875: {
7876: V = vars(P);
7877: if(Q==0) Q=P;
7878: for(Deg=0, R=P, V1=V, DD=[]; V1!=[]; V1=cdr(V1)){
7879: VT = car(V1);
7880: D = mydeg(R,VT);
7881: R = mycoef(R,D,VT);
7882: Deg += D;
7883: X = makev(["d",VT]);
7884: Q = subst(Q,VT,X);
7885: DD=cons([VT,X],DD);
7886: }
7887: DR=[[-1,0]];
7888: NV=length(V);
7889: if((R1=NV/Deg)!=1){
7890: DR=cons([-R1,0],DR);
7891: Sft=1;
7892: }else
7893: Sft=0;
7894: if(Deg%2==0)
7895: Sg=1;
7896: else Sg=-1;
7897: for(I = 0, R=R2=1; 2*I+Sft < Deg; I++){
7898: R = R2;
7899: R2 = R*P;
7900: S = appldo(Q,R2,DD);
7901: QQ = sdiv(S,R);
7902: DR=cons([I,QQ],DR);
7903: DR=cons([-R1-1-I,Sg*QQ],DR);
7904: }
7905: P = polbyvalue(DR,s);
7906: return fctr(P);
7907: }
7908:
7909: def sub3e(P0,P1,P2,N0,N1,N)
7910: {
7911: R = x^N0*(x-1)^N1*dx^N;
7912: for(V = I = 1, J = 1; I <= N; I++){
7913: S = 0;
7914: M = N-I;
7915: if(I <= N0){
7916: T = mycoef(P0,N0-I,x);
7917: S += T;
7918: R += T*x^(N0-I)*(x-1)^N1*dx^M;
7919: K1 = N0-I+1;
7920: }else
7921: K1 = 0;
7922: if(I <= N1){
7923: T = mycoef(P1,N1-I,x);
7924: S += T;
7925: R += T*x^N0*(x-1)^(N1-I)*dx^M;
7926: K2 = N0-1;
7927: }else
7928: K2 = N-I;
7929: for(K = K1; K <= K2; K++){
7930: if(K == K2){
7931: R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(M-K)*dx^M;
7932: continue;
7933: }
7934: R += strtov("r"+rtostr(V))*x^K*(x-1)^(M-K)*dx^M;
7935: S += strtov("r"+rtostr(V++));
7936: }
7937: }
7938: if(V > 1)
7939: mycat([V-1, "accessory parameters: r1,r2,..."]);
7940: return R;
7941: }
7942:
7943: def fuchs3e(P,Q,R)
7944: {
7945: return getbygrs([R,P,Q],3);
7946: }
7947:
7948: def okubo3e(P,Q,R)
7949: {
7950: if(getopt(opt)==1){
7951: N=length(R);
7952: M1=N-length(P);M2=N-length(Q);
7953: V=(M1-1)*(M2-1);
7954: if(V>0) mycat([V, "accessory parameters"]);
7955: return getbygrs([R,cons([M1,0],P),cons([M2,0],Q)],3);
7956: }
7957: S = 0;
7958: V = -1;
7959: L = newvect(3,[[],[],[]]);
7960: N = newvect(3,[0,0,0]);
7961: if(type(R) < 4){
7962: I = -1;
7963: V = 3;
7964: }else{
7965: I = 2;
7966: V = -1;
7967: }
7968: for( ; I >= 0; I--){
7969: if(I == 2)
7970: U = R;
7971: else if(I == 1)
7972: U = Q;
7973: else
7974: U = P;
7975: for( ; length(U); U = cdr(U)){
7976: T = car(U);
7977: if( T == "?"){
7978: if(V < 0)
7979: V = I;
7980: else
7981: return 0;
7982: }else{
7983: if(I == 2)
7984: L[I] = cons(-T, L[I]);
7985: else
7986: L[I] = cons(T, L[I]);
7987: S += T;
7988: }
7989: N[I]++;
7990: }
7991: }
7992: if(V == 3){
7993: N[2] = N[0] + N[1];
7994: P2 = x^N;
7995: for(I = 1; I <= N; I++)
7996: P2 += makev([R,I])*x^(N-I);
7997: }else{
7998: if(N[0]+N[1] != N[2]){
7999: print("Number of exponents are wrong",0);
8000: return -1;
8001: }
8002: S -= N[0]*N[1];
8003: if(V < 0){
8004: if(S != 0){
8005: mycat(["Viorate Fuchs relation ->",S]);
8006: return -2;
8007: }
8008: }else{
8009: if(V != 2)
8010: S = -S;
8011: L[V] = cons(S, L[V]);
8012: }
8013: P2 = polinsft(polbyroot(L[2],x),x);
8014: }
8015: P0 = polinsft(mysubst(polbyroot(L[0],x),[x,x+N[1]]),x);
8016: P1 = polinsft(mysubst(polbyroot(L[1],x),[x,x+N[0]]),x);
8017: return sub3e(P0,P1,P2,N[0],N[1],N[2]);
8018: }
8019:
8020: /* N = 2*M (N-M = M) or 2*M+1 (N-M = M+1)
8021: 0 : 0 1 ..... M-1 B B+1 ... B+N-M-2 A
8022: 1 : C C+1 ... C+M-1 0 1 .... N-M-2 N-M-1
8023: */
8024: def eosub(A,B,C,N)
8025: {
8026: M = N%2;
8027: P = [];
8028: Q = [];
8029: P = cons(A,P);
8030: for(I = 0; I < N-M-1; I++)
8031: P = cons(B+I,P);
8032: for(I = 0; I < M; I++)
8033: Q = cons(C+I,Q);
8034: P = okubo3e(P,Q,s);
8035:
8036: C = newvect(2);
8037: L = newvect(2);
8038: C[1] = chkexp(P,[x,dx],0,b,N-M-1);
8039: C[0] = chkexp(P,[x,dx],1,c,M);
8040: for(LL = K = 0; K < 2; K++){
8041: L[K] = length(C[K]);
8042: C[K] = ltov(C[K]);
8043: if(L[K] > LL)
8044: LL = L[K];
8045: }
8046: JJ = 0;
8047:
8048: for(I = 1; Do; I++){
8049: Do = 0;
8050: S = makev(["r",I]);
8051: for(J = JJ; J < LL; J++){
8052: JJ = LL;
8053: for(K = 0; K < 2; K++){
8054: if(J >= L[K] || C[K][J] == 0)
8055: continue;
8056: if(J < JJ)
8057: JJ = J;
8058: if(Do == 1){
8059: CC = C[K];
8060: CC[J] = mysubst(CC[J], [S, Var]);
8061: continue;
8062: }
8063: if(mydeg(C[K][J]) >= 1){
8064: if(mydeg(C[K][J]) > 1){
8065: print("Internal error");
8066: return;
8067: }
8068: Var = getroot(C[K][J],S);
8069: Var = Var[0];
8070: CC = C[K];
8071: CC[J] = 0;
8072: P = mysubst(P, [S, Var]);
8073: Do = 1;
8074: J = JJ - 1;
8075: K++;
8076: }
8077: }
8078: }
8079: }
8080: if(JJ != L){
8081: print("Internal error (non Rigid)");
8082: return;
8083: }
8084: return P;
8085: }
8086:
8087: def even4e(X,Y){
8088: if(length(X) != 4 || length(Y) != 2){
8089: print("Usage: even4e([a,b,c,d],[e,f])");
8090: print("0: 0 1 e f");
8091: print("1; 0 1 * *+1");
8092: print("infty: a b c d");
8093: return;
8094: }
8095: S = -3;
8096: for(I = 0; I < 4; I++){
8097: S += X[I];
8098: if(I < 2)
8099: S += Y[I];
8100: }
8101: S = -S/2;
8102: P = okubo3e(Y,[S,"?"],X);
8103: T = chkexp(P,x,1,S,2);
8104: T = getroot(T[0],r1);
8105: return mysubst(P,[r1,T[0]]);
8106: }
8107:
8108: def odd5e(X,Y)
8109: {
8110: if(length(X) != 5 || length(Y) != 2){
8111: print("Usage: spec6e([a,b,c,d,e],[f,g])");
8112: print("0: 0 1 f g g+1");
8113: print("1: 0 1 2 * *+1");
8114: print("infty: a b c d e");
8115: return;
8116: }
8117: S = -4;
8118: for(I = 0; I < 5; I++){
8119: S += X[I];
8120: if(I < 2)
8121: S += Y[I];
8122: }
8123: S = -(S + Y[1])/2;
8124: P = okubo3e([Y[0],Y[1],Y[1]+1],[S,"?"],X);
8125: T = chkexp(P,x,1,S,2);
8126: T = getroot(T[0],r1);
8127: P = mysubst(P,[r1,T[0]]);
8128: T = chkexp(P,x,0,Y[1],2);
8129: T = getroot(T[0],r2);
8130: return mysubst(P,[r2,T[0]]);
8131: }
8132:
8133: def extra6e(X,Y)
8134: {
8135: if(length(X) != 6 || length(Y) != 2){
8136: print("Usage: extra6e([a,b,c,d,e,f],[g,h])");
8137: print("0: 0 1 g g+1 h h+1");
8138: print("1: 0 1 2 3 * *+1");
8139: print("infty: a b c d e f");
8140: return;
8141: }
8142: S = -5;
8143: for(I = 0; I < 6; I++){
8144: S += X[I];
8145: if(I < 2)
8146: S += 2*Y[I];
8147: }
8148: S = -S/2;
8149: P = okubo3e([Y[0],Y[0]+1,Y[1],Y[1]+1],[S,"?"],X);
8150: T = chkexp(P,x,1,S,2);
8151: T = getroot(T[0],r1);
8152: P = mysubst(P,[r1,T[0]]);
8153: T = chkexp(P,x,0,Y[0],2);
8154: T = getroot(T[0],r3);
8155: P = mysubst(P,[r3,T[0]]);
8156: T = chkexp(P,x,0,Y[1],2);
8157: T = getroot(T[0],r2);
8158: return mysubst(P,[r2,T[0]]);
8159: }
8160:
8161: def rigid211(X,Y,Z)
8162: {
8163: if(length(X) != 2 || length(Y) != 2 || length(Z) != 2){
8164: print("Usage: rigid211([a,b],[c,d],[e,f])");
8165: print("0: 0 1 a b");
8166: print("1: 0 1 c d");
8167: print("infty: e e+1 f *");
8168: return;
8169: }
8170: P = okubo3e(X,Y,[Z[0],Z[0]+1,Z[1],"?"]);
8171: T = chkexp(P,x,"infty",Z[0],2);
8172: T = getroot(T[0],r1);
8173: return mysubst(P,[r1,T[0]]);
8174: }
8175:
8176: def solpokuboe(P,L,N)
8177: {
8178: if(type(N) > 1 || ntype(N) != 0 || dn(N) != 1){
8179: mycat(["Irrigal argument :", N]);
8180: return 0;
8181: }
8182: L = vweyl(L);
8183: DD=N+1;
8184: for(U = S = L[0]^N; U != 0; ){
8185: D = mydeg(U,L[0]);
8186: if(D>=DD){
8187: mycat(["Internal Error",D,DD]);
8188: return -1;
8189: }
8190: DD=D;
8191: UU = L[0]^D;
8192: R = appldo(P,UU,L);
8193: if(mydeg(R,L[0]) > D){
8194: printf("Bad operator\n");
8195: return 0;
8196: }
8197: CC = mycoef(R,D,L[0]);
8198: if(D == N){
8199: P -= (E = CC);
8200: U = R-E*U;
8201: continue;
8202: }
8203: if(CC == 0){
8204: printf("No polynomial\n");
8205: return 0;
8206: }
8207: CC= mycoef(U,D,L[0])/CC;
8208: S = red(S - UU*CC);
8209: U = red(U - R*CC);
8210: }
8211: return [nm(S),E];
8212: }
8213:
8214: def stoe(M,L,N)
8215: {
8216: L = vweyl(L);
8217: Size = size(M);
8218: S = Size[0];
8219: NN = 0;
8220: if(type(N) == 4){
8221: NN=N[0]; N=N[1];
8222: }else if(N < 0){
8223: NN=-N; N=0;
8224: }
8225: if(S != Size[1] || N >= S || NN >= S)
8226: return;
8227: D = newmat(S+1,S+1);
8228: MN = dupmat(M);
8229: MD = newmat(S,S);
8230: DD = D[0];
8231: DD[N] = 1; DD[S] = 1;
8232: for(Lcm = I = 1; ; ){
8233: DD = D[I];
8234: MM = MN[N];
8235: for(J = 0; J < S; J++){
8236: DD[J] = MM[J];
8237: Lcm = lcm(dn(DD[J]),Lcm);
8238: }
8239: DD[S] = L[1]^I;
8240: for(J = 0; J <= S; J++)
8241: DD[J] = red(DD[J]*Lcm);
8242: if(I++ >= S)
8243: break;
8244: if(I==S && NN>0){
8245: DD = D[I];
8246: DD[0]=-z_zz; DD[NN]=1;
8247: break;
8248: }
8249: Mm = dupmat(MN*M);
8250: for(J = 0; J < S; J++){
8251: for(K = 0; K < S; K++)
8252: MN[J][K] = red(diff(MN[J][K],L[0])+Mm[J][K]);
8253: }
8254: }
8255: #if 0
8256: P = fctr(mydet2(D));
8257: #else
8258: P = fctr(det(D));
8259: #endif
8260: for(I = R = 1; I < length(P); I++){
8261: if(mydeg(P[I][0],L[1]) > 0)
8262: R *= P[I][0]^P[I][1];
8263: }
8264: if(NN > 0)
8265: R = -red(coef(R,0,z_zz)/coef(R,1,z_zz));
8266: return R;
8267: }
8268:
8269: def dform(L,X)
8270: {
8271: if(type(X)==2) X=[X];
8272: if(type(L[0])!=4) L=[L];
8273: if(type(X)==4) X=ltov(X);
8274: M=length(X);
8275: if(length(car(L))==2){
8276: R=newvect(M);
8277: for(LL=L; LL!=[]; LL=cdr(LL)){
8278: for(I=0; I<M; I++){
8279: RT=rmul(car(LL)[0],mydiff(car(LL)[1],X[I]));
8280: R[I] = (R[I]==0)?RT:radd(R[I],RT);
8281: }
8282: }
8283: Dif=getopt(dif);
8284: for(RR=[], I=M-1; I>=0; I--){
8285: if(Dif==1) RR=cons([1,R[I],X[I]],RR);
8286: else RR=cons([R[I],X[I]],RR);
8287: }
8288: if(Dif==1) RR=dform(RR,X);
8289: return RR;
8290: }else if(length(car(L))!=3) return L;
8291: N=M*(M-1)/2;
8292: R=newvect(N);
8293: S=newvect(N);
8294: for(LL=L; LL!=[]; LL=cdr(LL)){
8295: for(I=K=0; I<M; I++){
8296: for(J=I+1; J<M; J++, K++){
8297: if(LL==L) S[K]=[X[I],X[J]];
8298: LT=car(LL);
8299: R1=mydiff(LT[2],X[J]);
8300: R2=mydiff(-LT[2],X[I]);
8301: if(R2==0){
8302: if(R1==0) continue;
8303: R1=rmul(mydiff(LT[1],X[I]),R1);
8304: }else if(R1==0){
8305: R1=rmul(mydiff(LT[1],X[J]),R2);
8306: }else
8307: R1=rmul(mydiff(LT[1],X[I]),R1)+rmul(mydiff(LT[1],X[J]),R2);
8308: R1=rmul(LT[0],R1);
8309: R[K] = (R[K]==0)?R1:radd(R[K],R1);
8310: }
8311: }
8312: }
8313: for(RR=[],I=N-1; I>=0; I--)
8314: RR=cons([R[I],S[I][0],S[I][1]],RR);
8315: return RR;
8316: }
8317:
8318: def polinvsym(P,Q,Sym)
8319: {
8320: N = length(Q);
8321: T = polbyroot(Q,zz);
8322: for(I = 1; I <= N; I++){
8323: P = mysubst(P,[makev([Sym,I]), (-1)^I*coef(T,N-I,zz)]);
8324: }
8325: return P;
8326: }
8327:
8328: def polinsym(P,Q,Sym)
8329: {
8330: if(type(P) == 3){
8331: P = red(P);
8332: if(type(P) == 3){
8333: D = polinsym(dn(P),Q,Sym);
8334: if(D == 0)
8335: return 0;
8336: return polinsym(nm(P),Q,Sym)/D;
8337: }
8338: }
8339: N = length(Q);
8340: V = newvect(N+1);
8341: S = newvect(N+1);
8342: E = newvect(N+1);
8343: E0 = newvect(N+1);
8344: T = polbyroot(Q,zzz);
8345: for(J = 1; J <= N; J++){
8346: K = coef(T,N-J,zzz);
8347: if(J % 2)
8348: K = -K;
8349: S[J] = K;
8350: V[J] = makev([Sym,J]);
8351: }
8352: K = deg(P,Q[0]);
8353: for(J = 0; J <= N; J++)
8354: E0[J] = K+1;
8355: E[0] = K+1;
8356: while(deg(P,Q[0]) > 0){
8357: for(P0 = P, J = 1; J <= N; J++){
8358: E[J] = deg(P0,Q[J-1]);
8359: P0 = coef(P0,E[J],Q[J-1]);
8360: }
8361: /* P0*Q[0]^E[1]*Q[1]^E[2]*... E[1] >= E[2} >= ... */
8362: for(J = 1; J <= N; J++){
8363: if(E[J] < E0[J])
8364: break;
8365: if(E[J-1] < E[J])
8366: J = N;
8367: }
8368: if(J > N){
8369: print("Not symmetric");
8370: return 0;
8371: }
8372: for(J = 1; J <= N; J++)
8373: E0[J] = E[J];
8374: for(J = N; J > 1; J--){
8375: if(E[J] != 0)
8376: for(K = 1; K < J; K++)
8377: E[K] -= E[J];
8378: }
8379: for(R0 = P0, K = 1; K <= N; K++){
8380: if(E[K] > 0)
8381: P0 *= S[K]^E[K];
8382: R0 *= V[K]^E[K];
8383: }
8384: P += R0 - P0;
8385: }
8386: return P;
8387: }
8388:
8389: def tohomog(P,L,V)
8390: {
8391: while(length(L)>0){
8392: P = mysubst(P,[car(L),car(L)/V]);
8393: L = cdr(L);
8394: }
8395: P = red(P);
8396: N = mindeg(dn(P),V);
8397: if(N > 0)
8398: P = red(P*V^N);
8399: N = mindeg(dn(P),V);
8400: if(N > 0)
8401: P = red(P/(V^N));
8402: return P;
8403: }
8404:
8405: def substblock(P,X,Q,Y)
8406: {
8407: P = red(P);
8408: if(deg(dn(P),X) > 0)
8409: return substblock(nm(P),X,Q,Y)/substblock(dn(P),X,Q,Y);
8410: N = mydeg(Q,X);
8411: if(N < 1)
8412: return P;
8413: R = mycoef(Q,N,X);
8414: while(M = mydeg(P,X), M >= N)
8415: P = red(P - mycoef(P,M,X)*(Q-Y)*X^(M-N)/R);
8416: return P;
8417: }
8418:
8419: def okuboetos(P,L)
8420: {
8421: L = vweyl(L); X = L[0]; DX = L[1];
8422: N = mydeg(P,DX);
8423: C = mycoef(P,N,DX);
8424: K = mydeg(C,X);
8425: if(K > N){
8426: print("Irregular singularity at infinity")$
8427: return 0;
8428: }
8429: if(N > K)
8430: P *= x^(N-K);
8431:
8432: L = getroot(mycoef(P,N,DX),x);
8433: L = ltov(reverse(L));
8434: if(length(L) != N || N == 0){
8435: print("Cannot get exponents")$
8436: return 0;
8437: }
8438: if( type(LL = getopt(diag)) == 4 ){
8439: LL = ltov(LL);
8440: if(length(LL) != N){
8441: mycat(["Length of the option should be", N]);
8442: return 0;
8443: }
8444: Tmp = newvect(N);
8445: for(I = N-1; I >= 0; I--){
8446: for(LLT = LL[I], J = N-1; J >=0 ; J--){
8447: if(LLT == L[J] && Tmp[J] == 0){
8448: Tmp[J] = 1;
8449: break;
8450: }
8451: }
8452: if(J < 0){
8453: print("option is wrong");
8454: return 0;
8455: }
8456: }
8457: L = LL;
8458: }
8459: P /= mycoef(C,N,X);
8460: A = newmat(N,N);
8461: AT = newmat(N+1,N+1);
8462: Phi= newvect(N+1);
8463: Phi[0] = 1;
8464: for(J = 0; J < N; J++)
8465: Phi[J+1] = Phi[J]*(X-L[J]);
8466: for(ATT = AT[N], J = 0; J < N; J++)
8467: ATT[J] = mycoef(P,J,DX);
8468:
8469: for(K = 1; K <= N; K++){
8470: for(J = N; J >= K; J--){
8471: Aj = A[J-1];
8472: SIG = AT[J][J-K];
8473: for(I = 0; I <= K-2; I++)
8474: SIG += Aj[J-I-1]*AT[J-I-1][J-K];
8475: if(K == 1)
8476: DAT = mydiff(Phi[J-1],X);
8477: else
8478: DAT = mydiff(AT[J-1][J-K],X);
8479: Aj[J-K] = -SIG+(X-L[J-1])*DAT;
8480: Aj[J-K] /= Phi[J-K];
8481: Aj[J-K] = mysubst(Aj[J-K],[X,L[J-1]]);
8482: if(J < K+1) continue;
8483: ATj = AT[J-1];
8484: ATj[J-K-1] = SIG+Aj[J-K]*Phi[J-K];
8485: ATj[J-K-1] /= (X - L[J-1]);
8486: ATj[J-K-1] = red(ATj[J-K-1]-DAT);
8487: }
8488: }
8489:
8490: ATT = newmat(N,N);
8491: for(J = 0; J < N; J++){
8492: for(K = 0; K < N; K++){
8493: ATj = ATT[J];
8494: ATj[K] = AT[J][K];
8495: }
8496: ATj[J] = Phi[J];
8497: if(J < N-1){
8498: ATj = A[J];
8499: ATj[J+1] = 1;
8500: }
8501: }
8502: return [L,A,ATT];
8503: }
8504:
8505: def heun(X,P,R)
8506: {
8507: if(type(X) != 4 || length(X) != 5){
8508: print("Usage: huen([a,b,c,d,e],p,r)");
8509: print("0: 0 c");
8510: print("1: 0 d");
8511: print("p: 0 e");
8512: print("infty: a b");
8513: print("Fuchs relation: a+b+1 = c+d+e");
8514: return;
8515: }
8516: S = 1;
8517: V = -1;
8518: X = ltov(X);
8519: for(I = 0; I < 5; I++){
8520: if(X[I] == "?"){
8521: if(V >= 0)
8522: return;
8523: V = I;
8524: }else if(I < 2){
8525: S += X[I];
8526: }else
8527: S -= X[I];
8528: }
8529: if(V >= 0){
8530: if(V < 2)
8531: X[V] = -S;
8532: else
8533: X[V] = S;
8534: }else if(S != 0){
8535: mycat(["Fuch relation:", S,"should be zero!"]);
8536: return;
8537: }
8538: return
8539: x*(x-1)*(x-P)*dx^2
8540: + (X[2]*(x-1)*(x-P)+X[3]*x*(x-P)+X[4]*x*(x-1))*dx
8541: + X[0]*X[1]*(x-R);
8542: }
8543:
8544: def fspt(M,T)
8545: {
8546: if(type(M)==7) M=s2sp(M);
8547: if(T == 3) /* 3: cut 0 */
8548: return cutgrs(M);
8549: if(T == 4 || T== 5){ /* 4: short 5: long */
8550: for(MN = [] ; M != []; M = cdr(M)){
8551: MT = car(M);
8552: for(MNT = []; MT != []; MT = cdr(MT)){
8553: if(type(car(MT)) <= 3){
8554: if(T == 4) MNT = cons(car(MT),MNT);
8555: else MNT = cons([1,car(MT)],MNT);
8556: }else{
8557: if(T == 5 || car(MT)[0] > 1) MNT = cons(car(MT),MNT);
8558: else if(car(MT)[0] == 1) MNT = cons(car(MT)[1],MNT);
8559: }
8560: }
8561: MN = cons(reverse(MNT), MN);
8562: }
8563: return reverse(MN);
8564: }
8565: if(type(M[0][0]) == 4){
8566: for(MN = [] ; M != []; M = cdr(M)){
8567: MT = car(M);
8568: for(MNT = []; MT != []; MT = cdr(MT))
8569: MNT = cons(car(MT)[0], MNT);
8570: MN = cons(reverse(MNT), MN);
8571: }
8572: return fspt(reverse(MN),T);
8573: }
8574: if(T == 0) /* 0: sp */
8575: return M;
8576: for(MN = [] ; M != []; M = cdr(M)){
8577: MT = qsort(ltov(car(M)));
8578: L = length(MT);
8579: for(MNT = [], I = 0; I < L; I++)
8580: MNT = cons(MT[I], MNT);
8581: MN = cons(MNT, MN);
8582: }
8583: MN = reverse(MN);
8584: if(T==6) return MN; /* 7: sort */
8585: L = length(MN);
8586: for(M = MN; M != []; M = cdr(M)){
8587: for(I = 0, MT = car(M); MT != []; MT = cdr(MT))
8588: I += car(MT);
8589: if(OD == 0)
8590: OD = I;
8591: else if(OD != I || OD == 0)
8592: return 0;
8593: }
8594: ALL = [MN];
8595: RD=[];
8596: while(OD > 0){
8597: for(S = 0, MT = MN; MT != []; MT = cdr(MT))
8598: S += car(MT)[0];
8599: S -= (L-2)*OD;
8600: if(S <= 0){
8601: if(T==7) return [ALL[0],ALL[length(ALL)-1],RD];
8602: return (T==1)?MN:ALL;
8603: }
8604: RD=cons([S,0,0],RD);
8605: for(NP=0, M = [], MT = MN; MT != []; NP++, MT = cdr(MT)){
8606: MTT = car(MT);
8607: I = MTT[0] - S;
8608: if(I < 0){
8609: if(I+OD!=0) return 0;
8610: if(T==7) return [ALL[0],ALL[length(ALL)-1],cdr(RD)];
8611: return (T==1)?MN:ALL;
8612: }
8613: MTT = cdr(MTT);
8614: NC=1; DO=0;
8615: for(MNT = []; MTT != []; MTT = cdr(MTT)){
8616: if(MTT[0] > I){
8617: if(DO==0) RD=cons([MTT[0]-I,NP,NC++],RD);
8618: MNT = cons(MTT[0], MNT);
8619: }
8620: else if(MTT[0] <= I && I != 0){
8621: DO=1;
8622: MNT = cons(I, MNT);
8623: I = 0;
8624: if(MTT[0] > 0)
8625: MNT = cons(MTT[0], MNT);
8626: }
8627: }
8628: if(I > 0)
8629: MNT = cons(I,MNT);
8630: M = cons(reverse(MNT), M);
8631: }
8632: MN = reverse(M);
8633: ALL = cons(MN,ALL);
8634: OD -= S;
8635: }
8636: }
8637:
8638: def abs(X)
8639: {
8640: if(vars(X)!=[]) return todf(os_md.abs,[X]);
8641: if(type(X)==4){
8642: P=X[1];X=X[0];
8643: }else P=0;
8644: if(type(X)==1){
8645: if((T=ntype(X))<2 || T==3){
8646: if(X<0) X=-X;
8647: }else if(T==4) X=P?pari(abs,X,P):pari(abs,X);
8648: }
8649: return X;
8650: }
8651:
1.20 takayama 8652: def sgn(X)
8653: {
8654: if(X==0) return 0;
8655: if(type(X)==1){
8656: return (X>0)?1:-1;
8657: }
8658: if(type(X)==5) X=vtol(X);
8659: if(type(X)==4){
8660: for(W=0,Y=X;Y!=[];Y=cdr(Y))
8661: for(Z=cdr(Y);Z!=[];Z=cdr(Z))
8662: if(car(Y)>car(Z)) W++;
8663: if(getopt(val)==1) return W;
8664: return (iand(W,1))?-1:1;
8665: }
8666: }
8667:
1.6 takayama 8668: def calc(X,L)
8669: {
1.10 takayama 8670: if(type(X)<4||type(X)==7){
8671: if(type(L)==4||type(L)==7){
1.6 takayama 8672: V=L[1];
1.10 takayama 8673: if(type(X)!=7){
8674: if((L0=L[0])=="+") X+=V;
8675: else if(L0=="-") X-=V;
8676: else if(L0=="*") X*=V;
8677: else if(L0=="/") X/=V;
8678: else if(L0=="^") X^=V;
8679: }
8680: if((L0=L[0])==">") X=(X>V);
8681: else if(L0=="<") X=(X<V);
8682: else if(L0=="=") X=(X==V);
1.6 takayama 8683: else if(L0==">=") X=(X>=V);
8684: else if(L0=="<=") X=(X<=V);
8685: else if(L0=="!=") X=(X!=V);
1.10 takayama 8686: }else if(type(L)==7&&type(X)<4){
1.6 takayama 8687: if(L=="neg") X=-X;
8688: else if(L=="abs") X=abs(X);
8689: else if(L=="neg") X=-X;
8690: else if(L=="sqr") X*=X;
8691: else if(L=="inv") X=1/X;
8692: else if(L=="sgn"){
8693: if(X>0)X=1;
8694: else if(X<0) X=-1;
8695: }
8696: }
8697: }
8698: return X;
8699: }
8700:
1.23 takayama 8701: def tobig(X)
8702: {
8703: if((type(X)==1 && ntype(X)==3)||type(X)>3) return X;
8704: return eval(X*exp(0));
8705: }
8706:
1.6 takayama 8707: def isint(X)
8708: {
8709: if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1;
8710: return 0;
8711: }
8712:
8713: def israt(X)
8714: {
8715: if(X==0||(type(X)==1 && ntype(X)==0)) return 1;
8716: return 0;
8717: }
8718:
8719: def iscrat(X)
8720: {
8721: if(X==0 || (type(X)==1 && israt(real(X)) && israt(imag(X)))) return 1;
8722: return 0;
8723: }
8724:
8725: def isalpha(X)
8726: {
8727: return ((X>64&&X<91)||(X>96&&X<123))?1:0;
8728: }
8729:
8730: def isnum(X)
8731: {
8732: return (X>47&&X<58)?1:0;
8733: }
8734:
8735: def isalphanum(X)
8736: {
8737: return (isalpha(X)||isnum(X))?1:0;
8738: }
8739:
1.8 takayama 8740: def isdecimal(X)
8741: {
8742: if(type(X)!=7) return 0;
8743: F=S=0;
8744: L=strtoascii(X);
8745: while(L!=[]&&car(L)==32) L=cdr(L);
8746: if(L!=[]&&car(L)==45) L=cdr(L); /* - */
8747: while(L!=[]&&isnum(car(L))){
8748: F=1; L=cdr(L);
8749: }
8750: while(L!=[]&&car(L)<33){
8751: S=1;L=cdr(L);
8752: }
8753: if(L==[]) return F;
8754: else if(S||car(L)!=46) return 0; /* . */
8755: L=cdr(L);F=0;
8756: while(L!=[]&&isnum(car(L))){
8757: F=1; L=cdr(L);
8758: }
8759: while(L!=[]&&car(L)<33) L=cdr(L);
8760: return (L==[])?F:0;
8761: }
8762:
1.6 takayama 8763: def isvar(X)
8764: {
8765: return ([X]==vars(X)&&vtype(X)<3)?1:0;
8766: }
8767:
8768: def isyes(F)
8769: {
8770: if((CC=getopt(set))==1){
8771: IsYes=(type(F[0])==4)?F:[F];
8772: return 1;
8773: }else if(CC==0) return(IsYes);
8774: if(type(CC)!=7)
8775: CC=IsYes;
8776: for(;CC!=[]; CC=cdr(CC)){
8777: C=car(CC);
8778: V=call(C[0],cons(F,C[1]));
8779: if(type(C[2])!=4){
8780: if(V!=C[2]) break;
8781: }else{
8782: if(C[2][0]!="" && V<C[2][0]) break;
8783: if(C[2][1]!="" && V>C[2][1]) break;
8784: }
8785: }
8786: return (CC==[])?1:0;
8787: }
8788:
8789: def isall(FN,M)
8790: {
8791: if(type(M)<4 || type(M)>6) return ((*FN)(M)==0)?0:1;
8792: if(type(M)==4){
8793: for(;M!=[];M=cdr(M))
8794: if((*FN)(car(M))==0) return 0;
8795: }else if(type(M)==5){
8796: K=length(M);
8797: for(I=0;I<K;I++)
8798: if((*FN)(M[I])==0) return 0;
8799: }else if(type(M)==6){
8800: K=size(M)[0];
8801: for(I=0;I<K;I++)
8802: if (isall(FN,M[I])==0) return 0;
8803: }
8804: return 1;
8805: }
8806:
8807: def sproot(MP,T)
8808: {
8809: if((I=str_chr(T,0,","))>0){
8810: if(type(MP)==7) M=s2sp(MP);
8811: else M=chkspt(MP|opt=0);
8812: if(I==length(M[0])){
8813: N=s2sp(T);S=SM=SN=K=0;
8814: for(MM=M,NN=N;MM!=[];MM=cdr(MM),NN=cdr(NN),K++){
8815: for(MT=car(MM),NT=car(NN);MT!=[];MT=cdr(MT),NT=cdr(NT)){
8816: S+=car(MT)*car(NT);
8817: if(K==0){
8818: SM+=car(MT);SN+=car(NT);
8819: }
8820: }
8821: }
8822: return S-(length(M)-2)*SM*SN;
8823: }
8824: }
8825: MM=chkspt(MP|opt=7);
8826: if(T=="base") return MM;
8827: Keep=(getopt(keep)==1)?1:0;
8828: Null=getopt(null);
8829: Only=getopt(only);
8830: if(type(Only)!=1) Only=7;
8831: M0=MM[0];
8832: M1=MM[1];
8833: M=MM[2];
8834: if(T=="length") return length(M);
8835: if(T=="height"){
8836: for(J=2,S=M1[0][0],M2=M1; M2!=[]; M2=cdr(M2)){
8837: for(MT=cdr(car(M2)); MT!=[]; J++, MT=cdr(MT)){
8838: S+= J*car(MT);
8839: }
8840: J=1;
8841: }
8842: return S;
8843: }
8844: for(OD=0, MT=M1[0]; MT!=[]; MT=cdr(MT)) OD+=car(MT);
8845: if(T=="type"){
8846: R=newvect(OD+1);
8847: for(MT=M; MT!=[]; MT=cdr(MT)) R[MT[0][0]]++;
8848: for(RR=[],I=OD; I>0; I--)
8849: if(R[I]>0) RR=cons([R[I],I],RR);
8850: return RR;
8851: }
8852: if(T=="part"||T=="pair"||T=="pairs"){
8853: NP=length(M1);
8854: LM=newvect(NP);
8855: R=newvect(length(M));
8856: for(K=0; K<NP; K++) LM[K]=length(M1[K]);
8857: for(I=0,TM=M; TM!=[]; I++, TM=cdr(TM)){
8858: V=newvect(NP);
8859: for(K=0; K<NP; K++) V[K]=newvect(LM[K]);
8860: TP=car(TM);
8861: if(TP[2]==0){
8862: for(K=0;K<NP;K++) V[K][0]=1;
8863: for(J=0; J<I; J++){
8864: VJ=R[J][1];
8865: for(S=K=0;K<NP;K++) S+=VJ[K][0];
8866: for(OD=0,K=0;K<LM[0];K++) OD+=VJ[0][K];
8867: S-=(NP-2)*OD;
8868: for(K=0;K<NP;K++) VJ[K][0]-=S;
8869: }
8870: }else{
8871: K=TP[1]; P=TP[2];
8872: V[K][P-1]=-1; V[K][P]=1;
8873: for(J=0; J<I; J++){
8874: VJ=R[J][1];
8875: S=VJ[K][P]; VJ[K][P]=VJ[K][P-1]; VJ[K][P-1]=S;
8876: }
8877: }
8878: R[I]=[TP[0],V];
8879: }
8880: if(T=="pair"||T=="pairs"){
8881: MV=ltov(M1);
8882: for(K=0; K<NP; K++) MV[K] = ltov(MV[K]);
8883: for(RR=UU=SS=[],I=0; I<length(M); I++){
8884: V=newvect(NP); W=newvect(NP); U=newvect(NP);
8885: for(K=0; K<NP; K++){
8886: U[K]=newvect(LM[K]); V[K]=newvect(LM[K]); W[K]=newvect(LM[K]);
8887: }
8888: S=R[I][0];
8889: for(K=0; K<NP; K++){
8890: for(Q=J=0; J<LM[K]; J++){
8891: V[K][J] = S*(U[K][J] = R[I][1][K][J]);
8892: Q+=(W[K][J] = MV[K][J] - V[K][J]);
8893: }
8894: }
8895: if(Q>0 && iand(Only,1)==0) continue;
8896: if(Q==0 && iand(Only,2)==0) continue;
8897: if(Q<0 && iand(Only,4)==0) continue;
8898: for(K=0; K<NP; K++){
8899: V[K] = vtol(V[K]); W[K] = vtol(W[K]); U[K]=vtol(U[K]);
8900: }
8901: V=vtol(V); W=vtol(W);U=vtol(U);
8902: if(Q<0) S=-S;
8903: RR = cons([V,W], RR); UU = cons(U,UU); SS=cons(S,SS);
8904: }
8905: RR = reverse(RR); UU=reverse(UU); SS=reverse(SS);
8906: if(getopt(dviout)==1 && (Null!=1 || RR!=[])){
8907: Out=string_to_tb("\\begin{align}\\begin{split}"+s2sp(M1)+"&=");
8908: for(I=0,R=RR, U=UU; R!=[]; I++, R=cdr(R), U=cdr(U)){
8909: if(I>0) str_tb("\\\\\n &=",Out);
8910: if(T=="pairs"){
8911: if((S=SS[I])<0) S=-S;
8912: if(S>1) str_tb([my_tex_form(S),"("],Out);
8913: str_tb(s2sp(car(U)),Out);
8914: if(S>1) str_tb(")",Out);
8915: str_tb(" \\oplus ",Out);
8916: if(SS[I]<0){
8917: #ifdef USEMODULE
8918: str_tb(["-(",s2sp(mtransbys(os_md.abs,car(R)[1],[])),")"],Out);
8919: #else
8920: str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out);
8921: #endif
8922: }else
8923: str_tb(s2sp(car(R)[1]),Out);
8924: }else
8925: str_tb([s2sp(car(R)[0])," \\oplus ",s2sp(car(R)[1])],Out);
8926: }
8927: str_tb("\n\\end{split}\\end{align}",Out);
8928: dviout(str_tb(0,Out)|keep=Keep);
8929: }
8930: return RR;
8931: }
8932: for(I=0; I<length(M); I++){
8933: for(K=0; K<NP; K++) R[I][1][K] = vtol(R[I][1][K]);
8934: R[I] = [R[I][0],vtol(R[I][1])];
8935: }
8936: R = vtol(R);
8937: return [M0,M1,R];
8938: }
8939: }
8940:
8941: def spgen(MO)
8942: {
8943: Eq=(getopt(eq)==1)?1:0;
8944: Sp=getopt(sp);
8945: if(type(Sp)==7) Sp=s2sp(Sp);
8946: St=getopt(str);
8947: LP=getopt(pt);
8948: F=getopt(std);
8949: if(F!=1&&F!=-1) F=0;
8950: if(type(LP)==4){
8951: L0=LP[0]; L1=LP[1];
1.29 takayama 8952: }else if(type(LP)==1){
8953: L0=L1=LP;
1.6 takayama 8954: }else{
8955: L0=0; L1=MO+1;
8956: }
1.53 takayama 8957: if(M0<=0){
1.6 takayama 8958: MO=-MO;
8959: if(iand(MO,1)==1) return [];
1.53 takayama 8960: MO=MO/2;
8961: B=spbasic(-2*MO,0|str=1);
8962: if(L1<3) L1=MO+4;
1.6 takayama 8963: if(St!=1){
8964: for(R=[]; B!=[]; B=cdr(B)){
1.53 takayama 8965: RT= F?s2sp(car(B)|std=F): s2sp(car(B));
1.6 takayama 8966: if(length(RT)<L0 || length(RT)>L1) continue;
8967: R=cons(RT,R);
8968: }
8969: return reverse(R);
8970: }else{
8971: if(L0<=3 && L1>=MO+4) return B;
8972: for(R=[]; B!=[]; B=cdr(B)){
8973: RT=s2sp(T=car(B));
8974: if(length(RT)<L0 || length(RT)>L1) continue;
8975: if(F) T=s2sp(s2sp(T|std=K));
8976: R=cons(T,R);
8977: }
8978: return reverse(R);
8979: }
8980: }
8981: MP=(L1<MO+1)?L1:MO+1;
8982: LL=newvect(MO+1);
8983: R=newvect(MP+2);
8984: R0=newvect(MP+2);
8985: for(I=1; I<=MO; I++) LL[I]=[];
8986: if(type(Sp)==4){
8987: if(getopt(basic)==1) Sp=chkspt(Sp[6]);
8988: R=chkspt(Sp);
8989: if(R[1]>MO) return 0;
8990: LL[R[1]]=R;
8991: K=R[1];
8992: }
8993: if(K==1||type(Sp)!=4){
8994: LL[1]=[[[1]]];
8995: for(I=2; I<=MO && I<MP;I++){
8996: for(T=[], J=0; J<I+1; J++)
8997: T=cons([I-1,1],T);
8998: LL[I]=cons(T,LL[I]);
8999: }
9000: K=2;
9001: }
9002: for(OD=K; OD<MO; OD++){
9003: for(LT=LL[OD]; LT!=[]; LT=cdr(LT)){
9004: for(II=0,L=car(LT); L!=[]; II++, L=cdr(L)){
9005: R0[II]=R[II]=car(L);
9006: }
9007: for(; ;){
9008: for(S=-2*OD, I=0; I<II; I++){
9009: S += OD;
9010: if(R[I]!=[]) S-=car(R[I]);
9011: }
9012: --I;
9013: for(;S+OD<=MO && I<=MP;S+=OD,I++){
9014: if(S<=0) continue;
9015: for(J=0;J<=I;J++){
9016: if(J>=II){
9017: if(S<OD) break;
9018: }else
9019: if(S+((R[J]==[])?0:car(R[J]))<car(R0[J])) break;
9020: }
9021: if(--J>=I){
9022: V=newvect(I);
9023: RRR=[];
9024: for(;J>=0;J--){
9025: if(J>=II) RR=[OD,S];
9026: else{
9027: K=length(R[J]);
9028: RR=[S+((K==0)?0:car(R[J]))];
9029: K=length(R0[J])-K;
9030: for(RT=R0[J]; RT!=[]; K--,RT=cdr(RT)){
9031: if(K!=0) RR=cons(car(RT),RR);
9032: }
9033: }
9034: RRR=cons(reverse(RR),RRR);
9035: }
9036: RRR=qsort(reverse(RRR));
9037: if(findin(RRR,LL[S+OD])<0)
9038: LL[S+OD]=cons(RRR,LL[S+OD]);
9039: }
9040: }
9041: for(K=0; K<II; K++){
9042: if(R[K]!=[]){
9043: S=car(R[K]);
9044: while((R[K]=cdr(R[K]))!=[] && car(R[K])==S);
9045: break;
9046: }else R[K]=R0[K];
9047: }
9048: if(K>=II) break;
9049: }
9050: }
9051: }
9052: if(L0>0 || L1<MO+1 || St==1 || F){
9053: for(J=1; J<=MO; J++){
9054: for(RT=[],R=LL[J];R!=[];R=cdr(R)){
9055: L=length(T=car(R));
9056: if(L<L0 || L>L1) continue;
9057: if(F) T=s2sp(T|std=F);
9058: RT=cons((St==1)?s2sp(T):T,RT);
9059: }
9060: LL[J] = reverse(RT);
9061: }
9062: }
9063: if(Eq==1) return LL[MO];
9064: return LL;
9065: }
9066:
1.53 takayama 9067: def spbasic(Idx,D)
9068: {
9069: /*
9070: D<=3|Idx|+6, D<=|Idx|+2 (p>3), p<=|Idx|/2+4
9071: Idx=2*D^2-(D^2-\sum m_{j,\nu}^2); \sum(D-m_{j,1})>=2*D;
9072: \sum (m_{j,1)-m_{j,\nu})*m_{j,\nu)
9073: 0<=(2*D-\sum(D-m_{j,1})})*D=\sum_(m_{j,1}-m_{j,\mu})*m_{j,\nu} -|Idx|
9074: (-2,0) 13個 (9+3+?)
9075: (-4,0) 37個 (25+9+?)
9076: (-6,0) : 8.5sec ?sec 0.05sec 69個 (46+17+?)
1.54 takayama 9077: (-8,0) : 97 sec 1sec 0.13sec 113個 (73+29+?) <- (-2,0)
9078: (-10,0): 4sec 0.27sec 198個 (127+50+?)
9079: (-12,0) 28sec 4.2sec 0.64sec 291個 (182+76+?)
9080: (-14,0) 27sec 10.2sec 1.31sec 415個 (249+115+?)
9081: (-16,0) 34.0sec 2.47sec 647個 (395+172+?) <- (-4,0)
9082: (-18,0) 4.42sec 883個 (521+243+?) <- (-2,0)
9083: (-20,0) 8.17sec 1186個 (680+345+?)
1.53 takayama 9084: */
9085: Idx=-Idx;
9086: if((Str=getopt(str))!=1) Str=0;
9087: if(!isint(Idx)||!isint(Idx/2)||Idx<0||!isint(D)||D<0||D==1||D>3*Idx+6) return [];
9088: if(D==0){
9089: for(R=[],D=3*Idx+6;D>=2;D--) R=append(spbasic(-Idx,D|str=Str),R);
9090: return R;
9091: }
9092: if(!Idx){
9093: R=0;
9094: if(D==2) R="11,11,11,11";
9095: if(D==3) R="111,111,111";
9096: if(D==4) R="22,1111,1111";
9097: if(D==6) R="33,222,111111";
9098: if(!R) return [];
9099: return [(Str==1)?R:s2sp(R)];
9100: }
9101: if(D>Idx+2){
9102: L=3;
9103: if(D==3*Idx+6){
9104: R=[[D/2,D/2],[D/3,D/3,D/3],[D/6,D/6,D/6,D/6,D/6,D/6-1,1]];
9105: return [(Str==1)?s2sp(R):R];
9106: }
9107: if(iand(D,1)&&(D-3)/2>Idx) return [];
9108: }else L=Idx/2+4;
1.54 takayama 9109: V=newvect(L);SV=newvect(L);
1.53 takayama 9110: for(S1=[],I=0;I<D;I++) S1=cons(1,S1);
9111: for(T=D-1;T>1;T--){
9112: K=D%T;
9113: if((T-K)*K<=Idx) break;
9114: }
9115: J=(T-K)*K;SJ=K^2+(D-K)*T;
9116: TV=K?[K]:[];
9117: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9118: for(I=0;I<L;I++){
1.54 takayama 9119: SV[I]=2*D^2-(I+1)*(D^2-J)-Idx;
1.53 takayama 9120: V[I]=TV;
9121: }
1.54 takayama 9122: if(SV[2]>0) return [];
1.53 takayama 9123: if(D>Idx+2 && V[0][0]+V[1][0]>=D && V[1][0]>1){
9124: T=V[1][0]-1;K=D%T;TV=K?[K]:[];
9125: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9126: V[1]=V[2]=TV;
9127: }
9128: for(R=[];;){
9129: if(D>Idx+2){
1.54 takayama 9130: if(3*V[0][0]<D) break;
9131: if(V[0][0]+V[1][0]>=D && (T=D-V[0][0]-1)>0){
1.53 takayama 9132: K=D%T;TV=K?[K]:[];
9133: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9134: V[1]=V[2]=TV;
9135: }
9136: S2=V[0][0]+V[1][0]+V[2][0]-D;
9137: if(V[0][0]+2*V[1][0]<D ||(S2<0&&V[1][0]==1) ){
9138: V[0]=V[1]=V[2]=nextpart(V[0]);
9139: T=V[0][0];
9140: T=D-2*T;
9141: if(T==0){
9142: V[1]=[D/2-1,1];
9143: V[2]=S1;
9144: }else if(T>0){
9145: J=D%T;
1.54 takayama 9146: K=J?[J]:[];
1.53 takayama 9147: for(J=(D-J)/T;J>0;J--) K=cons(T,K);
9148: V[2]=K;
9149: }
9150: continue;
9151: }
9152: if(S2<0||V[2][0]<=S2){
9153: V[1]=V[2]=nextpart(V[1]);
9154: continue;
9155: }else if(S2>0){
9156: T=V[2][0]-S2;J=D%T;
9157: K=J?[J]:[];
9158: for(J=(D-J)/T;J>0;J--) K=cons(T,K);
9159: V[2]=K;
9160: }
9161: }
9162: for(S=-2*D,IL=0;IL<L;IL++){
9163: S+=D-car(V[IL]);
9164: if(S>=0) break;
9165: }
1.54 takayama 9166: if((I=IL)==L){ /* reducible i.e. IL=L && S<0 */
1.53 takayama 9167: for(LL=L-1;LL>=0;LL--){
9168: if((K=car(V[LL]))+S>0){
9169: K+=S;
9170: for(TV=[],TD=D;TD>=K;TD-=K) TV=cons(K,TV);
9171: if(TD>0) V[LL]=append(TV,[TD]);
9172: else V[LL]=TV;
9173: break;
9174: }else{
9175: S+=K-1;
9176: V[LL]=S1;
9177: }
9178: }
9179: if(LL<0) break;
9180: continue;
9181: }
9182: for(S0=K=0;K<=IL;K++){
9183: ST=car(V[K]);J=V[K][length(V[K])-1];S0+=(ST-J)*J;
9184: if(S0>Idx) break;
9185: }
9186: if(S0>Idx && car(V[K])!=1){
9187: ST=car(V[K]);
9188: S0-=(ST-J)*J;
9189: for(ST--;ST>0;ST--){
9190: J=D%ST;
9191: if(S0+(ST-J)*J <= Idx) break;
9192: }
9193: V[K]=J?[J]:[];
9194: for(J=D-J;J>0;J-=ST) V[K]=cons(ST,V[K]);
9195: for(J=K+1;J<L;J++) V[J]=V[K];
9196: continue;
9197: }
9198:
9199: for(K=SS=0;K<L&&SS<=Idx;K++){
9200: ST=car(V[K]);
9201: for(S0=0,TV=cdr(V[K]);TV!=[];TV=cdr(TV)) S0+=(ST-car(TV))*car(TV);
1.54 takayama 9202: SS+=S0;
1.53 takayama 9203: }
1.54 takayama 9204: if(SS>Idx && K<=IL && K!=L){
9205: SS0=Idx-SS+S0;
9206: for(TV=car(V[K]);TV>1;TV--){
9207: U=D%TV;
9208: if((D-U)*U<=SS0) break;
9209: }
9210: if(TV==car(V[K])){
9211: K=K-1;
9212: V[K]=nextpart(V[K]); /* to be improves */
9213: }else{
9214: V[K]=U?[U]:[]; /* to be improved */
9215: for(J=D-U;J>0;J-=TV) V[K]=cons(TV,V[K]);
9216: }
1.53 takayama 9217: for(J=K+1;J<L;J++) V[J]=V[K];
9218: continue;
9219: }
9220:
9221: for(Ix=2*D^2+Idx,J=0;J<L;J++){
9222: IxF=Ix;
9223: for(Ix-=D^2,TV=V[J];TV!=[];TV=cdr(TV)) Ix+=car(TV)^2;
9224: if(Ix<=0) break;
9225: }
9226: if(Ix==0&&(J>=I||IL==2)){
9227: for(TR=[],K=J;K>=0;K--) TR=cons(V[K],TR);
9228: R=cons((Str==1)?s2sp(TR):TR,R);
9229: }
9230: if(J>=0 && J<L && Ix<=0){
9231: I=V[J][0];K=D%I;S0=(D-K)*I+K^2;
9232: if(I>1&& IxF-D^2+S0<0){
9233: for(V[J]=[],K=D-I;K>0;K--) V[J]=cons(1,V[J]);
9234: V[J]=cons(I,V[J]);
9235: V[J]=nextpart(V[J]);
9236: for(I=J+1;I<L;I++) V[I]=V[J];
9237: continue;
9238: }
9239: }
9240: if(J>=0 && J<L && Ix<=0 && car(V[J])>(U=V[J][length(V[J])-1])+1){
9241: TV=reverse(V[J]);
9242: for(S0=0,K=[];TV!=[];TV=cdr(TV),S0++){
9243: if((I=car(TV))<U+2||(length(TV)>1&&S0<2)){
9244: while(I-->0) K=cons(1,K);
9245: }else K=cons(car(TV),K);
9246: }
9247: V[I=J]=K;
9248: }else{
9249: if(J>=L) J=L-1;
9250: for(I=J;I>=0&&length(V[I])==D;I--);
9251: if(I<0) break;
9252: }
9253: V[I]=nextpart(V[I]); /* to be improved */
9254: for(J=I+1;J<L;J++) V[J]=V[I];
9255: }
9256: return R;
9257: }
9258:
1.6 takayama 9259: def spType2(L)
9260: {
9261: C=0;R=[];
9262: for(LT=L;LT!=[];LT=cdr(LT)){
9263: D=-1;LP=car(LT);
9264: for(LPT=LP;LPT!=[];LPT=cdr(LPT)){
9265: if(D==-1) D=car(LPT);
9266: else D=igcd(D,car(LPT));
9267: if(D==1){
9268: C++;break;
9269: }
9270: }
9271: if(C==2) return 0;
9272: R=cons(D,R);
9273: }
9274: if(C==0) return L;
9275: if(C==1){
9276: for(K=length(R)-1;R[K]!=1;K--);
9277: D=-1;
9278: for(I=length(R)-1;I>=0;I--){
9279: if(I==K) continue;
9280: if(D==-1) D=R[I];
9281: else D=igcd(D,R[I]);
9282: if(D==1) return 0;
9283: }
9284: }
9285: return L;
9286: }
9287:
9288:
9289: /* ret [#points, order, idx, Fuchs, reduction order, reduction exponents, fund] */
9290: def chkspt(M)
9291: {
9292: Opt= getopt(opt);
9293: Mat= getopt(mat);
9294: if(type(M)==7) M=s2sp(M);
1.28 takayama 9295: if(type(Opt) >= 0&&Opt!="idx"){
1.6 takayama 9296: if(type(Opt) == 7)
9297: Opt = findin(Opt, ["sp","basic","construct","strip","short","long","sort","root"]);
9298: if(Opt < 0){
9299: erno(2);
9300: return 0;
9301: }
9302: return fspt(M,Opt);
9303: }
9304: P = length(M);
9305: OD = -1;
9306: XM = newvect(P);
9307: Fu = 0;
9308: for( I = SM = SSM = 0; I < P; I++ ){
9309: LJ = length(M[I]);
9310: JM = JMV = 0;
9311: for(J = SM = 0; J < LJ; J++){
9312: MV = M[I][J];
9313: if(type(MV) == 4){
9314: Fu += MV[0]*MV[1];
9315: MV = MV[0];
9316: }
9317: if(MV > JMV){
9318: JM = J; JMV = MV;
9319: }
9320: SM += MV;
9321: SSM += MV^2;
9322: }
9323: if(OD < 0)
9324: OD = SM;
9325: else if(OD != SM){
1.28 takayama 9326: if(getopt(dumb)!=1) print("irregal partitions");
9327: return -1;
1.6 takayama 9328: }
9329: XM[I] = JM;
9330: }
9331: SSM -= (P-2)*OD^2;
9332: for(I = SM = JM = 0; I < P; I++){
9333: MV = M[I][XM[I]];
9334: if(type(MV) == 4){
9335: MV = MV[0]; JM = 1;
9336: }
9337: if(I == 0)
9338: SMM = MV;
9339: else if(SMM > MV)
9340: SMM = MV;
9341: SM += MV;
9342: }
9343: SM -= (P-2)*OD;
1.28 takayama 9344: if(Opt=="idx") return SSM;
1.6 takayama 9345: if(SM > SMM && SM != 2*OD){
1.28 takayama 9346: if(getopt(dumb)!=1) print("not realizable");
9347: return 0;
1.6 takayama 9348: }
9349: if(JM==1 && Mat!=1)
9350: Fu -= OD - SSM/2;
1.28 takayama 9351: return [P, OD, SSM, Fu, SM, XM, fspt(M,1)];
1.6 takayama 9352: }
9353:
9354: def cterm(P)
9355: {
9356: V = getopt(var);
9357: if(type(V) != 4)
9358: V=vars(P);
9359: for(; V !=[]; V = cdr(V))
9360: P = mycoef(P,0,car(V));
9361: return P;
9362: }
9363:
9364: def terms(P,L)
9365: {
9366: Lv=getopt(level);
9367: if(type(Lv)!=1) Lv=0;
9368: V=car(L);L=cdr(L);
9369: for(R=[],D=mydeg(P,V);D>=0; D--){
9370: if((Q=mycoef(P,D,V))==0) continue;
9371: if(L!=[]){
9372: R0=terms(Q,L|level=Lv+1);
9373: for(;R0!=[];R0=cdr(R0)) R=cons(cons(D,car(R0)),R);
9374: }else R=cons([D],R);
9375: }
9376: if(Lv>0) return R;
9377: R=qsort(R);
9378: Rev = getopt(rev); Dic=getopt(dic);
9379: if(Dic==1 && Rev==1) R=reverse(R);
9380: for(R0=[];R!=[];R=cdr(R)){
9381: for(RT=car(R),S=0;RT!=[];RT=cdr(RT)) S+=car(RT);
9382: R0=cons(cons(S,car(R)),R0);
9383: }
9384: if(Dic==1) return R0;
9385: if(Rev==1){
9386: for(R=[];R0!=[];R0=cdr(R0)){
9387: T=car(R0);
9388: R=cons(cons(-car(T),cdr(T)),R);
9389: }
9390: R0=R;
9391: }
9392: R0=qsort(R0);
9393: if(Rev==1){
9394: for(R=[];R0!=[];R0=cdr(R0)){
9395: T=car(R0);
9396: R=cons(cons(-car(T),cdr(T)),R);
9397: }
9398: R0=R;
9399: }
9400: return (Rev==1)?R0:reverse(R0);
9401: }
9402:
9403: def polcut(P,N,L)
9404: {
9405: if(type(L)==2) L=[L];
9406: M=getopt(top);
9407: if(type(M)!=1) M=0;
9408: T=terms(P,L);
9409: for(S=0;T!=[];T=cdr(T)){
9410: LT=car(T);
9411: if(LT[0]<M || LT[0]>N) continue;
9412: for(PW=1,LT=cdr(LT),V=L,Q=P;LT!=[];LT=cdr(LT),V=cdr(V)){
9413: Q=mycoef(Q,car(LT),car(V));PW*=car(V)^car(LT);
9414: }
9415: S+=Q*PW;
9416: }
9417: return S;
9418: }
9419:
9420: def redgrs(M)
9421: {
9422: Mat = getopt(mat);
9423: if(Mat!=1) Mat=0;
9424: R = chkspt(M|mat=Mat);
9425: if(type(R) < 4)
9426: return -1;
9427: if(R[4] <= 0)
9428: return 1-R[4];
9429: if(R[4] == 2*R[1])
9430: return 0;
9431: V = newvect(R[0]);
9432: Type = type(M[0][0]);
9433: if(Type > 3){
9434: Mu = Mat-1;
9435: for(I = 0; I < R[0]; I++)
9436: Mu += M[I][R[5][I]][1];
9437: }
9438: for(I = 0; I < R[0]; I++){
9439: IR = R[5][I]; L = []; MI = M[I]; MIE=MI[IR];
9440: for(J = length(MI)-1; J >= 0; J--){
9441: if(Type <= 3){
9442: VM = MI[J];
9443: if(J == IR){
9444: VM -= R[4];
9445: if(VM < 0) return -1;
9446: }
9447: L = cons(VM, L);
9448: }else{
9449: VM = MI[J][0];
9450: if(J == IR){
9451: VM -= R[4];
9452: if(VM < 0)
9453: return -1;
9454: if(I == 0)
9455: EV = 1-Mat-Mu;
9456: else
9457: EV = 0;
9458: }else{
9459: if(I == 0)
9460: EV = MI[J][1] - M[0][R[5][0]][1] + 1-Mat; /* + MX - Mu; */
9461: else
9462: EV = MI[J][1] - MIE[1] + Mu;
9463: }
9464: L = cons([VM,EV], L);
9465: /*
1.24 takayama 9466: if(R[2] >= 2){ */ /* rigid */
1.6 takayama 9467: /* P = dx^(R[1]);
9468: } */
9469: }
9470: }
9471: V[I] = L;
9472: }
9473: return [R[5], vtol(V)];
9474: }
9475:
9476: def cutgrs(A)
9477: {
9478: for(AL=[] ; A!=[]; A=cdr(A)){ /* AT: level 2 */
9479: for(ALT=[], AT=car(A); AT!=[]; AT=cdr(AT)){
9480: M = (type(car(AT)) < 4)?car(AT):car(AT)[0];
9481: if(M > 0)
9482: ALT = cons(car(AT), ALT); /* ALT: level 2 */
9483: }
9484: AL = cons(reverse(ALT), AL); /* AL: level 3 */
9485: }
9486: return reverse(AL);
9487: }
9488:
9489: def mcgrs(G, R)
9490: {
9491: NP = length(G);
9492: Mat = (getopt(mat)==1)?0:1;
1.36 takayama 9493: if(Mat==0 && type(SM=getopt(slm))==4){
1.24 takayama 9494: SM0=SM[0];SM1=anal2sp(SM[1],["*",-1]);
9495: if(findin(0,SM0)>=0){
9496: for(SM=[],I=length(G)-1;I>0;I--)
9497: if(findin(I,SM0)<0) SM=cons(I,SM);
9498: SM=[SM,SM1];
1.36 takayama 9499: G=mcgrs(G,R|mat=1,slm=SM);
1.24 takayama 9500: return [G[0],anal2sp(G[1],["*",-1])];
9501: }
9502: }else SM0=0;
1.6 takayama 9503: for(R = reverse(R) ; R != []; R = cdr(R)){
9504: GN = [];
9505: L = length(G)-1;
9506: RT = car(R);
9507: if(type(RT) == 4){
1.37 takayama 9508: if(length(RT)==L+1&&RT[0]!=0){
9509: R=cons(cdr(RT),cdr(R));
1.24 takayama 9510: R=cons(RT[0],R);
1.37 takayama 9511: R=cons(0,R);
1.24 takayama 9512: continue;
9513: } /* addition */
9514: RT = reverse(RT); S = ADS = 0;
1.37 takayama 9515: for(G = reverse(G); G != []; G = cdr(G), L--, RT=cdr(RT)){
9516: AD = car(RT);
1.24 takayama 9517: if(L > 0){
1.6 takayama 9518: S += AD;
1.24 takayama 9519: if(SM && findin(L,SM0)>=0) ADS+=AD;
9520: }else
1.6 takayama 9521: AD = -S;
9522: for(GTN = [], GT = reverse(car(G)); GT != []; GT = cdr(GT))
9523: GTN = cons([car(GT)[0],car(GT)[1]+AD], GTN);
9524: GN = cons(GTN, GN);
9525: }
9526: G = GN;
1.24 takayama 9527: if(SM0){
9528: for(ST=reverse(SM1),SM1=[]; ST!=[]; ST=cdr(ST))
9529: SM1 = cons([car(ST)[0],car(ST)[1]+ADS], SM1);
9530: }
1.6 takayama 9531: continue;
9532: }
1.24 takayama 9533: if(RT==0) continue;
9534: VP = newvect(L+1); GV = ltov(G); /* middle convolution */
1.6 takayama 9535: for(I = S = OD = 0; I <= L; I++){
9536: RTT = (I==0)?(Mat-RT):0;
9537: VP[I] = -1;
1.24 takayama 9538: for(J = M = K = 0, GT = GV[I]; GT != []; GT = cdr(GT), J++){
1.6 takayama 9539: if(I == 0)
9540: OD += car(GT)[0];
9541: if(car(GT)[1] == RTT && car(GT)[0] > M){
9542: S += car(GT)[0]-M;
1.36 takayama 9543: M=car(GT)[0];
1.6 takayama 9544: VP[I] = J;
9545: }
9546: }
1.24 takayama 9547: }
9548: S -= (L-1)*OD;
9549: for(GN = []; L >= 0; L--){
9550: GT = GV[L];
9551: RTT = (L==0)?(-RT):RT;
1.38 takayama 9552: GTN = (VP[L]>=0 || S == 0)?[]:[[-S,(L==0)?(Mat-RT):0]];
1.24 takayama 9553: for(J = 0; GT != []; GT = cdr(GT), J++){
9554: if(J != VP[L]){
9555: GTN = cons([car(GT)[0],car(GT)[1]+RTT], GTN);
9556: continue;
1.6 takayama 9557: }
1.24 takayama 9558: K = car(GT)[0] - S;
9559: if(K < 0){
9560: print("Not realizable");
9561: return;
9562: }
1.38 takayama 9563: if(K>0) GTN = cons([K,(L==0)?(Mat-RT):0], GTN);
1.24 takayama 9564: }
9565: GN = cons(reverse(GTN), GN);
9566: }
1.36 takayama 9567: if(SM0&&RT!=0){
9568: for(M0=M1=-OD,L=length(G)-1;L>=0;L--){
9569: if(findin(L,SM0)>=0){
9570: M0+=OD;
9571: if(VP[L]>=0) M0-=GV[L][VP[L]][0];
9572: }else{
9573: M1+=OD;
9574: if(VP[L]>=0) M1-=GV[L][VP[L]][0];
9575: }
9576: }
9577: SM2=[];
9578: if((Mx1=anal2sp(SM1,["max",1,-RT])[0])<0){
9579: if(M1>0) SM2=cons([M1,0],SM2);
1.38 takayama 9580: }else M1+=car(SM1[Mx1]);
1.36 takayama 9581: if((Mx0=anal2sp(SM1,["max",1,0])[0])<0){
9582: if(M0>0) SM2=cons([M0,RT],SM2);
1.38 takayama 9583: }else M0+=car(SM1[Mx0]);
1.36 takayama 9584: for(J=0;SM1!=[];J++,SM1=cdr(SM1)){
9585: if(J==Mx0){
9586: if(M0>0) SM2=cons([M0,-RT],SM2);
9587: }else if(J==Mx1){
9588: if(M1>0) SM2=cons([M1,0],SM2);
9589: }else SM2=cons([car(SM1)[0],car(SM1)[1]+RT],SM2);
1.6 takayama 9590: }
1.36 takayama 9591: SM1=reverse(SM2);
1.6 takayama 9592: }
9593: G = cutgrs(GN);
9594: }
1.36 takayama 9595: return SM0?[G,SM1]:G;
1.6 takayama 9596: }
9597:
1.38 takayama 9598: def spslm(M,TT)
9599: {
9600: R=getbygrs(M,1|mat=1);
9601: if(type(R)!=4||type(R[0])!=4||type(S=R[0][1])!=4){
9602: errno(0);return0;
9603: }
9604: if(S[1]!=[[1,0]]){
9605: print("Not rigid!");return0;
9606: }
9607: if((F=S[0][0][1])!=0){
9608: for(V=vars(F);V!=[];V=cdr(V)){
9609: if(mydeg(F,car(V))==1){
9610: T=lsol(F,car(V));
9611: break;
9612: }
9613: }
9614: if(V==[]){
9615: print("Violate Fuchs condition!");
9616: return0;
9617: }
9618: }
9619: for(P=[];R!=[];R=cdr(R))
9620: P=cons(car(R)[0],P);
9621: if(F!=0){
9622: S=mysubst(S,[car(V),T]);P=mysubst(P,[car(V),T]);
9623: }
9624: return mcgrs(S,P|mat=1,slm=[TT,[[1,0]]]);
9625: }
9626:
1.6 takayama 9627: /*
9628: F=0 : unify
9629: F=["add",S] :
9630: F=["sub",S] :
9631: F=["+",A,B] :
9632: F=["*",A,B] :
9633: F=["mul",K];
9634: F=["get",F,V] :
9635: F=["put",F,V] :
9636: F=["get1",F,V] :
9637: F=["put1",F,V] :
1.24 takayama 9638: F=["max"] :
9639: F=["max",F.V] :
1.6 takayama 9640: F=["put1"] :
9641: F=["val",F];
9642: F=["swap"];
9643: */
9644: def anal2sp(R,F)
9645: {
9646: if(type(F)==4&&type(F[0])==4){ /* multiple commands */
9647: for(;F!=[];F=cdr(F)) R=anal2sp(R,car(F));
9648: return R;
9649: }
9650: if(type(F)==7) F=[F];
9651: if(F==0){ /* unify */
9652: R=ltov(R);
9653: L=length(R);
9654: for(J=1;J<L;J++){
9655: for(I=0;I<J;I++){
9656: if(cdr(R[I])==cdr(R[J])){
9657: R[I]=cons(R[I][0]+R[J][0],cdr(R[I]));
9658: R[J]=cons(0,cdr(R[J]));
9659: break;
9660: }
9661: }
9662: }
9663: for(G=[],I=L-1;I>=0;I--)
9664: if(R[I][0]!=0) G=cons(R[I],G);
9665: if(length(G[0])==2){ /* sort by multiplicity */
9666: R=ltov(G);
9667: L=length(R);
9668: for(I=1;I<L;I++){
9669: for(J=I;J>0;J--){
9670: if(R[J-1][0]>R[J][0]) break;
9671: if(R[J-1][0]==R[J][0]){
9672: S1=rtostr(R[J-1][1]);S2=rtostr(R[J][1]);
9673: if((K=str_len(S1)-str_len(S2))<0) break;
9674: if(!K&&S1<S2) break;
9675: }
9676: S=R[J-1];R[J-1]=R[J];R[J]=S;
9677: }
9678: }
9679: G=vtol(R);
9680: }
9681: return G;
9682: }
9683: if(F[0]=="add") return append(R,F[1]);
1.24 takayama 9684: if(F[0]=="max"){
9685: if(length(F)==3) C=1;
9686: else C=0;
9687: M=-10^10;K=[-1];
9688: for(I=0;R!=[];R=cdr(R),I++){
9689: if(C>0&&car(R)[F[1]]!=F[2]) continue;
9690: if(M<car(R)[0]){
9691: M=car(R)[0];K=[I,car(R)];
9692: }
9693: }
9694: return K;
9695: }
1.6 takayama 9696: R=reverse(R);
9697: if(F[0]=="sub"){
9698: for(S=F[1];S!=[];S=cdr(S))
9699: R=cons(cons(-car(S)[0],cdr(car(S))),R);
9700: return reverse(R);
9701: }
9702: if(F[0]=="swap"){
9703: for(G=[];R!=[];R=cdr(R))
9704: G=cons([car(R)[0],car(R)[2],car(R)[1]],G);
9705: return G;
9706: }
9707: if(F[0]=="+"){
1.24 takayama 9708: L=length(F);
9709: for(G=[];R!=[];R=cdr(R)){
9710: for(S=[],I=L-1;I>0;I--) S=cons(car(R)[I]+F[I],S);
9711: G=cons(cons(car(R)[0],S),G);
9712: }
1.6 takayama 9713: return G;
9714: }
9715: if(F[0]=="*"){
1.24 takayama 9716: L=length(F);
9717: for(G=[];R!=[];R=cdr(R)){
9718: for(S=0,I=1;I<L;I++) S+=car(R)[I]*F[I];
9719: G=cons([car(R)[0],S],G);
9720: }
1.6 takayama 9721: return G;
9722: }
9723: if(F[0]=="mult"){
9724: K=F[1];
9725: for(G=[];R!=[];R=cdr(R)) G=cons(cons(K*car(R)[0],cdr(car(R))),G);
9726: return G;
9727: }
9728: if(F[0]=="get"){
9729: for(G=[];R!=[];R=cdr(R))
9730: if(car(R)[F[1]]==F[2]) G=cons(car(R),G);
9731: return G;
9732: }
9733: if(F[0]=="put"){
9734: if(F[1]==1){
9735: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[2]],G);
9736: }else{
9737: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
9738: }
9739: return G;
9740: }
9741: if(F[0]=="get1"){
9742: if(length(F)==2){
9743: for(G=[];R!=[];R=cdr(R)) G=cons([R[0][0],car(R)[F[1]]],G);
9744: return G;
9745: }
9746: for(G=[];R!=[];R=cdr(R))
9747: if(car(R)[F[1]]==F[2]) G=cons([R[0][0],car(R)[3-F[1]]],G);
9748: return G;
9749: }
9750: if(F[0]=="put1"){
9751: if(length(F)==1)
9752: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],car(R)[1]],G);
9753: else if(F[1]==1)
9754: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[1]],G);
9755: else{
9756: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
9757: }
9758: return G;
9759: }
9760: if(F[0]=="val"){
9761: V=(length(F)==1)?1:F[1];
9762: for(I=J=0;R!=[];R=cdr(R)){
9763: I+=car(R)[0];
9764: J+=car(R)[0]*car(R)[V];
9765: }
9766: return [I,J];
9767: }
9768: return 0;
9769: }
9770:
9771: /*
9772: G=0 get trivial common spct
9773: G="..,..," spectre type of 4 singular points
9774: P=["get"] all spct
9775: P=["get",L]
9776: L=n for variable x_n
9777: L=[m,n] for residue [m,n]
1.23 takayama 9778: L=[m,n,l] for residue [m,n,l]
1.6 takayama 9779: L=[[m,n],[m',n']] for common spct
1.23 takayama 9780: P=["eigen",I] decomposition of A_I
1.6 takayama 9781: P=["get0",[m,n],[m',n']] for the sum of residues
1.23 takayama 9782: P=["rest",[m,n]] restriction
1.6 takayama 9783: P=["swap",[m,n]] for symmetry
9784: P=["perm",[...]] for symmetry
9785: P=["deg"]
9786: P=["homog"]
9787: P=["sort"]
9788: P=[[[m,n],c],...] for addition
9789: P=[c] or [[c],...] for middle convolution wrt 0
9790: P=[m,c] or [[m,c],...] for general middle convolution
9791: P=[[a,b,c]] for special additions
9792: P=[[d,a,b,c]] for middle convotution and additions
9793: P=["multi",...] multiple commands
9794: P=0,1,3 : return sim. spectre of 4 singular points
9795: */
9796: def mc2grs(G,P)
9797: {
9798: if(G==0){
9799: G=[];
9800: for(I=4;I>=0;I--){
9801: V=lsort([0,1,2,3,4],[I],1);
9802: for(J=1;J<4;J++){
9803: for(T=[],K=3;K>0;K--)
9804: if(K!=J) T=cons(V[K],T);
9805: G=cons([[[V[0],V[J]],T],[1,0,0]],G);
9806: }
9807: }
9808: G=mc2grs(G,"sort");
9809: }else if(type(G)==7||(type(G)==4&&length(G)==4)){
9810: if(type(G)==7) G=s2sp(G);
9811: F=(getopt(top)==0)?1:0;
9812: K=[];
9813: if(type(P)==1&&iand(P,1)&&type(G[0][0])<4){
9814: G=s2sp(G|std=1);
9815: if(F) G=[G[1],G[2],G[3],G[0]];
9816: G=sp2grs(G,[d,c,b,a],[1,length(G[0]),-1]|mat=1);
9817: G=reverse(G);
9818: if(iand(P,3)==3){
9819: V=vars(G);
9820: for(H=L=[a,b,c,d];H!=[];H=cdr(H))
9821: if(findin(car(H),V)>=0) G=subst(G,car(H),makev([car(H),1]));
9822: G=shortv(G,[a,b,c,d]);
9823: V=vars(G);
9824: for(H=G[3];H!=[];H=cdr(H)){
9825: T=car(H)[1];
9826: if(type(T)>1&&!isvar(T)){
9827: K=[car(H)[0],T];
9828: break;
9829: }
9830: }
9831: }
9832: F=1;
9833: }
9834: if(F) G=[G[3],G[0],G[1],G[2]];
9835: S=cons(["anal",1],getopt());
9836: if(!(R=m2mc(G,0|option_list=S))) return R;
9837: for(G=0,R=cdr(R);R!=[];R=cdr(R)){
9838: TR=car(R)[0];
9839: if(TR[0]) G=mc2grs(G,[[TR[0]]]);
9840: G=mc2grs(G,[cdr(TR)]);
9841: }
9842: if(type(P)==1&&K!=[]){
9843: for(T=10;T<36;T++){
9844: if(findin(X=makev([T]),V)>=0) continue;
9845: F=K[0]*(X-K[1]);
9846: return [F,simplify(G,[F],4)];
9847: }
9848: }
9849: }
9850: if(type(P)<2) return G;
9851: F=0;
1.25 takayama 9852: if(type(P)==7||(type(P)==4&&
9853: (type(P[0])<4||(type(P[0])==4&&length(P[0])==2&&type(P[0][0])<4&&type(P[1])<4))
9854: )) P=[P];
1.6 takayama 9855: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
9856: Keep=(Dvi==2)?1:0;
9857: if(type(P)==4&&type(F=car(P))==7){
9858: if(F=="mult"){
9859: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
9860: return G;
9861: }
9862: if(F=="show"){
9863: for(R=str_tb(0,0);G!=[];){
9864: L=car(G);
9865: I=L[0][0];J=L[0][1];
9866: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1])
9867: +"}]&=\\left\\{",R);
9868: for(L=cdr(L);;){
9869: S=car(L);
9870: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
9871: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
9872: if((L=cdr(L))==[]) break;
9873: str_tb(",\\,",R);
9874: }
9875: str_tb("\\right\\}",R);
9876: if((G=cdr(G))==[]) break;
9877: str_tb(",\\\\\n",R);
9878: }
9879: R=texbegin("align*",str_tb(0,R));
9880: if(Dvi!=-1) dviout(R|keep=Keep);
9881: return R;
9882: }
9883: if(F=="show0"){
1.26 takayama 9884: if(type(Fig=getopt(fig))>0){
9885: PP=[[-1.24747,-5.86889],[1.24747,-5.86889],[3.52671,-4.8541],[5.19615,-3],
9886: [5.96713,-0.627171],[5.70634,1.8541],[4.45887,4.01478],[2.44042,5.48127],
9887: [0,6],[-2.44042,5.48127],[-4.45887,4.01478],[-5.70634,1.8541],
9888: [-5.96713,-0.627171],[-5.19615,-3],[-3.52671,-4.8541]];
9889: PL=[[1.8,-5.2],[5.7,-1.7],[3.2,5],[-3.6,4.7],[2.2,3],[-2.8,2.8],
9890: [-1.5,-1.4],[-3.2,-2.5],[0.76,-1.4],[-2,0.2]];
9891: PC=["black,dashed","green,dashed","red,dashed","blue,dashed",
9892: "black","cyan","green","blue","red","magenta"];
9893: N=["1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"];
9894: 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],
9895: [2,9,14],[3,6,13]];
9896: TB=str_tb("\\draw\n",TB);
9897: if(type(Fig)==4){
9898: if(type(car(Fig))==1){
9899: PP=ptaffine(car(Fig)/12,PP);PL=ptaffine(car(Fig)/12,PL);
9900: Fig=cdr(Fig);
9901: }
9902: if(Fig!=[]&&length(Fig)==10) PC=Fig;
9903: }
9904: for(R=mc2grs(G,"show0"|dviout=-1),I=0;R!="";I++){ /* 頂点 */
9905: J=str_chr(R,0,",");
9906: if(J>0){
9907: S=str_cut(R,0,J-1);
9908: R=str_cut(R,J+1,1000);
9909: }else{
9910: S=R;R="";
9911: }
9912: T=(str_chr(S,0,"1")==0)?"":"[red]";
9913: str_tb(["node",T,"(",N[I],") at ",xypos(PP[I]),"{$",S,"$}\n"],TB);
9914: }
9915: for(S=PC,P=PL,I=0;I<4;I++){
9916: for(J=I+1;J<5;J++,S=cdr(S),P=cdr(P)){ /* 線の番号 */
9917: SS=car(S);
9918: if((K=str_chr(SS,0,","))>0) SS=sub_str(SS,0,K-1);
9919: str_tb(["node[",SS,"] at ",xypos(car(P)),
9920: "{$[",rtostr(I),rtostr(J),"]$}\n"],TB);
9921: }
9922: }
9923: str_tb(";\n",TB);
9924: for(I=0;I<10;I++){ /* 線 */
9925: S=car(PC);P0=car(PC);L0=car(LL);PC=cdr(PC);LL=cdr(LL);
9926: C=[N[L0[0]-1],N[L0[1]-1],N[L0[2]-1]];
9927: str_tb(["\\draw[",S,"] (", C[0],")--(",C[1],") (",
9928: C[0],")--(",C[2],") (",C[1],")--(",C[2],");\n"],TB);
9929: }
9930: R=str_tb(0,TB);
9931: if(TikZ==1&&Dvi!=-1) dviout(xyproc(R)|dviout=1,keep=Keep);
9932: return R;
9933: }
1.6 takayama 9934: for(S="",L=[];G!=[];G=cdr(G)){
9935: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
9936: TL=msort(TL,[-1,0]);
9937: if(Dvi){
9938: if(S!="") S=S+",";
9939: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
9940: if(car(T)==I) J++;
9941: else{
9942: if(I>0&&J>0){
9943: if(I>9) S=S+"("+rtostr(I)+")";
9944: else S=S+rtostr(I);
9945: if(J>1){
9946: if(J>9) S=S+"^{"+rtostr(J)+"}";
9947: else S=S+"^"+rtostr(J);
9948: }
9949: }
9950: I=car(T);J=1;
9951: }
9952: }
9953: }
9954: L=cons(TL,L);
9955: }
9956: if(Dvi){
1.43 takayama 9957: if(Dvi!=-1) dviout(S|eq=0);
1.6 takayama 9958: return S;
9959: }
9960: return reverse(L);
9961: }
9962: if(F=="sort"){
9963: G=ltov(G);L=length(G);
9964: for(I=0;I<L;I++){
9965: S=G[I][0];
9966: if(S[0][0]>S[0][1]) S=[[S[0][1],S[0][0]],S[1]];
9967: if(S[1][0]>S[1][1]) S=[S[0],[S[1][1],S[1][0]]];
9968: if(S[0]>S[1]){
9969: F=0;S=[S[1],S[0]];
9970: }
9971: if(S!=G[I][0]){
9972: if(F==0) G[I]=cons(S,anal2sp(cdr(G[I]),"swap"));
9973: else G[I]=cons(S,cdr(G[I]));
9974: }
9975: for(J=I;J>0;J--){
9976: if(G[J-1][0]<G[J][0]) break;
9977: S=G[J-1];G[J-1]=G[J];G[J]=S;
9978: }
9979: }
9980: return vtol(G);
9981: }
9982: if(F=="get"||F=="get0"){
9983: if(Dvi!=0) F="get";
9984: if(length(P)==1||type(P[1])<2){
9985: L=[];
9986: if(length(P)==1){
9987: for(I=3;I>=0;I--){
9988: for(J=4;J>I;J--) L=cons(mc2grs(G,[F,[I,J]]),L);
9989: }
9990: }else{
9991: for(I=P[1],J=4;J>=0;J--){
9992: if(I==J) continue;
9993: L=cons(mc2grs(G,[F,(I<J)?[I,J]:[J,I]]),L);
9994: }
9995: }
9996: if(Dvi){
9997: if(length(L)==10){
9998: R=ltov(L);
9999: if(R[6][0]==[1,4]){
10000: S=R[6];R[6]=R[7];R[7]=S;
10001: L=vtol(R);
10002: }
10003: }
10004: for(R=S=[],L=reverse(L);L!=[];L=cdr(L)){
10005: T=car(L);
10006: R=cons(cdr(T),R);
10007: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
10008: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
10009: }
10010: L=ltotex(R|opt="GRS",pre=S);
1.26 takayama 10011: if(type(D=getopt(div))==1 || type(D)==4) L=divmattex(L,D);
1.6 takayama 10012: if(Dvi>0) dviout(L|eq=0,keep=Keep);
10013: }
10014: return L; /* get all spct */
10015: }
10016: if(type(T=P[1])==4){
10017: if(F=="get0"&&length(P)==3&&type(I=P[1])==4&&type(J=P[2])==4){
10018: if(I[0]>I[1]) I=[I[1],I[0]];
10019: if(J[0]>J[1]) J=[J[1],J[0]];
10020: if(I[0]>I[0]){S=I;I=J;J=S;};
10021: K=lsort(I,J,0);
10022: if(length(K)==4){
1.24 takayama 10023: S=mc2grs(G,["get0",[I,J]]);
1.6 takayama 10024: return anal2sp(S,[["*",1,1],0]);
10025: }
10026: I=lsort(K,lsort(I,J,2),1);
10027: S=lsort([0,1,2,3,4],K,1);
1.24 takayama 10028: D=mc2grs(G,"deg");
1.6 takayama 10029: if(findin(4,S)<0) D=-D;
1.24 takayama 10030: J=mc2grs(G,["get0",[I,S]]);
1.6 takayama 10031: if(I[0]>S[0]) J=sp2grs(J,"swap");
10032: return anal2sp(J,[["+",0,D],["*",-1,1]]);
10033: }
10034: if(type(car(T))==4){
10035: if(T[0][0]>T[0][1]) T=[[T[0][1],T[0][0]],T[1]];
10036: if(T[1][0]>T[1][1]) T=[T[0],[T[1][1],T[1][0]]];
10037: if(T[0][0]>T[1][0]) T=[T[1],T[0]];
10038: for(PG=G;PG!=[];PG=cdr(PG))
10039: if(car(PG)[0]==T) return (F=="get")?car(PG):cdr(car(PG));
10040: return []; /* get common spct */
10041: }
1.23 takayama 10042: if(length(T)==3){
10043: T0=T;T=lsort([0,1,2,3,4],T,1);
10044: if(length(T)!=2) return [];
10045: }else T0=0;
1.6 takayama 10046: if(T[0]>T[1]) T=[T[1],T[0]];
10047: for(FT=0,PG=G;PG!=[];PG=cdr(PG)){
10048: if(car(PG)[0][0]==T){
10049: FT=1;break;
10050: }
10051: if(car(PG)[0][1]==T){
10052: FT=2;break;
10053: }
10054: }
10055: if(!FT) return [];
10056: L=anal2sp(cdr(car(PG)),[["get1",FT],0]);
1.23 takayama 10057: if(T0!=0){
10058: if((K=mc2grs(G,"deg"))!=0){
10059: if(T[1]!=4) K=-K;
10060: R=reverse(L);
10061: for(L=[];R!=[];R=cdr(R)) L=cons([car(R)[0],car(R)[1]+K],L);
10062: }
10063: T=T0;
10064: }
1.6 takayama 10065: return (F=="get")?cons(T,L):L;
10066: }
10067: }
1.27 takayama 10068: if(F=="rest"||F=="eigen"||F=="rest0"||F=="rest1"){
1.23 takayama 10069: if(F!="eigen") G=mc2grs(G,"homog");
1.26 takayama 10070: if(length(P)==1){
10071: for(R=[],I=0;I<4;I++){
10072: for(J=I+1;J<5;J++){
10073: S=mc2grs(G,[F,[I,J]]);
1.27 takayama 10074: if(S!=[]) R=cons(cons([I,J],S),R);
1.26 takayama 10075: }
10076: }
10077: R=reverse(R);
10078: if(Dvi){
10079: TB=str_tb(0,0);
1.27 takayama 10080: if(F=="rest0"||F=="rest1"){
1.26 takayama 10081: for(T=R;;){
10082: TT=car(T);
10083: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
10084: str_tb(["[",S,"]","&: "],TB);
10085: for(TR=[],TT=cdr(TT);TT!=[];TT=cdr(TT))
10086: TR=cons(car(TT)[1],TR);
10087: for(TR=qsort(TR);TR!=[];TR=cdr(TR))
10088: str_tb([s2sp(car(TR)|short=1,std=-1),"\\ \\ "],TB);
10089: if((T=cdr(T))==[]) break;
10090: str_tb("\\\\\n",TB);
10091: }
10092: }else{
10093: TB=str_tb(0,0);
10094: for(T=R;;){
10095: TT=car(T);
10096: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
10097: str_tb(["[",S,"]",":\\ "],TB);
10098: for(TR=[],TT=cdr(TT);;){
10099: T0=car(TT);
10100: str_tb(["&",my_tex_form(car(T0)),"&&\\to\\ \n",
10101: ltotex(cdr(T0)|opt="GRS")],TB);
10102: if((TT=cdr(TT))==[]) break;
10103: str_tb("\\\\\n",TB);
10104: }
10105: if((T=cdr(T))==[]) break;
10106: str_tb("\\allowdisplaybreaks\\\\\n",TB);
10107: }
10108: }
10109: R=texbegin("align*",str_tb(0,TB));
10110: if(Dvi!=-1) dviout(R|keep=Keep);
10111: }
10112: return R;
10113: }
1.23 takayama 10114: I=P[1];
10115: if(I[0]>I[1]) I=[I[1],I[0]];
10116: L=lsort([0,1,2,3,4],I,1);
1.29 takayama 10117: if(F=="rest"&&length(P)==3){
10118: J=P[2];if(J[0]>J[1]) J=[J[1],J[0]];
10119: L=lsort(L,J,1);
10120: if(length(L)!=1) return 0;
10121: return [mc2grs(G,["get0",I]),mc2grs(G,["get0",[I[0],J[0]],[I[1],J[1]]]),
10122: mc2grs(G,["get0",[I[0],J[1]],[I[1],J[0]]]),mc2grs(G,["get0",[I[0],I[1],L[0]]])];
10123: }
1.23 takayama 10124: L=[[L[0],L[1]],[L[0],L[2]],[L[1],L[2]]];
1.24 takayama 10125: if(F!="eigen"){
10126: if(I==[0,4]) L=reverse(L);
10127: else{
10128: for(V=[],J=2;J>=0;J--){
10129: if(L[J][0]==0) V=cons([L[J][1],J],V);
10130: else{
10131: for(K=4;K>=0;K--){
10132: if(findin(K,L[J])<0){
10133: V=cons([K,J],V);break;
10134: }
10135: }
10136: }
10137: }
10138: V=qsort(V);
10139: L=[L[V[0][1]],L[V[1][1]],L[V[2][1]]];
10140: }
10141: }
1.23 takayama 10142: for(LL=[],T=L;T!=[];T=cdr(T))
10143: LL=cons(mc2grs(G,["get0",[I,car(T)]]),LL);
10144: LL=reverse(LL);
10145: for(R=[],Q=mc2grs(G,["get0",I]);Q!=[];Q=cdr(Q)){
1.24 takayama 10146: for(T=[],J=2;J>=0;J--){
10147: V=anal2sp(LL[J],["get1",(I[0]<L[J][0])?1:2,car(Q)[1]]);
10148: if(F=="rest"){
10149: if(I[0]==0){
10150: if(I[1]!=4){
10151: if(L[J][1]!=4) V=anal2sp(V,["+",-car(Q)[1]]);
10152: }else if (L[J][0]!=2) V=anal2sp(V,["+",-car(Q)[1]]);
10153: }else if(L[J][0]!=0) V=anal2sp(V,["+",-car(Q)[1]]);
10154: }
10155: T=cons(V,T);
10156: }
1.23 takayama 10157: R=cons(cons(car(Q)[1],T),R);
10158: }
1.27 takayama 10159: if(F=="rest0"||F=="rest1"){
10160: for(L=[];R!=[];R=cdr(R)){
10161: TR=cdr(car(R));
1.28 takayama 10162: if(F=="rest1"&&chkspt(TR|opt="idx")==2) continue;
1.27 takayama 10163: L=cons([car(R)[0],s2sp(chkspt(TR|opt=6))],L);
10164: }
1.23 takayama 10165: R=reverse(L);
10166: }
10167: return R;
10168: }
1.6 takayama 10169: if(F=="deg"){
10170: for(S=I=0;I<3;I++){
10171: for(J=I+1;J<4;J++){
10172: L=mc2grs(G,["get0",[I,J]]);
10173: L=anal2sp(L,"val");
10174: S+=L[1];
10175: }
10176: }
10177: return S/L[0];
10178: }
1.27 takayama 10179: if(F=="spct"||F=="spct1"){
10180: K=(F=="spct")?5:6;
1.6 takayama 10181: G=mc2grs(G,"get");
1.27 takayama 10182: M=newmat(5,K);
1.6 takayama 10183: for(;G!=[];G=cdr(G)){
10184: GT=car(G);I=GT[0][0];J=GT[0][1];
10185: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
10186: L=cons(car(GT)[0],L);
10187: }
10188: L=reverse(qsort(L));
10189: M[I][J]=M[J][I]=L;
10190: }
10191: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
10192: for(I=0;I<5;I++){
10193: S=-2*D^2;
10194: for(J=0;J<5;J++){
10195: if(I==J) continue;
10196: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
10197: }
10198: M[I][I]=S;
1.27 takayama 10199: if(K==6){
10200: for(S=[],J=4;J>=0;J--)
10201: if(I!=J) S=cons(M[I][J],S);
10202: R=chkspt(S|opt=2);
10203: M[I][5]=((L=length(R))>1)?s2sp(R[L-2]|short=1):"";
10204: }
1.6 takayama 10205: }
10206: if(Dvi){
10207: S=[];
10208: for(I=4;I>=0;I--){
1.27 takayama 10209: L=(K==6)?[M[I][5]]:[];
10210: L=cons(M[I][I],L);
1.6 takayama 10211: for(J=4;J>=0;J--){
10212: if(I==J) L=cons("",L);
10213: else L=cons(s2sp([M[I][J]]),L);
10214: }
10215: S=cons(L,S);
10216: }
1.27 takayama 10217: T=(K==6)?["reduction"]:[];
10218: S=cons(append([x0,x1,x2,x3,x4,"idx"],T),S);
10219: M=ltotex(S|opt="tab",hline=[0,1,z],
1.41 takayama 10220: vline=(K==6)?[0,1,z-2,z-1,z]:[0,1,z-1,z],
1.26 takayama 10221: left=["","$x_0$","$x_1$","$x_2$","$x_3$","$x_4$"]);
1.6 takayama 10222: if(Dvi>0) dviout(M|keep=Keep);
10223: }
10224: return M;
10225: }
10226: if(F=="swap"||F=="perm"){
10227: if(F=="perm") TR=P[1];
10228: else{
10229: TR=newvect(5,[0,1,2,3,4]);
10230: K=P[1][0];L=P[1][1];
10231: TR[K]=L;TR[L]=K;
10232: if(TR[4]!=4) G=mc2grs(G,"deg");
10233: }
10234: V=newvect(2);
10235: for(L=[],T=G;T!=[];T=cdr(T)){
10236: TP=car(T)[0];
10237: for(TQ=[],I=1;I>=0;I--){
10238: V=[TR[TP[I][0]],TR[TP[I][1]]];
10239: if(V[0]>V[1]) V=[V[1],V[0]];
10240: TQ=cons(V,TQ);
10241: }
10242: if(TQ[0][0]<TQ[1][0]){
10243: L=cons(cons(TQ,cdr(car(T))),L);
10244: continue;
10245: }
10246: TQ=[[TQ[1],TQ[0]]];
10247: for(TP=cdr(car(T));TP!=[];TP=cdr(TP))
10248: TQ=cons([car(TP)[0],car(TP)[2],car(TP)[1]],TQ);
10249: L=cons(reverse(TQ),L);
10250: }
10251: return mc2grs(L,"sort");
10252: }
10253: if(F=="homog"){
10254: V=mc2grs(G,"deg");
10255: return mc2grs(G,[[[2,3],-V]]);
10256: }else if(F=="deg"){
10257: R=mc2grs(G,4);
10258: for(V=0;R!=[];R++){
10259: for(TR=cdr(R);TR!=[];TR=cdr(TR))
10260: V+=car(TR)[0]*car(TR)[1];
10261: }
10262: return -V;
10263: }
10264: }
10265: if(type(F)!=4) return 0;
10266: if(type(P[0])!=4) P=[P];
10267: for(;P!=[];P=cdr(P)){
10268: if(type((S=P[0])[0])==4){ /* addition */
10269: T=P[0][0];
10270: if(T[0]>T[1]) T=[T[1],T[0]];
10271: T1=[T[0],4];T2=[T[1],4];
10272: for(L=[],PG=reverse(G);PG!=[];PG=cdr(PG)){
10273: R=car(PG);R0=R[0];F=0;K=P[0][1];
10274: if(R0[0]==T) F=1;
10275: else if(R0[1]==T) F=2;
10276: else if(getopt(unique)!=1){
10277: K=-K;
10278: if(R0[0]==T1||R0[0]==T2) F=1;
10279: else if(R0[1]==T1||R0[1]==T2) F=2;
10280: }
10281: if(F==0) L=cons(R,L);
10282: else{
10283: R1=anal2sp(cdr(R),(F==1)?["+",K,0]:["+",0,K]);
10284: L=cons(cons(R0,R1),L);
10285: }
10286: }
10287: G=L;
10288: }else if(type(S[0])<4){
10289: if(length(S)==1){ /* mc wrt0 4:cases */
10290: U=mc2grs(G,"deg");
10291: C=P[0][0];
10292: L=[];
10293: /* [[0,1],[2,3]] : [K=[0,k],J=[i,j]], S=[k,4] : 3 cases */
10294: for(K=1;K<4;K++){
10295: J=lsort([1,2,3],[K],1);
10296: K4=[K,4];K0=[0,K];
10297: G0=mc2grs(G,["get0",[K0,J]]);
10298: LT=anal2sp(G0,["+",C,0]);
10299: G0=mc2grs(G,["get0",J]);
10300: L0=anal2sp(G0,["put1",1,0]);
10301: LT=anal2sp(LT,["add",L0]);
10302: G0=mc2grs(G,["get0",K4]);
10303: L0=anal2sp(G0,[["put1",1,0],["+",0,U]]);
10304: LT=anal2sp(LT,["add",L0]);
10305: G0=mc2grs(G,["get0",[[0,J[0]],K4]]);
10306: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
10307: LT=anal2sp(LT,["sub",L0]);
10308: G0=mc2grs(G,["get0",[[0,J[1]],K4]]);
10309: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
10310: LT=anal2sp(LT,["sub",L0]);
10311: G0=mc2grs(G,["get0",[K0,J]]);
10312: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10313: LT=anal2sp(LT,["sub",L0]);
10314: G0=mc2grs(G,["get0",[[0,4],J]]);
10315: L0=anal2sp(G0,[["+",-C,0],["get",1,0]]);
10316: LT=anal2sp(LT,[["sub",L0],0]);
10317: L=cons(cons([K0,J],LT),L);
10318: }
10319: /* [[0,1],[2,4]] : [K,I]=[[0,k],[i,4]] S=[j,k] : 6 cases */
10320: for(K=1;K<4;K++){
10321: for(I=1;I<4;I++){
10322: if(I==K) continue;
10323: for(J=1;J<4;J++) if(J!=I&&J!=K) break;
10324: I4=[I,4];S=(J<K)?[J,K]:[K,J];K0=[0,K];
10325: G0=cdr(mc2grs(G,["get",[K0,I4]]));
10326: LT=anal2sp(G0,["+",C,0]);
10327: G0=cdr(mc2grs(G,["get",I4]));
10328: L0=anal2sp(G0,["put1",1,0]);
10329: LT=anal2sp(LT,["add",L0]);
10330: G0=cdr(mc2grs(G,["get",S]));
10331: L0=anal2sp(G0,[["put1",1,0],["+",0,-C-U]]);
10332: LT=anal2sp(LT,["add",L0]);
10333:
10334: G0=cdr(mc2grs(G,["get",[[0,I],S]]));
10335: L0=anal2sp(G0,[["get",1,0],["+",0,-C-U]]);
10336: LT=anal2sp(LT,["sub",L0]);
10337: G0=cdr(mc2grs(G,["get",[[0,J],I4]]));
10338: L0=anal2sp(G0,["get",1,0]);
10339: LT=anal2sp(LT,["sub",L0]);
10340: G0=cdr(mc2grs(G,["get",[K0,I4]]));
10341: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10342: LT=anal2sp(LT,["sub",L0]);
10343: G0=cdr(mc2grs(G,["get",[[0,4],S]]));
10344: L0=anal2sp(G0,[["get",1,C],["+",-C,-C-U]]);
10345: LT=anal2sp(LT,[["sub",L0],0]);
10346: L=cons(cons([K0,I4],LT),L);
10347: }
10348: }
10349: /* [[0,4],[2,3]] : [[0,4],J]=[[0,4],[i,j]] 3 cases */
10350: for(K=3;K>0;K--){
10351: J=lsort([1,2,3],[K],1);
10352: G0=mc2grs(G,["get0",[[0,4],J]]);
10353: LT=anal2sp(G0,["+",-C,0]);
10354: G0=mc2grs(G,["get0",J]);
10355: L0=anal2sp(G0,["put1",1,-C]);
10356: LT=anal2sp(LT,["add",L0]);
10357: G0=mc2grs(G,["get0",[K,4]]);
10358: L0=anal2sp(G0,[["put1",1,-C],["+",0,U]]);
10359: LT=anal2sp(LT,["add",L0]);
10360:
10361: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
10362: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
10363: LT=anal2sp(LT,["sub",L0]);
10364: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
10365: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
10366: LT=anal2sp(LT,["sub",L0]);
10367: G0=mc2grs(G,["get0",[[0,K],J]]);
10368: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
10369: LT=anal2sp(LT,["sub",L0]);
10370: G0=mc2grs(G,["get0",[[0,4],J]]);
10371: L0=anal2sp(G0,[["get",1,C],["put",1,0]]);
10372: LT=anal2sp(LT,[["sub",L0],0]);
10373: L=cons(cons([[0,4],J],LT),L);
10374: }
10375: /* [[1,2],[3,4]] : [J,K]=[[i,j],[k,4]] 3 cases */
10376: for(K=3;K>0;K--){
10377: J=lsort([1,2,3],[K],1);
10378: if(K>1)
10379: LT=mc2grs(G,["get0",[J,[K,4]]]);
10380: else{
10381: LT=mc2grs(G,["get0",[[K,4],J]]);
10382: LT=anal2sp(LT,"swap");
10383: }
10384: G0=mc2grs(G,["get0",J]);
10385: L0=anal2sp(G0,[["put1"],["+",0,-C-U]]);
10386: LT=anal2sp(LT,["add",L0]);
10387: G0=mc2grs(G,["get0",[K,4]]);
10388: L0=anal2sp(G0,[["put1"],["+",U,0]]);
10389: LT=anal2sp(LT,["add",L0]);
10390:
10391: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
10392: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
10393: LT=anal2sp(LT,["sub",L0]);
10394: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
10395: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
10396: LT=anal2sp(LT,["sub",L0]);
10397: G0=mc2grs(G,["get0",[[0,K],J]]);
10398: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",0,-C-U]]);
10399: LT=anal2sp(LT,["sub",L0]);
10400: G0=mc2grs(G,["get0",[[0,4],J]]);
10401: L0=anal2sp(G0,[["get1",1,C],["put1"],["+",0,-C-U]]);
10402: LT=anal2sp(LT,[["sub",L0],0]);
10403: if(K==1){
10404: LT=anal2sp(LT,"swap");
10405: L=cons(cons([[K,4],J],LT),L);
10406: }else L=cons(cons([J,[K,4]],LT),L);
10407: }
10408: G=L;
10409: }else if(length(S)==2){ /* general mc */
10410: if(S[1]!=0){
10411: I=S[0];
10412: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
10413: G=mc2grs(G,[S[1]]);
10414: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
10415: }
10416: }else if(length(S)==3||length(S)==4){ /* addition */
10417: for(I=1;I<4;I++,S=cdr(S))
10418: if(S[0]) G=mc2grs(G,[[[0,I],S[0]]]);
10419: if(length(S)==1 && S[0]) /* mc */
10420: G=mc2grs(G,[S[0]]);
10421: }
10422: }
10423: }
10424: return mc2grs(G,"sort");
10425: }
10426:
10427: def mcmgrs(G,P)
10428: {
10429: if(type(G)<2){
10430: if(G>1){
10431: N=G+2;G=[];
10432: for(I=1;I<=N;I++){
10433: for(J=1;J<N;J++){
10434: if(I==J) continue;
10435: for(K=J+1;K<=N;K++){
10436: if(I==K) continue;
10437: G=cons([[[0,I],[J,K]],[1,0,0]],G);
10438: }
10439: }
10440: }
10441: for(I=1;I<=N;I++){
10442: for(J=1;J<I;J++) G=cons([[[0,I],[0,J,I]],[1,0,0]],G);
10443: for(J=I+1;J<=N;J++) G=cons([[[0,I],[0,I,J]],[1,0,0]],G);
10444: }
10445: return reverse(G);
10446: }
10447: return 0;
10448: }
10449: if(type(G)==7) G=os_md.s2sp(G);
10450: if(type(G)!=4||type(G[0])!=4) return 0;
10451: if(type(G[0][0])!=4){ /* spectre type -> GRS */
10452: G=s2sp(G|std=1);
10453: L=length(G);
10454: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
10455: V=cons(makev([L+9]),V);
10456: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
10457: if(getopt(short)!=0){
10458: V=append(cdr(V),[V[0]]);
10459: G=shortv(G,V);
10460: }
10461: R=chkspt(G|mat=1);
10462: if(R[2] != 2 || R[3] != 0 || !(R=getbygrs(G,1|mat=1))) return 0;
10463: if(getopt(anal)==1) return R; /* called by mcmgrs() */
10464: if(!(G=mcmgrs(L-2,0))) return 0;
10465: for(R=cdr(R);R!=[];R=cdr(R)){
10466: TR=car(R)[0];
10467: if(TR[0]) G=mcmgrs(G,[[TR[0]]]);
10468: G=mcmgrs(G,[cdr(TR)]);
10469: }
10470: }
10471: L=length(G);
10472: for(N=4;N<25;N++){
10473: K=N^2*(N-1)/2;
10474: if(K>L) return 0;
10475: if(K==L) break;
10476: }
10477: if(type(P)<2) return G;
10478: F=0;
10479: if(type(P)==7||(type(P)==4&&type(P[0])<4)) P=[P];
10480: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
10481: Keep=(Dvi==2)?1:0;
10482: if(type(P)==4 && type(F=car(P))==7){
10483: if(F=="mult"){
1.24 takayama 10484: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
1.6 takayama 10485: return G;
10486: }
10487: if(F=="get"||F=="get0"){
10488: if(Dvi!=0) F="get";
10489: if(length(P)==2){
10490: if(type(P[1])==4){
10491: if(type(P[1][1])==4){ /* [[,],[,]] */
10492: for(PG=reverse(G);PG!=[];PG=cdr(PG)){
10493: TP=car(PG);
10494: if(TP[0]==P[1]) return (F=="get")?TP:cdr(TP);
10495: }
10496: return [];
10497: }
10498: if(P[1][0]==0){
10499: if(length(P[1])==2){ /* [0,] */
10500: for(J=1;J<=N;J++) if(J!=P[1][1]) break;
10501: for(K=J+1;K<=N;K++) if(K!=P[1][1]) break;
10502: L=mcmgrs(G,["get0",[P[1],[J,K]]]);
10503: L=anal2sp(L,["get1",1]);
10504: }else{ /* [0,*,*] */
10505: L=mcmgrs(G,["get0",[[P[1][0],P[1][1]],P[1]]]);
10506: L=anal2sp(L,["get1",2]);
10507: }
10508: }else{ /* [,] */
10509: for(J=1;J<=N;J++) if(J!=P[1][0]&&J!=P[1][1]) break;
10510: L=mcmgrs(G,["get0",[[0,J],P[1]]]);
10511: L=anal2sp(L,["get1",2]);
10512: }
10513: L=anal2sp(L,0);
10514: if(F=="get") L=cons(P[1],L);
10515: return L;
10516: }else{ /* I */
10517: for(L=[],I=P[1],J=0;J<=N;J++){
10518: if(I==J) continue;
10519: II=(I<J)?[I,J]:[J,I];
10520: L=cons(mcmgrs(G,[F,II]),L);
10521: }
10522: }
10523: }else{
10524: for(L=[],I=0;I<N;I++){
10525: for(J=I+1;J<=N;J++) L=cons(mcmgrs(G,[F,[I,J]]),L);
10526: }
10527: }
10528: if(Dvi){
10529: for(R=S=[];L!=[];L=cdr(L)){
10530: T=car(L);
10531: R=cons(cdr(T),R);
10532: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
10533: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
10534: }
10535: L=ltotex(R|opt="GRS",pre=S);
10536: if(type(V=getopt(div))!=4) V=[];
10537: if(V==[]&&(K=length(R))>10)
10538: for(I=9;I<K;I+=9) V=cons(I,V);
10539: V=reverse(V);
10540: if(V!=[]) L=divmattex(L,V);
10541: if(Dvi>0){
10542: if(V!=[]) dviout(L|keep=Keep);
10543: else dviout(L|eq=0,keep=Keep);
10544: }
10545: }else L=reverse(L);
10546: return L;
10547: }
10548: if(F=="show"){
10549: for(R=str_tb(0,0);G!=[];){
10550: L=car(G);
10551: I=L[0][0];J=L[0][1];
10552: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1]),R);
10553: if(length(J)==3) str_tb(rtostr(J[2]),R);
10554: str_tb("}]&=\\left\\{",R);
10555: for(L=cdr(L);;){
10556: S=car(L);
10557: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
10558: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
10559: if((L=cdr(L))==[]) break;
10560: str_tb(",\\,",R);
10561: }
10562: str_tb("\\right\\}",R);
10563: if((G=cdr(G))==[]) break;
10564: str_tb(texcr(43),R);
10565: }
10566: R=texbegin("align*",str_tb(0,R));
10567: if(Dvi!=-1) dviout(R|keep=Keep);
10568: return R;
10569: }
10570: if(F=="show0"){
10571: for(C=N*(N-1)*(N-2)/2,S="",L=[];G!=[];G=cdr(G)){
10572: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
10573: TL=msort(TL,[-1,0]);
10574: if(Dvi){
10575: if(S!=""){
10576: if(--C==0) S=S+";";
10577: else S=S+",";
10578: }
10579: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
10580: if(car(T)==I) J++;
10581: else{
10582: if(I>0&&J>0){
10583: if(I>9) S=S+"("+rtostr(I)+")";
10584: else S=S+rtostr(I);
10585: if(J>1){
10586: if(J>9) S=S+"^{"+rtostr(J)+"}";
10587: else S=S+"^"+rtostr(J);
10588: }
10589: }
10590: I=car(T);J=1;
10591: }
10592: }
10593: }
10594: L=cons(TL,L);
10595: }
10596: if(Dvi){
1.43 takayama 10597: if(Dvi!=-1) dviout(S|eq=0,keep=Keep);
1.6 takayama 10598: return S;
10599: }
10600: return reverse(L);
10601: }
10602: if(F=="spct"){
10603: G=mcmgrs(G,"get");
10604: M=newmat(N+1,N+1);
10605: for(;G!=[];G=cdr(G)){
10606: GT=car(G);I=GT[0][0];J=GT[0][1];
10607: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
10608: L=cons(car(GT)[0],L);
10609: }
10610: L=reverse(qsort(L));
10611: M[I][J]=M[J][I]=L;
10612: }
10613: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
10614: for(I=0;I<=N;I++){
10615: S=-(N-2)*D^2;
10616: for(J=0;J<=N;J++){
10617: if(I==J) continue;
10618: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
10619: }
10620: M[I][I]=S;
10621: }
10622: if(Dvi){
10623: S=[];
10624: for(LS=[],I=N;I>=0;I--){
10625: L=[M[I][I]];
10626: for(J=N;J>=0;J--){
10627: if(I==J) L=cons("",L);
10628: else L=cons(s2sp([M[I][J]]),L);
10629: }
10630: S=cons(L,S);
10631: LS=cons("$x_"+rtostr(I)+"$",LS);
10632: }
10633: S=cons(append(LS,["idx"]),S);
10634: M=ltotex(S|opt="tab",hline=[0,1,z],vline=[0,1,z-1,z],left=cons("",LS));
10635: if(Dvi>0) dviout(M|keep=Keep);
10636: }
10637: return M;
10638: }
10639: if(F=="deg"){
10640: for(S=I=0;I<N-1;I++){
10641: for(J=I+1;J<N;J++){
10642: L=mcmgrs(G,["get0",[I,J]]);
10643: L=anal2sp(L,"val");
10644: S+=L[1];
10645: }
10646: }
10647: return S/L[0];
10648: }
10649: }
10650: L=[];
10651: if(type(F)!=4) return 0;
10652: if(type(P[0])!=4||length(P[0])==2) P=[P];
10653: for(;P!=[];P=cdr(P)){
10654: if(type(T=(S=car(P))[0])==4){ /* addition */
10655: if((K=P[0][1])!=0){
10656: if(T[0]>T[1]) T=[T[1],T[0]];
10657: T1=[T[0],N];T2=[T[1],N];
10658: T01=cons(0,T1);T02=cons(0,T2);
10659: for(PG=G;PG!=[];PG=cdr(PG)){
10660: R=car(PG);R0=R[0];K1=K2=0;
10661: TP=R0[0];
10662: if(TP==T) K1=K;
10663: else if(TP==T1||TP==T2) K1=-K;
10664: if(length(TP=R0[1])==2){
10665: if(TP==T) K2=K;
10666: else if(TP==T1||TP==T2) K2=-K;
10667: }else{
10668: S=0;
10669: if(findin(T[0],TP)>=0) S++;
10670: if(findin(T[1],TP)>=0) S++;
10671: if(S>0&&TP[2]==N) K2=-K;
10672: else if(S==2) K2=K;
10673: }
10674: R1=anal2sp(cdr(R),["+",K1,K2]);
10675: L=cons(cons(R0,R1),L);
10676: }
10677: G=reverse(L);
10678: }
10679: }else if(length(S)==1){ /* middle convolution */
10680: C=S[0];L=[];
10681: for(I=1;I<=N;I++){
10682: for(J=1;J<=N;J++){
10683: if(I==J) continue;
10684: for(K=J+1;K<=N;K++){ /* [[0,I],[J,K]] */
10685: if(I==K)continue;
10686: T=[[0,I],JK=[J,K]];
10687: if(I==N){
10688: LT=mcmgrs(G,["get0",T]);
10689: G0=mcmgrs(G,["get0",JK]);
10690: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10691: G0=mcmgrs(G,["get0",[0,J,K]]);
10692: LT=anal2sp(LT,["add",L0]);
10693: L0=anal2sp(G0,["put1",1,0]);
10694: LT=anal2sp(LT,["add",L0]);
10695: for(V=1;V<=N;V++){
10696: if(V==I){
10697: G0=mcmgrs(G,["get0",T]);
10698: L0=anal2sp(G0,["get",1,C]);
10699: }else if(V==J||V==K){
10700: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10701: L0=anal2sp(G0,["get",1,0]);
10702: }else{
10703: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10704: L0=anal2sp(G0,["get",1,0]);
10705: }
10706: LT=anal2sp(LT,["sub",L0]);
10707: }
10708: LT=anal2sp(LT,["+",-C,0]);
10709: }else if(K==N){
10710: LT=mcmgrs(G,["get0",T]);
10711: LT=anal2sp(LT,["+",C,0]);
10712: G0=mcmgrs(G,["get0",JK]);
10713: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10714: LT=anal2sp(LT,["add",L0]);
10715: G0=mcmgrs(G,["get0",[0,J,K]]);
10716: L0=anal2sp(G0,[["put1",1,0],["+",0,-C]]);
10717: LT=anal2sp(LT,["add",L0]);
10718: for(V=1;V<=N;V++){
10719: if(V==I){
10720: G0=mcmgrs(G,["get0",T]);
10721: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10722: }else if(V==J){
10723: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10724: L0=anal2sp(G0,[["get",1,0],["+",0,-C]]);
10725: }else if(V==N){
10726: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10727: L0=anal2sp(G0,[["get",1,C],["+",-C,-C]]);
10728: }else{
10729: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10730: L0=anal2sp(G0,["get",1,0]);
10731: }
10732: LT=anal2sp(LT,["sub",L0]);
10733: }
10734: }else{
10735: G0=mcmgrs(G,["get0",T]);
10736: LT=anal2sp(G0,["+",C,0]);
10737: G0=mcmgrs(G,["get0",JK]);
10738: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10739: LT=anal2sp(LT,["add",L0]);
10740: G0=mcmgrs(G,["get0",[0,J,K]]);
10741: L0=anal2sp(G0,["put1",1,0]);
10742: LT=anal2sp(LT,["add",L0]);
10743: for(V=1;V<=N;V++){
10744: if(V==I){
10745: G0=mcmgrs(G,["get0",T]);
10746: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10747: }else if(V==J||V==K){
10748: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10749: L0=anal2sp(G0,["get",1,0]);
10750: }else if(V==N){
10751: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10752: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
10753: }else{
10754: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10755: L0=anal2sp(G0,["get",1,0]);
10756: }
10757: LT=anal2sp(LT,["sub",L0]);
10758: }
10759: }
10760: LT=anal2sp(LT,0);
10761: L=cons(cons(T,LT),L);
10762: }
10763: T=[[0,I],(I<J)?[0,I,J]:[0,J,I]]; /* [0,I], [0,I,J] */
10764: JK=(I<J)?[I,J]:[J,I];
10765: if(I==N){
10766: G0=mcmgrs(G,["get0",T]);
10767: LT=anal2sp(G0,["+",-C,0]);
10768: G0=mcmgrs(G,["get0",JK]);
10769: L0=anal2sp(G0,[["put1",1,-C],["mult",N-3]]);
10770: LT=anal2sp(LT,["add",L0]);
10771: G0=mcmgrs(G,["get0",T[1]]);
10772: L0=anal2sp(G0,["put1",1,-C]);
10773: LT=anal2sp(LT,["add",L0]);
10774: for(V=1;V<=N;V++){
10775: if(V==J){
10776: G0=mcmgrs(G,["get0",T]);
10777: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
10778: }else if(V==N){
10779: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
10780: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
10781: }else{
10782: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10783: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
10784: }
10785: LT=anal2sp(LT,["sub",L0]);
10786: }
10787: LT=anal2sp(LT,["+",0,C]);
10788: }else if(J==N){
10789: G0=mcmgrs(G,["get0",T]);
10790: LT=anal2sp(G0,["+",C,0]);
10791: G0=mcmgrs(G,["get0",T[0]]);
10792: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10793: LT=anal2sp(LT,["add",L0]);
10794: G0=mcmgrs(G,["get0",T[1]]);
10795: L0=anal2sp(G0,["put1",1,0]);
10796: LT=anal2sp(LT,["add",L0]);
10797: for(V=1;V<=N;V++){
10798: if(V==I){
10799: G0=mcmgrs(G,["get0",T]);
10800: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10801: }else if(V==N){
10802: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
10803: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
10804: }else{
10805: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10806: L0=anal2sp(G0,["get",1,0]);
10807: }
10808: LT=anal2sp(LT,["sub",L0]);
10809: }
10810: LT=anal2sp(LT,["+",0,-C]);
10811: }else{
10812: G0=mcmgrs(G,["get0",T]);
10813: LT=anal2sp(G0,["+",C,C]);
10814: G0=mcmgrs(G,["get0",JK]);
10815: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10816: LT=anal2sp(LT,["add",L0]);
10817: G0=mcmgrs(G,["get0",T[1]]);
10818: L0=anal2sp(G0,[["put1",1,0],["+",0,C]]);
10819: LT=anal2sp(LT,["add",L0]);
10820: for(V=1;V<=N;V++){
10821: if(V==I){
10822: G0=mcmgrs(G,["get0",T]);
10823: L0=anal2sp(G0,[["get",1,0],["+",C,C]]);
10824: }else if(V==J){
10825: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
10826: L0=anal2sp(G0,[["get",1,0],["+",0,C]]);
10827: }else if(V==N){
10828: G0=mcmgrs(G,["get0",[[0,V],JK]]); L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
10829: }else{
10830: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10831: L0=anal2sp(G0,["get",1,0]);
10832: }
10833: LT=anal2sp(LT,["sub",L0]);
10834: }
10835: }
10836: LT=anal2sp(LT,0);
10837: L=cons(cons(T,LT),L);
10838: }
10839: }
10840: for(G0=G=[];L!=[];L=cdr(L)){
10841: if(length(car(L)[0][1])==2) G0=cons(car(L),G0);
10842: else G=cons(car(L),G);
10843: }
10844: G=append(G0,G);
10845: }else{
10846: if(length(S)==N-1||length(S)==N){ /* [a_1,...,a_{N-1},c] */
10847: for(I=1;I<N;S=cdr(S),I++) G=mcmgrs(G,[[0,I],car(S)]);
10848: if(length(S)==1) G=mcmgrs(G,[S[0]]);
10849: }else return 0;
10850: }
10851: }
10852: return G;
10853: }
10854:
10855:
10856: def delopt(L,S)
10857: {
1.70 takayama 10858: if((Inv=getopt(inv))!=1&&Inv!=2) Inv=0;
10859: if(Inv&&type(S)==4&&type(car(S))==4){
10860: for(R=[];L!=[];L=cdr(L)){
10861: L0=car(L)[0];
10862: for(F=0,TS=[];S!=[];S=cdr(S)){
10863: if(!F&&L0==car(S)[0]){
10864: R=cons(car(S),R);
10865: F++;
10866: continue;
10867: }
10868: TS=cons(car(S),TS);
10869: }
10870: if(!F) R=cons(car(L),R);
10871: S=reverse(TS);
10872: }
10873: R=reverse(R);
10874: return Inv==1?append(S,R):append(R,S);
10875: }
1.6 takayama 10876: for(R=[];L!=[];L=cdr(L)){
10877: if(type(car(L))!=4) F=0;
10878: else if(type(S)==4) F=(findin(car(L)[0],S)<0)?0:1;
10879: else F=(car(L)[0]==S)?1:0;
10880: if(F==Inv) R=cons(car(L),R);
10881: }
10882: return reverse(R);
10883: }
10884:
10885: def str_char(S,N,L)
10886: {
10887: if(type(S)==7){
10888: if(type(L)==1) L=asciitostr([L]);
10889: return str_chr(S,N,L);
10890: }
10891: if(type(L)==7) L=strtoascii(L)[0];
10892: if(type(S)==4){
10893: M=N;
10894: while(M-->0) S=cdr(S);
10895: M=findin(L,S);
10896: return (M>=0)?findin(L,S)+N:-1;
10897: }else if(type(S)==5){
10898: K=length(S);
10899: for(I=N;I<K;I++)
10900: if(S[I]==L) return I;
10901: }
10902: return -1;
10903: }
10904:
10905: def str_pair(S,N,I,J)
10906: {
10907: if(type(I)==7) I=(II=strtoascii(I))[0];
10908: if(type(J)==7) J=(JJ=strtoascii(J))[0];
10909: if(type(S)==7) S=strtoascii(S);
10910: if(getopt(inv)==1){
10911: if(II!=0){
10912: I=asciitostr(reverse(II));
10913: IL=length(II);
10914: }else IL=1;
10915: if(JJ!=0) J=asciitostr(reverse(JJ));
10916: R=str_pair(reverse(S),length(S)-N-1,J,I);
10917: if(R>=0) R=length(S)-IL-R;
10918: return R;
10919: }
10920: if((SJIS=getopt(sjis))!=1) SJIS=0;
10921: if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){
10922: for(;;){
10923: MJ=str_str(S,N|top=JJ,sjis=SJIS);
10924: if(MJ>=0){
10925: MI=str_str(S,II|top=N,sjis=SJIS);
10926: if(MI<0 || MI>MJ){
10927: if(C==0) return MJ;
10928: C--; N=MJ+length(II);
10929: }else if(MI>=0){
10930: C++; N=MI+length(JJ);
10931: }
10932: }
10933: return -1;
10934: }
10935: }
10936: if(type(S)==4){
10937: M=N;
10938: while(M-->0) S=cdr(S);
10939: while(S!=[]){
10940: if(car(S)==I) C++;
10941: else if(car(S)==J){
10942: if(C==0) return N;
10943: C--;
10944: }
10945: S=cdr(S);N++;
10946: }
10947: }else if(type(S)==5){
10948: K=length(S);
10949: for(T=N;T<K && C>=0;T++){
10950: if(S[T]==I) C++;
10951: else if(S[T]==J){
10952: if(C==0) return T;
10953: C--;
10954: }
10955: }
10956: }
10957: return -1;
10958: }
10959:
10960:
10961: def str_cut(S,I,J)
10962: {
10963: if(type(S)==7) return sub_str(S,I,J);
10964: if((JJ=length(S))<=J) J=JJ-1;
10965: if(type(S)==5){
10966: for(L=[],K=J; K>=I; K--) L=cons(S[K],L);
10967: }else if(type(S)==4){
10968: J-=I;
10969: while(I-->0) S=cdr(S);
10970: for(L=[];J-->=0;S=cdr(S)) L=cons(car(S),L);
10971: L=reverse(L);
10972: }
10973: return asciitostr(L);
10974: }
10975:
10976: def str_str(S,T)
10977: {
10978: if(S==0) return -1;
10979: if(type(S) == 7)
10980: S = strtoascii(S);
10981: if(type(J=getopt(top))!=1 || J<0) J=0;
10982: LS=length(S);
10983: if(LS-J<1) return -1;
10984: if(type(S)==4){
10985: LS-=(J0=J);
10986: for( ; J>0 && S!=[]; S=cdr(S),J--);
10987: }
10988: if(type(JJ=getopt(end))!=1 && JJ!=0) JJ=LS;
10989: else JJ-=J0;
10990: if((SJIS=getopt(sjis))!=1) SJIS=0;
10991: if(JJ-J<0) return -1;
10992: /* search from J-th to JJ-th */
10993: if(type(T)==1) T=[T];
10994: else if(type(T)==7) T = strtoascii(T);
10995: else if(type(T)==4 && type(T[0])>3){
10996: for(K=(KF=-1)-J0; T!=[]; F++,T=cdr(T)){
10997: JK=str_str(S,car(T)|top=J,end=JJ,sjis=SJIS);
10998: if(JK>=0){
10999: JJ=(K=JK)-1; KF=F;
11000: if(J>JJ) break;
11001: }
11002: }
11003: return [KF,J0+K];
11004: }
11005: if(type(T)==4) T=ltov(T);
11006: LT = length(T);
11007: if(LT>0){
11008: LE = LS-LT;
11009: LP = T[0];
11010: if(JJ==0 ||(type(JJ)==1 && JJ<LE)) LE=JJ;
11011: if(type(S)==5){
11012: for(; J <= LE; J++){
11013: if(S[J] != LP){
11014: if(SJIS && (V=S[J])>128){
11015: if(V<160 || (V>223 && V<240)) J++;
11016: }
11017: continue;
11018: }
11019: for(I = 1; I < LT && S[I+J] == T[I]; I++);
11020: if(I >= LT) return J;
11021: }
11022: }else if(type(S)==4){
11023: for(; J<=LE; S=cdr(S),J++){
11024: if(car(S) != LP){
1.56 takayama 11025: if(SJIS && (V=car(S))>128){
11026: if((V<160 || (V>223 && V<240))&&S!=[]) {
11027: J++;S=cdr(S);
11028: }
1.6 takayama 11029: }
11030: continue;
11031: }
11032: for(ST=cdr(S), I = 1; I < LT && car(ST) == T[I]; I++, ST=cdr(ST));
11033: if(I >= LT) return J0+J;
11034: }
11035: }
11036: }
11037: return -1;
11038: }
11039:
11040: def str_times(S,N)
11041: {
11042: if(!isint(N)) return "";
11043: if(type(S)==7){
11044: for(Tb=str_tb(0,0);N-->0;)
11045: str_tb(S,Tb);
11046: return str_tb(0,Tb);
11047: }
11048: if(type(S)==4){
11049: for(LT=[],I=0;I<N;I++){
11050: if(type(car(S))==7){
11051: LT=cons(car(S),LT);
11052: S=cdr(S);
11053: if(S==[]) S=[[""]];
11054: }else if(type(car(S))==4){
11055: ST=car(S);
11056: for(J=0;I<N;I++){
11057: if(J==length(ST)) J=0;
11058: LT=cons(ST[J++],LT);
11059: }
11060: }
11061: }
11062: return reverse(LT);
11063: }
11064: return S;
11065: }
11066:
11067: def ssubgrs(M,L)
11068: {
11069: if(type(L)==7) L=s2sp(L);
11070: for(S=0, L=L, M=M; L!=[]; L=cdr(L), M=cdr(M)){
11071: for(LT=car(L), MT=car(M); LT!=[]; LT=cdr(LT), MT=cdr(MT)){
11072: S += car(LT)*car(MT)[1];
11073: }
11074: }
11075: return S;
11076: }
11077:
11078: def s2os(S)
11079: {
11080: return str_subst(S,[["\\","\\\\"],["\"","\\\""]],0);
11081: }
11082:
11083: def l2os(S)
11084: {
11085: if(type(S)==6)
11086: S=m2ll(S);
11087: else if(type(S)==5)
11088: S=vtol(S);
11089: else if(type(S)==7) return "\""+s2os(S)+"\"";
11090: else if(type(S)<4) return rtostr(S);
11091: if(type(S)==4){
11092: for(F=0,Tb=str_tb("[",0);S!=[];S=cdr(S)){
11093: if(F++) str_tb(", ",Tb);
11094: str_tb(l2os(car(S)),Tb);
11095: }
11096: str_tb("]",Tb);
11097: return str_tb(0,Tb);
11098: }
11099: return 0;
11100: }
11101:
11102: def r2os(S)
11103: {
11104: if(type(S)==6){
11105: for(T="",S=m2ll(S);S!=[];S=cdr(S)){
11106: if(T!="") T=T+","+r2os(car(S));
11107: else T=r2os(car(S));
11108: }
11109: return "mat("+T+")\n";
11110: }else if(type(S)==5){
11111: for(T="",S=v2l(S);S!=[];S=cdr(S)){
11112: if(T!="") T=T+","+r2os(car(S));
11113: else T=r2os(car(S));
11114: }
11115: return "vect("+T+")\n";
11116: }else if(type(S)<4) return rtostr(S);
11117: else if(type(S)==4){
11118: for(T="";S!=[];S=cdr(S)){
11119: if(T!="") T=T+","+r2os(car(S));
11120: else T=r2os(car(S));
11121: }
11122: return "["+T+"]";
11123: }else if(type(S)==7) return "\""+s2os(S)+"\"";
11124: return "";
11125: }
11126:
11127: def s2euc(S)
11128: {
11129: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
11130: if((C=car(L)) == 0x1b && length(L)>1) {
11131: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
11132: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
11133: Mode = 1;
11134: } else return 0;
11135: }else if(C == 0x28 && length(L)>1) { /* ( */
11136: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
11137: Mode = 0;
11138: }else if(C == 0x49) { /* I */
11139: Mode = 2;
11140: }else{
11141: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
11142: }
11143: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
11144: L=cdr(L);
11145: }else{
11146: R=cons(0x1b,R);R=cons(C,R);
11147: }
11148: }else if(C == 0x0e) {
11149: Mode = 2;
11150: }else if(C == 0x0f) {
11151: Mode = 0;
11152: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
11153: D=car(L=cdr(L));
11154: if(D>0x20 && D<0x7f) {
11155: R=cons(ior(C,0x80),R);R=cons(ior(D,0x80),R);
11156: } else return 0;
11157: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
11158: R=cons(0x8e,R); R=cons(ior(C,0x80),R);
11159: }else if(((C>0x80 && C<0xa0) || (C>0xdf && C<0xf0)) && length(L)>1) { /* ShiftJIS */
11160: D=car(L=cdr(L));
11161: if(D>0x3f && D<0xfd && D!=0x7f) {
11162: T=sjis2jis([C,D]);
11163: R=cons(ior(T[0],0x80),R); R=cons(ior(T[1],0x80),R);
11164: }else return 0;
11165: }else if(C>0x9f && C<0xe0) { /* HanKana */
11166: R=cons(0x8e,R); R=cons(C,R);
11167: }else if(C == 0x0a){
11168: CR++;
11169: }else if(C == 0x0d){
11170: R=cons(0x0d,R);
11171: CR=0;
11172: }else{
11173: while(CR-->0) R=cons(0x0d,R);
11174: R=cons(C,R);
11175: }
11176: }
11177: while(CR-->0) R=cons(0x0d,R);
11178: return asciitostr(reverse(R));
11179: }
11180:
11181: def s2sjis(S)
11182: {
11183: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
11184: if((C=car(L)) == 0x1b && length(L)>1) {
11185: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
11186: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
11187: Mode = 1;
11188: } else return 0;
11189: }else if(C == 0x28 && length(L)>1) { /* ( */
11190: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
11191: Mode = 0;
11192: }else if(C == 0x49) { /* I */
11193: Mode = 2;
11194: }else{
11195: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
11196: }
11197: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
11198: L=cdr(L);
11199: }else{
11200: R=cons(0x1b,R);R=cons(C,R);
11201: }
11202: }else if(C == 0x0e) {
11203: Mode = 2;
11204: }else if(C == 0x0f) {
11205: Mode = 0;
11206: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
11207: D=car(L=cdr(L));
11208: if(D>0x20 && D<0x7f) {
11209: T=jis2sjis([C,D]);
11210: R=cons(T[0],R);R=cons(T[1],R);
11211: } else return 0;
11212: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
11213: R=cons(ior(C,0x80),R);
11214: }else if(C>0xa0 && C<0xff && length(L)>1) { /* EUC */
11215: D=car(L=cdr(L));
11216: if(D>0xa0 && D<0xff) {
11217: T=jis2sjis([iand(C,0x7f),iand(D,0x7f)]);
11218: R=cons(T[0],R);R=cons(T[1],R);
11219: }else return 0;
11220: }else if(C == 0x0a){
11221: CR++;
11222: }else if(C == 0x0d){
11223: R=cons(0x0a,R);R=cons(0x0d,R);
11224: CR=0;
11225: }else{
11226: while(CR-->0){
11227: R=cons(0x0a,R);R=cons(0x0d,R);
11228: }
11229: R=cons(C,R);
11230: }
11231: }
11232: while(CR-->0){
11233: R=cons(0x0a,R);R=cons(0x0d,R);
11234: }
11235: return asciitostr(reverse(R));
11236: }
11237:
11238: def r2ma(S)
11239: {
11240: return evalma(S|inv=1);
11241: }
11242:
11243: def evalma(S)
11244: {
11245: L0=["\n","\d","{","}","[","]","Log","Exp","Sinh","Cosh","Tanh","Sin","Cos","Tan",
11246: "ArcSin","ArcCos","ArcTan"];
11247: L1=["", "" ,"[","]","(",")","log","exp","sinh","cosh","tanh","sin","cos","tan",
11248: "asin", "acos", "atan"];
11249: if(getopt(inv)==1){
11250: if(type(S)==6) S=m2ll(S);
11251: else if(type(S)==5) S=vtol(S);
11252: if(type(S)==4){
11253: for(L=[];S!=[];S=cdr(S)){
11254: if(type(car(S))==6) L=cons(m2ll(car(S)),L);
11255: else if(type(car(S))==5) L=cons(vtol(car(S)),L);
11256: else L=cons(car(S),L);
11257: }
11258: S=reverse(L);
11259: }else return 0;
11260: return str_subst(rtostr(S),cdr(cdr(L1)),cdr(cdr(L0)));
11261: }
11262: if(S==0){
11263: print("Mathematica text (terminated by ;) ?");
11264: purge_stdin();
11265: Tb=str_tb(0,0);
11266: for(;;){
11267: S=get_line();
11268: str_tb(S,Tb);
11269: if(str_char(S,0,";")>=0) break;
11270: }
11271: S=str_tb(0,Tb);
11272: }
11273: /*
11274: while((P=str_chr(S,0,";"))>=0){
11275: V0=evalma(str_cut(S,0,P+1));
11276: S=str_cut(S,P+1,length(S));
11277: }
11278: if((P=str_char(S,0,"="))>=0){
11279: X=strtoascii(str_cut(S,0,P));
11280: L=length(X);
11281: for(P0=P1=-1,I=0;I<L;I++){
11282: if(L(I)<=32) continue;
11283: if(isalphanum(L[I])){
11284: if(P0<0){
11285: if(isnum(L[I])) break;
11286: P0=I;
11287: }
11288: else if(P1!=I+1) break;
11289: P1=I;
11290: }
11291: }
11292: if(I==L && P0>=0){
11293: for(I==P0;I-->0;) X=cdr(X);
11294: if((X0=car(X))>96) X0-=32;
11295: Y=[X0];X=cdr(X);
11296: for(I=P1-P0;I-->0;X=cdr(X))
11297: Y=cons(car(X),Y);
11298: Y=cons(61,Y);
11299: Var=asciitostr(reverse(Y));
11300: S=str_cut(S,P,length(S));
11301: }
11302: }
11303: */
11304: S=eval_str(str_subst(S,L0,L1));
11305: if(type(S)==4){
11306: for(L=-1,T=S;T!=[];T=cdr(T)){
11307: if(type(T0=car(T))>4) break;
11308: if(type(T0)<4){
11309: if(L>=0) break;
11310: L=-2;continue;
11311: }
11312: if(L<-2) break;
11313: if(L==-1) L=length(T0);
11314: else if(L!=length(T0)) break;
11315: }
11316: if(T==[]){
11317: if(L>0) S=s2m(S);
11318: else S=ltov(S);
11319: }
11320: }
11321: /*
11322: if(S==0 && V0!=0) return V0;
11323: if(type(Var)==7){
11324: T=rtostr(S);
11325: if(type(S)==7) T="\""+T+"\"";
11326: S=eval_str(Var+T);
11327: mycat(["Define",Var]);
11328: }
11329: */
11330: return S;
11331: }
11332:
1.73 takayama 11333: def evalcoord(L)
11334: {
11335: if(type(L)==7) L=strtoascii(L);
11336: I=str_str(L,"(");
11337: if(I>=0) J=str_pair(L,I+1,"(",")");
11338: if(I<0 || J<I) return [0,[]];
11339: for(F=1,K=I+1;K<J;K++){
11340: C=L[K];
11341: if(C>32&&(C<40||C>58)){F=0;break;}
11342: }
11343: S0=str_cut(L,I+1,J-1);
11344: for(;J>=0;J--) L=cdr(L);
11345: while(L!=[]&&car(L)<33) L=cdr(L);
11346: if(F){
11347: S="["+S0+"]";
11348: return [eval_str(S),L];
11349: }else return [[S0],L];
11350: }
11351:
11352: def readTikZ(L)
11353: {
11354: if(type(L)!=4) L=strtoascii(L);
11355: R=[];
11356: while(L!=0&&L!=[]){
11357: while(L!=[]&&car(L)<33) L=cdr(L);
11358: if(L==[]) break;
11359: if(L[0]==34){ /* % */
11360: while(L!=[]&&car(L)!=10) L=cdr(L);
11361: continue;
11362: }
11363: if(str_str(L,"\\begin")==0){
11364: for(K=str_str(L,"}");K>=0;K--) L=cdr(L);
11365: continue;
11366: }
11367: if(!(DF=str_str(L,"\\draw"))|| (DF=(str_str(L,"\\fill")+1))==1){
11368: S=T=0;
11369: I=str_str(L,"(");J=str_str(L,"[");
11370: if(J>0&&I>J){
11371: K=str_str(L,"]");
11372: S=str_cut(L,J+1,K-1);
11373: }
11374: F0=F=0;C=[];
11375: while(L!=0&&L!=[]){
11376: V=evalcoord(L);
11377: L=V[1];
11378: if(L==[]) break;
11379: if(F0){
11380: if (!F) C=cons(0,C);
11381: else if(F0!=3) C=cons(1,C);
11382: }
11383: C=cons(V[0],C);
11384: F0=F;F=0;
11385: if(L[0]==34){ /* % */
11386: while(L!=[]&&car(L)!=10) L=cdr(L);
11387: continue;
11388: }
11389: if(!str_str(L,"..")){ /* .. */
11390: L=cdr(L);L=cdr(L);
11391: F=1;
11392: }else if(!str_str(L,"--")){ /* -- */
11393: L=cdr(L);L=cdr(L);
11394: F=2;
11395: }
11396: while(L!=[]&&car(L)<33) L=cdr(L);
11397: if(L==[]){L=0; break;}
11398: if(!str_str(L,"cycle")){
11399: if(F==2) C=cons(1,C);
11400: C=cons(-1,C);
11401: F0=F=0;
11402: continue;
11403: }
11404: if(!str_str(L,"and")||!str_str(L,"control"))
11405: F=3; /* control, and */
11406: else if(car(L)==59){ /* ; */
11407: L=cdr(L);
11408: break;
11409: }else if(isalpha(car(L))){
11410: for(T=[];isalpha(car(L));L=cdr(L)) T=cons(car(L),T);
11411: while(car(L)<33) L=cdr(L);
11412: if(car(L)==40){
11413: F0=0;continue;
11414: }
11415: T=cons(32,T);
11416: while(car(L)!=40 && car(L)!=59){ /* ( ; */
11417: T=cons(car(L),T);
11418: if((L=cdr(L))==[]){L=0;break;}
11419: }
11420: T=asciitostr(reverse(T));
11421: if(car(L)==59){
11422: L=cdr(L);
11423: break;
11424: }
11425: F0=0;continue;
11426: }else if(F!=1&&F!=2){
11427: L=0;break;
11428: }
11429: }
11430: if(T){
1.74 ! takayama 11431: if(length(C)==2){
! 11432: if(!S) S=
! 11433: S=(!S)?["",T]:[S,T];
! 11434: }else L=0;
! 11435: }
! 11436: S=(!S)? []:[["opt",S]];
! 11437: if(DF) S==cons(["cmd","fill"],S);
! 11438: if(T&&L){
! 11439: if(L) R=cons([3,S,C[0],C[1]],R);
! 11440: }else
! 11441: R=cons([1,S,reverse(C)],R);
! 11442: }else if(!str_str(L,"\\node")){
1.73 takayama 11443: U=0;
11444: I=str_str(L,"(");J=str_str(L,"[");
11445: if(J>0&&I>J){
11446: K=str_str(L,"]");
11447: U=str_cut(L,J+1,K-1);
11448: }
11449: V=evalcoord(L);
11450: C=V[0];L=V[1];
11451: J=str_str(L,"{");K=str_pair(L,J+1,"{","}");
11452: S=str_cut(L,J+1,K-1);
11453: if(U) S=[U,S];
11454: R=cons([2,[],C,S],R);
11455: for(;K>=0;K--) L=cdr(L);
11456: K=str_str(L,";");
11457: for(;K>=0;K--) L=cdr(L);
11458: }else L=0;
11459: }
11460: if(!L){
11461: mycat("Can't understand!");
11462: return -1;
11463: }
11464: return R;
11465: }
11466:
1.6 takayama 11467: def i2hex(N)
11468: {
11469: Opt=getopt();
11470: if(type(N)==4 && isint(car(N))){
11471: #ifdef USEMODULE
11472: L=mtransbys(os_md.i2hex,N,[]|option_list=Opt);
11473: #else
11474: L=mtransbys(i2hex,N,[]|option_list=Opt);
11475: #endif
11476: return rtostr(L);
11477: }
11478: if(!isint(N) || N<0) return 0;
11479: if(!N) L=[];
11480: else{
11481: Cap=(getopt(cap)==1)?32:0;
11482: for(L=[];N!=0;N=ishift(N,4)){
11483: J=iand(N,15);
11484: L=cons(((J>9)?(87-Cap):48)+J,L);
11485: }
11486: }
11487: if(!isint(Min=getopt(min))) Min=2;
11488: for(Min-=length(L);Min-->0;)
11489: L=cons(48,L);
11490: if(getopt(num)==1){
11491: L=cons(120,L);L=cons(48,L);
11492: }
11493: return asciitostr(L);
11494: }
11495:
11496: def sjis2jis(L)
11497: {
11498: L1=L[1];
11499: if((L0=L[0])<=0x9f){
11500: if(L1<0x9f) L0=L0*2-0xe1;
11501: else L0=(L0*2)-0xe0;
11502: }else{
11503: if(L1<0x9f) L0=L0*2-0x161;
11504: else L0=L0*2-0x160;
11505: }
11506: if(L1<0x7f) return [L0,L1-0x1f];
11507: else if(L1<0x9f) return [L0,L1-0x20];
11508: return [L0,L1-0x7e];
11509: }
11510:
11511: def jis2sjis(L)
11512: {
11513: L1=L[1];
11514: if(iand(L0=L[0],1)){
11515: if(L1<0x60) L=[L1+0x1f];
11516: else L=[L1+0x20];
11517: }else L=[L1+0x7e];
11518: if(L0<0x5f) return cons(ishift(L0+0xe1,1),L);
11519: return cons(ishift(L0+0x161,1),L);
11520: }
11521:
11522: def verb_tex_form(P)
11523: {
11524: L = reverse(strtoascii(rtostr(P)));
11525: for(SS = []; L != []; L = cdr(L)){
11526: Ch = car(L); /* ^~\{} */
11527: if(Ch == 92 || Ch == 94 || Ch == 123 || Ch == 125 || Ch == 126){
11528: SS = append([92,Ch,123,125],SS); /* \Ch{} */
11529: if(Ch != 94 && Ch != 126) /* \char` */
11530: SS = append([92,99,104,97,114,96],SS);
11531: continue;
11532: }
11533: SS = cons(Ch, SS);
11534: if((Ch >= 35 && Ch <= 38) || Ch == 95) /* #$%&_ */
11535: SS = cons(92, SS); /* \Ch */
11536: }
11537: return asciitostr(SS);
11538: }
11539:
11540: def tex_cuteq(S,P)
11541: {
11542: if(P==0) return 0;
11543: if(S[P]==125){ /* } */
11544: if((Q=str_pair(S,P-1,"{","}"|inv=1))<0) return -1;
11545: if(Q<2||S[Q-1]!=95) return Q;
11546: return tex_cuteq(S,Q-2);
11547: }
11548: if(!isalphanum(S[Q=P--])) return -1;
11549: while(P>0&&isalphanum(S[P])) P--;
11550: if(S[P]==92){ /* \ */
11551: if(P==0) return P;
11552: else P--;
11553: }
11554: if(S[P]!=95||P==0) return Q; /* _ */
11555: return tex_cuteq(S,P-1);
11556: }
11557:
11558:
11559: def texket(S)
11560: {
11561: if(!isint(F=getopt(all))) F=0;
11562: if(type(S)==7){
11563: L=str_len(S);
11564: SS=strtoascii(S);
11565: }else{
11566: L=length(S);
11567: SS=S;
11568: }
11569: for(T="",I=I0=0;I<L-1;){
11570: J=str_char(SS,I,"(");
11571: if(J<0) break;
11572: if(J<L-1 && J>4 && str_str(SS,"\\left"|top=J-5,end=J-1)>=0){
11573: I=J+1;continue;
11574: }
11575: if((K=str_pair(SS,J+1,"(",")"))>=0){
11576: KK=str_char(SS,J+2,"(");
11577: if(KK>K||KK<0){
11578: if(F!=1){
11579: if(!F){
11580: for(N=J+1;N<K;N++) /* + - _ { } */
11581: if(!isalphanum(P=SS[N])&&findin(P,[32,43,45,95,123,125])<0) break;
11582: }else N=K;
11583: if(N==K){
11584: I=K+1;continue;
11585: }
11586: }
11587: T=T+str_cut(SS,I0,J-1)+"\\left"+str_cut(SS,J,K-1)+"\\right)";
11588: I0=I=K+1;
11589: }else{
11590: T=T+str_cut(SS,I0,J-1)+"\\left("+texket(str_cut(SS,J+1,K-1)|all=F) +"\\right)";
11591: I0=I=K+1;
11592: }
11593: }else break;
11594: }
11595: return T+str_cut(SS,I0,L);
11596: }
11597:
11598:
11599: def my_tex_form(S)
11600: {
11601: if(getopt(skip) != 1){
11602: if(type(S)==1 && S<0) return "-"+print_tex_form(-S);
11603: if(type(S)==6) return mtotex(S);
11604: S = print_tex_form(S);
11605: for(F=Top=0;(L=str_str(S,"\\verb`"|top=Top))>=0;Top=LV+1){
11606: F++;
11607: if(Top==0) Tb = string_to_tb("");
11608: LV = str_chr(S, L+6, "`");
11609: if(LV<0) LV=str_len(S);
11610: str_tb([my_tex_form(sub_str(S, Top, L-1)|skip=1), "\\texttt{"], Tb);
11611: str_tb([verb_tex_form(sub_str(S,L+6, LV-1)),"}"], Tb);
11612: Top=LV+1;
11613: }
11614: if(F>0){
11615: str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb);
11616: return tb_to_string(Tb);
11617: }
11618: }
11619: if(S==0) return "";
11620: S = ltov(strtoascii(S));
11621: L = length(S)-1;
11622: while(L >= 1 && S[L] == 10)
11623: L--;
11624: if((Fr=getopt(frac))!=0 && Fr!=1) Fr=2;
11625: for(I = L+1, T = K = 0, SS = []; --I >= 0; ){
11626: if(S[I] == 32 && I!=L){
11627: if(I==L) continue;
11628: if(findin(S[I+1], [32,40,41,43,45,123,125]) >= 0 /* " ()+-{}" */
11629: || (S[I+1] >= 49 && S[I+1] <= 57)) /* 1 - 9 */
11630: if(I == 0 || S[I-1] >= 32) continue;
11631: }
11632: if(Fr && S[I]>=48 && S[I]<=57){ /* 2/3 -> \tfrac{2}{3} */
11633: for(K=0,II=I; II>=0; II--){
11634: if(S[II]>=48 && S[II]<=57) continue;
11635: if(S[II]==47){ /* / */
11636: if(K>0) break;
11637: K=II;
11638: }else break;
11639: }
11640: if(K>II+1){
11641: SS=cons(125,SS);
11642: for(J=I; J>K; J--) SS=cons(S[J],SS);
11643: if(AMSTeX){
11644: SS=cons(123,SS);SS=cons(125,SS);
11645: }else{
11646: for(J=[114,101,118,111,92];J!=[];J=cdr(J)) /* \over */
11647: SS=cons(car(J),SS);
11648: }
11649: for(J=K-1;J>II;J--) SS=cons(S[J],SS);
11650: SS=cons(123,SS);
11651: if(AMSTeX){
11652: J=(Fr==2)?[99,97,114,102,116,92]:[99,97,114,102,92];
11653: for(;J!=[];J=cdr(J)) /* \tfrac */
11654: SS=cons(car(J),SS);
11655: }
11656: I=II+1;
11657: }else{
11658: for(;I>II;I--) SS = cons(S[I], SS);
11659: I++;
11660: }
11661: continue;
11662: }
11663: SS = cons(S[I], SS);
11664: }
1.52 takayama 11665: SS=str_subst(SS,"\n\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
1.6 takayama 11666: SS=str_subst(SS,"\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
11667: Subst=getopt(subst);
11668: Sub0=["{asin}","{acos}","{atan}"];
11669: Sub1=["\\arcsin ","\\arccos","\\arctan "];
11670: if(type(Subst) == 4){
11671: Sub0=append(Sub0,Subst[0]);Sub1=append(Sub1,Subst[1]);
11672: }
11673: SS = str_subst(SS,Sub0,Sub1|raw=1);
11674: S = ltov(SS);
11675: L = length(S);
11676: SS = [];
11677: while(--L >= 0){
11678: if(S[I=L] == 125){
11679: while(--I >= 0 && S[I] == 125);
11680: J = 2*I - L;
11681: if(J >= 0 && S[I] != 123){
11682: for(K = J; K < I && S[K] == 123; K++);
11683: if(K == I){
11684: if(J-- <= 0 || S[J] < 65 || S[J] > 122 || (S[J] > 90 && S[J] < 97)){
11685: SS = cons(S[I],SS);
11686: L = J+1;
11687: continue;
11688: }
11689: }
11690: }
11691: }
11692: SS = cons(S[L],SS);
11693: }
11694: RT=getopt(root);
11695: for(Top=0;;Top++){ /* ((x+1))^{y} , 1/y=2,3,...,9 */
11696: #if 1
11697: P=str_str(SS,["))^","^{\\tfrac{1}"]|top=Top);
11698: if(P[0]<0) break;
11699: Sq=0;
11700: if(P[0]==0){
11701: P=P[1];
11702: if((Q=str_pair(SS,P,"(",")"|inv=1))<0||SS[Q+1]!=40) continue;
11703: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
11704: && SS[P+14]==125){
11705: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
11706: }
11707: F=2;
11708: }else{
11709: P=P[1];
11710: if(SS[P+12]!=125||(Sq=(SS[P+11]-48))<2||Sq>9) break;
11711: if(SS[P-1]==125){
11712: if((Q=str_pair(SS,P-2,"{","}"|inv=1))<0) break;
11713: if(Q>1&&SS[Q-1]==95){
11714: if((Q=tex_cuteq(SS,Q-2))<0) break;
11715: F=0;
11716: }else F=1;
11717: }else{
11718: if(!isalphanum(SS[Q=P-1]) || (Q=tex_cuteq(SS,Q))<0) break;
11719: F=0;
11720: }
11721: if(RT!=2&&P-Q>32) break;
11722: }
11723: #else
11724: if((P=str_str(SS,"))^"|top=Top))<0 || (Q=str_pair(SS,P,"(",")"|inv=1))<0) break;
11725: else F=2;
11726: Sq=0;
11727: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
11728: && SS[P+14]==125){
11729: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
11730: }
11731: #endif
11732: for(I=0,S=[];SS!=[];SS=cdr(SS),I++){
11733: if(I==Q){
11734: if(Sq){
11735: S=append([116,114,113,115,92],S);
11736: if(Sq>2) S=append([93,Sq+48,91],S);
11737: S=cons(123,S);
11738: if(F==2) SS=cdr(SS);
11739: else if(F==0) S=cons(car(SS),S);
1.68 takayama 11740: }else if(F==2&&P-Q==3){ /* (2)^x -> 2^x */
1.6 takayama 11741: SS=cdr(SS);SS=cdr(SS);
11742: S=cons(123,S);S=cons(car(SS),S);S=cons(125,S);
11743: SS=cdr(SS);SS=cdr(SS);
11744: I+=3;
11745: }
11746: continue;
11747: }else if(I==P){
11748: if(Sq){
11749: if(F>0) S=cdr(S);
11750: S=cons(125,S);
11751: if(F==2) SS=cdr(SS);
11752: for(J=0;J<12;J++) SS=cdr(SS);
11753: }
11754: continue;
11755: }
11756: S=cons(car(SS),S);
11757: }
11758: SS=reverse(S);
11759: Top=P;
11760: }
1.68 takayama 11761: for(F=G=0,S=[];SS!=[];SS=cdr(SS)){ /* 22^x -> 2\cdot 2^x */
11762: if(F==1&&G!=-1&&car(SS)==123 && length(SS)>1 && isnum(SS[1]))
11763: S=append([116,111,100,99,92],S);
11764: G=F;
11765: if(car(SS)==125||car(SS)==95) F=-1;
11766: else F=isnum(car(SS));
11767: S=cons(car(SS),S);
11768: }
11769: S=asciitostr(reverse(S));
11770: /* S=asciitostr(SS); */
1.6 takayama 11771: if((K=getopt(ket))==1) S=texket(S);
11772: else if(K==2) S=texket(S|all=1);
11773: return S;
11774: }
11775:
11776: def smallmattex(S)
11777: {
11778: return str_subst(S,[["\\begin{pmatrix}","\\left(\\begin{smallmatrix}"],
11779: ["\\end{pmatrix}","\\end{smallmatrix}\\right)"],
11780: ["\\begin{Bmatrix}","\\left\\{\\begin{smallmatrix}"],
11781: ["\\end{Bmatrix}","\\end{smallmatrix}\\right\\}"],
11782: ["\\begin{bmatrix}","\\left[{\\begin{smallmatrix}"],
11783: ["\\end{bmatrix}","\\end{smallmatrix}\\right]"],
11784: ["\\begin{vmatrix}","\\left|\\begin{smallmatrix}"],
11785: ["\\end{vmatrix}","\\end{smallmatrix}\\right|"],
11786: ["\\begin{Vmatrix}","\\left\\|\\begin{smallmatrix}"],
11787: ["\\end{Vmatrix}","\\end{smallmatrix}\\right\\|"],
11788: ["\\begin{matrix}","\\begin{smallmatrix}"],
11789: ["\\end{matrix}","\\end{smallmatrix}"]],0);
11790: }
11791:
11792:
11793: def divmattex(S,T)
11794: {
11795: TF=["matrix","pmatrix","Bmatrix","bmatrix","vmatrix","Vmatrix"];
11796: TG=[0,"(","\\{","[","|","\\|"];
11797: TH=[0,")","\\}","]","|","\\|"];
11798: if(type(S)!=7) S=mtotex(S);
11799: S=strtoascii(S0=S);
11800: if((P0=str_str(S,"\\begin{"))<0 || (P1=str_str(S,"}"|top=P0+7))<0)
11801: return S0;
11802: F=str_cut(S,P0+7,P1-1);
11803: if((K=findin(F,TF))<0) return S0;
11804: Q=str_str(S,"\\end{"+F+"}");
11805: if(Q<0) return S0;
11806: for(J=P1+1;S[J]<33;J++);
11807: for(L0=L=[],I=J;J<Q;J++){
11808: if(S[J]==38){ /* & */
11809: if(I>=J) L0=cons(0,L0);
11810: else L0=cons(str_cut(S,I,J-1),L0);
11811: I=J+1;
11812: }
11813: if(S[J]==92&&S[J+1]==92){ /* \\ */
11814: if(I>=J) L0=cons(0,L0);
11815: else L0=cons(str_cut(S,I,J-1),L0);
11816: L=cons(reverse(L0),L);
11817: L0=[];
11818: J++;
11819: for(I=J+1;S[I]<33;I++);
11820: }
11821: }
11822: J--;
11823: if(S[J]<33) J--;
11824: if(I<=J) L0=cons(str_cut(S,I,J),L0);
11825: if(length(L0)>0) L=cons(reverse(L0),L);
11826: L=lv2m(reverse(L)); /* get matrix */
11827: if(T==0) return L;
1.26 takayama 11828: if(type(T)==1) T=[T];
1.6 takayama 11829: Size=size(L);S0=Size[0];
11830: if(type(T[0])!=4){
11831: S1=Size[1];
11832: T=append(T,[S1]);
11833: for(TT=[],I=0;T!=[];T=cdr(T)){
11834: J=car(T);
11835: if(J>S1) J=S1;
11836: for(T0=[];J>I;J--) T0=cons(J-1,T0);
11837: if(T0!=[]) TT=cons(T0,TT);
11838: I=car(T);
11839: }
11840: T=reverse(TT);
11841: }
11842: SS=length(T);
11843: St=str_tb(0,0);
11844: if(SS==1) St=str_tb("\\begin{"+F+"}\n",St);
11845: else{
11846: if(K>0) St=str_tb("&\\left"+TG[K],St);
11847: St=str_tb("\\begin{matrix}\n",St);
11848: }
11849: for(;T!=[];T=cdr(T)){
11850: for(I=0;I<S0;I++){
11851: for(J=0,TT=car(T);TT!=[];TT=cdr(TT),J++){
11852: if(J>0) St=str_tb("&",St);
11853: if(L[I][car(TT)]!=0) St=str_tb(L[I][car(TT)],St);
11854: }
11855: if(I<S0-1) St=str_tb("\\\\",St);
11856: St=str_tb("\n",St);
11857: }
11858: if(length(T)>1)
11859: St=str_tb("\\end{matrix}\\right.\\\\\n&\\quad\\left.\\begin{matrix}\n",St);
11860: else{
11861: if(SS==1) St=str_tb("\\end{"+F+"}\n",St);
11862: else St=str_tb("\\end{matrix}\\right"+TH[K]+"\n",St);
11863: }
11864: }
11865: S=str_tb(0,St);
11866: if(SS==1) return S;
11867: return texbegin("align*",S);
11868: }
11869:
11870: def str_subst(S, L0, L1)
11871: {
11872: if(type(S) == 7)
11873: S = strtoascii(S);
11874: if(type(S) == 4)
11875: S = ltov(S);
11876: SE = length(S);
11877: if(L1 == 0){
11878: for(L1 = L = [], L0 = reverse(L0); L0 != []; L0 = cdr(L0)){
11879: L = cons(car(L0)[0], L);
11880: L1 = cons(car(L0)[1], L1);
11881: }
11882: L0 = L;
11883: }
11884: if(type(L0)==7) L0 = [strtoascii(L0)];
11885: else{
11886: for(LT = []; L0 != []; L0 = cdr(L0))
11887: LT = cons(strtoascii(car(L0)), LT);
11888: L0 = ltov(LT);
11889: }
11890: E0 = length(L0);
11891: if(type(L1)==7) L1 = [strtoascii(L1)];
11892: else{
11893: for(LT = []; L1 != []; L1 = cdr(L1))
11894: LT = cons(strtoascii(car(L1)), LT);
11895: L1 = ltov(LT);
11896: }
11897: if(getopt(inv)==1){
11898: L2=L0;L0=L1;L0=L2;
11899: }
11900: if((SJIS=getopt(sjis))!=1) SJIS=0;
11901: for(J = JJ = 0, ST = []; J < SE; J++){
11902: SP = S[J];
11903: for(I = E0-1; I >= 0; I--){
11904: if(SP != L0[I][0] || J + (K = length(L0[I])) > SE)
11905: continue;
11906: while(--K >= 1)
11907: if(L0[I][K] != S[J+K]) break;
11908: if(K > 0) continue;
11909: for(KE = length(L1[I]), K = 0 ;K < KE; K++)
11910: ST = cons(L1[I][K],ST);
11911: J += length(L0[I])-1;
11912: break;
11913: }
11914: if(I < 0){
11915: ST = cons(S[J],ST);
11916: if(SJIS && (V=S[J])>128){
11917: if(V<160 || (V>223 && V<240)) ST = cons(S[J++],ST);
11918: }
11919: }
11920: }
11921: if(getopt(raw)==1) return reverse(ST);
11922: return asciitostr(reverse(ST));
11923: }
11924:
11925: def dviout0(L)
11926: {
1.70 takayama 11927: Cmd=["TikZ","TeXLim","TeXEq","DVIOUT","XYPrec","XYcm","XYLim","Canvas","TeXPages"];
1.6 takayama 11928: if(type(Opt=getopt(opt))==7){
11929: if((F=findin(Opt,Cmd)) < 0) return -1;
11930: if(L==-1){
11931: if(F<=3){
11932: if(F==0) V=TikZ;
11933: else if(F==1) V=TeXLim;
11934: else if(F==2) V=TeXEq;
11935: else V=iand(DVIOUTF,1);
11936: }else{
11937: if(F==4) V=XYPrec;
11938: else if(F==5) V=XYcm;
11939: else if(F==6) V=XYLim;
1.70 takayama 11940: else if(F==7) V=Canvas;
11941: else if(F==8) V=TeXPages;
1.6 takayama 11942: }
11943: return V;
11944: }
11945: if(F==0) TikZ=L;
11946: else if(F==2) TeXEq=L;
11947: else if(F==3){
11948: if(iand(DVIOUTF,1)==L)
11949: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
11950: else dviout0(4);
11951: return 1;
11952: }else if(F==7&&type(L)==4)
11953: Canvas=L;
11954: else if(L>0){
11955: if(F==1) TeXLim=L;
11956: else if(F==4) XYPrec=L;
11957: else if(F==5) XYcm=L;
11958: else if(F==6) XYLim=L;
1.70 takayama 11959: else if(F==8) TeXPages=L;
1.6 takayama 11960: }
11961: mycat0([Cmd[F],"=",L],1);
11962: return 1;
11963: }
11964: if(type(L) == 4){
11965: for( ; L != []; L = cdr(L)) dviout0(car(L));
11966: return 1;
11967: }
11968: if(type(L) == 7){
11969: if(L=="") dviout(" \n"|keep=1);
11970: else if(L=="cls") dviout0(0);
11971: else if(L=="show") dviout(" ");
11972: else if(L=="?") dviout0(3);
11973: else dviout("\\"+L+"\n"|keep=1);
11974: return 1;
11975: }
11976: if(L == 0)
11977: dviout(" "|keep=1,clear=1);
11978: else if(L == 1)
11979: dviout(" ");
11980: else if(L == 2)
11981: dviout(" "|clear=1);
11982: else if(L>10)
11983: dviout("\\setcounter{MaxMatrixCols}{"+rtostr(L)+"}%"|keep=1);
11984: else if(L < 0)
11985: dviout(" "|delete=-L,keep=1);
11986: else if(L == 3){
11987: mycat0(["DIROUT =\"", DIROUT,"\""],1);
11988: mycat0(["DVIOUTH=\"", DVIOUTH,"\""],1);
11989: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
11990: mycat0(["DVIOUTB=\"", DVIOUTB,"\""],1);
11991: mycat0(["DVIOUTL=\"", DVIOUTL,"\""],1);
11992: mycat(["Canvas =", Canvas]);
11993: mycat(["TeXLim =", TeXLim]);
1.70 takayama 11994: mycat(["TeXPages =", TeXPages]);
1.6 takayama 11995: mycat(["TeXEq =", TeXEq]);
11996: mycat(["AMSTeX =", AMSTeX]);
11997: mycat(["TikZ =", TikZ]);
11998: mycat(["XYPrec =", XYPrec]);
11999: mycat(["XYcm =", XYcm]);
12000: mycat(["XYLim =", XYLim]);
12001: }else if(L==4){
12002: Tmp=DVIOUTA; DVIOUTA=DVIOUTB; DVIOUTB=Tmp;
12003: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
12004: DVIOUTF++;
12005: }else if(L==5){
12006: if(!iand(DVIOUTF,1)) dviout0(4);
12007: }else if(L==6){
12008: TikZ=1;mycat("TikZ=1");
12009: }else if(L==7){
12010: TikZ=0;mycat("TikZ=0");
12011: }
12012: return 1;
12013: }
12014:
12015: def myhelp(T)
12016: {
12017: /* extern DVIOUT; */
12018: /* extern HDVI; */
12019: /* extern DVIOUTH; */
12020:
12021: if(type(T)==2){
12022: if(T==getbygrs){
12023: getbygrs(0,0);
12024: return 0;
12025: }
12026: else if(T==m2mc){
12027: m2mc(0,0);
12028: return 0;
12029: }
12030: else if(T==mgen){
12031: mgen(0,0,0,0);
12032: return 0;
12033: }
12034: else T=rtostr(T);
12035: }
12036: if(type(T)==4 && typeT[0]==7){
12037: if(length(T)==2 && type(T[1])==1){
12038: DVIOUTH="start "+T[0]+" -"+rtostr(T[1])+"-hyper:0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #r:%LABEL%";
12039: }else if(str_len(T[0])>2) DVIOUTH=T[0];
12040: mycat(["DVIOUTH="+DVIOUTH,"\nmyhelp(fn) is set!"]);
12041: return 0;
12042: }
12043: if(T==0){
12044: mycat([
12045: "myhelp(t) : show help\n",
12046: #ifdef USEMODULE
12047: " t : -1 (dvi), 1 (pdf) or os_md.getbygrs, os_md.m2mc, os_md.mgen\n",
12048: #else
12049: " t : -1 (dvi), 1 (pdf) or getbygrs, m2mc, mgen\n",
12050: #endif
12051: " \"fn\" : Help of the function fn\n",
12052: " [path,n] : path of dviout, n = # dviout\n",
12053: " [DVIOUTH] : Way to jump to the help of a function\n",
12054: " default: start dviout -2 \"%ASIRTOOT%\\help\\os_muldif.dvi\" #r:%LABEL%"
12055: ]);
12056: return 0;
12057: }
12058: if(type(T)==7){
12059: if(str_str(T,"os_md.")==0) T=str_cut(T,6,str_len(T)-1);
12060: Dr=str_subst(DVIOUTH,["%ASIRROOT%","%LABEL%"],[get_rootdir(),"r:"+str_subst(T,"_","")]);
12061: shell(Dr);
12062: return 0;
12063: }
12064: Dr=get_rootdir();
12065: if(T==-1) Dr+="\\help\\os_muldif.dvi";
12066: else Dr+="\\help\\os_muldif.pdf";
12067: if(!isMs()) Dr=str_subst(Dr,"\\","/");
12068: shell(Dr);
12069: return 0;
12070: }
12071:
12072: def isMs()
12073: {
12074: if(type(Tmp=getenv("TEMP"))!=7) {
12075: if (type(Tmp=getenv("TMP")) != 7) Tmp=getenv("HOME");
12076: }
12077: if(type(Tmp)==7 && str_chr(Tmp,0,"\\")==2) return 1;
12078: else return 0;
12079: }
12080:
12081: def tocsv(L)
12082: {
12083: if(type(L)==6) L=m2ll(L);
12084: else if(type(L)==5) L=vtol(L);
12085: Null=getopt(null);
12086: Tb=str_tb(0,0);
12087: for(LL=L; LL!=[]; LL=cdr(LL)){
12088: LT=car(LL);
12089: if(type(LT)==5) LT=vtol(LT);
12090: if(type(LT)<4) LT=[LT];
12091: for(N=0; LT!=[]; LT=cdr(LT),N++){
1.55 takayama 12092: if(N) str_tb(",",Tb);
1.6 takayama 12093: if((T=car(LT))==Null) continue;
12094: if(type(T)==7){
12095: K=str_len(T);
12096: T=str_subst(T,["\""],["\"\""]);
12097: if(str_len(T)>K||str_char(T,0,",")>=0) T="\""+T+"\"";
12098: str_tb(T,Tb);
12099: }else str_tb(rtostr(T),Tb);
12100: }
12101: str_tb("\n",Tb);
12102: }
1.16 takayama 12103: S=str_tb(0,Tb);
12104: if(type(EXE=getopt(exe))!=1&&EXE!=0&&type(EXE)!=7) return S;
12105: if(type(F)!=7){
1.18 takayama 12106: fcat(-1,0);
1.16 takayama 12107: F="risaout";
12108: if(EXE>=2&&EXE<=9) F+=rtostr(EXE);
12109: F=DIROUTD+F+".csv";
12110: }else F=S;
12111: if(EXE!=0 && access(F)) remove_file(F);
12112: fcat(F,S|exe=1);
12113: return 1;
1.6 takayama 12114: }
12115:
12116: def readcsv(F)
12117: {
12118: if((ID=open_file(F))<0) return -1;
12119: SJIS=isMs();
12120: L=[];
12121: if(type(V=getopt(eval))!=4){
12122: if(V=="all") V=1;
12123: else if(type(V)==1) V=[V];
12124: else V=[];
12125: }
1.9 takayama 12126: Eq=getopt(eq);
1.6 takayama 12127: Sp=getopt(sp);
12128: if(type(T=getopt(col))!=1) T=0;
12129: Null=getopt(null);
1.9 takayama 12130: if(type(Null)<0) Null=(Eq==1)?0:"";
1.6 takayama 12131: while((S=get_line(ID))!=0){
12132: S=strtoascii(S);
12133: N=length(S);
12134: for(I=J=F=0,LL=LT=[];I<N;I++){
12135: C=S[I];
12136: if(F==0){
12137: if(C<=32) continue;
12138: if(C==34){F=2;continue;}
12139: F=1;
12140: }
12141: if(F==2 && C==34){
12142: if(I<N-1&& S[I+1]==34){
12143: LT=cons(34,LT);I++;continue;
12144: }
12145: F=-2;
12146: }
12147: if(F==1){
12148: if((C==44&&Sp!=1)||(C<=32&&Sp==1)) F=-1;
12149: else if(C<32 && C!=9) continue;
12150: }
12151: if(SJIS && I<N-1 && ((C>128 && C<160)||(C>223 && C<240))){
12152: LT=cons(C,LT);LT=cons(S[++I],LT);continue;
12153: }
12154: if(F>0){
12155: LT=cons(C,LT);continue;
12156: }
12157: LS=asciitostr(reverse(LT));
1.9 takayama 12158: if(V==1||findin(++J,V)>=0){
12159: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
12160: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
12161: }
1.6 takayama 12162: if(!T || T==J) LL=cons(LS,LL);
12163: if(F==-2) while(++I<N && Sp!=1 && S[I]!=44);
12164: F=0;LT=[];
12165: }
12166: if(I<=N && (Sp!=1 || length(LT)>0)){ /* lastline */
12167: LS=asciitostr(reverse(LT));
1.9 takayama 12168: if(V==1||findin(++J,V)>=0){
12169: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
12170: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
12171: }
1.6 takayama 12172: if(!T || T==J) LL=cons(LS,LL);
12173: }
12174: L=cons(reverse(LL),L);
12175: }
12176: close_file(ID);
12177: if(T) L=m2l(L|flat=1);
1.16 takayama 12178: L=reverse(L);
12179: return L;
1.6 takayama 12180: }
12181:
1.55 takayama 12182: def getline(ID)
12183: {
12184: if(isint(Maxlen=getopt(Max))>0) Maxlen=1024;
12185: if(type(CR=getopt(CR))!=4) CR=[13];
12186: if(type(LF=getopt(LF))!=4) LF=[10];
12187: S=[];
12188: for(I=0; I<1023; I++){
12189: C=get_byte(ID);
12190: if(C<0) return 0;
12191: if(findin(C,CR)>=0) continue;
12192: if(findin(C,LF)>=0) break;
12193: S=cons(C,S);
12194: }
12195: return asciitostr(reverse(S));
12196: }
12197:
1.6 takayama 12198: def showbyshell(S)
12199: {
12200: Id = getbyshell(S);
12201: if(Id<0) return Id;
12202: while((S=get_line(Id))!=0) print(S,2);
12203: return close_file(Id);
12204: }
12205:
12206:
12207: def getbyshell(S)
12208: {
12209: /* extern DIROUT; */
12210:
12211: Home=getenv("HOME");
12212: if(type(Home)!=7) Home="";
12213: if(type(Tmp=getenv("TEMP"))!=7 && type(Tmp=getenv("TMP")) != 7)
12214: Tmp=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
12215: Sep=isMs()?"\\":"/";
12216: F=Tmp+Sep+"muldif.tmp";
1.16 takayama 12217: if(type(S)<=1 && S>=0) close_file(S);
1.6 takayama 12218: remove_file(F);
12219: if(type(S)<=1) return -1;
12220: shell(S+" > \""+F+"\"");
12221: return open_file(F);
12222: }
12223:
1.69 takayama 12224: def isfctr(P)
12225: {
12226: if(type(P)>3) return 0;
12227: if(type(P)==3) return (!isfctr(nm(P))||!isfctr(dn(P)))?0:1;
12228: V=ptol(P,vars(P)|opt=0);
12229: for(;V!=[];V=cdr(V)){
12230: if(type(car(V))>1||ntype(car(V))>0) return 0;
12231: }
12232: return 1;
12233: }
12234:
1.6 takayama 12235: def show(P)
12236: {
12237: T=type(P);
12238: S=P;
12239: Var=getopt(opt);
1.69 takayama 12240: if((Raw=getopt(raw))!=1) Raw=0;
1.6 takayama 12241: if(Var=="verb"){
1.69 takayama 12242: S="{\\tt"+verb_tex_form(T)+"}\n\n";
12243: if(Raw) return S;
12244: dviout(S);return;
1.6 takayama 12245: }
12246: if(type(Var)<0) Var=getopt(var);
12247: if(T==6){
12248: if((Sp=getopt(sp))==1 || Sp==2)
12249: S=mtotex(P|lim=1,small=2,sp=Sp,null=1,mat="B");
12250: else if(type(Var)==4 || type(Var)==7)
12251: S=mtotex(P|lim=1,small=2,var=Var);
12252: else
12253: S=mtotex(P|lim=1,small=2);
12254: Size=size(P);
12255: Size=(Size[0]>Size[1])?Size[0]:Size[1];
12256: if(Size>10) dviout0(Size);
12257: }else if(T<=3){
12258: X=0;
12259: if(Var=="pfrac") X=var(P);
12260: else X=getopt(pfrac);
12261: if(isvar(X)){
1.69 takayama 12262: if(Raw) return pfrac(P,X|TeX=1);
12263: pfrac(P,X|dviout=1);return;
1.6 takayama 12264: }
1.69 takayama 12265: Opt=getopt();
12266: if(type(Var)!=2&&type(Var)!=4&&type(Var)!=7){
1.6 takayama 12267: if(isdif(P)!=0) Opt=cons(["var","dif"],Opt);
12268: else Opt=cons(["br",1],Opt);
12269: }
1.69 takayama 12270: if(!isfctr(P)){
12271: if(Raw) return my_tex_form(P);
12272: else{
12273: dviout(P); return;
12274: }
12275: }
12276: if(Raw) return fctrtos(P|option_list=cons(["TeX",3],Opt));
1.70 takayama 12277: fctrtos(P|option_list=cons(["pages",2],cons(["dviout",1],Opt)));return;
1.6 takayama 12278: }else if(T==4){
1.70 takayama 12279: F=0;N=length(getopt());
12280: if(Raw) N--;
12281: if(N==1){
12282: if(type(Var=getopt(var))>1){
12283: if(isvar(Var)) Var=[0,Var];
1.71 takayama 12284: else if(type(Var)==4&&Var[0]!=0) Var=cons(0,Var);
1.70 takayama 12285: else Var=0;
12286: }else if(type(Var=getopt(eqs))!=4) Var=0;
12287: }else if(N==0) Var=[];
12288: else Var=0;
12289: if(type(Var)==4){
12290: for(F=0,L=P;L!=[];L=cdr(L)){ /* */
12291: if(type(car(L))==2) F+=nmono(car(L));
12292: else{
12293: F=0;break;
12294: }
12295: }
12296: }
12297: if(F>50){
12298: S=texbegin("align*",eqs2tex(P,Var));
12299: if(Raw) return S;
12300: dviout(S);return;
12301: }
1.6 takayama 12302: if(type(Var)==4 || type(Var)==7){
12303: S=ltotex(P|option_list=getopt());
12304: if(Var=="text"){
1.69 takayama 12305: if(Raw) return S;
12306: dviout(S);return;
1.6 takayama 12307: }
12308: }else{
12309: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
12310: LL=car(L);
12311: if(type(LL)==4){
12312: if(F==0){
12313: T=type(LL[0]);
12314: if(T==4) F=2; /* [[[? */
12315: else if(T==1 || T==0) F=1; /* [[num,.. */
12316: }
12317: if(F==1){
12318: if(length(LL)!=2 || !isint(LL[0]) || LL[0]<0 || type(LL[1])>3)
12319: F=-1; /* [[num,rat],[num,rat],...] */
12320: }else if(F==2){
12321: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
12322: LLL=car(LLT); /* [[[num,rat],[num,rat],...],[[..],..]],....] */
12323: if(length(LLL)!=2 || !isint(LLL[0]) || LLL[0]<0 || type(LLL[1])>3)
12324: F=-1;
12325: }
12326: }
12327: }else if((F==0 || F==7) && type(LL)==7){
12328: F=7;
12329: }else F=-1;
12330: }
12331: if(F==1) S=ltotex(P|opt="spt");
12332: else if(F==2){
12333: M=mtranspose(lv2m(S));
1.69 takayama 12334: if(Raw) return show(M|sp=1,raw=1); /* GRS */
12335: show(M|sp=1);return;
1.6 takayama 12336: }else if(F==7) S=ltotex(P|opt="spts");
12337: else{
12338: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
12339: LL=car(L);
12340: if(type(LL)!=4){
12341: F=-1; break;
12342: }
12343: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
12344: T=type(LLL=car(LLT));
12345: if(T<7 && T!=4) F0++;
12346: else if(T==7){
12347: if(str_char(LLL,0,"\\")<0) F1++;
12348: else F2++;
12349: }else F=-1;
12350: }
12351: }
12352: }
12353: if(F==0 && F0>0 && (F1+F2)>0){ /* list of list of eq and str */
12354: if(F2>0) S=ltotex(P|opt=["cr","spts0"],str=1);
12355: else S=ltotex(P|opt=["cr","spts"]);
12356: }else{
12357: for(S="[";;){
12358: S+=my_tex_form(car(P));
12359: if((P=cdr(P))==[]){
12360: S+="]";break;
12361: }
12362: S+=",";
12363: }
12364: }
12365: }
12366: }else if(T==7){
1.71 takayama 12367: if(Var=="raw") S=P+"\n\n";
12368: else if(Var != "eq" &&str_str(P,"\\begin"|end=128)<0){
12369: if((TikZ&&str_str(P,"\\draw"|end=128)>=0)||(!TikZ&&str_str(P,"\\ar@"|end=128)>=0))
12370: S=xyproc(P);
1.72 takayama 12371: }else if(Var !="eq"){
12372: if(str_str(P,"\\begin{align")>=0 || str_str(P,"\\[")>=0
12373: || str_str(P,"\\begin{equation")>=0
12374: || (str_char(P,0,"^")<0 && str_char(P,0,"_")<0 && str_char(P,0,"&")<0))
12375: S=P+"\n\n";
12376: }
1.71 takayama 12377: if(P!=S){
12378: if(Raw) return S;
12379: dviout(S); return;
1.6 takayama 12380: }
12381: }
1.69 takayama 12382: if(Raw) return "\\begin{align}\\begin{split}\n &"+S+"\\end{split}\\end{align}";
12383: else dviout(S|eq=5);
1.6 takayama 12384: }
12385:
12386:
12387: /* options : eq = 1 - 8, clear=1, keep=1, delete=1, title=s,
12388: fctr=1, begin=s */
12389: def dviout(L)
12390: {
12391: /* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTB, DVIOUTL; */
12392:
12393: MyEq = [
12394: ["\\[\n ","\\]"],
12395: ["\\begin{align}\n","\\end{align}"],
12396: ["\\begin{gather}\n ","\\end{gather}"],
12397: ["\\begin{multline}\n ","\\\\[-15pt]\\end{multline}"],
12398: ["\\begin{align}\\begin{split}\n &","\\end{split}\\end{align}"],
12399: ["\\begin{align*}\n &","\\end{align*}"],
12400: ["\\begin{gather*}\n ","\\end{gather*}"],
12401: ["\\begin{equation}\n ","\\end{equation}"]
12402: ];
12403: if(!chkfun("print_tex_form", "names.rr"))
12404: return 0;
12405: Home=getenv("HOME");
12406: if(type(Home)!=7) Home="";
12407: Dir=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],[Home,get_rootdir(),"/"]);
12408: Dirout=Dir+(AMSTeX?"/out.tex":"/out0.tex");
12409: Risaout=(AMSTeX)?"risaout":"risaout0";
12410: Dirisa=Dir+"/"+Risaout+".tex";
12411: Viewer="dviout";
12412: SV=["c:/w32tex/dviout","c:/dviout"];
12413: Risatex=str_subst(AMSTeX?DVIOUTA:DVIOUTL,
12414: ["%HOME%","%ASIRROOT%","%TikZ%"],[Home,get_rootdir(),rtostr(TikZ)]);
12415: if(isMs() && !access(Risatex)){
12416: for(TV=SV; TV!=[]; TV=cdr(TV)){
12417: VV=car(TV)+"/dviout.exe";
12418: if(access(VV)){
12419: Viewer=str_subst(VV,"/","\\");
12420: break;
12421: }
12422: }
12423: output(Risatex);
12424: print("cd \""+str_subst(Dir,"/","\\")+"\"");
12425: print("latex -src=cr,display,hbox,math,par "+Risaout);
12426: print("start "+Viewer+" -1 \""+Dr+"\\tex\\"+Risaout+"\" 1000");
12427: output();
12428: }
12429: if(access(Dirisa) == 0){
12430: D0="\""+(isMs()?str_subst(Dir,"/","\\")+"\"":Dir);
12431: shell("mkdir "+D0);
12432: output(Dirisa);
12433: if(AMSTeX){
12434: print("\\documentclass[a4paper]{amsart}");
12435: print("\\usepackage{amsmath,amssymb,amsfonts}");
12436: }else
12437: print("\\documentclass[a4paper]{article}");
12438: print("\\pagestyle{empty}\n\\begin{document}\n\\thispagestyle{empty}");
12439: print(AMSTeX?"\\input{out}\n\\end{document}":"\\input{out0}\n\\end{document}");
12440: output();
12441: }
12442: if((K = getopt(delete)) >= 1){ /* delete */
12443: LC = 0;
12444: if(type(K) == 1 && K > 10) K = 10;
12445: if(type(K) == 4){
12446: K = qsort(K);
12447: LC = 1; /* specific lines */
12448: }
12449: Done = 1;
12450: Id = open_file(Dirout);
12451: if(Id >= 0){
12452: Buf = Buf0 = Buf1 = Key = "";
12453: PE = 0;
12454: if(type(K) == 1)
12455: BufE = newvect(K--);
12456: Dout = Dirout+"0";
12457: remove_file(Dout);
12458: output(Dout);
12459: while((S = get_line(Id)) != 0){
12460: if(LC){
12461: while(K != [] && car(K) < LC)
12462: K = cdr(K);
12463: if(K == [] || car(K) > LC)
12464: output(S);
12465: }
12466: if(Key == ""){
12467: if((P0 = str_str(S,"\\begin{")) == 0){
12468: Key = sub_str(S,7,str_str(S,"}")-1);
12469: if(findin(Key,["align", "gather","multline", "equation","align*"]) < 0)
12470: Key = "";
12471: else{
12472: Key = "\\end{"+Key+"}";
12473: if(!LC){
12474: if(Buf != ""){
12475: if(PE < K)
12476: BufE[PE++] = Buf1+Buf;
12477: else{
12478: if(K > 0){
12479: print(BufE[0]);
12480: for(I = 1; I < K; I++)
12481: BufE[I-1]=BufE[I];
12482: BufE[K-1] = Buf1+Buf;
12483: }else
12484: print(Buf1+Buf);
12485: Done = 0;
12486: }
12487: Buf1 = Buf0;
12488: Buf = Buf0 ="";
12489: }
12490: }
12491: }
12492: }
12493: if(Key == "" && !LC) Buf0 += S;
12494: }
12495: if(Key != ""){
12496: if(!LC) Buf += S;
12497: if(str_str(S,Key) >= 0){
12498: Key = "";
12499: if(LC) LC++;
12500: }
12501: }
12502: }
12503: output();
12504: close_file(Id);
12505: }
12506: if(Done==0){
12507: Id = open_file(Dout);
12508: if(Id >= 0){
12509: remove_file(Dirout);
12510: output(Dirout);
12511: while((S = get_line(Id)) != 0)
12512: print(S,0);
12513: output();
12514: close_file(Id);
12515: }
12516: remove_file(Dout);
12517: }else L=" ";
12518: }
12519: if(getopt(clear) == 1 || Done == 1){ /* clear */
12520: remove_file(Dirout);
12521: if(L == "" || L == " "){
12522: output(Dirout);
12523: print("\\centerline{Risa/Asir}");
12524: output();
12525: }
12526: }
12527: if(L != " "){
12528: Eq=1;
12529: Eqo = getopt(eq);
12530: Fc = getopt(fctr);
12531: if(Fc == 1 && (type(L) == 2 || type(L) == 3)){
12532: L = fctrtos(L|TeX=1);
12533: if(type(L) == 4)
12534: L = "\\fact{"+L[0]+"}{"+L[1]+"}";
12535: if(type(Eqo) != 0 && type(Eqo) !=7){
12536: Eqo=0;
12537: }
12538: }
12539: if(type(L) != 4 || getopt(mult) != 1)
12540: L = [L];
12541: if(type(Eqo)!=7 && (Eqo<1 || Eqo>8))
12542: Eqo = (AMSTeX==1)?TeXEq:1;
12543: Title = getopt(title);
12544: if(type(Title) == 7){
12545: output(Dirout);
12546: print(Title);
12547: output();
12548: }
12549: Sb = getopt(subst);
12550: for( ; L != []; L = cdr(L)){
12551: Eq = 1;
12552: if(type(LT=car(L)) != 7 && type(LT) != 21)
12553: LT = my_tex_form(LT);
12554: else if(type(getopt(eq)) < 0)
12555: Eq = 0;
12556: if(type(Sb) == 4)
12557: LT = str_subst(LT,Sb[0],Sb[1]);
12558: output(Dirout);
12559: if(Eq == 1){
12560: if(type(Eqo)==7)
12561: print(texbegin(Eqo,LT));
12562: else if(Eqo >= 1 && Eqo <= 8){
12563: mycat0([MyEq[Eqo-1][0],LT,"%"],1);
12564: print(MyEq[Eqo-1][1]);
12565: }else print(LT);
12566: }else print(LT);
12567: output();
12568: }
12569: }
12570: if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTB,0," ")<0
12571: && str_char(DVIOUTL,0," ")<0)
12572: Risatex="\""+Risatex+"\"";
12573: if(getopt(keep) != 1) shell(Risatex);
12574: return 1;
12575: }
12576:
12577: def rtotex(P)
12578: {
12579: S = my_tex_form(P);
12580: return (str_len(S) == 1)?S:"{"+S+"}";
12581: }
12582:
12583: def mtotex(M)
12584: {
12585: /* extern TexLim; */
12586:
12587: MB=mat(["(",")","p"],["\\{","\\}","B"],["[","]","b"],["|","|","v"],
12588: ["\\|","\\|","V"], [".",".",""]);
12589: if(type(MT=getopt(mat))==7){
12590: MT=findin(MT,["p","B","b","v","V",""]);
12591: if(MT<0) MT=0;
12592: }
12593: else MT=0;
12594: MT=MB[MT];
12595: if((F=getopt(small))!=1 && F!=2) F=0;
12596: Lim=getopt(lim);
12597: if(type(Lim)==1){
12598: if(Lim<30 && Lim!=0) Lim = TexLim;
12599: }else Lim=0;
12600: FL=getopt(len);
12601: Rw=getopt(raw);
12602: Sp=getopt(sp);
12603: Idx=getopt(idx);
12604: if(type(Idx)==4) Idx=ltov(Idx);
12605: if(type(Idx)==6 && length(Idx)==0) Idx=-1;
12606: Var=getopt(var);
12607: if(Lim>0) FL=1;
12608: Null=getopt(null);
12609: if(Null!=1 && Null!=2) Null=0;
12610: if(type(M)==5) M=lv2m([V]);
12611: else if(type(M)!=6) return monototex(M);
12612: S=size(M);
12613: if(FL==1){
12614: L=newmat(S[0],S[1]); LL=newvect(S[1]);
12615: }
12616: SS=newmat(S[0],S[1]);
12617: for(I=0; I<S[0]; I++){
12618: for(J=0; J<S[1]; J++){
12619: if(type(P=M[I][J])<=3){
12620: if(P!=0 || Null == 0 || (Null==2 && I==J)){
12621: SS[I][J]=(type(Var)>1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0);
12622: if(type(P)==1 && str_str(SS[I][J],"\\frac{-"|end=0)==0)
12623: SS[I][J]="-\\frac{"+str_cut(SS[I][J],7,100000);
12624: }
12625: }else if(type(P)==6){
12626: ST= mtotex(P|small=1,len=1);
12627: SS[I][J]=ST[0];
12628: L[I][J]=ST[1];
12629: }else if(type(P)==7){
12630: if(Rw==1) SS[I][J]=P;
12631: else SS[I][J]="\\text{"+P+"\}";
12632: }else if(type(P)==4 && length(P)==2 && P[0]>0 && (Sp==1 || Sp==2)){
12633: if(P[0]==1){
12634: SS[I][J]=fctrtos(P[1]|TeX=2,lim=0);
12635: }else{
12636: ST=my_tex_form(P[0]);
12637: if(Sp==2) ST="("+ST+")";
12638: SS[I][J]="["+fctrtos(P[1]|TeX=2,lim=0)+"]_";
12639: if(str_len(ST)<2) SS[I][J]+=ST;
12640: else SS[I][J]+="{"+ST+"}";
12641: }
12642: }else
12643: SS[I][J]=my_tex_form(P);
12644: if(FL==1) L[I][J]=texlen(SS[I][J]);
12645: }
12646: }
12647: if(Lim>0 || FL==1){
12648: for(LLL=J=0; J<S[1];J++){
12649: for(I=K=0; I<S[0];I++){
12650: if(K<L[I][J]) K=L[I][J];
12651: }
12652: LLL+=(LL[J]=K);
12653: }
12654: }
12655: if(Lim>0){
12656: if(F==2 && LLL>Lim-2*S[1]-2) F=1;
12657: if(F==1)
12658: Lim=idiv(Lim*6,5);
12659: if(LLL<=Lim-(2-F)*S[I]-2) Lim=0;
12660: }
12661: Mat=(F==1)?"smallmatrix}":"matrix}";
12662: if(F==1) Out=str_tb("\\left"+MT[0]+"\\begin{",0);
12663: else Out=str_tb((Lim==0)?"\\begin{"+MT[2]:"\\left"+MT[0]+"\\begin{",0);
12664: Out = str_tb(Mat,Out);
12665: for(I=II=LT=0; II<=S[0]; II++){
12666: if(Lim==0) II=S[0];
12667: if(II<S[0]){
12668: K=LL[II]+(2-F);
12669: if(I==II){
12670: LT+=K;
12671: continue;
12672: }
12673: if(LT+K<Lim-2) continue;
12674: LT=K;
12675: }
12676: for(I0=I; I<II; I++){
12677: if(I==I0){
12678: str_tb((I==0)?
12679: "\n ":
12680: "\\right.\\\\\n \\allowdisplaybreaks\\\\\n &\\ \\left.\\begin{"+Mat+"\n ", Out);
12681: if(Idx==1||Idx==0||type(Idx)==5){
12682: for(J=I; J<II; J++){
12683: if(type(Idx)!=4)
12684: str_tb("("+rtostr(J+Idx)+")",Out);
12685: else{
12686: JJ=length(Idx)-1;
12687: if(J<JJ) JJ=J;
12688: str_tb(my_tex_form(Idx[JJ]),Out);
12689: }
12690: if(J<II) str_tb(" & ",Out);
12691: }
12692: str_tb("\\\\\n ",Out);
12693: }
12694: }
12695: else str_tb("\\\\\n ",Out);
12696: for(J=0; J<S[1]; J++){
12697: if(J!=0) str_tb(" & ",Out);
12698: if(type(SS[I][J])==7) str_tb(SS[I][J],Out);
12699: }
12700: }
12701: Out=str_tb("\n\\end{", Out);
12702: if(II==S[0]) Out=str_tb((Lim==0&&F!=1)?MT[2]+Mat:Mat+"\\right"+MT[1],Out);
12703: else Out=str_tb(Mat+"\\right.",Out);
12704: }
12705: SS = str_tb(0,Out);
12706: if(FL!=1) return SS;
12707: if(F==1) LLL=idiv((LLL+S[1])*5+13,6);
12708: else LLL+=2*(1+S[1]);
12709: return [SS,LLL];
12710: }
12711:
12712: def sint(N,P)
12713: {
1.11 takayama 12714: if( type(N)==1 || N==0 ) {
1.6 takayama 12715: NT=ntype(N);
12716: if((type(Opt=getopt(str))==1 || Opt==0) && Opt>=0 && P>=0){
12717: if(Opt==2 || Opt==4 || Opt==0){
1.11 takayama 12718: if(N==0) return (Opt>0)?"0":0;
1.6 takayama 12719: Pw=0;
12720: if(NT==4){
12721: NN=abs(real(N));N1=abs(imag(N));
12722: if(NN<N1) NN=N1;
12723: }else NN=abs(N);
12724: while(NN<1 && NN>-1){
12725: Pw--;
12726: N*=10;NN*=10;
12727: }
12728: while(N>=10 || N<=-10){
12729: Pw++;
12730: N/=10;NN/=10;
12731: }
12732: if(Opt==0) return sint(N*10^Pw,P-Pw-1);
12733: S=(getopt(sqrt)==1)?sint(N,P|str=(Opt==4)?3:1,sqrt=1):sint(N,P|str=(Opt==4)?3:1);
12734: if(Pw==0) return S;
12735: if(NT==4)
12736: S="("+S+")";
12737: if(Pw==1){
12738: if(Opt==2)
12739: return S+"*10";
12740: else
12741: return S+"\\times10";
12742: }
12743: if(Opt==2)
12744: return S+"*10^("+rtostr(Pw)+")";
12745: else
12746: return S+"\\times10^{"+rtostr(Pw)+"}";
12747: }
12748: if(NT==4){
12749: NN=real(N);
12750: if(NN!=0){
12751: S=sint(NN,P|str=1);
12752: if(imag(N)>0) S=S+"+";
12753: }
12754: else S="";
12755: S=S+sint(imag(N),P|str=1)+((Opt==3)?((getopt(sqrt)==1)?"\\sqrt{-1}":"i"):"@i");
12756: return S;
12757: }
12758: if(N<0){
12759: N=-N;
12760: Neg="-";
12761: }else Neg="";
1.11 takayama 12762: N=rint(N*10^P)/10^P;
1.6 takayama 12763: NN=floor(N);
1.11 takayama 12764: NV=(N-NN+1)*10^P;
1.6 takayama 12765: NS=rtostr(NN);
12766: if(P<=0) return Neg+NS;
12767: if(NN==0 && getopt(zero)==0) NS="";
1.11 takayama 12768: return Neg+NS+"."+str_cut(rtostr(NV),1,P);
1.6 takayama 12769: }
12770: if(NT==4)
12771: return sint(real(N),P)+sint(imag(N),P)*@i;
12772: X = rint( N*10^P );
1.11 takayama 12773: return deval(X/10^P);
1.6 takayama 12774: }
12775: if( (type(N)==2) || (type(N)==3) ){
12776: NN = eval(N);
12777: if( type(NN)==1 )
12778: return sint(NN,P|option_list=getopt());
12779: else return N;
12780: }
1.8 takayama 12781: if( type(N)>3 && type(N) < 7)
1.6 takayama 12782: #ifdef USEMODULE
12783: return mtransbys(os_md.sint,N,[P]|option_list=getopt());
12784: #else
12785: return mtransbys(sint,N,[P]|option_list=getopt()));
12786: #endif
1.8 takayama 12787: return N;
1.6 takayama 12788: }
12789:
12790: def frac2n(N)
12791: {
12792: if((T=type(N))<0) return N;
12793: E=(getopt(big)==1)?eval(@e):0.1;
12794: if(T==1){
1.15 takayama 12795: if(ntype(N)==0) return (E*N)/E;
1.6 takayama 12796: else if(ntype(N)!=4) return N;
1.15 takayama 12797: else return (E*(1+@i)*N)/(E*(1+@i));
1.6 takayama 12798: }
12799: if(T==3||T==2){
12800: N=red(N);
12801: Nm=nm(N);Var=vars(Nm);V=car(Var);K=length(Var);
12802: for(S=0,I=mydeg(Nm,V);I>=0;I--) S+=frac2n(mycoef(Nm,I,V))*V^I;
12803: return S/dn(N);
12804: }
1.15 takayama 12805: if(T<4) return (E*N)/E;
1.6 takayama 12806: #ifdef USEMODULE
12807: return mtransbys(os_md.frac2n,N,[]|option_list=getopt());
12808: #else
12809: return mtransbys(frac2n,N,[]|option_list=getopt());
12810: #endif
12811: }
12812:
1.71 takayama 12813: /* Option : opt */
1.70 takayama 12814: def ptconvex(L)
12815: {
1.71 takayama 12816: if(!(isint(Opt=getopt(opt)))) Opt=0;
12817: L0=car(L);X=L0[0];Y=L0[1];
1.70 takayama 12818: for(TL=cdr(L);TL!=[];TL=cdr(TL)){ /* find the most left pt L0 */
1.71 takayama 12819: if(X<car(TL)[0]||(X==car(TL)[0]&&Y<car(TL)[1])) continue;
1.70 takayama 12820: L0=car(TL);X=car(L0);
12821: }
1.71 takayama 12822: if(Opt==3) return L0;
1.70 takayama 12823:
12824: R=[]; /* find a polygone through all points */
12825: X0=L0[0];Y0=L0[1];
12826: for(TL=L;TL!=[];TL=cdr(TL)){
1.71 takayama 12827: L0=car(TL);
12828: X=L0[0]-X0;Y=L0[1]-Y0;S=X^2+Y^2;
12829: L0=(!S)? append([-8,0],L0):append([(Y>0?Y^2:-Y^2)/S,S],L0);
12830: R=cons(L0,R);
1.70 takayama 12831: }
12832: L=qsort(R);
12833: if(Opt==2) return L;
12834:
1.71 takayama 12835: for(R=[],TL=L;TL!=[];TL=cdr(TL)){
12836: if(Opt==4){
12837: L0=car(TL);
12838: V=car(L0);
12839: L0=append(cdr(cdr(L0)),[V]);
12840: }else L0=cdr(cdr(car(TL)));
12841: R=cons(L0,R);
12842: }
12843: L=reverse(R);
12844: if(Opt==1) return L;
12845: R=[cons(V0=-8,L0=car(L))];
1.70 takayama 12846: for(TL=cdr(L);TL!=[];TL=cdr(TL)){
1.71 takayama 12847: V=darg(L0,L1=car(TL));
12848: if(V<-4) continue;
1.70 takayama 12849: while(V<V0){
12850: R=cdr(R);
1.71 takayama 12851: V0=car(car(R));
12852: V=darg(cdr(car(R)),L1);
1.70 takayama 12853: }
12854: if(V==V0) R=cdr(R);
1.71 takayama 12855: R=cons(cons(V0=V,L0=L1),R);
1.70 takayama 12856: }
1.71 takayama 12857: for(L=[],TL=R;TL!=[];TL=cdr(TL)) L=cons(cdr(car(TL)),L);
1.70 takayama 12858: return L;
12859: }
12860:
1.71 takayama 12861: def darg(P,Q)
12862: {
12863: if(type(car(P))==4){
12864: if((V=darg(Q[0],Q[1]))<-1) return -8;
12865: if((V-=darg(P[0],P[1]))>2){
12866: if((V-=4)>4) return -4;
12867: }else if(V<=-2) V+=4;
12868: return V;
12869: }
12870: X=Q[0]-P[0];Y=Q[1]-P[1];
12871: if(!(S=X^2+Y^2)) return -8;
12872: V=Y^2/S;
12873: if(Y<0) V=-V;
12874: return X<=0?2-V:V;
12875: }
12876:
12877: def dwinding(P,Q)
12878: {
12879: V=V0=V1=darg(P,Q0=car(Q));
12880: Q=cons(Q0,reverse(Q));
12881: for(Q=cdr(Q);Q!=[];Q=cdr(Q)){
12882: if((V2=darg(P,car(Q)))<-4) return 1/3;
12883: V1=V2-V1;
12884: if(V1==2||V1==-2) return 1/2;
12885: if(V1<-2) V1+=4;
12886: else if(V1>2) V1-=4;
12887: V+=V1;
12888: V1=V2;
12889: }
12890: return floor((V0-V+1/2)/4);
12891: }
12892:
1.6 takayama 12893: def xyproc(F)
12894: {
12895: if(type(Opt=getopt(opt))!=7) Opt="";
12896: if(type(Env=getopt(env))!=7)
12897: Env=(!TikZ)?"xy":"tikzpicture";
12898: if(F==1)
12899: return(Opt=="")?"\\begin{"+Env+"}\n":"\\begin{"+Env+"}["+Opt+"]\n";
12900: if(F==0) return "\\end{"+Env+"}\n";
12901: if(type(F)==7){
12902: F=xyproc(1|opt=Opt,env=Env)+F+xyproc(0|env=Env);
12903: if(getopt(dviout)==1) dviout(F);
12904: else return F;
12905: }
12906: }
12907:
12908: def xypos(P)
12909: {
12910: if(type(P[0])==7){
12911: if(P[0]=="") S="";
12912: else S=(!TikZ)?"\""+P[0]+"\"":"("+P[0]+")";
12913: }
12914: else{
12915: if(TikZ==0 && XYcm==1){
12916: X=sint(P[0]*10,XYPrec); Y=sint(P[1]*10,XYPrec);
12917: }else{
12918: X=sint(P[0],XYPrec); Y=sint(P[1],XYPrec);
12919: }
12920: S="("+rtostr(X)+","+rtostr(Y)+")";
12921: }
12922: if(!TikZ){
12923: if(length(P)>2 && (PP=P[2])!=""){
12924: S=S+" *";
12925: if(type(PP)==4 && length(PP)==2 && type(PP[0])==7){
12926: S=S+PP[0];
12927: PP=PP[1];
12928: }
12929: if(type(PP)==7){
12930: L=str_len(PP);
12931: if(str_chr(PP,0,"$")==0 && str_chr(PP,L-1,"$")==L-1){
12932: PP=str_cut(PP,1,L-2);
12933: }else S+="\\txt";
12934: }
12935: else PP=my_tex_form(PP);
12936: S=S+"{"+PP+"}";
12937: }
12938: if(length(P)>3){
12939: if(type(P[3])==7 && P[3]!="") S=S+"=\""+P[3]+"\"";
12940: if(length(P)>4 && type(P[4])==7) S=S+P[4];
12941: }
12942: }else{
12943: T="";
12944: if(length(P)>2 && (PP=P[2])!=""){
12945: F=1;
12946: if(type(PP)==4){
12947: if(length(PP)==2 && type(PP[0])==7){
12948: T="["+PP[0]+"]";
12949: PP=PP[1];
12950: }
12951: }
12952: if(type(PP)!=7) PP="$"+my_tex_form(PP)+"$";
12953: S=S+"{"+PP+"}";
12954: }else F=0;
12955: if(length(P)>3){
12956: if(type(P[3])==7 && P[3]!="") T=T+"("+P[3]+")";
12957: else if(P[3]==1) T=T+"(_)";
12958: if(length(P)>4 && type(P[4])==7) S=S+P[4];
12959: }
12960: if(length(P)>2){
12961: if(F) S="node"+T+" at"+S;
12962: else S="coordinate"+T+" at"+S;
12963: }
12964: }
12965: return S;
12966: }
12967:
12968: def xyput(P)
12969: {
12970: if((type(Sc=getopt(scale))==1 && Sc!=1) || type(Sc)==4){
12971: if(type(Sc)==1) Sc=[Sc,Sc];
12972: Sx=Sc[0];Sy=Sc[1];
12973: if(length(P)>2)
12974: P1=cons(Sy*P[1],cdr(cdr(P)));
12975: else P1=[Sy*P[1]];
12976: P=cons((type(P[0])==7)?P[0]:(Sx*P[0]),P1);
12977: }
12978: if(!TikZ) return "{"+xypos(P)+"};\n";
12979: return "\\"+xypos(P)+";\n";
12980: }
12981:
12982: def xyline(P,Q)
12983: {
12984: if(!TikZ) return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n";
12985: if(type(T=getopt(opt))!=7) T="";
12986: else T="["+T+"]";
12987: if(length(P)<3 && length(Q)<3)
12988: return "\\draw"+T+xypos(P)+"--"+xypos(Q)+";\n";
12989: if(length(P)==2) P=[P[0],P[1],"","_0"];
12990: else if(length(P)==3 || (length(P)==4 && P[3]==""))
12991: P=[P[0],P[1],P[2],"_0"];
12992: else if(length(P)>4 && P[3]=="")
12993: P=[P[0],P[1],P[2],"_0",P[4]];
12994: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
12995: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
12996: Q=[Q[0],Q[1],Q[2],"_1"];
12997: else if(length(Q)>4 && Q[3]=="")
12998: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
12999: return "\\draw "+T+xypos(P)+" "+xypos(Q)+"("+P[3]+")--("+Q[3]+");\n";
13000: }
13001:
13002: def xylines(P)
13003: {
13004: Lf=getopt(curve);
13005: if(type(Lf)!=1) Lf=0;
13006: SS=getopt(opt);
13007: SF=(SS==0)?1:0;
13008: if((Proc=getopt(proc))==1||Proc==2||Proc==3){
13009: OL=cons(["opt",0],delopt(getopt(),["opt","proc"]));
13010: R=xylines(P|option_list=OL);
13011: OP=(type(SS)<0)?[]:((type(SS)==4)?[["opt",SS[0]],["cmd",SS[1]]]:[["opt",SS]]);
13012: return [1,OP,R];
13013: }
13014: if(type(SS)!=7 && type(SS)!=4){
13015: if(Lf==0 && !TikZ) SS="@{-}";
13016: else SS="";
13017: }
13018: if(type(Sc=getopt(scale))==1 || type(Sc)==4){
13019: if(type(Sc)==1) Sc=[Sc,Sc];
13020: Sx=Sc[0];Sy=Sc[1];
13021: if(Sx!=1 || Sy!=1){
13022: for(PP=[], P0=P; P0!=[]; P0=cdr(P0)){
13023: PT=car(P0);
13024: if((type(PT)!=4 && type(PT)!=5) || (type(PT[0])!=1 && PT[0]!=0))
13025: PP=cons(PT,PP);
13026: else{
13027: if(length(PT)>2 && type(PT)==4)
13028: P1=cons(Sy*PT[1],cdr(cdr(PT)));
13029: else P1=[Sy*PT[1]];
13030: PP=cons(cons(Sx*PT[0],P1),PP);
13031: }
13032: }
13033: P=reverse(PP);
13034: }
13035: }
13036: if(type(Cl=CL0=getopt(close))!=1) Cl=0;
13037: if((Vb=getopt(verb))!=1&&type(Vb)!=4) Vb=0;
13038: if(type(Lf)!=1 || Lf==0){ /* lines */
13039: if(TikZ||SF){
13040: for(L=[],F=0,PT=P;PT!=[];PT=cdr(PT)){
13041: if(type(car(PT))<4){
13042: L=cons(car(PT),L);
13043: F=0;
13044: }else{
13045: if(F++>1) L=cons(1,L);
13046: L=cons(car(PT),L);
13047: }
13048: }
13049: if(Cl==1){
13050: L=cons(1,L);L=cons(-1,L);
13051: }
13052: if(L) L=reverse(L);
13053: if(SF) return L;
13054: if(type(SS)!=4) S=xybezier(L|opt=SS);
13055: else S=xybezier(L|opt=SS[0],cmd=SS[1]);
13056:
13057: }else{
13058: Out = str_tb(0,0);
13059: for(PT=P; PT!=[]; ){
13060: PS1=car(PT);
13061: PT=cdr(PT);
13062: if(PT==[]){
13063: if(Cl==1) PS2=car(P);
13064: else PS2=0;
13065: }else PS2=car(PT);
13066: str_tb(xyarrow(PS1,PS2|opt=SS),Out);
13067: }
13068: S=str_tb(0,Out);
13069: }
13070: }else if(Lf==2){ /* B-spline */
13071: if(SF) return P;
13072: if(!TikZ){
13073: Out = str_tb("{\\curve{",0);
13074: for(PT=P;PT!=[];PT=cdr(PT)){
13075: if(car(PT)==0){
13076: str_tb("}};\n{\\curve{",Out);
13077: continue;
13078: }
13079: if(PT!=P) str_tb("&",Out);
13080: str_tb(xypos([car(PT)[0],car(PT)[1]]),Out);
13081: }
13082: str_tb("}};\n",Out);
13083: S=str_tb(0,Out);
13084: }else Out=str_tb(xybezier(P|opt=SS),0);
13085: for(I=0;I<2;I++){
13086: Q=car(P);
13087: if(length(Q)>2)
13088: str_tb(xyput(Q),Out);
13089: P=reverse(P);
13090: }
13091: S=str_tb(0,Out);
13092: }else{ /* extended Bezier */
13093: RTo=getopt(ratio);
13094: if(type(Acc=getopt(Acc))!=1) Acc=0;
13095: if(type(RTo)!=1 || RTo>1.5 || RTo<0.001) RTo=0;
13096: if(Cl==1){
13097: PR=reverse(P);
13098: PT=car(PR);
13099: PR=cons(P[0],PR);
13100: PR=cons(P[1],PR);
13101: P=cons(PT,reverse(PR));
13102: }else if(Cl==-1) Cl=1;
13103: for(L=P2=P3=0,PT=P;;){
13104: P1=P2;P2=P3;P3=P4;
13105: P4=(PT==[])?0:car(PT);
13106: if(PT==[] && (Cl==1 || P3==0)) break;
13107: PT=cdr(PT);
13108: if(P3==0) str_tb("%\n", Out);
13109: if(P2==0 || P3==0 || (Cl==1 && P1==0)) continue;
13110: if(L!=0){
13111: if(car(L)==P2)
13112: L=cons(1,L);
13113: else{
13114: L=cons(0,L); L=cons(P2,L);
13115: }
13116: }else L=[P2];
13117: X=P3[0]-P2[0];Y=P3[1]-P2[1];
13118: DL1=DL2=0;DL=Acc?sqrt(X^2+Y^2):dsqrt(X^2+Y^2);
13119: if(P4!=0){
13120: XD1=P4[0]-P2[0];YD1=P4[1]-P2[1];DL1=Acc?sqrt(XD1^2+YD1^2):dsqrt(XD1^2+YD1^2);
13121: }
13122: if(P1!=0){
13123: XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];DL2=Acc?sqrt(XD2^2+YD2^2):dsqrt(XD2^2+YD2^2);
13124: }
13125: if(RTo!=0)
13126: R=RTo;
13127: else if(DL1>0 && DL2>0){
13128: Cos=(XD1*XD2+YD1*YD2)/(DL1*DL2);
13129: RT=4/(3*(Acc?sqrt((1+Cos)/2):dsqrt((1+Cos)/2))+3);
13130: R=DL*RT/(DL1+DL2);
13131: }else if(DL1!=0)
13132: R=DL/(2*DL1);
13133: else if(DL2!=0)
13134: R=DL/(2*DL2);
13135: if(DL2!=0) L=cons([P2[0]+R*XD2,P2[1]+R*YD2],L);
13136: if(DL1!=0) L=cons([P3[0]-R*XD1,P3[1]-R*YD1],L);
13137: L=cons([P3[0],P3[1]],L);
13138: }
13139: if(CL0==1) L=cons(-1,cdr(L));
13140: if(L!=0) L=reverse(L);
13141: if(SF) return L;
13142: if(type(SS)==4)
13143: S=xybezier(L|opt=SS[0],cmd=SS[1],verb=Vb);
13144: else
13145: S=xybezier(L|opt=SS,verb=Vb);
13146: }
13147: if(getopt(dviout)!=1) return S;
13148: xyproc(S|dviout=1);
13149: }
13150:
13151: def saveproc(S,Out)
13152: {
13153: if(type(Out)==4){
13154: Out=cons(S,Out);
13155: return Out;
13156: }else{
13157: str_tb(S,Out);
13158: return Out;
13159: }
13160: }
13161:
1.18 takayama 13162: def xygrid(X,Y)
13163: {
13164: for(RR=[],I=0,Z=X;I<2;I++){
1.19 takayama 13165: U=Z[2];L=LL=[];M=Z[3];
13166: if(Z[1]==1||Z[1]==-1){
1.18 takayama 13167: if(type(M)==4) L=M;
13168: else{
1.19 takayama 13169: if(U*(-dlog(1-1/20)/dlog(10))>=M){
1.18 takayama 13170: L=cons([1,2,1/10],L);
1.19 takayama 13171: LL=cons([1,2,1/2],LL);
13172: }else if(U*(-dlog(1-1/10)/dlog(10))>=M)
1.18 takayama 13173: L=cons([1,2,1/5],L);
13174: else if(U*(-dlog(1-1/4)/dlog(10))>=M)
13175: L=cons([1,2,1/2],L);
1.19 takayama 13176: if(U*(-dlog(1-1/50)/dlog(10))>=M){
1.18 takayama 13177: L=cons([2,5,1/10],L);
1.19 takayama 13178: LL=cons([2,5,1/2],LL);
13179: }else if(U*(-dlog(1-1/25)/dlog(10))>=M)
1.18 takayama 13180: L=cons([2,5,1/5],L);
13181: else if(U*(-dlog(1-1/10)/dlog(10))>=M)
13182: L=cons([2,5,1/2],L);
1.19 takayama 13183: if(U*(-dlog(1-1/100)/dlog(10))>=M){
1.18 takayama 13184: L=cons([5,10,1/10],L);
1.19 takayama 13185: LL=cons([5,10,1/2],LL);
13186: }
1.18 takayama 13187: else if(U*(-dlog(1-1/50)/dlog(10))>=M)
13188: L=cons([5,10,1/5],L);
13189: else if(U*(-dlog(1-1/20)/dlog(10))>=M)
13190: L=cons([5,10,1/2],L);
1.19 takayama 13191: L=cons(L,cons(LL,[[[1,10,1]]]));
1.18 takayama 13192: }
13193: R=scale(L|scale=U);
1.19 takayama 13194: if(Z[1]==-1){
13195: for(LL=[];R!=[];R=cdr(R)){
13196: for(L=[],T=car(R);T!=[];T=cdr(T)) L=cons(U-car(T),L);
13197: LL=cons(reverse(L),LL);
13198: }
13199: R=reverse(LL);
13200: }
1.18 takayama 13201: }else if(Z[1]==0){
13202: if(type(M)==4){
13203: R=scale(M|f=x,scale=U);
13204: }else{
13205: V=0;
13206: if(U/10>=M) V=1/10;
13207: else if(U/5>=M) V=1/5;
13208: else if(U/2>=M) V=1/2;
13209: R=[];
13210: if(V>0){
13211: UU=U*V;
13212: for(R=[],J=UU;J<U;J+=UU) R=cons(J,R);
13213: }
1.19 takayama 13214: if(V==1/10) L=[U/2];
13215: else L=[];
13216: R=cons(R,cons(L,[[0,U]]));
1.18 takayama 13217: }
13218: }else if(type(Z[1])==4){
13219: R=Z[1];
1.19 takayama 13220: if(length(R)==0||type(R[0])!=4) R=[[],[],R];
1.18 takayama 13221: }else return 0;
1.19 takayama 13222: K=length(R);
13223: S=newvect(K);
13224: for(J=0;J<K;J++){
13225: for(S[J]=[],JJ=0;JJ<=Z[0];JJ+=U){
13226: for(P=R[J];P!=[];P=cdr(P))
13227: if(car(P)+JJ<=Z[0]) S[J]=cons(car(P)+JJ,S[J]);
13228: }
13229: }
13230: for(J=0;J<K;J++) S[J]=lsort(S[J],[],1);
13231: for(U=[],J=K-1;J>0;J--){
13232: U=lsort(S[J],U,0);S[J-1]=lsort(S[J-1],U,1);
1.18 takayama 13233: }
1.19 takayama 13234: RR=cons(vtol(S),RR);
1.18 takayama 13235: Z=Y;
13236: }
13237: if((Raw=getopt(raw))==1) return RR;
13238: SS=[];
13239: if(type(Sf=getopt(shift))==7){
13240: Sx=Sf[0];Sy=Sf[1];
13241: }else Sx=Sy=0;
13242: for(I=0;I<2;I++){
13243: for(S0=[],L=RR[I];L!=[];L=cdr(L)){
13244: for(S=[],T=car(L);T!=[];T=cdr(T)){
13245: if(S!=[]) S=cons(0,S);
13246: if(I==0){
13247: S=cons([X[0]+Sx,car(T)+Sy],S);
13248: S=cons([Sx,car(T)+Sy],S);
13249: }else{
13250: S=cons([car(T)+Sx,Y[0]+Sy],S);
13251: S=cons([car(T)+Sx,Sy],S);
13252: }
13253: }
13254: S0=cons(S,S0);
13255: }
13256: SS=cons(reverse(S0),SS);
13257: }
13258: SS=reverse(SS);
13259: if(Raw==2) return SS;
13260: if(length(Y)<5) T=[["",""]];
13261: else if(type(Y[4])==4) T=[Y[4]];
13262: else T=[Y[4],Y[4]];
13263: if(length(X[4])==4) T=cons([""],T);
13264: else if(type(X[4])==4) T=cons(X[4],T);
13265: else T=cons([X[4]],T);
13266: for(Sx=Sy=[],I=0;I<2;I++){
13267: TT=T[I];
13268: for(V=SS[I];V!=[];V=cdr(V)){
13269: Op=car(TT);
13270: if(length(TT)>1) TT=cdr(TT);
13271: if(car(V)==[]) continue;
13272: if(Op=="") S=xylines(car(V));
13273: else S=xylines(car(V)|opt=Op);
13274: if(I==0) Sx=cons(S,Sx);
13275: else Sy=cons(S,Sy);
13276: }
13277: }
13278: for(S="",Sx=reverse(Sx), Sy=reverse(Sy);Sx!=[]&&Sy!=[];){
13279: if(Sx!=[]){
13280: S+=car(Sx);Sx=cdr(Sx);
13281: }
13282: if(Sy!=[]){
13283: S+=car(Sy);Sy=cdr(Sy);
13284: }
13285: }
13286: return S;
13287: }
13288:
13289:
1.22 takayama 13290: def addIL(I,L)
1.18 takayama 13291: {
1.22 takayama 13292: if(I==0){
13293: for(R=[];L!=[];L=cdr(L)) R=addIL(car(L),R);
13294: return reverse(R);
1.18 takayama 13295: }
1.22 takayama 13296: if(type(In=getopt(in))==1){
13297: if(In==-1){
13298: J=JJ=I[1];I=I[0];
13299: for(R=[];L!=[];L=cdr(L)){
13300: J=lmin([car(L)[0],JJ]);
13301: if(J>I) R=cons([I,J],R);
13302: I=lmax([car(L)[1],I]);
13303: }
13304: if(I<JJ) R=cons([I,JJ],R);
13305: return reverse(R);
13306: }else{
13307: for(;L!=[];L=cdr(L)){
13308: if(car(L)[0]>I) return 0;
13309: if(car(L)[1]>=I){
13310: if(In==3) return car(L);
13311: if(In==1||(I!=car(L)[0]&&I!=car(L)[1])) return 1;
13312: return 2;
13313: }
13314: }
13315: return 0;
13316: }
13317: }
13318: I0=car(I);I1=I[1];
13319: for(F=0,R=[];L!=[];L=cdr(L)){
13320: if(I0>car(L)[1]){
13321: R=cons(car(L),R);
13322: continue;
13323: }
13324: if(I0<=car(L)[1]){
13325: I0=lmin([I0,car(L)[0]]);
13326: if(I1<car(L)[0]){
13327: R=cons([I0,I1],R);
13328: for( ;L!=[];L=cdr(L)) R=cons(car(L),R);
13329: F=1;
13330: break;
13331: }
13332: I1=lmax([I1,car(L)[1]]);
13333: }
13334: }
13335: if(!F) R=cons([I0,I1],R);
13336: return reverse(R);
1.18 takayama 13337: }
13338:
13339: def xy2curve(F,N,Lx,Ly,Lz,A,B)
13340: {
1.22 takayama 13341: Raw=getopt(raw);
13342: if(type(Gap=getopt(gap))==4){
13343: MG=Gap[1];Gap=car(Gap);
13344: }else MG=3;
13345: if(type(Gap)!=1 && Gap!=0) Gap=0.7;
13346: if(type(Dvi=getopt(dviout))<1) Dvi=0;
13347: OL=[["dviout",Dvi]];
13348: if(type(Opt=getopt(opt))<1) Opt=0;
13349: else OL=cons(["opt",Opt],OL);
13350: if(type(Sc=getopt(scale))!=1 && type(Sc)!=4) Sc=[1,1,1];
13351: else if(type(Sc)!=4) Sc=[Sc,Sc,Sc];
13352: else if(length(Sc)!=3) Sc=[Sc[0],Sc[1],Sc[1]];
13353: M=diagm(3,Sc);
13354: if(A!=0||B!=0){
13355: if(type(A)==6) M=A;
13356: else M=mrot([0,-B,-A]|deg=1)*M;
13357: V=M*newvect(3,[x,y,z]);
13358: Fx=compdf(V[0],[x,y,z],F);Fy=compdf(V[1],[x,y,z],F);Fz=compdf(V[2],[x,y,z],F);
13359: }else{
13360: for(I=0;I<3;I++){
13361: if(type(T=F[I])!=4) T=f2df(T);
13362: if(type(T)==4) T=cons(car(T)*Sc[I],cdr(T));
13363: else T*=Sc[I];
13364: if(I==0) Fx=T;
13365: else if(I==1) Fy=T;
13366: else Fz=T;
13367: }
13368: }
13369: if(Raw==5||!Gap)
13370: return (Dvi||!Gap)? xygraph([Fy,Fz],N,Lx,Ly,Lz|option_list=OL):[Fx,Fy,Fz];
1.18 takayama 13371: R=xygraph([Fy,Fz],N,Lx,Ly,Lz|raw=2);
1.22 takayama 13372: R0=cdr(car(R));R1=R[1];
13373: for(LT=[];R0!=[];R0=cdr(R0),R1=cdr(R1))
13374: if(car(R0)!=0) LT=cons([R1[0],R1[1]],LT);
13375: LT=reverse(LT);
1.19 takayama 13376: if(N<0){
13377: Be=xylines(car(R)|curve=1,proc=3,close=-1);
13378: LT=reverse(cdr(LT));
13379: LT=reverse(cdr(LT));
13380: }
13381: else Be=xylines(car(R)|curve=1,proc=3);
1.18 takayama 13382: Be=cdr(cdr(Be));
1.22 takayama 13383: Be=lbezier(car(Be));
13384: if(Raw==4) return [Be,LT,Lx];
13385: X=ptcombz(Be,0,0);
13386: Var=(length(Lx)==3)?car(Lx):x;
13387: if(type(Eq=getopt(eq))!=1) Eq=0.01;
13388: if(TikZ==1){
13389: Gap/=10;Eq/=10;
1.18 takayama 13390: }
13391: for(R=[],XT=X;XT!=[];XT=cdr(XT)){
13392: V=car(XT);
1.22 takayama 13393: U=LT[V[0][0]];
13394: T=U[0]*V[1][0]+U[1]*(1-V[1][0]);
13395: VV=myfdeval(Fx,[Var,T]);
13396: U=LT[V[0][1]];
1.18 takayama 13397: T=U[0]*V[1][1]+U[1]*(1-V[1][1]);
1.22 takayama 13398: VV-=myfdeval(Fx,[Var,T]);
13399: if(abs(VV)<Eq) continue;
13400: I=(VV<0)?0:1;
13401: R=cons([V[0][I],V[1][I],V[0][1-I],V[1][1-I]],R);
1.18 takayama 13402: }
13403: R=qsort(R);
1.22 takayama 13404: if(Raw==3) return [Be,R];
13405: Db=newvect(L=length(Be));
13406: for(I=0;I<L;I++) Db[I]=[];
13407: for(TR=R;TR!=[];TR=cdr(TR)){
13408: V1=ptbezier(Be,[I=car(TR)[0],P=car(TR)[1]])[1];
13409: V2=ptbezier(Be,[car(TR)[2],car(TR)[3]])[1];
13410: T=dsqrt(1-dvangle(V1,V2)^2);
13411: if(T<1/MG) T=MG;
13412: GP=Gap/T;
13413: W=GP/dnorm(V1);
13414: Db[I]=addIL([P-W,P+W],Db[I]);
13415: if(P-W<0 && I>0) Db[I-1]=addIL([P-W+1,1],Db[I-1]);
13416: if(P+W>1 && I+1<L) Db[I+1]=addIL([0,P+W-1],Db[I+1]);
13417: }
13418: Db=vtol(Db);
13419: for(Bf=[];Be!=[];Be=cdr(Be),Db=cdr(Db)){
13420: if(car(Db)==[]) Bf=cons(car(Be),Bf);
13421: else{
13422: D=addIL([0,1],car(Db)|in=-1);
13423: for(;D!=[];D=cdr(D))
13424: Bf=cons(tobezier(car(Be)|inv=car(D)),Bf);
13425: }
13426: }
13427: Bf=reverse(Bf);
13428: if(Raw==2) return Bf;
13429: OL=[];
13430: if(Opt){
13431: if(type(Opt)==4&&length(Opt)>1) OL=[["opt",Opt[0]],["cmd",Opt[1]]];
13432: else OL=[["opt",Opt]];
13433: }else OL=[];
13434: S=xybezier(lbezier(Bf|inv=1)|option_list=OL);
13435: if(Raw==1||!Dvi) return S;
13436: return xyproc(S|dviout=Dvi);
13437: }
13438:
13439: def rungeKutta(F,N,Lx,Y,IY)
13440: {
13441: if((Pr=getopt(prec))==1){
13442: One=eval(exp(0));
13443: }else{
1.58 takayama 13444: One=deval(exp(0));Pr=0;
1.22 takayama 13445: }
1.57 takayama 13446: if(!isint(FL=getopt(mul))||!FL) FL=1;
1.22 takayama 13447: if(length(Lx)>2){
13448: V=car(Lx);Lx=cdr(Lx);
13449: }else V=x;
1.58 takayama 13450: if(Pr==1) Lx=[eval(Lx[0]),eval(Lx[1])];
13451: else Lx=[deval(Lx[0]),deval(Lx[1])];
1.22 takayama 13452: if(type(Y)==4){
13453: if((Sing=getopt(single))==1||type(F)!=4)
13454: F=append(cdr(Y),[F]);
13455: L=length(Y);
13456: for(TF=[];F!=[];F=cdr(F))
13457: TF=cons(f2df(car(F)),TF);
13458: F=reverse(TF);
13459: }else{
13460: L=1;
13461: F=f2df(F);
13462: }
13463: if(getopt(val)==1) V1=1;
13464: else V1=0;
1.57 takayama 13465: if(FL>0) N*=FL;
1.58 takayama 13466: H=(Lx[1]-Lx[0])/N*One;H2=H/2;
1.22 takayama 13467: FV=findin(V,vars(F));
13468: K=newvect(4);
13469: if(L==1){
13470: R=[[T=Lx[0],S=IY]];
13471: if(!H) return R;
1.57 takayama 13472: for(C=0;C<N;C++){
1.22 takayama 13473: for(I=0;I<4;I++){
13474: if(I==0) W=[[V,T],[Y,S]];
13475: else if(I==3) W=[[V,T+H],[Y,S+H*K[2]]];
13476: else W=[[V,T+H2],[Y,S+H2*K[I-1]]];
13477: if(FV<0) W=cdr(W);
13478: K[I]=Pr?myfeval(F,W)*One:myfdeval(F,W);
13479: }
13480: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
1.57 takayama 13481: if(FL>0&&!((C+1)%FL)) R=cons([deval(T),S],R);
1.22 takayama 13482: }
13483: }else{
13484: T=Lx[0];
13485: R=[cons(T,V1?[car(IY)]:IY)];
13486: S=ltov(IY);
13487: if(!H) return R;
1.57 takayama 13488: for(C=0;C<N;C++){
1.22 takayama 13489: for(I=0;I<4;I++){
13490: if(I==0) W=cons([V,T ],lpair(Y,vtol(S)));
13491: else if(I==3) W=cons([V,T+H ],lpair(Y,vtol(S+H*K[2])));
13492: else W=cons([V,T+H2],lpair(Y,vtol(S+H2*K[I-1])));
13493: if(FV<0) W=cdr(W);
13494: for(TK=[],TF=F;TF!=[];TF=cdr(TF)){
13495: TK=cons(Pr?myfeval(car(TF),W)*One:myfdeval(car(TF),W),TK);
13496: }
13497: K[I]=ltov(reverse(TK));
13498: }
13499: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
13500: TS=vtol(S);
1.58 takayama 13501: if(FL<0||(C+1)%FL) continue;
1.22 takayama 13502: if(V1) TS=[car(TS)];
1.58 takayama 13503: R=cons(cons(deval(T),TS),R);
1.22 takayama 13504: }
13505: }
1.58 takayama 13506: L=(FL<0)?(V1?S[0]:S):reverse(R);
13507: return L;
1.57 takayama 13508: }
13509:
13510: def pwTaylor(F,N,Lx,Y,Ly,M)
13511: {
1.68 takayama 13512: /* Pr:bigfloat, V1:last, Sf: single, Tf: autonomous, */
1.58 takayama 13513: if(!isint(FL=getopt(mul))||!FL) FL=1;
13514: if(getopt(val)==1) V1=1;
13515: else V1=0;
1.59 takayama 13516: if(length(Lx)>2){
13517: V=car(Lx);Lx=cdr(Lx);
13518: }else V=t;
13519: if(!isvar(T=getopt(var))) V=t;
13520: if(isint(Pr=getopt(prec))&&Pr>0){
13521: One=eval(exp(0));
13522: if(Pr>9){
13523: setprec(Pr);
13524: ctrl("bigfloat",1);
13525: }
13526: Pr=1;
13527: }else{
13528: One=deval(exp(0));Pr=0;
13529: }
13530: if(Pr==1) Lx=[eval(Lx[0]),eval(Lx[1])];
13531: else Lx=[deval(Lx[0]),deval(Lx[1])];
1.68 takayama 13532: Sf=(type(F)!=4)?1:0;
1.59 takayama 13533: if(type(Y)==4){
13534: if(type(F)!=4) F=append(cdr(Y),[F]);
13535: }else Y=[Y];
13536: if(type(Ly)!=4) Ly=[Ly];
1.68 takayama 13537: if(findin(V,vars(F))>=0){
13538: if(type(F)!=4) F=[F];
13539: Tf=1;F=cons(1,subst(F,V,z_z));Y=cons(z_z,Y);Ly=cons(car(Lx),Ly);
13540: }else Tf=0; /* Tf: autonomous */
1.60 takayama 13541: ErF=0;
1.59 takayama 13542: if(type(Er=getopt(err))==4){
1.61 takayama 13543: if(length(Er)==2) ErF=Er[1]; /* ErF&1: Raw, ErF&2: relative, ErF&4: add Sol */
1.60 takayama 13544: Er=car(Er);
13545: };
13546: if(!isint(Er)||Er<0) Er=0; /* 基準解を返す */
1.59 takayama 13547: if(FL>0) N*=FL;
13548: S=vtol(pTaylor(F,Y,M|time=V));
13549: FM=pmaj(F|var=x);
13550: LS=length(S);
13551:
13552: if(type(Vw=getopt(view))==4){ /* Dislay on Canvas */
1.61 takayama 13553: Glib_math_coordinate=1;
1.68 takayama 13554: glib_window(car(Vw)[0], car(Vw)[2],car(Vw)[1],car(Vw)[3]);
1.67 takayama 13555: if(length(car(Vw))==6) Vr=[car(Vw)[4],car(Vw)[5]];
13556: else Vr=0;
1.66 takayama 13557: if(length(Vw)>1){
13558: if(type(Cl=Vw[1])==4) Cl=map(os_md.trcolor,Cl);
13559: else Cl=trcolor(Cl);
13560: }else Cl=0;
1.59 takayama 13561: if(length(Vw)>2){
13562: Mt=Vw[2];
13563: if(LS==1){
13564: if(type(Mt)>1) Mt=0;
13565: }else{
1.68 takayama 13566: if(type(Mt)!=6||((Ms=size(Mt)[0])!=2&&Ms!=3)) Mt=0;
13567: if(Ms!=3) Vr=0;
1.59 takayama 13568: }
1.68 takayama 13569: if(Tf&&type(Mt)==6) Mt=newbmat(2,2,[[1,0],[0,Mt]]);
1.59 takayama 13570: }else Mt=0;
13571: if(!Mt){
1.68 takayama 13572: if(LS>1+Tf){
1.67 takayama 13573: if(Vr){
1.68 takayama 13574: Mt=newmat(3,LS);Mt[2+Tf][2+Tf]=1;
1.67 takayama 13575: }
13576: else Mt=newmat(2,LS);
1.68 takayama 13577: Mt[Tf][Tf]=Mt[Tf+1][Tf+1]=1;
1.59 takayama 13578: }else Mt=1;
1.68 takayama 13579: if(LS==1+Tf||Sf) glib_putpixel(Lx[0],Mt*Ly[Tf]|color=mcolor(Cl,0));
1.59 takayama 13580: else{
1.67 takayama 13581: YT=Mt*ltov(Ly);
1.66 takayama 13582: glib_putpixel(YT[0],YT[1]|color=mcolor(Cl,0));
1.59 takayama 13583: }
13584: }
13585: }else Vw=0;
13586:
1.68 takayama 13587: T=Lx[0];
13588: RE=R=(Tf)?[Ly]:[cons(T,Ly)];
1.59 takayama 13589: H=(Lx[1]-Lx[0])/N*One;
1.65 takayama 13590:
13591: Ck=N+1;CB=10;Ckm=2;MM=2;C1=1;
13592: if(Ck<5) Ck=100;
13593: if(type(Inf=getopt(Inf))==4&&length(Inf)>1&&Inf[0]>4){ /* explosion */
1.59 takayama 13594: Ck=Inf[0];Ckm=Inf[1];
13595: if(length(Inf)>2) MM=Inf[2];
1.67 takayama 13596: if(!isint(MM)||MM<1) MM=2;
1.59 takayama 13597: if(length(Inf)>3) C1=Inf[3];
1.60 takayama 13598: if(type(C1)!=1||C1<0) C1=1;
1.65 takayama 13599: if(length(Inf)>4) CB=Inf[4];
13600: }else if(isint(Inf)&&Inf>0&&Inf<100){
13601: MM=Inf+1;Ck=100;
1.59 takayama 13602: }else Inf=0;
1.60 takayama 13603: Ckm*=Ck;
1.65 takayama 13604:
1.66 takayama 13605: SS=subst(S,V,H);N0=N;
1.59 takayama 13606: if(Er>0){
1.61 takayama 13607: HE=H/(Er+1);SSE=subst(S,V,HE);LyE=Ly;
1.59 takayama 13608: }
1.65 takayama 13609: for(C=CC=CF=0;C<N;C++,CC++){
1.59 takayama 13610: if(CC>=Ck){ /* check explosion */
13611: CC=0;
13612: D0=dnorm(Ly|max=1);
1.65 takayama 13613: if(Er&&CF){
13614: DE=dnorm(ladd(LyE,Ly,-1)|max=1);
13615: if(CB*DE>D0) break;
13616: }
1.59 takayama 13617: for(Dy=F,TY=Y,TL=Ly;TY!=[];TY=cdr(TY),TL=cdr(TL))
13618: Dy=subst(Dy,car(TY),One*car(TL));
13619: D1=dnorm(Dy|max=1);D2=subst(FM,x,2*D0+C1);D3=D1+D2;
1.60 takayama 13620: HH=2*(D0+C1)/Ckm;
1.59 takayama 13621: if(HH<H*D3){
1.60 takayama 13622: HH/=D3;
13623: while(H>HH) H/=2;
13624: if(H*7/5<HH) H*=7/5;
13625: if(H*6/5<HH) H*=6/5;
1.59 takayama 13626: SS=subst(S,V,H);
13627: if(Er){
1.65 takayama 13628: CF++;
1.59 takayama 13629: HE=H/(Er+1);
13630: SSE=subst(S,V,HE);
13631: }
13632: if(MM>1) N*=MM;
13633: MM=0;
13634: }
13635: CC=0;
13636: }
13637:
13638: T+=H;
13639: for(Dy=SS,TY=Y,TL=Ly;TY!=[];TY=cdr(TY),TL=cdr(TL))
13640: Dy=subst(Dy,car(TY),One*car(TL));
13641: Ly=Dy;
13642:
13643: if(Er>0){ /* estimate error */
1.60 takayama 13644: for(CE=0;CE<=Er;CE++){
1.59 takayama 13645: for(Dy=SSE,TY=Y,TL=LyE;TY!=[];TY=cdr(TY),TL=cdr(TL))
13646: Dy=subst(Dy,car(TY),One*car(TL));
13647: LyE=Dy;
13648: }
13649: }
13650: if(FL<0||(C+1)%FL) continue;
13651: if(Vw){
1.68 takayama 13652: if(LS==1+Tf||Sf) CR=CC/N0;
1.59 takayama 13653: else{
1.67 takayama 13654: YT=Mt*ltov(Ly);
13655: CR=(!Vr)?CC/N0:(YT[2]-Vr[0])/(Vr[1]-Vr[0]);
1.59 takayama 13656: }
1.68 takayama 13657: if(LS==1+Tf||Sf) glib_putpixel(deval(T),Mt*Ly[Tf]|color=mcolor(Cl,CR));
1.67 takayama 13658: else glib_putpixel(YT[0],YT[1]|color=mcolor(Cl,CR));
1.59 takayama 13659: continue;
13660: }
1.68 takayama 13661: TR=(V1)?[car(Ly)]:Ly;
13662: if(!Tf) TR=cons((Inf)?eval(T):deval(T),TR);
1.59 takayama 13663: R=cons(TR,R);
13664: if(Er){
1.68 takayama 13665: TRE=(V1)?[car(LyE)]:LyE;
13666: if(!Tf) TRE=cons((Inf)?eval(T):deval(T),TRE);
1.59 takayama 13667: RE=cons(TRE,RE);
13668: }
13669: }
13670: if(Vw) return 1;
13671: L=(FL<0)?((V1)?car(Ly):Ly):reverse(R);
13672: if(Er){ /* Estimate error */
13673: LE=(FL<0)?((V1)?car(LyE):LyE):reverse(RE);
13674: if(FL>0){
13675: for(S=L,T=LE,D=[];S!=[];S=cdr(S),T=cdr(T)) D=cons(os_md.ladd(car(S),car(T),-1),D);
13676: F=map(os_md.dnorm,reverse(D));
1.60 takayama 13677: if(iand(ErF,2)){ /* relative error */
1.61 takayama 13678: G=llget(LE,-1,[0]);
13679: G=map(os_md.dnorm,G);
1.60 takayama 13680: for(R=[];G!=[];G=cdr(G),F=cdr(F)){
13681: if(car(G)) R=cons(car(F)/car(G),R);
13682: else R=cons(0,R);
13683: }
13684: F=reverse(R);
13685: }
13686: if(!iand(ErF,1)) F=map(os_md.nlog,F);
13687: if(!iand(ErF,8)) F=map(deval,F);
1.59 takayama 13688: }else if(V1){
13689: D=ladd(L,LE,-1);F=dnorm(D);
1.60 takayama 13690: if(iand(ErF,2)){
13691: G=dnorm(cdr(L));
13692: if(!G) D/=G;
13693: else D=1;
13694: }
13695: F=(!iand(ErF,1))?nlog(D):D;
13696: if(!iand(ErF,8)) F=deval(F);
1.59 takayama 13697: }else{
1.60 takayama 13698: D=abs(L-LE);
13699: if(iand(ErF,2)){
13700: G=abs(L);
13701: if(!G) D/=G;
13702: else D=1;
1.58 takayama 13703: }
1.60 takayama 13704: F=(!iand(ErF,1))?nlog(D):D;
13705: if(!iand(ErF,8)) F=deval(F);
1.58 takayama 13706: }
1.61 takayama 13707: return iand(ErF,4)?[L,F,LE]:[L,F];
1.57 takayama 13708: }
1.58 takayama 13709: return L;
1.18 takayama 13710: }
13711:
1.6 takayama 13712: def xy2graph(F0,N,Lx,Ly,Lz,A,B)
13713: {
1.18 takayama 13714: /* (x,y,z) -> (z sin B + x cos A cos B + y sin A cos B,
13715: -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */
1.6 takayama 13716: if((Proc=getopt(proc))==1||Proc==2){
13717: OPT0=[["proc",3]];
13718: }else{
13719: Proc=0;OPT0=[];
13720: }
13721: if(type(DV=getopt(dviout))==4){
13722: S=["ext","shift","cl","dviout"];
13723: OL=delopt(getopt(),S);
13724: OL=cons(["proc",1],OL);
13725: R=xy2graph(F0,N,Lx,Ly,Lz,A,B|option_list=OL);
13726: OL=delopt(getopt(),S|inv=1);
13727: return execdraw(R,DV|optilon_list=OL);
13728: }
13729: if(N==0 || N>100 || N<-100) N=-16;
13730: if(N<0){
13731: N=-N;N1=-1;N2=NN+1;
13732: }else{
13733: N1=0;N2=NN=N;
13734: }
13735:
13736: Ratio=Ratio2=1;
13737: if(type(Sc=Sc0=getopt(scale))!=1 && type(Sc)!=4) Sc=1;
13738: if(type(Sc)==4){
13739: Ratio=Sc[1]/Sc[0];
13740: if(length(Sc)>2) Ratio2=Sc[2]/Sc[0];
13741: Sc=Sc[0];
13742: }
13743: if(type(Vw=getopt(view))!=1) Vw=0;
13744: if(type(Raw=getopt(raw))!=1) Raw=0;
13745: if(type(M1=getopt(dev))==1) M2=M1;
13746: else if(type(M1)==4){
13747: M2=M1[1];M1=M1[0];
13748: }else M1=0;
13749: if(type(M3=getopt(acc))!=1 || (M3<0.5 && M3>100)) M3=1;
13750: if(M1<=0) M1=16;
13751: if(M2<=0) M2=16;
13752: OL=[["para",1],["scale",Sc]];
13753: if(Raw==1) OL=cons(["raw",1],OL);
13754: if(type(Prec=getopt(prec))>=0) OL=cons(["prec",Prec],OL);
13755: L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]);
13756: Lx=[deval(Lx[0]),deval(Lx[1])];
13757: Ly=[deval(Ly[0]),deval(Ly[1])];
13758: Lz=[deval(Lz[0]),deval(Lz[1])];
13759: A=(A0=A)%360;
13760: F00=F0;
13761: if(type(F0)<4){
13762: FC=f2df(F0);
13763: if(findin(z,Vars=vars(FC))>=0 && findin(x,Vars)<0 && findin(y,Vars)<0)
13764: F0=[w,[z,0,x+y*@i],[w,os_md.abs,FC]];
13765: }
13766: if(type(Org=getopt(org))==4){ /* shift origin */
13767: Lx=[Lx[0]-Org[0],Lx[1]-Org[0]];
13768: Ly=[Ly[0]-Org[1],Ly[1]-Org[1]];
13769: Lz=[Lz[0]-Org[2],Lz[1]-Org[2]];
13770: F0=mysubst(F0,[[x,x+Org[0]],[y,y+Org[1]]]);
13771: if(type(F0)==4){
13772: F0=cons(F0[0]-Org[2],cdr(F0));
13773: }
13774: else F0-=Org[2];
13775: }else Org=[0,0,0];
13776: Cpx=getopt(cpx);
13777: if(type(Cpx)<0){
13778: if(str_str(rtostr(F0),"@i")>=0) Cpx=1;
13779: else Cpx=0;
13780: }
13781: if(A<0) A+=360;
13782: if(A<90){
13783: Sh=1;F1=F0;Cx=x-Org[0];Cy=y-Org[1];
13784: }else if(A<180){ /* x -> y, y -> -x */
13785: Sh=2;A-=90; F1=mulsubst(F0,[[x,-y],[y,x]]);
13786: LL=Ly;Ly=[-Lx[1],-Lx[0]];Lx=LL;Cx=y-Org[1];Cy=-x+Org[0];
13787: }else if(A<270){
13788: Sh=3;A-=180; F1=subst(F0,[[x,-x],[y,-y]]);
13789: Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];Cx=-x+Org[0];Cy=-y+Org[1];
13790: }else{
13791: Sh=4;A-=270;F1=mulsubst(F0,[[x,y],[y,-x]]);
13792: LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;Cx=-y+Org[1];Cy=x-Org[0];
13793: }
13794: A=@pi*A/180; B=@pi*B/180;
13795: if(A==0) A=@pi/3;
13796: if(B==0) B=@pi/12;
13797: NN=N*M2;
13798: Ac=dcos(deval(A)); As=dsin(deval(A));
13799: if(Ac<=0.087 || As<=0.087){
13800: mycat(["Unsuitable angle",A0,"(6-th argument)!"]);
13801: return -1;
13802: }
13803: Bc=Ratio*dcos(deval(B)); Bs=dsin(deval(B));
13804: if(Bc<0){
13805: mycat("Unsuitable angle (7-th argument)!");
13806: return -1;
13807: }
13808: /*
13809: z = f(x,y) => X=-As*x+Ac*y, Y= Bc*f(x,y)-Bsc*x-Bss*y
13810: Out X-coord is in [X0,X1], dvided by Dev segments
13811: J-th segment of Y-coord : ZF[J]==1 => [Z0[0],Z1[J]]
13812: */
13813: Bsc=Bs*Ac;Bss=Bs*As;
13814: if(Ratio2!=1){
13815: if(Sh%2==1){
13816: Ac*=Ratio2;Bss*=Ratio2;
13817: }else{
13818: As*=Ratio2;Bsc*=Ratio2;
13819: }
13820: }
13821: CX=-As*Cx+Ac*Cy;CY=Bc*(z-Org[2])-Bsc*Cx-Bss*Cy;
13822: if(type(Dvi=getopt(dviout))!=1 && getopt(trans)==1) return [CX*Sc,CY*Sc];
13823: if(type(N1=getopt(inf))==1){
13824: if(Proc) Dvi=N1;
13825: else if(Dvi<=0) Dvi=-N1;
13826: }
13827: X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1];
13828: F1=mysubst(F1,[@pi,deval(@pi)]);
13829: Tf=type(F1=f2df(F1|opt=0));
13830: if(Tf!=4) F=Bc*F1-Bsc*x-Bss*y;
13831: else F=append([Bc*F1[0]-Bsc*x-Bss*y],cdr(F1));
13832: Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN;
13833: if(type(Err=getopt(err))==1)
13834: F=mysubst(F,[[x,x+Err*Dx/1011.23],[y,y+Err*Dy/1101.34]]);
13835: Out=(Proc)?[]:str_tb(0,0);
13836: Dev=N*M1;
13837: XD=(X1-X0)/Dev;
13838: OLV=newvect(2,[OL,OL]);
13839: if(type(Ura=getopt(opt))==4 || type(Ura)==7){
13840: if(type(Ura)==7) Ura=[Ura,Ura];
13841: else{
13842: OLV[0]=cons(["opt",Ura[0]],OL);
13843: OLV[1]=cons(["opt",Ura[1]],OL);
13844: }
13845: }
13846: for(KC=0; KC<=1; KC++){ /* draw curves */
13847: Z0=newvect(Dev+1); Z1=newvect(Dev+1); ZF=newvect(Dev+1);
13848: for(I=0; I<=NN; I++){
13849: FV=I%M2;
13850: if(KC==0){
13851: X=x; Y=Ly[1]-I*Dy; LX=Lx; DD=Dx; G=mysubst(F,[y,Y]);
13852: if(!FV){
13853: if(!Proc) str_tb(["%y=",rtostr(Y),"\n"],Out);
13854: else Out=cons([-2,"y="+rtostr(Y)],Out);
13855: }
13856: }else{
13857: X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=mysubst(F,[[x,X],[y,Y]]);
13858: if(!FV){
13859: if(!Proc) str_tb(["%x=",rtostr(X),"\n"],Out);
13860: else Out=cons([-2,"x="+rtostr(X)],Out);
13861: }
13862: }
13863: XX=-As*X+Ac*Y; A1=coef(XX,1,x); A0=coef(XX,0,x); /* XX = A1*x + A0, x = (XX-A0)/A1 */
13864: if(!FV && Vw==1){
13865: if(Proc) Out=cons(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1,proc=3),Out);
13866: else str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1),Out);
13867: continue;
13868: }
13869: V=VT=LX[1];
13870: J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD;
13871: if(J0<J1){
13872: J0=ceil(J0); J1=floor(J1); JD=1; /* fixed x: y: dec => (x,z):(dec,inc) */
13873: }else{
13874: J0=floor(J0); J1=ceil(J1); JD=-1; /* fixed y: x: dec => (x,z):(inc,inc) */
13875: }
13876: for(FF=1,J=J1;;J-=JD){
13877: V1=VT;
13878: VT=(X0+J*XD-A0)/A1;GG=mysubst(G,[x,VT]);
13879: if(Cpx>=1) VV=myeval(GG);
13880: else VV=(Tf==4)? mydeval(GG):deval(GG); /* J -> V */
13881: if(ZF[J]==0 || VV<=Z0[J] || VV>=Z1[J]){ /* visible */
13882: if(FF==0){
13883: V0=(VT+V1)/2;
13884: if(!FV && Vw==-1 && Raw!=1){ /* draw doted line */
13885: K=ceil(M3*(V-V0)/(M2*DD));
13886: if(N1<0) K=-K;
13887: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"],["scale",Sc],["para",1]]);
13888: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|
13889: option_list=OPT),Out);
13890: }
13891: V=V0;
13892: }
13893: if(ZF[J]==0){
13894: ZF[J]=1; Z0[J]=Z1[J]=VV;
13895: }else if(VV<=Z0[J]) Z0[J]=VV;
13896: else Z1[J]=VV;
13897:
13898: if(VV>=Z1[J]) FF=1;
13899: else if(VV<=Z0[J]) FF=-1;
13900: }else{
13901: if(FF!=0){
13902: V0=(VT+V1)/2;
13903: K=ceil(M3*(V-V0)/(M2*DD));
13904: if(N1<0) K=-K;
13905: if(!FV){
13906: OPT=append(OPT0,OLV[(1-FF)/2]);
13907: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
13908: }
13909: V=V0;
13910: }
13911: FF=0;
13912: }
13913: if(J==J0) break;
13914: }
13915: if(FV) continue;
13916: V0=LX[0];K=ceil(M3*(V-V0)/(M2*DD));
13917: if(N1<0) K=-K;
13918: if(FF!=0){
13919: if(Raw!=1){
13920: OPT=append(OPT0,OLV[(1-FF)/2]);
13921: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
13922: }else if(Vw==-1 && Raw!=1){
13923: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"]]);
13924: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
13925: }
13926: }
13927: }
13928: }
13929: OptSc=(Sc==1)?[]:[["scale",Sc]];
13930: if(type(LZ=getopt(ax))==4){ /* draw box */
13931: FC=0;
13932: if(length(LZ)==3) FC=LZ[2];
13933: P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*(LZ[0]-Org[0])-Bsc*Lx[1]-Bss*Ly[1]]);
13934: Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]);
13935: Vy=newvect(2,[Ac*(Ly[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]);
13936: Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]);
13937: OL=OL0=append(OPT0,OL);
13938: if(TikZ && type(Ura)==4 && length(Ura)>2) OL0=cons(["opt",Ura[2]],OL);
13939: LL=[[P0+Vz,P0+Vx+Vz],[P0,P0+Vx]];
13940: if(Bs>0){
13941: LL=cons([P0+Vy+Vz,Pz=P0+Vx+Vy+Vz],LL);
13942: LL=cons([P0+Vx+Vz,Pz],LL);
13943: PP=Pz-Vz;
13944: }
13945: else{
13946: LL=cons([P0+Vy,Pz=P0+Vx+Vy+Vz],LL);
13947: LL=cons([P0+Vx,Pz],LL);
13948: PP=Pz+Vz;
13949: }
13950: J=ceil((PP[0]-X0)/XD+0.5);
13951: LL=append([[P0+Vy,P0+Vy+Vz],[P0+Vy,P0+Vy+Vz],[P0+Vx,P0+Vx+Vz],[P0,P0+Vz],
13952: [P0+Vz,P0+Vy+Vz],[P0,P0+Vy]],LL);
13953: for(LL=reverse(LL);LL!=[];LL=cdr(LL)) Out=saveproc(xylines(car(LL)|option_list=OL0),Out);
13954: if(Dev>4) Dev2=ceil(Dev/2);
13955: if(FC<0 && Raw!=1){
13956: if(TikZ){
13957: if(type(Ura)==4 && length(Ura)>2)
13958: OL1=cons(["opt",Ura[2]+",dotted"],OL);
13959: else OL1=cons(["opt","dotted"],OL);
13960: }else OL1=cons(["opt","@{.}"],OL);
13961: if(FC==-8) FC=0;
13962: }
13963: for(I=0;I<3;I++){ /* box with hidden part */
13964: if(I==1) Pz=PP-Vx;
13965: else if(I==2) Pz=PP-Vy;
13966: LP=Pz-PP;
13967: for(FV=-1,K=0;K<=Dev2; K++){
13968: PPx=PP[0]+(K/Dev2)*LP[0]; PPy=PP[1]+(K/Dev2)*LP[1];
13969: J=ceil((PPx-X0)/XD);
13970: if(K!=Dev2 && (J<0||J>Dev)) continue;
13971: if(K!=Dev2 && (ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){ /* visible */
13972: if(FV!=1){
13973: FV=1;
13974: PPP=[PPx,PPy];
13975: }
13976: }else{
13977: if(FV!=0){
13978: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
13979: FV=0;
13980: }
13981: }
13982: }
13983: }
13984: if(FC!=0 && Raw!=1){ /* show coordinate*/
13985: if(iand(FC,4)){
13986: Sub=1;
13987: if(TikZ){
13988: S0="\\scriptsize";S1="";
13989: }else{
13990: S0="{}_{"; S1="}";
13991: }
13992: }else Sub=0;
13993: if(iand(FC,2))
13994: LLL=[[1,0,P0+Vx,(TikZ)?"right":"+!L"],[3,0,P0+Vy,(TikZ)?"left":"+!R"]];
13995: else LL=[];
13996: if(Bs>0){
13997: LLL=cons([0,0,P0,(TikZ)?"below":"+!U"],LLL);
13998: LLL=cons([2,1,P0+Vx+Vy+Vz,(TikZ)?"above":"+!D"],LLL);
13999: }else{
14000: LLL=cons([2,0,P0+Vx+Vy,(TikZ)?"below":"+!U"],LLL);
14001: LLL=cons([0,1,P0+Vz,(TikZ)?"above":"+!D"],LLL);
14002: }
14003: for(TLL=LLL;TLL!=[];TLL=cdr(TLL)){
14004: TL=car(TLL);LL=L[(Sh+TL[0])%4];
14005: if(Cpx==0 || Cpx==3){
14006: S=ltotex([LL[0],LL[1],LZ[TL[1]]]|opt="coord");
14007: SS="("+rtostr(LL[0]) +","+rtostr(LL[1])+","+rtostr(LZ[TL[1]])+")";
14008: }else{
14009: S=ltotex([LL[0]+LL[1]*@i,LZ[TL[1]]]|opt="coord",cpx=Cpx);
14010: SS="("+rtostr(LL[0])+"+"+rtostr(LL[1])+"i,"+ rtostr(LZ[TL[1]])+")";
14011: }
14012: if(TikZ) S="$"+S+"$";
14013: if(Sub) S=S0+S+S1;
14014: if(!TikZ) S="$"+S+"$";
14015: if(Proc) Out=cons([2,OptSc,[TL[2][0],TL[2][1]],[[TL[3],S]],SS],Out);
14016: else str_tb(xyput([TL[2][0],TL[2][1],[TL[3],S]]|option_list=OptSc),Out);
14017: }
14018: }
14019: }
14020: if(type(Pt=getopt(pt))==4){ /* option pt=[] */
14021: if(type(Pt[0])<4) Pt=[[Pt]];
14022: if(length(Pt)>1&&type(Pt[1])!=4) Pt=[Pt];
14023: for(PT=Pt;PT!=[];PT=cdr(PT)){
14024: PP=car(PT);
14025: if(type(PP)==4 && length(PP)==3 && type(PP[0])<2 && type(PP[2])<2) PP=[PP];
14026: P=car(PP);
14027: if(type(P)==7) Q=[P,0];
14028: else if(P==1) Q=["_",0];
14029: else Q=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
14030: if(length(PP)>1 && type(PP[1])==4 && length(PP[1])==3){ /* draw line */
14031: PP=cdr(PP);P=car(PP);
14032: if(type(P)==7) Q1=P;
14033: else if(P==1) Q="_";
14034: else Q1=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
14035: if(length(PP)<2 || PP[1]==0 || iand(PP[1],1)) OL2="";
14036: else OL2=(TikZ)?"dotted":"@{.}";
14037: if(length(PP)>2 && type(PP[2])==7){
14038: if(OL2=="") OL2=PP[2];
14039: else{
14040: if(TikZ) OL2=OL2+",";
14041: OL2=OL2+PP[2];
14042: }
14043: }
14044: OL1=OL;
14045: if(OL2!="") OL1=cons(["opt",OL2],OL1);
14046: if(length(PP)<2 || PP[1]>=0)
14047: Out=saveproc(xylines([Q,Q1]|option_list=OL1),Out);
14048: else{
14049: LP0=Q1[0]-Q[0];LP1=Q1[1]-Q[1];
14050: for(FV=-1,K=0;K<=Dev2; K++){
14051: PPx=Q[0]+(K/Dev2)*LP0; PPy=Q[1]+(K/Dev2)*LP1;
14052: J=ceil((PPx-X0)/XD);
14053: if(K!=Dev2 && (J<0 || J>Dev || ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){
14054: /* visible */
14055: if(FV!=1){
14056: FV=1;
14057: PPP=[PPx,PPy];
14058: }
14059: }else{
14060: if(FV!=0){
14061: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
14062: FV=0;
14063: }
14064: }
14065: }
14066: }
14067: continue;
14068: }
14069: if(length(PP)==1) S="$\\bullet$";
14070: else if(type(PP[1])==7) S=PP[1];
14071: else if(type(PP[1])==4){
14072: if(length(PP[1])>1 && type(PP[1][1])!=7)
14073: S=cons(car(PP),cons("$\\bullet$",cdr(cdr(PP))));
14074: else S=PP[1];
14075: }else S="$\\bullet$";
14076: if(length(PP)<=2){
14077: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S]],Out);
14078: else str_tb(xyput([Q[0],Q[1],S]|option_list=OptSc),Out);
14079: }else if(!TikZ){
14080: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S,"",PP[2]]],Out);
14081: else str_tb(xyput([Q[0],Q[1],S,"",PP[2]]|option_list=OptSc),Out);
14082: }else{
14083: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],cons(S,cdr(cdr(PP)))],Out);
14084: else str_tb(xyput(append([Q[0],Q[1],S],cdr(cdr(PP)))|option_list=OptSc),Out);
14085: }
14086: }
14087: }
14088: if(Proc){
14089: S=reverse(Out);
14090: if(Proc==1||Proc==3){
14091: for(W=[],I=0;I<2;I++) for(J=0;J<2;J++) for(K=0;K<2;K++)
14092: W=cons(mysubst([CX*Sc,CY*Sc],[[x,Lx[I]],[y,Ly[J]],[z,Lz[K]]]),W);
14093: W=ptbbox(W);
14094: S=cons([0,W[0],W[1],(TikZ)?1:1/10],S);
14095: }
14096: }else S=str_tb(0,Out);
14097: if(type(Dvi)!=1||(Proc&&abs(Dvi)<2)) return S;
14098: Lout=[];
14099: if(abs(Dvi)>=2){
14100: /* show title */
14101: L0=[];
14102: Title=getopt(title);
14103: if(type(Title)!=7)
14104: Title=(type(F00)==4)?("\\texttt{"+verb_tex_form(F00)+"}"):my_tex_form(F00);
14105: if(type(Title)==7){
14106: T=my_tex_form(L[3][0])+"\\le x\\le "+my_tex_form(L[1][0])+",\\,"+
14107: my_tex_form(L[3][1])+"\\le y\\le "+my_tex_form(L[1][1])+")";
14108: if(Proc){
14109: if(Cpx>=1) L0=[[5,[["eq",1]],"|"+Title+"|\\quad(z=x+yi,\\ "+T]];
14110: else L0=[[5,[["eq",1]],"z="+Title+"\\ \\ ("+T]];
14111: }else{
14112: if(Cpx>=1) dviout("|"+Title+"|\\quad(z=x+yi,\\ "+T|eq=1,keep=1);
14113: else dviout("z="+Title+"\\ \\ ("+T|eq=1,keep=1);
14114: }
14115: }
14116: A=rint(deval(180*A/@pi))+90*(Sh-1);
14117: if(A>=180) A-=180;
14118: B=rint(deval(180*B/@pi));
14119: if(abs(Dvi)>=3){
14120: T="\\text{angle } ("+my_tex_form(A)+"^\\circ,"+my_tex_form(B)+"^\\circ)";
14121: if(Ratio!=1 || Ratio2!=1) T=T+"\\quad\\text{ratio }1:"
14122: +my_tex_form(sint(Ratio2,2))+":"+my_tex_form(sint(Ratio,2));
14123: if(Proc) L0=cons([5,[["eq",1]],T],L0);
14124: else dviout(T|eq=1,keep=1);
14125: }
14126: SS="% range "+rtostr([L[3][0],L[1][0]])+"x"+rtostr([L[3][1],L[1][1]])+
14127: " angle ("+ rtostr(A) +","+ rtostr(B)+") dev=";
14128: if(M1==M2) SS=SS+rtostr(M1);
14129: else SS=SS+rtostr([M1,M2]);
14130: if(M3!=1) SS=SS+" acc="+rtostr(M3);
14131: if(type(Sc0)>=0) SS=SS+" scale="+rtostr(Sc0);
14132: if(Proc){
14133: S=cons([5,[],SS],S);
14134: for(;L0!=[];L0=cdr(L0)) S=cons(car(L0),S);
14135: return S;
14136: }
14137: if(Dvi>0){
14138: dviout(SS|keep=1);
14139: dviout(xyproc(S)|eq=8);
14140: }else Lout=[SS,S];
14141: }else{
14142: if(Dvi>0) dviout(xyproc(S));
14143: else Lout=[S];
14144: }
14145: if(getopt(trans)==1) return cons([CX*Sc,CY*Sc],Lout);
14146: if(Dvi<0) return Lout;
14147: }
14148:
1.20 takayama 14149: def orthpoly(N)
14150: {
14151: F=0;
14152: if(type(P=getopt(pol))==7){
14153: for(L=["Le","Ge","Tc","2T","Ja","He","La","Se"];L!=[];L=cdr(L),F++)
14154: if(str_str(P,car(L)|end=2)==0) break;
14155: }else P=0;
14156: if(type(D=N)==4) D=N[0];
14157: if(!isint(D)||D<0) return 0;
14158: if(F==0) return seriesHG([-D,D+1],[1],(1-x)/2,D);
14159: 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));
14160: if(F==2) return seriesHG([-D,D],[1/2],(1-x)/2,D);
14161: if(F==3){
14162: if(D==0) return 0;
14163: return orthpoly([D-1,1]|pol="Ge");
14164: }
14165: if(F==4) return red(seriesHG([-D,D+N[1]],[N[2]],x,D));
14166: if(F==5){
14167: for(S=I=1;I<=D;I+=2) S*=I;
14168: if(iand(D,1)) return seriesHG([-(D-1)/2],[3/2],x^2/2,D-1)*x*S*(-1)^((D-1)/2);
14169: else return seriesHG([-D/2],[1/2],x^2/2,D)*S*(-1)^(D/2);
14170: }
14171: if(F==6){
14172: NN=(type(N)==4)?N[1]:0;
14173: return red(seriesHG([-D],[NN+1],x,D)*binom(D+NN,D));
14174: }
14175: if(F==7){
14176: NN=N[1];
14177: for(S=1,I=1;I<=D;I++) S+=(-1)^I*binom(D,I)*binom(D+I,I)*sftpow(x,I)/sftpow(NN,I);
14178: return S;
14179: }
14180: return 0;
14181: }
14182:
14183: def schurpoly(L)
14184: {
14185: N=length(L);
14186: for(R=[],I=1;L!=[];L=cdr(L),I++) R=cons(car(L)+N-I,R);
14187: L=reverse(R);
14188: if(type(X=getopt(var))!=4){
14189: V=(type(X)>1)?X:"x";
14190: for(X=[],I=0;I<N;I++) X=cons(makev([V,N-I]),X);
14191: }
14192: M=newmat(N,N);
14193: for(I=0;I<N;I++)
14194: for(J=0;J<N;J++) M[I][J]=X[I]^L[J];
14195: P=det(M);
14196: for(I=0;I<N;I++)
14197: for(J=I+1;J<N;J++) P=sdiv(P,X[I]-X[J]);
14198: return P;
14199: }
14200:
1.6 takayama 14201: def fouriers(A,B,X)
14202: {
1.20 takayama 14203: if((Y=getopt(y))==0||type(Y)>0) Y=deval(Y);
14204: else Y=0;
14205: if((V=getopt(const))==0||type(V)>0){
14206: V=myfeval(V,Y);
14207: K=1;
14208: }else K=0;
1.6 takayama 14209: if(A!=[]&&type(car(A))>1){
1.20 takayama 14210: for(C=[],I=A[1];I>=K;I--) C=cons(myf2eval(car(A),I,Y),C);
14211: if(K) C=cons(0,C);
1.6 takayama 14212: A=C;
14213: }
1.20 takayama 14214: if(K){
14215: if(A!=[]) A=cdr(A);
14216: A=cons(V,A);
14217: }
1.6 takayama 14218: if(B!=[]&&type(car(B))>1){
1.20 takayama 14219: for(C=[],I=B[1];I>0;I--) C=cons(myf2eval(car(B),I,Y),C);
1.6 takayama 14220: B=C;
14221: }
1.20 takayama 14222: L=length(B)+1;
14223: if(length(A)>=L) L=length(A)+1;
14224: if(type(Sum=getopt(sum))>0){
14225: if(Sum==1) Sum=1-x;
14226: else if(Sum==2) Sum=[(z__)/(3.1416*x),[z__,os_md.mysin,3.1416*x]];
14227: else Sum=f2df(Sum);
14228: C=[];
14229: if(A!=[]){
14230: C=cons(car(A),C);
14231: A=cdr(A);
14232: }
14233: for(I=1;A!=[];A=cdr(A),I++) C=cons(car(A)*myf2eval(Sum,I/L,L),C);
14234: A=reverse(C);
14235: for(C=[],I=1;B!=[];B=cdr(B),I++) C=cons(car(B)*myf2eval(Sum,I/L,L),C);
14236: B=reverse(C);
14237: }
1.6 takayama 14238: if(getopt(cpx)==1){
1.20 takayama 14239: if(type(X=eval(X))>1) return todf([os_md.fouriers,[["cpx",1]]],[[A],[B],[X]]);
1.6 takayama 14240: V=dexp(@i*X);
14241: for(C=A,P=1,I=0;C!=[];C=cdr(C),I++){
1.20 takayama 14242: R+=S*car(C)*P;
1.6 takayama 14243: P*=V;
14244: }
14245: V=dexp(-@i*X);
14246: for(C=B,P=1,I=0;C!=[];C=cdr(C),I++){
14247: P*=V;
14248: R+=car(C)*P;
14249: }
14250: return R;
14251: }
14252: if(type(X=eval(X))>1) return todf(os_md.fouriers,[[A],[B],[X]]);
14253: for(C=A,I=0;C!=[];C=cdr(C),I++)
14254: R+=car(C)*mycos(I*X);
14255: for(C=B,I=1;C!=[];C=cdr(C),I++)
14256: R+=car(C)*mysin(I*X);
14257: return R;
14258: }
14259:
14260:
14261: def myexp(Z)
14262: {
14263: if(type(Z=eval(Z))>1) return todf(os_md.myexp,[Z]);
14264: if((Im=imag(Z))==0) return dexp(Z);
14265: return dexp(real(Z))*(dcos(Im)+@i*dsin(Im));
14266: }
14267:
14268: def mycos(Z)
14269: {
14270: if(type(Z=eval(Z))>1) return todf(os_md.mycos,[Z]);
14271: if((Im=imag(Z))==0) return dcos(Z);
14272: V=myexp(Z*@i);
14273: return (V+1/V)/2;
14274: }
14275:
14276: def mysin(Z)
14277: {
14278: if(type(Z=eval(Z))>1) return todf(os_md.mysin,[Z]);
14279: if((Im=imag(Z))==0) return dsin(Z);
14280: V=myexp(Z*@i);
14281: return (1/V-V)*@i/2;
14282: }
14283:
14284: def mytan(Z)
14285: {
14286: if(type(Z=eval(Z))>1) return todf(os_md.mytan,[Z]);
1.17 takayama 14287: if((Im=imag(Z))==0) return dtan(Z);
1.6 takayama 14288: V=myexp(2*Z*@i);
14289: return @i*(1-V)/(1+V);
14290: }
14291:
14292: def mylog(Z)
14293: {
14294: if(type(Z=eval(Z))>1) return todf(os_md.mylog,[Z]);
1.58 takayama 14295: if(imag(Z)==0&&Z>=0) return dlog(Z);
1.6 takayama 14296: return dlog(dabs(Z))+@i*myarg(Z);
14297: }
14298:
1.57 takayama 14299: def nlog(X)
14300: {
14301: return mylog(X)/dlog(10);
14302: }
14303:
1.6 takayama 14304: def mypow(Z,R)
14305: {
14306: if(type(Z=eval(Z))>1||type(R=eval(R))>1) return todf(os_md.mypow,[Z,R]);
14307: if(Z==0) return 0;
14308: if(isint(2*R)){
14309: if(R==0) return 1;
14310: if(isint(R)) return Z^R;
14311: V=dsqrt(Z);
14312: if(R==1/2) return V;
14313: return Z^(R-1/2)*V;
14314: }
14315: return myexp(R*mylog(Z));
14316: }
14317:
14318: def myarg(Z)
14319: {
14320: if(type(Z=map(eval,Z))==4){
14321: if(length(Z)!=2) return todf(os_md.myarg,[Z]);
14322: Re=Z[0];Im=Z[1];
14323: }else if(type(Z)>1){
14324: return todf(os_md.myarg,[Z]);
14325: }else {
14326: Im=imag(Z);Re=real(Z);
14327: }
14328: if(Re==0) return (Im<0)?-deval(@pi)/2:deval(@pi)/2;
14329: V=datan(Im/Re);
14330: if(Re>0) return V;
14331: return (V>0)?(V-deval(@pi)):(V+deval(@pi));
14332: }
14333:
14334: def myatan(Z)
14335: {
14336: if(type(Z=eval(Z))>1) return todf(os_md.myatan,[Z]);
14337: if((Im=imag(Z))==0) return datan(Z);
14338: mylog((1-Z*@i)/(1+Z*@i))*@i/2;
14339: }
14340:
14341: def myasin(Z)
14342: {
14343: if(type(Z=eval(Z))>1) return todf(os_md.myasin,[Z]);
14344: return deval(@pi/2)-myacos(Z);
14345: }
14346:
14347: def frac(X)
14348: {
14349: if(type(X=eval(X))>1) return todf(os_md.frac,[X]);
14350: return (ntype(X)==3)? pari(frac,X):(X-floor(X));
14351: }
14352:
14353: def myacos(Z)
14354: {
14355: if(type(Z=eval(Z))>1) return todf(os_md.myacos,[Z]);
14356: if(imag(Z)==0 && Z<=1 && Z>=-1) return dacos(Z);
14357: return mylog(Z-dsqrt(Z^2-1))*@i;
14358: }
14359:
14360: def arg(Z)
14361: {
14362: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.arg,[Z]);
14363: return (type(Z)==4)?pari(arg,Z[0],Z[1]):arg(sqrt,Z);
14364: }
14365:
14366: def sqrt(Z){
14367: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.sqrt,[Z]);
14368: R=(type(Z)==4)?Z[1]:Z;
14369: if(ntype(R)==0){
14370: if(R==0) return 0;
14371: if(R>0){
14372: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R));
14373: }else{
14374: R=-R;
14375: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R))*@i;
14376: }
14377: }
14378: return (type(Z)==4)?pari(sqrt,Z[0],Z[1]):pari(sqrt,Z);
14379: }
14380:
14381: def gamma(Z)
14382: {
14383: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.gamma,[Z]);
14384: return (type(Z)==4)?pari(gamma,Z[0],Z[1]):pari(gamma,Z);
14385: }
14386:
14387: def lngamma(Z)
14388: {
14389: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.lngamma,[Z]);
14390: return (type(Z)==4)?pari(lngamma,Z[0],Z[1]):pari(lngamma,Z);
14391: }
14392:
14393: def digamma(Z)
14394: {
14395: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.digamma,[Z]);
14396: return (type(Z)==4)?pari(digamma,Z[0],Z[1]):pari(digamma,Z);
14397: }
14398:
14399: def dilog(Z)
14400: {
14401: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.dilog,[Z]);
14402: return (type(Z)==4)?pari(dilog,Z[0],Z[1]):pari(dilog,Z);
14403: }
14404:
14405: def erfc(Z)
14406: {
14407: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.erfc,[Z]);
14408: return (type(Z)==4)?pari(erfc,Z[0],Z[1]):pari(erfc,Z);
14409: }
14410:
14411: def zeta(Z)
14412: {
14413: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.zeta,[Z]);
14414: return (type(Z)==4)?pari(zeta,Z[0],Z[1]):pari(zeta,Z);
14415: }
14416:
14417: def eta(Z)
14418: {
14419: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.eta,[Z]);
14420: return (type(Z)==4)?pari(eta,Z[0],Z[1]):pari(eta,Z);
14421: }
14422:
14423: def jell(Z)
14424: {
14425: if(vars(Z=map(eval,V))>1) return todf(os_md.jell,[Z]);
14426: return (type(Z)==4)?pari(jell,Z[0],Z[1]):jell(jell,Z);
14427: }
14428:
14429: def evals(F)
14430: {
14431: if(type(F)==7){
14432: if(type(Del=getopt(del))!= 7) return eval_str(F);
14433: S=strtoascii(Del);K=length(S);
14434: if(K==0) return [eval_str(F)];
14435: Raw=getopt(raw);
14436: F=strtoascii(F);L=[];T1=0;
14437: do{
14438: T2=str_str(F,S|top=T1);
14439: if(T2<0) T2=10000;
14440: FT=str_cut(F,T1,T2-1);
14441: L=cons((Raw==1)?FT:evals(FT),L);
14442: T1=T2+K;
14443: }while(T2!=10000);
14444: return reverse(L);
14445: }
14446: if(type(F)==4){
14447: if(type(S=car(F))==7){
14448: S+="(";
14449: for(I=0,FT=cdr(F); FT!=[]; I++,FT=cdr(FT)){
14450: if(type(ST=car(FT))!=7) ST=rtostr(ST);
14451: if(I>0) S=S+","+ST;
14452: else S=S+ST;
14453: }
14454: S=S+")";
14455: return eval_str(S);
14456: }else return call(S,cdr(F));
14457: }
14458: return F;
14459: }
14460:
14461: def myval(F)
14462: {
14463: if(type(F)!=4){
14464: F=f2df(sqrt2rat(F));
14465: if(type(F)!=4) return F;
14466: };
14467: if(length(F)==1) V=car(F);
14468: else for(V=car(F),F=cdr(F); F!=[];){
14469: FT=car(F);
14470: if(type(G=FT[1])==2){
14471: if(length(FT)>2){
14472: FT2=myval(FT[2]);
14473: if(length(FT)>3) FT3=myval(FT[3]);
14474: };
14475: X=red(FT2/@pi);Vi=-red(FT2*@i/@pi);W=red(FT2/@e);
14476: if(G==os_md.mypow && FT3==1/2){
14477: G=os_md.sqrt;
14478: FT=[FT[0],G,FT[2]];
14479: }
14480: if((T=findin(G,
14481: [sin,os_md.mysin,cos,os_md.mycos,tan,os_md.mytan]))>=0
14482: &&(isint(6*X)||isint(4*X))){
14483: if(T==2||T==3){
14484: T=0;X=1/2-X;
14485: }
14486: X=X-floor(X/2)*2;
14487: if(T==0||T==1){
14488: if(X>1){
14489: S=-1;X-=1;
14490: }else S=1;
14491: if(X>1/2) X=1-X;
14492: if(X==0) R=0;
14493: else if(X==1/6) R=1/2;
14494: else if(X==1/4) R=2^(1/2)/2;
14495: else if(X==1/3) R=3^(1/2)/2;
14496: else R=1;
14497: R*=S;
14498: }else{
14499: if(X>1) X-=1;
14500: if(X>1/2){
14501: S=-1;V=1-X;
14502: }else S=1;
14503: if(X==0) R=0;
14504: else if(X==1/6) R=3^(1/2)/3;
14505: else if(X==1/4) R=1;
14506: else if(X==1/3) R=3^(1/2);
14507: else R=2^512;
14508: R*=S;
14509: }
14510: }else if((G==exp||G==os_md.myexp)&&(isint(FT2)||isint(6*Vi)||isint(4*Vi))){
14511: if(isint(FT2)) R=@e^FT2;
14512: else R=myval([z+w*@i,[z,cos,Vi*@pi],[w,sin,Vi*@pi]]);
14513: }else if((G==pow||G==os_md.mypow) && (isint(FT3)||FT2==1||FT2==0)){
14514: if(FT2==0) R=0;
14515: else if(FT2==1) R=1;
14516: else R=FT2^FT3;
14517: }else if(G==os_md.abs&&ntype(P=eval(FT2))<4){
14518: R=FT2;
14519: if(P<0) R=-R;
14520: }else if((G==os_md.sqrt||G==dsqrt)&&type(FT2)<2&&ntype(FT2)==0)
14521: R=sqrtrat(FT2);
14522: else if((G==os_md.mylog||G==dlog)&&(FT2==@e||FT2==1))
14523: R=(FT2==1)?0:1;
14524: else if(length(FT)==3) R=eval((*G)(myeval(FT2)));
14525: #ifdef USEMODULE
14526: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
14527: #else
14528: else R=call(G,map(myeval,cdr(cdr(FT))));
14529: #endif
14530: }
14531: else if(G==0) R=FT[2];
14532: #ifdef USEMODULE
14533: else R=eval(call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]));
14534: #else
14535: else R=eval(call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]));
14536: #endif
14537: V=mysubst(V,[FT[0],R]);
14538: F=mysubst(cdr(F),[FT[0],R]);
14539: }
14540: if(type(V)<4 && !iscoef(V,os_md.iscrat)) V=eval(V);
14541: #if 0
14542: return (type(V)<4)?myeval(V):mtransbys(os_md.myeval,V,[]);
14543: #else
14544: return V;
14545: #endif
14546: }
14547:
14548: /* -1:空 0:整数 1:有理数 2:Gauss整数 3:Gauss有理数 4:それ以外の複素数 */
14549: /* def vntype(F)
14550: {
14551: if((T=type(F))<2){
14552: if(T<0) return -1;
14553: if((Tn=ntype(F))==0){
14554: return (isint(F))?0:1;
14555: }
14556: if(Tn==4){
14557: if(ntype(real(F))==0&&ntype(real(F))==0)
14558: return (isint(F)&&isint(F))?2:3;
14559: return 4;
14560: }
14561: }
14562: if(T==2){
14563: V=vars(F);
14564: if((VV=lsort(V,[@e,@pi],1))==[]){
14565: FT=mycoef(
14566: }else{
14567: if(length(VV)==1){
14568: }else
14569: }
14570: }else if(T==3){
14571:
14572: }
14573: }
14574: */
14575:
14576:
14577: def myeval(F)
14578: {
14579: if(type(F)!=4) V=F;
14580: else if(length(F)==1) V=car(F);
14581: else for(V=car(F),F=cdr(F); F!=[];){
14582: FT=car(F);
14583: if(type(G=FT[1])==2){
14584: if(length(FT)==3) R=(*G)(myeval(FT[2]));
14585: #ifdef USEMODULE
14586: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
14587: #else
14588: else R=call(G,map(myeval,cdr(cdr(FT))));
14589: #endif
14590: }
14591: else if(G==0) R=myeval(FT[2]);
14592: #ifdef USEMODULE
14593: else R=call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]);
14594: #else
14595: else R=call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]);
14596: #endif
14597: V=mysubst(V,[FT[0],R]);
14598: F=mysubst(cdr(F),[FT[0],R]);
14599: }
14600: return (type(V)<4)?eval(V):mtransbys(eval,V,[]);
14601: }
14602:
14603: def mydeval(F)
14604: {
14605: if(type(F)!=4) V=F;
14606: else if(length(F)==1) V=car(F);
14607: else for(V=car(F),F=cdr(F); F!=[]; ){
14608: FT=car(F);
14609: if(type(G=FT[1])==2){
14610: if(length(FT)==3) R=(*G)(myeval(FT[2]));
14611: #ifdef USEMODULE
14612: else R=call(G,map(os_md.mydeval,cdr(cdr(FT))));
14613: #else
14614: else R=call(G,map(mydeval,cdr(cdr(FT))));
14615: #endif
14616: }
14617: else if(G==0) R=mydeval(FT[2]);
14618: #ifdef USEMODULE
14619: else R=call(G[0],map(os_md.mydeval,cdr(cdr(FT)))|option_list=G[1]);
14620: #else
14621: else R=call(G[0],map(mydeval,cdr(cdr(FT)))|option_list=G[1]);
14622: #endif
14623: V=mysubst(V,[FT[0],R]);
14624: F=mysubst(cdr(F),[FT[0],R]);
14625: }
14626: return (type(V)<4)?deval(V):mtransbys(deval,V,[]);
14627: }
14628:
14629: def myfeval(F,X)
14630: {
14631: if(type(X)==4){
14632: if(isvar(X[0])&&length(X)==2)
14633: return mydeval(mysubst(F,[X[0],X[1]]));
14634: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
14635: for(Y=X;Y!=[];Y=cdr(Y))
14636: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
14637: return myeval(F);
14638: }
14639: }
14640: return myeval(mysubst(F,[x,X]));
14641: }
14642:
14643: def myf2eval(F,X,Y)
14644: {
14645: return myeval(mysubst(F,[[x,X],[y,Y]]));
14646: }
14647:
14648: def myf3eval(F,X,Y,Z)
14649: {
14650: return myeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
14651: }
14652:
14653: def myfdeval(F,X)
14654: {
14655: if(type(X)==4){
14656: if(isvar(X[0])&&length(X)==2)
14657: return mydeval(mysubst(F,[X[0],X[1]]));
14658: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
14659: for(Y=X;Y!=[];Y=cdr(Y))
14660: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
14661: return mydeval(F);
14662: }
14663: }
14664: return mydeval(mysubst(F,[x,X]));
14665: }
14666:
14667: def myf2deval(F,X,Y)
14668: {
14669: return mydeval(mysubst(F,[[x,X],[y,Y]]));
14670: }
14671:
14672: def myf3deval(F,X,Y,Z)
14673: {
14674: return mydeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
14675: }
14676:
14677: def df2big(F)
14678: {
14679: AG=[[os_md.mysin,sin],[os_md.mycos,cos],[os_md.mytan,tan],[os_md.myasin,asin],
14680: [os_md.acos,acos],[os_md,atan,atan],[os_md.myexp,exp],[os_md.mylog,log],[os_md.mypow,pow]];
14681: if(getopt(inv)!=1) return mysubst(F,AG);
14682: else return mysubst(F,AG|inv=1);
14683:
14684: }
14685:
14686: def f2df(F)
14687: {
14688: if(type(Opt=getopt(opt))!=1) Opt=0;
14689: if(iand(Opt,1)){
14690: if(Opt>0) F=map(eval,F);
14691: else F=map(deval,F);
14692: }
14693: Cpx=getopt(cpx);
14694: if(type(F)==4 && iand(Opt,2)==0) return F;
14695: K=getopt(level);
14696: if(type(K)!=1) K=0;
14697: AG=[sin,cos,tan,asin,acos,atan,exp,sinh,cosh,tanh,log,pow];
14698: AGd=[os_md.mysin,os_md.mycos,os_md.mytan,os_md.myasin,os_md.myacos,
14699: os_md.myatan,os_md.myexp,os_md.myexp,os_md.myexp,os_md.myexp,
14700: os_md.mylog,os_md.sqrt,os_md.myexp];
14701: for(R=[],I=0,Arg=vars(F);Arg!=[];Arg=cdr(Arg)){
14702: Fn=functor(car(Arg));
14703: if(vtype(Fn)!=3) continue;
14704: V=args(car(Arg));
14705: for(PAG=AG,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)){
14706: if(Fn==car(PAG)){
14707: if(K==0) L="z__";
14708: else L="z"+rtostr(K)+"__";
14709: if(I==0) VC=makev([L]);
14710: else VC=makev([L,I]);
14711: I++;
14712: VC0=VC;
14713: if(Fn==sinh || Fn==cosh || Fn==tanh){
14714: VC=makev([L,I++]);
14715: if(Fn==sinh)
14716: R=cons([VC0,0,(VC^2-1)/(2*VC)],R);
14717: else if(Fn==cosh)
14718: R=cons([VC0,0,(VC^2+1)/(2*VC)],R);
14719: else
14720: R=cons([VC0,0,(VC^2-1)/(VC^2+1)],R);
14721: }
14722: if(Fn==pow && (V[1]!=1/2||Cpx==1)){
14723: #if 0
14724: R0=f2df(V[1]*((type(V[0])==1)?dlog(V[0]):log(V[0]))|level=K+1);
14725: PAGd=cdr(PAGd);
14726: #else
14727: R=cons([VC,os_md.mypow,V[0],V[1]],R);
14728: F=mysubst(F,[car(Arg),VC0]);
14729: Arg=cons(0,vars(F));
14730: break;
14731: #endif
14732: }else R0=f2df(V[0]|level=K+1);
14733: R=cons([VC,car(PAGd),R0],R);
14734: F=mysubst(F,[car(Arg),VC0]);
14735: Arg=cons(0,vars(F));
14736: break;
14737: }
14738: }
14739: }
14740: if(R==[]) return F;
14741: if(Cpx==1){
14742: for(PAG=P,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd))
14743: R=mysubst(R,[car(PADd),car(PAG)]);
14744: }
14745: return cons(F,reverse(R));
14746: }
14747:
14748: def todf(F,V)
14749: {
14750: if(type(V)!=4) V=[V];
14751: for(R=[];V!=[];V=cdr(V)){
14752: R=cons(f2df(car(V)),R);
14753: }
14754: V=reverse(R);
14755: Z=makenewv([F,V]);
14756: return [Z,cons(Z,cons(F,V))];
14757: }
14758:
14759: def compdf(F,V,G)
14760: {
14761: FL=["abs","floor","rint","zeta","gamma","arg","real","imag","conj"];
14762: FS=[os_md.abs,floor,rint,os_md.zeta,os_md.gamma,os_md.myarg,real,imag,conj];
14763: if(type(F)==7){
14764: if(str_str(F,"|")==0){
14765: F="abs("+str_cut(F,1,str_len(F)-2)+")";
14766: }else if(str_str(F,"[")==0){
14767: F="floor("+str_cut(F,1,str_len(F)-2)+")";
14768: }
14769: I=str_str(F,"(");
14770: Var=x;
14771: if(I>0){
14772: J=str_pair(F,I+1,"(",")");
14773: if(J<0) return 0;
14774: Var=eval_str(str_cut(F,I+1,J-1));
14775: Var=f2df(Var);
14776: F0=str_cut(F,0,I-1);
14777: }
14778: if((I=findin(F0,FL))<0&&(I=findin(F,FL))<0) F=f2df(eval_str(F));
14779: else F=[z__,[z__,FS[I],Var]];
14780: }
14781: if(type(F)!=4) F=f2df(F);
14782: if(type(G)!=4) G=f2df(G);
1.20 takayama 14783: if(V==G) return F; /* subst(F(V),V,G) */
1.6 takayama 14784: VF=vars(F);VG=vars(G);
1.20 takayama 14785: if(type(V)==4){
14786: for(VT=[],VV=V;VV!=[];VV=cdr(VV)){
14787: if(findin(car(VV),VF)>=0){
14788: X=makenewv(append(VF,VG));
14789: VF=cons(X,VF);
14790: F=mysubst(F,[car(VV),X]);
14791: VT=cons(X,VT);
14792: }else VT=cons(car(VV),VT);
14793: }
14794: for(V=reverse(VT);V!=[];V=cdr(V),G=cdr(G)) F=compdf(F,car(V),car(G));
14795: return F;
14796: }
1.6 takayama 14797: for(E=I=0;I<30;I++){
14798: for(J=0;J<30;J++){
14799: X=makev(["z__",I,J]);
14800: if(findin(X,VF)<0 && findin(X,VG)<0){
14801: E=1;break;
14802: }
14803: }
14804: if(E) break;
14805: }
14806: if(!E) return 0;
14807: if(type(G)<4) return mysubst(F,[V,G]);
14808: if(type(F)<4) F=[F]; /* return compdf([X,[X,0,F]],V,G); */
14809: F=mysubst(F,[V,X]);
14810: if(isvar(G[0])){
14811: G=mysubst(G,[G[0],X]);
14812: if(length(G)==2&&type(G[1])==4&&G[1][0]==X) G=G[1];
14813: G=cons(G,cdr(F));
14814: }
14815: else G=cons([X,0,G],cdr(F));
14816: return cons(car(F),G);
14817: }
14818:
14819: def fzero(F,LX)
14820: {
14821: if(length(LX)==3){
14822: V=LX[0];LX=cdr(LX);
14823: }else V=x;
14824: LX1=eval(LX[0]);LX2=eval(LX[1]);
14825: if(getopt(zero)==1){
14826: if(getopt(cont)==1) CT=1;
14827: else CT=0;
14828: if(getopt(trans)!=1 && type(F)<4) F=f2df(F);
14829: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
14830: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
14831: V1=myeval(mysubst(F,[V,X1=LX1]));
14832: V2=myeval(mysubst(F,[V,X2=LX2]));
14833: if(V1>0){
14834: V0=V1;V1=V2;V2=V0;
14835: X0=X1;X1=X2;X2=X0;
14836: }
14837: if(V1<0 && V2>0){
14838: D=(V2-V1)*1024;
14839: for(I=0; I<Dev; I++){
14840: /* mycat([D,X1,V1,X2,V2]) ; */
14841: if(iand(I,1)) X0=(X1+X2)/2;
14842: else X0=(V2*X1-V1*X2)/(V2-V1);
14843: V0=myeval(mysubst(F,[V,X0]));
14844: if(V0==0||V0==V1||V0==V2) return [X0,V0];
14845: if(V0<0){
14846: if(!CT && V0+D<0) return [];
14847: V1=V0;X1=X0;
14848: }else{
14849: if(!CT && V0>D) return [];
14850: V2=V0;X2=X0;
14851: }
14852: }
14853: X0=(V2*X1-V1*X2)/(V2-V1);
14854: return [X0,myeval(mysubst(F,[V,X0]))];
14855: }
14856: if(V0==0) return [X0,V0];
14857: if(V1==0) return [X1,V1];
14858: return [];
14859: }
14860: if(type(F)<4) F=f2df(F);
14861: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
14862: L=[];
14863: if(type(F)<4){
14864: if(type(F)==3) F=nm(red(F));
14865: if((Deg=deg(F,V))<=2){
14866: if(Deg==2){
14867: D=(C1=coef(F,1,V))^2-4*(C2=coef(F,2,V))*coef(F,0,V);
14868: if(D>=0){
14869: R=dsqrt(D);
14870: if((S=(-C1+R)/(2*C2))>=LX1&&S<=LX2) L=[[S,mysubst(F,[V,S])]];
14871: if(D!=0 && (S=(-C1-R)/(2*C2))>=LX1&&S<=LX2) L=cons([S,mysubst(F,[V,S])],L);
14872: }
14873: L=qsort(L);
14874: }else if(Deg==1&&(S=-coef(F,0,V)/coef(F,1,V))>=LX1&&S<=LX2)
14875: L=[[S,mysubst(F,[V,S])]];
14876: return L;
14877: }
14878: for(L=[];S!=[];S=cdr(S))
14879: if(car(S)>=LX1&&car(S)<=LX2) L=cons([car(S),mysubst(F,[V,car(S)])],L);
14880: return qsort(L);
14881: }
14882: if(type(Div=getopt(mesh))!=1 || Div<=0)
14883: Div = 2^(10);
14884: W=(LX2-LX1)/Div;
14885: for(I=V2=0;I<=Div;I++){
14886: X1=X2;X2=LX1+I*W;V1=V2;
14887: if((V2=myeval(mysubst(F,[V,X2])))==0)
14888: L=cons([X2,V2],L);
14889: if(V1*V2<0){
14890: L0=fzero(F,[V,X1,X2]|zero=1,trans=1);
14891: if(L0!=[]) L=cons(L0,L);
14892: }
14893: }
14894: return reverse(L);
14895: }
14896:
14897: def fmmx(F,LX)
14898: {
14899: if(length(LX)==3){
14900: V=LX[0];LX=cdr(LX);
14901: }else V=x;
14902: LX1=eval(LX[0]);LX2=eval(LX[1]);
14903: FT=F;
14904: if(getopt(trans)!=1 && type(F)<4) FT=f2df(FT);
14905: FT=mysubst(FT,[[@pi,eval(@pi)],[@e,eval(@e)]]);
14906: if(type(G=getopt(dif))>=1){
14907: if(G==1) G=os_md.mydiff(F,V);
14908: L=fzero(G,[V,LX1,LX2]|option_list=getopt());
14909: R=[[LX1,myeval(mysubst(FT,[V,LX1]))]];
14910: for(I=0;L!=[];L=cdr(L),I++){
14911: X=car(L)[0];
14912: if(X==LX1) continue;
14913: R=cons([X,myeval(mysubst(FT,[V,X]))],R);
14914: }
14915: if(X!=LX2) R=cons([LX2,myeval(mysubst(FT,[V,LX2]))],R);
14916: if(getopt(mmx)!=1) return reverse(R);
14917: for(Mi=Ma=car(R);R!=[];R=cdr(R)){
14918: if(car(R)[1]>Ma[1]) Ma=car(R);
14919: else if(car(R)[1]<Mi[1]) Mi=car(R);
14920: }
14921: return [Mi,Ma];
14922: }
14923: if(type(Div=getopt(mesh))!=1 || Div<=0)
14924: Div = 2^(10);
14925: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
14926: W=(LX2-LX1)/Div;
14927: for(I=V2=V3=0;I<=Div;I++){
14928: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
14929: V3=myeval(mysubst(FT,[V,X3]));
14930: if(I==0) L=[[X3,V3]];
14931: if(I<2) continue;
14932: if((V1-V2)*(V2-V3)<0){
14933: X02=X2;V02=V2;X03=X3;V03=V3;
14934: for(J=0; J<Dev && X1!=X3; J++){
14935: X12=(X1+X2)/2;V12=myeval(mysubst(FT,[V,X12]));
14936: if((V1-V12)*(V12-V2)<=0){
14937: X3=X2;V3=V2;X2=X12;V2=V12;continue;
14938: }
14939: X23=(X2+X3)/2;V23=myeval(mysubst(FT,[V,X23]));
14940: if((V12-V2)*(V2-V23)<=0){
14941: X1=X12;V1=V12;X3=X23;V3=V23;continue;
14942: }
14943: if((V2-V23)*(V23-V3)<=0){
14944: X1=X2;V1=V2;X2=X23;V2=V23;continue;
14945: }
14946: }
14947: L=cons([X2,V2],L);
14948: X2=X02;V2=V02;X3=X03;V3=V03;
14949: }
14950: }
14951: L=cons([LX2,myeval(mysubst(FT,[V,LX2]))],L);
14952: if(getopt(mmx)!=1) return L;
14953: for(Mi=Ma=car(L);L!=[];L=cdr(L)){
14954: if(car(L)[1]>Ma[1]) Ma=car(L);
14955: else if(car(L)[1]<Mi[1]) Mi=car(L);
14956: }
14957: return [Mi,Ma];
14958: }
14959:
14960: def flim(F,L)
14961: {
14962: FD=f2df(F);
14963: Lim0=4;Lim=12;FS=1;
14964: if(type(Pc=getopt(prec))==1){
14965: if((Pc>1&&Pc<31)||Pc>-5) Lim+=Pc;
14966: }
14967: if(type(Pc=getopt(init))==1 && Pc>0) FS*=Pc;
14968: if(type(L)==7) L=[L];
14969: else if(type(L)<2){
14970: K=flim(F,["+",L]|option_list=getopt());
14971: if(K=="") return K;
14972: K1=flim(F,["-",L]|option_list=getopt());
14973: if(K1=="") return K1;
14974: if(type(K)==7||type(K1)==7){
14975: if(K!=K1) return "";
14976: return K;
14977: }
14978: if(abs(K)<10^(-5)){
14979: if(abs(K1)<10^(-5)) return (K1+K)/2;
14980: else return "";
14981: }
14982: if(abs((K1-K)/K)<10^(-4)) return (K1+K)/2;
14983: return "";
14984: }
14985: if(type(L)!=4||type(L[0])!=7) return "";
14986: if(L[0]=="-"||L[0]=="-infty"){
14987: FS=-FS;
14988: }else if(L[0]!="+"&&L[0]!="infty") return "";
14989: FI=(length(L)==1)?1:0;
14990: for(Inf=0,I=Lim0;I<Lim;I++){
14991: D1=FS*8^I;D2=8*D1;
14992: if(FI==0){
14993: D1=1/D1;D2=1/D2;
14994: }
14995: if(D1>D2){
14996: D=D1;D1=D2;D1=D;
14997: X1=D1;X2=D2;
14998: }
14999: if(FI==0){
15000: D1+=L[1];D2+=L[1];
15001: }
15002: K=fmmx(FD,[D1,D2]|mmx=1,mesh=16,dev=4);
15003: if(I>Lim0){
15004: if(DF<K[1][1]-K[0][1]&&DF>10^(-8)&&DF<10^7){
15005: if(I>Lim0+1){
15006: if(Inf==0) return "";
15007: }else Inf=1;
15008: }else if(Inf==1) return "";
15009: }
15010: DF=K[1][1]-K[0][1];
15011: }
15012: if(Inf==1){
15013: if(K[0][1]>10^8) return "+";
15014: else if(K[1][1]<-10^8) return "-";
15015: return "";
15016: }
15017: V=(myfeval(FD,D1)+1.0)-1.0;
15018: if(V!=0 && abs(V)<10^(-9)) return 0;
15019: return V;
15020: }
15021:
15022: def fcont(F,LX)
15023: {
15024: if(length(LX)==3){
15025: V=LX[0];LX=cdr(LX);
15026: }else V=x;
15027: LX1=eval(LX[0]);LX2=eval(LX[1]);
15028: if(getopt(trans)!=1 && type(F)<4) FT=f2df(F);
15029: if(type(Div=getopt(mesh))!=1 || Div<=0)
15030: Div = 2^(10);
15031: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
15032: W=(LX2-LX1)/Div;
15033: if((Df=getopt(dif))!=1){
15034: Df=0;
15035: }else{
15036: if(Dev==16) Dev=6;
15037: WD=W/2^(Dev+1);
15038: }
15039: F=FT;
15040: C=2;
15041: for(I=V2=V3=0;I<=Div;I++){
15042: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
15043: V3=myeval(mysubst(F,[V,X3]));
15044: if(Df){
15045: if(I==Div) break;
15046: V3=(myeval(mysubst(F,[V,X3+WD]))-V3)/WD;
15047: }
15048: if(I==0) L=[[X3,V3]];
15049: if(I<2) continue;
15050: if(C*dabs(2*V2-V1-V3) > dabs(V1-V3)){
15051: X01=X1;V01=V1;X02=X2;V02=V2;X03=X3;V03=V3;
15052: for(J=0; X01!=X03; J++){
15053: if(dabs(V01-V02)>dabs(V02-V03)){
15054: X03=X02;V03=V02;
15055: }else{
15056: X01=X02;V01=V02;
15057: }
15058: if(J==Dev) break;
15059: X02=(X01+X02)/2;
15060: V02=myeval(mysubst(F,[V,X02]));
15061: if(Df) V02=(myeval(mysubst(F,[V,WD]))-V02)/WD;
15062: if(C*dabs(2*V02-V01-V03) < dabs(V01-V03)) break;
15063: }
15064: if(J==Dev||X01==X03) L=cons([X01,X03,V03-V01],L);
15065: }
15066: }
15067: return reverse(L);
15068: }
15069:
1.57 takayama 15070: def xyplot(L,LX,LY)
15071: {
1.63 takayama 15072: Vw=getopt(view);
15073: if(type(Vw)!=1 && type(Vw)!=7 && Vw!=0) Vw=-1;
15074: if(!LX){
15075: L0=llget(L,1,[0]|flat=1);
1.71 takayama 15076: LX=[lmin(L0),LXm=lmax(L0)];
15077: S=SX=LX[1]-LX[0];
1.63 takayama 15078: if(S>0){
15079: if(Vw) LX=[LX[0]-S/32,LX[1]+S/32];
15080: }else LX=[LX[0]-1,LX[0]+1];
1.64 takayama 15081: }
15082: LX=map(deval,LX);
1.63 takayama 15083: if(!LY){
15084: L0=llget(L,1,[1]|flat=1);
1.71 takayama 15085: LY=[lmin(L0),LYm=lmax(L0)];
15086: S=SY=LY[1]-LY[0];
1.63 takayama 15087: if(S>0){
15088: if(Vw) LY=[LY[0]-S/32,LY[1]+S/32];
15089: }else LY=[LY[0]-1,LY[0]+1];
1.64 takayama 15090: }
15091: LY=map(deval,LY);
1.63 takayama 15092: if(getopt(raw)==1) mycat([LX,LY]);
15093: if(Vw!=-1){
15094: if(Vw!=1){
15095: if(type(Vw)==7) Vw=trcolor(Vw);
15096: Opt=[["color",Vw]];
15097: }else Opt=[];
15098: Glib_math_coordinate=1;
15099: glib_window(LX[0],LY[0],LX[1],LY[1]);
15100: for(; L!=[];L=cdr(L))
15101: glib_putpixel(car(L)[0],car(L)[1]|option_list=Opt);
1.71 takayama 15102: if((AX=getopt(ax))==1||AX==2){
15103: if(LY[0]<0&&LY[1]>0){
15104: glib_line(LX[0],0,LX[1],0);
15105: if(AX==2&&LXm>0){
15106: E=floor(dlog(LXm)/dlog(10));
15107: V=floor(LXm*10^(-E)+1/128)*10^E;
15108: glib_line(V,0,V,SY/64);
15109: glib_print(V,-SY/128,rtostr(V));
15110: }
15111: }
15112: if(LX[0]<0&&LX[1]>0){
15113: glib_line(0,LY[0],0,LY[1]);
15114: if(AX==2&&LYm>0){
15115: E=floor(dlog(LYm)/dlog(10)+1/64);
15116: V=floor(LYm*10^(-E)+1/128)*10^E;
15117: glib_line(0,V,SX/64,V);
15118: glib_print(SX/96,V,rtostr(V));
15119: }
15120:
15121: }
15122: }
1.63 takayama 15123: return [LX,LY];
15124: }
1.57 takayama 15125: Opt=getopt();Opt0=delopt(Opt,["dviout","proc"]);
1.64 takayama 15126: if(type(R=getopt(to))!=4) To=[12,8];
15127: R=[To[0]/(LX[1]-LX[0]),RY=To[1]/(LY[1]-LY[0])];
15128: R=[sint(R[0],4|str=0),sint(R[1],4|str=0)];
15129: S="% ";
15130: if(type(C=getopt(scale))!=1&&type(C)!=4){
15131: Opt0=cons(["scale",R],Opt0);
15132: S+="scale="+rtostr(R)+", ";
15133: }
1.65 takayama 15134: S+=rtostr(LX)+", "+rtostr(LY)+"\n";
1.64 takayama 15135: for(L0=[],TL=L;TL!=[];TL=cdr(TL)){
1.57 takayama 15136: TTL=map(deval,car(TL));
15137: if(TTL[0]<LX[0]||TTL[0]>LX[1]||TTL[1]<LY[0]||TTL[1]>LY[1]){
15138: S+=xylines(reverse(L0)|option_list=Opt0);
15139: L0=[];
15140: }else{
15141: L0=cons(TTL,L0);
15142: }
15143: }
15144: if(length(L0)>1) S+=xylines(reverse(L0)|option_list=Opt0);
1.64 takayama 15145: AX=getopt(ax);Opt=delopt(Opt0,"opt");
1.65 takayama 15146: if(type(AX)==4) S+="% axis\n"+xygraph([0,0],0,LX,LX,LY|option_list=Opt);
1.64 takayama 15147: else if((LX[0]<=0&&LX[1]>=0)||(LY[0]<=0&&LY[1]>=0))
1.65 takayama 15148: S+="% axis\n"+xygraph([0,0],0,LX,LX,LY|option_list=cons(["ax",[0,0]],Opt));
1.57 takayama 15149: if(getopt(dviout)!=1) return S;
15150: xyproc(S|dviout=1);
1.64 takayama 15151: return [LX,LY];
1.57 takayama 15152: }
15153:
1.63 takayama 15154: def xyaxis(A,X,Y)
15155: {
15156: if(isint(Vw=getopt(view))&&Vw!=0){
15157: CL=getopt(opt);
15158: if(type(CL)==7) CL=trcolor(CL);
15159: if(type(CL)!=0) CL=0;
15160: if(CL) Opt=[[color,CL]];
15161: else Opt=[];
15162: Glib_math_coordinate=1;
15163: UX=(X[1]-X[0])/50;UY=(Y[1]-Y[0])/50;
15164: glib_window(X[0],Y[0],X[1],Y[1]);
15165: glib_line(A[0],Y[0],A[0],Y[1]|option_list=Opt);
15166: glib_line(X[0],A[1],X[1],A[1]|otpion_list=Opt);
15167: if(length(A)>2&&A[2]){
15168: I0=-floor((A[0]-X[0])/A[2]);I1=floor((X[1]-A[0])/A[2]);
15169: for(I=I0;I<=I1;I++){
15170: IX=A[0]+A[2]*I;
15171: if(iand(Vw,2)) glib_print(IX-UX,A[1]-UY/2,rtostr(IX));
15172: glib_line(IX,A[1],IX,A[1]+UY);
15173: }
15174: }
15175: if(length(A)>3&&A[3]){
15176: I0=-floor((A[1]-Y[0])/A[3]);I1=floor((Y[1]-A[1])/A[3]);
15177: for(I=I0;I<=I1;I++){
15178: IY=A[1]+A[3]*I;
15179: if(iand(Vw,4)) glib_print(A[0]-UX*2,IY+UY,rtostr(IY));
15180: glib_line(A[0],IY,A[0]+UX,IY);
15181: }
15182: }
15183: return;
15184: }
15185: Opt=getopt();
15186: Opt=cons(["ax",A],Opt);
15187: return xygraph([0,0],0,[0,1],X,Y|option_list=Opt);
15188: }
15189:
1.6 takayama 15190: def xygraph(F,N,LT,LX,LY)
15191: {
15192: if((Proc=getopt(proc))!=1&&Proc!=2&&Proc!=3) Proc=0;
15193: if(type(DV=getopt(dviout))==4){
15194: OL=delopt(getopt(),["dviout","shift","ext","cl"]);
15195: OL=cons(["proc",1],OL);
15196: R=xygraph(F,N,LT,LX,LY|option_list=OL);
15197: OL=delopt(getopt(),["shift","ext","cl"]|inv=1);
15198: return execdraw(R,DV|optilon_list=OL);
15199: }
15200: if(N==0) N=32;
15201: if(N<0){
15202: N=-N;
15203: N1=-1; N2=N+1;
15204: }else{
15205: N1=0; N2=N;
15206: }
15207: if(length(LT)==3 && isvar(LT[0])==1){
15208: TT=LT[0]; LT=cdr(LT);
15209: F=mysubst(F,[TT,x]);
15210: }
15211: if(LX==0) LX=LT;
15212: if((Acc=getopt(Acc))!=1) Acc=0;
15213: if(Acc){
15214: LX=[eval(LX[0]),eval(LX[1])];
15215: LY=[eval(LY[0]),eval(LY[1])];
15216: LT=[eval(LT[0]),eval(LT[1])];
15217: }else{
15218: LX=[deval(LX[0]),deval(LX[1])];
15219: LY=[deval(LY[0]),deval(LY[1])];
15220: LT=[deval(LT[0]),deval(LT[1])];
15221: }
15222: TD=(LT[1]-LT[0])/N;
15223: if(type(Mul=getopt(scale))!=1){
15224: if(type(Mul)==4){
15225: MulX=Mul[0]; MulY=Mul[1];
15226: }else MulX=MulY=1;
15227: }else MulX=MulY=Mul;
15228: if(type(Org=getopt(org))==4){
15229: Orgx=Org[0];Orgy=Org[1];
15230: }else Orgx=Orgy=0;
15231: if(type(F)!=4 || (getopt(para)!=1 && length(F)>1 && type(F[0])<4 && type(F[1])==4)) {
15232: if(getopt(rev)!=1){
15233: F1=x; /* LX[0]+(LX[1]-LX[0])*(x-LT[0])/(TD*N); */
15234: F2=F;
15235: }else{
15236: F1=F;
15237: F2=x; /* LY[0]+(LY[1]-LY[0])*(x-LT[0])/(TD*N); */
15238: }
15239: }else{
15240: F1=F[0]; F2=F[1];
15241: }
15242: if(F1==0 || F2==0) LT=[];
15243: if(length(LT)==2){
15244: if(Acc){
15245: for(LTT=[],I=N2;I>=N1;I--)
15246: LTT=cons(eval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
15247: }else{
15248: for(LTT=[],I=N2;I>=N1;I--)
15249: LTT=cons(deval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
15250: }
15251: LT=LTT;
15252: }
15253: Cpx=getopt(cpx);
15254: if(Cpx!=1 && (str_str(rtostr(F1),"@i")>=0 || str_str(rtostr(F2),"@i")>=0))
15255: Cpx=1;
15256: if(type(Cpx)<0) Cpx=0;
15257: if(!Acc){
15258: if(type(F1)<4) F1=f2df(F1);
15259: if(type(F2)<4) F2=f2df(F2);
15260: }
15261: if(type(Err=getopt(err))==1){
15262: F1=mysubst(F1,[x,x+Err*TD/1001.23]);
15263: F2=mysubst(F2,[x,x+Err*TD/1001.23]);
15264: }
15265: if(type(F1)==4 || type(F2)==4){
15266: Dn=1;
15267: }else Dn=dn(F1)*dn(F2);
15268: for(V=[],PT=LT;PT!=[]; PT=cdr(PT)){
15269: T=car(PT);
15270: if(myfeval(Dn,T)==0){
15271: V=cons(0,V); continue;
15272: }
15273: if(Cpx>0||Acc){
15274: X=myfeval(F1,T);Y=myfeval(F2,T);
15275: }else{
15276: X=myfdeval(F1,T);Y=myfdeval(F2,T);
15277: }
15278: if((N1==0||(PT!=LT&&length(PT)!=1)) && (X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1]))
15279: V=cons(0,V);
15280: else
15281: V=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],V);
15282: }
15283: V=reverse(V);
15284: Gap0=Gap=Arg=0;
15285: if(type(Prec=getopt(prec))<0)
15286: Level=0;
15287: else if(Prec==0) Level=4;
15288: else if(type(Prec)==1){
15289: Level=Prec;
15290: if(Level<0){
15291: Level=-Level;
15292: Gap0=1;
15293: }
15294: }else if(type(Prec)==4){
15295: Level=Prec[0];
15296: if(length(Prec)>1) Arg=Prec[1];
15297: if(length(Prec)>2) Gap0=Prec[2];
15298: }
15299: if(Level>0){
15300: if(Level>16) Level=16;
15301: if(Arg<=0) Arg=30;
15302: else if(Arg>120) Arg=120;
15303: Arg=Acc?eval(@pi*Arg/180):deval(@pi*Arg/180);
15304: SL=dcos(Arg);
15305: }
15306: if(Gap0>0){
15307: if(Gap0<2) Gap0=16;
15308: else if(Gap0>512) Gap0=512;
15309: Gap=((MulX*(LX[1]-LX[0]))^2+(MulY*(LY[1]-LY[0]))^2)/(Gap0^2);
15310: }
15311: for(I=0;I<Level;I++){
15312: for(F=K=G=0,NV=NLT=[],PLT=LT,PV=V;PLT!=[];K++,PLT=cdr(PLT),PV=cdr(PV)){
15313: TG=0;D0=D1;CLT0=CLT;CV0=CV;CV=car(PV);CLT=car(PLT);
15314: if(length(PV)>1){
15315: if((CV1=car(cdr(PV)))!=0 && CV!=0)
15316: D1=[CV[0]-CV1[0],CV[1]-CV1[1]];
15317: else D1=0;
15318: }else K=-1; /* ? */
15319: if(K>0 &&(((D1==0||D0==0)&&(CV0!=0||CV!=0||CV1!=0)) || dvangle(D0,D1)<SL ||
15320: (Gap>0 && type(D0)==4 && (TG=(D0[0]^2+D0[1]^2-Gap)>0)))){
15321: G++;T1=(CLT0+CLT)/2;
15322: if(F==0 && (CV0!=0 || CV!=0)){
15323: if(myfdeval(Dn,T1)==0){
15324: NV=cons(0,NV); NLT=cons(T1,NLT);
15325: }
15326: if(Cpx>0||Acc){
15327: X=myfeval(F1,T1);Y=myfeval(F2,T1);
15328: }else{
15329: X=myfdeval(F1,T1);Y=myfdeval(F2,T1);
15330: }
15331: if(K==1 && N1<0){
15332: NV=[];NLT=[];
15333: }
15334: if((K>1||N1==0)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
15335: NV=cons(0,NV);NLT=cons(T1,NLT);F=0;
15336: }else{
15337: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T1,NLT);
15338: }
15339: }
15340: NV=cons(CV,NV);NLT=cons(CLT,NLT);
15341: if(!TG&&(CV0!=0||CV1!=0)){
15342: T2=(car(cdr(PLT))+CLT)/2;
15343: if(myfdeval(Dn,T2)==0){
15344: NV=cons(0,NV); NLT=cons(CLT,NLT);
15345: }
15346: if(Cpx>0||Acc){
15347: X=myfeval(F1,T2);Y=myfeval(F2,T2);
15348: }else{
15349: X=myfdeval(F1,T2);Y=myfdeval(F2,T2);
15350: }
15351: if((N1==0||length(PV)!=2)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
15352: NV=cons(0,NV);NLT=cons(T1,NLT);
15353: }else{
15354: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T2,NLT);
15355: }
15356: }
15357: if(length(PV)==2 && N1==-1) break;
15358: F=1;
15359: }else{
15360: F=0;NV=cons(CV,NV);NLT=cons(CLT,NLT);
15361: }
15362: }
15363: V=reverse(NV);LT=reverse(NLT);
15364: if(G==0) break;
15365: }
15366: if(Gap>0){
15367: for(NV=[],PV=V;PV!=[];PV=cdr(PV)){
15368: NV=cons(P0=car(PV),NV);
15369: if(length(PV)>1 && P0!=0 && PV[1]!=0
15370: && (P0[0]-PV[1][0])^2+(P0[1]-PV[1][1])^2>Gap) NV=cons(0,NV);
15371: }
15372: V=reverse(NV);
15373: }
1.18 takayama 15374: if((Raw=getopt(raw))==1) return V;
15375: if(Raw==2) return [V,LT];
1.6 takayama 15376: OL=[["curve",1]];OLP=[];
15377: if(type(C=getopt(ratio))==1){
15378: OL=cons(["ratio",C],OL);OLP=cons(["ratio",C],OLP);
15379: }
15380: if(Acc==1) OL=cons(["Acc",1],OL);
15381: if(N1<0) OL=cons(["close",-1],OL);
15382: if(type(Opt=getopt(opt))!=7 && type(Opt)!=4){
15383: if(Opt==0) return xylines(V|option_list=cons(["opt",0],OL));
15384: }
15385: OL=cons(["opt",(Proc)?0:Opt],OL);
15386: if(type(Opt)>=0) OLP=cons(["opt",Opt],OLP);
15387: if(type(Vb=getopt(verb))==1||type(Vb)==4){
15388: OL=cons(["verb",Vb],OL);OLP=cons(["verb",Vb],OL);
15389: }
15390: if(Proc){
15391: S=(Proc==1)?
15392: [[0,[MulX*(LX[0]-Orgx),MulX*(LX[1]-Orgx)],[MulY*(LY[0]-Orgy),MulY*(LY[1]-Orgy)],
15393: (TikZ)?1:1/10]]:[];
15394: S=cons([1,OLP,xylines(V|option_list=OL)],S);
15395: if(Proc==3) return car(S);
15396: }else S=xylines(V|option_list=OL);
15397: if(type(Pt=getopt(pt))==4){
15398: if(type(Pt[0])!=4) Pt=[Pt];
15399: if(length(Pt)>1 && type(Pt[1])!=4) Pt=[Pt];
15400: for(PT=Pt;PT!=[];PT=cdr(PT)){
15401: PP=car(PT);
15402: if(type(PP[0])!=4) PP=[PP];
15403: P=car(PP);PP=cdr(PP);
15404: Qx=MulX*(P[0]-Orgx);Qy=MulY*(P[1]-Orgy);
15405: if(length(PP)>0 && type(PP[0])==4){ /* draw line */
15406: P=car(PP);
15407: Q1x=MulX*(P[0]-Orgx);Q1y=MulY*(P[1]-Orgy);
15408: if(length(PP)<1 || car(PP)==0 || iand(car(PP),1))
15409: OL=["opt",(TikZ)?"-":"@{-}"];
15410: else OL=["opt",(TikZ)?".":"@{.}"];
15411: if(Proc) S=cons([1,OL,[[Qx,Qy],[Q1x,Q1y]]],S);
15412: else S=S+xylines([[Qx,Qy],[Q1x,Q1y]]|optilon_list=OL);
15413: continue;
15414: }
15415: if(length(PP)==0 || type(car(PP))!=7) SS="$\\bullet$";
15416: else SS=car(PP);
15417: if(length(PP)<=1){
15418: if(Proc) S=cons([2,[],[Qx,Qy],[SS]],S);
15419: else S=S+xyput([Qx,Qy,SS]);
15420: }else{
15421: if(Proc) S=cons([2,[],[Qx,Qy],[[SS],"",PP[1]]],S);
15422: S=S+xyput([Qx,Qy,SS,"",PP[1]]);
15423: }
15424: }
15425: }
15426: if(type(Ax=getopt(ax))==4){ /* draw axis */
15427: Adx0=Ady0=0; Adx1=Ady1=0.1;
15428: if(!TikZ){
15429: if(!XYcm) Adx1=Ady1=1;
15430: LOp="@{-}"; LxOp="+!U"; LyOp="+!R";
15431: }else{
15432: LOp="-"; LxOp="below"; LyOp="left";
15433: }
15434: LOp0=LOp1=LOp;
15435: LxOO=(Ax[1]==LY[0])?LxOp:(TikZ)?"below left":"+!UR";
15436: if(type(AxOp=getopt(axopt))>0){
15437: if(type(AxOp)==1){
15438: if(AxOp>0) Adx1=Ady1=AxOp;
15439: else if(AxOp<0){
15440: Adx1=Ady1=0; Adx0=Ady0=AxOp;
15441: }
15442: }else if(type(AxOp)==4){
15443: if(type(T=car(AxOp))==4 && length(AxOp)>1){
15444: if(type(T)==7){
15445: LxOp=T; LyOp=AxOp[1];
15446: }else if(type(T)==4){
15447: Ay0=T[0]; Ay1=T[1]; Ax0=AxOp[1][0]; Ax1=AxOp[1][1];
15448: if(length(T)>2) LxOp=T[2];
15449: if(length(AxOp[1])>2) LyOp=AxOp[1][2];
15450: }
15451: }
15452: if(length(AxOp)>2 && type(AxOp[2])==7) LxOO=AxOp[2];
15453: if(length(AxOp)>3 && type(AxOp[3])==7) LOp0=AxOp[3];
15454: if(length(AxOp)>4 && type(AxOp[4])==7) LOp1=AxOp[4];
15455: }
15456: if(type(AxOp)==7) LOp0=AxOp;
15457: }
15458: if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */
15459: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp0]]:[],
15460: [MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],[MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]],S);
15461: else S=S+xyarrow([MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],
15462: [MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]|opt=LOp0);
15463: if(length(Ax)>2){
15464: D=Ax[2];
15465: if(type(D)==1 && D>0){
15466: I0=ceil((LX[0]-Ax[0])/D); I1=floor((LX[1]-Ax[0])/D);
15467: for(DD=[],I=I0; I<=I1; I++){
15468: if(length(Ax)<5) DD=cons(I*D,DD);
15469: else if(Ax[4]==0) DD=cons([I*D,I*D+Ax[0]],DD);
15470: else if(Ax[4]==1) DD=cons([I*D,I*D],DD);
15471: else if(Ax[4]==2) DD=cons([I*D,I],DD);
15472: }
15473: D=DD;
15474: }
15475: if(type(D)==4){
15476: for(;D!=[]; D=cdr(D)){
15477: T=car(D);
15478: if(type(T)==4) T=car(T);
15479: X=MulX*(T+Ax[0]-Orgx); Y=MulY*(Ax[1]-Orgy);
15480: if(T!=0){
15481: if(Proc) S=cons([3,(type(LOp1)>=0)?[["opt",LOp1]]:[],[X,Y+Ady0],[X,Y+Ady1]],S);
15482: else S=S+xyarrow([X,Y+Ady0],[X,Y+Ady1]|opt=LOp1);
15483: }
15484: if(type(car(D))==4){
15485: Arg=[(T==0)?LxOO:LxOp,D[0][1]];
15486: if(Proc) S=cons([2,[],[X,Y+Ady0],[Arg]],S);
15487: else S=S+xyput([X,Y+Ady0,Arg]);
15488: }
15489: }
15490: }
15491: }
15492: }
15493: if(Ax[1]>=LY[0] && Ax[1]<=LY[1]){ /* draw marks on y-axis */
15494: if(Proc) S=cons([3,[["opt",LOp0]],
15495: [MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
15496: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]],S);
15497: else S=S+xyarrow([MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
15498: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]|opt=LOp0);
15499: if(length(Ax)>3){
15500: D=Ax[3];
15501: if(type(D)==1 && D>0){
1.57 takayama 15502: I0=ceil((LY[0]-Ax[1])/D); I1=floor((LY[1]-Ax[1])/D);
1.6 takayama 15503: for(DD=[],I=I0; I<=I1; I++){
15504: if(length(Ax)<5) DD=cons(I*D,DD);
15505: else if(I!=0){
15506: if(Ax[4]==0) DD=cons([I*D,I*D+Ax[1]],DD);
15507: if(Ax[4]==1) DD=cons([I*D,I*D],DD);
15508: if(Ax[4]==2) DD=cons([I*D,I],DD);
15509: }
15510: }
15511: D=DD;
15512: }
15513: if(type(D)==4){
15514: for(;type(D)==4&&D!=[]; D=cdr(D)){
15515: T=car(D);
15516: if(type(T)==4) T=car(T);
15517: X=MulX*(Ax[0]-Orgx); Y=MulY*(T+Ax[1]-Orgy);
15518: if(T!=0){
15519: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp1]]:[],
15520: [X+Adx0,Y],[X+Adx1,Y]],S);
15521: else S=S+xyarrow([X+Adx0,Y],[X+Adx1,Y]|opt=LOp1);
15522: }
15523: if(type(car(D))==4){
15524: if(Proc) S=cons([2,[],[X,Y+Ady0],[[LyOp,D[0][1]]]],S);
15525: else S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]);
15526: }
15527: }
15528: }
15529: }
15530: }
15531: }
15532: if(Proc) return reverse(S);
15533: if(getopt(dviout)!=1) return S;
15534: xyproc(S|dviout=1);
15535: }
15536:
15537: def xyarrow(P,Q)
15538: {
15539: Cmd = ["fill","filldaw","shade","shadedraw","clip ","pattern","path ","node","coordinate"];
15540: if(type(P)<4) return "%\n";
15541: SS=getopt(opt);
15542: if(!TikZ){
15543: if(type(Q)<4) return "";
15544: S="{"+xypos(P)+" \\ar";
15545: if(type(SS)==7) S=S+SS;
15546: return S+" "+xypos(Q)+"};\n";
15547: }
15548: if(type(SS)==4 && length(SS)>1){
15549: if(length(SS)>2) SU=SS[2];
15550: ST=SS[1];
15551: SS=SS[0];
15552: }
15553: if(type(SS)!=7) SS="->";
15554: if(type(ST)!=7) ST=" -- ";
15555: if(type(SU)!=7) SU="";
15556: if(type(S=getopt(cmd))==7) S="\\"+S;
15557: else S="\\draw";
15558: if(type(Q)!=4){
15559: if(Q>0 && Q<=length(Cmd)) S="\\"+Cmd[Q-1]+"";
15560: if(SS!="-") S=S+"["+SS+"]";
15561: if(SU!="") SU="["+SU+"]";
15562: return S+xypos(P)+ST+SU+";\n";
15563: }
1.8 takayama 15564: if(SS!="-"&&SS!="") S=S+"["+SS+"]";
1.6 takayama 15565: if(length(P)<3 && length(Q)<3)
15566: return S+xypos(P)+ST+xypos(Q)+SU+";\n";
15567: if(length(P)==2) P=[P[0],P[1],"","_0"];
15568: else if(length(P)==3 || (length(P)==4 && P[3]==""))
15569: P=[P[0],P[1],P[2],"_0"];
15570: else if(P[3]=="")
15571: P=[P[0],P[1],P[2],"_0",P[4]];
15572: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
15573: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
15574: Q=[Q[0],Q[1],Q[2],"_1"];
15575: else if(Q[3]=="")
15576: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
15577: return S+xypos(P)+" "+xypos(Q)+"("+P[3]+")"+ST+"("+Q[3]+")"+SU+";\n";
15578: }
15579:
15580: def xyarrows(P,Q,R)
15581: {
15582: PQ=newvect(4);
15583: PQ[0]=(type(P[0])!=4)?f2df(P[0]):P[0];
15584: PQ[1]=(type(P[1])!=4)?f2df(P[1]):P[1];
15585: PQ[2]=(type(Q[0])!=4)?f2df(Q[0]):Q[0];
15586: PQ[3]=(type(Q[1])!=4)?f2df(Q[1]):Q[1];
15587: if(type(R[0])!=4) R=[R];
15588: TR=R[0];NX=TR[2];X=X0=TR[0];DX=(TR[1]-TR[0])/NX;
15589: if(length(R)==2){
15590: TR=R[1];NY=TR[2];Y=TR[0];DY=(TR[1]-TR[0])/NY;
15591: }else{
15592: NY=1;Y=DY=0;
15593: }
15594: if(type(L=getopt(abs))!=1) L=0;
15595: if(type(Sc=getopt(scale))!=1) Sc=0;
15596: OL=[];
15597: if(type(Opt=getopt(opt))==7) OL=cons(["opt",Opt],OL);
15598: Tb=str_tb(0,0);
15599: for(J=0;J<NY;Y+=DY,J++){
15600: for(I=0,X=X0;I<NX;I++,X+=DX){
15601: PX=myf2eval(PQ[0],X,Y);PY=myf2eval(PQ[1],X,Y);
15602: VX=myf2eval(PQ[2],X,Y);VY=myf2eval(PQ[3],X,Y);
15603: if(L>0){
15604: C=dnorm([VX,VY]);
15605: if(C!=0){
15606: VX*=L/C;VY*=L/C;
15607: }
15608: }
15609: if(Sc){
15610: VX*=Sc;VY*=Sc;
15611: }
15612: if(VX||VY) str_tb(xyarrow([PX,PY],[PX+VX,PY+VY]|optilon_list=OL),Tb);
15613: }
15614: }
15615: return str_tb(0,Tb);
15616: }
15617:
15618: def polroots(L,V)
15619: {
15620: INIT=1;
15621: if(type(CF=getopt(comp))!=1) CF=0;
15622: OL=getopt();
15623: if(CF>32){
15624: CF-=64;
15625: INIT=0;
15626: }else OL=cons(["comp",CF+64],delopt(OL,"comp"));
15627: if(type(V)==4&&length(V)==1){
15628: L=L[0];V=V[0];
15629: }
15630: Lim=Lim2=[];
15631: if(type(L)<4){
15632: if(type(Lim=getopt(lim))==4){
1.17 takayama 15633: if(type(Lim[0])!=4){
15634: if(!isvar(Lim[0])) Lim=cons(V,[Lim]);
15635: Lim=[Lim];
15636: }
15637: if(!isvar(Lim[0][0])) Lim=[cons(V,Lim)];
1.6 takayama 15638: Lim=delopt(Lim,V|inv=1);
15639: if(Lim!=[]){
15640: Lim=Lim[0];
15641: if(length(Lim)==3) Lim2=Lim[2];
15642: Lim=Lim[1];
15643: }
15644: }else{
15645: Lim=Lim2=[];
15646: }
15647: if((CF==-2||CF==-1||CF==2)&&iscoef(L,os_md.israt)){ /* Rat+Comp, Rat+Real or Rat */
15648: S=(CF==-1)?getroot(L,V|cpx=1):getroot(L,V);
15649: for(RR=[],F=x;S!=[];S=cdr(S)){
15650: if(findin(V,vars(C=car(S)))<0){ /* Rational solution */
15651: if(type(C)<2){
15652: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15653: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15654: }
15655: if(F!=C) RR=cons(F=C,RR);
15656: }else if(CF<0){ /* Irrational solution */
15657: if((R=pari(roots,mysubst(C,[V,x])))!=0){
15658: for(R=vtol(R);R!=[];R=cdr(R))
15659: if((C=car(R))!=F && ntype(C)<CF+6){
15660: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15661: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15662: RR=cons(F=C,RR);
15663: }
15664: }
15665: }
15666: }
15667: return qsort(RR);
15668: }
15669: R=pari(roots,subst(L,V,x));
15670: if(R==0){
15671: R=[0];
15672: if(CF==1){
15673: for(R=[0],I=mydeg(L,V);I>1; I--)
15674: R=cons(0,R);
15675: }
15676: return R;
15677: }
15678: if(CF==1){ /* Complex */
15679: if(Lim==[]&&Lim2==[]) return vtol(R);
15680: for(L=[],I=length(R)-1;I>=0;I--){
15681: C=R[I];
15682: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15683: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15684: L=cons(C,L);
15685: }
15686: return L;
15687: }
15688: for(L=[],F=x,I=length(R)-1;I>=0;I--){ /* Real */
15689: if(ntype(R[I])<4 && F!=R[I]){
15690: if(Lim!=[] && (R[I]<Lim[0]||R[I]>Lim[1])) continue;
15691: L=cons(F=R[I],L);
15692: }
15693: }
15694: return qsort(L);
15695: }
15696: if(SS==0&&INIT==1){
15697: SS=polroots(L,V|option_list=OL);
15698: if(SS!=0) return SS;
1.18 takayama 15699: for(C=0;SS==0&&C<5;C++){
1.6 takayama 15700: I=(C==0)?1:(iand(random(),0xff)-0x80);
15701: for(LL=[],K=length(L)-1;K>=0;K--){
15702: for(Q=0,J=length(L)-1;J>=0;J--)
15703: Q+=L[J]*(I+K)^J;
15704: LL=cons(Q,LL);
15705: }
15706: SS=polroots(LL,V|option_list=OL);
15707: if(SS!=0) return SS;
15708: }
15709: return SS;
15710: }
15711: C=2^(-32);
15712: if(type(getopt(err))==1) C=err;
15713: if((N=length(V))!=length(L)) return [];
15714: if(N==1) return polroots(L[0],V[0]|option_list=OL);
15715: for(L1=[],I=1;I<N;I++){
15716: Res=res(V[0],L[I-1],L[I]);
15717: if(type(Res)<2) return Res;
15718: L1=cons(res(V[0],L[I-1],L[I]),L1);
15719: }
15720: R=polroots(L1,V1=cdr(V)|option_list=OL);
15721: if(type(R)<2) return R;
15722: for(SS=[];R!=[];R=cdr(R)){
15723: RS=(N==2)?[car(R)]:car(R);
15724: for(I=0,L0=L[0];I<N-1;I++) L0=mysubst(L0,[V1[I],RS[I]]);
1.17 takayama 15725: if(L0==0) return 0;
1.6 takayama 15726: S0=polroots(L0,V[0]|option_list=OL);
15727: if(type(S0)<2) return S0;
15728: for(S=S0;S!=[];S=cdr(S)){
15729: S0=cons(car(S),RS);
15730: for(LT=cdr(L);LT!=[];LT=cdr(LT)){
15731: for(I=0,TV=car(LT);I<N;I++) TV=mysubst(TV,[V[I],S0[I]]);
15732: if(abs(TV)>C) break;
15733: }
15734: if(LT==[]) SS=cons(S0,SS);
15735: }
15736: }
15737: return reverse(SS);
15738: }
15739:
1.71 takayama 15740: def lsub(P)
15741: {
15742: if((T=type(P[0]))==4){
15743: Q=reverse(P[1]);P=reverse(P[0]);
15744: for(R=[];P!=[];P=cdr(P),Q=cdr(Q)) R=cons(car(Q)-car(P),R);
15745: return R;
15746: }else if(T==5){
15747: L=length(P[0]);Q=P[1];P=P[0];
15748: R=newvect(L);
15749: for(V=[],L--;L>=0;L--) R[L]=Q[L]-P[L];
15750: return R;
15751: }
15752: return P;
15753: }
15754:
15755: def dext(P,Q)
15756: {
15757: P=lsub(P);Q=lsub(Q);
15758: return P[0]*Q[1]-P[1]*Q[0];
15759: }
15760:
1.6 takayama 15761: def ptcommon(X,Y)
15762: {
15763: if(length(X)!=2 || length(Y)!=2) return 0;
15764: if(type(X[1])==4){ /* X is a line */
15765: if((In=getopt(in))==-1||In==-2||In==-3){
15766: X0=(X[0][0]+X[1][0])/2;X1=(X[0][1]+X[1][1])/2;
15767: X=[[X0,X1],[X0+X[1][1]-X[0][1],X1-X[1][0]+X[0][0]]];
15768: if(In==-1&&type(Y[1])==4) return ptcommon(Y,X|in=-2);
15769: /* for the second line */
15770: if(In==-3) In=1;
15771: else In=0;
15772: }else if(In==2||In==3){
15773: X=(X[1][0]-X[0][0])+(X[1][1]-X[0][1])*@i;
15774: if(X==0) return 0;
15775: Y=(Y[1][0]-Y[0][0])+(Y[1][1]-Y[0][1])*@i;
15776: X=myarg(Y/X);
15777: return (In==2)?X:(X*180/deval(@pi));
15778: }else if(In!=1) In=0;
15779: if(type(Y[0])<=3){
15780: if(In==1){
15781: return [(Y[1]*X[0][0]+Y[0]*X[1][0])/(Y[0]+Y[1]),
15782: (Y[1]*X[0][1]+Y[0]*X[1][1])/(Y[0]+Y[1])];
15783: }
15784: XX=X[1][0]-X[0][0];YY=X[1][1]-X[0][1];
15785: Arg=(length(Y)<2)?0:Y[1];
15786: Arg=deval(Arg);
15787: if(Arg!=0){
15788: S=dcos(Arg)*XX-dsin(Arg)*YY;
15789: YY=dsin(Arg)*XX+dcos(Arg)*YY;
15790: XX=S;
15791: }
15792: S=dnorm([XX,YY]);
15793: if(S!=0){
15794: XX*=Y[0]/S;YY*=Y[0]/S;
15795: }
15796: return [X[1][0]+XX,X[1][1]+YY];
15797: }
15798: S=[X[0][0]+(X[1][0]-X[0][0])*x_,X[0][1]+(X[1][1]-X[0][1])*x_];
15799: if(type(Y[1])==4){ /* Y is a line */
15800: T=[Y[0][0]+(Y[1][0]-Y[0][0])*y_-S[0],
15801: Y[0][1]+(Y[1][1]-Y[0][1])*y_-S[1]];
15802: R=lsol(T,[x_,y_]);
1.71 takayama 15803: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
15804: /* unique sol of parameters */
15805: if(In && (R[0][1]<0||R[0][1]>1||R[1][1]<0||R[1][1]>1) ) return 0;
15806: return subst(S,x_,R[0][1],y_,R[1][1]);
1.6 takayama 15807: }
1.71 takayama 15808: if((type(R[0])>0&&type(R[0])<4)||(type(R[1])>0&&type(R[1])<4)) return 0; /* no solution */
15809: F=0;
15810: if(X[0]==X[1]) F=1;
15811: else if(Y[0]==Y[1]) F=2;
15812: if(!In){
15813: if(!F) return 1;
15814: else if(F==1) return X[0];
15815: else if(F==2) return Y[0];
15816: }
15817: X0=X[0];X1=X[1];
15818: if(X0>X1){R=X0;X0=X1;X1=R;}
15819: Y0=Y[0];Y1=Y[1];
15820: if(Y0>Y1){R=Y0;Y0=Y1;Y1=R;}
15821: if(X0<Y0) X0=Y0;
15822: if(Y0>Y1) X1=Y1;
15823: if(X0>X1) return 0;
15824: if(X0<X1) return [X0,X1];
15825: return X0;
1.6 takayama 15826: }else if(Y[1]==0){ /* orth */
15827: T=[Y[0][0]+(X[1][1]-X[0][1])*y_-S[0],
15828: Y[0][1]-(X[1][0]-X[0][0])*y_-S[1]];
15829: R=lsol(T,[x_,y_]);
15830: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
15831: if(!In||(R[0][1]>=0&&R[0][1]<=1))
15832: return subst(S,x_,R[0][1],y_,R[1][1]);
15833: }
15834: return (X[0]==X[1])?0:1;
15835: }else if(type(Y[1])==1 && Y[1]>0){ /* circle */
15836: T=(S[0]-Y[0][0])^2+(S[1]-Y[0][1])^2-Y[1]^2;
15837: D=mycoef(T,1,x_)^2-4*mycoef(T,0,x_)*mycoef(T,2,x_);
15838: if(D==0){
15839: V=mycoef(T,1,x_)/(2*mycoef(T,2,x_));
15840: if(!in||(V>=0&&V<=1)) return [subst(S,x_,V)];
15841: }
15842: else if((type(D)==1&&D>0)){
15843: D=dsqrt(D);
15844: V=-(mycoef(T,1,x_)+D)/(2*mycoef(T,2,x_));
15845: if(!In||(V>=0&&V<=1)) L=[subst(S,x_,V)];
15846: else L=[];
15847: V=(D-mycoef(T,1,x_))/(2*mycoef(T,2,x_));
15848: if(!In||(V>=0&&V<=1)) L=cons(subst(S,x_,V),L);
15849: if(length(L)>0) return L;
15850: }
15851: }
15852: return 0;
15853: }
15854: if(type(Y[1])==4 || X[1]==0) return ptcommon(Y,X);
15855: /* X is a circle */
15856: if(Y[1]==0){ /* tangent line */
15857: if(Y[0][0]==X[0][0]+X[1] || Y[0][0]==X[0][0]-X[1]) L=[[Y[0][0],X[0][1]]];
15858: else L=[];
15859: P=(Y[0][0]+x_-X[0][0])^2+(Y[0][1]+x_*y_-X[0][1])^2-X[1]^2;
15860: Q=mycoef(P,1,x_)^2-4*mycoef(P,2,x_)*mycoef(P,0,x_);
15861: for(R=polroots(Q,y_);R!=[];R=cdr(R)){
15862: X0=-subst(mycoef(P,1,x_)/(2*mycoef(P,2,x_)),y_,car(R));
15863: L=cons([Y[0][0]+X0,Y[0][1]+car(R)*X0],L);
15864: }
15865: }else{ /* Y is a circle */
15866: P=(x_-X[0][0])^2+(y_-X[0][1])^2-X[1]^2;
15867: Q=(x_-Y[0][0])^2+(y_-Y[0][1])^2-Y[1]^2;
15868: V=(X[0][0]!=Y[0][0])?[x_,y_]:[y_,x_];
15869: R=subst(P,V[0],T=lsol(P-Q,V[0]));
15870: if(type(T[0])<4) return (T[0]==0)?1:0;
15871: S=polroots(R,V[1]);
15872: for(L=[];S!=[];S=cdr(S)){
15873: R=subst(T,V[1],car(S));
15874: if(V[0]==x_) L=cons([R,car(S)],L);
15875: else L=cons([S,R],L);
15876: }
15877: }
15878: if(length(L)!=0) return L;
15879: return 0;
15880: }
15881:
1.71 takayama 15882:
15883: def ptcontain(P,L)
15884: {
15885: if(type(car(P))==4){
15886: if((C=getopt(common))!=1) C=0;
15887: if((F0=ptcontain(P[0])&&!C)) return F0;
15888: if((F1=ptcontain(P[1])&&!C)) return F1;
15889: if(F0&&F1) return P; /* include */
15890: L=cons(L[2],L); /* outside part exists */
15891: for(I=1,R=[];I<4;I++,L=cdr(L)){
15892: if(!(F[I]=ptcotain(P,[L[0],L[1]]))){
15893: if(C) continue;
15894: return -1;
15895: }
15896: if(type(F[I])==4&&length(F[I])==2) /* infinite points */
15897: return F[I];
15898: else R=cons(F[I],R);
15899: }
15900: if(R==[]) return 0; /* no intersection */
15901: if(F1==1) return [P[0],car(R)];
15902: if(F2==1) return [P[1],car(R)];
15903: if(length(R)>1 && R[0]==R[1]) R=cdr(R);
15904: return R;
15905: }
15906: if(dext([L[0],L[1]],[L[0],L[2]])<0) L=[L[0],L[2],L[1]];
15907: L=cons(L[2],L);
15908: for(I=F=1;I<4;I++,L=cdr(L)){
15909: if((V=dext([L[0],L[1]],[L[0],P])) < 0) return 0;
15910: if(!V) F++;
15911: }
15912: return F;
15913: }
15914:
1.6 takayama 15915: def tobezier(L)
15916: {
15917: if((Div=getopt(div))==1||Div==2){
15918: if(length(L)!=4) return [tobezier(L|inv=[0,1/2]),tobezier(L|inv=[1/2,1])];
15919: if(type(L)==4) L=ltov(L);
15920: if(type(L[0])==4)
15921: L=[ltov(L[0]),ltov(L[1]),ltov(L[2]),ltov(L[3])];
15922: S=[(L[0]+3*L[1]+3*L[2]+L[3])/8];
15923: T=[L[3]];
15924: S=cons((L[0]+2*L[1]+L[2])/4,S);
15925: T=cons((L[2]+L[3])/2,T);
15926: S=cons((L[0]+L[1])/2,S);
15927: T=cons((L[1]+2*L[2]+L[3])/4,T);
15928: S=cons(L[0],S);
15929: T=cons((L[0]+3*L[1]+3*L[2]+L[3])/8,T);
15930: return [S,T];
15931: }
15932: if(Div>2&&Div<257){
15933: L=tobezier(L);
15934: for(R=[],I=Div-1;I>=0;I--)
15935: R=cons(tobezier(L|inv=[I/Div,(I+1)/Div]),R);
15936: return R;
15937: }
15938: if((V=getopt(inv))==1 || type(V)>3){
15939: if(type(L[0])>3 && type(V)>3) L=tobezier(L);
15940: if(type(V)>3 && length(V)>2) V2=V[2];
15941: if(type(V2)!=2) V2=t;
15942: if(type(V)>3) L=subst(L,V2,(V[1]-V[0])*V2+V[0]);
15943: N=mydeg(L,V2);
15944: for(R=[],I=0;I<=N;I++){
15945: RT=mycoef(L,I,V2);
15946: R=cons(RT/binom(N,I),R);
15947: L-=RT*V2^I*(1-V2)^(N-I);
15948: }
15949: return reverse(R);
15950: };
15951: N=length(L)-1;
15952: V=newvect(2);
15953: for(I=0;I<=N;I++,L=cdr(L)){
15954: if(type(X=car(L))==4) X=ltov(X);
15955: V+=X*binom(N,I)*t^I*(1-t)^(N-I);
15956: }
15957: return V;
15958: }
15959:
15960: def cutf(F,X,VV)
15961: {
15962: if(type(car(V=VV))==2){
15963: Y=[car(V),X];
15964: V=cdr(V);
15965: }else Y=X;
15966: if(type(X)>1){
15967: Y=(type(Y)==4)?Y[0]:x;
15968: V1=makenewv(F);
15969: if(X==Y||Y==x){
15970: V2=makenewv([F,V1]);
15971: F=mysubst(F,[Y,V2]);
15972: V=cons(V2,V);
15973: }
15974: return [V1,[V1,os_md.cutf,[F],X,[V]]];
15975: }
15976: if(car(V)!=[] && X<car(V)[0]) return myfeval(car(V)[1],Y);
15977: for(V=cdr(V); ;V=R){
15978: if((R=cdr(V))==[]){
15979: if(car(V)!=[] && car(V)[0]<X) return myfeval(car(V)[1],Y);
15980: return myfeval(F,Y);
15981: }
1.20 takayama 15982: if(car(V)==[]||X>car(V)[0]) continue;
1.6 takayama 15983: if(X==car(V)[0]) return car(V)[1];
15984: return myfeval(F,Y);
15985: }
15986: }
15987:
1.12 takayama 15988: def fsum(F,L)
1.6 takayama 15989: {
1.12 takayama 15990: if(getopt(df)==1){
15991: F=f2df(F);
15992: }else Sub=getopt(subst);
1.6 takayama 15993: if(type(L[0])==2){
15994: X=L[0];
15995: L=cdr(L);
15996: }else X=0;
15997: V=(length(L)>2)?L[2]:1;
15998: for(R=0,I=L[0];;I+=V){
15999: if(V==0||(I-L[1])*V>0) return R;
1.12 takayama 16000: R+=(Sub==1)?subst(F,X?X:x,I):os_md.myfeval(F,X?[X,I]:I);
1.6 takayama 16001: }
16002: }
16003:
16004: def periodicf(F,L,X)
16005: {
16006: if(type(L)==4) L=[eval(L[0]),eval(L[1])];
16007: else L=eval(L);
16008: if(isvar(X)){
1.20 takayama 16009: Y=makenewv([X,F]);
16010: Z=makenewv([X,Y,F]);
1.16 takayama 16011: return [Z,[Z,os_md.periodicf,[mysubst(F,[x,Y])],(type(L)==4)?[L]:L,[[Y,X]]]];
16012: }
16013: if(type(X)==4){
16014: V=X[0];
16015: X=X[1];
16016: }else V=x;
16017: if(type(F)==5){
16018: X=eval(X);
16019: return myfeval(F[floor(X/L)%length(F)],[V,X-floor(X/L)*L]);
1.6 takayama 16020: }
16021: if(type(L)==4){
16022: X-=floor((X-L[0])/(L[1]-L[0]))*(L[1]-L[0]);
16023: return myfeval(F,[V,X]);
16024: }
16025: }
16026:
16027: def cmpf(X)
16028: {
16029: if(type(X)>3){
16030: if(type(L)==7) return [S_Fc,Dx,S_Ic,S_Ec,S_EC,S_Lc];
16031: S_Lc=0;
16032: if(type(S_Fc=X[0])!=4) S_Fc=f2df(S_Fc);
16033: S_Ic=X[1];
16034: if(length(S_Ic)>2){
16035: S_Fc=mysubst(S_Fc,[S_Ic[0],x]);
16036: S_Ic=cdr(S_Ic);
16037: }
16038: S_Dc=(type(S_Ic[0])==7)?1:0;
16039: if(type(S_Ic[1])==7) S_Dc=ior(S_Dc,2);
16040: if(type(S_Ec=getopt(exp))!=1) S_Ec=0;
16041: if(S_Ec<=0){
16042: S_EC=-S_Ec;
16043: if(S_EC==0) S_EC=1;
16044: if(S_Dc==3) S_EC*=2;
16045: else S_EC/=4;
16046: if(type(F=X[0])==3&&vars(F)==[x]&&(D=deg(nm(F),x))==deg(dn(F),x)-2){
16047: S_Lc=S_EC*coef(nm(F),D,x)/coef(dn(F),D+2,x);
16048: }
16049: }else{
16050: S_EC=S_Ec;
16051: if(S_Dc==3) S_EC*=12;
16052: else S_EC/=6;
16053: }
16054: if(type(S_Fc)==3) S_Fc=red(S_Fc);
16055: S_EC=1/S_EC;
16056: return [z_,[z_,os_md.cmpf,x]];
16057: }
16058: if(X<=0 && iand(S_Dc,1)) return S_Lc;
16059: if(X>=1 && iand(S_Dc,2)) return S_Lc;
16060: if(S_Dc==3){
16061: if(S_Ec>0){
16062: Y0=dexp(1/X)*S_EC;
16063: Y1=dexp(1/(1-X))*S_EC;
16064: return myfeval(S_Fc,Y1-Y0)*(Y0/X^2+Y1/(1-X)^2);
16065: }
16066: return myfeval(S_Fc,S_EC/(1-X)-S_EC/X)*(S_EC/(1-X)^2+S_EC/X^2);
16067: }
16068: if(S_Dc==1){
16069: if(S_Ec>0){
16070: Y=dexp(1-1/X);
16071: R=myfeval(S_Fc,S_EC*(Y-1)+I[1])*Y;
16072: }
16073: else R=myfeval(S_Fc,I[1]+(1-1/X)*S_EC);
16074: return R*S_EC/X^2;
16075: }
16076: if(S_Dc==2){
16077: if(S_Ec>0){
16078: Y=dexp(X/(1-X));
16079: R=myfeval(S_Fc,S_EC*(Y-1)+S_Ic[0])*Y;
16080: }else R=myfeval(S_Fc,S_EC*X/(1-X)+S_Ic[0]);
16081: return R*S_EC/(1-X)^2;
16082: }
16083: X=S_Ic[0]+(S_Ic[1]-S_Ic[0])*X;
16084: return myfeval(S_Fc,X)/(S_Ic[1]-Ic[0]);
16085: }
16086:
16087: def fresidue(P,Q)
16088: {
16089: if(iscoef(Q,os_md.israt)) S=fctr(Q);
16090: else S=[[Q,1]];
16091: for(R=[];S!=[];S=cdr(S)){
16092: T=car(S);
16093: if((D=mydeg(T[0],z))==0) continue;
16094: L=[];
16095: if(iscoef(T[0],os_md.iscrat)) L=getroot(T[0],z|cpx=2);
16096: if(findin(z,vars(L))>=0) L=[];
16097: if(L==[]) L=polroots(T[0],z|comp=-1);
16098: for(;L!=[];L=cdr(L)){
16099: QQ=Q;
16100: for(I=T[1]; I>1;I--) QQ=mydiff(QQ,z);
16101: for(U=0,W=I=T[1];I>0;I--,W++){
16102: QQ=diff(QQ,z);
16103: U+=subst(QQ,z,L[0])*(z-L[0])^(W-T[1])/fac(W);
16104: }
16105: UD=mydiff(U,z);
16106: for(I=T[1],K=1,PP=P; I>1;I--,K++)
16107: PP=diff(PP,z)*U-K*PP*UD;
16108: QQ=subst(PP,z,L[0])/subst(U,z,L[0])^K;
16109: /* if(D==2) QQ=sqrt2rat(QQ); */
16110: R=cons([L[0],sqrt2rat(QQ)],R);
16111: }
16112: }
16113: if(type(L=getopt(cond))==4){
16114: for(S=[];R!=[];R=cdr(R)){
16115: Z=car(R);
16116: for(LL=L;LL!=[];LL=cdr(LL)){
16117: X=real(car(Z));Y=imag(car(Z));
16118: if(myf3eval(car(LL),X,Y,car(Z))<=0) break;
16119: }
16120: if(LL==[]) S=cons(Z,S);
16121: }
16122: R=reverse(S);
16123: }
16124: if((Sum=getopt(sum))==1||Sum==2){
16125: for(S=0;R!=[];R=cdr(R)) S+=car(R)[1];
16126: if(Sum==2) S*=2*@pi*@i;
16127: return sqrt2rat(S);
16128: }
16129: return R;
16130: }
16131:
16132: def fint(F,D,V)
16133: {
16134: if(((L=length(V))==2 || (L==3&&isvar(V[0])<3))
16135: && (type(V[L-1])==7||(type(V[L-1])<3&&type(eval(V[L-1]))<2)))
16136: /* real integral */
16137: return areabezier([F,D,V]|option_list=getopt());
16138: /* complex integral */
16139: if(L>1&&type(V[1])==4&&type(V[1][1])<4){
16140: if(type(V[0])==4&&type(V[0][0])<2){
16141: for(R=[],VT=car(V),VV=cdr(V);VV!=[];VV=cdr(VV),VT=VU){
16142: if((VU=car(VV))==-1) VU=car(V);
16143: R=cons([ptcommon([VT,VU],[t,1-t]|in=1),[0,1]],R);
16144: }
16145: V=reverse(R);
16146: }
16147: else if(L==2) V=[V];
16148: }
16149: Opt=cons(["cpx",1],getopt());
16150: for(R=0;V!=[];V=cdr(V)){
16151: VT=car(V);
16152: X=car(VT)[0];XD=red(diff(X,t));
16153: Y=car(VT)[1];YD=red(diff(Y,t));
16154: F=mysubst(F,[[x,X],[y,Y],[z,X+@i*Y]]);
16155: if(type(F)==4)
16156: FF=cons(F[0]*(XD+@i*YD),cdr(F));
16157: else FF=red(F*(XD+@i*YD));
16158: R+=areabezier([FF,D,cons(t,VT[1])]|option_list=Opt);
16159: }
16160: return R;
16161: }
16162:
16163: def areabezier(V)
16164: {
16165: if(getopt(cpx)==1){
16166: Opt=delopt(getopt(),"cpx");
16167: F=V[0];
16168: if(!isvar(Var=V[2][0])) Var=x;
16169: if(type(F)==3 && vars(F)==[Var] && imag(dn(F))!=0){
16170: F=(nm(F)*conj(dn(F)))/(dn(F)*conj(dn(F)));
16171: V0=red(real(nm(F))/dn(F));
16172: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
16173: V0=red(imag(nm(F))/dn(F));
16174: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
16175: }
16176: if(getopt(Acc)!=1) F=f2df(F);
16177: V0=compdf([o,[o,real,o_]],o_,F);
16178: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
16179: V0=compdf([o,[o,imag,o_]],o_,F);
16180: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
16181: }
16182: if(type(V[0])!=4 || vars(V[0][0])!=0){
16183: Mx=[-2.0^(512),2.0^(512)];
16184: I=length(V[2]);
16185: if(type(V[2][I-1])==7||type(V[2][I-2])==7){ /* infinite interval */
16186: if(type(Ec=getopt(exp))==1) R=cmpf([V[0],V[2]]|exp=Ec);
16187: else R=cmpf([V[0],V[2]]);
16188: V=[R,V[1],[0,1]];
16189: }
16190: if(type((Int=getopt(int)))==1 && type(V[0])<4 && (V1=V[1])>=0){
16191: if(Int==2&&iand(V1,1)) V1++;
16192: if(!V1) V1=32;
16193: Opt=cons(["raw",1],getopt());
16194: W=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
16195: SS=W[0][1];
16196: for(S0=S1=0,I=0,L=W;L!=[] && I<=V1;I++, L=cdr(L)){
16197: if(iand(I,1)) S1+=car(L)[1];
16198: else S0+=car(L)[1];
16199: if (I==V1) SS+=car(L)[1];
16200: }
16201: VV=deval(V[2][1]-V[2][0]);
16202: if(Int==2)
16203: return (2*S0+4*S1-SS)*VV/(3*V1);
16204: else
16205: return (2*S0+2*S1-SS)*VV/(2*V1);
16206: }
16207: Opt=cons(["opt",0],getopt());
16208: V=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
16209: }
16210: if(type(V[0][0])!=4) V=os_md.lbezier(V);
16211: for(S=0; V!=[]; V=cdr(V)){
16212: B=tobezier(car(V));
16213: P=intpoly(B[1]*diff(B[0],t),t);
16214: S+=mysubst(P,[t,1]);
16215: }
16216: return S;
16217: }
16218:
16219: def velbezier(V,L)
16220: {
16221: if(L==0) L=[t,0,1];
16222: else L=[(length(L)==3)?L[2]:t,L[0],L[1]];
16223: for(R=[],II=length(V)-1;II>=0;II--){
16224: S=fmmx(diff(V[II],L[0]|dif=1),L|dif=1);
16225: for(U=0;S!=[];S=cdr(S)) if((T=abs(car(S)[1]))>U) U=T;
16226: R=cons(U,R);
16227: }
16228: return R;
16229: }
16230:
16231: def ptbezier(V,L)
16232: {
16233: if(type(V[0])==4&&type(V[0][0])!=4) V=lbezier(V);
16234: K=length(V);
16235: if(type(L)<2){
16236: if(L<0) return K;
16237: if(L>=K-1) L=[K-1,1];
16238: else{
16239: L0=floor(L);
16240: if(L0>=K-1) L0=K-1;
16241: L=[L0,L-L0];
16242: }
16243: }
16244: if(L[0]>=0) B=V[L[0]];
16245: else B=V[K+L[0]];
16246: B=tobezier(B);
16247: BB=[diff(B[0],t),diff(B[1],t)];
16248: return [subst(B,t,L[1]),subst(BB,t,L[1])];
16249: }
16250:
1.70 takayama 16251: /*
16252: def isroot(P,Q,I)
16253: {
16254: if(subst(P,X,X0=I[0])*subst(P,X,I[1])<=0) return 1;
16255: XM=(I[1]+I[0])/2;W=XM-X0;
16256: if(W<0) W=-W;
16257: X=var(P);
16258: if(!Q) Q=diff(P,X);
16259: Q=subst(Q,X,X+I2);D=deg(Q,X);
16260: for(M=0,P=1,I=deg(Q,X);I<=D;I++){
16261: V=coef(Q,I,X);
16262: M+=(V<0?-V:V)*P;
16263: P*=W;
16264: }
16265: V=subst(P,X,X0);
16266: if(V<0) V=-V;
16267: return (V-M<=0) 2:0;
16268: }
16269: */
16270:
16271: def sgnstrum(L,V)
16272: {
16273: X=var(car(L));
16274: if(X==0) X=var(L[1]);
16275: for(F=N=0;L!=[];L=cdr(L)){
16276: P=car(L);
16277: if(type(V)==7){
16278: C=coef(P,D=deg(P,X),X);
16279: if(V=="-"&&iand(D,1)) C=-C;
16280: }else C=subst(P,X,V);
16281: if(!C) continue;
16282: if(C*F<0) N++;
16283: F=C;
16284: }
16285: return N;
16286: }
16287:
16288: def polstrum(P)
16289: {
16290: X=vars(P0=P);
16291: if(!length(X)) return [];
16292: X=car(X);
16293: if(isfctr(P)){
16294: D=gcd(P,Q=diff(P,X));
16295: P=sdiv(P,D);
16296: if(getopt(mul)==1&&type(getopt(num))<0)
16297: return append(polstrum(D|mul=1),[P]);
16298: }
16299: D=deg(P,X);
16300: P=P/coef(P,deg(P,X),X);
16301: Q=diff(P,X)/D;
16302: for(L=[Q,P];D>0;){
16303: R=urem(P,Q);
16304: if((D=deg(R,X))<0) break;
16305: C=coef(R,D,X);
16306: if(C>0) C=-C;
16307: R/=C;
16308: L=cons(R,L);
16309: P=Q;Q=R;
16310: }
16311: if(type(N=getopt(num))>0){
16312: if(getopt(mul)!=1){
16313: if(type(N)==1) N=["-","+"];
16314: return sgnstrum(L,N[0])-sgnstrum(L,N[1]);
16315: }
16316: if(!isfctr(P0)) return -1;
16317: R=polstrum(P0|mul=1);
16318: for(C=0;R!=[];R=cdr(R)) C+=polstrum(car(R)|num=N);
16319: return C;
16320: }
16321: return reverse(L);
16322: }
16323:
1.71 takayama 16324: def iceil(X)
16325: {
16326: S=(X>0)?1:-1;
16327: X*=S;
16328: if(X>1) X=ceil(X);
16329: else if(X>1/2) X=1;
16330: else if(X) X=1/floor(1/X);
16331: return S*X;
16332: }
16333:
1.70 takayama 16334: def polradiusroot(P)
16335: {
16336: X=var(P);D=deg(P,X);
16337: if(D<1) return -1;
16338: C=coef(P,D,X);
16339: P/=-C;
16340: Int=getopt(int);
16341: if(getopt(comp)==1){
16342: for(ND=0,TD=0;TD<D;TD++) if(coef(P,TD,X)!=0) ND++;
16343: for(V=0,TD=0;TD<D;TD++){
16344: TV=eval((abs(coef(P,TD,X))*ND)^(1/(D-TD)));
16345: if(V<TV) V=TV;
16346: }
1.71 takayama 16347: return (Int==1)? iceil(X):X;
1.70 takayama 16348: }
16349: for(N0=N1=0,TD=0;TD<D;TD++){
16350: if(!(C=coef(P,TD,X))) continue;
16351: if(C>0){
16352: N2++;
16353: if(!iand(D-TD,1)) N1++;
16354: }else if(iand(D-TD,1)) N1++;
16355: }
16356: for(V1=V2=0,TD=0;TD<D;TD++){
16357: if(!(C=C1=coef(P,TD,X))) continue;
16358: if(C>0){
16359: TV=eval((C*N2)^(1/(D-TD)));
16360: if(V2<TV) V2=TV;
16361: }
16362: if(iand(D-TD,1)) C=-C;
16363: if(C>0){
16364: TV=eval((C*N1)^(1/(D-TD)));
16365: if(V1<TV) V1=TV;
16366: }
16367: }
1.71 takayama 16368: return Int?[-iceil(V1),iceil(V2)]:[-V1,V2];
1.70 takayama 16369: }
16370:
1.71 takayama 16371: /* step, num, strum */
1.70 takayama 16372: def polrealroots(P)
16373: {
16374: if(type(MC=getopt(step))==4){
16375: MC1=MC[1];MC=car(MC);
16376: }else if(isint(MC)&&MC>1&&MC<10001) MC1=MC;
1.71 takayama 16377: else MC1=MC=32;
16378: if(type(I=getopt(in))!=4){
16379: I=polradiusroot(P);
1.70 takayama 16380: W=(I[1]-I[0])/1024;
16381: I=[I[0]-W,I[1]+W];
16382: }
16383: if(type(L=type(getopt(strum)))!=4) L=polstrum(P);
16384: N0=sgnstrum(L,I[0]);N1=sgnstrum(L,I[1]);
16385: P=car(L);X=var(P);
1.71 takayama 16386: if(N0<=N1) return []; /* [L,I,N0,N1]; */
1.70 takayama 16387: LT=[[0,I[0],I[1],N0,N1]];R=[];
1.71 takayama 16388: Z=eval(exp(0));
1.70 takayama 16389: while(LT!=[]){
16390: T=car(LT);LT=cdr(LT);
16391: C=T[0];X0=T[1];X1=T[2];N0=T[3];N1=T[4];
16392: if(N0<=N1)continue;
16393: if(N0==N1+1){
1.71 takayama 16394: V0=subst(P,X,X0);
16395: V1=subst(P,X,X1);
1.70 takayama 16396: while(C++<MC1){
1.71 takayama 16397: V2=subst(P,X,X2=(X0+X1)/2*Z);
1.70 takayama 16398: if((V0>0&&V2>0)||(V0<0&&V2<0)) X0=X2;
16399: else X1=X2;
16400: }
16401: R=cons([X0,X1,1],R);
16402: continue;
16403: }
16404: while(++C<MC){
1.71 takayama 16405: N2=sgnstrum(L,X2=(X0+X1)/2*Z);
1.70 takayama 16406: if(N0>N2){
1.71 takayama 16407: if(N2>N1) LT=cons([C,X2,X1,N2,N1],LT);
1.70 takayama 16408: X1=X2;
16409: N1=N2;
16410: if(N0==N1+1){
16411: LT=cons([C,X0,X1,N0,N1],LT);
1.71 takayama 16412: C=MC+1;
1.70 takayama 16413: }
16414: }else{
16415: X0=X2;
16416: N0=N2;
16417: }
16418: }
1.71 takayama 16419: if(C!=MC+2) R=cons([X0,X1,N0-N1],R);
16420: }
16421: if(isint(Nt=getopt(nt)) && Nt>0){
16422: if(Nt>256) Nt=256;
16423: Q=diff(P,X);
16424: for(S=[],TR=R;TR!=[];TR=cdr(TR)){
16425: if(car(TR)[2]>1) continue;
16426: V0=subst(P,X,car(TR)[0]);
16427: V1=subst(P,X,car(TR)[1]);
16428: if(abs(V0)<abs(V1))
16429: X0=car(TR)[0];
16430: else{
16431: X0=car(TR)[1];V0=V1;
16432: }
16433: for(Tn=Nt;Tn>0;Tn--){
16434: X1=X0-V0/subst(Q,X,X0);
16435: V1=subst(P,X,X1);
16436: if(abs(V1)>=abs(V0)) break;
16437: X0=X1;V0=V1;
16438: }
16439: S=cons(X0,S);
16440: }
16441: for(TR=R;TR!=[];TR=cdr(TR))
16442: if(car(TR)[2]>1) S=cons(car(TR),S);
16443: return reverse(S);
1.70 takayama 16444: }
16445: return reverse(cons(P,R));
16446: }
16447:
16448: /*
16449: def ptcombezier0(P,Q)
16450: {
16451: PB=subst(tobezier(P|div=1),t,s);
16452: QB=tobezier(Q|Div=1);
16453: Z=res(PB[0]-QB[0],PB[1]-QB[1],s);
16454: D=pmaj(diff(Z,t)|val=t);
16455: }
16456: */
16457:
1.6 takayama 16458: def ptcombezier(P,Q,T)
16459: {
16460: if(type(T)<2){
16461: if(T<2) T=20; /* default */
16462: return ptcombezier(P,Q,[0,0,1,T]);
16463: }
16464: V=T[2]/2;;
16465: PB=tobezier(P|div=1);
16466: PP=[ptbbox(PB[0]),ptbbox(PB[1])];
16467: QB=tobezier(Q|div=1);
16468: QQ=[ptbbox(QB[0]),ptbbox(QB[1])];
16469: for(L=[],I=0;I<2;I++){
16470: for(J=0;J<2;J++){
16471: if(!iscombox(PP[I],QQ[J])) continue;
16472: if(T[3]<=1) return
16473: [[T[0]+(I+0.5)*V,T[1]+(J+0.5)*V,
16474: [(PP[I][0][0]+PP[I][0][1])/2,(PP[I][1][0]+PP[I][1][1])/2]]];
16475: else{
16476: #if 0
16477: U=PB[I][0];V=PB[I][length(PB[I])-1];
16478: if(abs(A=(U[0]-V[0]))>abs(B=(U[1]-V[I])))
16479: M=mat([1,0],[-B/A,1]);
16480: else if(U!=V)
16481: M=mat([1,-A/B],[0,1]);
16482: else continue;
16483: if(!iscombox(ptbox(ptaffine(M,PB[I])),ptbox(ptaffine(M,QB[J])))) continue;
16484: #endif
16485:
16486: LN=ptcombezier(PB[I],QB[J],[T[0]+I*V,T[1]+J*V,V,T[3]-1]);
16487: #if 0
16488: L=append(LN,L);
16489: #else
16490: if(LN!=[]){
16491: if(L==[]) L=LN;
16492: else for(VV=3*V/2^T[3];LN!=[];LN=cdr(LN)){
16493: for(LT=L;LT!=[];LT=cdr(LT)){
16494: if(abs(car(LN)[0]-car(LT)[0])<VV&&abs(car(LN)[1]-car(LT)[1])<VV) break;
16495: }
16496: }
16497: }
16498: if(length(L)>32){ /* Too many points */
16499: I=J=2;
16500: }
16501: #endif
16502: }
16503: }
16504: }
16505: return L;
16506: }
16507:
16508:
16509: def ptcombz(P,Q,T)
16510: {
16511: if(P==Q) Q=0;
16512: if(type(P[0][0])!=4) P=P0=lbezier(P);
16513: if(Q==0){
16514: Q=P;F=1;
16515: }
16516: else if(type(Q[0][0])!=4) Q=lbezier(Q);
16517: for(R=[],I=0,Q0=Q;P!=[];P=cdr(P),I++){
16518: for(J=0,Q=Q0;Q!=[];Q=cdr(Q),J++){
16519: if(F==1&&I<J+2) break;
16520: if((RT=ptcombezier(car(P),car(Q),T))!=[]){
16521: RT=cons([I,J],RT);
16522: R=cons(RT,R);
16523: }
16524: }
16525: }
16526: if((Red=getopt(red))==1||Red==2){
16527: if(type(M=getopt(prec))!=1) M=12;
16528: for(F=0,T=P0;T!=[];T=cdr(T)){
16529: for(S=car(T);S!=[];S=cdr(S)){
16530: if(type(ST=car(S))==4 && type(ST[0])<2){
16531: if(F++==0){
16532: X0=X1=ST[0];Y0=Y1=ST[1];
16533: }else{
16534: if(ST[0]<X0) X0=ST[0];
16535: if(ST[0]>X1) X1=ST[0];
16536: if(ST[1]<Y0) Y0=ST[1];
16537: if(ST[1]>Y1) Y1=ST[1];
16538: }
16539: }
16540: }
16541: }
16542: V0=(X1-X0)/2^M;V1=(Y1-Y2)/2^M;
16543: for(RR=[],RT=R;RT!=[];RT=cdr(RT))
16544: for(S=cdr(car(RT));S!=[];S=cdr(S)) RR=cons(car(S)[2],RR);
16545: RR=ltov(RR);L=length(RR);
16546: for(I=0;I<L;I++)
16547: for(K=1,J=I+1;K!=0&&J<L;J++)
16548: if(abs(RR[I][0]-RR[J][0])<V0 && abs(RR[I][1]-RR[J][1])<V1) RR[I]=K=0;
16549: R0=[];
16550: I=L-1;
16551: if(Red==2){
16552: for(;I>=0;I--) if(RR[I]!=0) R0=cons(RR[I],R0);
16553: }else{
16554: for(RT=R;RT!=[];RT=cdr(RT)){
16555: R00=[car(RT)[0]];
16556: for(S=cdr(car(RT));S!=[];S=cdr(S),I--)
16557: if(RR[L-I-1]!=0) R00=cons(car(S),R00);
16558: if(length(R00)>1) R0=cons(reverse(R00),R0);
16559: }
16560: }
16561: return R0;
16562: }
16563: return reverse(R);
16564: }
16565:
16566: def draw_bezier(ID,IDX,B)
16567: {
16568: if(getopt(init)==1){
16569: S_FDot=0;
16570: return;
16571: }
16572: if(type(Col=getopt(col))!=1&&Col!=0) Col=0;
16573: Dot=0;
16574: if(type(Opt=getopt(opt))==7){
16575: if(!Col){
16576: Col=drawopt(Opt,0);
16577: if(Col==-1) Col=0;
16578: }
16579: T=drawopt(Opt,3);
16580: if(iand(T,2)){
16581: M=iand(T,1)?1/8:1/4;
16582: for(C=Col,Col=I=0;I<20;I+=8)
16583: Col+=ishift(0xff-(floor((0xff-iand(0xff,ishift(C,I)))*M)),-I);
16584: }
16585: if(iand(T,4)) Dot=2; /* 2 or 3 or 4 or 6 */
16586: else if(iand(T,8)) Dot=4;
16587: }
16588: if(type(B)==4 && (type(B[0])==4||type(B[0])==5) && type(B[0][0])<2) B=lbezier(B);
16589: else if(type(B)==5) B=[vtol(B)];
16590: for(;B!=[];B=cdr(B)){
16591: if(vars(F=car(B))==[]){
16592: #if 1
16593: if(length(F)<3&&!Dot){ /* line or point */
16594: if(length(F)>0){
16595: G=[rint(F[0][0]),rint(F[0][1])];
16596: if(length(F)==1) draw_obj(ID,IDX,G,Col);
16597: else{
16598: G=[G[0],G[1],rint(F[1][0]),rint(F[1][1])];
16599: draw_obj(ID,IDX,G,Col);
16600: }
16601: }
16602: continue;
16603: }
16604: #endif
16605: if(length(F)<2) continue;
16606: F=tobezier(F);
16607: }
16608: N=velbezier(F,0);
16609: N=(N[0]>N[1])?N[0]:N[1];
16610: if(!N) N=1;
16611: for(I=0;I<=N;I++,S_FDot++){
16612: if(Dot!=iand(S_FDot,Dot)) continue;
16613: G=subst(F,t,I/N);
16614: G=[rint(G[0]),rint(G[1])];
16615: if(G!=G0){
16616: draw_obj(ID,IDX,G,Col);
16617: G0=G;
16618: }
16619: }
16620: }
16621: if(S_FDot-->=2^32) S_FDot=0;
16622: return 0;
16623: }
16624:
1.29 takayama 16625:
16626: /*
16627: def redbezier(L)
16628: {
16629: V=newvect(4);ST=0;
16630: for(R=[],I=0,T=L;T=[];T=cdr(T){
16631: if(type(car(T))<4){
16632: F=0;
16633: if(I==3)
16634: if(car(T)==0){
16635: }else if(car(T)==1){
16636: }else if(car(T)==-1){
16637: if(I<3) V[I++]=ST;
16638: }
16639: }else if(I==3){
16640: if(R==[] || car(R)!=1){
16641: R=cons(V[0],R);
16642: if(ST==0) ST=V[0];
16643: }
16644: for(J=1;J<3;J++) R=cons(V[J],R);
16645: while((T=cdr(T))!=[]){
16646: R=cons(car(T),R);
16647: if(type(car(R))<4)
16648: }
16649: }else{
16650: if(ST==0) ST=car(T);
16651: V[I++]= car(T);
16652: }
16653: }
16654: }
16655: */
16656:
1.6 takayama 16657: def lbezier(L)
16658: {
16659: if((In=getopt(inv))==1||In==2||In==3){
16660: for(F=0,R=[];L!=[];L=cdr(L)){
16661: LT=car(L);
16662: if(F==car(LT)) R=cons(1,R);
16663: else{
16664: if(R!=[]&&F!=0) R=cons(0,R);
16665: R=cons(G=car(LT),R);
1.72 takayama 16666: if(In==3) In=2;
1.6 takayama 16667: }
16668: for(LT=cdr(LT);LT!=[];LT=cdr(LT))
16669: R=cons(car(LT),R);
16670: if((F=car(R))==G&&In==1){
16671: R=cons(-1,cdr(R));
16672: F=0;
16673: }
16674: }
16675: if(In==3 && car(R)==G) R=cons(-1,cdr(R));
16676: return reverse(R);
16677: }
16678: for(F=0,RT=R=[];L!=[];L=cdr(L)){
16679: if(type(T=car(L))==4||type(T)==5){
16680: if(F==0){
16681: FT=T;F=1;
16682: }
16683: RT=cons(T,RT);
16684: }else if(T==0){
1.72 takayama 16685: if(RT!=[]) R=cons(reverse(RT),R);
1.6 takayama 16686: RT=[];F=0;
16687: }else if(T==1){
16688: if(RT!=[]){
16689: R=cons(reverse(RT),R);
16690: RT=[car(RT)];
16691: }else{
16692: RT=[];F=0;
16693: }
16694: }else if(T==-1){
16695: RT=cons(FT,RT);
16696: R=cons(reverse(RT),R);
16697: RT=[];F=0;
16698: }
16699: }
16700: if(RT!=[]) R=cons(reverse(RT),R);
16701: return reverse(R);
16702: }
16703:
16704:
16705: def xybezier(L)
16706: {
1.72 takayama 16707: if(type(L)==4&&type(car(L))==4&&type(car(L)[0])==4) L=lbezier(L|inv=1);
1.6 takayama 16708: if(L==0 || (LS=length(L))==0) return "";
16709: Out=str_tb(0,0);
16710: if(type(VF=getopt(verb))==4){
16711: if(type(car(VF))>3){
16712: VFS=VF;VF=1;
16713: }else{
16714: VFS=cdr(VF);VF=car(VF);
16715: }
16716: }else VFS=["$\\bullet$","$\\times$"];
16717: if(VF!=1 && VF!=2) VF=0;
16718: if(!TikZ){
16719: if(VF) Ob=str_tb(0,0);
16720: T="\n**\\crv{";
16721: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+Opt;
16722: L00=Q=L[I0=0];S=S1="";
16723: for(F=0,I=1;I<=LS;I++){
16724: P=Q;Q=(I==LS)?0:L[I];
16725: if(type(Q)==4){
16726: if(F==0){
16727: S1="";L0=P;F=1;
16728: continue;
16729: }else if(F==1)
16730: F=2;
16731: else if(F==2){
16732: S1=S1+"&";
16733: }
16734: S1=S1+xypos(P);
16735: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
16736: }else{
16737: if(Q==0){
16738: if(F>0){
16739: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
16740: if(VF){
16741: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
16742: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
16743: }
16744: F=0;
16745: }
16746: }else if(Q==1){
16747: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
16748: if(VF){
16749: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
16750: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
16751: }
16752: F=1;
16753: }else if(Q==-1){
16754: if(F==2)
16755: S1=S1+"&";
16756: str_tb("{"+xypos(L0)+";"+xypos(L00)+T+S1+xypos(P)+"}};\n",Out);
16757: if(VF) str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
16758: F=0;
16759: }
16760: if(F==1){
16761: if(I<LS-1 && type(L[I+1])<2){
16762: if(L[I+1]==-1){
16763: str_tb("{"+xypos(P)+";"+xypos(L00)+T+"}};\n",Out);
16764: }
16765: if(VF) str_tb(xyput([P[0][0],P[0][1],VFS[0]]),Ob);
16766: F=0;
16767: }
16768: }
16769: while(++I<LS && type(L[I])<2);
16770: if(I>=LS) break;
16771: if(F==1){
16772: Q=P;I--;F=0;
16773: }else L00=Q=L[I];
16774: }
16775: }
16776: }else{
16777: if(type(T=getopt(cmd))==7){
16778: if(T!="") T="\\"+T;
16779: }else T="\\draw";
16780: if((Rel=getopt(relative))==1) VF=0;
16781: if(VF) Ob=str_tb(0,0);
16782: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+"["+Opt+"]";
16783: Out=str_tb(T,0);
16784: Q=L[0];
16785: for(F=M=0,I=1;I<=LS;I++){
16786: P=Q; Q=(I==LS)?0:L[I];
16787: if(++M>XYLim){
16788: str_tb("\n",Out);M=1;
16789: }
16790: if(type(Q)==4 || type(Q)==5 || type(Q)==7){
16791: if(F==0){
16792: str_tb(" ",Out);
16793: F=1;
16794: }else if(F==1){
16795: str_tb(" .. controls ",Out);
16796: F=2;
16797: }else if(F==2){
16798: str_tb(" and ",Out);
16799: F=2;
16800: }
16801: PP=xypos(P);
16802: if(Rel==1 && F==2) PP="+"+PP;
16803: str_tb(PP,Out);
16804: if(VF&&((F<2)||length(VFS)>1))
16805: str_tb(xyput([P[0],P[1],(F<2)?VFS[0]:VFS[1]]),Ob);
16806: }else{
16807: /* if(I<LS-1) VF=0; */
16808: if(Q==0||Q==1){
16809: PP=xypos(P);
16810: if(Rel==1) PP="+"+PP;
16811: str_tb(((F==0)?" ":((F==1)?" -- ":" .. "))+PP,Out);
16812: if(VF) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
16813: F=Q;
16814: }else if(Q==-1){
16815: PP=xypos(P);
16816: if(Rel==1) PP="+"+PP;
16817: if(F==1)
16818: str_tb("..controls "+PP+" .. cycle",Out);
16819: else if(F==2)
16820: str_tb(" and "+PP+" .. cycle",Out);
16821: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
16822: F=0;
16823: }
16824: if(F==1){
16825: if(I<LS-1){
16826: if(L[I+1]==-1){
16827: str_tb(" -- cycle",Out);
16828: I=I+1;
16829: F=0;
16830: }
16831: else if(type(L[I+1])<2) F=0;
16832: }
16833: }
16834: while(++I<LS && type(L[I])<2);
16835: if(I>=LS) break;
16836: Q=L[I];
16837: }
16838: }
16839: str_tb(";\n",Out);
16840: }
16841: if(VF) str_tb(str_tb(0,Ob),Out);
16842: return str_tb(0,Out);
16843: }
16844:
16845: def xybox(L)
16846: {
16847: K=length(L);
16848: P=L[0];Q=L[1];
16849: if(K==2)
16850: LL=[ P, [P[0],Q[1]], Q, [Q[0],P[1]] ];
16851: else{
16852: R=L[2];
16853: LL=[ P, R, Q, [P[0]+Q[0]-R[0],P[1]+Q[1]-R[1]] ];
16854: }
16855: Opt=getopt();
16856: SS=getopt(opt);
1.8 takayama 16857: FL=getopt(color);
16858: if(TikZ&&type(SS)<1&&K==2){
16859: if(type(FL)==4){
16860: F=FL[0];
16861: if(length(FL)>1) CMD=FL[1];
16862: }else if(type(FL)==7) F=FL;
16863: else F="";
16864: F=cons(F,["rectangle"]);
16865: if(CMD) return xyarrow(P,Q|opt=F,cmd=CMD);
16866: else return xyarrow(P,Q|opt=F);
16867: }
1.6 takayama 16868: if(type(SS)!=7&&!TikZ) Opt=cons(["opt","@{-}"],Opt);
16869: Opt=cons(["close",1],Opt);
16870: return xylines(LL|option_list=Opt);
16871: }
16872:
16873: def xyang(S,P,Q,R)
16874: {
1.72 takayama 16875: Opt=delopt(getopt(),"ar");
1.6 takayama 16876: if(type(Prec=getopt(prec))!=1) Prec=0;
16877: if(type(Q)>2){
1.72 takayama 16878: if(type(Ar=getopt(ar))!=1) Ar=0;
1.6 takayama 16879: if(R==1||R==-1){ /* 直角 */
16880: P1=ptcommon([Q,P],[-S,0]);
16881: S*=R;
16882: P2=ptcommon([P,P1],[S,@pi/2]);
16883: P3=ptcommon([P1,P2],[S,@pi/2]);
16884: return xylines([P1,P2,P3]|option_list=Opt);
1.72 takayama 16885: }else if((AR=abs(R))==0||AR==2||AR==3||AR==4||AR>=10){ /* 矢印 */
1.6 takayama 16886: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
16887: if(R<0) Ang+=3.14159;
1.72 takayama 16888: if(AR>10) X=deval(@pi/180*AR);
16889: else{
16890: ANG=[0.7854,0.5236,1.0472];
16891: X=(AR==0)?1.5708:ANG[AR-2];
16892: }
1.6 takayama 16893: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
16894: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; /* 矢先 */
1.72 takayama 16895: L=(X==0)?[U,V]:[U,P,V];
16896: if(X&&iand(Ar,2)){
16897: L=append([V],L);
16898: if((X=ptcommon([P,Q],[U,V]|in=1))!=0) P=X;
16899: }
16900: if(iand(Ar,1))
16901: L=append([Q,P,0],L); /* 心棒 */
16902: return xylines(L|option_list=Opt);
1.6 takayama 16903: }else if(AR>4&&AR<9){
16904: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
16905: ANG=[0.7854,0.5236,0.3927,0.2618];
16906: X=ANG[AR-5];
16907: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
16908: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)];
16909: W=ptcommon([P,U],[P,Q]|in=-2);
16910: W1=[(U[0]+P[0]+W[0])/3,(U[1]+P[1]+W[1])/3];
16911: W2=[(V[0]+P[0]+W[0])/3,(V[1]+P[1]+W[1])/3];
1.72 takayama 16912: L=iand(Ar,2)?[V,U,1,W1,P,1,W2,V]:[U,W1,P,1,W2,V];
16913: if(iand(Ar,1)){
16914: if(iand(Ar,2)) P=ptcommon([P,Q],[U,V]);
16915: L=append([Q,P,0],L);
1.73 takayama 16916: };
1.6 takayama 16917: if(type(Sc=getopt(scale))>0){
16918: if(type(Sc)==1) Sc=[Sc,Sc];
16919: L=ptaffine(diagm(2,Sc),L);
16920: }
1.73 takayama 16921: Opt=delopt(Opt,"proc");
1.72 takayama 16922: if(getopt(proc)==1) return append([2,Opt],L);
16923: S=xybezier(L|option_list=Opt);
1.6 takayama 16924: if(getopt(dviout)!=1) return S;
1.72 takayama 16925: dviout(xyproc(S));
1.6 takayama 16926: return 1;
16927: }
16928: }
16929: if(type(Q)<3){
16930: X=deval(Q); Y=deval(R);
16931: }else{
16932: X=myarg([Q[0]-P[0],Q[1]-P[1]]);
16933: Y=myarg([R[0]-P[0],R[1]-P[1]]);
16934: }
16935: if(Prec>2) N=8;
16936: else if(Prec==2) N=6;
16937: else if(Prec==1) N=4;
16938: else N=3;
16939: U=deval(@pi)*2/N;
16940: if(X==Y||Y-X>6.28318){
16941: for(L=[],I=N-1;I>=0;I--) L=cons([P[0]+S*dcos(I*U),P[1]+S*dsin(I*U)],L);
16942: return xylines(L|option_list=append([["curve",1],["close",1]],Opt));
16943: }
16944: for(M=1;(Y-X)/M>U;M++);
16945: for(L=[],I=M+1;I>-2;I--){
16946: Ang=X+(Y-X)*I/M;
16947: L=cons([P[0]+S*dcos(Ang),P[1]+S*dsin(Ang)],L);
16948: }
16949: if(getopt(ar)!=1) return xylines(L|option_list=append([["curve",1],["close",-1]],Opt));
16950: OL=delopt(Opt,["dviout","opt","proc"]);
16951: S=xylines(L|option_list=append([["curve",1],["close",-1],["opt",0]],OL));
16952: T=xylines([P,L[1]]|option_list=cons(["opt",0],OL));
16953: S=ptaffine("close",[S,T]); /* connect curves */
16954: if(getopt(opt)==0) return S;
16955: OL=(type(SS=getopt(opt))>1)?[["opt",SS]]:[];
16956: if(type(T=getopt(proc))==1 && T>=1 && T<=3) return [1,OL,S];
16957: if(OL==[]) S=xybezier(S);
16958: else S=(type(SS)==7)? xybezier(S|opt=SS):xybezier(S|opt=SS[0],cmd=SS[1]);
16959: if(getopt(dviout)==1) return xyproc(S|dviout=1);
16960: return S;
16961: }
16962:
16963: def xyoval(P,L,R)
16964: {
16965: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
16966: if(length(Arg)>2)
16967: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180,@pi*Arg[2]/180];
16968: else
16969: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
16970: }
16971: if(type(Arg)==4){
16972: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
16973: if(length(Arg)>2) Arg2=deval(Arg[2]);
16974: if(Arg1<Arg0 || Arg0<-7) return 0;
16975: }
16976: if(type(Prec=getopt(prec))!=0) Prec=0;
16977: if((Ar=getopt(ar))!=1) Ar=0;
16978: L=xyang(L,[0,0],Arg0,Arg1|prec=Prec,opt=0,ar=Ar);
16979: Sc=getopt(scale);
16980: if(type(Sc=getopt(scale))<1) Sc=[1,1];
16981: else if(type(Sc)==1) Sc=[Sc,Sc];
16982: M=mat([1,0],[0,R]);
16983: L=ptaffine(M,L|shift=P);
16984: M=mat([Sc[0],0],[0,Sc[1]]);
16985: L=ptaffine(M,L|arg=Arg2);
16986: if((Opt=getopt(opt))==0) return L;
16987: Opt=(type(Opt)>1)? [["opt2",Opt]]:[];
16988: if(getopt(proc)==1) return [1,Opt,L];
16989: S=xybezier(L|option_list=getopt());
16990: if(getopt(dviout)==1){
16991: xyproc(S|dviout=1);
16992: return 1;
16993: }
16994: return S;
16995: }
16996:
16997: def xycirc(P,R)
16998: {
16999: ST=getopt(opt);
17000: if(type(ST)<0) ST="";
17001: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
17002: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
17003: }
17004: /* Is it OK?
17005: if(TikZ==0 && XYcm==1){
17006: R*=10; P=[P[0]*10,P[1]*10];
17007: }
17008: */
17009: if(type(Arg)==4){
17010: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
17011: if(Arg1<=Arg0 || Arg0<-7 || Arg1-Arg0>7) return 0;
17012: if(type(ST)==7)
17013: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
17014: [P[1]-R-1,P[1]+R+1]|opt=ST);
17015: else
17016: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
17017: [P[1]-R-1,P[1]+R+1]);
17018: if(getopt(close)==1){
17019: S=S+xyline([0,0],
17020: [deval(subst(R*cos(x)+P[0],x,Arg0)),deval(subst(R*sin(x)+P[0],x,Arg0))]);
17021: S=S+xyline([0,0],
17022: [deval(subst(R*cos(x)+P[0],x,Arg1)),deval(subst(R*sin(x)+P[0],x,Arg1))]);
17023: }
17024: return S;
17025: }
17026: if(TikZ){
17027: SP="";
17028: if(length(P)>2) SP=P[2];
17029: if(type(SP)!=7) SP="$"+my_tex_form(SP)+"$";
17030: if(R==0){
17031: if(ST!="") ST=ST+",";
17032: return "\\node ["+ST+"circle,draw]"+xypos([P[0],P[1]])+ "{"+SP+"};\n";
17033: }
1.8 takayama 17034: if(type(R)!=7) R=rtostr(deval(R));
1.6 takayama 17035: if(ST!="") ST="["+ST+"]";
17036: S="\\draw "+ST+xypos([P[0],P[1]])+" circle [radius="+R+"]";
17037: if(SP!="") S=S+" node at"+xypos([P[0],P[1]])+" {"+SP+"}";
17038: return S+";\n";
17039: }
17040: S="{"+xypos([P[0],P[1]]);
17041: if(length(P)>2){
17042: SP=P[2];
17043: if(type(P)!=7) SP=my_tex_form(SP);
17044: S=S+" *+{"+SP+"}";
17045: }
17046: S =S+" *\\cir";
17047: if(R!=0){
1.8 takayama 17048: R=deval(R);
1.6 takayama 17049: S=S+"<"+rtostr(R)+((XYcm)?"cm>":"mm>");
17050: }
17051: S = S+"{";
17052: if(type(ST)==7) S=S+ST;
17053: return S+"}};\n";
17054: }
17055:
1.33 takayama 17056: def xypoch(W,H,R1,R2)
17057: {
17058: if(H>R1||2*H>R2){
17059: errno(0);
17060: return;
17061: }
17062: if(type(Ar=getopt(ar))!=1) Ar=TikZ?0.25:2.5;
17063: T1=dasin(H/R1);S1=R1*dcos(T1);
17064: T2=dasin(H/R2);S2=R2*dcos(T2);
17065: T3=dasin(2*H/R2);S3=R2*dcos(T3);
17066: S=xyline([R1,0],[W-R1,0]);
17067: S+=xyang(R1,[W,0],-@pi,@pi-T1);
17068: S+=xyline([S2,H],[W-S1,H]);
17069: S+=xyang(R2,[0,0],T2,2*@pi-T3);
17070: S+=xylines([[S3,-2*H],[W-H-R2,-2*H],[W-H-R2,2*H],[W-S3,2*H]]);
17071: S+=xyang(R2,[W,0],-@pi+T2,@pi-T3);
17072: S+=xyline([W-T2,-H],[W-T2,-H]);
17073: S+=xyang(R1,[0,0],0,2*@pi-T1);
17074: S+=xyline([W-S2,-H],[S1,-H]);
17075: if(Ar>0){
17076: S+=xyang(Ar,[W/2,0],[0,0],8);
17077: S+=xyang(Ar,[W/2,-2*H],[0,-2*H],8);
17078: S+=xyang(Ar,[W/2-Ar,-H],[W,-H],8);
17079: S+=xyang(Ar,[W/2-Ar,H],[W,H],8);
17080: S+=xyang(Ar,[W-S3,2*H],[W-H-R2,2*H],8);
17081: }
17082: S+=xyput([R1,0,"$\\bullet$"]);
17083: S+=xyput([0,0,"$\\times$"]);
17084: S+=xyput([W,0,"$\\times$"]);
17085: if(TikZ) S=str_subst(S,";\n\\draw","\n");
17086: return S;
17087: }
17088:
1.72 takayama 17089: def xycircuit(P,S)
17090: {
17091: if(type(Sc=getopt(scale))!=1) Sc=1;
17092: if(type(Opt0=getopt(opt))!=7) Opt0="";
1.73 takayama 17093: if(type(At=getopt(at))!=1) At=(S=="E"||S=="EE")?1:1/2;
1.72 takayama 17094: Rev=(getopt(rev)==1)?-1:1;
17095: if(type(P)==4&&type(car(P))==4&&P[0][0]==P[1][0]) Rev=-Rev;
17096: W=R=B2=0;Opt="";
1.73 takayama 17097: if(S=="L"||S=="VL"||S=="LT"){
1.72 takayama 17098: G=[1/8*x-2/5*cos(x)+2/5,1/2*sin(x)+1/2];
17099: B=xygraph(G,-21,[0,7*@pi],[-1,10],[-2,2]|scale=0.3/1.06466,opt=0);
17100: B=append(B,[1,[1,0]]);
17101: B=append([[0,0],car(B),1],cdr(B));
17102: W=1;Opt="thick";
17103: if(S=="VL"){
17104: B2=xyang(0.2,[0.5+0.4*Rev,0.45],[0.5-0.435*Rev,-0.3],3|ar=3,opt=0);
17105: Opt2="thick,fill";
1.73 takayama 17106: }else if(S=="LT"){
17107: B2=[[0.5+0.4*Rev,0.45],[0.5-0.435*Rev,-0.3],0,[0.45+0.4*Rev,0.394],[0.55+0.4*Rev,0.506]];
17108: Opt2="thick";
1.72 takayama 17109: }
1.73 takayama 17110: }else if(S=="C"||S=="VC"||S=="C+"||S=="C-"||S=="CT"){
1.72 takayama 17111: B=[[0,-0.2],[0,0.2],0,[0.15,-0.2],[0.15,0.2]];
17112: W=0.15;Opt="very thick";
17113: if(S=="VC"){
17114: B2=xyang(0.2,[1/3+0.075,0.3*Rev],[-1/3+0.075,-0.3*Rev],3|ar=3,opt=0);
17115: Opt2="thick,fill";
1.73 takayama 17116: }else if(S=="CT"){
17117: B2=[[1/3+0.075,0.3*Rev],[-1/3+0.075,-0.3*Rev],0,[1/3+0.125,0.244*Rev],
17118: [1/3+0.025,0.356*Rev]];
17119: Opt2="thick";
17120: }else if(S=="C+")
1.72 takayama 17121: B2=[[0,0.05],[0.15,-0.05],0,[0,0.15],[0.15,0.05],0,[0,-0.05],[0.15,-0.15],
1.73 takayama 17122: 0,[0.29,0.04*Rev],[0.29,0.24*Rev],0,[0.19,0.14*Rev],[0.39,0.14*Rev]];
17123: else if(S=="C-")
17124: B2=[[0,0.05],[0.15,-0.05],0,[0,0.15],[0.15,0.05],0,[0,-0.05],[0.15,-0.15]];
17125: }else if(S=="R"||S=="VR"||S=="VR3"||S=="RT"){
1.72 takayama 17126: for(I=0,B=[[0,0]];I<12;I++)
17127: if(iand(I,1)) B=cons([I,(-1)^((I+1)/2)],B);
17128: B=reverse(cons([12,0],B));
17129: B=xylines(B|scale=[1/18,0.15],opt=0);
17130: W=2/3;Opt="thick";
17131: if(S=="VR"){
17132: B2=xyang(0.2,[2/3,0.3*Rev],[0,-0.3*Rev],3|ar=3,opt=0);
17133: Opt2="thick,fill";
1.73 takayama 17134: }else if(S=="RT"){
17135: B2=[[2/3,0.3*Rev],[0,-0.3*Rev],0,[0.717,0.244*Rev],[0.617,0.357*Rev]];
17136: Opt2="thick";
1.72 takayama 17137: }else if(S=="RN3"){
17138: B2=xyang(0.2,[1/3,0.2*Rev],[1/3,0.5*Rev],3|ar=3,opt=0);
17139: Opt2="thick,fill";
17140: }
1.73 takayama 17141: }else if(S=="RN"||S=="VRN"||S=="RN3"||S=="NRT"){
1.72 takayama 17142: B=xylines([[0,0.1],[2/3,0.1],[2/3,-0.1],[0,-0.1],[0,0.1]]|opt=0);
17143: W=2/3;Opt="thick";
17144: if(S=="VRN"){
17145: B2=xyang(0.2,[2/3,0.3*Rev],[0,-0.3*Rev],3|ar=3,opt=0);
17146: Opt2="thick,fill";
17147: }else if(S=="RN3"){
17148: B2=xyang(0.2,[1/3,0.2*Rev],[1/3,0.5*Rev],3|ar=3,opt=0);
17149: Opt2="thick,fill";
1.73 takayama 17150: }else if(S=="NRT"){
17151: B2=[[2/3,0.3*Rev],[0,-0.3*Rev],0,[0.717,0.244*Rev],[0.617,0.357*Rev]];
17152: Opt2="thick";
1.72 takayama 17153: }
17154: }else if(S=="circle"){
17155: W=1;
17156: B=xyang(0.5,[0.5,0],0,0|opt=0);
17157: }else if(S=="gap"){
17158: W=0.3;
17159: B=xyang(0.15,[0.15,0],0,3.1416|opt=0);
17160: }else if(S=="E"){
17161: W=0.1;
17162: B=[[0,0.2],[0,-0.2],0,[0,0.05],[0.1,-0.05],0,[0,0.15],[0.1,0.05],0,[0,-0.05],[0.1,-0.15]];
1.73 takayama 17163: }else if(S=="EE"){
17164: W=0.15;
17165: B=[[0,0.2],[0,-0.2],0,[0.075,0.13],[0.075,-0.13],0,[0.15,-0.06],[0.15,0.06]];
1.72 takayama 17166: }else if(S=="Cell"){
17167: W=0.1;
17168: B=[[0,-0.2],[0,0.2]];
17169: B2=[[0.1,-0.1],[0.1,0.1]];Opt2="very thick";
17170: }else if(S=="Cell2"){
17171: W=0.3;
17172: B=[[0,-0.2],[0,0.2],0,[0.2,-0.2],[0.2,0.2]];
17173: B2=[[0.1,-0.1],[0.1,0.1],0,[0.3,-0.1],[0.3,0.1]];Opt2="very thick";
1.73 takayama 17174: }else if(S=="Cells"){
17175: W=0.6;
17176: B=[[0,-0.2],[0,0.2],0,[0.5,-0.2],[0.5,0.2],0,[0.1,0],[0.18,0],0,
17177: [0.24,0],[0.34,0],0,[0.40,0],[0.5,0]];
17178: B2=[[0.1,-0.1],[0.1,0.1],0,[0.6,-0.1],[0.6,0.1]];Opt2="very thick";
1.72 takayama 17179: }else if (S=="Sw"){
17180: W=0.5;
17181: B=xyang(0.05,[0.05,0],0,0|opt=0);
17182: B0=ptaffine(1,B|shift=[0.4,0]);
17183: B=ptaffine("union",[B,B0]);
17184: B=ptaffine("union",[B,[[0.0908,0.025*Rev],[0.45,0.17*Rev]]]);
17185: }else if(S=="D"){
17186: W=0.3;Opt="thick";
17187: B=[[0,0],[0.3,0.173],0,[0.3,0.173],[0.3,-0.173],0,[0.3,-0.173],[0,0],0,
17188: [0,0.173],[0,-0.173]];
17189: }else if(S=="") R=(Opt0=="")?xyline(P[0],P[1]):xyline(P[0],P[1]|opt=Opt0);
17190: else if(S=="arrow") R=xyang(0.2*Sc,P[1],P[0],3|ar=1,opt=Opt0);
17191: else if(type(S)==4&&type(car(S))==7){
17192: if(type(car(P))!=4) P=[P];
17193: for(R="";P!=[];P=cdr(P)) R+=xyput([car(P)[0],car(P)[1],car(S)]);
17194: }
17195: if(W){
17196: R="";
17197: if(type(P)==4){
17198: if(type(car(P))==4){
17199: T=ptcommon([[0,0],[1,0]],P|in=2);
17200: L=dnorm(P);
17201: W*=Sc;
17202: L1=L*At-W/2;L2=L*(1-At)-W/2;
17203: if(L1>0){
17204: P1=[P[0][0]+L1*dcos(T),P[0][1]+L1*dsin(T)];
17205: R+=xyline(P[0],P1);
17206: }
17207: if(L2>0){
17208: P2=[P[1][0]-L2*dcos(T),P[1][1]-L2*dsin(T)];
17209: R+=xyline(P2,P[1]);
17210: }
17211: B=ptaffine(Sc,B|shift=P1,arg=T);
17212: if(B2) B2=ptaffine(Sc,B2|shift=P1,arg=T);
17213: }else{
17214: B=ptaffine(Sc,B|shift=P1);
17215: if(B2) B2=ptaffine(Sc,B2|shift=P1);
17216: }
17217: }else{
17218: B=ptaffine(Sc,B);
17219: if(B2) B2=ptaffine(Sc,B2);
17220: }
17221: if(Opt=="") Opt=Opt0;
17222: else if(Opt0!="") Opt=Opt+","+Opt0;
17223: R+=(Opt=="")?xybezier(B):xybezier(B|opt=Opt);
17224: if(B2){
17225: if(Opt2=="") Opt2=Opt0;
17226: else if(Opt0!="") Opt2=Opt2+","+Opt0;
17227: R+=(Opt2=="")?xybezier(B2):xybezier(B2|opt=Opt2);
17228: }
17229: }
17230: return R;
17231: }
17232:
17233:
1.6 takayama 17234: def ptaffine(M,L)
17235: {
17236: if(type(L)!=4&&type(L)!=5){
17237: erno(0);return L;
17238: }
17239: if(type(M)==7){ /* connect lists */
17240: if(M=="reverse"){
17241: for(LO=LR=[],F=0,LT=L; LT!=[]; LT=cdr(LT)){
17242: if(type(P=car(LT))==4 || type(P)==7){
17243: LR=cons(P,LR);
17244: continue;
17245: }else{
17246: if(P==-1){
17247: LL=reverse(LR);
17248: LO=append(reverse(cons(-1,cdr(LL))),LO);
17249: LO=cons(car(LL),LO);
17250: LR=[];
17251: }else if(P==1){
17252: LR=cons(car(LR),cons(1,cdr(LR)));
17253: }else if(P==0 || length(LT)==1){
17254: if(LO!=[] && car(LO)!=0 && (type(car(LO))==4 || car(LO)==1))
17255: LO=cons(0,LO);
17256: LO=append(LR,LO);
17257: if(length(LT)>1&&length(LO)>0&&car(LO)!=0) LO=cons(0,LO);
17258: LR=[];
17259: }
17260: }
17261: }
17262: return append(LR,LO);
17263: }
17264: if(type(L[0][0])!=4) L=[L];
17265: LO=[];
17266: if(M=="connect" || M=="close" || M=="loop"){
17267: Top=car(car(L));
17268: for(K=1,LL=L; LL!=[]; LL=cdr(LL)){
17269: for(F=0,LT=car(LL); LT!=[]; LT=cdr(LT),F++){
17270: if((LTT=car(LT))==0) LTT=1;
17271: if(F==0 && LO!=[]){
17272: LO0=car(LO);
17273: if(car(LO)!=1&&length(LO)>1) LO=cons(1,LO);
17274: if(LTT==LO0) continue;
17275: else LO=cons(1,cons(LTT, LO));
17276: }else LO=cons(LTT, LO);
17277: }
17278: }
17279: if(M!="connect"){
17280: if(Top==car(LO) || car(LO)==1 || M=="loop")
17281: LO=cons(-1,cdr(LO));
17282: else
17283: LO=cons(-1,cons(1,LO));
17284: }
17285: return reverse(LO);
17286: }
17287: if(M=="union"){
17288: for(LL=reverse(L); LL!=[]; LL=cdr(LL)){
17289: if(LO!=[]) LO=cons(0,LO);
17290: LO=append(car(LL),LO);
17291: }
17292: L=LO;
17293: }
17294: return L;
17295: }
17296: if(type(Arg=getopt(deg))==1)
17297: Arg=@pi*Arg/180;
17298: else Arg=getopt(arg);
17299: if(type(Arg)==2) Arg=deval(Arg);
17300: if(type(Arg)==1)
17301: M=M*mat([dcos(Arg),-dsin(Arg)],[dsin(Arg),dcos(Arg)]);
17302: if(type(Sft=getopt(org))==4){
17303: Sft=ltov(Sft);
17304: Sft-=M*Sft;
17305: }else Sft=ltov([0,0]);
17306: if(type(V=getopt(shift))==4)
17307: Sft+=ltov(V);
17308: if(getopt(proc)==1){
17309: if(Sft!=0&<ov(Sft)!=[0,0]) Sft=[["shift",vtol(Sft)]];
17310: else Sft=[];
17311: for(LO=[],LT=L;LT!=[];LT=cdr(LT)){
17312: if(type(car(T=car(LT)))<2){
17313: if((P=car(T))==0){ /* exedraw 0 */
17314: 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]]];
17315: V=ptbbox(ptaffine(M,V|option_list=Sft));
17316: L1=cdr(cdr(cdr(T)));
17317: LO=cons(append([0,V[0],V[1]],L1),LO);
17318: continue;
17319: }else if(P==1){ /* exedraw 1 */
17320: L1=[];
17321: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
17322: D=car(TT);
17323: if(type(D[0][0])==4){
17324: for(L2=[],DT=D;DT!=[];DT=cdr(DT))
17325: L2=cons(ptaffine(M,car(DT)|option_list=Sft),L2);
17326: L1=cons(reverse(L2),L1);
17327: }else L1=cons(ptaffine(M,D|option_list=Sft),L1);
17328: }
17329: LO=cons(append([1,T[1]],reverse(L1)),LO);
17330: continue;
17331: }else if(P>=2 && P<=5){
17332: L1=ptaffine(M,cdr(cdr(T))|optilon_list=Sft);
17333: LO=cons(append([P,T[1]],L1),LO);
17334: continue;
17335: }
17336: }
17337: LO=cons(T,LO);
17338: }
17339: return reverse(LO);
17340: }
17341: F=0;
17342: if(type(L)==4){
17343: for(LT=L; LT!=[]; LT=cdr(LT)){
17344: if((T=type(car(LT)))==4||T==5){
17345: F=1; break;
17346: }
17347: }
17348: }
17349: if(F==0) return (Sft==0)?ptaffine(M,[L])[0]:ptaffine(M,[L]|shift=vtol(Sft))[0];
17350: for(LO=[],LT=L; LT!=[]; LT=cdr(LT)){
17351: if(((T=type(P=car(LT)))!=4 && T!=5)||type(P[0])>3) LO=cons(P,LO);
17352: else{
17353: if(T==4) P=ltov(P);
17354: V=M*P;
17355: if(Sft!=0) V+=Sft;
17356: if(T==4) V=vtol(V);
17357: LO=cons(V,LO);
17358: }
17359: }
17360: return reverse(LO);
17361: }
17362:
17363: def ptlattice(M,N,X,Y)
17364: {
17365: if(type(S=getopt(scale))!=1) S=1;
17366: if(type(Cond=getopt(cond))!=4) Cond=[];
17367: Line=getopt(line);
17368: if(Line==1 || Line==2) F=newmat(M,N);
17369: else Line=0;
17370: if(type(Org=getopt(org))==4) Org=ltov(Org);
17371: else Org=newvect(length(X));
17372: X=ltov(X); Y=ltov(Y);
17373: for(L=[],I=M-1;I>=0;I--){
17374: for(P0=P1=0,J=N-1;J>=0;J--){
17375: P=Org+I*X+J*Y;
17376: for(C=Cond; C!=[]; C=cdr(C))
17377: if(subst(car(C),x,P[0],y,P[1])<0) break;
17378: if(C!=[]) continue;
17379: if(Line) F[I][J]=1;
17380: else L=cons(vtol(S*P),L);
17381: }
17382: }
17383: if(Line==0) return L;
17384: for(I=M-1;I>=0;I--){
17385: for(T0=0,T1=J=N-1;J>=0;J--){
17386: if((K=F[I][J])!=0){
17387: if(T0==0) T0=J;
17388: else T1=J;
17389: }
17390: if(K==0 || T1==0){
17391: if(T1<T0){
17392: L=cons(vtol(S*(Org+I*X+T0*Y)), L);
17393: L=cons(vtol(S*(Org+I*X+T1*Y)), L);
17394: L=cons(0,L);
17395: }
17396: T0=0; T1=N-1;
17397: }
17398: }
17399: }
17400: for(J=N-1;J>=0;J--){
17401: for(T0=0,T1=I=M-1;I>=0;I--){
17402: if((K=F[I][J])!=0){
17403: if(T0==0) T0=I;
17404: else T1=I;
17405: }
17406: if(K==0 || T1==0){
17407: if(T1<T0){
17408: L=cons(vtol(S*(Org+T0*X+J*Y)), L);
17409: L=cons(vtol(S*(Org+T1*X+J*Y)), L);
17410: L=cons(0,L);
17411: }
17412: T0=0; T1=M-1;
17413: }
17414: }
17415: }
17416: return cdr(L);
17417: }
17418:
17419: def ptpolygon(N,R)
17420: {
17421: if(type(S=getopt(scale))!=1) S=1;
17422: if(type(Org=getopt(org))!=4) Org=[0,0];
17423: Pi=deval(@pi);
17424: if(type(Arg=getopt(deg))==1)
17425: Arg=Pi*Arg/180;
17426: else Arg=getopt(arg);
17427: if(type(Arg)==2) Arg=deval(Arg);
17428: if(type(Arg)!=1) Arg=0;
17429: Arg -= Pi*(1/2+1/N);
17430: D=Pi*2/N;
17431: for(L=[],I=N-1; I>=0; I--)
17432: L=cons([S*(Org[0]+R*dcos(Arg+I*D)),S*(Org[1]+R*dsin(Arg+I*D))],L);
17433: return L;
17434: }
17435:
17436: def ptwindow(L,X,Y)
17437: {
17438: if(type(S=getopt(scale))==1){
17439: X=[S*X[0],S*X[1]]; Y=[S*Y[0],S*Y[1]];
17440: }
17441: for(R=[],LT=L;LT!=[];LT=cdr(LT)){
17442: P=car(LT);
17443: if(P[0]<X[0] || P[0]>X[1] || P[1]<Y[0] || P[1]>Y[1])
17444: R=cons(0,R);
17445: else R=cons(P,R);
17446: }
17447: return reverse(R);
17448: }
17449:
17450: def lninbox(L,W)
17451: {
17452: if(L[0]==L[1]) return 0;
17453: R=newvect(2);C=newvect(2);
17454: for(J=0;J<2;J++){
17455: C[J]=L[1][J]-L[0][J];
17456: if(C[J]!=0){
17457: R[J]=[(W[J][0]-L[0][J])/C[J],(W[J][1]-L[0][J])/C[J]];
17458: if(R[J][0]>R[J][1]) R[J]=[R[J][1],R[J][0]];
17459: }
17460: }
17461: if(R[0]==0) R[0]=R[1];
17462: if(R[1]==0) R[1]=R[0];
17463: S0=(R[0][0]<R[1][0])?R[1][0]:R[0][0];
17464: S1=(R[0][1]<R[1][1])?R[0][1]:R[1][1];
17465: if(getopt(in)==1){
17466: if(S0<0) S0=0;
17467: if(S1>1) S1=1;
17468: }
17469: if(S0>S1) return 0;
17470: 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]];
17471: }
17472:
17473: def ptbbox(L)
17474: {
17475: J=length(L[0]);
17476: if((Box=getopt(box))==1){
17477: for(R=[],I=0;I<J;I++){
17478: P=car(LT=L)[I][0];Q=car(LT)[I][1];
17479: for(;LT!=[];LT=cdr(LT)){
17480: if((type(T=car(LT))==4 || type(T)==5) && length(T)==J){
17481: if(T[I][0]<P) P=T[I][0];
17482: if(T[I][1]>Q) Q=T[I][1];
17483: }
17484: }
17485: R=cons([P,Q],R);
17486: }
17487: }else if(type(Box)==4) return ptbbox([ptbbox(L),Box]|box=1);
17488: else{
17489: for(R=[],I=0;I<J;I++){
17490: P=Q=car(LT=L)[I];LT=cdr(LT);
17491: for(;LT!=[];LT=cdr(LT)){
17492: if((type(T=car(LT))==4||type(T)==5) && type(T[0])<2 && length(T)==J){
17493: if((V=T[I])<P) P=V;
17494: else if(V>Q) Q=V;
17495: }
17496: }
17497: R=cons([P,Q],R);
17498: }
17499: }
17500: return reverse(R);
17501: }
17502:
17503: def iscombox(S,T)
17504: {
17505: for(;S!=[];S=cdr(S),T=cdr(T))
17506: if(car(S)[0]>car(T)[1] || car(S)[1]<car(T)[0]) return 0;
17507: return 1;
17508: }
17509:
17510: def ptcopy(L,V)
17511: {
17512: if(type(V[0])!=4) V=[V];
17513: for(F=0,LL=[]; V!=[]; V=cdr(V)){
17514: if(F) LL=append(LL,[0]);
17515: F++;
17516: LL=append(LL,ptaffine(1,L|shift=car(V)));
17517: }
17518: }
17519:
1.58 takayama 17520: def regress(L)
17521: {
17522: E=deval(exp(0));
17523: for(S0=T0=0,S=L;S!=[];S=cdr(S)){
17524: S0+=car(S)[0]*E;T0+=car(S)[1]*E;
17525: }
17526: K=length(L);S0/=K;T0/=K;
17527: for(SS=TT=0,S=L;S!=[];S=cdr(S)){
17528: SS+=(car(S)[0]-S0)^2*E;TT+=(car(S)[1]-T0)^2*E;
17529: ST+=(car(S)[0]-S0)*(car(S)[1]-T0)*E;
17530: }
17531: if(!SS||!TT) return [];
17532: A=ST/SS;
17533: L=[A,A*S0-T0,ST/dsqrt(SS*TT),S0,dsqrt(SS/K),T0,dsqrt(TT/K)];
17534: if(isint(N=getopt(sint))){
17535: R=reverse(L);
17536: for(L=[];R!=[];R=cdr(R)) L=cons(sint(car(R),N|str=0),L);
17537: }
17538: return L;
17539: }
17540:
1.6 takayama 17541: def average(L)
17542: {
1.32 takayama 17543: if(getopt(opt)=="co"){
17544: S0=average(L[0]);V0=car(S0);
17545: S1=average(L[1]);V1=car(S1);
17546: L0=os_md.m2l(L[0]|flat=1);
17547: L1=os_md.m2l(L[1]|flat=1);
17548: for(S=0;L0!=[];L0=cdr(L0),L1=cdr(L1))
17549: S+=(car(L0)-V0)*(car(L1)-V1);
17550: S/=S0[1]*S1[1]*S0[2];
17551: S=[S,S0,S1];
17552: }else{
17553: L=os_md.m2l(L|flat=1);
17554: M0=M1=car(L);
17555: for(I=SS=0, LT=L; LT!=[]; LT=cdr(LT), I++){
17556: S+=(V=car(LT));
17557: SS+=V^2;
17558: if(V<M0) M0=V;
17559: else if(V>M1) M1=V;
17560: }
17561: SS=dsqrt(SS/I-S^2/I^2);
17562: S=[deval(S/I),SS,I,M0,M1];
1.6 takayama 17563: }
1.8 takayama 17564: if(isint(N=getopt(sint))) S=sint(S,N);
17565: return S;
1.6 takayama 17566: }
17567:
17568: def m2ll(M)
17569: {
17570: for(R=[],I=size(M)[0]-1; I>=0; I--)
17571: R=cons(vtol(M[I]),R);
17572: return R;
17573: }
17574:
17575: def madjust(M,W)
17576: {
17577: if(type(Null=getopt(null))<0) Null=0;
17578: if(type(M)==4 && type(M[0])==4){
17579: M=lv2m(M|null=Null);
17580: return m2ll(madjust(M,W|null=Null));
17581: }
17582: S=size(M);
17583: if(W<0){
17584: W=-W;
17585: T0=ceil(S[0]/W);
17586: T1=S[1]*W;
17587: N=newmat(T0,T1);
17588: for(I=0; I<T0; I++){
17589: for(K=0; K<W; K++){
17590: II=K*T0+I;
17591: for(J=0; J<S[1]; J++)
17592: N[I][S[1]*K+J]=(II<S[0])?M[II][J]:Null;
17593: }
17594: }
17595: }else{
17596: T1=W;
17597: T0=S[0]*(D=ceil(S[1]/T1));
17598: N=newmat(T0,T1);
17599: for(K=0; K<D; K++){
17600: for(J=0; J<W;J++){
17601: JJ=W*K+J;
17602: for(I=0; I<S[0]; I++)
17603: N[S[0]*K+I][J]=(JJ<S[1])?M[I][JJ]:Null;
17604: }
17605: }
17606: }
17607: return N;
17608: }
17609:
17610: def texcr(N)
17611: {
17612: if(!isint(N) || N<0 || N>127) return N;
17613: S=(iand(N,8))? "\\allowdisplaybreaks":"";
17614: if(iand(N,2)) S=S+"\\\\";
17615: if(iand(N,16)) S=S+"\\pause";
17616: if(iand(N,1)) S=S+"\n";
17617: if(iand(N,4)) S=S+"& ";
17618: else if(!iand(N,1)) S=S+" ";
17619: if(iand(N,64)) S=S+"=";
17620: if(iand(N,32)) S=","+S;
17621: return S;
17622: }
17623:
17624: def ltotex(L)
17625: {
17626: /* extern TeXLim; */
17627:
17628: if(type(L)==5)
17629: L = vtol(L);
17630: if(type(L) != 4)
17631: return my_tex_form(L);
17632: Opt=getopt(opt);
17633: Pre=getopt(pre);
17634: if(type(Var=getopt(var))<1) Var=0;
17635: Cr2="\n";
17636: if(type(Cr=getopt(cr))==4){
17637: Cr2=Cr[1];Cr=Cr[0];
17638: }
17639: if(isint(Cr)) Cr=texcr(Cr);
17640: if(type(Cr)!=7) Cr="\\\\\n & "; /* Cr=7 */
17641: if(type(Opt)==7) Opt=[Opt];
17642: if(type(Opt)!=4)
17643: Op = -1;
17644: else{
17645: Op=findin(Opt[0],["spt","GRS","Pfaff","Fuchs","vect","cr","text","spts","spts0",
17646: "dform","tab", "graph","coord"]);
17647: Opt=cdr(Opt);
17648: }
17649: if(Op==0){ /* spt */
17650: Out = str_tb("\\left\\{\n ",0);
17651: for(CC=0; L!=[]; L=cdr(L), CC++){
17652: if(CC>0) str_tb(",\\, ",Out);
17653: TP=car(L);
17654: if(Op!=0)
17655: str_tb(my_tex_form(TP),Out);
17656: else if(TP[0]==1)
17657: str_tb(my_tex_form(TP[1]),Out);
17658: else
17659: str_tb(["[", my_tex_form(TP[1]), "]_", rtotex(TP[0])],Out);
17660: }
17661: str_tb("%\n\\right\\}\n",Out);
17662: }else if(Op==1){ /* GRS */
17663: Out = string_to_tb("\\begin{Bmatrix}\n");
17664: if(type(Pre)==7) str_tb(Pre,Out);
17665: MC=length(M=ltov(L));
17666: for(ML=0, I=length(M); --I>=0; ){
17667: if(length(M[I]) > ML) ML=length(M[I]);
17668: }
17669: for(I=0; I<ML; I++){
17670: for(CC=J=0; J<MC; J++, CC++){
17671: if(length(M[J]) <= I){
17672: if(CC > 0) str_tb(" & ",Out);
17673: }else if(M[J][I][0] <= 1){
17674: if(M[J][I][0] == 0) str_tb(" & ",Out);
17675: else
17676: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
17677: }else
17678: str_tb([((!CC)?" [":" & ["), my_tex_form(M[J][I][1]), "]_",
17679: rtotex(M[J][I][0])], Out);
17680: }
17681: str_tb((I<ML-1)?"\\\\\n":"\n", Out);
17682: }
17683: str_tb("\\end{Bmatrix}",Out);
17684: }else if(Op==2){ /* Pfaff */
17685: V=monototex(Opt[0]);
17686: Out = string_to_tb("d"+V+"= \\Biggl(");
17687: Opt=cdr(Opt);
17688: II=length(Opt);
17689: for(I=0; I<II; I++){
17690: str_tb([(I>0)?" + ":" ",mtotex(L[I]),"\\frac{d",monototex(Opt[I]),"}{",
17691: my_tex_form(Opt[I]),(I==II-1)?"}\n":"}\n\\\\&\n"],Out);
17692: }
17693: str_tb(["\\Biggr)",V,"\n"],Out);
17694: }else if(Op==3){ /* Fuchs */
17695: Out = string_to_tb("\\frac{d");
17696: V=my_tex_form(Opt[0]);
17697: str_tb([V,"}{d",my_tex_form(Opt[1]),"}="] ,Out);
17698: Opt=cdr(Opt); Opt=cdr(Opt);
17699: II=length(Opt);
17700: for(I=0; I<II; I++){
17701: str_tb([(I>0)?" +":"\\Biggl(", " \\frac{",
17702: my_tex_form(L[I]),"}{", my_tex_form(Opt[I]),"}\n"],Out);
17703: }
17704: str_tb(["\\Biggr)",V,"\n"],Out);
17705: }else if(Op==4){ /* vect */
17706: Out=str_tb(mtotex(matc(L)|lim=0,var=Var),0);
17707: }else if(Op==5 || Op==6){ /* cr or text */
17708: Out = str_tb(0,0);
17709: if(type(Lim=getopt(lim))!=1) Lim=0;
17710: else if(Lim<30&&Lim>0) Lim=TeXLim;
17711: Str=getopt(str);
17712: if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1)
17713: Str=2;
17714: for(K=I=0; L!=[]; I++, L=cdr(L)){
17715: LT=car(L);
17716: if((!Lim||Op==6)&&I>0) str_tb((Op==5)?Cr:"\n",Out);
17717: if(Op==6){
17718: if(type(LT)==7){
17719: str_tb([LT," "],Out);
17720: I=-1;
17721: continue;
17722: }
17723: str_tb("$",Out);
17724: }
17725: KK=0;
17726: if(Str>0 && type(LT)==4 && Opt!=[])
17727: S=ltotex(LT|opt=car(Opt),lim=0,str=Str,cr=Cr2,var=Var);
17728: else if(type(LT)==6){
17729: if(Lim>0){
17730: S=mtotex(LT|var=Var,lim=0,len=1);
17731: KK=S[1];
17732: S=S[0];
17733: }else S=mtotex(LT|var=Var,lim=0);
17734: }else if(type(LT)==3 || type(LT)==2)
17735: S=fctrtos(LT|TeX=2,lim=0,var=Var);
17736: else S=my_tex_form(LT);
17737: if(Op!=6&&I>0&&Lim){
17738: if(Lim<0){
17739: if(I%(-Lim)==0)
17740: str_tb((Op==5)?Cr:"\n",Out);
17741: }else if((K+=(KK=(KK)?KK:texlen(S)))>Lim){
17742: str_tb((Op==5)?Cr:"\n",Out);
17743: K=KK;
17744: }
17745: }
17746: str_tb(S,Out);
17747: if(Op==6) str_tb("$",Out);
17748: }
17749: }else if(Op==7||Op==8){ /* spts, spts0 */
17750: if(type(Lim=getopt(lim))!=1 || (Lim<30 && Lim!=0))
17751: Lim=TeXLim;
17752: Str=getopt(str);
17753: Out = str_tb(0,0);
17754: for(K=0; L!=[]; L=cdr(L)){
17755: LT=car(L);
17756: KK=0;
17757: if(type(LT)==7 && Str==1) S=LT;
17758: else if(type(LT)==3 || type(LT)==2)
17759: S=fctrtos(LT|TeX=2,lim=0,var=Var);
17760: else if(type(LT)==6){
17761: if(Lim){
17762: S=mtotex(LT|var=Var,lim=0,len=1);
17763: KK=S[1];
17764: S=S[0];
17765: }else S=mtotex(LT|var=Var,lim=0);
17766: }else
17767: S=my_tex_form(LT);
17768: if(Lim!=0){
17769: if(!KK) KK=texlen(S);
17770: if(K>0 && K+KK>Lim){
17771: str_tb(Cr,Out);
17772: K=0;
17773: }
17774: }
17775: if(K>0){
17776: str_tb((Op==7)?"\\ ":" ",Out);
17777: if(type(LT)>3 && type(LT)<7) str_tb("%\n",Out);
17778: }
17779: str_tb(S,Out);
17780: K+=KK;
17781: if(OP==7) K++;
17782: }
17783: }else if(Op==9){ /* dform */
17784: Out=str_tb(0,0);
17785: for(I=0;L!=[];L=cdr(L),I++){
17786: for(J=0,LT=car(L); LT!=[]; LT=cdr(LT),J++){
17787: if(J==0){
17788: if((V=car(LT))==0) continue;
17789: if(I>0){
17790: if(type(V)==1){
17791: if(V<0){
17792: str_tb("-",Out);
17793: V=-V;
17794: }
17795: else str_tb("+",Out);
17796: if(V==1 && length(LT)>1) continue;
17797: str_tb(monototex(V),Out);
17798: continue;
17799: }
17800: else str_tb("+",Out);
17801: }
17802: }else if(J>0) str_tb((J>1)?"\\wedge d":"\\,d",Out);
17803: V=monototex(car(LT));
17804: if(V<"-" || V>=".") str_tb(V,Out);
17805: else str_tb(["(",V,")"],Out);
17806: }
17807: }
17808: }else if(Op==10 && type(L)==4 && type(car(L))==4){ /* tab */
17809: if(type(Null=getopt(null))<0) Null="";
17810: if(getopt(vert)==1){
17811: M=lv2m(L|null=Null);
17812: L=m2ll(mtranspose(M));
17813: }
17814: if(type(W=getopt(width))==1)
17815: L=madjust(L,W|null=Null);
17816: LV=ltov(L);
17817: S=length(LV);
17818: #if 1
17819: if(type(T=getopt(left))==4){
17820: T=str_times(T,S);
17821: for(L=[],I=0;I<S;I++){
17822: L=cons(cons(car(T),LV[I]),L);
17823: T=cdr(T);
17824: }
17825: LV=reverse(L);
17826: }
17827: if(type(T=getopt(right))==4){
17828: T=str_times(T,S);
17829: for(L=[],I=0;I<S;I++){
17830: L=cons(append(LV[I],[car(T)]),L);
17831: T=cdr(T);
17832: }
17833: LV=reverse(L);
17834: }
17835: for(I=CS=0; I<S; I++)
17836: if(length(LV[I])>CS) CS=length(LV[I]);
17837: if(type(T=getopt(top))==4){
17838: LV=cons(str_times(T,CS),vtol(LV));
17839: S++;
17840: }
17841: if(type(T=getopt(last))==4){
17842: LV=append(vtol(LV),[str_times(T,CS)]);
17843: S++;
17844: }
17845: #else
17846: for(I=CS=0; I<S; I++)
17847: if(length(LV[I])>CS) CS=length(LV[I]);
17848: #endif
17849: if(type(Title=getopt(title))!=7) Title="";
17850: if(type(Vline=getopt(vline))!=4) Vline=[0,CS];
17851: else Vline=subst(Vline,z,CS);
17852: for(VV=[],VT=Vline;VT!=[];VT=cdr(VT)){
17853: if(type(T=car(VT))==4 && T[1]>0){
17854: for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV);
17855: }else VV=cons(T,VV);
17856: }
17857: Vline=qsort(VV);
17858: Out=str_tb("\\begin{tabular}{",0);
17859: if(type(Al=getopt(align))==7 && str_len(Al)>1){
17860: str_tb(Al,Out);
17861: }else{
17862: if(type(Al)!=7 || str_len(Al)<1) Al="r";
17863: for(I=0;I<=CS;I++){
17864: if(I!=0) str_tb(Al,Out);
17865: while(Vline!=[] && car(Vline)==I){
17866: str_tb("|",Out);
17867: Vline=cdr(Vline);
17868: }
17869: }
17870: }
17871: str_tb("}",Out);
17872: if(Title!="")
17873: str_tb("\n\\multicolumn{"+rtostr(CS)+"}{c}{"+Title+"}\\\\",Out);
17874: if(type(Hline=getopt(hline))!=4) Hline=[0,S];
17875: else Hline=subst(Hline,z,S);
17876: for(VV=[],VT=Hline;VT!=[];VT=cdr(VT)){
17877: if(type(T=car(VT))==4 && T[1]>0){
1.14 takayama 17878: for(I=T[0];I<=S;I+=T[1]) VV=cons(I,VV);
1.6 takayama 17879: }else VV=cons(T,VV);
17880: }
17881: Hline=qsort(VV);
17882: while(Hline!=[] && car(Hline)==0){
17883: str_tb(" \\hline\n",Out);
17884: Hline=cdr(Hline);
17885: }
17886: /*
17887: if(type(getopt(left))==4) CS++;
17888: if(type(getopt(right))==4) CS++;
17889: if(type(T=getopt(top))==4){
17890: LV=cons(str_times(T,CS),vtol(LV));
17891: S++;
17892: }
17893: if(type(T=getopt(last))==4){
17894: LV=append(vtol(LV),[str_times(T,CS)]);
17895: S++;
17896: }
17897: if(type(T=getopt(left))==4){
17898: T=str_times(T,S);
17899: for(L=[],I=0;I<S;I++){
17900: L=cons(cons(car(T),LV[I]),L);
17901: T=cdr(T);
17902: }
17903: LV=reverse(L);
17904: }
17905: if(type(T=getopt(right))==4){
17906: T=str_times(T,S);
17907: for(L=[],I=0;I<S;I++){
17908: L=cons(append(LV[I],[car(T)]),L);
17909: T=cdr(T);
17910: }
17911: LV=reverse(L);
17912: }
17913: */
17914: for(I=0; I<S; I++){
17915: for(C=0,LT=LV[I];C<CS; C++){
17916: if(LT!=[]){
17917: P=car(LT);
17918: if(type(P)!=7) P="$"+my_tex_form(P)+"$";
17919: if(P!="") str_tb(P,Out);
17920: LT=cdr(LT);
17921: }
17922: if(C<CS-1) str_tb("& ",Out);
17923: }
17924: str_tb("\\\\",Out);
17925: while(Hline!=[] && car(Hline)==I+1){
17926: str_tb(" \\hline",Out);
17927: Hline=cdr(Hline);
17928: }
17929: str_tb("\n",Out);
17930: }
17931: str_tb("\\end{tabular}\n",Out);
17932: }else if(Op==11){ /* graph */
1.10 takayama 17933: if(type(Strip=getopt(strip))!=1) Strip=0;
17934: if(type(MX=getopt(max))!=1) MX=0;
17935: if(type(ML=getopt(mult))!=1) ML=0;
17936: if((REL=getopt(relative))!=1) REL=0;
17937: CL=getopt(color);
17938: OL=delopt(getopt(),["color","strip","mult"]);
17939: if(ML==1&&type(CL)==4){
17940: LL=L[1];L=L[0];K=length(L);S=T="";
17941: if(!MX){
17942: MX=vector(length(L[0]));
17943: for(LT=L;LT!=[];LT=cdr(LT)){
17944: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
17945: if(REL==1) MX[I]+=car(LTT);
17946: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
17947: }
17948: }
17949: MX=lmax(MX);
17950: OL=cons(["max",MX],OL);
17951: }
17952: if(REL==1) MX=newvect(length(L[0]));
17953: for(I=0;I<K;I++){
17954: for(R=[],J=length(L[I]);--J>=0;){
17955: if(REL==1){
17956: R=cons([MX[J],V=MX[J]+L[I][J]],R);
17957: MX[J]=V;
17958: }else R=cons([(!I)?0:L[I-1][J],L[I][J]],R);
17959: }
17960: OP=cons(["color",CL[I]],OL);
17961: S+=ltotex([R,LL]|option_list=cons(["value",0],cons(["strip",(!I)?1:2],OP)));
17962: T+=ltotex([R,LL]|option_list=cons(["strip",3],OP));
17963: }
17964: return(!Strip)?xyproc(S+T):(S+T);
17965: }else if(!TikZ) CL=0;
17966: if(type(Line=getopt(line))!=1){
17967: if(type(Line)==4){
17968: if(type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
17969: Opt=Line[1]; Line=Line[0];
17970: }else if(ML==1){
17971: OL=delopt(OL,"line");
17972: LL=L[1];L=L[0];K=length(L);S="";
17973: if(!MX){
1.15 takayama 17974: MX=newvect(length(L[0]));
1.10 takayama 17975: for(LT=L;LT!=[];LT=cdr(LT)){
17976: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
17977: if(REL==1) MX[I]+=car(LTT);
17978: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
17979: }
17980: }
17981: MX=lmax(MX);
17982: OL=cons(["max",MX],OL);
17983: }
1.15 takayama 17984: for(I=0;I<K;I++)
17985: S+=ltotex([L[I],LL]|option_list
1.10 takayama 17986: =cons(["line",Line[I]],cons(["strip",(!I)?1:2],OL)));
17987: return(!Strip)?xyproc(S):S;
17988: }
17989: }else Line=0;
17990: }else Opt="@{-}";
17991: Width=8; Hight=3; WRet=1/2; HMerg=(getopt(horiz)==1)?0.3:0.2;
1.6 takayama 17992: if(!TikZ){
1.7 takayama 17993: Width*=10; Hight*=10; HMerg*=10;
1.6 takayama 17994: }
1.10 takayama 17995: VMerg=HMerg;
17996: if(type(Shift=getopt(shift))!=1)
17997: Shift=0;
1.6 takayama 17998: if(type(V=getopt(size))==4){
17999: Width=V[0];Hight=V[1];
18000: if(length(V)>2) WRet=V[2];
1.10 takayama 18001: if(length(V)>3) VMerg=VMerg=V[3];
18002: if(length(V)>4) HMerg=V[4];
1.6 takayama 18003: }
18004: Val=getopt(value);
18005: if(!isint(Val)) Val=-1;
18006: if(type(Line=getopt(line))!=1){
18007: if(type(Line)==4 && type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
18008: Opt=Line[1]; Line=Line[0];
18009: }else Line=0;
18010: }else Opt="@{-}";
18011: if(type(car(L))==4){
18012: LL=L[1]; L=L[0];
18013: }else LL=[];
18014: if(Line==-1){
18015: for(Sum=0, LT=L; LT!=[]; LT=cdr(LT)){
18016: if((S=car(LT))<=0) return 0;
18017: Sum+=S;
18018: }
1.16 takayama 18019: for(R=[],LT=L;LT!=[];LT=cdr(LT)) R=cons(car(LT)/Sum,R);
1.6 takayama 18020: R=reverse(R);
18021: Opt0=Opt*2/3;
1.10 takayama 18022: Out=str_tb((Strip>0)?0:xyproc(1),0);
1.16 takayama 18023: if(type(CL)!=4) str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out);
1.6 takayama 18024: for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){
1.16 takayama 18025: SS=S+RT[0];
18026: if(type(CL)==4){
18027: str_tb(xyang(Opt,[0,0],(0.25-SS)*6.2832,(0.25-S)*6.2832|ar=1,opt=car(CL)),Out);
18028: if(length(CL)>0) CL=cdr(CL);
18029: }else str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out);
18030: T=(S+SS)/2;
18031: S=SS;
1.6 takayama 18032: if(LT!=[]){
1.16 takayama 18033: str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),car(LT)]),Out);
1.6 takayama 18034: LT=cdr(LT);
18035: }
18036: }
1.10 takayama 18037: if(!Strip) str_tb(xyproc(0),Out);
1.6 takayama 18038: return str_tb(0,Out);
18039: }
18040: if(MX==0){
18041: for(MX=0,LT=L; LT!=[]; LT=cdr(LT))
18042: if(car(LT)>MX) MX=car(LT);
18043: }
18044: MX-=Shift;
18045: S=length(L);
18046: WStep=Width/S;
18047: WWStep=WStep*WRet;
1.10 takayama 18048: HStep=(Hight<0)?-Hight:Hight/MX;
1.7 takayama 18049: if(LL!=[]&&length(LL)==S-1) WS2=WStep/2;
18050: else WS2=0;
1.10 takayama 18051: Out=str_tb((Strip>0)?0:xyproc(1),0);
18052: Hori=getopt(horiz);
18053: if(Strip<2){
18054: if(Hori==1) str_tb(xyline([0,0],[0,Width-WStep+WWStep]),Out);
18055: else str_tb(xyline([0,0],[Width-WStep+WWStep,0]),Out);
18056: }
1.6 takayama 18057: for(I=0,LT=L;LT!=[]; LT=cdr(LT),I++){
1.10 takayama 18058: XP=WStep*I; XPM=XP+WWStep/2;
18059: if(type(LTT=car(LT))==4){
18060: YP0=(car(LTT)-Shift)*HStep;YP=(LTT[1]-Shift)*HStep;
18061: VL=LTT[1];
18062: if(REL) VL-=LTT[0];
18063: }else{
18064: YP0=0;YP=(LTT-Shift)*HStep;VL=LTT;
18065: }
18066: if(Hori==1){
18067: if(Line!=0){
18068: if(I>0)
18069: str_tb(xyarrow([XPM,YP],[XPM-WStep,YPP]|opt=Opt),Out);
18070: if(Val!=0)
18071: str_tb(xyput([YP+HMerg, XPM,car(LT)]),Out);
18072: if(Line==2)
18073: str_tb(xyput([YP,XPM,"$\\bullet$"]),Out);
18074: YPP=YP;
18075: }else if(YP!=0 || Val==1){
18076: if(Strip!=3){
18077: if(CL) str_tb(xybox([[YP,XP+WWStep], [YP0,XP]]|color=CL),Out);
18078: else str_tb(xybox([[YP,XP+WWStep],[YP0,XP]]),Out);
18079: }
18080: if(Val!=0) str_tb(xyput([(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),XPM,VL]),Out);
18081: }
18082: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([-VMerg,XPM+WS2,LL[I]]),Out);
18083: }else{
18084: if(Line!=0){
18085: if(I>0)
18086: str_tb(xyarrow([XPM-WStep,YPP],[XPM,YP]|opt=Opt),Out);
18087: if(Val!=0)
18088: str_tb(xyput([XPM,YP+HMerg,car(LT)]),Out);
18089: if(Line==2)
18090: str_tb(xyput([XPM,YP,"$\\bullet$"]),Out);
18091: YPP=YP;
18092: }else if(YP!=0 || Val==1){
18093: if(Strip!=3){
18094: if(CL) str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]|color=CL),Out);
18095: else str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]),Out);
18096: }
18097: if(Val!=0) str_tb(xyput([XPM,(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),VL]),Out);
1.6 takayama 18098: }
1.10 takayama 18099: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([XPM+WS2,-VMerg,LL[I]]),Out);
1.6 takayama 18100: }
18101: }
1.10 takayama 18102: if(!Strip)str_tb(xyproc(0),Out);
1.6 takayama 18103: }else if(Op==12){ /* coord */
18104: Out=str_tb("(",0);
18105: for(LT=L;;){
18106: X=car(LT);
18107: if(type(X)>3 || imag(X)==0) str_tb(my_tex_form(X),Out);
18108: else{
18109: XR=real(X);XI=imag(X);
18110: S=monototex(imag(X));
18111: if(S=="1") S="";
18112: else if(S=="- 1") S="-";
18113: if(getopt(cpx)==2) S=S+"\\sqrt{-1}";
18114: else S=S+"i";
18115: if(XR!=0){
18116: if(str_char(S,0,"-")==0) S=monototex(XR)+S;
18117: else S=monototex(XR)+"+"+S;
18118: }
18119: str_tb(S,Out);
18120: }
18121: if((LT=cdr(LT))==[]) break;
18122: else str_tb(",",Out);
18123: }
18124: str_tb(")",Out);
18125: }
18126: else return my_tex_form(L);
18127: S = str_tb(0,Out);
18128: return (getopt(small)==1)?smallmattex(S):S;
18129: }
18130:
18131:
18132: def str_tb(L,TB)
18133: {
18134: if(type(TB) == 0) TB = "";
18135: if(L == 0)
18136: return (type(TB) == 7)?string_to_tb(TB):tb_to_string(TB);
18137: if(type(L) == 7)
18138: L = [L];
18139: else if(type(L) != 4){
18140: erno(0);
18141: return 0;
18142: }
18143: if(type(TB) <= 7)
18144: TB = string_to_tb((type(TB)==7)?TB:"");
18145: for(; L != []; L = cdr(L))
18146: write_to_tb(car(L), TB);
18147: return TB;
18148: }
18149:
18150: /*
18151: def redgrs(M,T)
18152: {
18153: L = [zzz];
18154: for(I=S=0,Eq=[],MT=M; MT!=[]; I++, MT=cdr(MT)){
18155: for(J=LS=0, N=car(MT); N!=[]; N=cdr(N)){
18156: X = makev([z,I,z,J]);
18157: L=cons(X,L);
18158: LS += X;
18159: S += car(N)[1]*X;
18160: }
18161: Eq = cons(LS-zzz,Eq);
18162: }
18163: Eq = cons(S-T,Eq);
18164: Sol= lnsol(Eq,L);
18165: for(LS=[],S=Sol; S!=[]; S=cdr(S)){
18166: T=car(S);
18167: if(type(S)!=4) return 0;
18168: LS=cons(car(S)[0],LS);
18169: }
18170: }
18171: */
18172:
18173: /* T=0 : all reduction
18174: =1 : construction procedure
18175: =2 : connection coefficient
18176: =3 : operator
18177: =4 : series expansion
18178: =5 : expression by TeX
18179: =6 : Fuchs relation
18180: =7 : All
18181: =8 : basic
18182: =9 : ""
18183: =10: irreducible
18184: =11: recurrence */
18185: def getbygrs(M, TT)
18186: {
18187: /* extern TeXEq; */
18188:
18189: if(type(M)==7) M=s2sp(M);
18190: if(type(M) != 4 || TT =="help"){
18191: mycat(
18192: ["getbygrs(m,t) or getbygrs(m,[t,s_1,s_2,...]|perm=?,var=?,pt=?,mat=?)\n",
18193: " m: generalized Riemann scheme or spectral type\n",
18194: " t: reduction, construct, connection, series, operator, TeX, Fuchs, irreducible, basic, recurrence,\n",
18195: " All\n",
18196: " s: TeX dviout simplify short general operator irreducible top0 x1 x2 sft\n",
18197: "Ex: getbygrs(\"111,21,111\", [\"All\",\"dviout\",\"operator\",\"top0\"])\n"]);
18198: return 0;
18199: }
18200: if(type(TT) == 4){
18201: T = TT[0];
18202: T1 = cdr(TT);
18203: }else{
18204: T = TT;
18205: T1 = [];
18206: }
18207: if(type(T) == 7)
18208: T = findin(T,["reduction","construct","connection", "operator", "series",
18209: "TeX", "Fuchs", "All", "basic", "", "irreducible", "recurrence"]);
18210: TeX = findin("TeX", T1);
18211: Simp = findin("simplify", T1);
18212: Short = findin("short", T1);
18213: Dviout= findin("dviout", T1);
18214: General=findin("general", T1);
18215: Op =findin("operator", T1);
18216: Irr =findin("irreducible", T1);
18217: Top0 =findin("top0",T1);
18218: X1 =findin("x1",T1);
18219: X2 =findin("x2",T1);
18220: Sft =findin("sft",T1);
18221: Title = getopt(title);
18222: Mat = getopt(mat);
18223: if(Mat!=1 || T<0 ||(T!=0&&T!=1&&T!=5&&T!=6&&T!=8&&T!=10&&T!=9)) Mat = 0;
18224: if(findin("keep",T1) >= 0)
18225: Keep = Dviout = 1;
18226: else Keep = 0;
18227: if(Dviout >= 0 || T == 5) TeX = 1;
18228: for(J = 0, MM = M; J == 0 && MM != []; MM = cdr(MM)){
18229: for(MI = car(MM); MI != []; MI = cdr(MI)){
18230: if(type(car(MI)) != 1 || car(MI) <= 0){
18231: J = 1; break;
18232: }
18233: }
18234: }
18235:
18236: /* spectral type -> GRS */
18237: if(J == 0){
18238: for(R = [], S = J = 0, MM = M; MM != []; MM = cdr(MM), J++){
18239: MT = qsort(car(MM));
18240: R = cons(reverse(MT), R);
18241: if(J == 1){
18242: S = length(MT)-1;
18243: if(MT[S] > MT[0]) S = 0;
18244: }
18245: }
18246: M = reverse(R);
18247: R = getopt(var);
18248: if(type(R)<1){
18249: for(R = [], I = J-1; I >= 0; I--)
18250: R = cons(asciitostr([97+I]), R);
18251: }
18252: Sft=(Sft>=0)?1:0;
18253: if(General < 0)
18254: Sft=-Sft-1;
18255: M = sp2grs(M,R,Sft|mat=Mat);
18256: }
18257: for(M0=[],MM=M;MM!=[];MM=cdr(MM)){ /* change "?" -> z_z */
18258: for(M1=[],Mm=car(MM);Mm!=[];Mm=cdr(Mm)){
18259: Mt=car(Mm);
18260: if(type(Mt)==4 && Mt[1]=="?"){
18261: M1=cons([Mt[0],z_z],M1);
18262: continue;
18263: }else if(type(Mt)==7 && Mt=="?"){
18264: M1=cons(z_z,M1);
18265: continue;
18266: }
18267: M1=cons(Mt,M1);
18268: }
18269: M0=cons(reverse(M1),M0);
18270: }
18271: M = fspt(reverse(M0),5); /* short -> long */
18272: if(findin(z_z,vars(M))>=0)
18273: M=subst(M,z_z,lsol(chkspt(M|mat=Mat)[3],z_z)); /* Fuchs relation */
18274: NP = length(M);
18275: Perm = getopt(perm);
18276: if(type(Perm) == 4)
18277: M = mperm(M,Perm,0);
18278: if(T == 9){ /* "" */
18279: if(Short >= 0)
18280: M = chkspt(M|opt=4,mat=Mat);
18281: return M;
18282: }
18283: R = [0,M];
18284: ALL = [R];
18285:
18286: while(type(R = redgrs(R[1]|mat=Mat)) == 4)
18287: ALL = cons(R, ALL);
18288: if(R < 0)
18289: return 0;
18290:
18291: /* TeX */
18292: if(TeX >= 0 && !chkfun("print_tex_form", "names.rr"))
18293: return 0;
18294: if(Dviout >= 0 && type(Title) == 7)
18295: dviout(Title|keep=1);
18296: if(T == 7 && Dviout >= 0){
18297: S=["keep","simplify"];
18298: if(Top0 >= 0)
18299: S = cons("top0",S);
18300: getbygrs(M,cons(5,S)|title="\\noindent Riemann Scheme",mat=Mat);
18301: Same = 0;
18302: if(R > 0){
18303: MM = getbygrs(M,8|mat=Mat); /* basic GRS */
18304: MS = chkspt(MM|opt=0,mat=Mat); /* spectral type */
18305: if(M != MM)
18306: getbygrs(MM,cons(5,S)|title="Basic Riemann Scheme",mat=Mat);
18307: else{
18308: dviout("This is a basic Riemann Scheme.\n\n\\noindent"|keep=1);
18309: Same = 1;
18310: }
18311: dviout(MS|keep=1);
18312: }
18313: if(chkspt(ALL[0][1]|mat=Mat)[3] != 0)
18314: getbygrs(M,cons(6,S)|title="Fuchs condition",mat=Mat);
18315: if(Same == 0){
18316: M1 = M[1];
18317: if(M1[length(M1)-1][0]==1 && Mat!=1){
18318: M1=M[2];
18319: if(M1[length(M1)-1][0] == 1){
18320: getbygrs(M,cons(2,S)|title="Connection formula");
18321: if(M1[length(M[0][0])-1][0] == 1 && R==0)
18322: getbygrs(M,cons(11,S)|title="Recurrence relation shifting the last exponents at $\\infty$, 0, 1");
18323: }
18324: getbygrs(M,cons(1,S)|title="Integral representation");
18325: getbygrs(M,cons(4,S)|title="Series expansion");
18326: }
18327: if(Irr < 0){
18328: TI="Irreduciblity $\\Leftrightarrow$ any value of the following linear forms $\\notin\\mathbb Z$";
18329: if(R > 0)
18330: TI += " + fundamental irreducibility";
18331: getbygrs(M,cons(10,S)|title=TI,mat=Mat);
18332: dviout("which coorespond to the decompositions"|keep=1);
18333: sproot(chkspt(M|opt=0),"pairs"|dviout=1,keep=1);
18334: }
18335: }
18336: if(Op >= 0 && Mat!=1) getbygrs(M,cons(3,S)|title="Operator");
18337: dviout(" ");
18338: return 1;
18339: }
18340: if(T == 0 && TeX >= 0){
18341: T = 1; TeX = 16;
18342: }
18343: /* Fuchs */
18344: Fuc = chkspt(ALL[0][1]|Mat=mat)[3];
18345: if(Fuc == 0) Simp = -1;
18346: if(type(Fuc) == 1){
18347: print("Violate Fuchs condition");
18348: return 0;
18349: }
18350: if(T == 6){
18351: if(Dviout >= 0) dviout(Fuc|eq=0,keep=Keep);
18352: return (TeX >= 0)?my_tex_form(Fuc):Fuc;
18353: }
18354: Fuc = [Fuc];
18355: /* Generelized Riemann scheme */
18356: if(T == 5){
18357: M = ltov(M);
18358: for(ML=0, I=0; I<NP; I++){
18359: L = length(M[I]);
18360: if(L > ML) ML = L;
18361: }
18362: Out = string_to_tb("P\\begin{Bmatrix}\nx=");
18363: if(Top0 < 0)
18364: write_to_tb("\\infty & ",Out);
18365: Pt = getopt(pt);
18366: if(type(Pt) == 4){
18367: for(J = 3; J < NP; J++){
18368: str_tb(["& ",rtotex(car(Pt))],Out);
18369: Pt = cdr(Pt);
18370: }
18371: }
18372: else if(X2>=0)
18373: str_tb("0 & x_2",Out);
18374: else
18375: str_tb((X1>=0)?"x_1 & x_2":"0 & 1",Out);
18376: for(J = 3; J < NP; J++)
18377: str_tb(["& x_",rtotex(J)],Out);
18378: if(Top0 >= 0)
18379: write_to_tb("& \\infty",Out);
18380: write_to_tb("\\\\\n",Out);
18381: for(I = 0; I < ML; I++){
18382: for(CC = 0, J = (Top0 >= 0)?1:0; ; J++, CC++){
18383: if(J == NP){
18384: if(Top0 < 0) break;
18385: J = 0;
18386: }
18387: if(length(M[J]) <= I){
18388: if(CC > 0) write_to_tb(" & ",Out);
18389: }else if(M[J][I][0] <= 1){
18390: if(M[J][I][0] == 0) str_tb(" & ",Out);
18391: else
18392: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
18393: }else{
18394: str_tb([((!CC)?"[":" & ["), my_tex_form(M[J][I][1]),
18395: (Mat==1)?"]_{":"]_{("],Out);
18396: str_tb([my_tex_form(M[J][I][0]),(Mat==1)?"}":")}"],Out);
18397: }
18398: if(Top0 >= 0 && J == 0)
18399: break;
18400: }
18401: if(I == 0)
18402: str_tb("&\\!\\!;x",Out);
18403: str_tb("\\\\\n",Out);
18404: }
18405: str_tb("\\end{Bmatrix}",Out);
18406: Out = str_tb(0,Out);
18407: if(Dviout >= 0)
18408: dviout(Out|eq=0,keep=Keep);
18409: return Out;
18410: }
18411:
18412: /* Reduction */
18413: if(T == 0){
18414: if(Simp >= 0)
18415: ALL = simplify(ALL,Fuc,4);
18416: return reverse(ALL);
18417: }
18418: LA = length(ALL) - 1;
18419: NP = length(ALL[0][1]);
18420:
18421: /* irreducible */
18422: if(T == 10){
18423: for(IR=[], I = 0; I < LA; I++){
18424: AI = ALL[I]; AIT = AI[1];
18425: K = AI[0][0];
18426: P = -AIT[0][K][1];
18427: P -= cterm(P);
18428: IR = cons(P, IR);
18429: for(J = 0; J < NP; J++){
18430: K = AI[0][J];
18431: for(L = length(AIT[J]) - 1; L >= 0 ; L--){
18432: if(L == K || AIT[J][L][0] <= AIT[J][K][0])
18433: continue;
18434: P = AIT[J][L][1] - AIT[J][K][1];
18435: Q = cterm(P);
18436: if(dn(Q)==1)
18437: P -= Q;
18438: IR = cons(P,IR);
18439: }
18440: }
18441: }
18442: P=Fuc[0];
18443: Q=cterm(P);
18444: if(type(Q)==1 && dn(Q)==1){
18445: for(F=0,V=vars(P);V!=[];V=cdr(V)){
18446: R=mycoef(P,1,car(V));
18447: if(type(R)!=1 || Q%R!=0){
18448: F=1; break;
18449: }
18450: }
18451: if(F==0){
18452: P-=Q;
18453: Simp=0;
18454: }
18455: }
18456: if(Simp >= 0){
18457: IR=simplify(IR,[P],4);
18458: for(R=[]; IR!=[]; IR=cdr(IR)){
18459: P=car(IR);
18460: Q=cterm(P);
18461: if(dn(Q)==1) P-=Q;
18462: R=cons(P,R);
18463: }
18464: IR=R;
18465: }
18466: for(R=[]; IR!=[]; IR=cdr(IR)){
18467: P=car(IR);
18468: if(str_len(rtostr(P)) > str_len(rtostr(-P)))
18469: P = -P;
18470: R = cons(P,R);
18471: }
18472: R = ltov(R);
18473: #ifdef USEMODULE
18474: R = qsort(R,os_md.cmpsimple);
18475: #else
18476: R = qsort(R,cmpsimple);
18477: #endif
18478: R = vtol(R);
18479: if(TeX >= 0){
18480: Out = string_to_tb("");
18481: for(I=L=K=0; R!=[]; R=cdr(R),I++){
18482: K1 = K;
18483: RS = my_tex_form(car(R));
18484: K = nmono(car(R));
18485: L += K;
18486: if(I){
18487: if(K1 == K && L < 30)
18488: str_tb("\\quad ",Out);
18489: else{
18490: L = K;
18491: str_tb((TeXEq==5)?["\\\\%\n &"]:["\\\\%\n "],Out);
18492: }
18493: }
18494: str_tb(RS,Out);
18495: }
18496: R = Out;
18497: if(Dviout>=0){
18498: dviout(R|eq=0,keep=Keep);
18499: return 1;
18500: }
18501: }
18502: return R;
18503: }
18504:
18505: AL = []; SS = 0;
18506: for(I = 0; I <= LA; I++){
18507: AI = ALL[I]; AIT = AI[1]; /* AIT: GRS */
18508: if(I > 0){
18509: for(S = J = 0; J < NP; J++){
18510: GE = AIT[J][AI0[J]][1];
18511: S += GE;
18512: if(J == 0)
18513: SS = [];
18514: else
18515: SS = cons(GE,SS);
18516: }
18517: SS = cons(1-Mat-S, reverse(SS));
18518: }
18519: AI0 = AI[0];
18520: AL = cons([SS, cutgrs(AIT)], AL);
18521: }
18522: AL = reverse(AL);
18523: AD = newvect(NP);
18524: ALT = AL[0][1];
18525: for(J = 1; J < NP; J++){
18526: /* AD[J] = ALT[J][0][1]; [J][?][1] <- [J][?][0]: max */
18527: for(MMX=0, K = KM = length(ALT[J])-1; K >= 0; K--){
18528: if(MMX <= ALT[J][K][0]){
18529: if(J == 1 && MMX == ALT[J][K][0])
18530: continue;
18531: KM = K;
18532: MMX = ALT[J][K][0];
18533: }
18534: }
18535: AD[J] = ALT[J][KM][1];
18536: }
18537: AL = cdr(AL);
18538: AL = cons([vtol(AD), ALT], AL);
18539: AL = cons([0, mcgrs(ALT, [vtol(-AD)]|mat=Mat)], AL);
18540: if(Simp >= 0 && T != 3)
18541: AL = simplify(AL,Fuc,4);
18542: /* Basic */
18543: if(T == 8){
18544: ALT = AL[0][1];
18545: if(TeX >= 0){
18546: if(Dviout >= 0){
18547: return getbygrs(ALT,["TeX","dviout","keep"]);
18548: }
18549: return getbygrs(ALT,"TeX");
18550: }
18551: if(Short >= 0)
18552: ALT = chkspt(ALT|opt=4);
18553: return ALT;
18554: }
18555:
18556: /* Construct */
18557: if(T == 1){
18558: if(TeX >= 0){
18559: L = length(AL);
18560: I = Done = 0; Out0=Out1=""; NM = DN = [];
18561: if(TeX != 16){
18562: AL11=AL[L-1][1][1];
18563: AT = AL11[length(AL11)-1];
18564: if(type(AT) == 4){
18565: PW = (AT[0] > 1)?"":AT[1];
18566: }else PW = AT;
18567: }
18568: Out = string_to_tb("");
18569: while(--L >= 0){
18570: if(TeX == 16){
18571: if(Done)
18572: write_to_tb(":\\ ", Out);
18573: write_to_tb(getbygrs(AL[L][1],(Top0>=0)?["TeX", "top0"]:"TeX"|mat=Mat), Out);
18574: Done = 1;
18575: if(L != 0) write_to_tb((TeXEq==5)?
18576: "\\\\%\n&\\leftarrow ":"\\\\%\n\\leftarrow ", Out);
18577: }
18578: ALT = AL[L][0];
18579: if(TeX != 16){
18580: V1 = (I==0)?"x":V2;
18581: V2 = /* (I==0 && L<=2)?"s": */
18582: "s_"+rtotex(I);
18583: }else V1=V2="x";
18584: JJ = (type(ALT) == 4)?length(ALT):0;
18585: if(I > 0 && L > 0)
18586: write_to_tb("\n ", Out);
18587: for(Outt = "", J = 1; J < JJ; J++){
18588: if(ALT[J] == 0) continue;
18589: if(J == 1) Outt += V1;
18590: else if(J == 2) Outt += "(1-"+V1+")";
18591: else Outt += "(x_"+rtotex(J)+"-"+V1+")";
18592: Outt += "^"+ rtotex(ALT[J]);
18593: }
18594: if(TeX != 16) write_to_tb(Outt, Out);
18595: else if(Outt != "")
18596: str_tb(["\\mathrm{Ad}\\Bigl(",Outt,"\\Bigr)"], Out);
18597: if(JJ == 0){
18598: if(I != 0)
18599: Out1 = "ds_"+rtotex(I-1)+Out1;
18600: continue;
18601: }
18602: if(ALT[0] == 0) continue;
18603: Out0 += "\\int_p^{"+V1+"}";
18604: if(TeX == 16)
18605: str_tb(["mc_",rtotex(ALT[0])], Out);
18606: else{
18607: str_tb(["(",V1,"-",V2,")^",rtotex(-1+ALT[0])], Out);
18608: AL11=AL[L-1][1][1];
18609: AT = AL11[length(AL11)-1];
18610: if(type(AT) == 4) AT = AT[1];
18611: DN = cons(ALT[0]+AT+1,DN);
18612: NM = cons(AT+1,cons(ALT[0],NM));
18613: }
18614: if(L != 2) Out1 += "d"+V2;
18615: I++;
18616: }
18617: if(R){
18618: if(I == 0) Ov = "x";
18619: else Ov = "s_"+rtotex(I-1);
18620: Out1 = "u_B("+Ov+")"+Out1;
18621: }
18622: if(TeX != 16){
18623: Out0 = string_to_tb(Out0);
18624: str_tb([Out, Out1], Out0);
18625: Out = Out0;
18626: NM = simplify(NM, Fuc, 4);
18627: DN = simplify(DN, Fuc, 4);
18628: DNT = lsort(NM,DN,"reduce");
18629: NMT = DNT[0]; DNT = DNT[1];
18630: if(NMT != [] && PW != ""){
18631: write_to_tb((TeXEq==5)?"\\\\\n &\\sim\\frac{\n"
18632: :"\\\\\n \\sim\\frac{\n", Out);
18633: for(PT = NMT; PT != []; PT = cdr(PT))
18634: str_tb([" \\Gamma(",my_tex_form(car(PT)), ")\n"], Out);
18635: write_to_tb(" }{\n", Out);
18636: for(PT = DNT; PT != []; PT = cdr(PT))
18637: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
18638: write_to_tb(" }", Out);
18639: if(R > 0) write_to_tb("C_0", Out);
18640: write_to_tb("x^"+rtotex(PW) +"\\ \\ (p=0,\\ x\\to0)", Out);
18641: }
18642: }else
18643: Out = str_tb(0, Out);
18644: if(Dviout >= 0){
18645: dviout(Out|eq=0,keep=Keep);
18646: return 1;
18647: }
18648: return O;
18649: }
18650: if(Short >= 0){
18651: for(ALL = [] ; AL != []; AL = cdr(AL)){
18652: AT = car(AL);
18653: ALL = cons([AT[0], chkspt(AT[1]|opt=4)], ALL);
18654: }
18655: AL = reverse(ALL);
18656: }
18657: return AL; /* AL[0][1] : reduced GRS, R==0 -> rigid */
18658: }
18659:
18660: if(T == 2 || T == 4 || T == 11){
18661: for(I = (T==2)?2:1; I >= (T==11)?0:1; I--){
18662: ALT = M[I];
18663: if(ALT[length(ALT)-1][0] != 1){
18664: mycat(["multiplicity for",I,":",ALT[length(ALT)-1][1],
18665: "should be 1"]);
18666: return;
18667: }
18668: }
18669: }
18670: LA++;
18671: NM = DN = [];
18672:
18673: /* Three term relation */
18674: if(T == 11){
18675: if(R > 0){
18676: print("This is not rigid\n");
18677: return 0;
18678: }
18679: for(I = 0; I <= LA; I++){
18680: if(I > 0){
18681: AI = AL[I][0]; /* operation */
18682: if(AI[0] != 0){
18683: DN = cons(simplify(AI1+1,Fuc,4),DN);
18684: NM = cons(simplify(AI1+AI[0]+1,Fuc,4),NM);
18685: }
18686: }
18687: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
18688: }
18689: DNT = lsort(NM,DN,"reduce");
18690: if(TeX < 0) return DNT;
18691: NMT = DNT[0]; DNT = DNT[1];
18692: Out = str_tb("u_{0,0,0}-u_{+1,0,-1}=\\frac{","");
18693: for(PT = NMT; PT != []; PT = cdr(PT))
18694: str_tb(["(",my_tex_form(car(PT)),")"], Out);
18695: str_tb(["}\n{"],Out);
18696: for(PT = DNT; PT != []; PT = cdr(PT))
18697: str_tb(["(",my_tex_form(car(PT)),")"], Out);
18698: write_to_tb("}u_{0,+1,-1}",Out);
18699: if(Dviout >= 0){
18700: dviout(Out|eq=0,keep=Keep);
18701: return 1;
18702: }
18703: return Out;
18704: }
18705:
18706: AD=newvect(NP);
18707: for(I = 0; I <= LA; I++){
18708: if(I > 0){
18709: AI = AL[I][0]; /* operation */
18710: if(T == 2 && AI[0] != 0){
18711: DN = cons(simplify(-AI2,Fuc,4), cons(simplify(AI1+1,Fuc,4),DN));
18712: NM = cons(simplify(-AI2-AI[0],Fuc,4), cons(simplify(AI1+AI[0]+1,Fuc,4),
18713: NM));
18714: }
18715: for(J = 1; J < NP; J++)
18716: AD[J] += simplify(AI[J],Fuc,4);
18717: }
18718: if(T == 2){
18719: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
18720: ALT = AL[I][1][2]; AI2 = ALT[length(ALT)-1][1];
18721: if(I == 0){
18722: C3 = AI1; C4 = AI2;
18723: }
18724: }
18725: }
18726:
18727: /* Connection */
18728: if(T == 2){
18729: DNT = lsort(NM,DN,"reduce");
18730: NMT = DNT[0]; DNT = DNT[1];
18731: if(TeX < 0) return [NMT,DNT,AD];
18732: C0 = M[1][length(M[1])-1][1];
18733: C1 = M[2][length(M[2])-1][1];
18734: M = AL[0][1];
18735: C3 = M[1][length(M[1])-1][1];
18736: C4 = M[2][length(M[2])-1][1];
18737: Out = str_tb(["c(0\\!:\\!", my_tex_form(C0),
18738: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C1),")"], "");
18739: if(R > 0 && AMSTeX == 1 && (TeXEq == 4 || TeXEq == 5)){
18740: write_to_tb("\\\\\n", Out);
18741: if(TeXEq == 5) write_to_tb(" &", Out);
18742: }
18743: write_to_tb("=\\frac{\n",Out);
18744: for(PT = NMT; PT != []; PT = cdr(PT))
18745: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
18746: write_to_tb(" }{\n",Out);
18747: for(PT = DNT; PT != []; PT = cdr(PT))
18748: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n",Out);
18749: write_to_tb(" }", Out);
18750: for(J = 3; J < length(AD); J++){
18751: if(AD[J] == 0) continue;
18752: str_tb(["\n (1-x_", rtotex(J), "^{-1})^", rtotex(AD[J])], Out);
18753: }
18754: if(R != 0)
18755: str_tb(["\n c_B(0\\!:\\!", my_tex_form(C3),
18756: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C4), ")"], Out);
18757: Out = tb_to_string(Out);
18758: if(Dviout >= 0){
18759: dviout(Out|eq=0,keep=Keep);
18760: return 1;
18761: }
18762: return Out;
18763: }
18764:
18765: /* Series */
18766: if(T == 4){
18767: AL11 = AL[0][1][1];
18768: V = AL11[length(AL11)-1][1];
18769: S00 = -V; S01 = (R==0)?[]:[[0,0]];
18770: S1 = S2 = [];
18771: for(Ix = 1, ALL = cdr(AL); ALL != []; ){
18772: ALT = ALL[0][0];
18773: if(ALT[0] != 0){ /* mc */
18774: for(Sum = [], ST = S01; ST != []; ST = cdr(ST))
18775: Sum = cons(car(ST)[0], Sum);
18776: S1 = cons(cons(S00+1,Sum), S1);
18777: S2 = cons(cons(S00+1+ALT[0],Sum),S2);
18778: S00 += ALT[0];
18779: }
18780: ALL = cdr(ALL);
18781: for(I = 1; I < length(ALT); I++){ /* addition */
18782: if(I == 1){
18783: S00 += ALT[1];
18784: if(ALL == [])
18785: S00 = [S00];
18786: }else{
18787: if(ALT[I] == 0)
18788: continue;
18789: if(ALL != []){
18790: S1 = cons([-ALT[I],Ix],S1);
18791: S2 = cons([1,Ix],S2);
18792: S01= cons([Ix,I],S01);
18793: Ix++;
18794: }else
18795: S00 = cons([ALT[I],I],S00);
18796: }
18797: }
18798: }
18799: S00 = reverse(S00);
18800: S01 = qsort(S01); S1 = qsort(S1); S2 = qsort(S2);
18801: if(Simp >= 0){
18802: S00 = simplify(S00,Fuc,4);
18803: S01 = simplify(S01,Fuc,4);
18804: S1 = simplify(S1,Fuc,4);
18805: S2 = simplify(S2,Fuc,4);
18806: SS = lsort(S1,S2,"reduce");
18807: S1 = SS[0]; S2 = SS[1];
18808: }
18809:
18810: if(TeX >= 0){
18811: /* Top linear power */
18812: TOP = Ps = Sm = "";
18813: for(TOP = Ps = Sm = "", ST = cdr(S00); ST != []; ST = cdr(ST)){
18814: SP = car(ST);
18815: if(SP[0] != 0){
18816: if(SP[1] == 2)
18817: TOP += "(1-x)^"+rtotex(SP[0]);
18818: else
18819: TOP += "(1-x/x_"+rtotex(SP[1])+")^"+rtotex(SP[0]);
18820: }
18821: }
18822: /* Top power */
18823: PW = my_tex_form(car(S00));
18824: if(PW == "0")
18825: PW = "";
18826: NP = length(AL[0][1]);
18827: PWS = newvect(NP);
18828: for(I = 0; I < NP; I++)
18829: PWS[I] = "";
18830: for(S = S01, I = 0; S != []; S = cdr(S), I++){
18831: SI = rtotex(car(S)[0]);
18832: if(I > 0) Sm += ",\\ ";
18833: Sm += "n_"+SI+"\\ge0";
18834: if(PW != "")
18835: PW += "+";
18836: PW += "n_"+SI;
18837: if(car(S)[1] > 2)
18838: PWS[car(S)[1]] += "-n_"+rtotex(car(S)[0]);
18839: else if(car(S)[1] == 0)
18840: Ps = "C_{n_0}"+Ps;
18841: }
18842: for(I = 3; I < NP; I++){
18843: if(PWS[I] != "")
18844: Ps += "x_"+rtotex(I)+"^{"+PWS[I]+"}";
18845: }
18846: Out = str_tb([TOP, Ps, "x^{", PW, "}"], "");
18847: /* Gamma factor */
18848: for(I = 0, SS = S1; I <= 1; I++, SS = S2){
18849: PW = string_to_tb("");
18850: for(PW1=""; SS != [] ; SS = cdr(SS)){
18851: for(J = 0, SST = car(SS); SST != []; SST = cdr(SST), J++){
18852: if(J == 0){
18853: JJ = (car(SST) == 1)?((length(SST)==2)?(-1):0):1;
18854: if(JJ > 0)
18855: str_tb(["(", my_tex_form(car(SST)), ")_{"], PW);
18856: else if(JJ == 0)
18857: PW1 = "(";
18858: }else{
18859: if(JJ > 0){
18860: if(J > 1) write_to_tb("+", PW);
18861: str_tb(["n_", rtotex(car(SST))], PW);
18862: }else{
18863: if(J > 1) PW1 += "+";
18864: PW1 += "n_"+rtotex(car(SST));
18865: }
18866: }
18867: }
18868: if(JJ > 0) write_to_tb("}", PW);
18869: else PW1 += (JJ == 0)?")!":"!";
18870: }
18871: if(I == 0)
18872: Out0 = "\\frac";
18873: Out0 += "{"+tb_to_string(PW)+PW1+"}";
18874: PW = string_to_tb(""); PW1 = "";
18875: }
18876: if(Out0 == "\\frac{}{}")
18877: Out0 = "";
18878: Out = "\\sum_{"+Sm+"}"+Out0 + Top + tb_to_string(Out);
18879: if(length(S01) == 1){
18880: Out = str_subst(Out, "{n_"+SI+"}", "n");
18881: Out = str_subst(Out, "n_"+SI, "n");
18882: }
18883: if(Dviout >= 0)
18884: dviout(Out|eq=0,keep=Keep);
18885: return Out;
18886: }
18887: return [cons(S00, S01), S1, S2];
18888: }
18889:
18890: /* Operator */
18891: if(T==3){
18892: Fuc0 = car(Fuc);
18893: if(Fuc0 != 0){ /* Kill Fuchs relation */
18894: for(V = vars(Fuc0); V != []; V = cdr(V)){
18895: VT = car(V);
18896: if(deg(Fuc0,VT) == 1){
18897: AL = mysubst(AL, [VT, -red(coef(Fuc0,0,VT)/coef(Fuc0,1,VT))]);
18898: break;
18899: }
18900: }
18901: if(V == []){
18902: print("Fuchs condition has no variable with degree 1");
18903: return 0;
18904: }
18905: }
18906: L = newvect(NP);
18907: Pt = getopt(pt);
18908: for(I = NP-1; I >= 1; I--){
18909: if(type(Pt) == 4)
18910: L[I] = Pt[I-1];
18911: else if(I >= 3 || X1 >= 0 || (X2 >= 0 && I >= 2))
18912: L[I] = makev(["x_", I]);
18913: else L[I] = I-1;
18914: }
18915: if(R){ /* non-rigid basic */
18916: MM = AL[0][1]; /* Riemann scheme */
18917: for(OD = 0, MT = car(MM); MT != []; MT = cdr(MT))
18918: OD += car(MT)[0];
18919: for(V = DN = [], M = MM; M != []; M = cdr(M)){
18920: MT = car(M); /* exponents */
18921: for(K = KM = 0, NT = []; ; K++){
18922: for(J = 0, P = 1, MTT = MT; MTT != []; MTT = cdr(MTT)){
18923: if(J == 0 && car(MTT)[1] == 0)
18924: KM = car(MTT)[0];
18925: for(KK = car(MTT)[0] - K -1; KK >= 0; KK--)
18926: P *= (dx-car(MTT)[1]-KK);
18927: }
18928: if(P == 1) break;
18929: NT = cons(P,NT);
18930: }
18931: V = cons(reverse(NT), V);
18932: DN = cons(KM, DN);
18933: }
18934: V = ltov(reverse(V)); /* conditions for GRS */
18935: DN = ltov(reverse(DN)); /* dims of local hol. sol. */
18936: for(J = OD; J >= 0; J--){
18937: for(I = Q = 1; I < NP; I++){
18938: if(J > DN[I])
18939: Q *= (x-L[I])^(J-DN[I]);
18940: }
18941: K = mydeg(Q,x);
18942: if(J == OD){
18943: P = Q*dx^J;
18944: DM = K;
18945: }else{
18946: for(I = DM-OD+J-K; I >= 0; I--){
18947: X = makev(["r",J,"_",I]);
18948: P += Q*x^I*X*dx^J;
18949: }
18950: }
18951: }
18952: for(R = [], I = 0; I < NP; I++){
18953: Q = toeul(P, [x,dx], (I==0)?"infty":L[I]); /* Euler at I-th pt */
18954: for(VT = V[I], J=0; VT != [] ; VT = cdr(VT), J++){
18955: if(car(VT) != 0)
18956: R = cons(rpdiv(coef(Q,J,x), car(VT), dx)[0], R); /* equations */
18957: }
18958: }
18959: for(RR = RRR = [], I = OD-1; I>=0; I--){
18960: RR = [];
18961: for(RT = R; RT != [] ; RT = cdr(RT)){
18962: if( (VT = mycoef(car(RT), I, dx)) != 0)
18963: RR = cons(VT, RR); /* real linear eqs */
18964: }
18965: J = mydeg(mycoef(P,I,dx),x);
18966: for(S = 0, VVV = []; J >= 0; J--){
18967: X = makev(["r",I,"_",J]);
18968: VVV = cons(X, VVV); /* unknowns */
18969: }
18970: RR = lsol(RR,VVV);
18971: LN = length(RR);
18972: for(K=0; K<LN; K++){
18973: RRT = RR[K];
18974: if(type(RRT) != 4) continue;
18975: R = mysubst(R,RRT);
18976: P = mysubst(P,RRT);
18977: }
18978: }
18979: }else /* Rigid case */
18980: P = dx^(AL[0][1][0][0][0]);
18981: /* additions and middle convolutions */
18982: for(ALT = AL; ALT != []; ALT = cdr(ALT)){
18983: AI = car(ALT)[0];
18984: if(type(AI) != 4) continue;
18985: V = ltov(AI);
18986: if(V[0] != 0) P = mc(P,x,V[0]);
18987: for(I = 1; I < NP; I++){
18988: if(V[I] != 0)
18989: P = sftexp(P,x,L[I],-V[I]);
18990: }
18991: }
18992: P = (Simp>=0)? simplify(P,Fuc,4|var=[dx]):simplify(P,Fuc,4);
18993: if(TeX >= 0){
18994: Val = 1;
18995: if(mydeg(P,dx) > 2 && AMSTeX == 1 && TeXEq > 3)
18996: Val = (TeXEq==5)?3:2;
18997: Out = fctrtos(P|var=[dx,"\\partial"],TeX=Val);
18998: if(Dviout < 0) return Out;
18999: dviout(Out|eq=0,keep=Keep);
19000: return 1;
19001: }
19002: return P;
19003: }
19004: return 0;
19005: }
19006:
19007: def mcop(P,M,S)
19008: {
19009: for(V=[],ST=S;ST!=[];ST=cdr(ST))
19010: if(isvar(VT=car(ST))) V=cons(vweyl(VT),V);
19011: V=reverse(V);
19012: N=length(V);
19013: for(MT=M;MT!=[];MT=cdr(MT)){
19014: T=car(MT);
19015: if(T[0]!=0)
19016: P=mc(P,V[0],T[0]);
19017: for(TT=cdr(T),ST=cdr(S);ST!=[];TT=cdr(TT),ST=cdr(ST))
19018: if(car(TT)!=0) P=sftpexp(P,V,S[0]-ST[0],-car(TT));
19019: }
19020: return P;
19021: }
19022:
19023: /* option: zero, all, raw */
19024: def shiftop(M,S)
19025: {
19026: if(type(M)==7) M=s2sp(M);
19027: if(type(S)==7) S=s2sp(S);
19028: Zero=getopt(zero);
19029: NP=length(M);
19030: for(V=L=[],I=NP-1; I>=0; I--){
19031: V=cons(strtov(asciitostr([97+I])),V);
19032: if(I>2) L=cons(makev(["y_", I-1]),L);
19033: else L=cons(I-1,L);
19034: }
19035: if(type(M[0][0])==4){
19036: F=1;RS=M;SS=S;
19037: R=chkspt(M);
19038: if(R[2]!=2 || R[3]!=0){
19039: mycat("GRS is not valid!");return 0;
19040: }
19041: for(; S!=[]; S=cdr(S)){
19042: if(nmono(S[0][0])!=1) break;
19043: if(isint(S[0][1]-S[0][0])==0) break;
19044: }
19045: if(S!=[]){
19046: mycat("Error in shift!"); return 0;
19047: }
19048: }else{
19049: F=0;
19050: RS=sp2grs(M,V,[1,length(M[0]),1]);
19051: for(SS=S0=[],I=0; I<NP; I++){
19052: for(J=F=0; J<length(M[I]); J++){
19053: if(I==0 && J==length(M[0])-1) break;
19054: if((U=S[I][J])!=0){
19055: if(isint(U)!=1){
19056: mycat("Error in shift!"); return 0;
19057: }
19058: VT=RS[I][J][1];
19059: SS=cons([VT,VT+U],SS);
19060: }else if(I>0 && Zero==1 && F==0){
19061: RS=mysubst(RS,[RS[I][J][1],0]);
19062: F=J+1;
19063: }
19064: }
19065: if((F>0 && J==2) || (I==0 && J==1)){
19066: J=(I==0)?0:2-F; VT=RS[I][J][1];
19067: S0=cons([VT,strtov(asciitostr([strtoascii(rtostr(VT))[0]]))],S0);
19068: }
19069: }
19070: }
19071: RS1=mysubst(RS,SS);
19072: if(F==1){
19073: R=chkspt(RS1);
19074: if(R[2]!=2 || R[3]!=0){
19075: mycat("Error in shift!");
19076: return 0;
19077: }
19078: }
19079: R=getbygrs(RS,1); R1=getbygrs(RS1,1);
19080: RT=R[0][1][0];
19081: if(length(RT)!=1 || RT[0][0]!=1){
19082: mycat("Not rigid!");
19083: return 0;
19084: }
19085: P=dx;Q=Q1=1;
19086: for(RT = R, RT1=R1; RT != []; RT = cdr(RT), RT1=cdr(RT1)){
19087: V=car(RT)[0]; V1=car(RT1)[0];
19088: if(type(V) != 4) continue;
19089:
19090: if(V[0] != 0){
19091: P = mc(P,x,V[0]); /* middle convolution */
19092: QT = mc(Q,x,V[0]);
19093: }else QT=Q;
19094: D0=mydeg(Q,dx);D0T=mydeg(QT,dx);
19095: C0=red(mycoef(Q,D0,dx)/mycoef(QT,D0T,dx));
19096: if(C0!=1) QT=red(C0*QT);
19097:
19098: if(V1[0] != 0) Q1T = mc(Q1,x,V1[0]);
19099: else Q1T=Q1;
19100: D1=mydeg(Q1,dx);D1T=mydeg(Q1T,dx);
19101: C1=red(mycoef(Q1,D1,dx)/mycoef(Q1T,D1T,dx));
19102: if(C1!=1) Q1T=red(C1*Q1T);
19103: DD=(V[0]-V1[0])+(D0-D0T)-(D1-D1T);
19104: if(DD>0){
19105: QT=muldo(dx^DD,QT,[x,dx]);
19106: D0T+=DD;
19107: }else if(DD<0){
19108: Q1T=muldo(dx^(-DD),Q1T,[x,dx]);
19109: D1T-=DD;
19110: }
19111: C=mylcm(dn(QT),dn(Q1T),x);
19112: if(C!=1){
19113: QT=red(C*QT); Q1T=red(C*Q1T);
19114: }
19115: Q=QT;Q1=Q1T;
19116: for(I = 1; I < NP; I++){
19117: if(V[I]!=0){
19118: P = sftexp(P,x,L[I],-V[I]); /* addition u -> (x-L[I])^V[I]u */
19119: QT = sftexp(QT,x,L[I],-V[I]);
19120: }
19121: if(V1[I]!=0)
19122: Q1T = sftexp(Q1T,x,L[I],-V1[I]);
19123: }
19124: C=red(mycoef(QT,D0T,dx)*mycoef(Q1,D1T,dx)/(mycoef(Q,D0T,dx)*mycoef(Q1T,D1T,dx)));
19125: Q=red(dn(C)*QT);Q1=red(nm(C)*Q1T);
19126: for(I = 1; I < NP; I++){
19127: if((J=V[I]-V1[I])!=0){
19128: if(J>0) Q1*=(x-L[I])^J;
19129: else Q*=(x-L[I])^(-J);
19130: }
19131: while((QT=tdiv(Q,x-L[I]))!=0){
19132: if((Q1T=tdiv(Q1,x-L[I]))!=0){
19133: Q=QT;Q1=Q1T;
19134: }else break;
19135: }
19136: }
19137: }
19138: P1=mysubst(P,SS);
19139: if(type(S0)==4 && S0!=[]){
19140: P=mysubst(P,S0); Q=mysubst(Q,S0);
19141: P1=mysubst(P1,S0); Q1=mysubst(Q1,S0);
19142: RS=mysubst(RS,S0); RS1=mysubst(RS1,S0);
19143: }
19144: R=mygcd(Q1,P1,[x,dx]);
19145: if(findin(dx,vars(R[0]))>=0){
19146: mycat("Some error!");
19147: return 0;
19148: }
19149: Q=muldo(R[1]/R[0],Q,[x,dx]);
19150: R=divdo(Q,P,[x,dx]);
19151: Q=red(R[1]/R[2]);
19152: R=fctr(nm(Q));
19153: QQ=Q/R[0][0];
19154: R1=fctr(dn(QQ));
19155: for(RR=cdr(R1); RR!=[]; RR=cdr(RR)){
19156: VT=vars(car(RR)[0]);
19157: if(findin(x,VT)<0 && findin(dx,VT)<0){
19158: for(I=car(RR)[1];I>0;I--) QQ=red(QQ*car(RR)[0]);
19159: }
19160: }
19161: Raw=getopt(raw);
19162: Dviout=getopt(dviout);
19163: if(Dviout==1) Raw=4;
19164: if(Raw!=1){
19165: for(RR=cdr(R); RR!=[]; RR=cdr(RR)){
19166: VT=vars(car(RR)[0]);
19167: if(findin(x,VT)<0 && findin(dx,VT)<0){
19168: for(I=car(RR)[1];I>0;I--) QQ=red(QQ/car(RR)[0]);
19169: }
19170: }
19171: }
19172: if(Raw==2||Raw==3||Raw==4){
19173: R=mygcd(QQ,P,[x,dx]); /* R[0]=R[1]*QQ + R[2]*P */
19174: Q1=red(R[0]/R[2]);
19175: for(Q=1,RR=cdr(fctr(nm(Q1))); RR!=[]; RR=cdr(RR)){
19176: VT=vars(car(RR)[0]);
19177: if(findin(x,VT)<0){
19178: for(I=car(RR)[1];I>0;I--) Q*=car(RR)[0];
19179: }
19180: }
19181: if(Raw==3) QQ=[QQ,Q];
19182: else if(Raw==4) /* Q=Q*R[1]/R[0]*QQ+Q/R[0]*P */
19183: QQ=[QQ,Q,red(R[1]*Q/R[0])];
19184: else QQ=Q;
19185: }
19186: F=getopt(all);
19187: if(Dviout==1){
19188: Pre = " x=\\infty & 0 & 1";
19189: for(I=3; I<NP; I++) Pre = Pre+"& "+rtostr(L[I]);
19190: Pre = Pre+"\\\\\n";
19191: PW=str_tb(ltotex(RS|opt="GRS",pre=Pre),0);
19192: str_tb(
19193: "=\\{u\\mid Pu=0\\}\\\\\n&\\underset{Q_2}{\\overset{Q_1}{\\rightleftarrows}}\n",PW);
19194: str_tb([ltotex(RS1|opt="GRS",pre=Pre),"\\\\\n"],PW);
19195: R=fctrtos(QQ[0]|TeX=3,var=[dx,"\\partial"]);
19196: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
19197: str_tb(["Q_1&=",R,"\\\\\n"],PW);
19198: R=fctrtos(QQ[2]|TeX=3,var=[dx,"\\partial"]);
19199: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
19200: str_tb(["Q_2&=",R,"\\\\\n"],PW);
19201: str_tb(["Q_2Q_1&\\equiv ",fctrtos(QQ[1]|TeX=3),"\\mod W(x)P"],PW);
19202: if(F==1)
19203: str_tb(["\\\\\nP&=",fctrtos(P|TeX=3,var=[dx,"\\partial"])],PW);
19204: dviout(str_tb(0,PW)|eq=0,title="Shift Operator");
19205: }
19206: if(F==1) return [QQ,P,RS,P1,RS1];
19207: else if(F==0) return QQ;
19208: return [QQ,P,RS];
19209: }
19210:
1.56 takayama 19211:
19212: def shiftPfaff(A,B,G,X,M)
19213: {
19214: if(type(G)==4){
19215: G0=G[1];G1=G[0];
19216: }
19217: if(type(G)==6){
19218: G=map(red,G);
19219: G0=llcm(G);G1=map(red,G0*G);
19220: }
19221: if(type(G)==3){
19222: G=red(G);G0=dn(G);G1=nm(G);
19223: }
19224: if(type(M)==4){
19225: M0=M[0];M1=M[1];
19226: }else{
19227: M0=M;M1=0;
19228: }
19229: X=vweyl(X);
19230: D0=mydeg(G0,X[0]);D1=mydeg(G1,X[0]);
19231: if(M1>=0){
19232: D=(D1-M1>D0)?D1-M1:D0;
19233: G0=muldo(X[1]^D,G0,X);G1=muldo(X[1]^(D+M1),G1,X);
19234: }else{
19235: D=(D0+M1>D1)?D0+M1:D1;
19236: G0=muldo(X[1]^(D-M1),G0,X);G1==muldo(X[1]^D,G1,X);
19237: }
19238: G0=map(mc,G0,X,M0);G1=map(mc,G1,X,M0+M1);
19239: G0=appldo(G0,A,X|Pfaff=1);
19240: G1=sppldo(G1,B,X|Pfaff=1);
19241: return rmul(myinv(G0),G1);
19242: }
19243:
1.6 takayama 19244: def conf1sp(M)
19245: {
19246: if(type(M)==7) M=s2sp(M);
19247: L0 = length(M);
19248: L1 = length(M[L0-1]);
19249: X2 = getopt(x2);
19250: Conf= getopt(conf);
19251: if(Conf != 0)
19252: Conf = -1;
19253: if((X2==1 || X2==-1) && Conf != 0){
19254: X1 = 0;
19255: X = x_1;
19256: }else{
19257: X1 = 1;
19258: X = x_2;
19259: }
19260: G = sp2grs(M,a,[L0,L1]);
19261: for(I = 0; I < L0-1; I++){
19262: V = makev([a,I-Conf,0]);
19263: G = subst(G,V,0);
19264: }
19265: L2 = length(M[1]);
19266: for(I=J=S0=S1=0; I < L2; I++){
19267: S1 += G[1][I][0];
19268: while(S0 < S1){
19269: S0 += G[0][J][0];
19270: if((V=G[0][J][1]) != 0)
19271: G = mysubst(G,[V,V-G[1][I][1]]);
19272: J++;
19273: }
19274: if(S0 > S1){
19275: print("Error in data!");
19276: return 0;
19277: }
19278: }
19279: if(Conf==0){
19280: for(L=[], I=L0-2; I>=0; I--)
19281: L=cons(I,L);
19282: L=cons(L0-1,L);
19283: P = getbygrs(G,["operator","x2"]|perm=L);
19284: }else if(X1)
19285: P = getbygrs(mperm(G,[[1,2]],[]), ["operator","x2"]);
19286: else
19287: P = getbygrs(G,["operator","x1"]);
19288: if(Conf==0)
19289: P=nm(mysubst(P,[X,c]));
19290: else{
19291: P = nm(mysubst(P,[X,1/c]));
19292: if(X2==-1){
19293: for(I=2; I<L0; I++){
19294: V=makev(["x_",I]); VC=makev([c,I]);
19295: P = nm(mysubst(P,[V,1/VC]));
19296: }
19297: }
19298: }
19299: for(I = 1; I < L2; I++){
19300: X = G[1][I][1];
19301: P = nm(mysubst(P,[X,X/c]));
19302: }
19303: VS = vars(P);
19304: while(VS!=[]){
19305: V = car(VS);
19306: if(str_chr(rtostr(V),0,"r")==0){
19307: CV = mycoef(P,1,V);
19308: D = mymindeg(CV,c);
19309: if(D > 0) P = mysubst(P,[V,V/c^D]);
19310: CV = mycoef(P,1,V);
19311: DD = mydeg(CV,dx);
19312: CVV = mycoef(CV,DD,dx);
19313: CD1 = mydeg(CVV,x);
19314: CD = (X==x1)?0:CD1;
19315: while(CD>=0 && CD<=CD1){
19316: CC = mycoef(CVV,CD,x);
19317: if(type(CC)==1){
19318: VT = mycoef(mycoef(mycoef(P,DD,dx),CD,x),0,V)/CC;
19319: if(VT != 0) P = mysubst(P,[V,V-VT]);
19320: break;
19321: }
19322: if(X==x1) CD++;
19323: else CD--;
19324: }
19325: while(subst(P,c,0,V,0) == 0)
19326: P = red(mysubst(P,[V,c*V])/c);
19327: }
19328: VS =cdr(VS);
19329: }
19330: return P;
19331: }
19332:
1.44 takayama 19333: /* ((1)(1)) ((1)) 111|11|21 [[ [2,[ [1,[1]],[1,[1]] ]], [1,[[1,[1]]]] ]] */
19334: /* (11)(1),111 111|21,111 [[[2,[1,1]],[1,[1]]],[1,1,1]] */
19335: def s2csp(S)
19336: {
19337: if(type(S)!=7){
19338: U="";
19339: if(type(N=getopt(n))>0){
19340: for(D=0,S=reverse(S);S!=[];S=cdr(S),D++){
19341: if(D) U=","+U;
19342: T=str_subst(rtostr(car(S)),","," ");
19343: U=str_cut(T,1,str_len(T)-2)+U;
19344: }
19345: V=strtoascii(U);
19346: for(R=[];V!=[];V=cdr(V)){
19347: if((CC=car(V))==91){ /* [ */
19348: if(length(V)>1 && V[1]==91) V=cdr(V);
19349: for(I=1;(CC=V[I])!=91&&CC!=93;I++);
19350: if(CC==91){
19351: R=cons(40,R); /* ( */
19352: while(I--) V=cdr(V);
19353: }else{
19354: V=cdr(V);
19355: while(--I) R=cons(car(V),R);
19356: }
19357: }else if(CC==93){ /* ] */
19358: R=cons(41,R);
19359: if(length(V)>1 && V[1]==93) V=cdr(V);
19360: }else R=cons(CC,R);
19361: }
19362: return asciitostr(reverse(R));
19363: }
19364: for(;S!=[];S=cdr(S)){
19365: if(U!="") U=U+",";
19366: for(D=0,TU="",T=car(S);T!=[];D++){
19367: if(type(car(T))==4){
19368: R=lpair(T,0);
19369: T=R[0];R1=m2l(R[1]|flat=1);
19370: }else R1=[];
19371: if(D) TU="|"+TU;
19372: TU=s2sp([T])+TU;
19373: T=R1;
19374: }
19375: U=U+TU;
19376: }
19377: return U;
19378: }
19379: S=strtoascii(S);
1.45 takayama 19380: if(type(N=getopt(n))>0){
19381: S=ltov(S);
19382: L=length(S);
19383: R="";
19384: for(I=J=N=0, V=[];J<L;J++){
19385: if(S[J]==72) I=J; /* ( */
19386: else if(S[J]>47&&S[J]<58) N=N*10+S[J]-48;
19387: else{
19388: if(N>0){
19389: V=cons(N,V);
19390: N=0;
19391: }
19392: if(S[J]==41){ /* ) */
19393:
19394: }else if(S[J]==44){ /* , */
19395:
19396: }
19397: }
19398: }
19399: }
1.44 takayama 19400: for(P=TS=[],I=D=0; S!=[]; S=cdr(S)){
19401: if((C=car(S))==44){ /* , */
19402: P=cons(D,P);D=0;
19403: }else if(C==124){ /* | */
19404: D++;C=44;
19405: }
19406: TS=cons(C,TS);
19407: }
19408: S=reverse(TS);
19409: P=reverse(cons(D,P));
19410: U=s2sp(asciitostr(S));
19411:
19412: for(R=[];P!=[];P=cdr(P),U=cdr(U)){
19413: D=car(P);R0=car(U);
19414: while(D--){
19415: U=cdr(U);
19416: for(U0=car(U),R2=[];U0!=[];U0=cdr(U0)){
19417: for(R1=[],N=car(U0);N>0;R0=cdr(R0)){
19418: R1=cons(car(R0),R1);
19419: if(type(car(R0))==4) N-=car(R0)[0];
19420: else N-=car(R0);
19421: }
19422: R2=cons([car(U0),reverse(R1)],R2);
19423: }
19424: R0=reverse(R2);
19425: }
19426: R=cons(R0,R);
19427: }
19428: return reverse(R);
19429: }
19430:
19431:
1.36 takayama 19432: def partspt(S,T)
19433: {
1.40 takayama 19434: if(length(S)>length(T)) return [];
1.38 takayama 19435: if(type(Op=getopt(opt))!=1) Op=0;
1.40 takayama 19436: else{
19437: VS=ltov(S);
19438: L=length(S)-1;
19439: VT=ltov(qsort(T));
19440: }
1.38 takayama 19441: if(length(S)==length(T)){
1.40 takayama 19442: if(S==T||qsort(S)==qsort(T)) R=S;
1.38 takayama 19443: else return [];
1.40 takayama 19444: }else if(getopt(sort)==1){
19445: S0=S1=[];
19446: for(;S!=[]&&car(S)==car(T);S=cdr(S),T=cdr(T))
19447: S0=cons(car(S),S0);
19448: if(S!=[]&&car(S)<car(T)) return [];
19449: S0=reverse(S0);
19450: for(S=reverse(S),T=reverse(T);S!=[],car(S)==car(T);S=cdr(S),T=cdr(T))
19451: S1=cons(car(S),S1);
19452: if(car(S)!=[]&&car(S)<cat(T)) return [];
19453: R=partspt(reverse(S),reverse(T));
19454: if(S1!=[]){
19455: for(R0=[];R!=[];R=cdr(R))
19456: R0=cons(append(car(R),S1),R0);
19457: R=reverse(R0);
19458: }
19459: if(S0!=[]){
19460: for(R0=[];R!=[];R=cdr(R))
19461: R0=cons(append(S0,car(R)),R0);
19462: R=reverse(R0);
19463: }
1.38 takayama 19464: }else{
19465: for(R=[];;){
19466: for(I=J=P=0;I<L;I++){
19467: P=VS[I];
19468: X=100000;
19469: while((P-=(Y=VT[J++]))>0){
19470: if(X<Y) break;
19471: X=Y;
19472: }
19473: if(X<Y||P<0) break;
19474: }
19475: if(!P&&X>=Y) R=cons(vtol(VT),R);
19476: if(!vnext(VT)) break;
19477: }
1.36 takayama 19478: }
1.38 takayama 19479: if(Op){
19480: for(W=[];R!=[];R=cdr(R)){
19481: for(I=0,S=VS[0],K=U=[],TR=car(R);TR!=[];TR=cdr(TR)){
19482: K=cons(car(TR),K);
19483: if(!(S-=car(K))){
19484: U=cons([VS[I],reverse(K)],U);
19485: K=[];
19486: S=VS[++I];
19487: if(I==L){
19488: U=cons([S,cdr(TR)],U);
19489: break;
19490: }
19491: }
1.36 takayama 19492: }
1.38 takayama 19493: W=cons(reverse(U),W);
19494: }
19495: R=W;
19496: if(iand(Op,1)){
1.40 takayama 19497: for(R=[];W!=[];W=cdr(W))
1.38 takayama 19498: R=cons(reverse(qsort(car(W))),R);
19499: R=lsort(R,[],1);
19500: }
19501: if(Op==3){
19502: for(W=[];R!=[];R=cdr(R)){
19503: for(S=[],TR=car(R);TR!=[];TR=cdr(TR))
19504: S=append(S,car(TR)[1]);
19505: W=cons(S,W);
1.36 takayama 19506: }
1.38 takayama 19507: R=reverse(W);
1.36 takayama 19508: }
19509: }
1.38 takayama 19510: return R;
1.36 takayama 19511: }
19512:
1.38 takayama 19513: #if 0
1.36 takayama 19514: def confspt(S,T)
19515: {
19516: R=[];
19517: LS=length(S);LT=length(T);
19518: if(LS<LT) return R;
19519: if(LS==LT){
19520: return(S==T)? return [[S,T]]:R;
19521: }
19522: R=[];
19523: for(ST=S,S0=T0=[],TT=T;ST!=[];ST=cdr(ST),TT=cdr(TT)){
19524: if(car(ST)>car(TT)) return R;
19525: if(car(ST)==car(TT){
19526: S0=cons(car(ST));T0=cons(car(TT));
19527: LS--;LT--;continue;
19528: }
19529: V=car(TT);D=LS-LT;
19530: for(P=[ST],DD=D;DD>0;){
19531: VD=V-car(car(ST));
19532: }
19533: }
19534: }
19535: #endif
19536:
1.50 takayama 19537: def mcvm(N)
19538: {
19539: X=getopt(var);
19540: if((Z=getopt(z))!=1) Z=0;
19541: if(type(N)==4){
19542: if((K=length(N))==1&&isvar(X)) X=[X];
19543: if(type(X)!=4){
19544: for(X=[],I=0;I<K;I++) X=cons(asciitostr([97+I]),X);
19545: X=reverse(X);
19546: }
19547: if(getopt(e)==1){
19548: if(length(N)==4){
19549: N=ltov(N);
19550: if(N[1]<N[3]){
19551: I=N[1];N[1]=N[3];N[3]=I;
19552: }
19553: if(N[2]<N[3]||N[2]>=N[1]+N[3]) return 0;
19554: X=X[0];
19555: for(R=[],I=1;I<N[3];I++) R=cons(makev([X[0],I]),R);
19556: for(L=[],I=N[1];I<=N[2];I++) L=cons(makev([X[0],I]),L);
19557: for(S=0,I=N[1];I<=N[2];I++){
19558: V=makev([X[0],I]);
19559: S+=polbyroot(R,V)/polbyroot(lsort(L,V,1),V);
19560: S=red(S);
19561: }
19562: return S;
19563: }
19564: }
19565: for(M=[],I=S=0;I<K;Z=0,I++){
19566: M=cons(mcvm(N[I]|var=X[I],z=Z),M);
19567: S+=N[I];
19568: }
19569: M=newbmat(K,K,reverse(M));
1.52 takayama 19570: NR=N;
1.50 takayama 19571: N=S;
19572: }else{
19573: if(type(X)==7) X=strtov(X);
19574: if(!isvar(X)) X=a;
19575: M=newmat(N,N);
19576: for(I=0;I<N;I++){
19577: V=makev([X,I+1]);
19578: for(J=0;J<=I;J++){
19579: R=polbyroot([1,J],V|var=X);
19580: if(Z==1) R*=V;
19581: M[I][J]=R;
19582: }
19583: }
19584: }
1.52 takayama 19585: if((Get=getopt(get))==1){
1.50 takayama 19586: for(R=[],I=0;I<N;I++){
19587: U=newmat(N,N);
19588: for(J=0;J<N;J++) U[J][J]=M[J][I];
1.56 takayama 19589: R=cons(rmul(rmul(myinv(M),U),M),R);
1.50 takayama 19590: }
19591: return reverse(R);
1.52 takayama 19592: }else if(Get==2||Get==3||Get==4){
1.51 takayama 19593: for(V=[],I=N;I>0;I--) V=cons(makev(["a0",I]),V);
19594: MI=myinv(M);
19595: V=ltov(V)*MI;
19596: for(R=[],I=0;I<N;I++){
19597: for(J=I+1;J<N;J++){
19598: K=newmat(N,N);
19599: K[I][I]=V[J];K[I][J]=-V[J];K[J][J]=V[I];K[J][I]=-V[I];
1.56 takayama 19600: R=cons(rmul(rmul(MI,K),M),R);
1.51 takayama 19601: }
19602: }
1.52 takayama 19603: R=reverse(R);
19604: if(Get==2||length(NR)!=2||Z==1) return R;
19605: for(V1=[],I=NR[0];I>0;I--) V1=cons(os_md.makev([X[0],I]),V1);
19606: for(V2=[],I=NR[1];I>0;I--) V2=cons(os_md.makev([X[1],I]),V2);
19607: R=subst(R,car(V1),0,car(V2),0);
19608: V1=subst(V1,car(V1),0);
19609: V2=subst(V2,car(V2),0);
19610: for(V=[],S=V1;S!=[];S=cdr(S)) for(T=V2;T!=[];T=cdr(T)) V=cons(car(T)-car(S),V);
19611: V=reverse(V);
19612: Mx=length(V);
19613: for(A0=[],I=J=NR[0]-1;J>=0;I+=--J) for(K=0;K<NR[1];K++,I++) A0=cons(R[I],A0);
19614: A0=reverse(A0);
19615: for(F0=[],T=1,I=Mx-1;I>=0;I--) F0=cons(1/(x-V[I]), F0);
19616: MV=confexp([F0,V]|sym=3);
19617: RR=newvect(Mx);
19618: for(K=0;K<Mx;K++) for(RR[K]=0,I=0;I<Mx;I++) RR[K]=map(red,RR[K]+MV[I][K]*A0[I]);
19619: RR0=mysubst(RR,[append(cdr(V1),cdr(V2)),vtol(newvect(Mx-2))]|lpair=1);
19620: RR0=vtol(RR0);
19621: return (Get==3)?[RR,RR0]:RR0;
1.50 takayama 19622: }
19623: return M;
19624: }
1.36 takayama 19625:
1.34 takayama 19626: def confexp(S)
19627: {
1.52 takayama 19628: if((Sym=getopt(sym))==1||Sym==2||Sym==3){
1.51 takayama 19629: D=polbyroot(S[1],x);
1.52 takayama 19630: for(R=[],T=S[0];T!=[];T=cdr(T)){
19631: M=D*car(T);
19632: if(type(M)>3) M=map(red,M);
19633: else M=red(M);
19634: R=cons(M,R);
19635: }
1.51 takayama 19636: R=reverse(R);
19637: if(Sym==2) return R;
19638: M=length(R);N=length(S[1]);
19639: E=newmat(M,N);
19640: for(I=0;I<M;I++){
19641: for(J=0;J<N;J++) E[I][J]=mycoef(R[I],N-J-1,x);
19642: }
1.52 takayama 19643: if(Sym==3){
19644: for(R=[],P=1,T=S[1];T!=[];T=cdr(T)) R=cons(P/=(x-car(T)),R);
19645: R=confexp([reverse(R),S[1]]|sym=1);
19646: return E*myinv(R);
19647: }
1.51 takayama 19648: return E;
19649: }
1.35 takayama 19650: if(type(S[0])==4){
1.52 takayama 19651: for(E=[];S!=[];S=cdr(S)) E=cons(confexp(car(S),E));
1.35 takayama 19652: return reverse(E);
19653: }
1.34 takayama 19654: V=x;E=[];
19655: for(P=0,Q=[],ST=S;ST!=[];ST=cdr(ST)){
19656: Q=cons(car(ST)[0],Q);
19657: P+=car(ST)[1]/(V-car(ST)[0]);
19658: P=red(P);
19659: }
19660: P=red(P*polbyroot(Q,V));
19661: Q=cdr(reverse(Q));
19662: for(I=(length(W=Q));I>=0;I--){
19663: C=mycoef(P,I,V);
19664: P-=C*polbyroot(W,V);
19665: W=cdr(W);
19666: E=cons(red(C),E);
19667: }
19668: return reverse(E);
19669: }
19670:
1.6 takayama 19671: def pgen(L,VV)
19672: {
19673: if(type(L[0])<4) L=[L];
19674: if(type(L)==4) L=ltov(L);
19675: K=length(L);
19676: V=newvect(K);
19677: if(type(Sum=getopt(sum))!=1) Sum=0;
19678: if((Num=getopt(num))!=1) Num=0;
19679: if((Sep=getopt(sep))!=1) Sep=0;
19680: if(type(Shift=getopt(shift))!=1) Shift=0;
19681: for(;;){
19682: for(PP=1,R=[],II=K-1; II>=0; II--){
19683: R=cons(V[II]+Shift,R);
19684: if(II>0 && Sep==1) R=cons("_",R);
19685: PP*=L[II][0]^V[II];
19686: }
19687: P+=makev(cons(VV,R)|num=Num)*PP;
19688: for(I=0;I<K;){
19689: if(++V[I]<=L[I][1]){
19690: if(Sum>0){
19691: for(S=II=0;II<K;) S+=V[II++];
19692: if(S>Sum){
19693: V[I++]=0;
19694: continue;
19695: }
19696: }
19697: }else{
19698: V[I++]=0;
19699: continue;
19700: }
19701: break;
19702: }
19703: if(I>=K) return P;
19704: }
19705: }
19706:
19707: def diagm(M,A)
19708: {
19709: return mgen(M,0,A,1);
19710: }
19711:
19712: def mgen(M,N,A,S)
19713: {
19714: if(M==0 && N==0){
19715: mycat([
19716: "mgen(m,n,a,s|sep=1) : generate a matrix of size m x n\n",
19717: " n : a number or \"diagonal\", \"highdiag\", \"lowdiag\",\"skew\",\"symmetric\",\"perm\" = 0,-1,-2,..\n",
19718: " a : a symbol or list (ex. a, [a], [a,b,c], [1,2,3])\n",
19719: " s : 0 or 1 (shift of suffix)\n"
19720: ]);
19721: return 0;
19722: }
19723: if(type(N)==7) N=-findin(N,["diag","highdiag","lowdiag","skew","symmetric","perm"]);
19724: Sep=(getopt(sep)==1)?1:0;
19725: if(S < 0 || S > 2)
19726: S = 0;
19727: if(M+S > 30 || N+S > 30){
19728: erno(1);
19729: return;
19730: }
19731: if(N==-5){
19732: NM=newmat(M,M);
19733: for(I=0;I<M;I++,A=cdr(A)) NM[I][car(A)-S]=1;
19734: return NM;
19735: }
19736: if(type(A) == 4)
19737: L = length(A)-1;
19738: else
19739: L = -1;
19740: if(N <= 0 && N >= -2){
19741: MM = newmat(M,M);
19742: J = K = 0;
19743: if(N == -1){
19744: K = 1; M--;
19745: }else if(N == -2){
19746: J = 1; M--;
19747: }
19748: for(I = 0; I < M; I++){
19749: if(L >= 0)
19750: MM[I+J][I+K] = A[(I > L)?L:I];
19751: else if(type(A)==7 || isvar(A))
19752: MM[I+J][I+K] = makev([A,S+I]|sep=Sep);
19753: else
19754: MM[I+J][I+K] = A;
19755: }
19756: return MM;
19757: }
19758: K = N;
19759: if(K < 0) N = M;
19760: MM = newmat(M,N);
19761: for(I = 0; I < M; I++){
19762: if(L >= 0)
19763: AA = rtostr(A[(I > L)?L:I]);
19764: else
19765: AA = rtostr(A)+rtostr(I+S);
19766: if(AA>="0" && AA<=":"){
19767: erno(0); return;
19768: }
19769: for(J = 0; J < N; J++){
19770: if(K < 0){
19771: if(I > J) continue;
19772: if(K == -3 && I == J) continue;
19773: }
19774: MM[I][J] = makev([AA,J+S]|sep=Sep);
19775: }
19776: }
19777: if(K < 0){
19778: for(I = 0; I < M; I++){
19779: for(J = 0; J < I; J++)
19780: MM[I][J] = (K == -4)?MM[J][I]:-MM[J][I];
19781: }
19782: }
19783: return MM;
19784: }
19785:
19786: def newbmat(M,N,R)
19787: {
19788: S = newvect(M);
19789: T = newvect(N);
19790: IM = length(R);
1.50 takayama 19791: if(type(car(R))!=4 && M==N && M==IM){
19792: for(RR=TR=[],I=0;I<M;I++){
19793: for(TR=[R[I]],J=0;J<I;J++) TR=cons(0,TR);
19794: RR=cons(TR,RR);
19795: }
19796: R=reverse(RR);
19797: }
1.6 takayama 19798: for(I = 0; I < IM; I++){
19799: RI = R[I];
19800: JM = length(RI);
19801: for(J = 0; J < JM; J++){
19802: RIJ = RI[J];
19803: if(type(RIJ) == 6){
19804: S[I] = size(RIJ)[0];
19805: T[J] = size(RIJ)[1];
19806: }
19807: }
19808: }
19809: for(I = K = 0; I < M; I++){
19810: if(S[I] == 0)
19811: S[I] = 1;
19812: K += S[I];
19813: }
19814: for(J = L = 0; J < N; J++){
19815: if(T[J] == 0)
19816: T[J] = 1;
19817: L += T[J];
19818: }
19819: M = newmat(K,L);
19820: if(type(Null=getopt(null))>0){
19821: for(I=0;I<K;I++){
19822: for(J=0;J<L;J++) M[I][J]=Null;
19823: }
19824: }
19825: for(I0 = II = 0; II < IM; I0 += S[II++]){
19826: RI = R[II];
19827: JM = length(RI);
19828: for(J0 = JJ = 0; JJ < JM; J0 += T[JJ++]){
19829: if((RIJ = RI[JJ]) == 0)
19830: continue;
19831: Type = type(RIJ);
19832: for(I = 0; I < S[II]; I++){
19833: for(J = 0; J < T[JJ]; J++){
19834: if(Type == 6)
19835: M[I0+I][J0+J] = RIJ[I][J];
19836: else if(Type == 4 || Type == 5)
19837: M[I0+I][J0+J] = (I>0)?RIJ[I]:RIJ[J];
19838: else
19839: M[I0+I][J0+J] = RIJ;
19840: }
19841: }
19842: }
19843: }
19844: return M;
19845: }
19846:
19847: def unim(S)
19848: {
19849: if(!Rand++) random(currenttime());
19850: if(!isint(Wt=getopt(wt))||Wt<0||Wt>10) Wt=2;
19851: if(!isint(Xa=getopt(abs)) || Xa<1)
19852: Xa=9;
19853: if((Xaa=Xa)>10) Xaa=10;
19854: if(Xaa%2) Xaa++;
19855: Xh=Xaa/2;
19856: if(type(S0=SS=S)==4){
19857: Int=(getopt(int)==1)?1:0;
19858: U=[1,1,1,1,1,1,1,1,1,1,1,1,2,2,3,4];
19859: M=newmat(S[0],S[1]);
19860: SS=cdr(S);SS=cdr(SS);
19861: if(Rk=length(SS)) L=SS;
19862: else{
19863: L=[0];
19864: I=(S[0]>S[1])?S[1]:S[0];
19865: if(I<=2) return 0;
19866: if(!isint(Rk=getopt(rank))||Rk<1||Rk>S[0]||Rk>S[1])
19867: Rk=random()%(I-1)+2;
19868: for(I=1;I<Rk;){
19869: P=random()%(S[1]+Wt)-Wt;
19870: if(P<=0) P=1;
19871: if(findin(P,L)!=0){
19872: L=cons(P,L);
19873: I++;
19874: }
19875: }
19876: }
19877: L=ltov(qsort(L));
19878: M[0][L[0]]=1;
19879: for(I=1;I<Rk;I++){
19880: P=Int?1:U[random()%length(U)];
19881: if(P>Xa) P=Xa;
19882: M[I][L[I]]=(random()%2)?P:(-P);
19883: }
19884: for(I=0;I<Rk;I++){
19885: if(I!=0&&abs(M[I][L[I]])>1) M[K=random()%I][KK=L[I]]=1;
19886: I0=(I==0)?1:L[I]+1;
19887: I1=(I==Rk-1)?S[1]:L[I+1];
19888: for(J=I0;J<I1;J++){
19889: for(K=1;K<=Xa;K++){
19890: P=random()%(I+1);
19891: if((random()%2)==1) M[P][J]++;
19892: else M[P][J]--;
19893: }
19894: }
19895: }
19896: S=M;
19897: Res=(getopt(res)==1)?dupmat(S):0;
19898: }
19899: Conj=0;
19900: if(type(S)<2){
19901: if(S<2||S>20) return 0;
19902: if(getopt(conj)==1){
19903: M=S+Wt;
19904: if(M>15) M=10;
19905: M0=floor((M-1)/2);
19906: for(R=[],I=0;I<S;I++) R=cons(random()%M-M0,R);
19907: R=qsort(R);
19908: M=diagm(S,R);
19909: if(getopt(diag)!=1){
19910: for(I=1;I<S;I++)
19911: if(M[I-1][I-1]==M[I][I] && random()%2) M[I-1][I]=1;
19912: }
19913: if(M[0][0]==M[S-1][S-1]){
19914: for(I=1;I<S;I++) if(M[I-1][I]==1) break;
19915: if(I==S){
19916: if(M[0][0]>0) M[0][0]--;
19917: else M[S-1][S-1]++;
19918: }
19919: }
19920: if(getopt(res)==1) RR=diagm(S,[1]);
19921: S1=S;
19922: Res=dupmat(S=M);
19923: if(isint(I=getopt(int))&&I>1&&random()%I==0){
19924: K=S[0][0];L=K+1;
19925: for(I=1;I<S1;I++){
19926: if(S[I][I]>L && S[I-1][I]==0 && (I==S1-1||S[I][I+1]==0)){
19927: L=S[I][I];
19928: if(RR){
19929: RR[I][I]=L-K;RR[0][I]=1;
19930: }
19931: S[0][I]=1;
19932: if(!(random()%3)) break;
19933: }
19934: }
19935: if(random()%3==0){
19936: for(I=0;I<S1-1;I++){
19937: if(iand(S[I][I],1)&&S[I][I+1]==1){
19938: for(J=I+2;J<S1&&S[I][J]==0;J++);
19939: if(J<S1) continue;
19940: for(J=I-1;J>=0&&S[J][I]==0;J--);
19941: if(J>=0) continue;
19942: S[I][I+1]=2;
19943: for(J=0;J<S1;J++) RR[I][J]*=2;
19944: break;
19945: }
19946: }
19947: }
19948: }
19949: }else{
19950: M=diagm(S,[1]);
19951: S1=S;
19952: }
19953: }
19954: if(type(S)==6){
19955: M=dupmat(S);
19956: S=size(S);
19957: S1=S[1];S=S[0];
19958: Nt=1;
19959: if(getopt(conj)==1&&S==S1) Conj=1;
19960: }
19961: if(!isint(Ct=getopt(time)))
19962: Ct=(S>3||S1>3)?100:200;
19963: if(getopt(both)==1){
19964: OL=delopt(getopt(),"both");
19965: M=unim(mtranspose(M)|option_list=OL);
19966: M=mtranspose(M);
19967: }
19968: Mx=20;
19969: for(I=K=LL=0;I<Ct+Mx;I++){
19970: P=random()%S;Q=random()%S;
19971: if(3*K>Ct) T=random()%Xaa-Xh;
19972: else if(5*K<Ct) T=random()%2-1;
19973: else T=random()%4-2;
19974: if(T>=0) T++;
19975: if(P==Q) continue;
19976: for(G=0,J=S1-1;J>=0;J--){
19977: if((H=abs(M[Q][J]+M[P][J]*T))>Xa&&(!Conj||J!=P)) break;
19978: if(K<Mx&&!Conj) G=igcd(G,H);
19979: }
19980: if(K<Mx && G>1) J=1;
19981: if(J>0) continue;
19982: if(J<0&&Conj==1){
19983: for(J=S1-1;J>=0;J--)
19984: if(J!=Q&&abs(M[J][P]-M[J][Q]*T)>Xa) break;
19985: if(J<0&&abs(M[Q][P]-M[Q][Q]*T+M[P][P]*T-M[P][Q]*T^2)>Xa) J=1;
19986: if(J<0&&M[P][P]==M[Q][Q]){
19987: LF=0;
19988: for(L=S1-1;J>=0;J--) if(L!=Q&&M[J][Q]!=0) LF++;
19989: for(L=S1-1;J>=0;J--) if(L!=P&&M[P][J]!=0) LF++;
19990: if(!LF) J=1;
19991: }
19992: }
19993: if(J<0){
19994: for(J=S1-1;J>=0;J--)
19995: M[Q][J]+=M[P][J]*T;
19996: if(Conj==1)
19997: for(J=S1-1;J>=0;J--) M[J][P]-=M[J][Q]*T;
19998: if(RR) for(J=S1-1;J>=0;J--) RR[Q][J]+=RR[P][J]*T;
19999: K++;
20000: }
20001: if(K%5==0){
20002: if(!Nt) M=mtranspose(M);
20003: else if(!Conj&&K%2==0){
20004: for(F=0;F<S;F++){
20005: if((V=lgcd(M[F]))>1){
20006: for(L=0;L<S1;L++) M[F][L]/=V;
20007: }
20008: }
20009: }
20010: }
20011: if(I>Ct){
20012: for(L=S-1;L>=0;L--){
20013: for(F=0,J=S1-1;J>=0;J--)
20014: if(M[L][J]!=0) F++;
20015: if(F<2){
20016: F=-1;break;
20017: }
20018: else F=0;
20019: }
20020: if(F<0 && LL++<5){
20021: I=(CT-CT%2)/2;K=1;
20022: }
20023: if(I>Ct) break;
20024: }
20025: }
20026: if(RR){
20027: for(I=F=0;I<S1;I++){
20028: V=Res[I][I];
20029: for(J=I+1;J<S1;J++){
20030: if(Res[J][J]!=V) break;
20031: for(LP=0;LP<2;LP++){
20032: if(J==S1-1||Res[J][J+1]==0){
20033: if(I==0||Res[I-1][I]==0){
20034: for(VL=VS=[],K=0;K<S1;K++){
20035: VL=cons(RR[K][J],VL);VS=cons(RR[K][I],VS);
20036: }
20037: VR=ldev(VL,VS);
20038: if(VR[0]){
20039: for(K=S1-1,VN=VR[1];K>=0;K--,VN=cdr(VN))
20040: RR[K][J]=car(VN);
20041: F=1;
20042: }
20043: }
20044: }
20045: K=I;I=J;J=K;
20046: }
20047: }
20048: if(F&&I==S1-1){
20049: F=0;I=-1;
20050: }
20051: }
20052: if(getopt(int)==1){
20053: N=mtranspose(M);
20054: for(F=I=0;I<S1;I++) if(lgcd(M[I])>1||lgcd(N[I])>1) F++;
20055: if(F){
20056: for(F=I=0;I<S1;I++){
20057: if(Res[I][I]==-1) F=ior(F,1);
20058: else if(Res[I][I]==1) F=ior(F,2);
20059: }
20060: C=0;
20061: if(!iand(F,1)) C=1;
20062: else if(!iand(F,2)) C=-1;
20063: if(C){
20064: for(I=0;I<S1;I++){
20065: M[I][I]+=C;Res[I][I]+=C;
20066: }
20067: }
20068: }
20069: }
20070: if(getopt(rep)!=1){
20071: for(Lp=0;Lp<5;Lp++){
20072: F=(M==Res||abs(lmax(RR))>Xa*10||abs(lmin(RR))>Xa*10)?1:0;
20073: for(I=0;!F&&I<S1&&Lp<4;I++){
20074: for(K=L=J=0;J<S1;J++){
20075: if(M[I][J]) K++;
20076: if(M[J][I]) L++;
20077: }
20078: if(K<2||L<2) F=1;
20079: }
20080: if(!F) break;
20081: R=unim(S0|option_list=cons(["rep",1],getopt()));
20082: M=R[0];Res=R[1];RR=R[3];
20083: }
20084: }
20085: }
20086: if(Res==0) return M;
20087: if(RR){
20088: for(I=K=V=0;I<S1;I++){
20089: for(J=0;J<S1;J++){
20090: if(RR[J][I]>0) V++;
20091: else if(RR[J][I]<0) V--;
20092: }
20093: if(I<S1-1&&Res[I][I+1]!=0) continue;
20094: if(V<0){
20095: for(;K<=I;K++) RR=colm(RR,K,-1);
20096: }
20097: K=I+1;V=0;
20098: }
20099: }
20100: if(getopt(rep)!=1){
20101: if((F=getopt(dviout))==1){
20102: if(getopt(conj)==1){
20103: if(RR) show([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
20104: }else{
20105: if(type(Lim=getopt(lim))==1)
20106: mtoupper(M,0|step=1,opt=7,dviout=1,pages=1,lim=Lim);
20107: else mtoupper(M,0|step=1,opt=7,dviout=1,pages=1);
20108: }
20109: }else if(F==-1){
20110: if(getopt(conj)==1){
20111: if(RR) return ltotex([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
20112: }else{
20113: if(type(Lim=getopt(lim))==1)
20114: return mtoupper(M,0|step=1,opt=7,pages=1,lim=Lim,dviout=-1);
20115: else return mtoupper(M,0|step=1,opt=7,pages=1,dviout=-1);
20116: }
20117: }
20118: }
20119: if(RR==0) return[M,Res];
20120: return [M,Res,myinv(RR),RR];
20121: }
20122:
20123: def pfrac(F,X)
20124: {
20125: F = red(F);
20126: FN = nm(F);
20127: FD = dn(F);
20128: if(mydeg(FD,X) == 0)
20129: return [[F,1,1]];
20130: R = rpdiv(FN,FD,X);
20131: FN = R[0]/R[1];
20132: R0 = R[2]/R[1];
20133: FC = fctr(FD);
20134: RT=[];
20135: if(getopt(root)==2){
20136: for(FE=[],FT=FC;FT!=[];FT=cdr(FT)){
20137: if(mydeg(P=car(FT)[0],X)==4 && vars(P)==[X] && pari(issquare,C=mycoef(P,4,X))){
20138: if((S=mycoef(P,3,X)/4/C)!=0) P=subst(P,X,X-S);
20139: if(mycoef(P,1,X)==0 && pari(issquare,C0=mycoef(P,0,X))){
20140: C=sqrtrat(C);C0=sqrtrat(C0);C1=2*C*C0-mycoef(P,2,X);
20141: if(C1>0){
20142: FE=cons([C*(X+S)^2-C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
20143: FE=cons([C*(X+S)^2+C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
20144: RT=cons(C1,RT);
20145: continue;
20146: }
20147: }
20148: }
20149: FE=cons(car(FT),FE);
20150: }
20151: FC=reverse(FE);
20152: }
20153: N = Q = 0;
20154: L = [];
20155: for(I = length(FC)-1; I >= 0; I--){
20156: if((D = mydeg(FC[I][0],X)) == 0) continue;
20157: for(K=1; K<=FC[I][1]; K++){
20158: for(J=P=0; J < D; J++){
20159: V = makev(["zz_",++N]);
20160: P = P*X + V;
20161: L = cons(V,L);
20162: }
20163: Q += P/(FC[I][0]^K);
20164: Q = red(Q);
20165: }
20166: }
20167: L=reverse(L);
20168: Q = nm(red(red(Q*FD)-FN));
20169: Q = ptol(Q,X);
20170: S = lsol(Q,L);
20171: R = (R0==0)?[]:[[R0,1,1]];
20172: for(N=0,I=length(FC)-1; I >= 0; I--){
20173: if((D = mydeg(FC[I][0],X)) == 0) continue;
20174: for(K=1; K<=FC[I][1]; K++){
20175: for(P=J=0; J < D; N++,J++)
20176: P = P*X + S[N][1];
20177: if(P!=0) R = cons([P,FC[I][0],K],R);
20178: }
20179: }
20180: for(;RT!=[];RT=cdr(RT)){
20181: RTT=car(RT);
20182: R=mtransbys(os_md.substblock,R,[RTT^(1/2),(RTT^(1/2))^2,RTT]);
20183: }
20184: TeX=getopt(TeX);
20185: if((Dvi=getopt(dviout))==1||TeX==1){
20186: V=strtov("0");
20187: for(S=L=0,RR=R;RR!=[];RR=cdr(RR),L++){
20188: RT=car(RR);
20189: S+=(RT[0]/RT[1]^RT[2])*V^L;
20190: }
20191: if(TeX!=1) fctrtos(S|var=[V,""],dviout=1);
20192: else return fctrtos(S|var=[V,""],TeX=3);
20193: }
20194: return reverse(R);
20195: }
20196:
20197: def cfrac(X,N)
20198: {
20199: F=[floor(X)];
20200: if(N<0){
20201: Max=N=-N;
20202: }
20203: X-=F[0];
20204: if(Max!=1)
20205: M=mat([F[0],1],[1,0]);
20206: for(;N>0 && X!=0;N--){
20207: X=1/X;
20208: F=cons(Y=floor(X),F);
20209: X-=Y;
20210: if(Max){
20211: M0=M[0][0];M1=M[1][0];
20212: M=M*mat([Y,1],[1,0]);
20213: if(M[0][0]>Max) return M0/M1;
20214: }
20215: }
20216: return (Max==0)?reverse(F):M[0][0]/M[1][0];
20217: }
20218:
20219: def sqrt2rat(X)
20220: {
20221: if(type(X)>3) return X;
20222: X=red(X);
20223: if(getopt(mult)==1){
20224: for(V=vars(X);V!=[];V=cdr(V)){
20225: T=funargs(F=car(V));
20226: if(type(T)==4&&length(T)>1){
20227: Y=T[1];
20228: Z=sqrt2rat(Y);
20229: if(Y!=Z){
20230: if(length(T)==2){
20231: T0=T[0];
20232: X=subst(X,F,T0(Z));
20233: }else if(T[0]==pow)
20234: X=subst(X,F,Y^T[2]);
20235: }
20236: }
20237: }
20238: }
20239: for(V=vars(X);V!=[];V=cdr(V)){ /* r(x)^(1/2+n) -> r(x)^n*r(x)^(1/2) */
20240: T=args(Y=car(V));
20241: if(functor(Y)==pow&&T[1]!=1/2&&isint(T2=2*T[1])){
20242: if(iand(T2,1)){
20243: R=(T[0])^(1/2);T2--;
20244: }else R=1;
20245: R*=T[0]^(T2/2);
20246: X=red(subst(X,Y,R));
20247: }
20248: }
20249: D=dn(X);N=nm(X);
20250: if(imag(D)!=0){
20251: N*=conj(D);
20252: D*=conj(D);
20253: return sqrt2rat(N/D);
20254: }
20255: for(V=vars(N);V!=[];V=cdr(V)){ /* (r(x)^(n/m))^k */
20256: T=args(Y=car(V));
20257: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
20258: Dn=dn(T[1]);Nm=nm(T[1]);
20259: N=substblock(N,Y,Y^Dn,T[0]^Nm);
20260: }
20261: }
20262: for(V=vars(D);V!=[];V=cdr(V)){
20263: T=args(Y=car(V));
20264: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
20265: Dn=dn(T[1]);Nm=nm(T[1]);
20266: D=substblock(D,Y,Y^Dn,T[0]^Nm);
20267: }
20268: }
20269: for(V=vars(D);V!=[];V=cdr(V)){
20270: T=args(Y=car(V));
20271: if(functor(Y)==pow&&T[1]==1/2&&mydeg(D,Y)==1){
20272: N*=mycoef(D,0,Y)-mycoef(D,1,Y)*Y;
20273: N=mycoef(N,0,Y)+mycoef(N,1,Y)*Y+mycoef(N,2,Y)*T[0];
20274: D=mycoef(D,0,Y)^2-mycoef(D,1,Y)^2*T[0];
20275: X=red(N/D);
20276: D=dn(X);N=nm(X);
20277: break;
20278: }
20279: }
20280: X=red(N/D);
20281: D=dn(X);N=nm(X);
20282: for(V=vars(D);V!=[];V=cdr(V)){
20283: T=args(Y=car(V));
20284: if(functor(Y)==pow&&T[1]==1/2)
20285: D=substblock(D,T[0]^T[1],(T[0]^T[1])^2,T[0]);
20286: }
20287: for(V=vars(N);V!=[];V=cdr(V)){
20288: T=args(Y=car(V));
20289: if(functor(Y)==pow&&T[1]==1/2)
20290: N=substblock(N,T[0]^T[1],(T[0]^T[1])^2,T[0]);
20291: }
20292: for(V=vars(N);V!=[];V=cdr(V)){
20293: T=args(Y=car(V));
20294: if(functor(Y)==pow&&T[1]==1/2){
20295: Ag=T[0];
20296: R=S=1;
20297: An=fctr(nm(Ag));
20298: CA=An[0][0];
20299: if(CA<0){
20300: CA=-CA;R=-1;
20301: }
20302: if(type(I=sqrtrat(CA))<2) S=I;
20303: else R*=CA;
20304: for(An=cdr(An);An!=[];An=cdr(An)){
20305: Pw=car(An)[1];I=iand(Pw,1);
20306: if(I) R*=car(An)[0];
20307: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
20308: }
20309: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
20310: Pw=car(An)[1];I=iand(Pw,1);
20311: if(I) R/=car(An)[0]^I;
20312: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
20313: }
20314: if(S!=1) N=subst(N,Y,R^(1/2)*S);
20315: }
20316: }
20317: for(V=vars(N);V!=[];V=cdr(V)){
20318: T=args(Y=car(V));
20319: if(functor(Y)==pow&&T[1]==1/2){
20320: C=mycoef(N,1,Y);
20321: for(VC=vars(C);VC!=[];VC=cdr(VC)){
20322: TC=args(YC=car(VC));
20323: if(functor(YC)==pow&&TC[1]==1/2){
20324: Ag=red(T[0]*TC[0]);
20325: R=S=1;
20326: An=fctr(nm(Ag));
20327: CA=An[0][0];
20328: if(CA<0){
20329: CA=-CA;R=-1;
20330: }
20331: if(type(I=sqrtrat(CA))<2) S=I;
20332: else R*=CA;
20333: for(An=cdr(An);An!=[];An=cdr(An)){
20334: Pw=car(An)[1];I=iand(Pw,1);
20335: if(I) R*=car(An)[0];
20336: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
20337: }
20338: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
20339: Pw=car(An)[1];I=iand(Pw,1);
20340: if(I) R/=car(An)[0]^I;
20341: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
20342: }
20343: CC=mycoef(C,1,YC);
20344: N=N-CC*YC*Y+CC*R^(1/2)*S;
20345: }
20346: }
20347: }
20348: }
20349: return red(N/D);
20350: }
20351:
20352: def cfrac2n(X)
20353: {
20354: if(type(L=getopt(loop))==1&&L>0)
20355: C=x;
20356: else{
20357: C=0;L=0;
20358: }
20359: if(L>1){
20360: for(Y=[];L>1;L--){
20361: Y=cons(car(X),Y);
20362: X=cdr(X);
20363: }
20364: if(X!=[]){
20365: P=cfrac2n(X|loop=1);
20366: for(V=P,Y=reverse(Y);Y!=[];Y=cdr(Y))
20367: V=sqrt2rat(car(Y)+1/V);
20368: return V;
20369: }else{
20370: C=0;X=reverse(Y);
20371: }
20372: }
20373: for(V=C,X=reverse(X);X!=[];X=cdr(X)){
20374: if(V!=0) V=1/V;
20375: V+=car(X);
20376: }
20377: if(C!=0){
20378: V=red(V);P=dn(V)*x-nm(V);
20379: S=getroot(P,x|cpx=2);
20380: T=map(eval,S);
20381: V=(T[0]>0)?S[0]:S[1];
20382: }
20383: return V;
20384: }
20385:
20386: def s2sp(S)
20387: {
20388: if(getopt(short)==1){
20389: if(type(F=getopt(std))==1) S=s2sp(S|std=F);
20390: if(type(S)!=7) S=s2sp(S);
20391: L=strtoascii(S);
20392: for(LS=[],F=C=0;L!=[];L=cdr(L)){
20393: if((G=car(L))!=F){
20394: LS=cons(G,LS);C=0;
20395: }else if(C<3){
20396: LS=cons(G,LS);
20397: }else if(C==3){
20398: LS=cdr(LS);LS=cdr(LS);
20399: LS=cons(94,LS);LS=cons(52,LS);
20400: }else if(C==9){
20401: LS=cdr(LS);LS=cons(97,LS);
20402: }else{
20403: K=car(LS);LS=cdr(LS);LS=cons(K+1,LS);
20404: }
20405: C++;F=G;
20406: }
20407: return asciitostr(reverse(LS));
20408: }
20409: if(type(F=getopt(std))==1){
20410: F=(F>0)?1:-1;
20411: if(type(S)==7) S=s2sp(S);
20412: for(L=[];S!=[];S=cdr(S))
20413: L=cons(os_md.msort(car(S),[-1,0]),L);
20414: return os_md.msort(L,[F,2]);
20415: }
20416: if(type(S)==7){
20417: S = strtoascii(S);
20418: if(type(S) == 5) S = vtol(S);
20419: for(N=0,R=TR=[]; S!=[]; S=cdr(S)){
20420: if(car(S)==45) /* - */
20421: N=1;
20422: else if(car(S)==47) /* / */
20423: N=2;
20424: if(N>0){
20425: while(car(S)<48&&car(S)!=40) S=cdr(S);
20426: }
20427: if((T=car(S))>=48 && T<=57) TR=cons(T-48,TR);
20428: else if(T>=97) TR=cons(T-87,TR);
20429: else if(T>=65 && T<=90) TR=cons(T-29,TR); /* A-Z */
20430: else if(T==44){
20431: R=cons(reverse(TR),R);
20432: TR=[];
20433: }else if(T==94){ /* ^ */
20434: S=cdr(S);
20435: if(car(S)==40){ /* ( */
20436: S=cdr(S);
20437: for(T=0; car(S)!=41 && S!=[]; S=cdr(S)){
20438: V=car(S)-48;
20439: if(V>=10) V-=39;
20440: T=10*T+V;
20441: }
20442: }else{
20443: while(car(S)<48) S=cdr(S);
20444: T=car(S)-48;
20445: if(T>=10) T-=39;
20446: }
20447: while(--T>=1) TR=cons(car(TR),TR);
20448: }else if(T==40){ /* ( */
20449: S=cdr(S);
20450: if(N==1){
20451: N=0; NN=1;
20452: }else NN=0;
20453: if(car(S)==45){ /* - */
20454: S=cdr(S);
20455: NN=1-NN;
20456: }
20457: for(I=0; I<2; I++){
20458: for(V=0; (SS=car(S))!=41 && SS!=47 && S!=[]; S=cdr(S)){
20459: T=SS-48;
20460: if(T>=10) T-=39;
20461: V=10*V+T;
20462: }
20463: if(NN==1){
20464: V=-V; NN=0;
20465: }
20466: TR=cons(V,TR);
20467: if(SS!=47) break;
20468: else{
20469: N=2; S=cdr(S);
20470: }
20471: }
20472: }else if(T==60){
20473: for(V=[],S=cdr(S);S!=[]&&car(S)!=62;S=cdr(S))
20474: V=cons(car(S),V);
20475: if(car(S)!=62) continue;
20476: TR=cons(eval_str(asciitostr(reverse(V))),TR);
20477: }else if(T<48) continue;
20478: if(N==1){
20479: T = car(TR);
20480: TR=cons(-T,cdr(TR));
20481: N=0;
20482: }else if(N==2){
20483: T=car(TR); TR=cdr(TR);
20484: TR=cons(car(TR)/T,cdr(TR));
20485: N=0;
20486: }
20487: }
20488: return reverse(cons(reverse(TR),R));
20489: }else if(type(S)==4){
20490: Num=getopt(num);
20491: for(R=[]; ; ){
20492: if(type(TS=car(S))!=4) return;
20493: for(; TS!=[]; TS=cdr(TS)){
20494: V=car(TS);
20495: if(type(V)>1||(type(V)==1&&ntype(V)>0)){
20496: V="<"+rtostr(V)+">";
20497: R=append(reverse(strtoascii(V)),R);
20498: continue;
20499: }
20500: if(dn(V)>1){
20501: P=reverse(strtoascii(rtostr(V)));
20502: R=append(P,cons(40,R));
20503: R=cons(41,R);
20504: continue;
20505: }
20506: if(V<0 && V>-10){
20507: V=-V;
20508: R=cons(45,R);
20509: }
20510: if(V<0 || V>35 || (V>9 && Num==1)){
20511: P=reverse(strtoascii(rtostr(V)));
20512: R=append(P,cons(40,R));
20513: V=41;
20514: }else if(V<10) V+=48;
20515: else V+=87;
20516: R=cons(V,R);
20517: }
20518: if((S=cdr(S))==[]) break;
20519: R=cons(44,R);
20520: }
20521: return asciitostr(reverse(R));
20522: }
20523: return 0;
20524: }
20525:
20526: def sp2grs(M,A,L)
20527: {
20528: MM = [];
20529: T0 = 0;
20530: Mat=getopt(mat);
20531: if(Mat!=1) Mat=0;
20532: if(type(M)==7) M=s2sp(M);
20533: if((LM = length(M)) > 10 && type(A) < 4)
20534: CK = 1;
20535: Sft = (type(L)==1)?L:0;
20536: if(type(L)==4 && length(L)>=3)
20537: Sft = L[2];
20538: if(Sft < 0){
20539: T0 = 1;
20540: Sft = -Sft-1;
20541: }
20542: for(I = LM-1; I >= 0; I--){
20543: MI = M[I]; MN = [];
20544: if(CK == 1 && length(MI) > 10){
20545: erno(1);
20546: return;
20547: }
20548: if(type(A) == 4)
20549: AA = rtostr(A[I]);
20550: else
20551: AA = rtostr(A)+rtostr(I);
20552: for(J = LM = length(MI)-1; J >= 0; J--){
20553: V = MI[J];
20554: if(type(V) > 3)
20555: V = V[0];
20556: if(T0 == 0 || I == 0)
20557: MN = cons([V, makev([AA,J+Sft])], MN);
20558: else{
20559: if(LM == 1)
20560: MN = cons([V, (J==0)?0:makev([AA])], MN);
20561: else if(I == 1 && Mat == 0)
20562: MN = cons([V, (J==length(MI)-1)?0:makev([AA,J+Sft])], MN);
20563: else
20564: MN = cons([V, (J==0)?0:makev([AA,J])], MN);
20565: }
20566: }
20567: MM = cons(MN, MM);
20568: }
20569: if(type(L) == 4 && length(L) >= 2){
20570: R = chkspt(MM|mat=Mat); /* R[3]: Fuchs */
20571: AA = var(MM[L[0]-1][L[1]-1][1]);
20572: if(AA==0) AA=var(R[3]);
20573: if(AA!=0 && (P = mycoef(R[3],1,AA))!=0){
20574: P = -mycoef(R[3], 0, AA)/P;
20575: MM = mysubst(MM,[AA,P]);
20576: }
20577: }
20578: return MM;
20579: }
20580:
20581: def intpoly(F,X)
20582: {
20583: if((T=ptype(F,X))<4){
20584: if(T<3){ /* polynomial */
20585: if(type(C=getopt(cos))>0){
20586: V=vars(F);
20587: Z=makenewv(V);
20588: W=makenewv(cons(Z,V));
20589: Q=intpoly(F,X|exp=Z);
20590: Q=(subst(Q,Z,@i*C)*(Z+@i*W)+subst(Q,Z,-@i*C)*(Z-@i*W))/2;
20591: return [mycoef(Q,1,Z),mycoef(Q,1,W)];
20592: }
20593: if(type(C=getopt(sin))>0){
20594: Q=intpoly(F,X|cos=C);
20595: return [-Q[1],Q[0]];
20596: }
20597: if(type(C=getopt(log))>0){
20598: Q=intpoly(F,X);
20599: if(C[0]==0) return [Q,0];
20600: if(length(C)<3) C=[C[0],C[1],1];
20601: Q-=subst(Q,X,-C[1]/C[0]);
20602: if(iscoef(Q,os_md.israt)) Q=red(Q);
20603: if(C[2]==0) return [Q];
20604: S=subst(-Q*C[0]*C[2],X,X-C[1]/C[0]);
20605: for(R=0,D=mydeg(S,X);D>0;D--) R+=mycoef(S,D,X)*X^(D-1);
20606: R=subst(R,X,X+C[1]/C[0]);
20607: return cons(Q,intpoly(R,X|log=[C[0],C[1],C[2]-1]));
20608: }
20609: if(type(C=getopt(exp))>0){
20610: D = mydeg(F,X);
20611: for(P=Q=F/C;D>=0;D--){
20612: Q=-mydiff(Q,X)/C;
20613: P+=Q;
20614: }
20615: return P;
20616: }
20617: for(P=0,I=mydeg(F,X);I >= 0;I--)
20618: P += mycoef(F,I,X)*X^(I+1)/(I+1);
20619: return P;
20620: }
20621: R=pfrac(F,X|root=2); /* rational */
20622: for(P=0;R!=[];R=cdr(R)){
20623: if(type(V=getopt(dumb))==5){
20624: for(PF=[],RR=R;RR!=[];RR=cdr(RR))
20625: PF=cons(RR[0][0]/RR[0][1]^RR[0][2],PF);
20626: PF=[cons(X,reverse(PF))];
20627: if(P) PF=cons([1,P],PF);
20628: V[0]=cons(PF,V[0]);
20629: }
20630: RT=car(R);
20631: if(mydeg(RT[1],X)==0) P+=intpoly(RT[0]*RT[2],X);
20632: else if((Deg=mydeg(RT[1],X))==1){
20633: if(RT[2]>1) P+=RT[0]*RT[1]^(1-RT[2])/(1-RT[2])/mycoef(RT[1],1,X);
20634: else P+=RT[0]*log(RT[1])/mycoef(RT[1],1,X);
20635: P=red(P);
20636: }else if(Deg==2){
20637: D1=diff(RT[1],X);C1=mycoef(D1,1,X);
20638: B=2*C1*mycoef(RT[1],0,X)-mycoef(RT[1],1,X)^2; /* ax^2+bx+c => B=4ac-b^2 */
20639: B=sqrt2rat(B);
20640: N=RT[0];
20641: for(I=RT[2];I>0&&N!=0;I--){
20642: C0=mycoef(N,1,X)/C1;N-=C0*D1;
20643: if(C0){
20644: if(I>1) P-=C0/RT[1]^(I-1)/(I-1);
20645: else P+=C0*log(RT[1]);
20646: }
20647: if(I>1){
20648: BB=B/C1;
20649: P+=N*X/RT[1]^(I-1)/(I-1)/BB;
20650: N*=(2*I-3)/(I-1)/BB;
20651: }else{
20652: if(type(BR=sqrtrat(B))>3){
20653: mycat(["Cannot obtain sqare root of ",B]);
20654: return [];
20655: }
20656: if(real(nm(BR))!=0){
20657: P+=(2*N/BR)*atan(sqrt2rat(D1/BR|mult=1));
20658: }else{
20659: BR*=@i;BRI=sqrt2rat(1/BR);
20660: R1=(-mycoef(RT[1],1,X)+BR)/C1;
20661: R2=(-mycoef(RT[1],1,X)-BR)/C1;
20662: P+=N*BRI*log( /* sqrt2rat */((x-R1)/(x-R2)));
20663: }
20664: }
20665: P=red(P);
20666: }
20667: P=sqrt2rat(P);
20668: }else{
20669: mycat(["Cannot get an indefinite integral of ",F]);
20670: return [];
20671: }
20672: }
20673: Q=simplog(P,X);
20674: if(type(V)==5&&nmono(P)!=nmono(Q)) V[0]=cons([[1,red(P)]],V[0]);
20675: return red(Q);
20676: }
20677: return [];
20678: }
20679:
20680: def fshorter(P,X)
20681: {
20682: Q=sqrt2rat(P);
20683: R=trig2exp(Q,X|inv=1);
20684: if(str_len(fctrtos(R))<str_len(fctrtos(Q))) Q=R;
20685: Var=pfargs(Q,X|level=1);
20686: for(C=F=0,R=1,V=Var;V!=[];V=cdr(V)){
20687: if(findin(car(V)[1],[cos,sin,tan])>=0){
20688: if(!C){
20689: F=car(V)[2];
20690: }else{
20691: R=red(car(V)[2]/F);
20692: if(type(R)!=1) break;
20693: F/=dn(R);
20694: }
20695: C++;
20696: }
20697: }
20698: if(getopt(period)==1) return F;
20699: if(!isint(Log=getopt(log))) Log=0;
20700: if(V==[]&&F!=0){
20701: if(iand(Log,1)){
20702: H=append(cdr(fctr(nm(Q))),cdr(fctr(dn(Q))));
20703: for(L=0;H!=[];H=cdr(H))
20704: L+=str_len(rtostr(car(H)[0]));
20705: }else L=str_len(fctrtos(Q));
20706: S=trig2exp(P,X);
20707: for(T=[sin(F),tan(F),cos(F),sin(F/2),cos(F/2),tan(F/2)];T!=[];T=cdr(T)){
20708: R=trig2exp(S,X|inv=car(T));
20709: if(iand(Log,1)){
20710: H=append(cdr(fctr(nm(R))),cdr(fctr(dn(R))));
20711: for(K=0;H!=[];H=cdr(H))
20712: K+=str_len(rtostr(car(H)[0]));
20713: }else K=str_len(fctrtos(R));
20714: if(K<L){
20715: Q=R;L=K;
20716: }
20717: }
20718: }
20719: return Q;
20720: }
20721:
20722: def isshortneg(P)
20723: {
20724: return(str_len(rtostr(P))>str_len(rtostr(-P)))?1:0;
20725: }
20726:
20727: def simplog(R,X)
20728: {
20729: for(V=[],Var=pfargs(R,X);Var!=[];Var=cdr(Var)){
20730: VT=car(Var);
20731: if(VT[1]==log && ptype(R,VT[0])==2 && mydeg(R,VT[0])==1)
20732: V=cons([VT[0],VT[2],mycoef(R,1,VT[0])],V);
20733: }
20734: for(;V!=[];V=cdr(V)){
20735: VT=car(V);
20736: for(V2=cdr(V);V2!=[];V2=cdr(V2)){
20737: Dn=1;
20738: if((C=red(car(V2)[2]/VT[2]))!=1&&C!=-1){
20739: if(getopt(mult)==1&&type(C)==1&&ntype(C)==0){
20740: Dn=dn(C);C*=Dn;
20741: }else continue;
20742: }
20743: Log=red(VT[1]^Dn*car(V2)[1]^(Dn*C));
20744: L=str_len(rtostr(dn(Log)))-str_len(rtostr(nm(Log)));
20745: if(L>0 || (L==0&&isshortneg(VT[2])) ){
20746: Dn=-Dn;Log=1/Log;
20747: }
20748: R=mycoef(R,0,VT[0]);R=mycoef(R,0,car(V2)[0]);
20749: return(R+VT[2]*log(Log)/Dn);
20750: }
20751: }
20752: return R;
20753: }
20754:
20755: def integrate(P,X)
20756: {
20757: Dvi=getopt(dviout);
20758: if(type(I=getopt(I))==4){
20759: if((R=integrate(P,X))==[]) II="?";
20760: else if(type(I[0])>3||type(I[1])>3){
20761: R=subst(R,X,x);
20762: V=flim(R,I[0]);VV=flim(R,I[1]);
20763: if(V==""||VV=="") II="?";
20764: else if(type(V)==7||type(VV)==7){
20765: if(V==VV) II="?";
20766: else II=(VV=="+"||V=="-")?"\\infty":"-\\infty";
20767: }else{
20768: II=VV-V;
20769: if(II>10^10) II="\\infty";
20770: else if(II<-10^10) II="-\\infty";
20771: }
20772: }else{
20773: V=subst(R,X,I[1])-subst(R,X,I[0]);
20774: VV=myval(V);
20775: II=(type(VV)>=2||ntype(VV)<1)?VV:evalred(V);
20776: }
20777: if(type(Dvi)!=1) return II;
20778: I=ltov(I);
20779: for(J=0;J<2;J++){
20780: if(type(I[J])>3){
20781: if(type(I[J])==4&&length(I[J])>1) I[J]=I[J][1];
20782: else I[J]=(J==0)?"-\\infty":"\\infty";
20783: }
20784: if(type(I[J])<4) I[J]=my_tex_form(I[J]);
20785: }
20786: S=(type(II)==7)?II:my_tex_form(II);
20787: S="\\int_{"+I[0]+"}^{"+I[1]+"}"+monototex(P)+"\\,d"+my_tex_form(X)+"&="+S;
20788: if(Dvi==1) dviout(texbegin("align",S));
20789: return S;
20790: }
20791: if(isint(Dvi)==1){
20792: if(Dvi==2||getopt(dumb)==-1){
20793: V=newvect(1);V[0]=[];
20794: }else V=0;
20795: if((RR=integrate(P,X|dumb=V))==[]) return R;
20796: S=fshorter(RR,X);
20797: VV=[X];
20798: if(V!=0){
20799: R=cons([[1,RR]],V[0]);
20800: if(S!=RR) R=cons([[1,RR=S]],R);
20801: for(V=FR=[];R!=[];R=cdr(R))
20802: if(car(R)!=FR) V=cons(FR=car(R),V);
1.21 takayama 20803: Var=varargs(V|all=2);
1.6 takayama 20804: for(S0=[x0,x1,x2,x3],S=[t,s,u,v,w];S0!=[]&&S!=[];){
20805: if(findin(car(S0),Var)<0){
20806: S0=cdr(S0); continue;
20807: }
20808: if(findin(car(S),Var)>=0){
20809: S=cdr(S); continue;
20810: }
20811: V=subst(V,[car(S0),car(S)]);S0=cdr(S0);S=cdr(S);
20812: }
20813: if(Dvi==-2) return V;
20814: S1="\\,dx&";
20815: }else{
20816: V=[[],[[1,RR=S]]];
20817: S1="\\,dx";
20818: }
20819: if(type(P)>2){
20820: if(type(nm(P))<2){
20821: P=P*dx;S1=V?"&":"";
20822: }
20823: S=fctrtos(P|TeX=2,lim=0);SV0=my_tex_form(P);
20824: if(str_len(SV0)<str_len(S)) S=SV0;
20825: }else S=monototex(P);
20826: if(Dvi!=-2) S="\\int "+S+S1;
20827: else S="";
20828: for(L=[],V=cdr(V);V!=[];V=cdr(V)){
20829: CL=car(V);S0=["="]; /* a line */
20830: for(FL=0;CL!=[];CL=cdr(CL),FL++){
20831: CT=car(CL); /* a term */
20832: if((Y=CT[0])==0){ /* a variable */
20833: CT=cdr(CT);
20834: if(length(CT)>2) CT=cdr(CT);
20835: S0=["\\qquad(",CT[0],"=",CT[1],")"];
20836: break;
20837: }else{
20838: for(FT=0,S2=[],CT=cdr(CT);CT!=[];CT=cdr(CT),FT++){
20839: SV=fctrtos(car(CT)|TeX=2,lim=0);SV0=my_tex_form(car(CT));
20840: if(str_len(SV0)<str_len(SV)) SV=SV0;
20841: if(FL||FT||(F&&type(Y)<2)) SV=minustos(SV);
20842: S2=append(["+",SV],S2);
20843: }
20844: S2=reverse(cdr(S2));
20845: if(type(Y)>1){
20846: if(length(S2)>1){
20847: S1="\\int\\left(";S3="\\right)\\,d";
20848: }else{
20849: S1="\\int";S3="\\,d";
20850: }
20851: S2=cons(S1,append(S2,[S3,Y]));
20852: if(findin(Y,VV)<0) VV=cons(Y,VV);
20853: }
20854: if(FL) S0=append(S0,cons("+",S2));
20855: else S0=append(S0,S2);
20856: }
20857: }
20858: L=append([S0],L);
20859: };
20860: V=pfargs(RR,X|level=1);
20861: for(Var=[];V!=[];V=cdr(V)) Var=cons(car(V)[0],Var);
20862: Var=reverse(Var);
20863: if(!isint(J=getopt(frac))) J=0;;
20864: if(!iand(J,4)&&(!iand(J,2)||length(Var)==1)&&(iand(J,8)==8||ptype(RR,Var)==2)){
20865: F=1;
20866: if(iand(J,1)){
20867: K=str_len(fctrtos(RR));
20868: I=str_len(fctrtos(RR|var=Var));
20869: if(I>=K) F=0;
20870: }
20871: if(F){
20872: V=[fctrtos(RR|var=Var,TeX=2)];
20873: if(Dvi!=-2) V=cons("=",V);
20874: if(length(L)>0) L=cdr(L);
20875: L=append([V],L);
20876: }
20877: }else if(ptype(RR,X)==2){
20878: L=cdr(L);
20879: V=[fctrtos(RR|var=X,TeX=2)];
20880: if(Dvi!=-2) V=cons("=",V);
20881: L=append([V],L);
20882: }
20883: S=texket(S+ltotex(reverse(L)|opt=["cr","spts0"],str=1));
20884: if(getopt(log)!=1){
20885: for(V=[];VV!=[];VV=cdr(VV))
20886: V=cons(strtoascii(my_tex_form(car(VV))),V);
20887: S1=strtoascii("\\log");
20888: for(F=1;F;){ /* log(log(x)) */
20889: F=FT=0;
20890: S0=strtoascii(S); /* log(x) -> log|x| */
20891: L=length(S0);
20892: S2=str_tb(0,0);
20893: for(I=0;;){
20894: if(I>=L||(J=str_str(S0,S1|top=I+FT))<0){
20895: S=str_tb(0,S2)+str_cut(S0,I,100000);
20896: break;
20897: }
20898: if((K=str_str(S0,40|top=J+4))<0
20899: ||(K!=J+4&&K!=J+9)||(N=str_pair(S0,K+1,40,41))<0){
20900: FT=J-I+4;continue;
20901: }
20902: FT=0;
20903: if(str_str(S0,V|top=K+1,end=N-1)[0]<0) S2=str_tb(str_cut(S0,I,N),S2);
20904: else{
20905: /* log(a) -> log(a) */
20906: F=1;
20907: if(N<L-1&&S0[N+1]==94){ /* log(x)^2 -> (log|x|)^2 */
20908: S2=str_tb([str_cut(S0,I,J-1),"\\left(",str_cut(S0,J,K-1),
20909: "|",str_cut(S0,K+1,N-1),"|\\right)"],S2);
20910: }
20911: else S2=str_tb([str_cut(S0,I,K-1),"|",str_cut(S0,K+1,N-1),"|"],S2);
20912: }
20913: I=N+1;
20914: }
20915: }
20916: }
20917: if(Dvi>0){
20918: dviout(texbegin("align*",S));
20919: return 1;
20920: }
20921: return S;
20922: } /* end of dviout */
20923: SM=["Cannot integrate",P,"at present"];
20924: P=sqrt2rat(P|mult=1);
20925: Dumb2=1;Dumb3=0;W=newvect(1);W[0]=[];
20926: if(type(Dumb=getopt(dumb))==5){
20927: Dumb2=Dumb3=Dumb;D2=W;
20928: }else if(!isint(Dumb)) Dumb=0;
20929: if(Dumb==-1){
20930: Dumb2=Dumb3=-1;
20931: }
20932: if(type(Dumb)!=5) D2=Dumb2;
20933: if(!isint(Mul=getopt(mult))) Mul=0;
20934: else Mul++;
20935: if(type(VAR=getopt(var))!=4) VAR=[];
20936: if(type(P)>4) return [];
20937: if(iand(T=ptype(P=red(P),X),63)>3||Mul>4){
20938: if(Dumb!=1) mycat(SM);
20939: return [];
20940: }
20941: if(Dumb==-1) mycat(["integrate", P]);
20942: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
20943: if(T<4 && (T<3||iscoef(P,os_md.israt))){
20944: if(Dumb==-1) mycat(["rational function",P]);
20945: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
20946: return intpoly(P,X|dumb=Dumb); /* rational function */
20947: }
20948: Var=pfargs(P,X);
20949: for(F=0,VV=Var;VV!=[];VV=cdr(VV)){
20950: /* p(x)*log(x^2-1), @e^x, a^x, f(x)^(m/n) etc.->simplify */
20951: V=car(VV);
20952: if(V[1]==log && (T=ptype(V[2],X))>1 && T<4){
20953: if(mydeg(dn(V[2]),X)>0||mydeg(nm(V[2]),X)>1){
20954: FC=pfctr(V[2],X);RV=1;
20955: if(length(FC)>2){
20956: RR=0;RV=1;
20957: if((F0=car(FC)[0])!=1){
20958: if(type(F0)!=1 && F0<0){
20959: for(FT=cdr(FT);FT!=[];FT=cdr(FT)){
20960: if(iand(car(FT)[1],1)){
20961: RV=-1;F0=-F0;break;
20962: }
20963: }
20964: }
20965: }
20966: if(F0!=1) RR=log(F0);
20967: for(FC=cdr(FC);FC!=[];FC=cdr(FC)){
20968: if(RV==-1&&iand(car(FC)[1],1)==1){
20969: RR+=car(FC)[1]*log(-car(FC)[0]);
20970: RV=1;
20971: }else
20972: RR+=car(FC)[1]*log(car(FC)[0]);
20973: }
20974: P=subst(P,V[0],RR);
20975: F=1;
20976: }
20977: }
20978: F=1;
20979: }else if(V[1]==pow){
20980: if(ptype(V[2],X)==1){
20981: F=1;
20982: if(V[2]==@e){ /* @e^(f(x)) */
20983: P=subst(P,V[0],exp(V[3]));
20984: }else P=subst(P,V[0],exp(log(V[2])*V[3]));
20985: }else if(type(V[3])<=1 && ntype(V[3])==0){ /* r(x)^(m/n) */
20986: if((Pw=floor(V[3]))!=0){
20987: R=V[2]^Pw;
20988: if((PF=V[3]-Pw)!=0) R*=V[2]^PF;
20989: P=subst(P,V[0],R);
20990: F=1;
20991: V=[V[2]^PF,V[1],V[2],PF];
20992: }
20993: if(ptype(nm(V[2]),X)<2&&V[3]>0){ /* (1/p(x))^(m/n) */
20994: P=subst(P,V[0],V[2]*red(1/V[2])^(1-V[3]));
20995: F=0;VV=cons(0,Var=pfargs(P,X));continue;
20996: }
20997: if(ptype(V[2],X)<4&&(K=dn(V[3]))>1){
20998: V2=red(V[2]);
20999: DN=mydeg(nm(V2),X);DD=mydeg(dn(V2),X);
21000: if(DN+DD>1){
21001: VF=pfctr(V2,X);
21002: R=car(VF)[0]^(car(VF)[1]);RR=0;
21003: for(VF=cdr(VF);VF!=[];VF=cdr(VF)){
21004: TV=car(VF);TM=TV[1];
21005: while(abs(TM)>=K){
21006: RR=1;
21007: if(TM>0){
21008: TM-=K;
21009: RR*=TV[0]^nm(V[3]);
21010: }else{
21011: TM+=K;
21012: RR/=TV[0]^nm(V[3]);
21013: }
21014: }
21015: if(TM!=0) R*=TV[0]^TM;
21016: }
21017: if(RR){
21018: P=subst(P,V[0],RR*red(R)^(V[3]));F=1;
21019: F=0;VV=cons(0,Var=pfargs(P,X));continue;
21020: }
21021: }
21022: }
21023: }
21024: }
21025: }
21026: if(F){
21027: P=sqrt2rat(P|mult=1);
21028: Var=pfargs(P=red(P),X);T=ptype(P,X);
21029: if(T<4 && (T<3||iscoef(P,os_md.israt))){
21030: if(Dumb==-1) mycat(["rational function",P]);
21031: else if(type(Dumb)==5){
21032: Dumb[0]=cons([[X,P]],Dumb[0]);
21033: return intpoly(P,X|dumb=Dumb3);
21034: }
21035: return intpoly(P,X); /* rational function */
21036: }
21037: }
21038: #if 1
21039: for(P0=P,V=pfargs(P,X|level=1);V!=[];V=cdr(V)) /* P:tan(x) -> P0:sin(x)/cos(x) */
21040: if(car(V)[1]==tan) P0=red(subst(P0,car(V)[0],sin(car(V)[2])/cos(car(V)[2])));
21041: if(iand(ptype(P0,X),128)){ /* (log f)'=f'/f */
21042: for(Df=cdr(fctr(dn(P0)));Df!=[];Df=cdr(Df)){
21043: if(!iand(ptype(car(Df)[0],X),64)) continue;
21044: Q=car(Df)[0]^(car(Df)[1]);QQ=red(dn(P0)/Q);
21045: DQ=red(diff(Q,X)*QQ);
21046: if(type(C=DQ/nm(P0))<2&&C!=0){
21047: PP=0;DN=[1];
21048: }else for(DN=cdr(fctr(DQ));DN!=[];DN=cdr(DN)){
21049: Y=car(DN)[0];
21050: if(!iand(ptype(Y,X),64)||(I=mydeg(nm(P0),Y))!=mydeg(DQ,Y)
21051: || ptype((C=red(mycoef(nm(P0),I,Y)/mycoef(DQ,I,Y))),X)>1||C==0) continue;
21052: PP=red(P0-C*diff(Q,X)/Q);
21053: if(nmono(P0)>nmono(PP)) break;
21054: }
21055: if(DN!=[]){
21056: R=C*log(Q);
21057: if(PP==0){
21058: if(P!=P0&&type(Dumb)==5) Dumb[0]=cons([[X,P0]],Dumb[0]);
21059: return R;
21060: }
21061: W[0]=[];
21062: S=integrate(PP,X|dumb=D2);
21063: if(S!=[]){
21064: if(type(Dumb)==5){
21065: Dumb[0]=cons([[X,red(P0-PP),PP]],Dumb[0]);
21066: TD=W[0];
21067: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21068: if(car(TD)[0][0]){
21069: WL=cons([1,R],car(TD));
21070: Dumb[0]=cons(WL,Dumb[0]);
21071: }
21072: else Dumb[0]=cons(car(TD),Dumb[0]);
21073: }
21074: }
21075: return red(R+S);
21076: }
21077: }
21078: }
21079: }
21080: #endif
21081: if((length(Var)==1||getopt(exe)==1) && /* p(x)*atan(q(x))^m+r(x), etc */
21082: findin((VT=car(Var))[1],[atan,asin,acos,log])>=0 && ptype(P,VT[0])==2 &&
21083: (VT[1]!=log||(T!=65&&T!=66)||mydeg(VT[2],X)!=1)){ /* exclude x*log(x+1)^2 */
21084: for(R=0,D=mydeg(P,VT[0]);D>=0;D--){
21085: Q=S=mycoef(P,D,VT[0]);
21086: if(S){
21087: if(D>0){
21088: if((Q=integrate(S,X|mult=Mul))==[]) return Q;
21089: }else{
21090: W[0]=[];
21091: if((Q=integrate(S,X|dumb=D2,var=VAR,mult=Mul))==[]) return Q;
21092: if(type(Dumb)==5){
21093: TD=W[0];
21094: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21095: if(car(TD)[0][0]){
21096: WL=cons([1,R],car(TD));
21097: Dumb[0]=cons(WL,Dumb[0]);
21098: }
21099: else Dumb[0]=cons(car(TD),Dumb[0]);
21100: }
21101: if(car(Dumb[0])!=[[1,R],[1,Q]])
21102: Dumb[0]=cons([[1,R,Q]],Dumb[0]);
21103: }
21104: return red(R+Q);
21105: }
21106: }else if(D>0) continue;
21107: if(D==0){
21108: if(Q!=0&&type(Dumb)==5) Dumb[0]=cons([[1,R,Q]],Dumb[0]);
21109: return red(Q+R);
21110: }
21111: R0=Q*VT[0]^D;
21112: P=(P0=P)-S*VT[0]^D-Q*diff(VT[0]^D,X);
21113: if(mydeg(P,VT[0])>=D){ /* (x+1)*log(x)/x^2 */
21114: if(mydeg(P,VT[0])==D &&
21115: ptype(C=red(mycoef(P,D,VT[0])/diff(VT[0],X)),VT[0])<2){
21116: P=P0-(S*VT[0]^D+Q*diff(VT[0]^D,X)+C*diff(VT[0]^(D+1),X)/(D+1));
21117: R0+=C*VT[0]^(D+1)/(D+1);
21118: }else{
21119: P=P0;
21120: if(Dumb!=1) mycat(SM);
21121: return [];
21122: }
21123: }
21124: if(type(Dumb)==5){
21125: if(P) Dumb[0]=cons([R?[1,R,R0]:[1,R0],[X,P]],Dumb[0]);
21126: else if(R!=0) Dumb[0]=cons([[1,R,R0]],Dumb[0]);
21127: }
21128: R+=R0;
21129: }
21130: }
21131: if(length(Var)==1 && (VT=car(Var))[1]==pow && mydeg(P,VT[0])==1 && (PT=ptype(VT[2],X))<4){
21132: PR=mycoef(P,0,VT[0]);
21133: if(RR!=0){
21134: RR=integrate(RR,X|dumb=Dumb3,var=Var);
21135: if(RR==[]) return RR;
21136: }
21137: PW=VT[3];
21138: if((D=mydeg(nm(V2=VT[2]),X))==2&&PT==2){ /* f(x)*(ax^2+bx+c)^(m/2)+r(x) */
21139: if(isint(2*PW)){
21140: C2=mycoef(V20=V2,2,X);F=1;
21141: if((C21=sqrtrat(C2))==[]) return [];
21142: if(imag(C21)!=0){
21143: if(real(C21)!=0) return [];
21144: C21=C21/@i;F=-1;
21145: }
21146: if(type(C21)>3) return [];
21147: P=subst(P,X,X/C21);VT=mysubst(VT,[X,X/C21]);V2=VT[2];
21148: C1=mycoef(V2,1,X)/F/2;
21149: if(C1!=0){
21150: P=subst(P,X,X-C1);VT=mysubst(VT,[X,X-C1]);V2=VT[2];
21151: }
21152: C0=mycoef(V2,0,X);
21153: if((C01=sqrtrat(C0))==[]) return [];
21154: if(imag(nm(C01))!=0){
21155: if(real(nm(C01))!=0) return [];
21156: C01=C01/@i;G=-1;
21157: }else G=1;
21158: if(type(C01)>3||(F==-1&&G==-1)) return [];
21159: Y=makenewv([P,VAR]|var=x);
21160: if(F==-1){ /* (c^2-x^2)^(1/2) */
21161: Q=subst(P,VT[0],(C01*cos(Y))^(2*PW),X,YX=C01*sin(Y))
21162: *C01*cos(Y)/C21;
21163: SY=(C21*X+C1);CY=V20;YY=asin(sqrt2rat((C21*X+C1)/C01|mult=1));
21164: }else if(G==-1){ /* (x^2-c^2)^(1/2) */
21165: Q=subst(P,VT[0],(C01*sin(Y)/cos(Y))^(2*PW),X,YX=C01/cos(Y))
21166: *C01*sin(Y)/cos(Y)^2/C21;
21167: SY=V20;CY=1/(C21*X+C1);YY=acos(sqrt2rat(C01*(C21*X+C1)|mult=1));
21168: }else{ /* (x^2+c^2)^(1/2) */
21169: Q=subst(P,VT[0],(C01/cos(Y))^(2*PW),X,YX=C01*sin(Y)/cos(Y))
21170: *C01/cos(Y)^2/C21;
21171: CY=V20; YY=atan(sqrt2rat((C21*X+C1)/C01|mult=1));
21172: }
21173: if(Dumb==-1) mycat([C21*X+C1,"=",YX]);
21174: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,C21*X+C1,YX]],Dumb[0]);
21175: Q=sqrt2rat(Q);
21176: QQ=red(substblock(nm(Q),sin(Y),sin(Y)^2,1-cos(Y)^2)
21177: /substblock(dn(Q),sin(Y),sin(Y)^2,1-cos(Y)^2));
21178: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
21179: QQ=red(substblock(nm(Q),cos(Y),cos(Y)^2,1-sin(Y)^2)
21180: /substblock(dn(Q),cos(Y),cos(Y)^2,1-sin(Y)^2));
21181: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
21182: if((Q=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var)))==[]) return [];
21183: Q=trig2exp(Q,Y|inv=cos(Y));
21184: for(V=vars(Q);V!=[];V=cdr(V)){
21185: FA=funargs(car(V));
21186: if(type(FA)==4&&FA[0]==log){
21187: QQ=trig2exp(FA[1],Y|inv=cos(Y));
21188: Q=mycoef(Q,0,car(V))+mycoef(Q,1,car(V))*log(QQ);
21189: }
21190: }
21191: if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21192: if(F==-1) Q=subst(Q,sin(Y),SY/C01,cos(Y),CY^(1/2)/C01,Y,YY);
21193: else if(G==-1){
21194: Q=red(subst(Q,sin(Y),SY^(1/2)*cos(Y)/C01));
21195: Q=red(subst(Q,cos(Y),C01*CY,Y,YY));
21196: }else{
21197: Q=red(subst(Q,sin(Y),(C21*X+C1)*cos(Y)/C01));
21198: Nm=substblock(nm(Q),cos(Y),C01^2/CY,cos(Y)^2);
21199: Nm=subst(Nm,cos(Y),C01/CY^(1/2));
21200: Dn=substblock(dn(Q),cos(Y),C01^2/CY,cos(Y)^2);
21201: Dn=subst(Dn,cos(Y),C01/CY^(1/2));
21202: Q=red(subst(Nm/Dn,Y,YY));
21203: }
21204: if(findin(Y,vars(Q))>=0) return [];
21205: for(R=[],Var=vars(Q);Var!=[];Var=cdr(Var)){
21206: VT=funargs(V=car(Var));
21207: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60&&mydeg(Q,V)==1)
21208: R=cons([mycoef(Q,1,V),V],R);
21209: }
21210: if(length(R)==2 && (R[0][0]==R[1][0]||R[0][0]+R[1][0]==0)){
21211: R0=args(R[0][1])[0];R1=args(R[1][1])[0];
21212: if(R[0][0]==R[1][0]) S=R0*R1;
21213: else S=R1/R0;
21214: Q=mycoef(Q,0,R[0][1]);Q=mycoef(Q,0,R[1][1]);
21215: Q+=R[1][0]*log(red(S));
21216: }
21217: for(Var=vars(Q);Var!=[];Var=cdr(Var)){
21218: VT=funargs(car(Var));
21219: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60){
21220: S=trig2exp(VT[1],X|inv=cos(X),arc=1);
21221: if(ptype(dn(S),X)<2 && mydeg(Q,car(Var))==1
21222: && ptype(mycoef(Q,1,car(Var)),X)<2){
21223: S=nm(S);
21224: SF=fctr(S);
21225: S/=SF[0][0];
21226: }
21227: if(cmpsimple(S,-S)>0) S=-S;
21228: Q=subst(Q,car(Var),log(S));
21229: }
21230: } /* x/(1-x^2)^(1/2) */
21231: if(type(Q=red(Q+RR))==2&&type(Dumb)!=5) Q-=cterm(Q);
21232: if(Dumb==-1) mycat(["->",Q]);
21233: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21234: return Q;
21235: }
21236: }else if(D==1 && mydeg(Dn=dn(V2),X)<2 && type(PW)==1 && ntype(PW)==0 &&
21237: (V2!=X||ptype(mycoef(P,1,VT[0]),X)>2)){ /* p(x)((ax+b)/(cx+d))^(m/n) */
21238: PN=nm(PW);PD=dn(PW);
21239: Y=makenewv([P,VAR]|var=x);Q=Y^PD*Dn-nm(V2);F=-mycoef(Q,0,X)/mycoef(Q,1,X);
21240: Q=red(subst(P,VT[0],Y^PN,X,F)*diff(F,Y));
21241: if(Dumb==-1) mycat([Y,"=",V2^(1/PD)]);
21242: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,V2^(1/PD)]],Dumb[0]);
21243: if((Q=integrate(Q,Y|dumb=Dumb3,var=cons(X,Var)))==[]) return [];
21244: Q=red(Q);
21245: QN=subst(substblock(nm(Q),Y,Y^PD,V2),Y,V2^(1/PD));
21246: QD=subst(substblock(dn(Q),Y,Y^PD,V2),Y,V2^(1/PD));
21247: Q=red(QN/QD+RR);
21248: if(Dumb==-1) mycat(["->",Q]);
21249: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21250: return Q;
21251: }
21252: }else if(length(Var)==2 && /* r(x,(ax+b)^(1/2),(cx+d)^(1/2)) */
21253: (VT=car(Var))[1]==pow && ptype(VT[2],X)==1 && mydeg(VT[2],X)==1 && VT[3]==1/2 &&
21254: (VS=car(car(Var)))[1]==pow && ptype(VS[2],X)==1 && mydeg(VS[2],X)==1 && VS[3]==1/2){
21255: Y=makenewv([P,VAR]|var=x);R=(Y^2-myceof(VS[0],0,X))/(C=mycoef(VS[0],1,X));
21256: if(Dumb==-1) mycat([Y,"=",VS[0]]);
21257: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,VD[0]]],Dumb[0]);
21258: R=integrate(subst(P,VS[0],Y,X,R)*2*Y/C,Y|dumb=Dumb3,var=cons(X,Var));
21259: if(R!=[]){
21260: R=subst(substblock(R,Y,VS[0],Y^2),Y,VS[0]);
21261: if(Dumb==-1) mycat(["->",R]);
21262: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21263: }
21264: return R;
21265: }
21266: if(T==65||T==66){ /* polynomial including sin, exp etc */
21267: for(F=0,VT=Var;VT!=[];VT=cdr(VT)){
21268: VTT=car(VT);
21269: if(ptype(VTT[2],X)>2||mydeg(VTT[2],X)>1) F=ior(F,256); /* compos. or rat. or nonlin. */
21270: K=findin(VTT[1],[cos,sin,tan,exp,log,pow]);
21271: F=ior(F,2^(K+1)); /* 1:other,2:cos,4:sin,8:tan,16:exp,32:log,64:pow */
21272: if((Deg=mydeg(P,VTT[0]))>1&&K!=4) F=ior(F,1024); /* nonlinear */
21273: if(K==5 && (ptype(VTT[3],X)!=0 || VTT[2]!=x||Deg>1)) F=ior(F,8192); /* pow */
21274: for(;Deg>0;Deg--){ /* coef */
21275: if(ptype(mycoef(P,Deg,VTT[0]),X)>2){
21276: if(K==4||K==5) F=ior(F,2048); /* exp, log */
21277: else F=ior(F,4096);
21278: }
21279: }
21280: }
21281: if(!iand(F,1+8+64+256+512+2048+8192)){ /* cos,sin,exp,log^n,x^c */
21282: if(iand(F,1024+4096)&&!iand(F,32+64)){ /* cos,sin,exp */
21283: if(type(Dumb)==5){
21284: S=trig2exp(P,X|inv=1);
21285: if(P!=S) Dumb[0]=cons([[X,S]],Dumb[0]);
21286: }
21287: R=integrate(trig2exp(P,X),X);
21288: if(R!=[]) S=trig2exp(R,X|inv=1);
21289: R=fshorter(S,X);
21290: if(type(Dumb)==5&&R!=S){
21291: Dumb[0]=cons([[1,S]],Dumb[0]);
21292: }
21293: return R;
21294: }
21295: for(R=0,VT=Var;VT!=[];VT=cdr(VT)){
21296: CV=car(VT);
21297: C0=mycoef(CV[2],0,X);C1=mycoef(CV[2],1,X);
21298: Q=mycoef(P,1,CV[0]);
21299: if(CV[1]==sin||CV[1]==cos){
21300: TR=(CV[1]==sin)?intpoly(Q,X|sin=C1):intpoly(Q,X|cos=C1);
21301: R+=TR[0]*cos(CV[2])+TR[1]*sin(CV[2]);
21302: }else if(CV[1]==exp){
21303: QT=exp(CV[2]);
21304: for(V2=vars(C1);V2!=[];V2=cdr(V2)){ /* exp(2*log(a)*x) => a^(2*x) */
21305: if(vtype(VA=car(V2))==2&&functor(VA)==log){
21306: if(ptype(C1,VA)!=2||mydeg(C1,VA)==1&&mycoef(C1,0,VA)==0){
21307: QT=args(VA)[0]^(red(C1/VA)*X);
21308: if(C0!=0) QT*=exp(C0);
21309: break;
21310: }
21311: }
21312: }
21313: R+=intpoly(Q,X|exp=C1)*QT;
21314: }else if(CV[1]==pow)
21315: R+=intpoly(Q,X|pow=CV[2])*x^CV[2];
21316: else if(CV[1]==log){
21317: for(Deg=mydeg(P,CV[0]);Deg>0; Deg--){
21318: Q=mycoef(P,Deg,CV[0]);
21319: TR=intpoly(Q,X|log=[C1,C0,Deg]);
21320: for(I=0;TR!=[];I++,TR=cdr(TR)){
21321: if(I==Deg) R+=car(TR)-subst(car(TR),X,0);
21322: else R+=car(TR)*CV[0]^(Deg-I);
21323: }
21324: }
21325: }
21326: P=mycoef(P,0,CV[0]);
21327: }
21328: R+=intpoly(P,X);
21329: return R;
21330: }
21331: }
21332: for(K=0,VX=[],VT=Var;VT!=[];VT=cdr(VT)){ /* contain only both pow and trig */
21333: VTT=car(VT);
21334: if(findin(VTT[1],[cos,sin,tan])>=0){
21335: if(ptype(VTT[2],X)!=2||mydeg(VTT[2],X)!=1) break;
21336: VX=cons(VTT,VX);
21337: }else if(VTT[1]==pow) K=1;
21338: else break;
21339: }
21340: if(VT==[]&&K==1&&VX!=[]){
21341: D=VX[0][2];
21342: if(VX[0][1]==tan) D*=2;
21343: for(VT=cdr(VX);VT!=[];VT=cdr(VT)){
21344: K=VT[0][2]/D;
21345: if(VT[0][1]==tan) K*=2;
21346: if(type(K)!=1||ntype(K)!=0) break;
21347: D/=dn(K);
21348: }
21349: if(VT==[]){
21350: Y=makenewv([P,VAR]|var=x);
21351: for(Q=P,VT=VX;VT!=[];VT=cdr(VT)){
21352: VTT=car(VT);
21353: if(VTT[1]==cos||VTT[1]==sin){
21354: VV=trig2exp(VTT[0],X|inv=cos(D));
21355: VV=subst(VV,cos(D),(1-Y^2)/(1+Y^2),sin(D),2*Y/(Y^2+1));
21356: }else if(VTT[1]==tan){
21357: VV=trig2exp(VTT[0],X|inv=tan(D/2));
21358: VV=subst(VV,tan(D),Y);
21359: }
21360: Q=subst(Q,VTT[0],VV);
21361: }
21362: Q*=2/(Y^2+1);
21363: if(diff(Q,X)==0){
21364: if(Dumb==-1) mycat([Y,"=",tan(D/2)]);
21365: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,tan(D/2)]],Dumb[0]);
21366: R=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var));
21367: if(R!=[]){
21368: if(Dumb==-1) mycat(["->",R]);
21369: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21370: return sqrt2rat(subst(R,Y,tan(D/2))|mult=1);
21371: }
21372: }
21373: }
21374: }
21375: if(T>65||iand(F,8)){ /* rational for functions or tan */
21376: if(findin(X,vars(P))<0){
21377: for(XV=XE=0,VT=Var;VT!=[];VT=cdr(VT)){
21378: VTT=car(VT);
21379: if(mydeg(VTT[2],X)!=1) break;
21380: if(VTT[1]==cos||VTT[1]==sin||VTT[1]==tan){
21381: K=red(VTT[2]/X);
21382: if(type(K)>1||ntype(K)>0) break;
21383: if(XV==0) XV=K;
21384: else XV/=dn(K/XV);
21385: if(VTT[1]==tan) P=red(subst(P,VTT[0],sin(VTT[2])/cos(VTT[2])));
21386: }else if(VTT[1]==exp){
21387: K=red(VTT[2]/X);
21388: if(type(K)>1||ntype(K)>0) break;
21389: if(XE==0) XE=K;
21390: else XE/=dn(K/XE);
21391: }else break;
21392: }
21393: if(VT==[]&&XE*XV==0){
21394: if(XE){
21395: if(XE<0) XE=-XE;
21396: Y=makenewv([P,VAR]|var=x);
21397: for(F=0,VT=Var;VT!=[];VT=cdr(VT),F++){
21398: VTT=car(VT);C=red(VTT[2]/X/XE);
21399: P=subst(P,VTT[0],Y^C);
21400: if(!F){
21401: if(Dumb==-1) mycat([Y^C,"=",VTT[0]]);
21402: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y^C,VTT[0]]],Dumb[0]);
21403: }
21404: }
21405: P/=XE*Y;
21406: Q=integrate(P,Y|dumb=Dumb3,var=cons(X,VAR));
21407: if(Q==[]) return [];
21408: Q=subst(Q,Y,exp(XE*X));
21409: Q=trig2exp(Q,X);
21410: if(Dumb==-1) mycat(["->",Q]);
21411: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21412: return Q;
21413: }
21414: P=trig2exp(nm(P),X|inv=cos(XV*X))/trig2exp(dn(P),X|inv=cos(XV*X));
21415: Y=makenewv([P,VAR]|var=x);
21416: Q=red(subst(P,sin(XV*X),Y*cos(XV*X)));
21417: Q=substblock(nm(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))/
21418: (substblock(dn(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))*(Y^2+1));
21419: Q=red(Q);
21420: if(ptype(Q,X)<2){
21421: XV*=2;P=Q;
21422: }else{
21423: 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);
21424: P=red(P);
21425: }
21426: if(Dumb==-1){
21427: mycat([Y,"=",tan(XV*X/2)]);
21428: mycat(["integrate",P]);
21429: }else if(type(Dumb)==5) Dumb[0]=cons([[Y,P]],cons([[0,Y,tan(XV*X/2)]],Dumb[0]));
21430: R=intpoly(P,Y|dumb=Dumb);
21431: if(R==[]) return R;
21432: if(Dumb==-1) mycat(["->",R]);
21433: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21434: for(Log=1,K=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
21435: VTT=car(Var);
21436: if(VTT[1]==log){
21437: C=mycoef(R,1,VTT[0]);
21438: VT2=VTT[2];
21439: if(K==0){
21440: K=C;Log=VT2;
21441: if(K<0){
21442: K=-K;Log=1/Log;
21443: }
21444: }else{
21445: if((V=red(C/K))<0){
21446: VT2=1/VT2;V=-V;
21447: }
21448: if(type(V)>1||ntype(V)>0){
21449: Log=1;break;
21450: }
21451: if(isint(V)) Log*=VT2^V;
21452: else{
21453: D=dn(V);K/=D;
21454: Log=Log^D*VT2^nm(V);
21455: }
21456: }
21457: RR=mycoef(RR,0,VTT[0]);
21458: }
21459: }
21460: if(Log!=1){
21461: R=RR;
21462: if(type(Dumb)==5){
21463: if(RR) Dumb[0]=cons([[1,K*log(Log),RR]],Dumb[0]);
21464: else Dumb[0]=cons([[1,K*log(Log)]],Dumb[0]);
21465: }
21466: Log=red(subst(red(Log),Y,sin(XV*X/2)/cos(XV*X/2)));
21467: Log=fshorter(Log,X|log=1); /* log(cos(2*x)+1)=-2*log(cos(x)) */
21468: Nm=fctr(nm(Log));
21469: for(T=[];Nm!=[];Nm=cdr(Nm)){
21470: if(ptype(car(Nm)[0],X)>1) T=cons(car(Nm),T);
21471: }
21472: Nm=fctr(dn(Log));
21473: for(;Nm!=[];Nm=cdr(Nm)){
21474: if(ptype(car(Nm)[0],X)>1) T=cons([car(Nm)[0],-car(Nm)[1]],T);
21475: }
21476: for(I=0,Nm=T;T!=[];T=cdr(T)){
21477: if(I=0) I=abs(car(T)[1]);
21478: else I=igcd(I,car(T)[1]);
21479: }
21480: for(Log=1;Nm!=[];Nm=cdr(Nm)) Log*=car(Nm)[0]^(car(Nm)[1]/I);
21481: K*=I;
21482: if(cmpsimple(nm(Log),dn(Log))<0){
21483: K=-K;Log=red(1/Log);
21484: }
21485: Log=K*log(Log);
21486: if(type(Dumb)==5){
21487: if(RR) Dumb[0]=cons([[1,Log,RR]],Dumb[0]);
21488: else Dumb[0]=cons([[1,Log]],Dumb[0]);
21489: }
21490: }else Log=0;
21491: for(Atan=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
21492: VTT=car(Var);
21493: if(VTT[1]==atan){
21494: W=subst(VTT[2],Y,sin(XV*X/2)/cos(XV*X/2));
21495: W=trig2exp(W,X|inv=1);
21496: V2=funargs(dn(W));
21497: if(type(V2)==4&&length(V2)==2){
21498: V3=V2[1]*mycoef(R,1,VTT[0]);
21499: Z=0;
21500: if(V2[0]==cos)
21501: Z=red(W*cos(V2[1])/sin(V2[1]));
21502: else if(V2[0]==sin){
21503: Z=red(W*sin(V2[1])/cos(V2[1]));
21504: V3=-V3;
21505: }
21506: if(Z==1){
21507: Atan+=V3;W=0;
21508: }else if(Z==-1){
21509: Atan-=V3;W=0;
21510: }
21511: }
21512: R0=mycoef(R,0,VTT[0]);
21513: if(W!=0) Atan+=subst(R-R0,VTT[0],atan(W)); /* atan(W); */
21514: R=R0;
21515: }
21516: }
21517: if(R!=0){
21518: R=subst(R,Y,sin(XV*X/2)/cos(XV*X/2));
21519: R=red(R);
21520: R=trig2exp(nm(R),X|inv=1)/trig2exp(dn(R),X|inv=1);
21521: }
21522: if(type(Dumb)==5){
21523: F=0;WL=[];
21524: if(R){
21525: WL=cons(R,WL);
21526: F++;
21527: }
21528: if(Atan){
21529: WL=cons(Atan,WL);
21530: F++;
21531: }
21532: if(Log){
21533: WL=cons(Log,WL);
21534: F++;
21535: }
21536: WL=cons(1,WL);
21537: if(F>1) Dumb[0]=cons([WL],Dumb[0]);
21538: }
21539: R=red(R+Log+Atan);
21540: if(Dumb==-1) mycat(["->",R]);
21541: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21542: return fshorter(R,X);
21543: }
21544: }
21545: }
21546: VT=pfargs(Q=P,X|level=1);
21547: V=(iand(ptype(P,X),7)<3)?[X]:[];
21548: for(;VT!=[];VT=cdr(VT))
21549: if(ptype(P,car(VT)[0])<3) V=cons(car(VT)[0],V);
21550: if(length(V)>0){ /* 1/x+tan(x)+... etc.: sums */
21551: for(R=0;V!=[];V=cdr(V)){
21552: T=mycoef(Q,0,car(V));
21553: W[0]=[];
21554: S=integrate(TD=red(Q-T),X|dumb=D2,mult=Mul,exe=1);
21555: if(S==[]) continue;
21556: if(type(Dumb)==5){
21557: WL=0;
21558: if(T!=0) WL=[[X,TD,T]];
21559: if(R!=0) WL=cons([1,R],WL);
21560: if(WL) Dumb[0]=cons(WL,Dumb[0]);
21561: TD=W[0];
21562: if(R!=0||T!=0){
21563: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21564: if(car(TD)[0][0]){
21565: WL=(!T)?[]:[[X,T]];
21566: WL=append(car(TD),WL);
21567: if(R!=0) WL=cons([1,R],WL);
21568: }else WL=car(TD);
21569: Dumb[0]=cons(WL,Dumb[0]);
21570: }
21571: }else Dumb[0]=append(TD,Dumb[0]);
21572: }
21573: R+=S;Q=T;
21574: if(!Q) return red(R);
21575: }
21576: W[0]=[];
21577: if(P!=Q&&type(S=integrate(Q,X|dumb=D2,mult=Mul))<4){
21578: RR=red(R+S);
21579: if(type(Dumb)==5){
21580: TD=W[0];
21581: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21582: if(car(TD)[0][0]){
21583: WL=cons([1,R],car(TD));
21584: Dumb[0]=cons(WL,Dumb[0]);
21585: }
21586: else Dumb[0]=append(TD,Dumb[0]);
21587: }
21588: if(nmono(R)+nmono(S)!=nmono(RR)) Dumb[0]=cons([[1,R,S]],Dumb[0]);
21589: }
21590: return RR;
21591: }
21592: }
21593: if(Dumb!=1) mycat(SM);
21594: return [];
21595: }
21596:
21597: def fimag(P)
21598: {
21599: for(V=vars(P);V!=[];V=cdr(V)){
21600: Q=[];
21601: if(vtype(VF=car(V))==2){
21602: VAA=args(VF);
21603: if(VAA==[]) continue;
21604: VA=sqrt2rat(VAA[0]);
21605: if(functor(VF)==exp){
21606: if(imag(VA)!=0){
21607: R=(real(VA)!=0)?exp(real(VA)):1;
21608: Q=subst(P,VF,R*(cos(imag(VA))+sin(imag(VA))*@i));
21609: }
21610: }else if(functor(VF)==pow){
21611: VA=sqrt2rat(VAA[1]);
21612: if(imag(VA)!=0){
21613: R=(real(VA)!=0)?VAA[0]^(real(VA)):1;
21614: L=(VAA[0]!=@e)?log(VAA[0]):1;
21615: Q=subst(P,VAA[0]^(VAA[1]),R*(cos(L*imag(VA))+sin(L*imag(VA))*@i));
21616: }else if(VAA[1]!=(V0=fimag(VA)))
21617: Q=subst(P,VAA[0]^(VAA[1]),VAA[0]^(V0));
21618: }
21619: V0=VA;
21620: if(length(VAA)==1&&(VAA[0]!=V0||VA!=(V0=fimag(VA))))
21621: Q=subst(P,VF,subst(VF,VAA[0],V0));
21622: }
21623: if(Q!=[]&&P!=Q){
21624: P=Q;V=cons(0,vars(P));
21625: }
21626: }
21627: return P;
21628: }
21629:
21630:
21631: def trig2exp(P,X)
21632: {
21633: if(iand(ptype(P,X),128)){
21634: OL=getopt();
21635: Nm=trig2exp(nm(P),X|option_list=OL);
21636: Dn=trig2exp(dn(P),X|option_list=OL);
21637: R=red(Nm/Dn);
21638: if(getopt(arc)==1) return sqrt2rat(R);
21639: }
21640: if((Inv=getopt(inv))==1||type(Inv)==2){
21641: for(VT=T=vars(P);T!=[];T=cdr(T)){
21642: if(findin(functor(car(T)),[cos,sin,tan])>=0){
21643: P=trig2exp(P,X);VT=vars(P);break;
21644: }
21645: }
21646: for(;VT!=[];VT=cdr(VT)){
21647: if(functor(CT=car(VT))==exp){
21648: if((Re=real(args(CT)[0]))!=0){
21649: if(isint(Re)) S=@e^Re;
21650: else S=exp(Re);
21651: }else S=1;
21652: if((Im=imag(args(CT)[0]))!=0){
21653: Q=nm(Im);Q=mycoef(Q,mydeg(Q,X),X);
21654: if(-Q>Q) S*=cos(-Im)-@i*sin(-Im);
21655: else S*=cos(Im)+@i*sin(Im);
21656: }
21657: P=subst(P,CT,S);
21658: }
21659: }
21660: P=red(P);
21661: U=vars(Inv);
21662: if(length(U)!=1||((F=functor(car(U)))!=sin&&F!=cos&&F!=tan)) return P;
21663: XX=args(car(U))[0];
21664: if(mydeg(XX,X)!=1) return P;
21665: if(!isvar(XX)) P=subst(P,X,(X-mycoef(XX,0,X))/mycoef(XX,1,X));
21666: for(VT=vars(P);VT!=[];VT=cdr(VT)){
21667: if(vtype(CT=car(VT))<2) continue;
21668: TX=args(CT)[0];
21669: if(mydeg(TX,X)!=1) continue;
21670: if(!isint(C1=mycoef(TX,1,X))) continue;
21671: if((C0=mycoef(TX,0,X))==0){
21672: CC=1;CS=0;
21673: }else if(vars(C0)==[@pi]){
21674: CC=myval(cos(C0));
21675: if(CC!=0&&type(CC)==1&&ntype(CC)!=0){
21676: CC=cos(C0);CS=sin(C0);
21677: }else CS=myval(sin(C0));
21678: }else{
21679: CC=cos(C0);CS=sin(C0);
21680: }
21681: K=C1;
21682: if(K<0) K=-K;
21683: for(CC1=0,I=K;I>=0;I-=2) CC1+=(-1)^((K-I)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I);
21684: 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);
21685: if(C1<0) CS1=-CS1;
21686: if((TF=functor(CT))==cos) P=subst(P,cos(TX),CC1*CC-CS1*CS);
21687: else if(TF==sin) P=subst(P,sin(TX),CS1*CC+CC1*CS);
21688: }
21689: if(F==sin)
21690: P=substblock(P,cos(X),cos(X)^2,1-sin(X)^2);
21691: else{
21692: P=substblock(P,sin(X),sin(X)^2,1-cos(X)^2);
21693: if(F==tan){
21694: P=subst(P,sin(X),cos(X)*tan(X));
21695: P=substblock(P,cos(X),cos(X)^2,1/(tan(X)^2+1));
21696: }
21697: }
21698: if(!isvar(XX)) P=subst(P,X,XX);
21699:
21700: if(getopt(arc)==1){
21701: for(VT=vars(P);VT!=[];VT=cdr(VT)){
21702: FA=funargs(car(VT));
21703: if(type(FA)==4&&(FA[0]==cos||FA[0]==sin)&&ptype(FA[1],X)>60){
21704: VTT=vars(FA[1]);
21705: if(type(FA[1])!=2||length(VTT)!=1) break;
21706: FB=funargs(VTT[0]);
21707: if(type(FB)!=4||(FF=findin(FB[0],[asin,acos,atan]))<0) break;
21708: if(!isint(2*(C=mycoef(FA[1],1,VTT[0])))||mycoef(FA[1],0,VTT[0])!=0) break;
21709: if(C==1/2){
21710: if(FF==1){
21711: U=(FA[0]==cos)?(1+FB[1])/2:(1-FB[1])/2;
21712: P=subst(P,car(VT),red(U)^(1/2));
21713: }else if(FF==2){
21714: if(FA[0]==sin){
21715: FB1=red(FB[1]);
21716: Nm=nm(FB1);CC=fctr(Nm)[0][0];Dn=dn(FB1);
21717: if(CC<0) CC=-CC;
21718: Nm/=CC;Dn/=CC;
21719: NN=Nm^2+Dn^2;
21720: P=subst(P,car(VT),((NN)^(1/2)-Dn)/Nm*cos(FA[1]));
21721: }
21722: }
21723: P=red(P);
21724: }else if(C==1){
21725: if(FF==1){
21726: if(FA[0]==cos) P=subst(P,car(VT),FB[1]);
21727: else P=subst(P,car(VT),(1-FB[1])^(1/2));
21728: }else if(FF==0){
21729: if(FA[0]==sin) P=subst(P,car(VT),FB[1]);
21730: else P=subst(P,car(VT),(1-FB[1])^(1/2));
21731: }
21732: P=red(P);
21733: }
21734: }
21735: }
21736: P=sqrt2rat(P);
21737: }
21738: return red(P);
21739: }
21740: Var=pfargs(P,X);
21741: for(VT=Var;VT!=[];VT=cdr(VT)){
21742: CT=car(VT);
21743: if(CT[1]==cos)
21744: P=subst(P,CT[0],exp(CT[2]*@i)/2+exp(-CT[2]*@i)/2);
21745: else if(CT[1]==sin)
21746: P=subst(P,CT[0],exp(-CT[2]*@i)*@i/2-exp(CT[2]*@i)*@i/2);
21747: else if (CT[1]==tan)
21748: P=subst(P,CT[0],(exp(-CT[2]*@i)*@i-exp(CT[2]*@i)*@i)/(exp(CT[2]*@i)+exp(-CT[2]*@i)));
21749: else if(CT[1]==pow){
21750: if(ptype(CT[2],X)>1) continue;
21751: if(CT[2]==@e) P=subst(P,CT[0],exp(CT[3]));
21752: else P=subst(P,CT[0],exp(log(CT[2])*exp(CT[3])));
21753: }
21754: }
21755: P=red(P);
21756: for(PP=1,Lp=(dn(P)==1)?1:0;Lp<2;Lp++){
21757: PP=1/PP;
21758: U=(Lp==0)?dn(P):nm(P);
21759: if(U==1) continue;
21760: Var=vars(U);
21761: for(R=[],VT=Var;VT!=[];VT=cdr(VT))
21762: if(functor(car(VT))==exp) R=cons(car(VT),R);
21763: RR=os_md.terms(U,R);
21764: for(Q=0,RRT=RR;RRT!=[];RRT=cdr(RRT)){
21765: for(S=0,CT=cdr(car(RRT)),CR=R,UT=U;CR!=[];CR=cdr(CR),CT=cdr(CT)){
21766: UT=mycoef(UT,car(CT),car(CR));S+=car(CT)*args(car(CR))[0];
21767: }
21768: if(S==0) Q+=UT;
21769: else Q+=UT*exp(S);
21770: }
21771: PP*=Q;
21772: }
21773: return PP;
21774: }
21775:
21776: def powsum(N)
21777: {
21778: if (N < 0) return 0;
21779: if (N == 0) return x;
21780: P = intpoly(N*powsum(N-1),x);
21781: C = subst(P,x,1);
21782: return P+(1-C)*x;
21783: }
21784:
21785: def bernoulli(N)
21786: {
21787: return mydiff(powsum(N),x) - N*x^(N-1);
21788: }
21789:
21790: /* linfrac01([x,y]) */
21791: /* linfrac01(newvect(10,[0,1,2,3,4,5,6,7,8,9]) */
21792: /* 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
21793: 10:y_2=0, 11:y_2=x, 12:y_2=y, 13: y_2=1, 14: y_2=\infty
21794: 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
21795: X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
21796: X[3],X[1],X[12],X[4],X[6]
21797:
21798: T=0 (x_2,x_1,x_3,x_4,...)
21799: T=-j (x_1,x_2,..,x_{j-1},x_{j+1},x_j,x_{j+2},...)
21800: T=1 (1-x_1,1-x_2,1-x_3,1-x_4,...)
21801: T=2 (1/x_1,1/x_2,1/x_3,1/x_4,...)
21802: T=3 (x_1,x_1/x_2,x_1/x_3,x_1/x_4,...)
21803: */
21804:
21805: def lft01(X,T)
21806: {
21807: MX=getopt();
21808: if(type(X)==4){
21809: K=length(X);
21810: if(K>=1) D=1;
21811: }
21812: if(type(X)==5){
21813: K=length(X);
21814: for(J=5, F=K-10; F>0; F-=J++);
21815: if(F==0) D=2;
21816: }
21817: if(D==0) return 0;
21818: if(T==0){ /* x <-> y */
21819: if(D==1){
21820: R=cdr(X); R=cdr(R);
21821: R=cons(X[0],R);
21822: return cons(X[1],R);
21823: }
21824: R=newvect(K,[X[3],X[1],X[4],X[0],X[2],X[6],X[5]]);
21825: for(I=7;I<K;I++) R[I]=X[I];
21826: for(I=11,J=5; I<K; I+=J++){
21827: R[I]=X[I+1]; R[I+1]=X[I];
21828: }
21829: return R;
21830: }
21831: if(T==1){
21832: if(D==1){
21833: for(R=[];X!=[];X=cdr(X)) R=cons(1-car(X),R);
21834: return reverse(R);
21835: }
21836: R=newvect(K,[X[2],X[1],X[0],X[4],X[3],X[5],X[6],X[8],X[7],X[9]]);
21837: for(I=11;I<K;I++) R[I]=X[I];
21838: for(I=10, J=5; I<K; I+=J++){
21839: R[I]=X[I+J-2]; R[I+J-2]=X[I];
21840: }
21841: return R;
21842: }
21843: if(T==2){
21844: if(D==1){
21845: for(R=[]; X!=[]; X=cdr(X)) R=cons(red(1/car(X)),R);
21846: return reverse(R);
21847: }
21848: R=newvect(K,[X[5],X[1],X[2],X[6],X[4],X[0],X[3],X[9],X[8],X[7]]);
21849: for(I=11;I<K;I++) R[I]=X[I];
21850: for(I=10,J=5; I<K; I+=J++){
21851: R[I]=X[I+J-1]; R[I+J-1]=X[I];
21852: }
21853: return R;
21854: }
21855: if(T==3){
21856: if(D==1){
21857: T=car(X);
21858: for(R=[T],X=cdr(X); X!=[]; X=cdr(X))
21859: R=cons(red(T/car(X)),R);
21860: return reverse(R);
21861: }
21862: R=newvect(K,[X[7],X[4],X[2],X[6],X[1],X[9],X[3],X[0],X[8],X[5]]);
21863: for(I=10,J=5; I<K; I+=J++){
21864: 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];
21865: }
21866: return R;
21867: }
21868: if(T==-1){
21869: if(D==1){
21870: return append([X[1],X[2],X[0]],cdr(cdr(cdr(X))));
21871: }
21872: R=newvect(K,[X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
21873: X[3],X[1],X[12],X[4],X[6]]);
21874: for(I=11;I<K;I++) R[I]=X[I];
21875: for(I=17,J=5; I<K; I+=J++){
21876: R[I]=X[I+1]; R[I+1]=X[I];
21877: }
21878: return R;
21879: }
21880: if(T<0){
21881: if(D==1){
21882: for(R=[],I=0; X!=[]; X=cdr(X),I--){
21883: if(I==T){
21884: R=cons(X[1],R);
21885: R=cons(X[0],R);
21886: X=cdr(X);
21887: }
21888: else R=cons(car(X),R);
21889: }
21890: return reverse(R);
21891: }
21892: T=3-T;
21893: R=newvect(K);
21894: for(I=0;I<K;I++) R[I]=X[I];
21895: for(I=10,J=5;J<T;I+=J++);
21896: for(II=0; II<J-2; II++){
21897: R[I]=X[I+J]; R[I+J]=R[I];
21898: }
21899: for( ; II<J; II++){
21900: R[I]=X[I+J+1]; R[I+J+1]=X[I];
21901: }
21902: return R;
21903: }
21904: return 0;
21905: }
21906:
21907: def linfrac01(X)
21908: {
21909: if(type(X)==4) K=length(X)-2;
21910: else if(type(X)==5){
21911: L=length(X);
21912: for(K=0,I=10,J=5; I<L; K++,I+=J++);
21913: if(I!=L) return 0;
21914: }
21915: if(K>3 && getopt(over)!=1) return(-1);
21916: II=(K==-1)?3:4;
21917: for(CC=C=1,L=[X]; C!=0; CC+=C){
21918: for(F=C,C=0,R=L; F>0; R=cdr(R), F--){
21919: P=car(R);
21920: for(I=-K; I<II; I++){
21921: S=lft01(P,I);
21922: if(findin(S,L) < 0){
21923: C++; L=cons(S,L);
21924: }
21925: }
21926: }
21927: }
21928: return L;
21929: }
21930:
21931:
21932: def varargs(P)
21933: {
1.21 takayama 21934: if((All=getopt(all))!=1&&All!=2) All=0;
1.6 takayama 21935: V=vars(P);
21936: for(Arg=FC=[];V!=[];V=cdr(V)){
1.21 takayama 21937: if(vtype(CV=car(V))==0&&All!=0){
1.6 takayama 21938: Arg=lsort([CV],Arg,0);
21939: }
21940: if(vtype(CV)!=2) continue;
21941: if(findin(F=functor(CV),FC)<0) FC=cons(F,FC);
21942: for(AT=vars(args(CV));AT!=[];AT=cdr(AT)){
21943: if(vtype(X=car(AT))<2){
21944: if(findin(X,Arg)<0) Arg=cons(X,Arg);
21945: }else if(vtype(X)==2){
21946: R=varargs(X);
21947: if(R[1]!=[]){
21948: Arg=lsort(R[1],Arg,0);
21949: FC=lsort(R[0],FC,0);
21950: }
21951: }
21952: }
21953: }
1.21 takayama 21954: Arg=reverse(Arg);
21955: return (All==2)?Arg:[reverse(FC),Arg];
1.6 takayama 21956: }
21957:
21958: def pfargs(P,X)
21959: {
21960: if(type(L=getopt(level))!=1) L=0;
21961: for(Var=[],V=vars(P);V!=[];V=cdr(V)){
21962: if(vtype(car(V))==2){
21963: VT=funargs(car(V));
21964: if(length(VT)>1){
21965: if(L<2 &&(ptype(VT[1],X)>1 || (length(VT)>2 && ptype(VT[2],X)>1)))
21966: Var=cons(cons(car(V),VT),Var);
21967: if(L!=1 && (R=pfargs(VT[1],X|level=L-1))!=[]) Var=append(R,Var);
21968: }
21969: }
21970: }
21971: return reverse(Var);
21972: }
21973:
21974: def ptype(P,L)
21975: {
21976: if((T=type(P))<2 || T>3) return T;
21977: if(type(L)!=4) L=[L];
21978: F=0;
21979: if(lsort(L,varargs(dn(P))[1],2)!=[]) F=128;
21980: if(lsort(L,varargs(nm(P))[1],2)!=[]) F+=64;
21981: if(lsort(L,vars(dn(P)),2)!=[]) return F+3;
21982: return (lsort(L,vars(nm(P)),2)==[])?(F+1):(F+2);
21983: }
21984:
21985: def nthmodp(X,N,P)
21986: {
21987: X=X%P;
21988: for(Z=1;;){
21989: if((W=iand(N,1))==1) Z=(Z*X)%P;
21990: if((N=(N-W)/2)<=0) return Z;
21991: X=irem(X*X,P);
21992: }
21993: }
21994:
21995: def issquaremodp(X,P)
21996: {
21997: N=getopt(power);
21998: if(!isint(N)) N=2;
21999: if(P<=1 || !isint(P) || !pari(ispsp,P) || !isint(X) || !isint(N) || N<1){
22000: errno(0);
22001: return -2;
22002: }
22003: M=(P-1)/igcd(N,P-1);
22004: if((X%=P) == 0) return 0;
22005: if(X==1 || M==P-1) return 1;
22006: return (nthmodp(X,M,P)==1)?1:-1;
22007: }
22008:
22009: def iscoef(P,F)
22010: {
22011: if(P==0) return 1;
22012: if(type(P)==1) return F(P);
22013: if(type(P)==2) {
22014: X=var(P);
22015: for(I=deg(P,X); I>=0; I--){
22016: if(!iscoef(mycoef(P,I,X),F)) return 0;
22017: }
22018: }else if(type(P)==3){
22019: if(!iscoef(nm(P),F)||!iscoef(dn(P),F)) return 0;
22020: }else if(type(P)==4){
22021: for(;P!=[];P=cdr(P)) if(!iscoef(P,F)) return 0;
22022: }else if(type(P)>4 && type(P)<7) return iscoef(m2l(PP),F);
22023: else return 0;
22024: return 1;
22025: }
22026:
22027: def rootmodp(X,P)
22028: {
22029: X%=P;
22030: if(X==0) return [0];
22031: N=getopt(power);
22032: PP=pari(factor,P);
22033: P0=PP[0][0]; P1=PP[0][1];
22034: P2=pari(phi,P);
22035: if(!isint(N)) N=2;
22036: N%=P2;
22037: if(P0==2 || size(PP)[0]>1){
22038: for(I=1,R=[]; I<P2; I++)
22039: if(nthmodp(I,N,P)==X) R=cons(I,R);
22040: return qsort(R);
22041: }
22042: Y=primroot(P);
22043: if(Y==0) return 0;
22044: Z=nthmodp(Y,N,P);
22045: G=igcd(N,P2);
22046: P3=P2/G;
22047: for(I=0, W=1; I<P3;I++){
22048: if(W==X) break;
22049: W=(W*Z)%P;
22050: }
22051: if(I==P3) return [];
22052: W=nthmodp(Y,I,P);
22053: Z=nthmodp(Y,P3,P);
22054: for(I=0,R=[];;){
22055: R=cons(W,R);
22056: if(++I>=G) break;
22057: W=(W*Z)%P;
22058: }
22059: return qsort(R);
22060: }
22061:
22062: def primroot(P)
22063: {
22064: PP=pari(factor,P);
22065: P0=PP[0][0]; P1=PP[0][1];
22066: S=size(PP);
22067: if(S[0]>1 || !isint(P) || P0<=2){
22068: print("Not odd prime(power)!");
22069: return 0;
22070: }
22071: if(isint(Ind=getopt(ind))){
22072: Ind %= P;
22073: if(Ind<=0 || igcd(Ind,P)!=1 || (Z=primroot(P))==0){
22074: print("Not exist!");
22075: return 0;
22076: }
22077: P2=P0^(P1-1)*(P0-1);
22078: for(I=1,S=1; I<P2; I++)
22079: if((S = (S*Z)%P) == Ind) return I;
22080: return 0;
22081: }
22082: if(getopt(all)==1){
22083: I=primroot(P);
22084: P2=P0^(P1-1)*(P0-1);
22085: for(L=[],J=1; J<P2; J++){
22086: if(P1>1 && igcd(P0,J)!=1) continue;
22087: if(igcd(P0-1,J)!=1) continue;
22088: L=cons(nthmodp(I,J,P),L);
22089: }
22090: return qsort(L);
22091: }
22092: if(PP[0][1]>1){
22093: I=primroot(P0);
22094: P2=P0^(P1-2)*(P0-1);
22095: if(nthmodp(I,P2,P)==1) I+=P0;
22096: return I;
22097: }
22098: F=pari(factor,P-1);
22099: SF=size(F)[0];
22100: for(I=2; I<P; I++){
22101: for(J=0; J<SF; J++)
22102: if(nthmodp(I,(P-1)/F[J][0],P)==1) break;
22103: if(J==SF) return I;
22104: }
22105: }
22106:
22107: def rabin(P,X)
22108: {
22109: for(M=0,Q=P-1;iand(Q,1)==0;M++,Q/=2);
22110: Z=nthmodp(X,Q,P);
22111: for(N=M;M>0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P);
22112: return (M<N&&(M==0||Z==1))?0:1;
22113: }
22114:
22115: def powprimroot(P,N)
22116: {
22117: if(P<3) P=3;
22118: FE=getopt(exp);
22119: if(FE!=1) FE=0;
22120: if((Log=getopt(log))==1||Log==2) FE=-1;
22121: else if(Log==3){
22122: FE=-2;
22123: for(PP=1, L0=["$r$","$p/a$"];;){
22124: PP=pari(nextprime,PP+1);
22125: if(PP>=P) break;
22126: L0=cons(PP, L0);
22127: }
22128: L0=reverse(L0);
22129: }
22130: if(FE==0) All=getopt(all);
22131: for(I=0, PP=P, LL=[]; I<N; I++,PP++){
22132: PP=pari(nextprime,PP);
22133: if(All==1){
22134: PR=primroot(PP|all=1);
22135: LL=cons(cons(PP,PR),LL);
22136: continue;
22137: }
22138: PR=primroot(PP);
22139: if(FE==-2){ /* log=3 */
22140: LT=cdr(L0);LT=cdr(L0);
22141: for(L=[PP];LT!=[];LT=cdr(LT))
22142: L=cons(primroot(PP|ind=car(LT)),L);
22143: LL=cons(reverse(L),LL);
22144: if(I<N-1) L0=append(L0,[PP]);
22145: }else if(FE){
22146: for(J=1, L=[PP], K=1; J<PP; J++){
22147: if(FE==-1){ /* log=1,2 */
22148: K=primroot(PP|ind=J);
22149: if(K==0 && Log==2) K=PP-1;
22150: }
22151: else K=(K*PR)%PP; /* exp=1 */
22152: L=cons(K,L);
22153: }
22154: LL=cons(reverse(L),LL);
22155: }else
22156: LL=cons([PP,PR],LL); /* default */
22157: }
22158: LL=reverse(LL);
22159: if(!FE) return LL;
22160: PP--;
22161: if(FE==-2) return append(LL,[L0]);
22162: for(I=1,L=["$p$"];I<PP; I++) L=cons(I,L);
22163: return cons(reverse(L),LL);
22164: }
22165:
22166: def ntable(F,II,D)
22167: {
22168: F=f2df(F|opt=-1);
22169: Df=getopt(dif);
1.16 takayama 22170: Str=getopt(str);
1.6 takayama 22171: if(Df!=1) Df=0;
1.16 takayama 22172: L=[];
22173: if(type(D)==4){
22174: if(type(II[0])==4){
22175: T1=II[0][1]-II[0][0];T2=II[1][1]-II[1][0];
22176: for(L0=[],I=0;I<D[0];I++){
22177: for(R=[],J=0;J<D[1];J++)
22178: R=cons(myf2eval(F,II[0][0]+I*T1/D[0],II[1][0]+J*T2/D[1]),R);
22179: L=cons(reverse(R),L);L0=cons(II[0][0]+I*T1/D[0],L0);
22180: }
22181: }else{
22182: for(T=II[1]-II[0],L0=[],I=0;I<D[0];I++){
22183: for(R=[],J=0;J<D[1];J++)
22184: R=cons(myfdeval(F,II[0]+I*T/D[0]+J*T/D[0]/D[1]),R);
22185: L=cons(reverse(R),L);L0=cons(II[0]+I*T/D[0],L0);
22186: }
22187: }
22188: L=reverse(L);L0=reverse(L0);
22189: if(type(Str)==4){
22190: L0=mtransbys(os_md.sint,L0,[Str[0]]|str=1,zero=0);
22191: L=mtransbys(os_md.sint,L,[Str[1]]|str=1,zero=0);
22192: if(Df==1){
22193: for(DT=[],RT=L,I=0;RT!=[];){
22194: for(LT=[],TT=car(RT);TT!=[];TT=cdr(TT)){
22195: VV=car(TT);
22196: if((J=str_char(VV,0,"."))>=0){
22197: if(J==0) VV=str_cut(VV,1,10000);
22198: else VV=str_cut(VV,0,J-1)+str_cut(VV,J+1,10000);
22199: }
22200: V1=eval_str(VV);
22201: if(I++) LT=cons(V1-V0,LT);
22202: V0=V1;
22203: }
22204: DT=cons(LT,DT);
22205: if((RT=cdr(RT))==[]){
22206: VE=rint(myfdeval(F,II[1])*10^Str[1]);
22207: DT=cons([VE-V0],DT);
22208: }
22209: }
22210: for(I=0,D=[],TT=DT;TT!=[];TT=cdr(TT)){
22211: if(!I++) V=car(TT)[0];
22212: else{
22213: T1=reverse(cons(V,car(TT)));
22214: V=car(T1);
22215: if(length(TT)>1) T1=cdr(T1);
22216: D=cons(T1,D);
22217: }
22218: }
22219: for(DD=[],TT=D;TT!=[];TT=cdr(TT))
22220: DD=cons([os_md.lmin(car(TT)),os_md.lmax(car(TT))],DD);
22221: DD=reverse(DD);
22222: L=lsort(L,DD,"append");
22223: }
22224: }
22225: L=lsort(L,L0,"cons");
22226: if(type(Top=getopt(top))==4||getopt(TeX)==1){
22227: if(type(Top)==4){
22228: K=length(L[0])-length(Top);
22229: if(K>0&&K<4){
22230: if(K>1){
22231: Top=append(Top,["",""]);
22232: K-=2;
22233: }
22234: if(K) Top=cons("",Top);
22235: }
22236: L=cons(Top,L);
22237: }
22238: if(type(H=getopt(hline))!=4) H=[0,1,z];
22239: if(type(V=getopt(vline))!=4) V=[0,1,(DF)?z-2:z];
22240: if(type(T=getopt(title))!=7) Out=ltotex(L|opt="tab",hline=H,vline=V);
22241: else Out=ltotex(L|opt="tab",hline=H,vline=V,title=T);
22242: if(Df) Out=str_subst(Out,"\\hline","\\cline{1-"+rtostr(length(L[0])-2)+"}");
22243: return Out;
22244: }
22245: return L;
22246: }
1.6 takayama 22247: for(L=[],I=0;I<=D;I++){
22248: X=II[0]+I*T/D;
22249: L=cons([X,myfdeval(F,X)],L);
22250: }
22251: if(Df==1){
22252: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
22253: if(LD==[]) LD=cons([car(LL)[0],car(LL)[1],0],LD);
22254: else LD=cons([car(LL)[0],car(LL)[1],abs(car(LL)[1]-car(LD)[1])],LD);
22255: }
22256: L=reverse(LD);
22257: }
1.16 takayama 22258: if(type(Str)==4){
1.6 takayama 22259: if(length(Str)==1) Str=[Str[0],Str[0]];
1.16 takayama 22260: if(Df==1 && length(Str)==2) Str=[Str[0],Str[1],Str[1]];
1.6 takayama 22261: for(S=Str,Str=[];S!=[];S=cdr(S)){
22262: if(type(car(S))!=4) Str=cons([car(S),3],Str);
22263: else Str=cons(car(S),Str);
22264: }
22265: Str=reverse(Str);
22266: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
22267: for(K=[],J=length(Str); --J>=0; )
22268: K=cons(sint(car(LL)[J],Str[J][0]|str=Str[J][1]),K);
22269: LD=cons(K,LD);
22270: }
22271: L=LD;
22272: }else
22273: L=reverse(L);
22274: if(type(M=getopt(mult))==1){
22275: Opt=[["opt","tab"],["vline",[[0,2+Df]]],["width",-M]];
22276: if(type(T=getopt(title))==7)
22277: Opt=cons(["title",T],Opt);
22278: if(type(Tp=getopt(top))==4)
22279: Opt=cons(["top",Tp],Opt);
22280: L=ltotex(L|option_list=Opt);
22281: }
22282: return L;
22283: }
22284:
22285: def distpoint(L)
22286: {
22287: L=m2l(L|flat=1);
22288: if(getopt(div)==5) Div=5;
22289: else Div=10;
22290: V=newvect(100/Div);
22291: for(LT=L,LL=[],N=0; LT!=[]; LT=cdr(LT)){
22292: if(type(K=car(LT))>1||K<0){
22293: N++; continue;
22294: }
22295: LL=cons(K,LL);
22296: T=idiv(K,Div);
22297: if(Div==10 && T>=9) T=9;
22298: else if(Div==5 && T>=19) T=19;
22299: V[T]++;
22300: }
22301: V=vtol(V);
22302: if((Opt=getopt(opt))=="data") return V;
22303: Title=getopt(title);
22304: OpList=[["opt","tab"]];
22305: if(type(Title=getopt(title)) == 7)
22306: OpList=cons(["title",Title],OpList);
22307: if(Opt=="average"){
22308: T=isMs()?["平均点","標準偏差","最低点","最高点","受験人数"]:
22309: ["average","deviation","min","max","examinees"];
22310: L=average(LL);
22311: L=[sint(L[0],1),sint(L[1],1),L[3],L[4],L[2]];
22312: if(N>0){
22313: T=append(T,[isMs()?"欠席者":"absentees"]);L=append(L,[N]);
22314: }
22315: OpList=cons(["align","c"],OpList);
22316: return ltotex([T,L]|option_list=OpList);
22317: }
22318:
22319: if(getopt(opt)=="graph"){
22320: Mul=getopt(size);
22321: if(Div==5){
22322: V0=["00","05","10","15","20","25","30","35","40","45","50","55",
22323: "60","65","70","75","80","85","90","95"];
22324: if(type(Mul)!=4){
22325: Size = (TikZ)?[12,3,1/2,0.2]:[120,30,1/2,2];
22326: }
22327: }else{
22328: V0=["00-","10-","20-","30-","40-","50-","60-","70-","80-","90-"];
22329: if(type(Mul)!=4){
22330: Size = (TikZ)?[8,3,1/2,0.2]:[80,30,1/2,2];
22331: }
22332: }
22333: return ltotex([V,V0]|opt="graph",size=Size);
22334: }
22335: if(Div==5)
22336: V0=["00--04","05--09","10--14","15--19", "20--24", "25--29", "30--34", "35-39",
22337: "40--44", "45--49","50--54", "55--59","60--64", "65--69",
22338: "70--74", "75--79","80--84", "85--89","90--94", "95--100"];
22339: else
22340: V0=["00--09","10--19","20--29","30--39","40--49","50--59","60--69",
22341: "70--79","80--89","90--100"];
22342: Title=getopt(title);
22343: return ltotex([V0,V]|option_list=OpList);
22344: }
22345:
22346: def keyin(S)
22347: {
1.46 takayama 22348: mycat0(S,0);
1.6 takayama 22349: purge_stdin();
22350: S=get_line();
22351: L=length(S=strtoascii(S));
22352: if(L==0) return "";
22353: return str_cut(S,0,L-2);
22354: }
22355:
22356: def init() {
1.16 takayama 22357: LS=["DIROUT","DVIOUTA","DVIOUTB","DVIOUTH","DVIOUTL","TeXLim","TeXEq","TikZ",
1.6 takayama 22358: "XYPrec","XYcm","Canvas"];
22359: if(!access(get_rootdir()+"/help/os_muldif.dvi")||!access(get_rootdir()+"/help/os_muldif.pdf"))
22360: mycat(["Put os_muldif.dvi and os_muldif.pdf in", get_rootdir()+(isMs()?"\\help.":"/help.")]);
22361: if(!isMs()){
22362: DIROUT="%HOME%/asir/tex";
22363: DVIOUTA=str_subst(DVIOUTA,[["\\","/"],[".bat",".sh"]],0);
22364: DVIOUTB=str_subst(DVIOUTB,[["\\","/"],[".bat",".sh"]],0);
22365: DVIOUTL=str_subst(DVIOUTL,[["\\","/"],[".bat",".sh"]],0);
22366: DVIOUTH="%ASIRROOT%/help/os_muldif.pdf";
22367: }
22368: Home=getenv("HOME");
22369: if(type(Home)!=7) Home="";
22370: for(Id=-7, F=Home; Id<-1;){
22371: G = F+"/.muldif";
22372: if(access(G)) Id = open_file(G);
22373: else Id++;
22374: if(Id==-6) F+="/asir";
22375: else if(Id==-5) F=get_rootdir();
22376: else if(Id==-4) F+="/bin";
22377: else if(Id==-3) F=get_rootdir()+"/lib-asir-contrib";
22378: }
22379: if(Id>=0){
22380: while((S=get_line(Id))!=0){
1.18 takayama 22381: if(type(P=str_str(S,LS))==4 && (P0=str_char(S,P[1]+4,"="))>0){
1.6 takayama 22382: if(P[0]<5){
22383: P0=str_chr(S,P0+1,"\"");
22384: if(P0>0){
22385: for(P1=P0;(P2=str_char(S,P1+1,"\""))>0; P1=P2);
22386: if(P1>P0+1){
22387: SS=str_cut(S,P0+1,P1-1);
22388: SS=str_subst(SS,["\\\\","\\\""],["\\","\""]);
22389: if(P[0]==0) DIROUT=SS;
22390: else if(P[0]==1) DVIOUTA=SS;
22391: else if(P[0]==2) DVIOUTB=SS;
22392: else if(P[0]==3) DVIOUTH=SS;
22393: else if(P[0]==4) DVIOUTL=SS;
22394: }
22395: }
22396: if(P0<0 || P1<P0+2) mycat(["Error! Definiton of", LS[P[0]],
22397: "in .muldif"]);
22398: }else{
22399: SV=eval_str(str_cut(S,P0+1,str_len(S)-1));
1.16 takayama 22400: if(P[0]==5) TeXLim=SV;
22401: else if(P[0]==6) TeXEq=SV;
22402: else if(P[0]==7) TikZ=SV;
22403: else if(P[0]==8) XYPrec=SV;
22404: else if(P[0]==9) XYcm=SV;
1.18 takayama 22405: else if(P[0]==10) Canvas=SV;
1.6 takayama 22406: }
22407: }
22408: }
22409: close_file(Id);
22410: }
22411: chkfun(1,0);
22412: }
22413:
22414: #ifdef USEMODULE
22415: endmodule;
22416: os_md.init()$
22417: #else
22418: init()$
22419: #endif
22420:
22421: end$