![[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.83 ! takayama 1: /* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.82 2021/07/10 23:18:13 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.81 takayama 9: * Toshio Oshima (Nov. 2007 - July 2021)
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$
1.77 takayama 88: localf sexps$
1.6 takayama 89: localf sord$
90: localf vprod$
91: localf dvangle$
92: localf dvprod$
93: localf dnorm$
1.71 takayama 94: localf dext$
1.6 takayama 95: localf mulseries$
96: localf pluspower$
97: localf vtozv$
98: localf dupmat$
99: localf matrtop$
100: localf mytrace$
101: localf mydet$
1.71 takayama 102: localf permanent$
1.6 takayama 103: localf mperm$
104: localf mtranspose$
105: localf mtoupper$
106: localf mydet2$
107: localf myrank$
108: localf meigen$
109: localf transm$
110: localf vgen$
111: localf mmc$
112: localf lpgcd$
113: localf mdivisor$
114: localf mdsimplify$
115: localf m2mc$
116: localf easierpol$
117: localf paracmpl$
118: localf mykernel$
119: localf myimage$
120: localf mymod$
121: localf mmod$
122: localf ladd$
1.71 takayama 123: localf lsub$
1.6 takayama 124: localf lchange$
125: localf llsize$
126: localf llbase$
1.60 takayama 127: localf llget$
1.6 takayama 128: localf lsort$
1.44 takayama 129: localf rsort$
1.22 takayama 130: localf lpair$
1.6 takayama 131: localf lmax$
132: localf lmin$
133: localf lgcd$
134: localf llcm$
135: localf ldev$
136: localf lsol$
137: localf lnsol$
138: localf l2p$
139: localf m2v$
140: localf lv2m$
141: localf m2lv$
142: localf s2m$
143: localf c2m$
144: localf m2diag$
145: localf myinv$
146: localf madjust$
147: localf mpower$
148: localf mrot$
149: localf texlen$
150: localf isdif$
1.69 takayama 151: localf isfctr$
1.6 takayama 152: localf fctrtos$
153: localf texlim$
154: localf fmult$
155: localf radd$
156: localf getel$
157: localf ptol$
158: localf rmul$
159: localf mtransbys$
1.58 takayama 160: localf trcolor$
1.61 takayama 161: localf mcolor$
1.6 takayama 162: localf drawopt$
163: localf execdraw$
164: localf execproc$
165: localf myswap$
166: localf mysubst$
167: localf evals$
168: localf myval$
169: localf myeval$
170: localf mydeval$
171: localf myfeval$
172: localf myf2eval$
173: localf myf3eval$
174: localf myfdeval$
175: localf myf2deval$
176: localf myf3deval$
177: localf myexp$
178: localf mycos$
179: localf mysin$
180: localf mytan$
181: localf myarg$
182: localf myasin$
183: localf myacos$
184: localf myatan$
185: localf mylog$
1.57 takayama 186: localf nlog$
1.6 takayama 187: localf mypow$
1.13 takayama 188: localf scale$
1.71 takayama 189: localf iceil$
1.6 takayama 190: localf arg$
191: localf sqrt$
192: localf gamma$
193: localf lngamma$
194: localf digamma$
195: localf dilog$
196: localf zeta$
197: localf eta$
198: localf jell$
199: localf frac$
200: localf erfc$
1.20 takayama 201: localf orthpoly$
202: localf schurpoly$
1.6 takayama 203: localf fouriers$
204: localf todf$
205: localf f2df$
206: localf df2big$
207: localf compdf$
208: localf fzero$
209: localf fmmx$
210: localf flim$
211: localf fcont$
212: localf fresidue$
213: localf mmulbys$
214: localf appldo$
215: localf appledo$
216: localf muldo$
217: localf jacobian$
218: localf hessian$
219: localf wronskian$
220: localf adj$
221: localf laplace1$
222: localf laplace$
223: localf mce$
224: localf mc$
225: localf rede$
226: localf ad$
227: localf add$
228: localf vadd$
229: localf addl$
230: localf cotr$
231: localf rcotr$
232: localf muledo$
233: localf mulpdo$
234: localf transpdosub$
235: localf transpdo$
236: localf translpdo$
237: localf rpdiv$
238: localf mygcd$
239: localf mylcm$
240: localf sftpexp$
241: localf applpdo$
242: localf tranlpdo$
243: localf divdo$
244: localf qdo$
245: localf sqrtdo$
246: localf ghg$
247: localf ev4s$
248: localf b2e$
249: localf sftpow$
250: localf sftpowext$
251: localf polinsft$
252: localf pol2sft$
253: localf polroots$
1.70 takayama 254: localf sgnstrum$
255: localf polstrum$
256: localf polrealroots$
257: localf polradiusroot$
1.6 takayama 258: localf fctri$
259: localf binom$
260: localf expower$
261: localf seriesHG$
262: localf seriesMc$
263: localf seriesTaylor$
1.27 takayama 264: localf mulpolyMod$
1.46 takayama 265: localf solveEq$
1.70 takayama 266: localf res0$
267: localf eqs2tex$
1.45 takayama 268: localf baseODE$
1.70 takayama 269: localf baseODE0$
1.26 takayama 270: localf taylorODE$
1.6 takayama 271: localf evalred$
272: localf toeul$
273: localf fromeul$
274: localf sftexp$
275: localf fractrans$
276: localf soldif$
277: localf chkexp$
278: localf sqrtrat$
279: localf getroot$
280: localf expat$
281: localf polbyroot$
282: localf polbyvalue$
283: localf pcoef$
1.58 takayama 284: localf pmaj$
1.6 takayama 285: localf prehombf$
286: localf prehombfold$
287: localf sub3e$
288: localf fuchs3e$
289: localf okubo3e$
290: localf eosub$
291: localf even4e$
292: localf odd5e$
293: localf extra6e$
294: localf rigid211$
295: localf solpokuboe$
296: localf stoe$
297: localf dform$
298: localf polinvsym$
299: localf polinsym$
300: localf tohomog$
301: localf substblock$
302: localf okuboetos$
303: localf heun$
304: localf fspt$
305: localf abs$
1.20 takayama 306: localf sgn$
1.6 takayama 307: localf calc$
308: localf isint$
309: localf israt$
310: localf iscrat$
311: localf isalpha$
312: localf isnum$
313: localf isalphanum$
1.8 takayama 314: localf isdecimal$
1.6 takayama 315: localf isvar$
316: localf isyes$
317: localf isall$
318: localf iscoef$
319: localf iscombox$
320: localf sproot$
321: localf spgen$
1.53 takayama 322: localf spbasic$
1.6 takayama 323: localf chkspt$
324: localf cterm$
325: localf terms$
326: localf polcut$
327: localf redgrs$
328: localf cutgrs$
329: localf mcgrs$
330: localf mc2grs$
331: localf mcmgrs$
1.38 takayama 332: localf spslm$
1.6 takayama 333: localf anal2sp$
334: localf delopt$
335: localf str_char$
336: localf str_pair$
337: localf str_cut$
338: localf str_str$
339: localf str_subst$
340: localf str_times$
341: localf str_tb$
342: localf strip$
343: localf i2hex$
344: localf sjis2jis$
345: localf jis2sjis$
346: localf s2os$
347: localf l2os$
348: localf r2os$
349: localf s2euc$
350: localf s2sjis$
351: localf r2ma$
352: localf evalma$
1.73 takayama 353: localf evalcoord$
354: localf readTikZ$
1.6 takayama 355: localf ssubgrs$
356: localf verb_tex_form$
357: localf tex_cuteq$
358: localf my_tex_form$
359: localf texket$
360: localf smallmattex$
361: localf divmattex$
362: localf dviout0$
363: localf myhelp$
364: localf isMs$
1.55 takayama 365: localf getline$
1.6 takayama 366: localf showbyshell$
367: localf readcsv$
368: localf tocsv$
369: localf getbyshell$
370: localf show$
371: localf dviout$
372: localf rtotex$
1.79 takayama 373: localf togreek$
1.6 takayama 374: localf mtotex$
375: localf ltotex$
376: localf texbegin$
377: localf texcr$
378: localf texsp$
379: localf getbygrs$
380: localf mcop$
381: localf shiftop$
1.56 takayama 382: localf shiftPfaff;
1.6 takayama 383: localf conf1sp$
1.34 takayama 384: localf confexp$
1.36 takayama 385: localf confspt$
1.76 takayama 386: localf vConv$
1.50 takayama 387: localf mcvm$
1.44 takayama 388: localf s2csp$
1.38 takayama 389: localf partspt$
1.6 takayama 390: localf pgen$
391: localf diagm$
392: localf mgen$
393: localf madj$
394: localf newbmat$
395: localf unim$
396: localf pfrac$
397: localf cfrac$
398: localf cfrac2n$
399: localf sqrt2rat$
400: localf s2sp$
401: localf sp2grs$
402: localf fimag$
403: localf trig2exp$
404: localf intpoly$
405: localf integrate$
1.22 takayama 406: localf rungeKutta$
1.6 takayama 407: localf simplog$
408: localf fshorter$
409: localf isshortneg$
410: localf intrat$
411: localf powsum$
412: localf bernoulli$
413: localf lft01$
414: localf linfrac01$
415: localf nthmodp$
416: localf issquaremodp$
417: localf rootmodp$
418: localf rabin$
419: localf primroot$
420: localf varargs$
421: localf ptype$
422: localf pfargs$
1.58 takayama 423: localf regress$
1.6 takayama 424: localf average$
1.23 takayama 425: localf tobig$
1.6 takayama 426: localf sint$
427: localf frac2n$
1.58 takayama 428: localf openGlib$
1.6 takayama 429: localf xyproc$
430: localf xypos$
431: localf xyput$
432: localf xybox$
433: localf xyline$
434: localf xylines$
435: localf xycirc$
436: localf xybezier$
437: localf lbezier$
438: localf draw_bezier$
439: localf tobezier$
440: localf velbezier$
441: localf ptbezier$
442: localf cutf$
443: localf fsum$
444: localf fint$
445: localf periodicf$
446: localf cmpf$
447: localf areabezier$
448: localf saveproc$
1.57 takayama 449: localf xyplot$
1.63 takayama 450: localf xyaxis$
1.6 takayama 451: localf xygraph$
452: localf xy2graph$
1.22 takayama 453: localf addIL$
1.19 takayama 454: localf xy2curve$
1.18 takayama 455: localf xygrid$
1.6 takayama 456: localf xyarrow$
457: localf xyarrows$
458: localf xyang$
459: localf xyoval$
1.33 takayama 460: localf xypoch$
1.72 takayama 461: localf xycircuit$
1.70 takayama 462: localf ptline$
1.6 takayama 463: localf ptcommon$
1.83 ! takayama 464: localf ptinversion$
1.71 takayama 465: localf ptcontain$
1.6 takayama 466: localf ptcopy$
467: localf ptaffine$
468: localf ptlattice$
469: localf ptpolygon$
470: localf ptwindow$
1.81 takayama 471: localf pt5center$
1.70 takayama 472: localf ptconvex$
1.6 takayama 473: localf ptbbox$
1.71 takayama 474: localf darg$
475: localf dwinding$
1.6 takayama 476: localf lninbox$
477: localf ptcombezier$
478: localf ptcombz$
479: localf lchange$
480: localf init$
481: localf powprimroot$
482: localf distpoint$
483: localf ntable$
484: localf keyin$
485: localf mqsub$
486: localf msort$
487: #else
488: extern Muldif.rr$
489: extern TeXEq$
490: extern TeXLim$
1.70 takayama 491: extern TeXPages$
1.6 takayama 492: extern DIROUT$
1.16 takayama 493: extern DIROUTD$
1.6 takayama 494: extern DVIOUTL$
495: extern DVIOUTA$
496: extern DVIOUTB$
497: extern DVIOUTH$
498: extern DVIOUTF$
499: static LCOPT$
500: static COLOPT$
501: static LPOPT$
502: static LFOPT$
503: extern TikZ$
504: extern ErMsg$
505: extern FLIST$
506: extern IsYes$
507: extern XYPrec$
508: extern XYcm$
509: extern TikZ$
510: extern XYLim$
1.70 takayama 511: extern TeXPages$
1.6 takayama 512: extern Canvas$
513: extern ID_PLOT$
514: extern Rand$
515: extern LQS$
1.57 takayama 516: extern SV=SVORG$
1.6 takayama 517: #endif
518: static S_Fc,S_Dc,S_Ic,S_Ec,S_EC,S_Lc$
1.16 takayama 519: static S_FDot$
1.6 takayama 520: extern AMSTeX$
1.58 takayama 521: extern Glib_math_coordinate$
522: extern Glib_canvas_x$
523: extern Glib_canvas_y$
1.83 ! takayama 524: Muldif.rr="00210716"$
1.6 takayama 525: AMSTeX=1$
526: TeXEq=5$
527: TeXLim=80$
1.70 takayama 528: TeXPages=20$
1.6 takayama 529: TikZ=0$
530: XYcm=0$
531: XYPrec=3$
532: XYLim=4$
533: Rand=0$
534: DIROUT="%HOME%\\tex"$
535: DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$
536: DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$
537: DVIOUTB="%ASIRROOT%\\bin\\risatex1%TikZ%.bat"$
538: DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$
539: DVIOUTF=0$
540: LCOPT=["red","green","blue","yellow","cyan","magenta","black","white","gray"]$
541: COLOPT=[0xff,0xff00,0xff0000,0xffff,0xffff00,0xff00ff,0,0xffffff,0xc0c0c0]$
542: LPOPT=["above","below","left","right"]$
543: LFOPT=["very thin","thin","dotted","dashed"]$
1.45 takayama 544: SVORG=["x","y","z","w","u","v","p","q","r","s"]$
1.6 takayama 545: Canvas=[400,400]$
546: LQS=[[1,0]]$
547:
548: ErMsg = newvect(3,[
549: "irregal argument", /* 0 */
550: "too big size", /* 1 */
551: "irregal option" /* 2 */
552: ])$
553: FLIST=0$
554: IsYes=[]$
555: ID_PLOT=-1$
556:
557: def erno(N)
558: {
559: /* extern ErMsg; */
560: print(ErMsg[N]);
561: }
562:
563: def chkfun(Fu, Fi)
564: {
565: /* extern FLIST; */
566: /* extern Muldif.rr; */
567:
568: if(type(Fu) <= 1){
569: if(Fu==1)
570: mycat(["Loaded os_muldif Ver.", Muldif.rr, "(Toshio Oshima)"]);
571: else
572: mycat(["Risa/Asir Ver.", version()]);
573: return 1;
574: }
575: if(type(FLIST) < 4)
576: FLIST = flist();
577: if(type(Fu) == 4){
578: for(; Fu != [] ;Fu = cdr(Fu))
579: if(chkfun(car(Fu),Fi) == 0) return 0;
580: return 1;
581: }
582: if(findin(Fu, FLIST) >= 0)
583: return 1;
584: FLIST = flist();
585: if(findin(Fu, FLIST) >= 0)
586: return 1;
587: if(type(Fi)==7){
588: mycat0(["load(\"", Fi,"\") -> try again!\n"],1);
589: load(Fi);
590: }
591: return 0;
592: /*
593: if(type(Fi) == 7)
594: Fi = [Fi];
595: for( ; Fi != []; Fi = cdr(Fi))
596: load(car(Fi));
597: FLIST = flist();
598: return (findin(Fu,FLIST)>=0)?1:0;
599: */
600: }
601:
602: def makev(L)
603: {
604: S = "";
605: Num=getopt(num);
606: while(length(L) > 0){
607: VL = car(L); L = cdr(L);
608: if(type(VL) == 7)
609: S = S+VL;
610: else if(type(VL) == 2 || VL < 10)
611: S = S+rtostr(VL);
612: else if(VL<46 && Num!=1)
613: S = S+asciitostr([VL+87]);
614: else
615: S = S+rtostr(VL);
616: }
617: return strtov(S);
618: }
619:
620: def makenewv(L)
621: {
622: if((V=getopt(var))<2) V="z_";
623: else if(isvar(V)) V=rtostr(V);
624: if(type(N=getopt(num))!=1) N=0;
1.21 takayama 625: Var=varargs(L|all=2);
1.6 takayama 626: for(XX=[],I=J=0;;I++){
627: X=strtov(V+rtostr(I));
628: if(findin(X,Var)<0){
629: XX=cons(X,XX);
630: if(++J>N) return X;
631: else if(J==N) return reverse(XX);
632: }
633: }
634: }
635:
636: def shortv(P,L)
637: {
638: V=vars(P);
639: if(type(T=getopt(top))==2) T=strtoascii(rtostr(T))[0]-87;
640: else T=10;
641: for(;L!=[];L=cdr(L)){
642: for(J=0;J<36;J++){
643: if(findin(X=makev([car(L),J]|num=1),V)>=0){
644: while(findin(Y=makev([T]),V)>=0) T++;
645: if(T>35) return P;
646: P=subst(P,X,Y);
647: T++;
648: }else if(J>0) break;
649: }
650: }
651: return P;
652: }
653:
654: def vweyl(L)
655: {
656: if(type(L) == 4){
657: if(length(L) == 2)
658: return L;
659: else
660: return [L[0],makev(["d",L[0]])];
661: }
662: /* else if(type(L)<2) return L; */
663: return [L,makev(["d", L])];
664: }
665:
666: def mycat(L)
667: {
668: if(type(L) != 4){
669: print(L);
670: return;
671: }
672: Opt = getopt(delim);
673: Del = (type(Opt) >= 0)?Opt:" ";
674: Opt = getopt(cr);
675: CR = (type(Opt) >= 0)?0:1;
676: while(L != []){
677: if(Do==1)
678: print(Del,0);
679: print(car(L),0);
680: L=cdr(L);
681: Do = 1;
682: }
683: if(CR) print("");
1.46 takayama 684: else print("",2);
1.6 takayama 685: }
686:
1.9 takayama 687: def fcat(S,X)
688: {
689: if(type(S)!=7){
1.18 takayama 690: if(type(DIROUTD)!=7){
691: DIROUTD=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],
692: [getenv("HOME"),get_rootdir(),"/"])+"/";
693: if(isMs()) DIROUTD=str_subst(DIROUTD,"/","\\"|sjis=1);
694: }
1.16 takayama 695: T="fcat";
696: if(S>=2&&S<=9) T+=rtostr(S);
697: T=DIROUTD+T+".txt";
698: if(S==-1) return T;
699: if(S!=0&&access(T)) remove_file(T);
700: S=T;
1.9 takayama 701: }
1.19 takayama 702: R=output(S);
1.9 takayama 703: print(X);
704: output();
1.16 takayama 705: if(getopt(exe)==1) shell("\""+S+"\"");
1.19 takayama 706: return R;
1.9 takayama 707: }
708:
1.6 takayama 709: def mycat0(L,T)
710: {
711: Opt = getopt(delim);
712: Del = (type(Opt) >= 0)?Opt:"";
1.20 takayama 713: if(type(L)!=4) L=[L];
1.6 takayama 714: while(L != []){
715: if(Do==1)
716: print(Del,0);
717: print(car(L),0);
718: L=cdr(L);
719: Do = 1;
720: }
721: if(T) print("");
1.46 takayama 722: else print("",2);
1.6 takayama 723: }
724:
725: def findin(M,L)
726: {
727: if(type(L)==4){
728: for(I = 0; L != []; L = cdr(L), I++)
729: if(car(L) == M) return I;
730: }else if(type(L)==5){
731: K=length(L);
732: for(I = 0; I < K; I++)
733: if(L[I] == M) return I;
734: }else return -2;
735: return -1;
736: }
737:
738: def countin(S,M,L)
739: {
1.10 takayama 740: Step=getopt(step);
741: if(type(Step)==1){
742: N=(Step>0)?Step:-Step;
1.7 takayama 743: if(type(L)==5) L=vtol(L);
744: L=qsort(L);
745: while(car(L)<S&&L!=[]) L=cdr(L);
746: S+=M;
1.10 takayama 747: for(R=[],C=I=0;L!=[];){
748: if(car(L)<S||(Step>0&&car(L)==S)){
1.7 takayama 749: C++;
750: L=cdr(L);
751: }else{
752: R=cons(C,R);C=0;S+=M;
1.10 takayama 753: if(N>1&&++I>=N) break;
1.7 takayama 754: }
755: }
756: if(C>0) R=cons(C,R);
1.10 takayama 757: if(N>1&&(N-=length(R))>0) while(N-->0) R=cons(0,R);
1.7 takayama 758: return reverse(R);
759: }
1.6 takayama 760: if(type(L)==4){
761: for(N=0; L!=[]; L=cdr(L))
762: if(car(L)>=S && car(L)<=M) N++;
763: }else if(type(L)==5){
764: K=length(L);
765: for(I = 0; I < K; I++)
766: if(L[I]>=S && L[I]<=M) N++;
767: }else return -2;
768: return N;
769: }
770:
771: def mycoef(P,N,X)
772: {
773: if(type(P)<3 && type(N)<3)
774: return coef(P,N,X);
775: if(type(P) >= 4)
776: #ifdef USEMODULE
777: return map(os_md.mycoef,P,N,X);
778: #else
779: return map(mycoef,P,N,X);
780: #endif
781: if(type(N)==4){
782: for(;N!=[];N=cdr(N),X=cdr(X))
783: P=mycoef(P,car(N),car(X));
784: return P;
785: }
786: if(deg(dn(P), X) > 0){
787: P = red(P);
788: if(deg(dn(P), X) > 0)
789: return 0;
790: }
791: return red(coef(nm(P),N,X)/dn(P));
792: }
793:
794: def mydiff(P,X)
795: {
796: if(X == 0)
797: return 0;
798: if(type(P)<3 && type(X)<3)
799: return diff(P,X);
800: if(type(P) >= 4)
801: #ifdef USEMODULE
802: return map(os_md.mydiff,P,X);
803: #else
804: return map(mydiff,P,X);
805: #endif
806: if(type(X)==4){
807: for(;X!=[];X=cdr(X)) P=mydiff(P,car(X));
808: return P;
809: }
1.19 takayama 810: if(ptype(dn(P),X)<2)
1.6 takayama 811: return red(diff(nm(P),X)/dn(P));
812: return red(diff(P,X));
813: }
814:
815: def myediff(P,X)
816: {
817: if(X == 0)
818: return 0;
819: if(type(P) < 3)
820: return ediff(P,X);
821: if(type(P) >= 4)
822: #ifdef USEMODULE
823: return map(os_md.myediff,P,X);
824: #else
825: return map(myediff,P,X);
826: #endif
827: if(deg(dn(P),X) == 0)
828: return red(ediff(nm(P),X)/dn(P));
829: return red(X*diff(P,X));
830: }
831:
1.56 takayama 832: def mypdiff(P,L)
833: {
834: if(type(P)>3) return map(os_md.mypdiff,P,L);
835: for(Q=0;L!=[];L=cdr(L)){
836: Q+=mydiff(P,car(L))*L[1];
837: L=cdr(L);
838: }
839: return red(Q);
840: }
841:
1.57 takayama 842: def pTaylor(S,X,N)
1.56 takayama 843: {
1.57 takayama 844: if(!isvar(T=getopt(time))) T=t;
845: if(type(S)<4) S=[S];
846: if(type(X)<4) X=[X];
847: if(findin(T,varargs(S|all=2))>=0){
848: S=cons(z_z,S);X=cons(z_z,X);FT=1;
849: }else FT=0;
850: LS=length(S);
851: FR=(getopt(raw)==1)?1:0;
852: if(!FR) R=newvect(LS);
1.56 takayama 853: else R=R1=[];
1.57 takayama 854: for(L=[],I=0,TS=S,TX=X;I<LS;I++,TS=cdr(TS),TX=cdr(TX)){
855: if(!FR) R[I]=car(TX)+car(TS)*T;
1.56 takayama 856: else{
1.57 takayama 857: R=cons(car(TX),R);R1=cons(car(TS),R1);
1.56 takayama 858: }
1.57 takayama 859: L=cons(car(TS),cons(car(TX),L));
1.56 takayama 860: }
1.57 takayama 861: L=reverse(L);
862: if(FR) R=[reverse(R1),reverse(R)];
1.56 takayama 863: for(K=M=1;N>1;N--){
864: S=mypdiff(S,L);
865: K*=++M;
866: for(TS=S,I=0,R1=[];TS!=[];TS=cdr(TS),I++){
1.57 takayama 867: if(!FR) R[I]+=car(TS)*t^M/K;
1.56 takayama 868: else R1=cons(car(TS)/K,R1);
869: }
1.57 takayama 870: if(FR) R=cons(reverse(R1),R);
1.56 takayama 871: }
1.57 takayama 872: if(FT){
873: if(!FR){
1.56 takayama 874: S=newvect(LS-1);
875: for(I=1;I<LS;I++) S[I-1]=R[I];
876: }else{
877: for(S=[];R!=[];R=cdr(R)){
878: S=cons(cdr(car(R)),S);
879: }
880: R=S;
881: }
882: R=subst(S,z_z,0);
883: }
1.57 takayama 884: return (FR&&!FT)?reverse(R):R;
1.56 takayama 885: }
886:
1.6 takayama 887: def m2l(M)
888: {
889: if(type(M) < 4)
890: return [M];
891: if(type(M) == 4){
892: if(type(car(M))==4 && getopt(flat)==1){
893: for(MM = []; M!=[]; M=cdr(M))
894: MM = append(MM,car(M));
895: return MM;
896: }
897: return M;
898: }
899: if(type(M) == 5)
900: return vtol(M);
901: S = size(M);
902: for(MM = [], I = S[0]-1; I >= 0; I--)
903: MM = append(vtol(M[I]), MM);
904: return MM;
905: }
906:
907: def mydeg(P,X)
908: {
1.56 takayama 909: if(type(P) < 3 && type(X)==2)
1.6 takayama 910: return deg(P,X);
1.56 takayama 911: II=(type(X)==4)?-100000:-1;
1.6 takayama 912: Opt = getopt(opt);
913: if(type(P) >= 4){
914: S=(type(P) == 6)?size(P)[0]:0;
915: P = m2l(P);
1.56 takayama 916: for(I = 0, Deg = -100000; P != []; P = cdr(P), I++){
917: if( (DT = mydeg(car(P),X)) == -2&&type(X)!=4)
1.6 takayama 918: return -2;
919: if(DT > Deg){
920: Deg = DT;
921: II = I;
922: }
923: }
924: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
925: }
926: P = red(P);
1.56 takayama 927: if(type(X)==2){
928: if(deg(dn(P),X) == 0)
929: return deg(nm(P),X);
930: }else{
931: P=nm(red(P));
932: for(D=-100000,I=deg(P,X[1]);I>=0;I--){
933: if(TP=mycoef(P,I,X[1])){
934: TD=mydeg(TP,X[0])-I;
935: if(D<TD) D=TD;
936: }
937: }
938: return D;
939: }
1.6 takayama 940: return -2;
941: }
942:
943: def pfctr(P,X)
944: {
945: P=red(P);
946: if((T=ptype(P,X))>3) return [];
947: if(T==3){
948: G=pfctr(dn(P),X);
949: F=pfctr(nm(P),X);
950: R=[[car(F)[0]/car(G)[0],1]];
951: for(F=cdr(F);F!=[];F=cdr(F)) R=cons(car(F),R);
952: for(G=cdr(G);G!=[];G=cdr(G)) R=cons([car(G)[0],-car(G)[1]],R);
953: return reverse(R);
954: }
955: F=fctr(nm(P));
956: for(R=[],C=1/dn(P);F!=[];F=cdr(F))
957: if(mydeg(car(F)[0],X)>0) R=cons(car(F),R);
958: else C*=car(F)[0]^car(F)[1];
959: return cons([C,1],reverse(R));
960: }
961:
962: def mymindeg(P,X)
963: {
964: if(type(P) < 3)
965: return mindeg(P,X);
966: II = -1;T=60;
967: Opt = getopt(opt);
968: if(type(P) >= 4){
969: S=(type(P) == 6)?size(P)[0]:0;
970: P = m2l(P);
971: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
972: if(car(P) == 0)
973: continue;
974: if( (DT = mydeg(car(P),X)) == -2)
975: return -2;
976: if(DT < Deg || Deg == -3){
977: if(DT==0){
978: if(type(car(P))>=T) continue;
979: T=type(car(P));
980: }
981: Deg = DT;
982: II = I;
983: }
984: }
985: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
986: }
987: P = red(P);
988: if(deg(dn(P),X) == 0)
989: return mindeg(nm(P),X);
990: return -2;
991: }
992:
993: def m1div(M,N,L)
994: {
995: L = (type(L) <= 3)?[0,L]:vweyl[L];
996: DX = L[1]; X = L[0];
997: if(mydeg(N,DX) != 0)
998: return 0;
999: DD = mydeg(M,DX);
1000: MM = M;
1001: while( (Deg=mydeg(MM,DX)) > 0){
1002: MC = mycoef(MM,Deg,DX)*DX^(Deg-1);
1003: MS = radd(MC, MS);
1004: MM = radd(MM, muldo(MC,radd(-DX,N),L));
1005: }
1006: return [MM, MS];
1007: }
1008:
1009:
1010: def mulsubst(F,L)
1011: {
1012: N = length(L);
1013: if(N == 0)
1014: return F;
1015: if(type(L[0])!=4) L=[L];
1.46 takayama 1016: if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]);
1.6 takayama 1017: if(getopt(inv)==1){
1018: for(R=[];L!=[];L=cdr(L)) R=cons([car(L)[1],car(L)[0]],R);
1019: L=reverse(R);
1020: }
1021: if(length(L)==1) return mysubst(F,L);
1022: L1 = newvect(N);
1023: for(J = 0; J < N ; J++)
1024: L1[J] = uc();
1025: L2 = newvect(N);
1026: for(J = 0; J < N; J++){
1027: S = L[J][1];
1028: for(I = 0; I < N; I++)
1029: S = mysubst(S,[L[I][0],L1[I]]);
1030: L2[J] = S;
1031: }
1032: for(J = 0; J < N; J++)
1033: F = mysubst(F, [L[J][0],L2[J]]);
1034: for(J = 0; J < N; J++)
1035: F = mysubst(F, [L1[J],L[J][0]]);
1036: return F;
1037: }
1038:
1039: def cmpsimple(P,Q)
1040: {
1041: T = getopt(comp);
1042: if(P == Q)
1043: return 0;
1044: D = 0;
1045: if(type(T) < 0)
1046: T = 7;
1047: if(iand(T,1))
1048: D = length(vars(P)) - length(vars(Q));
1049: if(!D && iand(T,2))
1050: D = nmono(P) - nmono(Q);
1051: if(!D && iand(T,4))
1052: D = str_len(rtostr(P)) - str_len(rtostr(Q));
1053: if(!D){
1054: if(P > Q) D++;
1055: else D--;
1056: }
1057: return D;
1058: }
1059:
1060: def simplify(P,L,T)
1061: {
1.79 takayama 1062: if(type(P) > 3){
1.6 takayama 1063: #ifdef USEMODULE
1064: return map(os_md.simplify,P,L,T);
1065: #else
1066: return map(simplify,P,L,T);
1067: #endif
1.79 takayama 1068: }
1.6 takayama 1069: if(type(L[0]) == 4){
1070: if(length(L[0]) > 1)
1071: #if USEMODULE
1072: return fmult(os_md.simplify,P,L,[T]);
1073: #else
1074: return fmult(simplify,P,L,[T]);
1075: #endif
1076: L = L[0];
1077: }
1078: if(type(Var=getopt(var)) == 4 && Var!=[]){
1079: if(type(P) == 3)
1080: return simplify(nm(P),P,L,T|var=Var)/simplify(dn(P),P,L,T|var=Var);
1081: V = car(Var);
1082: if((I = mydeg(P,V)) > 0){
1083: Var = cdr(Var);
1084: for(Q=0; I>=0 ; I--)
1085: Q += simplify(mycoef(P,I,V), L, T|var=Var)*V^I;
1086: return Q;
1087: }
1088: }
1089: if(length(L) == 1){
1090: L = car(L);
1091: for(V = vars(L); V != []; V = cdr(V)){
1092: VT = car(V);
1093: if(deg(L,VT) != 1) continue;
1094: P = simplify(P, [VT, -red(coef(L,0,VT)/coef(L,1,VT))], T);
1095: }
1096: return P;
1097: }
1098: Q = mysubst(P,[L[0],L[1]]);
1099: return (cmpsimple(P,Q|comp=T) <= 0)?P:Q;
1100: }
1101:
1102: def monotos(P)
1103: {
1104: if(nmono(P) <= 1)
1105: return rtostr(P);
1106: return "("+rtostr(P)+")";
1107: }
1108:
1109:
1110: def monototex(P)
1111: {
1112: Q=my_tex_form(P);
1113: if(nmono(P)<2 && (getopt(minus)!=1 || str_str(Q,"-"|top=0,end=0)<0))
1114: return Q;
1115: return "("+Q+")";
1116: }
1117:
1118: def minustos(S)
1119: {
1120: if(str_str(S,"-"|top=0,end=0)<0) return S;
1121: return "("+S+")";
1122: }
1123:
1124: def vnext(V)
1125: {
1126: S = length(V);
1127: for(I = S-1; I > 0; I--){
1128: if(V[I-1] < V[I]){
1129: V0 = V[I-1];
1130: for(J = I+1; J < S; J++)
1131: if(V0 >= V[J]) break;
1132: V[I-1] = V[--J];
1133: V[J] = V0;
1134: for(J = S-1; I < J; I++, J--){
1135: V0 = V[I];
1136: V[I] = V[J];
1137: V[J] = V0;
1138: }
1139: return 1;
1140: }
1141: }
1142: return 0;
1143: }
1144:
1145: def ldict(N, M)
1146: {
1147: Opt = getopt(opt);
1148: R = S = [];
1149: for(I = 2; N > 0; I++){
1150: R = cons(irem(N,I), R);
1151: N = idiv(N,I);
1152: }
1153: L = LL = length(R);
1154: T=newvect(LL+1);
1155: while(L-- > 0){
1156: V = car(R); R = cdr(R);
1157: for(I = J = 0; J <= V ; I++){
1158: if(T[I] == 0)
1159: J++;
1160: }
1161: T[I-1] = 1;
1162: S = cons(LL-I+1, S);
1163: }
1164: for(I = 0; I <= LL; I++){
1165: if(T[I] == 0){
1166: S = cons(LL-I, S);
1167: break;
1168: }
1169: }
1170: if(M == 0)
1171: return S;
1172: if(M <= LL){
1173: print("too small size");
1174: return 0;
1175: }
1176: T = [];
1177: for(I = --M; I > LL; I--)
1178: T = cons(I,T);
1179: S = append(S,T);
1180: if(Opt == 2 || Opt == 3)
1181: S = reverse(S);
1182: if(Opt != 1 && Opt != 3)
1183: return S;
1184: for(T = []; S != []; S = cdr(S))
1185: T = cons(M-car(S),T);
1186: return T;
1187: }
1188:
1189: def ndict(L)
1190: {
1191: Opt = getopt(opt);
1192: R = [];
1193: if(Opt != 1 && Opt != 2)
1194: L = reverse(L);
1195: T = (Opt == 1 || Opt == 3)?1:0;
1196: for( ; L != []; L = cdr(L)){
1197: for(I = 0, V = car(L), LT = cdr(L); LT != []; LT = cdr(LT))
1198: if(T == 0){
1199: if(V < car(LT)) I++;
1200: }else if (V > car(LT)) I++;
1201: R = cons(I, R);
1202: }
1203: R = reverse(R);
1204: for(V = 0, I = length(R); I > 0; R = cdr(R), I--)
1205: V = V*I + car(R);
1206: return V;
1207: }
1208:
1209: def nextsub(L,N)
1210: {
1211: if(type(L) == 1){
1212: for(LL = [], I = L-1; I >= 0; I--)
1213: LL = cons(I,LL);
1214: return LL;
1215: }
1216: M = length(L = ltov(L));
1217: K = N-M;
1218: for(I = M-1; I >= 0; I--)
1219: if(L[I] < I+K) break;
1220: if(I < 0)
1221: return 0;
1222: for(J = L[I]+1; I < M; I++, J++)
1223: L[I] = J;
1224: return vtol(L);
1225: }
1226:
1227: def nextpart(L)
1228: {
1229: if(car(L) <= 1)
1230: return 0;
1231: for(I = 0, L = reverse(L); car(L) == 1; L=cdr(L))
1232: I++;
1233: I += (K = car(L));
1234: R = irem(I,--K);
1235: R = (R==0)?[]:[R];
1236: for(J = idiv(I,K); J > 0; J--)
1237: R = cons(K,R);
1238: L = cdr(L);
1239: while(L!=[]){
1240: R = cons(car(L), R);
1241: L = cdr(L);
1242: }
1243: return R;
1244: }
1245:
1246: def transpart(L)
1247: {
1248: L = reverse(L);
1249: for(I=1, R=[]; L!= []; I++){
1250: R = cons(length(L), R);
1251: while(L != [] && car(L) <= I)
1252: L = cdr(L);
1253: }
1254: return reverse(R);
1255: }
1256:
1257: def trpos(A,B,N)
1258: {
1259: S = newvect(N);
1260: for(I = 0; I < N; I++)
1261: S[I]=(I==A)?B:((I==B)?A:I);
1262: return S;
1263: }
1264:
1265: def sprod(S,T)
1266: {
1267: L = length(S);
1268: V = newvect(L);
1269: while(--L >= 0)
1270: V[L] = S[T[L]];
1271: return V;
1272: }
1273:
1274: def sinv(S)
1275: {
1276: L = length(S);
1277: V = newvect(L);
1278: while(--L >= 0)
1279: V[S[L]] = L;
1280: return V;
1281: }
1282:
1283: def slen(S)
1284: {
1285: L = length(S);
1286: for(V = 0, J = 2; J < L; i++){
1287: for(I = 0; I < J; I++)
1288: if(S[I] > S[J]) V++;
1289: }
1290: return V;
1291: }
1292:
1.77 takayama 1293: def sexps(S)
1294: {
1295: K=length(S);S=ltov(S);
1296: for(R=[],I=0;I<K-1;I++){
1297: for(J=I;J>=0&&S[J]>S[J+1];J--){
1298: T=S[J];S[J]=S[J+1];S[J+1]=T;
1299: R=cons(J,R);
1300: }
1301: }
1302: return R;
1303: }
1304:
1.6 takayama 1305: def sord(W,V)
1306: {
1307: L = length(W);
1308: W0 = nevect(L);
1309: V0 = newvect(L);
1310: for(I = F = C = 0; I < L; I++){
1311: C = 0;
1312: if( (W1 = W[I]) > (V1 = V[I]) ){
1313: if(F < 0) C = 1;
1314: else if(F==0) F = 1;
1315: }else if(W1 < V1){
1316: if(F > 0) C = 1;
1317: else if(F==0) F = -1;
1318: }
1319: for(J = I;--J >= 0 && W0[J] > W1; ) W0[J+1] = W0[J];
1320: W0[J+1] = W1;
1321: for(J = I;--J >= 0 && V0[J] > V1; ) V0[J+1] = V0[J];
1322: V0[J+1] = V1;
1323: if(C){
1324: for(J = I; J >= 0; J--){
1325: if((W1=W0[J]) == (V1=V0[J])) continue;
1326: if(W1 > V1){
1327: if(F < 0) return 2;
1328: }
1329: else if(F > 0) return 2;
1330: }
1331: }
1332: }
1333: return F;
1334: }
1335:
1336: def vprod(V1,V2)
1337: {
1.71 takayama 1338: V1=lsub(V1);V2=lsub(V2);
1.6 takayama 1339: for(R = 0, I = length(V1)-1; I >= 0; I--)
1340: R = radd(R, rmul(V1[I], V2[I]));
1341: return R;
1342: }
1343:
1344: def dnorm(V)
1345: {
1.61 takayama 1346: if(type(V)<2) return ctrl("bigfloat")?abs(V):dabs(V);
1.58 takayama 1347: if((M=getopt(max))==1||M==2){
1348: if(type(V)==5) V=vtol(V);
1349: for(S=0;V!=[];V=cdr(V)){
1.61 takayama 1350: if(M==2) S+=ctrl("bigfloat")?abs(car(V)):dabs(car(V));
1.58 takayama 1351: else{
1.61 takayama 1352: if((T=ctrl("bigfloat")?abs(car(V)):dabs(car(V)))>S) S=T;
1.58 takayama 1353: }
1354: }
1355: return S;
1356: }
1.6 takayama 1357: R=0;
1358: if(type(V)!=4)
1.58 takayama 1359: for (I = length(V)-1; I >= 0; I--) R+= real(V[I])^2+imag(V[I])^2;
1.6 takayama 1360: else{
1361: if(type(V[0])>3){
1362: V=ltov(V[0])-ltov(V[1]);
1363: return dnorm(V);
1364: }
1.58 takayama 1365: for(;V!=[]; V=cdr(V)) R+=real(car(V))^2+imag(car(V))^2;
1.6 takayama 1366: }
1.61 takayama 1367: return ctrl("bigfloat")?pari(sqrt,R):dsqrt(R);
1.6 takayama 1368: }
1369:
1370: def dvprod(V1,V2)
1371: {
1372: if(type(V1)<2) return V1*V2;
1373: R=0;
1.71 takayama 1374: V1=lsub(V1);
1375: V2=lsub(V2);
1.6 takayama 1376: if(type(V1)!=4)
1377: for(I = length(V1)-1; I >= 0; I--)
1378: R += V1[I]*V2[I];
1379: else{
1380: for(; V1!=[]; V1=cdr(V1),V2=cdr(V2))
1381: R+=car(V1)*car(V2);
1382: }
1383: return R;
1384: }
1385:
1.70 takayama 1386: def ptline(L,R)
1387: {
1388: P=L[0];Q=L[1];
1389: return (Q[1]-P[1])*(R[0]-P[0])-(Q[0]-P[0])*(R[1]-P[1]);
1390: }
1391:
1392:
1.6 takayama 1393: def dvangle(V1,V2)
1394: {
1395: if(V2==0 && type(V1)==4 && length(V1)==3 &&
1396: (type(V1[0])==4 || type(V1[0])==5 || type(V1[1])==4 || type(V1[1])==5 ||
1397: type(V1[2])==4 || type(V1[2])==5) ){
1398: if(V1[0]==0 || V1[1]==0 || V1[2]==0) return 1;
1399: PV2=V1[1];
1400: if(type(PV2)==4){
1401: PV2=ltov(PV2);
1402: return dvangle(PV2-ltov(V1[0]),ltov(V1[2])-PV2);
1403: }else
1404: return dvangle(PV2-V1[0],V1[2]-PV2);
1405: }
1406: if((L1=dnorm(V1))==0 || (L2=dnorm(V2))==0) return 1;
1407: return dvprod(V1,V2)/(L1*L2);
1408: }
1409:
1410: def mulseries(V1,V2)
1411: {
1412: L = length(V1);
1413: if(size(V2) < L)
1414: L = size(V2);
1415: VV = newvect(L);
1416: for(J = 0; J < L; J++){
1417: for(K = R = 0; K <= J; K++)
1418: R = radd(R,rmul(V1[K],V2[J-K]));
1419: VV[J] = R;
1420: }
1421: return VV;
1422: }
1423:
1.13 takayama 1424: def scale(L)
1425: {
1.23 takayama 1426: T=F=0;LS=1;
1.18 takayama 1427: Pr=getopt(prec);
1.23 takayama 1428: Inv=getopt(inv);
1429: Log10=dlog(10);
1430: if(type(L)==7){
1431: V=findin(L,["CI","DI","CIF","CIF'","DIF","DIF'","SI","TI1","TI2","STI"]);
1432: if(V>=0){
1433: L=["C","D","CF","CF'","DF","DF'","S","T1","T2","ST"];
1434: Inv=1;L=L[V];
1435: }
1436: V=findin(L,["C","A","K","CF","CF'","S","T1","T2","ST","LL0","LL1","LL2","LL3","LL00",
1437: "LL01","LL02","LL03"])+1;
1438: if(V==0) V=findin(L,["D","B","K","DF","DF'"])+1;
1439: if(V>0) L=V;
1440: }
1441: if(type(OL=L)!=4){
1.15 takayama 1442: if(L==2){
1.23 takayama 1443: L=(Pr==0)?
1.18 takayama 1444: [[[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 1445: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5]],
1.18 takayama 1446: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10]]]:
1447: [[[1,2,1/50],[2,5,1/20],[5,10,1/10], [10,20,1/5],[20,50,1/2],[50,100,1]],
1448: [[1,5,1/10],[5,10,1/2], [10,20,1],[50,100,5]],
1449: [[1,5,1/2],[5,10,1], [10,50,5],[50,100,10]]];
1.23 takayama 1450: LS=2;M2=[[1,10,1],[10,100,10]];
1.15 takayama 1451: }else if(L==3){
1.23 takayama 1452: L=(Pr==0)?
1.18 takayama 1453: [[[1,2,1/20],[2,5,1/10],[5,10,1/5], [10,20,1/2],[20,50,1],[50,100,2],
1454: [100,200,5],[200,500,10],[500,1000,20]],
1.15 takayama 1455: [[1,2,1/10],[2,5,1/2], [10,20,1],[20,50,5], [100,200,10],[200,500,50]],
1.18 takayama 1456: [[1,2,1/2],[2,10,1], [10,20,5],[20,100,10], [100,200,50],[200,1000,100]]]:
1457: [[[1,2,1/50],[2,5,1/20],[5,10,1/10],[10,20,1/5],[20,50,1/2],[50,100,1],
1458: [100,200,2],[200,500,5],[500,1000,10]],
1459: [[1,5,1/10],[5,10,1/2], [10,50,1],[50,100,5], [100,500,10],[500,1000,50]],
1.23 takayama 1460: [[1,5,1/2],[5,10,1],[10,50,5],[50,100,10], [100,500,50],[500,1000,100]]];
1461: LS=3;M2=[[1,5,1],[10,50,10],[100,500,100],[500,1000,500]];
1462: }else if(L>9&&L<18){
1.26 takayama 1463: if(L<18){ /* LL0 - LL3, LL00 - LL03 */
1.23 takayama 1464: if(L==10){
1465: L=[ [[1.001,1.002,0.00001],[1.002,1.005,0.00002],[1.005,1.0105,0.00005]],
1466: [[1.001,1.002,0.00005],[1.002,1.005,0.0001], [1.005,1.0105,0.0001]],
1467: [[1.001,1.002,0.0001],[1.002,1.005,0.0005], [1.005,1.0105,0.0005]]];
1468: M2=[1.001,1.0015,1.002,1.003,1.004,1.005,1.006,1.007,1.008,1.009,1.01];
1469: }
1470: if(L==11){
1471: L=[ [[1.01,1.02,0.0001],[1.02,1.05,0.0002],[1.05,1.105,0.0005]],
1472: [[1.01,1.02,0.0005],[1.02,1.05,0.001], [1.05,1.105,0.001]],
1473: [[1.01,1.02,0.001],[1.02,1.05,0.005], [1.05,1.105,0.005]]];
1474: M2=[1.01,1.015,1.02,1.03,1.04,1.05,1.06,1.07,1.08,1.09,1.10];
1475: }else if(L==12){
1476: 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],
1477: [2.5,2.72,0.02]],
1478: [[1.105,1.2,0.005],[1.2,1.4,0.01],[1.4,1.8,0.01],[1.8,2.5,0.05],
1479: [2.5,2.72,0.1]],
1480: [[1.105,1.2,0.01],[1.2,1.4,0.05],[1.4,1.8,0.05],[1.8,2.5,0.1],
1481: [2.5,2.72,0.1]]];
1.26 takayama 1482: 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 1483: }else if(L==13){
1484: 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],
1485: [50,100,2],[100,200,5],[200,400,10],[400,500,20],[500,1000,50],
1486: [1000,2000,100],[2000,5000,200],[5000,10000,500],[10000,22000,1000]],
1487: [[2.7,4,0.1],[4,6,0.1],[6,10,0.5],[10,15,1],[15,30,1],[30,50,5],
1488: [50,100,10],[100,200,10],[200,400,50],[400,500,100],[500,1000,100],
1489: [1000,2000,500],[2000,5000,1000],[5000,10000,1000],[10000,22000,5000]],
1490: [[3,4,0.5],[4,6,0.5],[6,10,1],[10,15,5],[15,30,5],[30,50,10],
1491: [50,100,50],[100,200,50],[200,400,100],[400,500,100],[500,1000,500],
1492: [1000,2000,1000],[2000,5000,3000],[5000,10000,5000],[10000,22000,10000]]];
1493: M2=[3,4,5,6,7,8,9,10,15,20,30,40,50,100,200,500,1000,2000,5000,10000,20000];
1494: }else if(L==14){
1.26 takayama 1495: L=[ [[0.998,0.999,0.00001],[0.995,0.998,0.00002],[0.99,0.995,0.00005]],
1496: [[0.998,0.999,0.00005],[0.995,0.998,0.0001],[0.99,0.995,0.0001]],
1497: [[0.998,0.999,0.0001],[0.995,0.998,0.0005],[0.99,0.995,0.0005]]];
1.23 takayama 1498: M2=[0.999,0.9985,0.998,0.997,0.996,0.995,0.994,0.993,0.992,0.991,0.99];
1499: }else if(L==15){
1.26 takayama 1500: L=[ [[0.98,0.9901,0.0001],[0.95,0.98,0.0002],[0.905,0.95,0.0005]],
1501: [[0.98,0.99,0.0005],[0.95,0.98,0.001], [0.905,0.95,0.001]],
1.23 takayama 1502: [[0.98,0.99,0.001],[0.95,0.98,0.005], [0.91,0.95,0.005]]];
1503: M2=[0.99,0.985,0.98,0.97,0.96,0.95,0.94,0.93,0.92,0.91];
1504: }else if(L==16){
1.26 takayama 1505: L=[ [[0.8,0.906,0.001],[0.6,0.8,0.002],[0.37,0.6,0.005]],
1506: [[0.8,0.906,0.005],[0.6,0.8,0.01],[0.37,0.6,0.01]],
1507: [[0.8,0.9,0.01],[0.6,0.8,0.05],[0.4,0.6,0.05]]];
1508: 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 1509: }else{
1.26 takayama 1510: L=[ [[0.05,0.37,0.002],[0.02,0.05,0.001],[0.01,0.02,0.0005],
1511: [0.005,0.01,0.0002],[0.001,0.005,0.0001],
1512: [0.0005,0.001,0.00002],[0.0001,0.0005,0.00001],[0.00005,0.0001,0.000002]],
1513: [[0.05,0.37,0.01],[0.02,0.05,0.002],[0.01,0.02,0.001],
1514: [0.005,0.01,0.001],[0.001,0.005,0.0002],
1515: [0.0005,0.001,0.0001],[0.0001,0.0005,0.00002],[0.00005,0.0001,0.00001]],
1516: [[0.05,0.37,0.05],[0.02,0.05,0.01],[0.01,0.02,0.005],
1517: [0.005,0.01,0.005],[0.002,0.005,0.001],
1518: [0.0005,0.001,0.0005],[0.0001,0.0005,0.0001],[0.00005,0.0001,0.00005]]];
1519: 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 1520: }
1521: }
1.15 takayama 1522: }else{
1.23 takayama 1523: if(L==6){ /* S */
1524: 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]],
1525: [[6-1/6,15,1/6],[15,30,1/2],[30,70,1],[70,80,5],[80,90,10]],
1526: [[6,15,1/2],[15,30,1],[30,70,5],[70,90,10]] ];
1527: M2=[6,7,8,9,10,15,20,30,40,50,60,70,90];
1528: }else if(L==7){ /* T1 */
1529: F=log(tan(x*3.1416/180))/Log10+1;
1530: L=[ [[6-1/3,15,1/12],[15,45,1/6]],
1531: [[6-1/3,15,1/6],[15,45,1/2]],
1532: [[6,45,1]] ];
1533: M2=[6,7,8,9,10,15,20,30,40,45];
1534: }else if(L==8){ /* T2 */
1535: L=[ [[45,75,1/6],[75,84+1/6,1/12]],
1536: [[45,75,1],[75,84+1/6,1/6]],
1537: [[45,84,1]] ];
1538: M2=[45,50,60,70,75,80,81,82,83,84];
1539: }else if(L==9){ /* ST */
1540: L=[ [[35/60,1,1/120],[1,2,1/60],[2,5+9/12,1/30]],
1541: [[35/60,1,1/60],[1,2,1/6],[2,5+9/12,1/6]],
1542: [[40/60,1,1/6],[1,2,1/2],[2,5+9/12,1]] ];
1543: M2=[1,2,3,4,5];
1544: }else{
1545: M2=(L==4||L==5)?[[1,2,1/2],[2,9,1]]:[[1,2,1/2],[2,10,1]];
1546: L=(Pr==0)?
1547: [ [[1,2,1/50],[2,5,1/20],[5,10,1/10]],
1548: [[1,5,1/10],[5,10,1/2]],
1549: [[1,5,1/2],[5,10,1]] ]:
1550: [[[1,2,1/100],[2,5,1/50],[5,10,1/20]],
1551: [[1,2,1/20],[2,10,1/10]],
1552: [[1,2,1/10],[2,10,1/2]] ];
1553: }
1.15 takayama 1554: }
1555: }else if(type(L[0])!=4){
1556: L=[L];
1557: if(length(L)!=3||L[0]+L[2]>L[1]) T=L;
1.13 takayama 1558: }
1.15 takayama 1559: if(T==0){
1560: if(type(L[0][0])!=4) L=[L];
1561: for(R=[];L!=[];L=cdr(L)){
1562: for(RR=[],LT=car(L);LT!=[];LT=cdr(LT))
1563: for(I=car(LT)[0];I<=car(LT)[1];I+=car(LT)[2]) RR=cons(I,RR);
1564: RR=lsort(RR,[],1);
1565: R=cons(RR,R);
1566: }
1567: R=reverse(R);
1568: for(T=[];R!=[];R=cdr(R)){
1569: if(length(R)>1) T=cons(lsort(R[0],R[1],"setminus"),T);
1570: else T=cons(R[0],T);
1571: }
1.13 takayama 1572: }
1573: V0=dlog(10);
1574: S0=S1=1;D0=D1=0;
1575: SC=getopt(scale);
1576: if(type(SC)==4){
1577: S0=SC[0];S1=SC[1];
1.18 takayama 1578: }else if(type(SC)==1){
1579: S0=SC;S1=0;
1.13 takayama 1580: }else return T;
1581: if(type(D=getopt(shift))==4){
1582: D0=D[0];D1=D[1];
1.31 takayama 1583: }else if(type(D)<2&&type(D)>=0){
1.23 takayama 1584: D0=0;D1=D;
1.31 takayama 1585: };
1.23 takayama 1586: if(Inv==1){
1587: D0+=S0;S0=-S0;
1.13 takayama 1588: }
1.23 takayama 1589: if(type(TF=getopt(f))>1) F=TF;
1590: if(F) F=f2df(F);
1591: if(type(I=getopt(ol))==1&&OL>3) OL=I;
1.18 takayama 1592: for(M=M0=[],I=length(T);T!=[];T=cdr(T),I--){
1.13 takayama 1593: for(S=car(T);S!=[];S=cdr(S)){
1.23 takayama 1594: VS=car(S);
1595: if(F) V=myfdeval(F,car(S));
1596: else if(OL==4) V=frac(dlog(VS)/Log10+0.5);
1597: else if(OL==5) V=frac(dlog(VS*3.1416)/Log10);
1598: else if(OL>5&&OL<10){
1599: VS=VS*3.1416/180;
1600: if(OL==6) V=dlog(dsin(VS))/Log10+1;
1601: else if(OL==9) V=dlog(VS)/Log10+2;
1602: else V=dlog(dtan(VS))/Log10+8-OL;
1603: }
1604: else if(OL>9&&OL<14) V=dlog(dlog(VS))/Log10+13-OL;
1605: else if(OL>13&&OL<18) V=dlog(-dlog(VS))/Log10+17-OL;
1606: else V=dlog(VS)/Log10/LS;
1607: V*=S0;
1.13 takayama 1608: if(S1!=0){
1609: M=cons([V+D0,D1],M);
1.23 takayama 1610: M=cons([V+D0,((length(SC)>2)?SC[I]:(I*S1))+D1],M);
1.13 takayama 1611: M=cons(0,M);
1.18 takayama 1612: }else M0=cons(V+D0,M0);
1.13 takayama 1613: }
1.18 takayama 1614: if(S1==0) M=cons(reverse(M0),M);
1.13 takayama 1615: }
1616: if(S1!=0) M=cdr(M);
1.18 takayama 1617: if(S1==0||getopt(TeX)!=1) return M;
1.13 takayama 1618: M=reverse(M);
1.23 takayama 1619: if(type(U=getopt(line))==4){
1620: if(Inv==1) U=[U[0]+S0,U[1]+S0];
1.18 takayama 1621: M=cons([U[0]+D0,D1],cons([U[1]+D0,D1],cons(0,M)));
1.23 takayama 1622: }
1623: if((VT=getopt(vert))==1){
1624: for(N=[];M!=[];M=cdr(M)){
1625: if(type(TM=car(M))==4) N=cons([TM[1],TM[0]],N);
1626: else N=cons(TM,N);
1627: }
1628: M=reverse(N);
1629: }
1.18 takayama 1630: if(type(Col=getopt(col))<1) S=xylines(M);
1631: else S=xylines(M|opt=Col);
1632: if(type(Mes=getopt(mes))==4){
1.23 takayama 1633: if(length(Mes)==1&&type(M2)==4) Mes=cons(car(Mes),M2);
1.18 takayama 1634: S3=car(Mes);
1635: if(type(S3)==4){
1636: Col=S3[1];
1637: S3=car(S3);
1638: }else Col=0;
1639: V=car(scale(cdr(Mes)));
1.23 takayama 1640: if(!F) Mes=scale(cdr(Mes)|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1.18 takayama 1641: else Mes=scale(cdr(Mes)|f=F,scale=[S0,0],shift=[D0,D1]);
1642: for(M=car(Mes);M!=[];M=cdr(M),V=cdr(V)){
1.23 takayama 1643: TV=deval(car(V));
1644: if(Col!=0) TV=[Col,TV];
1645: S+=(VT==1)?xyput([S3+D1,car(M),TV]):xyput([car(M),S3+D1,TV]);
1646: }
1647: }
1648: if(type(Mes=getopt(mes2))==4){
1649: if(type(car(Mes))!=4) Mes=[Mes];
1650: for(;Mes!=[];Mes=cdr(Mes)){
1651: TM=car(Mes);
1652: if(!F) V=scale([car(TM)]|scale=[S0/LS,0],shift=[D0,D1],ol=OL);
1653: else V=scale([car(TM)]|f=F,scale=[S0,0],shift=[D0,D1]);
1654: V=car(car(V));
1655: TM=cdr(TM);
1656: if(type(Col=car(TM))==4){
1657: C0=Col[0];C1=Col[1];
1658: if(length(Col)==3){
1659: S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]|opt=Col[2])
1660: :xyline([V,D1+C0],[V,D1+C1]|opt=Col[2]);
1661: }else S+=(VT==1)?xyline([D1+C0,V],[D1+C1,V]):xyline([V,D1+C0],[V,D1+C1]);
1662: }
1663: if(type(TM[1]<2)){
1664: TM=cdr(TM);
1665: S3=car(TM);
1666: }
1667: S+=(VT==1)?xyput([S3+D1,V,TM[1]]):xyput([V,S3+D1,TM[1]]);
1.13 takayama 1668: }
1669: }
1.18 takayama 1670: return S;
1.13 takayama 1671: }
1672:
1.6 takayama 1673: def pluspower(P,V,N,M)
1674: {
1675: RR = 1;
1676: for(K = R = 1; K < M-1; I++){
1677: R = R*(N-K+1)*P/K;
1678: RR = radd(RR,R);
1679: }
1680: VV = newvect(M);
1681: for(K = 0; K < M-1; K++)
1682: VV[K] = red(mycoef(RR,K,V));
1683: }
1684:
1685: def vtozv(V)
1686: {
1687: if(type(V)<4) V=newvect(1,[V]);
1688: S = length(V);
1689: VV = newvect(S);
1690: Lcm = 1;
1691: for(K = 0; K < S; K++){
1692: VV[K] = red(V[K]);
1693: Lcm = lcm(Lcm,dn(VV[K]));
1694: C = ptozp(nm(VV[K])|factor=0);
1695: if(K == 0){
1696: Dn = dn(C[1]);
1697: Nm = nm(C[1]);
1698: PNm = nm(C[0]);
1699: }else{
1700: Dn = ilcm(Dn,dn(C[1]));
1701: Nm = igcd(Nm,nm(C[1]));
1702: PNm = gcd(PNm,nm(C[0]));
1703: }
1704: }
1705: if(!(M=Nm*PNm)) return [VV,0];
1706: Mul = (Lcm*Dn)/M;
1707: for(K = 0; K < S; K++)
1708: VV[K] = rmul(VV[K],Mul);
1709: return [VV,Mul];
1710: }
1711:
1712: def dupmat(M)
1713: {
1714: if(type(M) == 6){
1715: Size = size(M);
1716: MM = newmat(Size[0],Size[1]);
1717: for(I = 0; I < Size[0]; I++){
1718: for(J = 0; J < Size[1]; J++)
1719: MM[I][J] = M[I][J];
1720: }
1721: return MM;
1722: }
1723: if(type(M) == 5)
1724: return ltov(vtol(M));
1725: return M;
1726: }
1727:
1728: def matrtop(M)
1729: {
1730: S = size(M);
1731: MM = dupmat(M);
1732: Lcm = newvect(S[0]);
1733: for(J = 0; J < S[0]; J++){
1734: U = vtozv(M[J]);
1735: for(K = -1, I = 0; I < S[1]; I++)
1736: MM[J][I] = U[0][I];
1737: Lcm[J] = U[1];
1738: }
1739: return [MM,Lcm];
1740: }
1741:
1742: def mytrace(M)
1743: {
1744: S=size(M);
1745: if(S[0]!=S[1]) return 0;
1746: for(I=V=0; I<S[0]; I++){
1747: V+=M[I][I];
1748: }
1749: return V;
1750: }
1751:
1752: def mydet(M)
1753: {
1754: MM = matrtop(M);
1755: if(type(MM[0]) == 6){
1756: S = size(M);
1757: for(Dn = 1, I = 0; I < S[0]; I++)
1758: Dn *= MM[1][I];
1759: return (!Dn)?0:red(det(MM[0])/Dn);
1760: }
1761: }
1762:
1.71 takayama 1763: def permanent(M)
1764: {
1765: SS=size(M);
1766: if((S=SS[0]) != SS[1] || S==0) return 0;
1767: if((Red=getopt(red))!=1){
1768: MM = matrtop(M);
1769: for(Dn = 1, I = 0; I < S; I++)
1770: Dn *= MM[1][I];
1771: return (!Dn)?0:red(permanent(MM[0]|red=1)/Dn);
1772: }
1773: if(S<3){
1774: if(S==1) return M[0][0];
1775: else return M[0][0]*M[1][1]+M[0][1]*M[1][0];
1776: }
1777: LL=m2ll(M);
1778: for(V=I=0;I<S;I++){
1779: if(!(K=M[I][0])) continue;
1780: for(TL=[],SL=LL,J=0;J<S;J++,SL=cdr(SL))
1781: if(I!=J) TL=cons(cdr(car(SL)),TL);
1782: if(K) V+=K*permanent(lv2m(TL));
1783: }
1784: return V;
1785: }
1786:
1.6 takayama 1787: def mperm(M,P,Q)
1788: {
1789: if(type(M) == 6){
1790: S = size(M);
1791: if(type(P) <= 1)
1792: P=(P==1)?Q:trpos(0,0,S[0]);
1793: if(type(P) > 3 && type(P[0]) >= 4)
1794: P = trpos(P[0][0],P[0][1],S[0]);
1795: else if(type(P) == 4){
1796: if(length(P)==2 && type(P[1])==4){
1797: P0=P[0];P1=car(P[1]);P=newvect(P1);
1798: for(I=0;I<P1;I++) P[I]=P0+I;
1799: }else P = ltov(P);
1800: }
1801: if(type(Q) <= 1)
1802: Q=(Q==1)?P:trpos(0,0,S[1]);
1803: if(type(Q) > 3 && type(Q[0]) >= 4)
1804: Q = trpos(Q[0][0],Q[0][1],S[1]);
1805: if(type(Q) == 4){
1806: if(length(Q)==2 && type(Q[1])==4){
1807: P0=Q[0];P1=car(Q[1]);Q=newvect(P1);
1808: for(I=0;I<P1;I++) Q[I]=P0+I;
1809: }else Q = ltov(Q);
1810: }
1811: MM = newmat(S0=length(P),S1=length(Q));
1812: for(I = 0; I < S0; I++){
1813: MMI = MM[I]; MPI = M[P[I]];
1814: for(J = 0; J < S1; J++)
1815: MMI[J] = MPI[Q[J]];
1816: }
1817: return MM;
1818: }
1819: if((type(M) == 5 || type(M) == 4) && type(P) >= 4){
1820: if(length(P) == 1 && type(car(P)) == 4)
1821: P = trpos(car(P)[0],car(P)[1],length(M));
1822: MM = newvect(S = length(P));
1823: for(I = 0; I < S; I++)
1824: MM[I] = M[P[I]];
1825: if(type(M) == 4)
1826: MM = vtol(MM);
1827: return MM;
1828: }
1829: return M;
1830: }
1831:
1832: def mtranspose(M)
1833: {
1834: if(type(M)==4){
1835: MV=ltov(M);
1836: II=length(MV);
1837: for(I=L=0; I<II; I++){
1838: if(type(MV[I])!=4) return M;
1839: MV[I]=ltov(MV[I]);
1840: }
1841: for(R=[],J=0; ;J++){
1842: for(T=[],I=F=0; I<II; I++){
1843: if(length(MV[I])>J){
1844: F=1;
1845: T=cons(MV[I][J],T);
1846: }
1847: }
1848: if(F==0) return reverse(R);
1849: if(F==1) R=cons(reverse(T),R);
1850: }
1851: }
1852: if(type(M) != 6)
1853: return M;
1854: S = size(M);
1855: MM = newmat(S[1],S[0]);
1856: for(I = 0; I < S[0]; I++){
1857: for(J = 0; J < S[1]; J++)
1858: MM[J][I] = M[I][J];
1859: }
1860: return MM;
1861: }
1862:
1863: def mtoupper(MM, F)
1864: {
1865: TeXs=["\\ -=\\ ","\\ +=\\ "];
1866: Lins=[" -= line"," += line"];
1867: Assume=["If","Assume"];
1868: if(type(St = getopt(step))!=1) St=0;
1869: Opt = getopt(opt);
1870: if(type(Opt)!=1) Opt=0;
1.43 takayama 1871: if(type(Main=getopt(main))!=1) Main=0;
1.6 takayama 1872: TeX=getopt(dviout);
1873: if(type(Tab=getopt(tab))!=1 && Tab!=0) Tab=2;
1874: Line="\\text{line}";
1875: if(type(TeX)!=1 || !St) TeX=0;
1876: Size = size(MM);
1877: if(F==-1){
1878: M = newmat(Size[0], Size[1]+1);
1879: for(I = 0; I < Size[0]; I++){
1880: for(J = 0; J < Size[1]; J++)
1881: M[I][J] = MM[I][J];
1882: M[I][Size[1]] = zz^I;
1883: }
1884: Size = size(M);
1885: F = 1;
1886: }else if(F<0){
1887: F=Size[0];
1888: M = newbmat(1,2,[[MM,mgen(F,0,[1],0)]]);
1889: Size=[Size[0],F+Size[1]];
1890: }else
1891: M = dupmat(MM);
1892: if(St){
1893: if(TeX) Lout=[[dupmat(M)]];
1894: else mycat0([M,"\n\n"],0);
1895: }
1896: Top="";
1897: if(Opt>3){
1898: for(I=Opt; I>4; I--)
1899: Top+=(TeX)?"\\ ":" ";
1900: }
1901: PC=IF=1;
1.43 takayama 1902: if(Opt>3){
1903: for(P=[1],K=0;K<Size[1]-F;K++){
1904: for(J=0;J<Size[0];J++)
1905: if(type(dn(M[J][K]))==2) P=cons(dn(M[J][K]),P);
1906: }
1907: PC=llcm(P|poly=1);
1908: }
1.6 takayama 1909: for(K = JJ = 0; K < Size[1] - F; K++){
1910: for(J = JJ; J < Size[0]; J++){
1911: if(M[J][K] != 0){ /* search simpler element */
1912: if(Opt>2 && (Mul=M[J][K])!=1){
1913: for(FF=0,JT=J; JT<Size[0]; JT++){
1914: if((Val=M[JT][K])==1){ /* 1 */
1915: Mul=1;J=JT; break;
1916: }
1917: if(Val==0 || type(Val)>type(Mul)) continue;
1918: if(type(Val)<type(Mul) || (Val==-1 && Mul!=-1)){
1919: Mul=Val; J=JT; /* smaller type */
1920: }
1921: else if(Opt>3){
1922: if(isint(Val)==1){ /* integer elememt */
1923: if(isint(Mul)!=1){
1924: Mul=Val; J=JT; /* integer */
1925: }
1926: if(FF<3||(FF==3&&Val>0)){
1927: for(JK=K+1;;){
1928: if(JK>=Size[1]-F){
1929: J=JT;
1930: FF=((Mul=Val)>0)?4:3;
1931: break; /* divisible int => 4: pos_int 3: neg_int */
1932: }
1933: if(isint(M[JT][JK++]/Val)!=1) break;
1934: }
1935: }
1936: }else if(!FF){
1937: for(JK=K+1; JK<Size[1]-F; JK++){
1938: if(isint(M[JT][JK]/Val)!=1) break;
1939: J=JT; FF=1; /* divisible => 1: non integer */
1940: }
1941: }
1942: }
1943: }
1944: if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){ /* FF > 0 => divisible */
1945: for(FF=0,J0=J; J0<Size[0]-1 && FF!=9; J0++){
1946: VV0=M[J0][K];
1947: if(VV0==0 || isint(VV0)==0) continue;
1948: for(J1=J0+1;J1<Size[0] && FF!=9; J1++){
1949: VV1=M[J1][K];
1950: if(VV1==0 || isint(VV1)==0) continue;
1951: for(C=FT=0,V0=VV0,V1=VV1; C<2 && FF!=10; C++,V1=V0,V0=VV1){
1952: for(CC=0,RC=ceil(V0/V1);CC<2;CC++,RC--){
1953: if((CD=V0-RC*V1)==0 && (RC==1 || RC==-1)){
1954: FT=1; FF=10; /* 10: vanish by +- */
1955: }else if(CD==1){
1956: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1957: if((RC==1 || RC==-1) && FF<8+FV){
1958: FT=1; FF=8+FV; /* 8/9: 1 by +- */
1959: }else if(FF<6+VF){
1960: FT=1; FF=6+FV; /* 6/7: 1 by times */
1961: }
1962: }else if(CD==-1){
1963: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1964: if((RC==1 || RC==-1) && FF<4+FV){
1965: FT=1; FF=4+FV; /* 4/5: 1 by +- */
1966: }else if(FF<2+VF){
1967: FT=1; FF=2+FV; /* 2/3: 1 by times */
1968: }
1969: }
1970: if(FT==1){
1971: FT=0; KRC=RC;
1972: if(C==0){
1973: KJ0=J0; KJ1=J1;
1974: }else{
1975: KJ0=J1; KJ1=J0;
1976: }
1977: }
1978: }
1979: }
1980: }
1981: }
1982: if(FF>0){
1983: for(I=K;I<Size[1];I++)
1984: M[KJ0][I]=radd(M[KJ0][I],rmul(M[KJ1][I],-KRC));
1985: if(KRC<0){
1986: KRC=-KRC;Sgn=1;
1987: }else
1988: Sgn=0;
1.43 takayama 1989: if(St&&!Main){
1.6 takayama 1990: if(TeX){
1991: if(KRC==1)
1992: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1993: Line,KJ1+1,"}",dupmat(M)],Lout);
1994: else
1995: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1996: Line,KJ1+1,"\\times\\left(",KRC,"\\right)}",
1997: dupmat(M)],Lout);
1998:
1999: }else{
2000: if(KRC==1)
2001: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1,"\n",M,"\n"]); else
2002: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1," * (",KRC,")\n",M,"\n"]);
2003: }
2004: }
2005: Mul=M[KJ0][K]; J=KJ0;
2006: if(FF==10){
2007: J--; continue;
2008: }
2009: }
2010: }
2011: }
2012: /* a parameter Var */
2013: Var=0;
1.43 takayama 2014: /* mycat(["start",J,K]); */
1.6 takayama 2015: if(St && Opt>4 && length(Var=vars(nm(M[J][K])))==1){
2016: J0=J;Jv=mydeg(nm(M[J0][K]),car(Var));
2017: for(I=JJ;I<Size[0]; I++){
2018: if((MIK=M[I][K])==0) continue;
2019: if((T=vars(MIK=nm(MIK)))==[]){ /* 1/poly */
2020: J=I;Var=[]; break;
2021: }
2022: if(length(T)>1) continue;
2023: if(mydeg(MIK,T[0])<Jv){
1.39 takayama 2024: J0=I;Jv=mydeg(MIK,T[0]);Var=T; /* search minimal degree */
1.6 takayama 2025: }
2026: }
2027: if(length(Var)==1){
2028: Var=car(Var);
2029: Q=nm(M[J0][K]);
1.43 takayama 2030: /* mycat(["min",Q,M[J0][K],"J0=",J0,"J=",J,"JJ=",JJ,K,M]); */
2031: J=J0;
1.6 takayama 2032: for(I=JJ; I<Size[0]; I++){
2033: if(I==J0 || mydeg(nm(M[I][K]),Var)<0) continue;
2034: T=rpdiv(nm(M[I][K]),Q,Var);
2035: if(T[0]!=0 && (vars(T)==[] || vars(T)==[Var])) break; /* dec. deg */
2036: }
2037: }
2038: }
2039: if(type(Var)==2){ /* 1 variable */
2040: if(I==Size[0]){
2041: for(QF=0,Q0=1,QR=getroot(Q,Var|mult=1);QR!=[];QR=cdr(QR)){
1.43 takayama 2042: /* mycat(["root",Q,QR,PC]); */
1.6 takayama 2043: if(deg(T=QR[0][1],Var)>0){
2044: QF=1;Q0*=T; continue;
2045: }
2046: if(subst(PC,Var,T)==0) continue;
2047: Q0*=(Var-(T=QR[0][1]));
2048: if(type(T)<2){
2049: M0=subst(M,Var,T);
2050: if(TeX){
2051: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2052: Var,"=",T,","] ,Lout);
1.43 takayama 2053: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),Lout);
1.6 takayama 2054: }else{
2055: mycat([str_times(" ",St-1)+"If",Var,"=",T,","]);
1.43 takayama 2056: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2057: }
2058: }
2059: }
2060: if(Q0!=1){
2061: if(TeX)
2062: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[QF]+" }",
2063: Q0/=fctr(Q0)[0][0],"\\ne0,"],Lout);
2064: else
2065: mycat([str_times(" ",St-1)+Assume[QF],Q0,"!=0,"]);
2066: PC*=Q0;
2067: }
2068: IF=0;St++;
2069: }else{
2070: KRC=-red((T[2]*dn(M[J0][K]))/(T[1]*dn(M[I][K])));
2071: for(II=K;II<Size[1];II++)
2072: M[I][II]=radd(M[I][II],rmul(M[J0][II],KRC));
1.43 takayama 2073: if(!Main){
2074: if(TeX)
2075: Lout=cons([Top+"\\xrightarrow{", Line,I+1,"\\ +=\\ ",Line,
2076: J0+1,"\\times\\left(",KRC,"\\right)}",dupmat(M)],Lout);
2077: else
2078: mycat([Top+"line",I+1,"+=",Line,J0+1," * (",KRC,")\n",M,"\n"]);
2079: }
1.6 takayama 2080: J=JJ-1;
2081: continue;
2082: }
2083: }
2084: if(J != JJ){
2085: for(I = K; I < Size[1]; I++){
2086: Temp = M[JJ][I];
2087: M[JJ][I] = M[J][I];
2088: M[J][I] = (Opt>=2)?Temp:-Temp;
2089: }
2090: if(St){
2091: if(TeX)
2092: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\leftrightarrow\\ ",
2093: Line,J+1,"}",dupmat(M)],Lout);
2094: else
2095: mycat0([Top+"line",JJ+1," <-> line",J+1,"\n",M,"\n\n"],0);
2096: }
2097: }
2098: /* Assume PC != 0 */
2099: if(Opt>1){
2100: Mul = M[JJ][K];
2101: if(Opt > 5 && St && IF && (Var=vars(MIK=nm(Mul)))!=[]){
2102: TF=fctr(MIK);
2103: for(FF=0,Q0=1,TP=cdr(TF);TP!=[];TP=cdr(TP)){
2104: if(type(dn(red(PC/(TP0=car(car(TP))))))<2) continue; /* divisible */
2105: Q0*=TP0;
2106: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
2107: if(mydeg(TP0,X=car(Var))==1 && type(dn(red(PC/mycoef(TP0,1,X))))<2){
2108: /* TP0=A*X+B with non-vanishing A */
2109: T=red(-mycoef(TP0,0,X)/mycoef(TP0,1,X));
2110: M0=mysubst(M,[X,T]);
2111: if(TeX){
2112: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2113: X,"=",T,","] ,Lout);
1.43 takayama 2114: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 2115: Lout);
2116: }else{
2117: mycat([str_times(" ",St-1)+"If",X,"=",T,","]);
1.43 takayama 2118: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2119: }
2120: break;
2121: }
2122: }
2123: if(Var==[] && Opt>6){
2124: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
2125: if(mydeg(TP0,X=car(Var))==1){
2126: /* TP0=A*X+B, A is a poly of X0 with rational funct */
2127: T=nm(mycoef(TP0,1,X));
2128: for(Var0=vars(T);Var0!=[]; Var0=cdr(Var0)){
2129: X0=car(Var0);
2130: if(type(dn(red(PC/type(mycoef(T,mydeg(T,X0),X0)))))>1) continue;
2131: TR=getroot(T,X0|mult=1);
2132: if(findin(X0,vars(TR))<0) break;
2133: }
2134: if(Var0==[]) continue;
2135: for(;TR!=[0];TR=cdr(TR)){
2136: if(TR==[]){
2137: TR=[0,0];
2138: T0=-mycoef(TP0,0,X)/mycoef(TP0,1,X);
2139: X0=X;
2140: }else T0=car(TR)[1];
2141: M0=mysubst(M,[X0,T0]);
2142: if(TeX){
2143: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
2144: X0,"=",T0,","] ,Lout);
1.43 takayama 2145: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab,main=Main),
1.6 takayama 2146: Lout);
2147: }else{
2148: mycat([str_times(" ",St-1)+"If",X0,"=",T0,","]);
1.43 takayama 2149: mtoupper(M0,F|step=St+1,opt=Opt,main=Main);
1.6 takayama 2150: }
2151: }
2152:
2153: }
2154: break;
2155: }
2156: }
2157: if(Var==[]){
2158: FF=1;
2159: }
2160: }
2161: if(Q0!=1){
2162: if(FF) FF=1;
2163: if(TeX) Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[FF]+" }",Q0/=fctr(Q0)[0][0],"\\ne0,"],
2164: Lout);
2165: else mycat([str_times(" ",St-1)+Assume[FF],Q0,"!=0,"]);
2166: PC*=Q0;St++;
2167: }
2168: }
2169: IF=M[JJ][K]=1;
2170: if(Mul!=1){
2171: for(L=K+1; L<Size[1]; L++)
2172: M[JJ][L]=red(M[JJ][L]/Mul);
2173: if(St){
2174: if(TeX)
2175: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,
2176: "\\ \\times=\\ \\left(",red(1/Mul),"\\right)}",
2177: dupmat(M)],Lout);
2178: else
2179: mycat0([Top+"line",JJ+1, " *= (",red(1/Mul), ")\n",M,"\n\n"],0);
2180: }
2181: }
2182:
2183: }
2184: for(J = (Opt>0)?0:(JJ+1); J < Size[0]; J++){
2185: if(J == JJ)
2186: continue;
2187: Mul = -M[J][K];
2188: if(Mul!=0){
2189: if(Opt!=2) Mul=rmul(Mul,1/M[JJ][K]);
2190: for(I = K+1; I < Size[1]; I++)
2191: M[J][I] = radd(M[J][I],rmul(M[JJ][I],Mul));
2192: M[J][K] = 0;
1.43 takayama 2193: if(St&&!Main){
1.6 takayama 2194: if(Mul<0){
2195: Mul=-Mul;Sgn=0;
2196: }else Sgn=1;
2197: if(TeX){
2198: if(Mul==1)
2199: Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2200: "}",dupmat(M)],Lout);
2201: else Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
2202: "\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout);
2203: }else{
2204: if(Mul==1)
2205: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1,"\n",M,"\n\n"],0);
2206: else
2207: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1," * (",Mul,")\n",M,"\n\n"],0);
2208: }
2209: }
2210: }
2211: }
2212: JJ++;
2213: }
2214: }
2215: }
2216: if(TeX){
2217: if(TeX==-2) return Lout;
2218: Lout=reverse(Lout);
2219: Br="\\allowdisplaybreaks";
2220: Cr="\\\\\n &";
2221: if(getopt(pages)==1) Cr=Br+Cr;
2222: if(type(S=getopt(cr))==7) Cr=S;
2223: if(type(Lim=getopt(lim))==1){
2224: if(Lim>0){
2225: if(Lim<30) Lim=TeXLim;
2226: Lim*=2;
2227: }
2228: }else Lim=0;
2229: Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr,lim=Lim);
2230: if(TeX<0) return Out;
2231: dviout(Out|eq=(str_str(Cr,Br)>=0)?6:5,keep=(TeX==1)?0:1);
2232: }
2233: return M;
2234: }
2235:
2236: def mydet2(M)
2237: {
2238: S = size(M);
2239: Det = 1;
2240: MM = mtoupper(M,0);
2241: for(I = 0; I < S[0]; I++)
2242: Det = rmul(Det,MM[I][I]);
2243: return Det;
2244: }
2245:
2246: def myrank(MM)
2247: {
2248: S = size(MM);
2249: M = dupmat(MM);
2250: M = mtoupper(M,0);
2251: C = 0;
2252: for(I = K = 0; I < S[0]; I++){
2253: for(J = K; J < S[1]; J++){
2254: if(M[I][J] != 0){
2255: C++; K++;
2256: break;
2257: }
2258: }
2259: }
2260: return C;
2261: }
2262:
2263: def meigen(M)
2264: {
2265: F = getopt(mult);
2266: if(type(M)==4 || type(M)==5){
2267: II=length(M);
2268: for(R=[],I=II-1; I>=0; I--){
2269: if(F==1)
2270: R=cons(meigen(M[I]|mult=1),R);
2271: else
2272: R=cons(meigen(M[I]),R);
2273: }
2274: return R;
2275: }
2276: S = size(M)[0];
2277: P = mydet2(mgen(S,0,[zz],0)-M);
2278: return (F==1)?getroot(P,zz|mult=1):getroot(P,zz);
2279: }
2280:
2281: def transm(M)
2282: {
2283: if(type(M)!=6) M=s2m(M);
2284: if(type(M)!=6){
2285: errno(0);
2286: return 0;
2287: }
2288: L=[M];TeX="";
2289: Line=["\\text{line}","\\text{col}"];
2290: if((DVI=getopt(dviout)) !=1) DVI=0;
2291: else dviout(M);
2292: for(;;){
2293: print(L0=dupmat(car(L)));
2294: Sz=size(L0);
2295: S=keyin("? ");
2296: N=0;
2297: if(str_len(S)<=1){
2298: if(S=="q") return L;
2299: if(S=="t"){
2300: N=mtranspose(L0);
2301: TeX=["\\text{transpose}"];
2302: }
2303: else if(S=="f"){
2304: if(length(L)>1){
2305: if(LF!=0) TeX="";
2306: L=cdr(L);LF=L0;
2307: if(DVI){
2308: dviout0(-1);
2309: dviout(" ");
2310: }
2311: }
2312: }else if(S=="g"){
2313: if(LF!=0) N=LF;
2314: }else if(S=="0"){
2315: N=M;L=[];TeX=[];
2316: }else if(S=="a"||S=="A"){
2317: if(DVI&&S=="A") mtoupper(L0,0|step=1,opt=10,dviout=1);
2318: else mtoupper(L0,0|step=1,opt=10);
2319: }else{
2320: mycat0([
2321: "2,5 : line2 <-> line5",
2322: "2,5,-2 ; line2 += (-2)*line5",
2323: "2,2,-2 : line2 *= -2",
2324: "2,5,0 : line2 += (?)*line5 for reduction",
2325: "r,2,5 : raw2 <-> raw5 (r,2,5,-2 etc.)",
2326: "s,x,2 : subst(*,x,2)",
2327: "t : transpose",
2328: "0 : first matrix",
2329: "f : previous matrix",
2330: "g : next matrix (only after f)",
2331: "A : auto (a : without TeX)",
2332: "q : quit"
2333: ],1|delim="\n");
2334: }
2335: }else{
2336: FR=0;
2337: S=evals(S|del=",");
2338: if(S[0]==r){
2339: FR=1; S=cdr(S);
2340: }
2341: if((LL=length(S))>=2){
2342: S0=S[0]-1;S1=S[1]-1;
2343: if(S[0]==s){
2344: if(length(S)==3) N=subst(L0,S[1],S[2]);
2345: if(DVI) TeX=[S[1],"\\mapsto",S[2]];
2346: }else if(FR==0){
2347: if(S0<0 || S0>=Sz[0] || S1<0 || S1>=Sz[0]) continue;
2348: if(LL==2){
2349: N=rowx(L0,S0,S1);
2350: if(DVI) TeX=[Line[0],S[0],"\\ \\leftrightarrow\\ ",Line[0],S[1]];
2351: }else{
2352: S2=S[2];
2353: if(S0==S1){
2354: N=rowm(L0,S0,S2);
2355: if(DVI) TeX=[Line[0],S[0],"\\ \\times=\\ ",S2];
2356: }else{
2357: if(S2==0){
2358: for(J=0;J<Sz[1] && L0[S1][J]==0;J++);
2359: if(J<Sz[1]) S2=-L0[S0][J]/L0[S1][J];
2360: }
2361: if(S2!=0){
2362: N=rowa(L0,S0,S1,S2);
2363: if(DVI) TeX=[Line[0],S[0],"\\ +=\\ ",Line[0],
2364: S[1],"\\ \\times\\ (",S2,")"];
2365: }
2366: }
2367: }
2368: }else{
2369: if(S0<0 || S0>=Sz[1] || S1<0 && S1>=Sz[1]) continue;
2370: if(LL==2){
2371: N=colx(L0,S0,S1);
2372: if(DVI) TeX=[Line[1],S[0],"\\ \\leftrightarrow\\ ",Line[1],S[1]];
2373: }else{
2374: S2=S[2];
2375: if(S0==S1){
2376: N=colm(L0,S0,S2);
2377: if(DVI) TeX=[Line[1],S[0],"\\ \\times=\\ ",S[2]];
2378: }else{
2379: if(S2!=0){
2380: for(J=0; I1<Sz[0] && L0[I1][J]==0; J++);
2381: if(J<Sz[0]) S2=-L0[J][S0]/L0[J][S1];
2382: }if(S2!=0){
2383: N=cola(L0,S0,S1,S2);
2384: if(DVI) TeX=[Line[1],S[0],"\\ +=\\ ",Line[1],
2385: S[1],"\\ \\times\\ (",S2,")"];
2386: }
2387: }
2388: }
2389: }
2390: }
2391: }
2392: if(N!=0){
2393: LF=0;L=cons(N,L);
2394: if(DVI) dviout("\\xrightarrow{"+ltotex(TeX|opt="spts0",str=1)+"}"+mtotex(N)|eq=8);
2395: }
2396: }
2397: }
2398:
2399: def vgen(V,W,S)
2400: {
2401: IM=length(V);
2402: I=(getopt(opt)==0)?IM:0;
2403: for(SS=0; I<IM && (SS==0 || V[I]<=W[I]); I++)
2404: SS += W[I];
2405: if(I<IM){
2406: W[I]++;
2407: SS--;
2408: }else
2409: SS=S;
2410: for(J=0;J<I;J++){
2411: W[J] = (SS<=V[J])?SS:V[J];
2412: SS -= W[J];
2413: }
2414: if(SS>0)
2415: return -1;
2416: return(I==IM)?0:I;
2417: }
2418:
2419: def mmc(M,X)
2420: {
1.81 takayama 2421: if(getopt(full)==1){
2422: M=mmc(M,X|option_list=delopt(getopt(),"full"));
2423: if(type(M)<4) return -1;
2424: L=length(M);
2425: Mt=getopt(mult);
2426: if((L>=6 && Mt!=0)||(L==3&&Mt==1)){
2427: for(SS=2,I=3; I<L; I+=(++SS));
2428: if(I==L) Mt=1;
2429: else Mt=0;
2430: }
2431: if(Mt!=1){
2432: for(R=[],I=S=0;I<L;I++){
2433: S=radd(S,M[I]);
2434: R=cons([[0,I+1],M[I]],R);
2435: }
2436: R=cons([[0,I+1],-S],R);
2437: return reverse(R);
2438: }
2439: for(R=[],I=S=0;I<SS;I++)
2440: for(J=I+1;J<=SS;J++,S++) R=cons([[I,J],M[S]],R);
2441: for(I=0;I<=SS;I++){
2442: for(J=S=0;J<=SS;J++){
2443: if(I==J) continue;
2444: S=radd(S,delopt(R,(I<J)?[I,J]:[J,I]|get=1));
2445: }
2446: R=cons([[I,SS+1],-S],R);
2447: }
2448: return qsort(R);
2449: }
2450:
1.6 takayama 2451: Mt=getopt(mult);
1.50 takayama 2452: if(type(M)==7) M=s2sp(M);
1.81 takayama 2453: if(type(M)!=4&&type(M)!=5) return 0;
1.50 takayama 2454: if(type(M[0])<=3){
1.81 takayama 2455: if(type(M)==5) M=vtol(M);
1.50 takayama 2456: for(RR=[];M!=[];M=cdr(M)) RR=cons(mat([car(M)]),RR);
2457: M=reverse(RR);
2458: }
1.6 takayama 2459: if(type(M[0])!=6){ /* spectre type -> GRS */
1.81 takayama 2460: G=M;
1.6 takayama 2461: L=length(G);
2462: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
2463: V=cons(makev([L+9]),V);
2464: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
2465: if(getopt(short)!=0){
2466: V=append(cdr(V),[V[0]]);
2467: G=shortv(G,V);
2468: }
2469: R=chkspt(G|mat=1);
2470: if(Mt!=1) Mt=0;
2471: if(R[2]!=2 || R[3]!=0 || !(R=getbygrs(G,1|mat=1))) return 0;
2472: MZ=newmat(1,1);
1.81 takayama 2473: SS=length(G)-1;
2474: if(Mt==1) SS=SS*(SS+1)/2;
1.6 takayama 2475: for(M=[],I=0;I<SS;I++) M=cons(MZ,M);
2476: for(RR=R; RR!=[]; RR=cdr(RR)){
2477: RT=car(RR)[0];
2478: if(type(RT)==4){
2479: if(RT[0]!=0) M=mmc(M,[RT[0]]|simplify=Simp);
1.81 takayama 2480: for(TT=cdr(RT);TT!=[];TT=cdr(TT)){
2481: if(car(TT)!=0){
2482: M=mmc(cdr(M),cdr(RT));
2483: break;
2484: }
2485: }
1.6 takayama 2486: }
2487: }
2488: }
2489: if(X==0) return M;
2490: L=length(M);
2491: if((L>=6 && Mt!=0)||(L==3&&Mt==1)){
2492: for(SS=2,I=3; I<L; I+=(++SS));
2493: if(I!=L) return -1;
2494: Mt=1;
2495: }else{
2496: SS=L;Mt=0;
2497: }
1.81 takayama 2498: if(type(X[0])==4){
2499: for(;X!=[];X=cdr(X)) M=mmc(M,car(X));
2500: return M;
2501: }
1.6 takayama 2502: if(length(X)==SS+1){
1.81 takayama 2503: if(car(X)!=0) M=mmc(M,[car(X)]|simplify=Simp);
2504: return mmc(M,cdr(X));
1.6 takayama 2505: }
2506: for(I=X;I!=[];I=cdr(I)) if(I[0]!=0) break;
2507: if(I==[]) return M;
2508: Simp=getopt(simplify);
2509: if(Simp!=0 && type(Simp)!=1) Simp=2;
2510: N=newvect(L);
2511: for(I=0;I<L;I++) N[I]=dupmat(M[I]);
2512: S=size(N[0])[0];
1.81 takayama 2513: if(type(X)==4&&length(X)>=SS){ /* addition */
2514: for(I=0;I<SS;I++,X=cdr(X)) if(car(X) != 0) N[I] = radd(N[I],diagm(S,[car(X)]));
1.6 takayama 2515: }
1.81 takayama 2516: if(length(X)!=1||!X[0]) return N;
1.6 takayama 2517: X=X[0];
2518: MZ = newmat(S,S);
2519: MM = newvect(L);
2520: for(M1=J=0; J<SS; J++){
2521: for(R=[],I=SS-1; I>=0; I--){
2522: if(I==J){
2523: for(RR=[],K=SS-1; K>=0; K--)
2524: RR=cons((K==I)?N[K]+diagm(S,[X]):N[K],RR);
2525: R=cons(RR,R);
2526: }else R=cons([MZ],R);
2527: }
2528: MM[J]=newbmat(SS,SS,R);
2529: if(J==0) M1=MM[0];
2530: else M1=radd(M1,MM[J]);
2531: }
2532: /* middle convolution */
2533: for(P=0,Q=1;J<L;J++){ /* A_{P,Q} */
2534: for(R=[],I=SS-1; I>=0; I--){
2535: for(RR=[],K=SS-1;K>=0;K--){
2536: MT=MZ;
2537: if(I==K){
2538: MT=N[J];
2539: if(I==P) MT-=N[Q];
2540: else if(I==Q) MT-=N[P];
2541: }else if(I==P && K==Q) MT=N[Q];
2542: else if(I==Q && K==P) MT=N[P];
2543: RR=cons(MT,RR);
2544: }
2545: R=cons(RR,R);
2546: }
2547: MM[J]=newbmat(SS,SS,R);
2548: if(++Q==SS){
2549: P++;Q=P+1;
2550: }
2551: }
2552: for(R=[],I=SS-1; I>=0; I--){
2553: for(RR=[N[I]],J=0; J<I; J++) RR=cons(MZ,RR);
2554: R=cons(RR,R);
2555: }
2556: M0 = newbmat(SS,SS,R);
2557: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
2558: if(length(KE) == 0) return MM;
2559: KK = mtoupper(lv2m(KE),0);
2560: for(I=0;I<L;I++) MM[I] = mmod(MM[I],KK);
1.81 takayama 2561: if(Simp!=0){
2562: MM = mdsimplify(MM|type=Simp,show=1);
2563: if(getopt(verb)) show([size(MM[0][0]),MM[1]]);
2564: MM=MM[0];
2565: }
1.6 takayama 2566: return MM;
2567: }
2568:
2569: def lpgcd(L)
2570: {
2571: for(F=[]; L!=[]; L=cdr(L)){
2572: if((P=car(L))==0) continue;
2573: if(F==[]){
2574: F=fctr(P);
2575: S=length(F);
2576: S--;
2577: V=newvect(S);
2578: M=newvect(S);
2579: for(I=0; I<S; I++){
2580: M[I] = F[I+1][1];
2581: V[I] = F[I+1][0];
2582: }
2583: N=nm(ptozp(P|factor=1)[1]);
2584: continue;
2585: }
2586: N=igcd(ptozp(P|factor=1)[1],N);
2587: for(I=0; I<S; I++){
2588: for(Q=P,CT=0; CT<M[I]; CT++)
2589: if((Q=tdiv(Q,V[I])) == 0) break;
2590: if(CT<M[I]) M[I]=CT;
2591: }
2592: }
2593: if(F==[]) return 0;
2594: for(Q=N,I=0;I<S; I++){
2595: while(M[I]>0){
2596: Q *= V[I];
2597: M[I]--;
2598: }
2599: }
2600: return Q;
2601: }
2602:
2603: def mdivisor(M,X)
2604: {
2605: S=size(M=dupmat(M));
2606: XX=(type(X)==4||X==0)?X:[0,X];
2607: S0=S[0]; S1=S[1];
2608: if((Tr=getopt(trans))==1||Tr==2){
2609: Tr0=1;
2610: GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0);
2611: }else Tr=Tr0=0;
2612: /* 0,a,b : (a,b)->(1,1)
2613: 1 : (1,1) invertible
2614: 2,i,M : line 0,i by M
2615: 3,j,M : col 0,j by M
2616: 4,j : col 1 += col j
2617: 5,j,T : line j by T
2618: 6,j,T : col 1 += col j by T (non-com)
2619: 7,j : line 2<->j (non-com)
2620: */
2621: if(type(V=getopt(dviout))==1){
2622: if(type(XX)==4 && type(XX[0])>1) Var=[XX[1],"\\partial"];
2623: else Var=0;
2624: Tr=(abs(V)==3)?0:1;
2625: MM=dupmat(M);
2626: II=((S[0]>S[1])?S[1]:S[0])+1;
2627: if(abs(V)>1){
2628: Is1=Js1=S[0]+S[1];
2629: Is=Js=[0,[Is1]];
2630: }else{
2631: Is=[0,[Is1=S[0]]];Js=[0,[Js1=S[1]]];
2632: }
2633: VV=V;
2634: V=newvect(II);
2635: for(I=0;I<II;I++) V[I]=[];
2636: N=newbmat(2,2,[[M,mgen(S[0],0,[1],0)],[mgen(S[1],0,[1],0)]]);
2637: mdivisor(M,X|step=1,dviout=V);
2638: L=S[0]+S[1];
2639: if(Tr){
2640: NN=mperm(N,Is1,Js1);
2641: for(K=S[0];K<Is1;K++){
2642: for(L=S[1];L<Js1;L++)
2643: NN[K][L]=" ";
2644: }
2645: Out=[[mperm(NN,Is,Js)]];
2646: }
2647: for(I=1;I<II;I++){
2648: I0=I-1;
2649: if(V[I]==[]) continue;
2650: for(T=reverse(V[I]);T!=[];T=cdr(T)){
2651: St=[];
2652: C=car(R=car(T));
2653: if(C==0){
2654: N=mperm(N,(R[1]==0)?0:[[R[1]+I0,I0]],(R[2]==0)?0:[[R[2]+I0,I0]]);
2655:
2656: if(Tr){
2657: if(R[2]!=0) St=append(["C",I,"\\leftrightarrow C",R[2]+I],St);
2658: if(R[1]!=0){
2659: if(R[2]!=0) St=cons(",\\ ",St);
2660: St=append(["L",I,"\\leftrightarrow L",R[1]+I],St);
2661: }
2662: Out=cons(St,Out);
2663: }
2664: }else if(C==1){
2665: P=1/N[I0][I0];N[I0][I0]=1;
2666: if(P!=1){
2667: for(J=I;J<L;J++)
2668: N[I0][J]=muldo(P,N[I0][J],XX);
2669:
2670: if(Tr){
2671: St=append(["L",I,"\\leftarrow(",P,")","\\times L",I],St);
2672: Out=cons(St,Out);
2673: NN=mperm(N,Is1,Js1);
2674: for(K=S[0];K<Is1;K++){
2675: for(L=S[1];L<Js1;L++)
2676: NN[K][L]=" ";
2677: }
2678: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2679: }
2680: }
2681: for(F=0,J=I;J<S[0];J++){
2682: if((P=N[J][I0])==0) continue;
2683: F++;
2684: N[J][I0]=0;
2685: for(K=I;K<L;K++)
2686: N[J][K]=red(N[J][K]-muldo(P,N[I0][K],XX));
2687:
2688: }
2689: if(F){
2690: if(Tr){
2691: Out=cons(["Li\\ -\\!=\\ \\circ\\times L",I,"\\quad(i>",I,")"],Out);
2692: NN=mperm(N,Is1,Js1);
2693: for(K=S[0];K<Is1;K++){
2694: for(L=S[1];L<Js1;L++)
2695: NN[K][L]=" ";
2696: }
2697: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2698: }
2699: }
2700: for(F=0,J=I;J<S[1];J++){
2701: if((P=N[I0][J])==0) continue;
2702: F++;
2703: N[I0][J]=0;
2704: for(K=I;K<L;K++)
2705: N[K][J]=red(N[K][J]-muldo(N[K][I0],P,XX));
2706: }
2707: if(F&&Tr) Out=cons(["Cj\\ -\\!=\\ C",I,"\\times\\circ\\quad(j>",I,")"],Out);
2708: else continue;
2709: }else if(C==2){
2710: C=mat(N[I0],N[R[1]+I0]);C=muldo(R[2],C,XX);
2711: for(J=0;J<L;J++){
2712: N[I0][J]=C[0][J];N[R[1]+I0][J]=C[1][J];
2713: }
2714: if(Tr) Out=cons([dupmat(R[2]),"\\begin{pmatrix}L",I,"\\\\L",R[1]+I,
2715: "\\end{pmatrix}"],Out);
2716: }else if(C==3){
2717: C=newmat(L,2);
2718: for(J=0;J<L;J++){
2719: C[J][0]=N[J][I0];C[J][1]=N[J][R[1]+I0];
2720: }
2721: C=muldo(C,R[2],XX);
2722: for(J=0;J<L;J++){
2723: N[J][I0]=C[J][0];N[J][R[1]+I0]=C[J][1];
2724: }
2725: if(Tr) Out=cons(["\\begin{pmatrix}C",I,"&C",R[1]+I,"\\end{pmatrix}",
2726: dupmat(R[2])],Out);
2727: }else if(C==4){
2728: for(J=0;J<L;J++)
2729: N[J][I0]=red(N[J][I0]+N[J][R[1]+I0]);
2730: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",R[1]+I],Out);
2731: }else if(C==5){
2732: for(J=0;J<L;J++)
2733: N[I0+R[1]][J]=red(R[2]*N[I0+R[1]][J]);
2734: if(Tr) Out=cons(["L",I+R[1],"\\leftarrow(", R[2],")\\times L",I+R[1]],
2735: Out);
2736: }else if(C==6){
2737: for(J=0;J<L;J++)
2738: N[J][I0]=N[J][I0]+muldo(N[J][I0+R[1]],R[2],XX);
2739: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",I+R[1],"\\times(", R[2],")"],
2740: Out);
2741: }else if(C==7){
2742: mycat(["line",I+1,"\\leftrightarrow",R[1]+I]);
2743: for(J=0;J<L;J++){
2744: C=N[I][J];N[I][J]=N[R[1]+I0][J];N[R[1]+I0][J]=C;
2745: }
2746: if(Tr) Out=cons(["L",I+1,"\\leftrightarrow L",R[1]+I],Out);
2747: }
2748: if(Tr){
2749: NN=mperm(N,Is,Js);
2750: for(K=S[0];K<Is1;K++){
2751: for(L=S[1];L<Js1;L++)
2752: NN[K][L]=" ";
2753: }
2754: Out=cons(["\\to",NN],Out);
2755: }
2756: }
2757: }
2758: if(!Tr){
2759: NN=mperm(N,Is,Js);
2760: Out=[];
2761: }
2762: if(S[0]+S[1]==Is1){
2763: N1=mperm(NN,[0,[S[0]]],[S[1],[S[0]]]);
2764: N2=mperm(NN,[S[0],[S[1]]],[0,[S[1]]]);
2765: N3=mperm(NN,[0,[S[0]]],[0,[S[1]]]);
2766: R1=mdivisor(N1,X|trans=1)[1];
2767: R2=mdivisor(N2,X|trans=1)[1];
2768: if(Tr){
2769: Out=cons(["\\text{As a result,}"],Out);
2770: Out=cons([N3,"=",N1,MM,N2],Out);
2771: if(S[0]==S[1] && N3==mgen(S[0],0,1,0)){
2772: Out=cons(["=",muldo(N2,N1,XX),MM,"."],Out);
2773: }else{
2774: Out=cons([N1,"^{-1}=",R1,","],Out);
2775: Out=cons([N2,"^{-1}=",R2,"."],Out);
2776: }
2777: }else{
2778: Out=cons([N3,"=P",MM,"Q,"],Out);
2779: Out=cons(["P=",N1,"=",R1,"^{-1},"],Out);
2780: Out=cons(["Q=",N2,"=",R2,"^{-1}."],Out);
2781: }
2782: }
2783: Out = ltotex(reverse(Out)|opt=["cr","spts0"],str=1,cr=15,var=Var);
2784: if(S[0]+S[1]==Is1)
2785: Out=str_subst(Out,"\\texttt{ }","");
2786: if(VV>0){
2787: dviout(Out|eq=6);
2788: return NN;
2789: }
2790: return Out;
2791: }else if(type(V)!=5) V=0;
2792:
2793: if(type(St=getopt(step))!=1) St=0;
2794: for(FF=": start";;){
2795: if(St && V==0){
2796: if(Tr){
2797: mycat0([St,FF,"\n"],0);
2798: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2799: }
2800: else mycat0([St,FF,"\n",M,"\n"],0);
2801: }
2802: if(X==0||X==[0,0]){ /* search minimal non-zero element */
2803: for(K=F=I=0; I<S0; I++){
2804: for(J=0; J<S1; J++){
2805: if((P=abs(M[I][J]))!=0 && (K>P || K==0)){
2806: K=P; R=[I,J];
2807: }
2808: }
2809: }
2810: R=cons(K-1,[R]);
2811: }
2812: else R=mymindeg(M,XX[1]|opt=1);
2813: if(R[0]<0){ /*zero matrix */
2814: if(Tr) return [[],mgen(S0,0,1,0),mgen(S1,0,1,0)];
2815: return [];
2816: }
2817: R0=R[1][0];R1=R[1][1];
2818: if(R0!=0){
2819: M=rowx(M,0,R0);
2820: if(Tr) GR=rowx(GR,0,R0);
2821: }
2822: if(R1!=0){
2823: M=colx(M,0,R1);
2824: if(Tr) GC=colx(GC,0,R1);
2825: }
2826: if(St>0 && (R0!=0 || R1!=0))
2827: if(type(V)==5) V[St]=cons([0,R0,R1],V[St]);
2828: else if(Tr){
2829: mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n"],0);
2830: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2831: }else mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n",M,"\n"],0);
2832: if(R[0]==0){ /* (1,1) : invertible */
2833: if(type(V)==5) V[St]=cons([1],V[St]);
2834: P=M[0][0]; M[0][0]=1;
2835: for(J=0;J<S1;J++){ /* (1,1) -> 1 */
2836: if(J>0) M[0][J]= red(M[0][J]/P);
2837: if(Tr) GR[0][J]=red(GR[0][J]/P);
2838: }
2839: if(S0>1 && S1>1) N=newmat(S0-1,S1-1);
2840: else N=0;
2841: for(I=1;I<S0;I++){
2842: P=M[I][0]; M[I][0]=0;
2843: for(J=1;J<S1;J++)
2844: N[I-1][J-1]=M[I][J]=red(M[I][J] - muldo(P,M[0][J],XX));
2845: if(Tr){
2846: for(J=0;J<S0;J++)
2847: GR[I][J] = red(GR[I][J] -muldo(P,GR[0][J],XX));
2848: }
2849: }
2850: if(Tr){
2851: for(J=1;J<S1; J++){
2852: for(I=0;I<S1;I++) GC[I][J]=red(GC[I][J]-muldo(GC[I][0],M[0][J],XX));
2853: M[0][J]=0;
2854: }
2855: }
2856: if(St>0 && V==0){
2857: if(Tr){
2858: mycat0([St,": unit\n"],0);
2859: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2860: }
2861: else mycat0([St,": unit\n",M,"\n"],0);
2862: }
2863: if(N==0){
2864: if(!Tr) return [1];
2865: if(Tr==2){
2866: GR0=mdivisor(GR,X|trans=1)[1];
2867: GC0=mdivisor(GC,X|trans=1)[1];
2868: return [[1],GR,GC,GR0,GC0];
2869: }
2870: return [[1],GR,GC];
2871: }
2872: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2873: if(!Tr) return cons(1,R);
2874: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2875: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2876: if(S0==S1 && countin(1,1,R[0])==S0-1){
2877: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2878: }
2879: if(Tr==2){
2880: GR0=mdivisor(GR,X|trans=1)[1];
2881: GC0=mdivisor(GC,X|trans=1)[1];
2882: return [cons(1,R[0]),GR,GC,GR0,GC0];
2883: }
2884: return [cons(1,R[0]),GR,GC];
2885: }
2886: for(I=1;I<S0;I++){
2887: if(M[I][0]!=0){
2888: /* Error! when mygcd(A,B,0) with A<=0 or B<=0 */
2889: R=mygcd(M[I][0],M[0][0],XX); /* R[0]=R[1]*M[I][0]+R[2]*M[0][0] */
2890: M[0][0]=R[0]; M[I][0]=0; /* 0=R[3]*M[I][0]+R[4]*M[0][0] */
2891: for(J=1;J<S1;J++){
2892: T=red(muldo(R[1],M[I][J],XX)+muldo(R[2],M[0][J],XX));
2893: M[I][J]=red(muldo(R[3],M[I][J],XX)+muldo(R[4],M[0][J],XX));
2894: M[0][J]=T;
2895: }
2896: if(Tr){
2897: for(J=0;J<S0;J++){
2898: T=red(muldo(R[1],GR[I][J],XX)+muldo(R[2],GR[0][J],XX));
2899: GR[I][J]=red(muldo(R[3],GR[I][J],XX)+muldo(R[4],GR[0][J],XX));
2900: GR[0][J]=T;
2901: }
2902: }
2903: if(St && V==0){
2904: mycat([" [",R[2],R[1],"]*"]);
2905: mycat([" [",R[4],R[3],"]"]);
2906: }
2907: if(type(V)==5) V[St]=cons([2,I,mat([R[2],R[1]],[R[4],R[3]])],V[St]);
2908: FF=": line 1 & "+rtostr(I+1); I=S0;
2909: }
2910: }
2911: if(I>S0) continue;
2912: for(J=1;J<S1;J++){
2913: if(M[0][J]!=0){
2914: R=mygcd(M[0][J],M[0][0],XX|rev=1); /* R[0]=M[0][J]*R[1]+M[0][0]*R[2] */
2915: M[0][0]=R[0]; M[0][J]=0; /* 0=M[0][J]*R[3]+M[0][0]*R[4] */
2916: for(I=1;I<S0;I++){
2917: T=red(muldo(M[I][J],R[1],XX)+muldo(M[I][0],R[2],XX));
2918: M[I][J]=red(muldo(M[I][J],R[3],XX)+muldo(M[I][0],R[4],XX));
2919: M[I][0]=T;
2920: }
2921: if(Tr){
2922: for(I=0;I<S1;I++){
2923: T=red(muldo(GC[I][J],R[1],XX)+muldo(GC[I][0],R[2],XX));
2924: GC[I][J]=red(muldo(GC[I][J],R[3],XX)+muldo(GC[I][0],R[4],XX));
2925: GC[I][0]=T;
2926: }
2927: }
2928: if(type(V)==5) V[St]=cons([3,J,mat([R[2],R[4]],[R[1],R[3]])],V[St]);
2929: FF=": column 1 & "+rtostr(J+1);J=S1;
2930: if(St && V==0){
2931: mycat([" *[",R[2],R[4],"]"]);
2932: mycat([" [",R[1],R[3],"]"]);
2933: }
2934: }
2935: }
2936: if(J>S1) continue;
2937: if(S0==1 || S1==1){
2938: P=M[0][0];
2939: if(X==0){
2940: if(P<0){
2941: P=-P;
2942: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2943: if(type(V)==5) V[St]=cons([5,0,-1],V[St]);
2944: }
2945: }else{
2946: P=nm(P);
2947: if((R=fctr(P)[0][0])!=1){
2948: P/=R;
2949: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=R;
2950: if(type(V)==5) V[St]=cons([5,0,1/R],V[St]);
2951: }
2952: }
2953: if(!Tr) return [P];
2954: if(Tr==2){
2955: GR0=mdivisor(GR,X|trans=1)[1];
2956: GC0=mdivisor(GC,X|trans=1)[1];
2957: return [[P],GR,GC,GR0,GC0];
2958: }
2959: return [[P],GR,GC];
2960: }
2961: if(XX==0 || (type(XX)==4 && XX[0]==0)){ /* commutative case */
2962: P=M[0][0];
2963: for(I=1; I<S0; I++){
2964: for(J=1; J<S1; J++)
2965: if(divdo(M[I][J],P,XX)[1]!=0) break;
2966: if(J<S1){
2967: if(type(V)==5) V[St]=cons([4,J],V[St]);
2968: FF=": column 1 += col"+rtostr(J+1);
2969: for(I=1;I<S0;I++) M[I][0]=M[I][J];
2970: if(Tr) for(I=0;I<S1;I++) GC[I][0]=red(GC[I][0]+GC[I][J]);
2971: break;
2972: }
2973: }
2974: if(J<S1) continue;
2975: N=newmat(S0-1,S1-1);
2976: for(I=1;I<S0;I++)
2977: for(J=1;J<S1;J++) N[I-1][J-1]=red(M[I][J]/P);
2978: if(X==0){
2979: if(P<0) P=-P;
2980: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2981: }else{
2982: P=M[0][0];
2983: P=nm(P);
2984: P/=fctr(P)[0][0];
2985: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=fctr(P)[0][0];
2986: }
2987: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2988: RT=(Tr)?R[0]:R;
2989: for(RR=[],L=reverse(RT);L!=[];L=cdr(L))
2990: RR=cons(red(P*car(L)),RR);
2991: RR=cons(P,RR);
2992: if(!Tr) return RR;
2993: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2994: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2995: if(S0==S1 && countin(1,1,RR)==S0){
2996: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2997: }
2998: if(Tr==2){
2999: GR0=mdivisor(GR,X|trans=1)[1];
3000: GC0=mdivisor(GC,X|trans=1)[1];
3001: return [RR,GR,GC,GR0,GC0];
3002: }
3003: return [RR,GR,GC];
3004: } /* End of commutative case */
3005: for(I=1; I<S0; I++){
3006: for(J=1; J<S1; J++){
3007: if(M[I][J] != 0){
3008: for(T=1;I<S0;T*=XX[0]){
3009: R=divdo(muldo(M[I][J],T,XX),M[0][0],XX);
3010: if(R[1]!=0){
3011: if(type(V)==5) V[St]=cons([6,J,T],V[St]);
3012: FF=": column 1 += col"+rtostr((J+1)*T);
3013: if(I>1){
3014: M=rowx(M,1,I);
3015: if(Tr) GR=rowx(GR,1,I);
3016: if(type(V)==5) V[St]=cons([7,I],V[St]);
3017: FF+=", line 2<->"+rtostr(I+1);
3018: }
3019: for(I=1;I<S0;I++) M[I][0]=muldo(M[I][J],T,XX);
3020: if(Tr)
3021: for(I=1;I<S1;I++) GC[I][0]=red(GC[I][0]+muldo(GC[I][J],T,XX));
3022: I=S0+1; J=S1;
3023: break;
3024: }
3025: }
3026: }
3027: }
3028: if(I>S0) break;
3029: }
3030: if(I==S0) return []; /* zero matrix : never happen */
3031: }
3032: }
3033:
3034: def mdsimplify(L)
3035: {
3036: T=getopt(type);
3037: SS=0;
3038: if(type(L)==6){
3039: L=[L]; SS=1;
3040: }
3041: if(type(L)==5){
3042: SS=2;
3043: L = vtol(L);
3044: }
3045: M=car(L);
3046: S=size(M)[0];
3047: #if 0
3048: MN=newmat(S,S);
3049: MD=newmat(S,S);
3050: for(I=0;I<S;I++){
3051: for(J=0;J<S;J++){
3052: TN=0;TD=1;
3053: for(PL=L;PL!=[];PL=cdr(PL)){
3054: TM=red(car(PL)[I][J]);
3055: TN=lgcd([TN,nm(TM)]|pol=1);
3056: TD=llcm([TD,dn(TM)]|pol=1);
3057: }
3058: MN[I][J]=TM;
3059: MD[I][J]=TN;
3060: }
3061: }
3062: for(I=0;I<S;I++){
3063: for(J=0;J<S;J++){
3064: if(I==J||type(TD[I][J])<2||type(TN[J][I])<2) continue;
3065: for(FC=cdr(fctr(TD[I][J]));FC!=[];){
3066: TFC=car(FC);
3067: if(type(red(TN[J][I]/TFC[0]))>2) continue;
3068: }
3069: }
3070: }
3071: #endif
3072: DD=newvect(S);
3073: for(I=0; I<S; I++){
3074: LN=RN=[];
3075: LD=RD=1;
3076: for(LL=L; LL!=[]; LL=cdr(LL)){
3077: M = car(LL);
3078: for(J=0; J<S; J++){
3079: if(J==I) continue;
3080: if((MM=M[I][J]) != 0){
3081: LN = cons(nm(MM),LN);
3082: if(type(MM)==3 && tdiv(LD,P=dn(MM))==0)
3083: LD=tdiv(LD*P,gcd(LD,P));
3084: }
3085: if((MM=M[J][I]) != 0){
3086: RN = cons(nm(MM),RN);
3087: if(type(MM)==3 && tdiv(RD,P=dn(MM))==0)
3088: RD=tdiv(RD*P,gcd(RD,P));
3089: }
3090: }
3091: }
3092: if(T==1 || T==3) LQ=RD;
3093: else{
3094: P=lpgcd(LN);
3095: LQ=gcd(P,RD);
3096: if(P!=0) LQ *= nm(fctr(P)[0][0]);
3097: }
3098: if(T==1 || T==2) RQ=LD;
3099: else{
3100: P=lpgcd(RN);
3101: RQ=gcd(P,LD);
3102: if(P!=0) RQ *= nm(fctr(P)[0][0]);
3103: }
3104: if((P=gcdz(LQ,RQ))!=1){
3105: LQ = red(LQ/P); RQ=red(RQ/P);
3106: }
3107: DD[I]=red(LQ/RQ);
3108: if(LQ!=1 || RQ!=1){
3109: for(LA=[],LL=L; LL!=[]; LL=cdr(LL)){
3110: M = car(LL);
3111: for(J=0; J<S; J++){
3112: if(I!=J){
3113: if(LQ!=1){
3114: M[I][J] = red(M[I][J]/LQ);
3115: M[J][I] = red(M[J][I]*LQ);
3116: }
3117: if(RQ!=1){
3118: M[J][I] = red(M[J][I]/RQ);
3119: M[I][J] = red(M[I][J]*RQ);
3120: }
3121: }
3122: }
3123: }
3124: }
3125: }
3126: if(SS==2) L=ltov(L);
3127: if(SS==1) L=L[0];
3128: if(getopt(show)==1) L=[L,DD];
3129: return L;
3130: }
3131:
1.81 takayama 3132: #if 1
1.6 takayama 3133: def m2mc(M,X)
3134: {
3135: if(type(M)<2){
3136: mycat([
3137: "m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
3138: " m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
3139: " t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
3140: " s : TeX, dviout, GRSC\n",
3141: " option : swap, small, simplify, operator, int\n",
3142: " Ex: m2mc(\"21,21,21,21\",\"All\")\n"
3143: ]);
3144: return 0;
3145: }
3146: if(type(M)==7) M=s2sp(M);
3147: if(type(X)==7) X=[X];
3148: Simp=getopt(simplify);
3149: if(Simp!=0 && type(Simp)!=1) Simp=2;
3150: Small=(getopt(small)==1)?1:0;
3151: if(type(M[0])==4){
3152: if(type(M[0][0])==1){ /* spectral type */
3153: XX=getopt(dep);
3154: if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
3155: M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
3156: if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
3157: if(getopt(int)!=0){
3158: T=M[XX[0]-1][XX[1]-1][1];
3159: for(V=vars(T);V!=[];V=cdr(V)){
3160: F=coef(T,1,car(V));
3161: if(type(F)==1 && dn(F)>1)
3162: M = subst(M,car(V),dn(F)*car(V));
3163: }
3164: }
3165: V=vars(M);
3166: if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
3167: M=subst(M,d1,d);
3168: }
3169: RC=chkspt(M|mat=1);
3170: if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
3171: erno(0);return 0;
3172: }
3173: R=getbygrs(M,1|mat=1);
3174: if(getopt(anal)==1) return R; /* called by mc2grs() */
3175: Z=newmat(1,1,[[0]]);
3176: N=[Z,Z,Z,Z,Z];
3177: for(RR=R; RR!=[]; RR=cdr(RR)){
3178: RT=car(RR)[0];
3179: if(type(RT)==4){
3180: if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
3181: N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
3182: }
3183: }
3184: if(type(X)==4 && type(X[0])==7)
3185: return m2mc(N,X|keep=Keep,small=Small);
3186: return N;
3187: }
3188: if(type(X)==4 && type(X[0])==7){
3189: Keep=(getopt(keep)==1)?1:0;
3190: if(X[0]=="All"){
3191: dviout("Riemann scheme"|keep=1);
3192: m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
3193: dviout("Spectral types : "|keep=1);
3194: m2mc(M,["sp","dviout"]|keep=1);
3195: dviout("\\\\\nBy the decompositions"|keep=1);
3196: R=m2mc(M,["pairs","dviout"]|keep=1);
3197: for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
3198: for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
3199: if(S==0) R0=cons(I,R0);
3200: else if(S<0) R1=cons(I,R1);
3201: }
3202: S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
3203: +"\\ \\emptyset=\\mathbb Z\\cap$";
3204: dviout(S|keep=1);
3205: m2mc(M,["irreducible","dviout"]|keep=1);
3206: if(R0!=[])
3207: dviout(ltotex(reverse(R0))|eq=0,keep=1,
3208: title="The following conditions may not be necessary for the irreducibility.");
3209: if(R1!=[])
3210: dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
3211: if(getopt(operator)!=0){
3212: dviout("The equation in a Pfaff form is"|keep=1);
3213: m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
3214: }
3215: else if(Keep!=1) dviout(" ");
3216: return M;
3217: }
3218: Show=0;
3219: if(length(X)>1){
3220: if(X[1]=="dviout") Show=2;
3221: if(X[1]=="TeX") Show=1;
3222: }
1.81 takayama 3223: if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"||X[0]=="extend"){
1.6 takayama 3224: Y=radd(-M[0],-M[1]-M[2]);
1.81 takayama 3225: if(X[0]=="extend")
3226: return [M[1],M[0],M[2],Y, M[3],M[4],radd(-M[1],-M[3]-M[4]),
3227: radd(Y,-M[3]-M[4]),radd(M[1],M[2]+M[4]), radd(M[0],M[1]+M[3])];
1.6 takayama 3228: if(X[0]!="GRSC"){
3229: 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);
3230: if(X[0]=="sp"){
3231: L=chkspt(L|opt="sp");
3232: V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
3233: if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
3234: return [V,W];
3235: }
3236: S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
3237: }else{
3238: 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]),
3239: radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
3240: 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";
3241: }
3242: T=ltotex(L|opt="GRS",pre=S,small=Small);
3243: if(Show==2) dviout(T|eq=0,keep=Keep);
3244: if(Show==1) L=T;
3245: return L;
3246: }
3247: if(X[0]=="Pfaff"){
3248: S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
3249: if(Show==2) dviout(S|eq=0,keep=Keep);
3250: return S;
3251: }
3252: if(X[0]=="irreducible"){
3253: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3254: S=getbygrs(L,10|mat=1);
3255: if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
3256: return S;
3257: }
3258: if(X[0]=="pairs"||X[0]=="pair"){
3259: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3260: S=chkspt(L|opt=0);
3261: V=(Show==2)?1:0;
3262: S=sproot(L,X[0]|dviout=V,keep=Keep);
3263: return S;
3264: }
3265: if(X[0]=="swap"){
3266: Swap=getopt(swap);
3267: if(type(Swap)<1 || Swap==1)
3268: return newvect(5,[M[3],M[1],M[4],M[0],M[2]]);
3269: if(Swap==2)
3270: return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
3271: if(type(Swap)==4 && length(Swap)==3){
3272: MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
3273: if(Swap[0]==1){
3274: MX0=M[2];MY0=M[4];
3275: }
3276: else if(Swap[0]==2){
3277: MX0=MX;MY0=MY;
3278: }else{
3279: MX0=M[0];MY0=M[3];
3280: }
3281: if(Swap[1]==1){
3282: MX1=M[2];MY1=M[4];
3283: }
3284: else if(Swap[1]==2){
3285: MX1=MX;MY1=MY;
3286: }else{
3287: MX1=M[0];MY1=M[3];
3288: }
3289: return newvect(5,MX0,M[1],MX1,MY0,MY1);
3290: }
3291: }
3292: return 0;
3293: }
3294: if(getopt(swap)==1)
3295: return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
3296: N=newvect(5);
3297: for(I=0;I<5;I++)
3298: N[I]=M[I];
3299: S=size(N[0])[0];
3300: if(type(X)==4){
3301: for(I=0;I<3;I++){
3302: if(X[I] != 0)
3303: N[I] = radd(N[I],X[I]);
3304: }
3305: if(length(X)==3) return N;
3306: X=X[3];
3307: }
3308: MZ = newmat(S,S);
3309: ME = mgen(S,0,[X],0);
3310: MM = newvect(5);
3311: MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]);
3312: MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]);
3313: MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]);
3314: MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]);
3315: MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]);
3316: M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
3317: M1 = radd(MM[0],MM[1]+MM[2]);
3318: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
3319: if(length(KE) == 0) return MM;
3320: KK = mtoupper(lv2m(KE),0);
3321: for(I=0;I<5;I++)
3322: MM[I] = mmod(MM[I],KK);
1.81 takayama 3323: if(Simp!=0){
3324: MM = mdsimplify(MM|type=Simp);
3325: if(getopt(verb)) show([size(MM[0][0]),MM[1]]);
3326: MM=MM[0];
3327: }
3328: return MM;
3329: }
3330: #else
3331: def m2mc(M,X)
3332: {
3333: if(type(M)<2){
3334: mycat([
3335: "m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
3336: " m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
3337: " t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
3338: " s : TeX, dviout, GRSC\n",
3339: " option : swap, small, simplify, operator, int\n",
3340: " Ex: m2mc(\"21,21,21,21\",\"All\")\n"
3341: ]);
3342: return 0;
3343: }
3344: if(type(M)==7) M=s2sp(M);
3345: if(type(X)==7) X=[X];
3346: Simp=getopt(simplify);
3347: if(Simp!=0 && type(Simp)!=1) Simp=2;
3348: Small=(getopt(small)==1)?1:0;
3349: if(type(M[0])==4){
3350: if(type(M[0][0])==1){ /* spectral type */
3351: XX=getopt(dep);
3352: if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
3353: M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
3354: if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
3355: if(getopt(int)!=0){
3356: T=M[XX[0]-1][XX[1]-1][1];
3357: for(V=vars(T);V!=[];V=cdr(V)){
3358: F=coef(T,1,car(V));
3359: if(type(F)==1 && dn(F)>1)
3360: M = subst(M,car(V),dn(F)*car(V));
3361: }
3362: }
3363: V=vars(M);
3364: if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
3365: M=subst(M,d1,d);
3366: }
3367: RC=chkspt(M|mat=1);
3368: if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
3369: erno(0);return 0;
3370: }
3371: R=getbygrs(M,1|mat=1);
3372: if(getopt(anal)==1) return R; /* called by mc2grs() */
3373: Z=newmat(1,1,[[0]]);
3374: N=[Z,Z,Z,Z,Z,Z];
3375: for(RR=R; RR!=[]; RR=cdr(RR)){
3376: RT=car(RR)[0];
3377: if(type(RT)==4){
3378: if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
3379: N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
3380: }
3381: }
3382: if(type(X)==4 && type(X[0])==7)
3383: return m2mc(N,X|keep=Keep,small=Small);
3384: return N;
3385: }
3386: if(type(X)==4 && type(X[0])==7){
3387: Keep=(getopt(keep)==1)?1:0;
3388: if(X[0]=="All"){
3389: dviout("Riemann scheme"|keep=1);
3390: m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
3391: dviout("Spectral types : "|keep=1);
3392: m2mc(M,["sp","dviout"]|keep=1);
3393: dviout("\\\\\nBy the decompositions"|keep=1);
3394: R=m2mc(M,["pairs","dviout"]|keep=1);
3395: for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
3396: for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
3397: if(S==0) R0=cons(I,R0);
3398: else if(S<0) R1=cons(I,R1);
3399: }
3400: S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
3401: +"\\ \\emptyset=\\mathbb Z\\cap$";
3402: dviout(S|keep=1);
3403: m2mc(M,["irreducible","dviout"]|keep=1);
3404: if(R0!=[])
3405: dviout(ltotex(reverse(R0))|eq=0,keep=1,
3406: title="The following conditions may not be necessary for the irreducibility.");
3407: if(R1!=[])
3408: dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
3409: if(getopt(operator)!=0){
3410: dviout("The equation in a Pfaff form is"|keep=1);
3411: m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
3412: }
3413: else if(Keep!=1) dviout(" ");
3414: return M;
3415: }
3416: Show=0;
3417: if(length(X)>1){
3418: if(X[1]=="dviout") Show=2;
3419: if(X[1]=="TeX") Show=1;
3420: }
3421: if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"||X[0]=="extend"){
3422: Y=radd(-M[0],-M[1]-M[2]);
3423: if(X[0]=="extend")
3424: return [M[1],M[0],M[2],Y, M[3],M[4],radd(-M[1],-M[3]-M[4]),
3425: radd(Y,-M[3]-M[4]),radd(M[1],M[2]+M[4]), radd(M[0],M[1]+M[3])];
3426: if(X[0]!="GRSC"){
3427: 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);
3428: if(X[0]=="sp"){
3429: L=chkspt(L|opt="sp");
3430: V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
3431: if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
3432: return [V,W];
3433: }
3434: S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
3435: }else{
3436: 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]),
3437: radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
3438: 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";
3439: }
3440: T=ltotex(L|opt="GRS",pre=S,small=Small);
3441: if(Show==2) dviout(T|eq=0,keep=Keep);
3442: if(Show==1) L=T;
3443: return L;
3444: }
3445: if(X[0]=="Pfaff"){
3446: S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
3447: if(Show==2) dviout(S|eq=0,keep=Keep);
3448: return S;
3449: }
3450: if(X[0]=="irreducible"){
3451: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3452: S=getbygrs(L,10|mat=1);
3453: if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
3454: return S;
3455: }
3456: if(X[0]=="pairs"||X[0]=="pair"){
3457: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
3458: S=chkspt(L|opt=0);
3459: V=(Show==2)?1:0;
3460: S=sproot(L,X[0]|dviout=V,keep=Keep);
3461: return S;
3462: }
3463: if(X[0]=="swap"){
3464: Swap=getopt(swap);
3465: if(type(Swap)<1 || Swap==1)
3466: return newvect(6,[M[3],M[1],M[4],M[0],M[2],M[5]]);
3467: if(Swap==2)
3468: return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
3469: if(type(Swap)==4 && length(Swap)==3){
3470: MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
3471: if(Swap[0]==1){
3472: MX0=M[2];MY0=M[4];
3473: }
3474: else if(Swap[0]==2){
3475: MX0=MX;MY0=MY;
3476: }else{
3477: MX0=M[0];MY0=M[3];
3478: }
3479: if(Swap[1]==1){
3480: MX1=M[2];MY1=M[4];
3481: }
3482: else if(Swap[1]==2){
3483: MX1=MX;MY1=MY;
3484: }else{
3485: MX1=M[0];MY1=M[3];
3486: }
3487: return newvect(5,MX0,M[1],MX1,MY0,MY1);
3488: }
3489: }
3490: return 0;
3491: }
3492: if(getopt(swap)==1)
3493: return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
3494: N=newvect(6);
3495: for(I=0;I<6;I++)
3496: N[I]=M[I];
3497: S=size(N[0])[0];
3498: if(type(X)==4){
3499: for(I=0;I<3;I++){
3500: if(X[I] != 0)
3501: N[I] = radd(N[I],X[I]);
3502: }
3503: if(length(X)==3) return N;
3504: X=X[3];
3505: }
3506: MZ = newmat(S,S);
3507: ME = mgen(S,0,[X],0);
3508: MM = newvect(6);
3509: MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]); /* A01 */
3510: MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]); /* A02 */
3511: MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]); /* A03 */
3512: MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]); /* A12 */
3513: MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]); /* A23 */
3514: MM[5] = newbmat(3,3, [[MZ,N[5]+N[2],-N[2]], [N[5]], [MZ,-N[0],radd(N[5],N[0])]]); /* A13 */
3515: M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
3516: M1 = radd(MM[0],MM[1]+MM[2]);
3517: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
3518: if(length(KE) == 0) return MM;
3519: KK = mtoupper(lv2m(KE),0);
3520: for(I=0;I<6;I++)
3521: MM[I] = mmod(MM[I],KK);
1.6 takayama 3522: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
3523: return MM;
3524: }
1.81 takayama 3525: #endif
1.6 takayama 3526:
3527: def easierpol(P,X)
3528: {
3529: if(type(X) == 4){
3530: for( Y = [] ; X != []; X = cdr(X) )
3531: Y = cons([0,car(X)], Y);
3532: }else
3533: Y = [0,X];
3534: return rede(P,Y);
3535: }
3536:
3537: def l2p(L,V)
3538: {
3539: if(type(L)==4){
3540: for(S=I=0;L!=[];L=cdr(L),I++)
3541: S+=car(L)*V^I;
3542: return S;
3543: }else if(type(L)==5){
3544: for(S=0,I=size(L)-1;I>=0;I--)
3545: S+=L[I]*V^I;
3546: return S;
3547: }else{
3548: if(type(D=getopt(size))==1) D--;
3549: else D=mydeg(L,V);
3550: for(S=[];D>=0;D--)
3551: S=cons(mycoef(L,D,V),S);
3552: return S;
3553: }
3554: }
3555:
3556: def paracmpl(L,V)
3557: {
3558: if(type(L)==4) L=ltov(L);
3559: S=length(L);
3560: Lim=getopt(lim);Low=getopt(low);
3561: if((F=type(L[0]))>3){
3562: SV=length(L[0]);
3563: V0=makenewv(L);
3564: for(LL=[];S>0;S--)
3565: LL=cons(l2p(L[S-1],V0),LL);
3566: G=paracmpl(LL,V|option_list=getopt());
3567: H=(Lim==1)?G:G[0];
3568: for(HH=[];H!=[];H=cdr(H)){
3569: HT=l2p(car(H),V0|size=SV);
3570: if(F==5) HT=ltov(HT);
3571: HH=cons(HT,HH);
3572: }
3573: H=reverse(HH);
3574: return (Lim==1)?H:[H,G[1]];
3575: }
3576: H=newvect(S);D=newvect(S);
3577: for(Dn=1,I=0;I<S;I++){
3578: P=dn(L[I]=red(L[I]));
3579: Dn=red(Dn*P/gcd(Dn,P));
3580: }
3581: if(Dn!=1){
3582: for(I=0;I<S;I++) L[I]=red(Dn*L[I]);
3583: }
3584: G=diagm(S,[1]);
3585: if(type(V)<4) V=[V];
3586: VV=lsort(vars(L),V,1);
3587: V=car(V);
3588: for(I=0;I<S;I++){
3589: P=L[I];
3590: for(J=0,C=P;J<I;J++){
3591: if(D[J]!=[]){
3592: C=mycoef(C,DT,VV);
3593: P-=C*H[J];
3594: G=cola(G,I,J,-C);
3595: }
3596: }
3597: if(P==0){
3598: D[I]=[];continue;
3599: }
3600: P0=nm(red(P));
3601: K=mymindeg(P0,V);
3602: C=mycoef(P0,K,V);
3603: if(K>0){
3604: P=red(P/V^K);
3605: G=colm(G,I,1/V^K);
3606: }
3607: for(DT=[],VT=VV;VT!=[];VT=cdr(VT)){
3608: K=(Low==1)?mymindeg(C,car(VT)):mydeg(C,car(VT));
3609: C=mycoef(C,K,car(VT));
3610: DT=cons(K,DT);
3611: }
3612: D[I]=DT=reverse(DT);
3613: for(C=P,VT=VV;VT!=[];VT=cdr(VT),DT=cdr(DT))
3614: C=mycoef(C,car(DT),car(VT));
3615: H[I]=P=red(P/C);
3616: G=colm(G,I,1/C);
3617: }
3618: if(Dn!=1){
3619: for(I=0;I<S;I++){
3620: TH=red(H[I]/Dn);
3621: F=fctr(dn(TH));F=cdr(F);
3622: if(Lim!=1||subst(Dn,V,0)==0){
3623: for(;F!=[];F=cdr(F)){
3624: if(lsort(vars(car(F)[0]),VV,2)==[]){
3625: C=car(F)[0]^car(F)[1];
3626: TH=red(TH*C);
3627: G=colm(G,I,C);
3628: }
3629: }
3630: }
3631: H[I]=TH;
3632: }
3633: }
3634: H=vtol(H);
3635: if(Lim==1){
3636: H=subst(H,V,0);
3637: return map(red,H);
3638: }
3639: return [H,map(red,G)];
3640: }
3641:
3642: def mykernel(M)
3643: {
3644: if(getopt(opt) == 1)
3645: M = mtranspose(M);
3646: S = size(M);
3647: R = [];
3648: MM = mtoupper(M,-1);
3649: for(I = S[0]-1; I >= 0; I--){
3650: for(J = S[1]-1; J >= 0; J--){
3651: if(MM[I][J] != 0)
3652: return R;
3653: }
3654: P = easierpol(MM[I][S[1]],zz);
3655: RR = newvect(S[0]);
3656: for(J = 0; J < S[0]; J++)
3657: RR[J] = mycoef(P,J,zz);
3658: R = cons(RR,R);
3659: }
3660: return R;
3661: }
3662:
3663: def myimage(M)
3664: {
3665: if(getopt(opt) == 1)
3666: M = mtranspose(M);
3667: S = size(M);
3668: V = [];
3669: M0 = newvect(S[1]);
3670: M = mtoupper(M,0|opt=1);
3671: for(I = S[0]-1; I >= 0; I--)
3672: if(M0 != M[I])
3673: V = cons(vtozv(M[I])[0], V);
3674: return V;
3675: }
3676:
3677: def mymod(V,L)
3678: {
3679: Opt = getopt(opt);
3680: S = length(V);
3681: VP = newvect(S);
3682: if(type(L)==6)
3683: L=m2lv(L);
3684: CT = length(L);
3685: for(LT = L; LT != []; LT = cdr(LT)){
3686: for(VT = car(LT), I = 0; I < S; I++)
3687: if(VT[I] != 0) break;
3688: if(I >= S){
3689: CT--;
3690: continue;
3691: }
3692: VP[I] = 1;
3693: MI = -red(V[I]/VT[I]);
3694: if(MI != 0)
3695: V = radd(V,rmul(MI,VT));
3696: }
3697: if(Opt==1){
3698: for(I = 0; I < S; I++)
3699: if(V[I] != 0)
3700: return 1;
3701: return 0;
3702: }
3703: if(Opt==2){
3704: W=newvect(S-CT);
3705: for(CC = I = 0; I < S; I++){
3706: if(VP[I]==0) W[CC++] =V[I];
3707: }
3708: return W;
3709: }
3710: return V;
3711: }
3712:
3713: def mmod(M,L)
3714: {
3715: S=size(M)[1];
3716: MM=mtranspose(M);
3717: VP = newvect(S);
3718: if(type(L)==6)
3719: L=m2lv(L);
3720: for(CT = 0, LT = L; LT != []; LT = cdr(LT)){
3721: for(VT = car(LT), I = 0; I < S; I++){
3722: if(VT[I] != 0){
3723: VP[I] = 1;
3724: break;
3725: }
3726: }
3727: }
3728: if(getopt(opt)==1)
3729: NE=1;
3730: for(D=I=0; I<S; I++){
3731: if(NE != 1 && VP[I] == 1) continue;
3732: T = mymod(MM[I],L|opt=2);
3733: if(D==0){
3734: K=length(T);
3735: MN=newmat((NE==1)?S:K,K);
3736: }
3737: for(J=0;J<K;J++)
3738: MN[J][D]=T[J];
3739: D++;
3740: }
3741: return MN;
3742: }
3743:
3744: def llsize(V)
3745: {
3746: for(I=J=0;V!=[];V=cdr(V),I++)
3747: if(length(car(V))>J) J=length(car(V));
3748: return [I,J];
3749: }
3750:
3751: def llbase(VV,L)
3752: {
3753: S = length(VV);
3754: V = dupmat(VV);
3755: if(type(V) == 4)
3756: V = ltov(V);
3757: T = length(L);
3758: for(I = 0; I < S; I++)
3759: V[I] = nm(red(V[I]));
3760: LV = 0;
3761: for(J = 0; J < T; J++){
3762: X = var(L[J]); N = deg(L[J],X);
3763: for(I = LV; I < S; I++){
3764: if((C2=coef(V[I],N,X)) != 0){
1.83 ! takayama 3765: if(type(C2)==1){
! 3766: for(K=I+1;K<S;K++){
! 3767: if(!(C1=coef(V[K],N,X))||type(C1)!=1) continue;
! 3768: if(abs(C2)<abs(C1)) I=K;
! 3769: }
! 3770: }
1.6 takayama 3771: if(I > LV){
3772: Temp = V[I];
3773: V[I] = V[LV];
3774: V[LV] = Temp;
3775: }
3776: for(I = 0; I < S; I++){
3777: if(I == LV || (C1 = coef(V[I],N,X)) == 0)
3778: continue;
3779: Gcd = gcd(C1,C2);
3780: V[I] = V[I]*tdiv(C2,Gcd)-V[LV]*tdiv(C1,Gcd);
3781: }
3782: LV++;
3783: }
3784: }
3785: }
3786: return V;
3787: }
3788:
1.44 takayama 3789: def rsort(L,T,K)
3790: {
3791: for(R=[];L!=[];L=cdr(L))
3792: R=cons((type(car(L))==4)?rsort(car(L),T-1,K):car(L),R);
3793: if(T>0||iand(T,iand(K,2)/2)) return reverse(R);
3794: R=qsort(R);
3795: return (iand(K,1))? reverse(R):R;
3796: }
3797:
1.60 takayama 3798: def llget(L,LL,LC)
3799: {
3800: if(type(LL)==4){
3801: LM=length(L);
3802: for(R=[];LL!=[];LL=cdr(LL)){
3803: if(isint(TL=car(LL))) R=cons(TL,R);
3804: else{
3805: IM=(length(TL)==1)?(LM-1):TL[1];
3806: for(I=car(TL);I<=IM;I++) R=cons(I,R);
3807: }
3808: }
3809: LL=reverse(R);
3810: if(LC==-1){
3811: LL=lsort(LL,[],1);
3812: return lsort(L,"num",["sub"]|c1=LL);
3813: }
3814: L=lsort(L,"num",["get"]|c1=LL);
3815: }
3816: if(type(LC)==4){
3817: LM=length(L[0]);
3818: for(R=[];LC!=[];LC=cdr(LC)){
3819: if(isint(TL=car(LC))) R=cons(TL,R);
3820: else{
3821: IM=(length(TL)==1)?(LM-1):TL[1];
3822: for(I>=car(TL);I<=IM;I++) R=cons(I,R);
3823: }
3824: }
3825: LC=reverse(R);
3826: if(LL==-1){
3827: LC=lsort(LC,[],1);
3828: return lsort(L,"col",["setminus"]|c1=LC);
3829: }
3830: L=lsort(L,"col",["put"]|c1=LC);
3831: }
1.63 takayama 3832: if(getopt(flat)==1) L=m2l(L|flat=1);
1.60 takayama 3833: return L;
3834: }
3835:
1.44 takayama 3836:
1.6 takayama 3837: def lsort(L1,L2,T)
3838: {
1.10 takayama 3839: C1=getopt(c1);C2=getopt(c2);
1.8 takayama 3840: if(type(T)==4){
3841: K=T;
1.10 takayama 3842: if(length(T)>0){
3843: T=K[0];
3844: K=cdr(K);
1.12 takayama 3845: }else T=0;
1.8 takayama 3846: }else K=0;
1.10 takayama 3847: if(type(TT=T)==7)
3848: T = findin(T,["cup","setminus","cap","reduce","sum","subst"]);
3849: if(type(L2)==7&&T<0)
3850: T=findin(TT,["put","get","sub"]);
3851: if(K){ /* [[..],..] */
3852: if(K!=[]) KN=K[0];
3853: if(L2==[]||L2=="sort"){ /* sort or deduce duplication */
3854: if((T!=0&&T!=3)||length(K)!=1) return L1;
1.8 takayama 3855: if(KN<0){
3856: KN=-KN-1;
3857: F=-1;
3858: }else F=1;
3859: L1=msort(L1,[F,0,KN]);
1.10 takayama 3860: if(T==3){
1.8 takayama 3861: R=[car(L1)];L1=cdr(L1);
3862: for(;L1!=[];L1=cdr(L1)){
3863: if(car(L1)[KN]!=car(R)[KN]) R=cons(car(L1),R);
3864: }
3865: L1=reverse(R);
3866: }
3867: return L1;
1.10 takayama 3868: }else if((L2==0||L2=="col")&&type(C1)==4){
1.8 takayama 3869: if(T==0||T==1){ /* extract or delete columns */
3870: for(R=[];L1!=[];L1=cdr(L1)){
1.10 takayama 3871: if(T==1&&C1==[0]){ /* delete top column */
1.8 takayama 3872: R=cons(cdr(car(L1)),R);
3873: continue;
3874: }
1.10 takayama 3875: LT=car(L1);RT=[];
1.8 takayama 3876: if(T==0){
1.10 takayama 3877: for(CT=C1;CT!=[];CT=cdr(CT)) RT=cons(LT[car(CT)],RT);
1.8 takayama 3878: }else{
1.10 takayama 3879: for(I=0;LT!=[];I++,LT=cdr(LT))
1.8 takayama 3880: if(findin(I,C1)<0) RT=cons(car(LT),RT);
3881: }
1.59 takayama 3882: R=cons(reverse(RT),R);
1.8 takayama 3883: }
3884: return reverse(R);
3885: }
1.10 takayama 3886: }else if(type(L2)==1||type(L2)==7){
3887: if(L2==1||L2=="num"){
3888: if(T==4) T=3;
3889: I=(length(K)<2)?(-1):K[1];
3890: if(T==0||T==1||T==2||T==3){
3891: S=F=CT=0;R=[];
3892: if(K==[] || type((S=K[0]))==1 || S==0){
3893: if(T==0||T==1||T==2){
3894: for(J;L1!=[];L1=cdr(L1),J++){
3895: if(T==0) R=cons(cons(J+S,car(L1)),R);
3896: else if(T==1){
3897: for( ;C1!=[]; C1=cdr(C1))
3898: R=cons(L1[car(C1)],R);
3899: }else{
3900: if(findin(J,C1)<0) R=cons(car(L1),R);
3901: }
3902: }
3903: return reverse(R);
3904: }else if(T==3) return length(L1);
3905: }else{
3906: if(type(S)==2&&vtype(S)>2) F=1;
3907: else if(type(S)==4) F=2;
3908: else if(S=="+") F=3;
3909: else return L1;
3910: }
3911: for(R=[];L1!=[];L1=cdr(L1)){
3912: L1T=car(L1);
3913: if(F==1) V=call(S,(I<0)?L1T:L1T[I]);
3914: else if(F==2) V=calc((I<0)?L1T:L1T[I],S);
3915: else if(F==3){
3916: for(C=C1,V=0;C!=[];C=cdr(C))
3917: if(type(X=L1T[car(C)])==1) V+=X;
3918: }
3919: if(T==0) R=cons(cons(V,L1T),R);
3920: else if(T==1){
3921: if(V) R=cons(L1T,R);
3922: }else if(T==2){
3923: if(!V) R=cons(L1T,R);
3924: }else if(T==3){
3925: if(F==3) CT+=V;
3926: else if(V) CT++;
3927: }
3928: }
3929: return (T==3)?CT:reverse(R);
3930: }else if(TT=="col"){
3931: J=(length(K)>0)?car(K):0;
3932: I=length(car(L1))+J;
3933: for(V=[];I>J;)
3934: V=cons(--I,V);
3935: return cons(V,L1);
3936: }
3937: }else if(L2=="transpose") return mtranspose(L1);
1.12 takayama 3938: else if(L2=="subst"||L2=="adjust"){
3939: Null=(!K)?"":car(K);
1.17 takayama 3940: if(L2=="adjust") C1=[];
1.12 takayama 3941: R=lv2m(L1|null="");
1.10 takayama 3942: for(;C1!=[];C1=cdr(C1)) R[car(C1)[0]][car(C1)[1]]=car(C1)[2];
3943: return m2ll(R);
3944: }
3945: return L1;
3946: }else{ /* [[..],..], [[..],..] */
3947: if(type(L2[0])<4){
3948: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3949: L2=reverse(R);
3950: }
3951: if(TT=="sum") T=3;
3952: if(TT=="over") T=4;
3953: if(findin(T,[0,1,2,3,4,5])<0) return L1;
3954: if(T==4||T==5){
3955: if(type(C1)<2) C1=[C1];
3956: if(type(C2)<2) C2=[C2];
3957: }
1.8 takayama 3958: if(type(car(L2))!=4){
3959: for(R=[];L2!=[];L2=cdr(L2)) R=cons([car(L2)],R);
3960: R=reverse(R);
3961: if(length(K)==1) K=[K[0],0];
3962: C2=0;
3963: }
1.10 takayama 3964: L1=lsort(L1,"num",["put",0]); /* insert number */
3965: K0=(length(K)>0)?K[0]+1:1;
3966: K1=(length(K)>1)?K1=K[1]:0;
3967: L1=lsort(L1,"sort",[0,K0]);
3968: if(T<4&&type(C2)==4&&length(L2[0])>1){
3969: L2=lsort(L2,"col",["put"]|c1=cons(K1,C2)); /* add key and extract columns */
3970: C2=0;K1=0;
3971: }
3972: L2=lsort(L2,"sort",[0,K1]);
3973: for(R0=[],S=S1=length(L1[0]);S>0;S--) R0=cons("",R0);
3974: for(R1=[],S=length(L2[0]);S>0;S--) R1=cons("",R1);
3975: if(!K1&&T!=3) R1=cdr(R1);
3976: for(R=[];L1!=[];L1=cdr(L1)){
3977: while(L2!=[]&&car(L1)[K0]>car(L2)[K1]){
3978: if(T==3) R=cons(append(R0,car(L2)),R);
3979: L2=cdr(L2);
3980: }
3981: if(L2==[]||car(L1)[K0]<car(L2)[K1]){
3982: if(T!=2) R=cons((T==1||T>3||R1==[])?car(L1):append(car(L1),R1),R);
3983: }else if(T==0||T==2||T==3){
3984: if(R0==[]) R=append(car(L1),R);
3985: else R=cons(append(car(L1),(!K1&&T!=3)?cdr(car(L2)):car(L2)),R);
3986: L2=cdr(L2);
3987: }else if(T==4||T==5){
3988: V1=ltov(car(L1));V2=ltov(car(L2));
3989: for(D1=C1,D2=C2;D1!=[];D1=cdr(D1),D2=cdr(D2))
3990: if((I=V2[car(D2)])!=""||T==4) V1[car(D1)+1]=I;
3991: R=cons(vtol(V1),R);
3992: }
3993: }
3994: if(T==3){
3995: while(L2!=[]){
3996: R=cons(append(R0,car(L2)),R);
3997: L2=cdr(L2);
3998: }
3999: }
4000: R=lsort(R,"sort",["put",0]); /* original order */
4001: D=(((T==0||T==2)&&!K1)||T==3)?[0]:[0,S1+K1];
4002: R=lsort(R,0,[1]|c1=D); /* delete */
4003: if(type(C1)!=4||T==1||T==4||T==5) return R;
4004: C=[];S0=size(L1[0]);
4005: for(;C1!=[];C1=cdr(C1)) C=cons(car(C1),C);
4006: for(I=0;I<S0-S1;I++) C=cons(I+S1,C);
1.8 takayama 4007: C=reverse(C);
1.10 takayama 4008: return lsort(R,"col",[1]|c1=C);
1.8 takayama 4009: }
4010: }
1.10 takayama 4011: if(L2 == []){ /* [...] */
4012: if(T==8||TT=="count") return [length(L1),length(lsort(L1,[],1))];
4013: if(T==7||TT=="cut"){
4014: K=length(L1);
4015: if(C1<0) C1=K+C1;
4016: for(R=[],I=0;I<C1&&L1!=[];I++,L1=cdr(L1))
4017: R=cons(car(L1),R);
4018: for(S=[];L1!=[];L1=cdr(L1))
4019: S=cons(car(L1),S);
4020: return [reverse(R),reverse(S)];
4021: }
4022: if(T==2) return L2;
4023: if(T==3) return [L1,L2];
1.6 takayama 4024: L1 = ltov(L1); qsort(L1);
4025: if(T != 1)
4026: return vtol(L1);
4027: L3 = [];
4028: for(I = length(L1)-1; I >= 0; I--){
4029: if(I > 0 && L1[I] == L1[I-1])
4030: continue;
4031: L3 = cons(L1[I], L3);
4032: }
4033: return L3;
4034: }
1.10 takayama 4035: if(T==8||TT=="count"){
4036: K=length(lsort(L1,L2,3)[0]);
4037: R=[length(L2),length(L1)];
4038: L1 = lsort(L1,[],1);
4039: L2 = lsort(L2,[],1);
4040: R=append([length(L2),length(L1)],R);
4041: R=cons(length(lsort(L1,L2,2)),R);
4042: return reverse(cons(K,R));
4043: }
1.12 takayama 4044: if((T==9||TT=="cons")&&type(car(L1))==4){
4045: if(type(L2)!=4) L2=[L2];
4046: for(R=[];L1!=[];L1=cdr(L1)){
4047: R=cons(cons(car(L2),car(L1)),R);
4048: if(length(L2)>1) L2=cdr(L2);
4049: }
4050: return reverse(R);
4051: }
1.13 takayama 4052: if(T==10||TT=="cmp"){
4053: if(length(L1)!=length(L2)){
4054: mycat("Different length!");
4055: return 1;
4056: }
4057: R=[];
4058: if(type(car(L1))==4){
4059: for(U=[],I=0;L1!=[];I++,L1=cdr(L1),L2=cdr(L2)){
4060: if(length(S=car(L1))!=length(T=car(L2))){
4061: mycat(["Different size : line ",I]);
4062: return 0;
4063: }
4064: for(J=0;S!=[];S=cdr(S),T=cdr(T),J++)
4065: if(car(S)!=car(T)) U=cons([[I,J],car(S),car(T)],U);
4066: }
4067: if(U!=[]) R=cons(reverse(U),R);
4068: }else{
4069: for(I=0;L1!=[];L1=cdr(L1),L2=cdr(L2),I++)
4070: if(car(L1)!=car(L2)) R=cons([I,car(L1),car(L2)],R);
4071: }
4072: return reverse(R);
4073: }
4074: if(T==11||TT=="append"){
4075: if(type(car(L1))!=4) return append(L1,L2);
4076: for(R=[];L1!=[];L1=cdr(L1),L2=cdr(L2))
4077: R=cons(append(car(L1),car(L2)),R);
4078: return reverse(R);
4079: }
1.6 takayama 4080: if(T == 1 || T == 2){
4081: L1 = lsort(L1,[],1);
4082: L2 = lsort(L2,[],1);
4083: L3 = [];
4084: if(T == 1){
4085: while(L1 != []){
4086: if(L2 == [] || car(L1) < car(L2)){
4087: L3 = cons(car(L1), L3);
4088: L1 = cdr(L1);
4089: continue;
4090: }
4091: if(car(L1) > car(L2)){
4092: L2 = cdr(L2);
4093: continue;
4094: }
4095: L1 = cdr(L1); L2 = cdr(L2);
4096: }
4097: return reverse(L3);
4098: }
4099: if(T==2){
4100: while(L1 != [] && L2 != []){
4101: if(car(L1) != car(L2)){
4102: if(car(L1) <= car(L2))
4103: L1 = cdr(L1);
4104: else L2 = cdr(L2);
4105: continue;
4106: }
4107: while(car(L1) == car(L2))
4108: L1 = cdr(L1);
4109: L3 = cons(car(L2), L3);
4110: }
4111: return reverse(L3);
4112: }
4113: }
4114: if(T==3){
4115: L1 = qsort(L1); L2 = qsort(L2);
4116: L3 = L4 = [];
4117: while(L1 != [] && L2 != []){
4118: if(car(L1) == car(L2)){
4119: L1 = cdr(L1); L2 = cdr(L2);
4120: }else if(car(L1) < car(L2)){
4121: L3 = cons(car(L1),L3);
4122: L1 = cdr(L1);
4123: }else{
4124: L4 = cons(car(L2), L4);
4125: L2 = cdr(L2);
4126: }
4127: }
4128: L4 = append(reverse(L4),L2);
4129: L3 = append(reverse(L3),L1);
4130: return [L3,L4];
4131: }
4132: L1 = append(L1,L2);
4133: return lsort(L1,[],1);
4134: }
4135:
4136: def mqsub(X,Y)
4137: {
4138: for(L=LQS;L!=[];L=cdr(L)){
4139: F=(T=car(L))[0];M=(T=cdr(T))[0];
4140: X0=X;Y0=Y;
4141: for(T=cdr(T);T!=[];T=cdr(T)){
4142: X0=X0[car(T)];Y0=Y0[car(T)];
4143: }
4144: if(type(M)==1){
4145: if(M==3){
4146: X0=type(X0);Y0=type(Y0);
4147: }else if(M==4&&type(X0)<2&&type(Y0)<2){
4148: X0=abs(X0);Y0=abs(Y0);
4149: }else if(M==5){
4150: X0=str_len(rtostr(X0));Y0=str_len(rtostr(Y0));
4151: }else if(type(X0)==type(Y0)&&type(X0)>3&&type(X0)<7){
4152: if(M==1){
4153: X0=length(X0);Y0=length(Y0);
4154: }else if(M==2){
4155: LX=length(X0);LY=length(Y0);
4156: L0=(LX<LY)?LX:LY;
4157: for(I=0;;I++){
4158: if(I==L0){
4159: X0=LX;Y0=LY;break;
4160: }
4161: if(X0[I]==Y0[I]) continue;
4162: X0=X0[I];Y0=Y0[I];break;
4163: }
4164: }
4165: }
4166: }else if(type(M)==2){
4167: X0=(*M)(X0,Y0);Y0=0;
4168: }else if(type(M)==4&&length(M)==1){
4169: X0=(*car(M))(X0);Y0=(*car(M))(Y0);
4170: }
4171: if(X0==Y0) continue;
4172: return (X0<Y0)?-F:F;
4173: }
4174: return 0;
4175: }
4176:
4177: def msort(L,S)
4178: {
4179: if(type(S)!=4) return qsort(L);
4180: if(type(S[0])!=4) S=[S];
4181: LQS=S;
4182: return qsort(L,os_md.mqsub);
4183: }
4184:
1.22 takayama 4185: def lpair(A,B)
4186: {
4187: if(B==0){
4188: for(S=T=[];A!=[];A=cdr(A)){
4189: S=cons(car(A)[0],S);T=cons(car(A)[1],T);
4190: }
4191: return [reverse(S),reverse(T)];
4192: }else{
4193: for(R=[];A!=[];A=cdr(A),B=cdr(B))
4194: R=cons([car(A),car(B)],R);
4195: return reverse(R);
4196: }
4197: }
4198:
1.6 takayama 4199: def lmax(L)
4200: {
4201: if(type(L)==4){
4202: V=car(L);
4203: while((L=cdr(L))!=[])
4204: if(V < car(L)) V=car(L);
4205: return V;
4206: }else if(type(L)==5||type(L)==6)
4207: return lmax(m2l(L));
4208: return [];
4209: }
4210:
4211: def lmin(L)
4212: {
4213: if(type(L)==4){
4214: V=car(L);
4215: while((L=cdr(L))!=[])
4216: if(V > car(L)) V=car(L);
4217: return V;
4218: }else if(type(L)==5||type(L)==6)
4219: return lmin(m2l(L));
4220: return [];
4221: }
4222:
4223: def lgcd(L)
4224: {
4225: if(type(L)==4){
4226: F=getopt(poly);
4227: V=car(L);
4228: while((L=cdr(L))!=[]&&V!=1){
4229: if(V!=0)
4230: V=(F==1)?gcd(V,car(L)):igcd(V,car(L));
4231: }
4232: return V;
4233: }else if(type(L)==5||type(L)==6)
4234: return lgcd(m2l(L)|option_list=getopt());
4235: return [];
4236: }
4237:
1.56 takayama 4238: def llcm(R)
4239: {
1.60 takayama 4240: if(type(R)==5||type(R)==6) R=m2l(R);
1.56 takayama 4241: if(type(R)<4) R=[R];
4242: if(type(R)!=4) return 0;
4243: V=getopt(poly);
4244: if(type(V)<1){
4245: for(L=R;L!=[];L=cdr(L)){
4246: if(type(car(L))>1){
4247: V=1; break;
4248: }
4249: }
4250: }
4251: if(getopt(dn)!=1){
4252: for(L=[];R!=[];R=cdr(R)) if(R!=0) L=cons(1/car(R),L);
4253: R=L;
4254: }
4255: P=1;
4256: if(type(V)<1){
4257: for(;R!=[];R=cdr(R)){
4258: if(!(TL=car(R))) continue;
4259: else P=ilcm(P,dn(TL));
4260: }
4261: return P;
4262: }
4263: for(;R!=[];R=cdr(R)){
4264: if(!car(R)) continue;
4265: D=dn(red(car(R)));
4266: N=red(P/D);
4267: if(type(V)<2){
4268: if(type(N)!=3) continue;
4269: P*=dn(N);
4270: continue;
4271: }
4272: if(ptype(N,V)>2){
4273: L=fctr(dn(N));
4274: for(;L!=[];L=cdr(L)){
4275: if(ptype(car(L)[0],V)<2) continue;
4276: P*=car(L)[0]^car(L)[1];
4277: }
4278: }
4279: }
4280: return P;
4281: }
1.6 takayama 4282:
4283: def ldev(L,S)
4284: {
4285: M=abs(lmax(L));N=abs(lmin(L));
4286: if(M<N) M=N;
4287: for(C=0,LT=L;;C++){
4288: LT=ladd(LT,S,1);
4289: MT=abs(lmax(LT));NT=abs(lmin(LT));
4290: if(MT<NT) MT=NT;
4291: if(MT>=M) break;
4292: M=MT;
4293: }
4294: if(!C){
4295: for(C=0,LT=L;;C--){
4296: LT=ladd(LT,S,-1);
4297: MT=abs(lmax(LT));NT=abs(lmin(LT));
4298: if(MT<NT) MT=NT;
4299: if(MT>=M) break;
4300: M=MT;
4301: }
4302: }
4303: return [C,ladd(L,S,C)];
4304: }
4305:
4306: def lchange(L,P,V)
4307: {
4308: if(getopt(flat)==1&&type(P)==4){
4309: for(L=ltov(L);P!=[];P=cdr(P),V=cdr(V))
4310: L[car(P)]=car(V);
4311: return vtol(L);
4312: }
4313: if(type(P)==4){
4314: IP=car(P); P=cdr(P);
4315: }else{
4316: IP=P; P=[];
4317: }
4318: for(I=0, LL=[], LT=L; LT!=[]; I++,LT=cdr(LT)){
4319: if(I==IP){
4320: LL=cons((P==[])?V:lchange(car(LT),P,V),LL);
4321: }else
4322: LL=cons(car(LT),LL);
4323: }
4324: return reverse(LL);
4325: }
4326:
4327: def lsol(VV,L)
4328: {
4329: if(type(VV)<4 && type(L)==2)
4330: return red(L-VV/mycoef(VV,1,L));
4331: S = length(VV);
4332: T = length(L);
4333: V = llbase(VV,L);
4334: for(J = K = 0; J < T; J++){
4335: X = var(L[J]); N = deg(L[J],X);
4336: for(I = K; I < S; I++){
4337: if((C=mycoef(V[I], N, X)) != 0){
4338: V[I] = [L[J],red(X^N-V[I]/C)];
4339: K++;
4340: break;
4341: }
4342: }
4343: }
4344: return V;
4345: }
4346:
4347: def lnsol(VV,L)
4348: {
4349: LL=lsort(vars(VV),L,1);
4350: VV=ptol(VV,LL|opt=0);
4351: return lsol(VV,L);
4352: }
4353:
4354:
4355: def ladd(X,Y,M)
4356: {
1.58 takayama 4357: if(Y==0){
4358: Y=X[1];X=X[0];
4359: }
1.22 takayama 4360: if(type(Y)==4) Y=ltov(Y);
1.6 takayama 4361: if(type(X)==4) X=ltov(X);
4362: return vtol(X+M*Y);
4363: }
4364:
4365: def mrot(X)
4366: {
1.22 takayama 4367: if(type(X)==4){
4368: if(getopt(deg)==1)
4369: X=[deval(@pi*X[0]/180),deval(@pi*X[1]/180),deval(@pi*X[2]/180)];
4370: if(getopt(conj)==1)
4371: return mrot([-X[2],-X[1],0])*mrot([X[0],X[1],X[2]]);
4372: if(X[1]==0){
4373: X=[X[0]+X[2],0,0];
4374: if(X[0]==0) return diagm(3,[1]);
4375: }
4376: if(X[0]!=0){
4377: M=mat([dcos(X[0]),-dsin(X[0]),0],[dsin(X[0]),dcos(X[0]),0],[0,0,1]);
4378: if(X[1]==0) return M;
4379: }
4380: N=mat([dcos(X[1]),0,-dsin(X[1])],[0,1,0],[dsin(X[1]),0,dcos(X[1])]);
4381: if(X[0]!=0) N=M*N;
4382: if(X[2]==0) return N;
4383: return N*mrot([X[2],0,0]);
4384: }
1.6 takayama 4385: if(getopt(deg)==1) X=@pi*X/180;
4386: X=deval(X);
1.22 takayama 4387: return mat([dcos(X),-dsin(X)],[dsin(X),dcos(X)]);
1.6 takayama 4388: }
4389:
4390: def m2v(M)
4391: {
4392: S = size(M);
4393: V = newvect(S[0]*S[1]);
4394: for(I = C = 0; I < S[0]; I++){
4395: MI = M[I];
4396: for(J = 0; J < S[1]; J++)
4397: V[C++] = MI[J];
4398: }
4399: return V;
4400: }
4401:
4402: def lv2m(L)
4403: {
4404: if(type(L)==5) L=vtol(L);
4405: II=length(L);
4406: for(J=1,T=L; T!=[]; T=cdr(T))
4407: if(length(car(T))>JJ) JJ=length(car(T));
4408: M = newmat(II,JJ);
4409: N = getopt(null);
4410: if(type(N)<0) N=0;
4411: for(I=0; I<II; I++){
4412: V=car(L); L=cdr(L);
4413: for(J=length(V);--J>=0;)
4414: M[I][J] = V[J];
4415: if(N!=0){
4416: for(J=length(V); J<JJ; J++)
4417: M[I][J]=N;
4418: }
4419: }
4420: return M;
4421: }
4422:
4423: def m2lv(M)
4424: {
4425: I=size(M)[0];
4426: for(N=[],I=size(M)[0];I-->0;)
4427: N=cons(M[I],N);
4428: return N;
4429: }
4430:
4431: def s2m(S)
4432: {
4433: if(type(S)==6) return S;
4434: if(type(S)==7){
4435: if(str_chr(S,0,"[")!=0) S=s2sp(S);
4436: else if(str_chr(S,0,",")>=0) return eval_str(S);
4437: else{
4438: for(L=LL=[],I=0; ; ){
4439: II=str_chr(S,I+2,"]");
4440: if(II<0) return 0;
4441: J=str_chr(S,I+2," ");
4442: while(str_chr(S,J+1," ")==J+1) J++;
4443: if(J>II-2 || J<0) J=II;
4444: V=eval_str(sub_str(S,I+1,J-1));
4445: L=cons(V,L);
4446: I=J;
4447: if(J==II){
4448: LL=cons(ltov(reverse(L)),LL);
4449: L=[];
4450: if((I=str_chr(S,II+1,"["))<0)
4451: return lv2m(reverse(LL));
4452: }
4453: }
4454: }
4455: }
4456: if(type(S)==5) S=vtol(S);
4457: if(type(S[0])==5) return lv2m(S);
4458: I=length(S);
4459: for(J=1,T=S; T!=[]; T=cdr(T))
4460: if(length(car(T))>J) J=length(car(T));
4461: return newmat(I,J,S);
4462: }
4463:
4464: def c2m(L,V)
4465: {
4466: if(type(Pow=getopt(pow))!=1){
4467: if(isvar(V)==1){
4468: for(Pow=0,LT=L;LT!=[];LT=cdr(LT)){
4469: if(mydeg(car(LT),V)>JJ) Pow=mydeg(car(LT),V);
4470: }
4471: JJ=Pow+1;
4472: }else{
4473: Pow=-1;
4474: JJ=length(V);
4475: }
4476: }else JJ=Pow+1;
4477: M=newmat(length(L),JJ);
4478: for(I=0;L!=[];L=cdr(L),I++){
4479: for(J=0;J<JJ;J++){
4480: LT=car(L);
4481: M[I][J]=(Pow>=0)?mycoef(LT,J,V):mycoef(LT,1,V[J]);
4482: }
4483: }
4484: return M;
4485: }
4486:
4487: #if 0
4488: def m2diag(M,N)
4489: {
4490: S = size(M);
4491: MM = mtoupper(M,N);
4492: for(I = S[0]-1; I >= 0; I--){
4493: for(J = 0; I < S[1]-N; I++){
4494: if(MM[I][J] != 0){
4495: P = MM[I][J];
4496: for(K = 0; K < I; K++){
4497: Q = -rmul(MM[K][J],1/P);
4498: MM[K][J] = 0;
4499: if(Q != 0){
4500: for(L = J+1; L < S[1]; L++){
4501: if(MM[I][L] != 0)
4502: MM[K][L] = radd(MM[K][L], rmul(MM[I][L],Q));
4503: }
4504: }
4505: }
4506: }
4507: }
4508: }
4509: return MM;
4510: }
4511: #endif
4512:
4513: def myinv(M)
4514: {
4515: S = size(M);
4516: if((T=S[0]) != S[1])
4517: return 0;
4518: MM = mtoupper(M,-T|opt=2);
4519: if(MM[T-1][T-1] != 1) return 0;
4520: return mperm(MM,0,[T,[T]]);
4521: }
4522:
4523: def madj(G,M)
4524: {
4525: H=myinv(G);
4526: if(type(M)==6)
4527: return rmul(rmul(G,M),H);
4528: if(type(M)==4||type(M)==5){
4529: L=length(M);
4530: N=newvect(L);
4531: for(I=0;I<L;I++){
4532: N[I]=rmul(rmul(G,M[I]),H);
4533: }
4534: if(type(N)==4) N=vtol(N);
4535: return N;
4536: }
4537: return -1;
4538: }
4539:
4540: def mpower(M,N)
4541: {
4542: if(type(M)<=3) return (red(M))^N;
4543: S = size(M);
4544: if(S[0] != S[1])
4545: return 0;
4546: if(N == 0) return mgen(S[0],0,[1],0);
4547: if(N < 0)
4548: return(mpower(myinv(M), -N));
4549: R = dupmat(M);
4550: V=1;
4551: for(V=1;;){
4552: if(iand(N,1)){
4553: V=map(red,R*V);
4554: N--;
4555: }
4556: if((N/=2)==0) break;
4557: R=map(red,R*R);
4558: }
4559: return V;
4560: }
4561:
4562: def texlen(S)
4563: {
4564: if(type(S)!=7) return 0;
4565: LF=I=J=0;
4566: LM=str_len(S);
4567: while((I=str_str(S,"\\frac{"|top=J))>=0){
4568: if(I>J) LF+=texlen(str_cut(S,J,I-1));
4569: I+=6;
4570: for(F=L=0,J=I;F<2 && J<LM-1;F++){
4571: for(C=1;C>0 && J<LM;){
4572: if((K0=str_char(S,J,"}"))<0) K0=LM;
4573: if((K1=str_char(S,J,"{"))<0) K1=LM;
4574: if(K0<0 && K1<0){
4575: J = str_len(S)-1;
4576: break;
4577: }
4578: if(K0<K1){
4579: J=K0+1; C--;
4580: }else{
4581: J=K1+1; C++;
4582: }
4583: }
4584: T=str_cut(S,I,J-1);
4585: if(F==0){
4586: I=J=K1+1;C=1;
4587: }else J=K0+1;
4588: if(type(T)==7 && (LL=texlen(T))>L) L=LL;
4589: }
4590: LF+=L;
4591: }
4592: if(J>0) S=str_cut(S,J,str_len(S)-1);
4593: if(S==0) return LF;
4594: S=ltov(strtoascii(S));
4595: L=LL=length(S);
4596: for(I=F=0; I<L; I++){
4597: if(S[I]==92) F=1;
4598: else if(F==1){
4599: if((S[I]>96 && S[I]<123)||(S[I]>64 && S[I]<91)) LL--;
4600: else F=0;
4601: }
4602: if(S[I]<=32||S[I]==123||S[I]==125||S[I]==94||S[I]==38) LL--; /* {}^& */
4603: else if(S[I]==95){
4604: LL--;
4605: if(I+2<L && S[I+2]==94) LL--; /* x_2^3 */
4606: else if(I+6<L && S[I+1]==123 && S[I+4]==125){ /* x_{11}^2 */
4607: if(S[I+5]==94 || (S[I+5]==125 && S[I+6]==94)) LL-- ; /* x_{11}}^2 */
4608: }
4609: }
4610: }
4611: return LL+LF;
4612: }
4613:
4614: def isdif(P)
4615: {
4616: if(type(P)<1 || type(P)>3) return 0;
4617: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4618: V0=rtostr(car(R));
4619: if(V0>"d" && V0<"e"){
4620: V=sub_str(V0,1,str_len(V0)-1);
4621: if(V>="a" && V<"{") Var=cons([strtov(V),strtov(V0)],Var);
4622: }
4623: }
4624: if(Var==[]) return 0;
4625: for(V=Var; V!=[]; V=cdr(V))
4626: if(ptype(P,car(V)[1])==3) return 0;
4627: return Var;
4628: }
4629:
4630: def texsp(P)
4631: {
4632: Q=strtoascii(P);
4633: if((J=str_char(Q,0,92))<0 || (C=Q[L=str_len(P)-1])==32||C==41||C==125)
4634: return P;
4635: for(;;){
4636: if((I=str_char(Q,J+1,92))<0) break;
4637: J=I;
4638: };
4639: for(I=J+1;I<L&&isalpha(Q[I]);I++);
4640: return(I==L)?P+" ":P;
4641: }
4642:
4643: def fctrtos(P)
4644: {
4645: /* extern TeXLim; */
4646: if(!chkfun("write_to_tb", "names.rr"))
4647: return 0;
4648:
4649: TeX = getopt(TeX);
4650: if(TeX != 1 && TeX != 2 && TeX != 3)
4651: TeX = 0;
1.70 takayama 4652: if((Dvi=getopt(dviout)==1) && TeX<2) TeX=3;
1.6 takayama 4653: if(TeX>0){
4654: Lim=getopt(lim);
4655: if(Lim!=0 && TeX>1 && (type(Lim)!=1||Lim<30)) Lim=TeXLim;
4656: else if(type(Lim)!=1) Lim=0;
4657: CR=(TeX==2)?"\\\\\n":"\\\\\n&";
1.70 takayama 4658: CR2="\\allowdisplaybreaks"+CR;
4659: if(TeX==1 || Lim==0) CR=CR2="";
4660: else if((Pages=getopt(pages))==1) CR2=CR;
1.6 takayama 4661: if(!chkfun("print_tex_form", "names.rr"))
4662: return 0;
4663: Small=getopt(small);
4664: }
4665: Dif=getopt(dif);
4666: Var=getopt(var);
4667: if(Lim>0 && type(Var)<2 && TeX!=1) Var=[strtov("0"),""];
4668: Dif=0;
4669: if(Var=="dif"){
4670: Dif=DV=1;
4671: }else if (Var=="dif0") Dif=1;
4672: else if(Var=="dif1") Dif=2;
4673: else if(Var=="dif2") Dif=3;
4674: if(Dif>0){
4675: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
4676: V=rtostr(car(R));
4677: if(V>"d" && V<"e"){
4678: V=sub_str(V,1,str_len(V)-1);
4679: if(V>="a" && V<"{"){
4680: if(TeX>0){
4681: V=my_tex_form(strtov(V));
4682: if(Dif>=1){
4683: if(Dif==1){
4684: if(str_len(V)==1) V="\\partial_"+V;
4685: else V="\\partial_{"+V+"}";
4686: }
4687: Var=cons([car(R),V],Var);
4688: }
4689: else Var=cons([car(R)],Var);
4690: }else Var=cons([car(R)],Var);
4691: }
4692: }
4693: }
4694: if(TeX>0){
4695: if(length(Var)==1){
4696: if(DV==1 && str_len(Var[0][1])==10) Var=[[Var[0][0],"\\partial"]];
4697: }else if(DV==1){
4698: for(V=Var;V!=[];V=cdr(V)){
4699: VV=rtostr(car(V)[0]);
4700: if(VV<"dx0" || VV>= "dx:" || str_len(VV)>4) break;
4701: }
4702: if(V==[]){
4703: for(VT=[],V=Var;V!=[];V=cdr(V)){
4704: VV=str_cut(rtostr(car(V)[0]),2,3);
4705: if(str_len(VV)==1) VT=cons([car(V)[0],"\\partial_"+VV],VT);
4706: else VT=cons([car(V)[0],"\\partial_{"+VV+"}"],VT);
4707: }
4708: Var=reverse(VT);
4709: }
4710: }else
4711: if(Dif==2 && length(Var)>1) Dif=3;
4712: }
4713: if(Dif>0) Dif--;
4714: }
4715: if(type(Var)>1 && Var!=[]){ /* as a polynomial of Var */
4716: Add=getopt(add);
4717: if(type(Add)>0){
4718: if(type(Add)!=7){
4719: Add=my_tex_form(Add);
4720: if(str_char(Add,0,"-")>=0 || str_char(Add,0,"+")>=0) Add="("+Add+")";
4721: }
4722: if(str_char(Add,0,"(")!=0) Add = " "+Add;
4723: }else Add=0;
4724: if(type(Var)!=4) Var=[Var];
4725: if(length(Var)==2 && type(Var[1]) == 7)
4726: Var = [Var];
4727: for(VV=VD=[]; Var!=[];Var=cdr(Var)){
4728: VT=(type(car(Var))==4)?car(Var):[car(Var)];
4729: VT0=var(car(VT));
4730: VV=cons(VT0,VV);
4731: if(length(VT)==1){
4732: VD=cons((TeX>=1)?my_tex_form(VT0):rtostr(VT0),VD);
4733: }else VD=cons(VT[1],VD);
4734: }
4735: VV=reverse(VV);VD=reverse(VD);
4736: Rev=(getopt(rev)==1)?1:0;
1.70 takayama 4737: Rdic=0;
4738: if((Dic=getopt(dic))==2){
4739: Dic=Rdic=1;
4740: }else if(Dic!=1) Dic=0;
1.6 takayama 4741: TT=terms(P,VV|rev=Rev,dic=Dic);
4742: if(TeX==0){
4743: Pre="("; Post=")";
4744: }else{
4745: Pre="{"; Post="}";
4746: }
4747: Out = string_to_tb("");
1.70 takayama 4748: for(L=C=CC=0,Tm=TT;Tm!=[];C++,Tm=cdr(Tm)){
1.6 takayama 4749: for(I=0,PC=P,T=cdr(car(Tm)),PW="";T!=[];T=cdr(T),I++){
4750: PC=mycoef(PC,D=car(T),VV[I]);
4751: if(PC==0) continue;
4752: PT="";
4753: if(D!=0 && VD[I]!=""){
4754: if(TeX==0 && PW!="") PW+="*";
4755: if(D>1){
4756: if(D>9) PT="^"+Pre+rtostr(D)+Post;
4757: else PT="^"+rtostr(D);
4758: }
4759: if(Dif>0) PW+=(Dif==1)?"d":"\\partial ";
1.70 takayama 4760: if(Rdic) PW=VD[I]+PT+PW;
4761: else PW+=VD[I]+PT;
1.6 takayama 4762: }
4763: }
4764: D=car(Tm)[0];
4765: if(Dif>0 && D>0){
4766: Op=(Dif==1)?"\\frac{d":"\\frac{\\partial";
4767: if(D>1) Op+="^"+((D>9)?(Pre+rtostr(D)+Post):rtostr(D));
4768: PW=Op+Add+"}{"+PW+"}";
4769: }else if(Add!=0) PW=PW+Add;
1.69 takayama 4770: CD=0;
1.6 takayama 4771: if(TeX>=1){
4772: if(type(PC)==1 && ntype(PC)==0 && PC<0)
4773: OC="-"+my_tex_form(-PC);
4774: else OC=fctrtos(PC|TeX=1,br=1);
1.69 takayama 4775: if(isint(PC)&&(PC<-1||PC>1)) CD=1;
1.6 takayama 4776: }else OC=fctrtos(PC|br=1);
4777: if(PW!=""){
4778: if(OC == "1") OC = "";
4779: else if(OC == "-1") OC = "-";
4780: }
4781: if(TeX==0 && D!=0 && OC!="" && OC!="-") PW= "*"+PW;
4782: if((TOC=type(OC)) == 4){ /* rational coef. */
4783: if(Lim>0 && (texlen(OC[0])>Lim || texlen(OC[0])>Lim)){
4784: OC = (Small==1)?"("+OC[0]+")/("+OC[1]+")"
4785: :"\\Bigl("+OC[0]+"\\Bigr)\\Bigm/\\Bigl("+OC[1]+"\\Bigr)";
4786: TOC = 7;
4787: }else{
4788: if(str_char(OC[0],0,"-")==0){
4789: OC = fctrtos(-PC|TeX=1,br=1);
4790: OC = "-\\frac{"+OC[0]+"}{"+OC[1]+"}";
4791: }
4792: else
4793: OC = "\\frac{"+OC[0]+"}{"+OC[1]+"}";
4794: }
4795: }
4796: if(Lim>0){
1.70 takayama 4797: CC++;
1.6 takayama 4798: LL=texlen(OC)+texlen(PW);
4799: if(LL+L>=Lim){
4800: if(L>0) str_tb(CR,Out);
4801: if(LL>Lim){
1.70 takayama 4802: if(TOC==7) OC=texlim(OC,Lim|cut=[CR,CR2]);
1.73 takayama 4803: if(length(Tm)!=1) PW+=CR;
4804: L=0;
1.6 takayama 4805: }else L=LL;
4806: }else L+=LL;
1.70 takayama 4807: }else if(length(Tm)!=1){
4808: CC++;
4809: PW += CR; /* not final term */
4810: }
4811: if(CC>TeXPages) CR=CR2;
1.69 takayama 4812: if(TeX){
4813: OC=texsp(OC);
4814: if(CD){ /* 2*3^x */
4815: CD=strtoascii(str_cut(PW,0,1));
4816: if(length(CD)==2&&car(CD)==123&&isnum(CD[1])) OC+="\\cdots";
4817: }
4818: }
1.6 takayama 4819: if(str_chr(OC,0,"-") == 0 || C==0) str_tb([OC,PW], Out);
4820: else{
4821: str_tb(["+",OC,PW],Out);
4822: if(LL<=Lim) L++;
4823: }
4824: }
4825: S=str_tb(0,Out);
4826: if(S=="") S="0";
4827: }else{ /* Var is not specified */
4828: if((TP=type(P)) == 3){ /* rational function */
4829: P = red(P); Nm=nm(P); Dn=dn(P);
4830: Q=dn(ptozp(Nm|factor=1)[1]);
4831: if(Q>1){
4832: Nm*=Q;Dn*=Q;
4833: }
4834: if(TeX>0){
4835: return (TeX==2)?
4836: "\\frac\{"+fctrtos(Nm|TeX=1)+"\}\{"+fctrtos(Dn|TeX=1)+"\}"
4837: :[fctrtos(Nm|TeX=1),fctrtos(Dn|TeX=1)];
4838: }
4839: else{
4840: S=fctrtos(Nm);
4841: if(nmono(Nm)>1) S="("+S+")";
4842: return S+"/("+fctrtos(Dn)+")";
4843: }
4844: }
4845: if(imag(P)==0) P = fctr(P); /* usual polynomial */
4846: else P=[[P,1]];
4847: S = str_tb(0,0);
1.69 takayama 4848: for(J = N = CD = 0; J < length(P); J++){
4849: if(type(V=P[J][0]) <= 1){
4850: if(V == -1){
1.6 takayama 4851: write_to_tb("-",S);
4852: if(length(P) == 1)
4853: str_tb("1", S);
1.69 takayama 4854: }else if(V != 1){
4855: str_tb((TeX>=1)?my_tex_form(V):rtostr(V), S);
1.6 takayama 4856: N++;
4857: }else if(length(P) == 1)
4858: str_tb("1", S);
4859: else if(getopt(br)!=1 && length(P) == 2 && P[1][1] == 1){
4860: str_tb((TeX>=1)?my_tex_form(P[1][0]):rtostr(P[1][0]), S);
4861: J++;
4862: }
1.69 takayama 4863: if(J==0&&isint(V=P[J][0])&&(V<-1||V>1)) CD=1;
1.6 takayama 4864: continue;
4865: }
4866: if(N > 0 && TeX != 1 && TeX != 2 && TeX != 3)
4867: write_to_tb("*", S);
4868: SS=(TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]);
4869: N++;
4870: if(P[J][1] != 1){ /* (log(x))^2 */
4871: if(nmono(P[J][0])>1||
4872: (!isvar(P[J][0])||vtype(P[J][0]))&&str_len(SS)>1) SS="("+SS+")";
4873: write_to_tb(SS,S);
1.70 takayama 4874: str_tb(["^", (TeX>=1)?rtotex(P[J][1]):monotos(P[J][1])],S);
1.6 takayama 4875: }else{
1.70 takayama 4876: if(nmono(P[J][0])>1&&length(P)>1) SS="("+SS+")";
1.69 takayama 4877: else if(CD&&J==1){ /* 2*3^x */
4878: CD=strtoascii(str_cut(SS,0,1));
4879: if(length(CD)==2&&car(CD)==123&&isnum(CD[1])) SS="\\cdot"+SS;
4880: }
1.6 takayama 4881: write_to_tb(SS,S);
4882: }
4883: }
4884: S = str_tb(0,S);
1.70 takayama 4885: if((Lim>0 || TP!=2) && CR!="") S=texlim(S,Lim|cut=[CR,CR2]);
1.6 takayama 4886: }
4887: if(TeX>0){
4888: if(Small==1) S=str_subst(S,"\\frac{","\\tfrac{");
4889: if(Dvi==1){
1.70 takayama 4890: dviout(strip(S,"(",")")|eq=(Pages==1||Pages==2)?6:0); S=1;
1.6 takayama 4891: }
4892: }
4893: return S;
4894: }
4895:
4896: def strip(S,S0,S1)
4897: {
4898: SS=strtoascii(S);
4899: if(length(SS)>1){
4900: if(SS[0]==40&&SS[length(SS)-1]==41&&str_pair(SS,1,S0,S1)==length(SS)-1)
4901: S=str_cut(SS,1,length(SS)-2);
4902: }
4903: return S;
4904: }
4905:
4906: def texlim(S,Lim)
4907: {
4908: /* extern TeXLim; */
4909: if(S==1 && Lim>10){
4910: TeXLim=Lim;
4911: mycat(["Set TeXLim =",Lim]);
4912: return 1;
4913: }
1.70 takayama 4914: if(type(Out=getopt(cut))!=7){
4915: if(type(Out)!=4) Out=Out2="\\\\\n&";
4916: else{
4917: Out2=Out[1];Out=Out[0];
4918: }
4919: }
1.6 takayama 4920: if(type(Del=getopt(del))!=7) Del=Out;
4921: if(Lim<30) Lim=TeXLim;
4922: S=ltov(strtoascii(S));
4923: for(L=[0],I=F=0;F==0; ){
4924: II=str_str(S,Del|top=I)+2;
4925: if(II<2){
4926: F++;II=/* str_len(S) */ length(S)-1;
4927: }
4928: for(J=JJ=I+1;;JJ=K+1){
4929: K=str_char(S,JJ,43); /* + */
4930: if((K1=str_char(S,JJ,45))>2 && K1<K){ /* - */
4931: if(S[K1-1]!=123 && S[K1-1]!=40) K=K1; /* {, ( */
4932: }
4933: if((K1=str_char(S,JJ,40))>0 && K1-JJ>6 && K1<K && S[K1-1]!=43 && S[K1-1]!=45){ /* ( */
4934: T=str_char(S,K1-6,"\\"); /* \Big*(, \big*( */
4935: if((T==K1-6 || T==K1-5)
4936: && (str_str(S,"big"|top=T+1,end=T+1)>0 || str_str(S,"Big"|top=T+1,end=T+1)>0))
4937: K=T;
4938: else if(K1>0 && K1<K) K=K1;
4939: }
4940: if(K<0 || K>II) break;
4941: if(K-J>Lim && texlen(str_cut(S,J,K-1))>=Lim){
4942: J=K+1; L=cons(JJ-1,L); SL=0;
4943: }
4944: }
4945: I=II;
4946: }
4947: SS=str_tb(0,0);
4948: L=cons(length(S),L);
4949: L=reverse(L);
1.70 takayama 4950: if(length(L)>TeXPages) Out=Out2;
1.6 takayama 4951: for(I=0; L!=[]; I=J,L=cdr(L)){
4952: str_tb((I==0)?"":Out,SS);
4953: J=car(L);
4954: str_tb(str_cut(S,I,J-1),SS);
4955: }
4956: return str_tb(0,SS);
4957: }
4958:
4959: def fmult(FN,M,L,N)
4960: {
4961: Opt=getopt();
4962: for(I = 0; I < length(M); I++)
4963: M = call(FN, cons(M,cons(L[I],N))|option_list=Opt);
4964: return M;
4965: }
4966:
4967: def radd(P,Q)
4968: {
4969: if(type(P) <= 3 || type(Q) <= 3){
4970: if(type(P) >= 5)
4971: return radd(Q,P);
4972: if(type(Q) >= 5){
4973: R = dupmat(Q);
4974: if(P == 0)
4975: return R;
4976: if(type(Q) == 6){
4977: S = size(Q);
4978: if(S[0] != S[1])
4979: return 0;
4980: for(I = 0; I < S[0]; I++)
4981: R[I][I] = radd(R[I][I], P);
4982: }else{
4983: for(I = length(R)-1; I >= 0; I--)
4984: R[I] = radd(R[I],P);
4985: }
4986: return R;
4987: }
4988: /* P=red(P);Q=red(Q); */
4989: if((P1=dn(P)) == (Q1=dn(Q))){
4990: if(P1==1) return P+Q;
4991: return red((nm(P)+nm(Q))/P1);
4992: }
4993: R=gcd(P1,Q1);S=tdiv(P1,R);
4994: return red((nm(P)*tdiv(Q1,R)+nm(Q)*S)/(S*Q1));
4995: }
4996: if(type(P) == 5){
4997: S = length(P);
4998: R = newvect(S);
4999: for(I = 0; I < S; I++)
5000: R[I] = radd(P[I],Q[I]);
5001: return R;
5002: }
5003: if(type(P) == 6){
5004: S = size(P);
5005: R = newmat(S[0],S[1]);
5006: for(I = 0; I < S[0]; I++){
5007: for(J = 0; J < S[1]; J++)
5008: R[I][J] = radd(P[I][J],Q[I][J]);
5009: }
5010: return R;
5011: }
5012: erno(0);
5013: }
5014:
5015: def getel(M,I)
5016: {
5017: if(type(M) >= 4 && type(M) <= 6 && type(I) <= 1)
5018: return M[I];
5019: if(type(M) == 6 && type(I) == 5)
5020: return M[I][J];
5021: return M;
5022: }
5023:
5024: def ptol(P,X)
5025: {
5026: F=(getopt(opt)==0)?0:1;
5027: if(type(P) <= 3)
5028: P = [P];
5029: if(type(X) == 4){
5030: for( ; X != []; X = cdr(X))
5031: P=ptol(P,car(X)|opt=F);
5032: return P;
5033: }
5034: P = reverse(P);
5035: for(R=[]; P != []; P = cdr(P)){
5036: Q = car(P);
5037: for(I = mydeg(Q,X); I >= 0; I--){
5038: S=mycoef(Q,I,X);
5039: if(F==1 || S!=0) R = cons(S,R);
5040: }
5041: }
5042: return R;
5043: }
5044:
5045: def rmul(P,Q)
5046: {
5047: if(type(P) <= 3 && type(Q) <= 3){
5048: P=red(P);Q=red(Q);
5049: P1=dn(P);P2=nm(P);Q1=dn(Q);Q2=nm(Q);
5050: if(P1==1 && Q1==1)
5051: return P*Q;
5052: if((R=gcd(P1,Q2)) != 1){
5053: P1=tdiv(P1,R);Q2=tdiv(Q2,R);
5054: }
5055: if((R=gcd(Q1,P2)) != 1){
5056: Q1=tdiv(Q1,R);P2=tdiv(P2,R);
5057: }
5058: return P2*Q2/(P1*Q1);
5059: }
5060: #ifdef USEMODULE
5061: return mmulbys(os_md.rmul,P,Q,[]);
5062: #else
5063: return mmulbys(rmul,P,Q,[]);
5064: #endif
5065: }
5066:
5067: def mtransbys(FN,F,LL)
5068: {
5069: Opt=getopt();
5070: if(type(F) == 4){
5071: F = ltov(F);
5072: S = length(F);
5073: R = newvect(S);
5074: for(I = 0; I < S; I++)
5075: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
5076: return vtol(R);
5077: }
5078: if(type(F) == 5){
5079: S = length(F);
5080: R = newvect(S);
5081: for(I = 0; I < S; I++)
5082: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
5083: return R;
5084: }
5085: if(type(F) == 6){
5086: S = size(F);
5087: R = newmat(S[0],S[1]);
5088: for(I = 0; I < S[0]; I++){
5089: for(J = 0; J < S[1]; J++)
5090: R[I][J] = mtransbys(FN,F[I][J],LL|option_list=Opt);
5091: }
5092: return R;
5093: }
5094: if(type(F) == 7) return F;
5095: return call(FN, cons(F,LL)|option_list=Opt);
5096: }
5097:
1.58 takayama 5098: def trcolor(S)
5099: {
5100: if(type(S)!=7) return S;
5101: return ((I=findin(S,LCOPT))>=0)?COLOPT[I]:0;
5102: }
5103:
1.61 takayama 5104: def mcolor(L,P)
5105: {
5106: if(type(L)!=4) return L;
5107: if(!P||(S=length(L))==1){
5108: if(type(V=car(L))!=7) return V;
5109: return trcolor(V);
5110: }
5111: P-=ceil(P)-1;
5112: if(P==1){
5113: if(type(V=L[S-1])!=7) return V;
5114: return trcolor(V);
5115: }
5116: for(S=P*(S-1);S>1;S--,L=cdr(L));
5117: if(getopt(disc)==1) S=0;
5118: if(type(L0=L[0])==7) L0=trcolor(L0);
5119: if(type(L1=L[1])==7) L1=trcolor(L1);
5120: T=rint(iand(L0,0xff)*(1-S)+iand(L1,0xff)*S);
5121: TT=iand(L0,0xff00)*(1-S)+iand(L1,0xff00)*S;
5122: T+=rint(TT/0x100)*0x100;
5123: TT=iand(L0,0xff0000)*(1-S)+iand(L1,0xff0000)*S;
5124: return T+rint(TT/0x10000)*0x10000;
5125: }
5126:
1.6 takayama 5127: def drawopt(S,T)
5128: {
5129: if(type(S)!=7) return -1;
5130: if(T==0||T==1){
5131: for(I=0,R=LCOPT;I<7;I++,R=cdr(R))
5132: if(str_str(S,car(R))>=0) return(T==0)?COLOPT[I]:car(R);
5133: return -1;
5134: }
5135: if(T==2){
5136: V0=V1=0;
5137: for(I=0,R=LPOPT;R!=[];I++,R=cdr(R)){
5138: if(str_str(S,car(R))>=0){
5139: if(I==0) V1++;
5140: else if(I==1) V1--;
5141: else if(I==2) V0--;
5142: else V0++;
5143: }
5144: }
5145: if(V0==0&&V1==0) return -1;
5146: return [V0,V1];
5147: }
5148: if(T==3){
5149: V=0;
5150: for(I=1,R=LFOPT;R!=[];R=cdr(R),I*=2){
5151: if(str_str(S,car(R))>=0) V+=I;
5152: }
5153: return (V==0)?-1:V;
5154: }
5155: return -1;
5156: }
5157:
1.58 takayama 5158: def openGlib(W)
5159: {
5160: extern Glib_canvas_x;
5161: extern Glib_canvas_y;
5162: extern Glib_math_coordinate;
5163:
5164: if(W==0){
5165: glib_clear();
5166: return;
5167: }
5168: if(type(W)==4&&length(W)==2){
5169: Glib_canvas_x=W[0];
1.67 takayama 5170: Glib_canvas_y=W[1];
1.58 takayama 5171: }
5172: Glib_math_coordinate=1;
5173: if(getopt(null)!=1) return glib_open();
5174: }
5175:
1.6 takayama 5176: def execdraw(L,P)
5177: {
5178: if((Proc=getopt(proc))!=1) Proc=0;
5179: if(type(P)<2) P=[P];
5180: if(L!=[]&&type(L[0])!=4) L=[L];
5181: /* special command */
5182: if(P[0]<0){
5183: if(length(P)==1&&(P[0]==-1||P[0]==-2||P[0]==-3)){ /* Bounding Box */
5184: W=WS=N=LS=0;
5185: for(LL=L;LL!=[];LL=cdr(LL)){
5186: T=car(LL);
5187: if(P[0]!=-3 && T[0]==0){
5188: if(length(T)>3) S=" by "+rtostr(T[3])+" cm";
5189: else S="";
5190: if(P[0]==-1){
5191: mycat(["Windows : ",T[1][0],"< x <",T[1][1],", ",
5192: T[2][0],"< y <",T[2][1],S]);
5193: if(length(T)>4 && type(T[4])==4) mycat(["ext :",T[4]]);
5194: if(length(T)>5) mycat(["shift :",T[5]]);
5195: }
5196: return cdr(T);
5197: }
5198: if(type(T[0])==1){
5199: if(T[0]==1){
5200: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
5201: D=car(TT);
5202: if(type(D[0][0])==4){
5203: for(DT=D;DT!=[];DT=cdr(DT)){
5204: if(N++==0) W=ptbbox(car(DT));
5205: else W=ptbbox(car(DT)|box=W);
5206: }
5207: }else{
5208: if(N++==0) W=ptbbox(D);
5209: else W=ptbbox(D|box=W);
5210: }
5211: }
5212: }else if(T[0]==2){
5213: V=T[2];
5214: if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
5215: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
5216: Sc=car(Sc)[1];
5217: if(type(Sc)==1) V=[Sc*V[0],Sc*V[1]];
5218: else V=[Sc[0]*V[0],Sc[1]*V[1]];
5219: }
5220: if(LS==0) WS=ptbbox([V]);
5221: else WS=ptbbox([V]|box=WS);
5222: if(length(T)>4) S=T[4];
5223: else if(type(S=T[3])==4){
5224: S=S[0];
5225: if(type(S)==4) S=S[length(S)-1];
5226: S=rtostr(S);
5227: }
5228: if(str_len(S)>LS) LS=str_len(S);
5229: }else if(T[0]==3||T[0]==4){
5230: if(N++==0) W=ptbbox(cdr(cdr(T)));
5231: else W=ptbbox(cdr(cdr(T))|box=W);
5232: }
5233: }
5234: }
5235: if(W!=0&&WS!=0) W=ptbbox([W,WS]|box=1);
5236: return (P[0]==-3)?[W,LS,WS]:W;
5237: }else if(length(P)>1&&P[0]==-1){ /* set Bounding Box */
5238: P=cons(0,cdr(P));
5239: Ex=Sft=[0,0];
5240: if(type(X=getopt(ext))==4) Ex=X;
5241: if(type(X=getopt(shift))==4) Sft=X;
5242: if(Ex!=Sft||Ex!=[0,0]){
5243: if(Sft==[0,0]) Sft=[Ex];
5244: else Sft=[Ex,Sft];
5245: if(length(P)==3) Sft=cons(1,Sft);
5246: if(length(P)==3||length(P)==4) P=append(P,Sft);
5247: }
5248: return cons(P,delopt(L,0));
5249: }
5250: if(P[0]==-4){
5251: for(N=0,LT=L;LT!=[];LT=cdr(LT)){ /* count coord. */
5252: T=car(LT);
5253: if(T[0]==1){
5254: for(T=cdr(cdr(T));T!=[];T=cdr(T)){
5255: if(type((S=car(T))[0][0])==4) N+=length(S);
5256: else for(;S!=[];S=cdr(S)) if(type(car(S))==4) N++;
5257: }
5258: }else if(T[0]==2) N++;
5259: else if(T[0]==3||T[0]==4) N+=2;
5260: }
5261: return N;
5262: }
5263: if(P[0]==-5){ /* functions */
5264: for(N=0,R=[],LT=L;LT!=[];LT=cdr(LT)){
5265: T=car(LT);
5266: if(T[0]==0) N=ior(N,1);
5267: else if(type(T[0])==1){
5268: if(T[0]>0) N=ior(N,2^T[0]);
5269: }
5270: else if(Type(T[0])==2){
5271: if(findin(T[0],R)<0) R=cons(T[0],R);
5272: }
5273: }
5274: for(I=5;I>=0;I--) if(iand(N,2^I)) R=cons(I,R);
5275: return R;
5276: }
5277: return 0;
5278: }
5279:
5280: if(length(P)>1){
5281: if(type(P[1])==6||(type(P[1])<2&&P[1]>0)) M=P[1];
5282: else if(type(P[1])==4&&length(P[1])==2) M=diagm(2,P[1]);
5283: }
5284: if(length(P)>2&&type(P[2])==4){
5285: Org=[["shift",P[2]]];
5286: if(M==0) M=1;
5287: }else Org=[];
5288: if(P[0]==0||(type(P[0])==4&&P[0][0]==0)){ /* Risa/Asir */
5289: PP=car(P);PPP=0;
5290: if(type(PP)!=4) PP=[PP];
5291: if(length(PP)<3){
5292: if(length(PP)==1 || type(PP[1])==4){
5293: if(ID_PLOT<0) ID_PLOT=ox_launch_nox(0,"ox_plot");
5294: Id=ID_PLOT;
5295: if(length(PP)==1&&type(Canvas)==4&&length(Canvas)==2)
5296: PP=cons(PP[0],[Canvas]);
5297: if(length(PP)>1){
5298: PPP=PP[1][0];
5299: PPQ=(length(PP[1])==2)?PP[1][1]:PPP;
5300: open_canvas(Id,[PPP,PPQ]);
5301: }else open_canvas(Id);
5302: Ind=ox_pop_cmo(Id);
5303: }else{
5304: Ind=PP[1];
5305: if(getopt(cl)==1) clear_canvas(Id,Ind);
5306: }
5307: }else{
5308: Id=PP[1];Ind=PP[2];
5309: if(length(PP)>3 && type(PP[3])==1) PPP=PP[3];
5310: if(length(PP)>4 && type(PP[4])==1) PPQ=PP[4];
5311: if(getopt(cl)==1) clear_canvas(Id,Ind);
5312: }
5313: if(L==[]) return (PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
5314: Ex0=Ex0;Sft=[0,0];
5315: if(length(P)>1&&P[1]==0&&length(P)<4){
5316: R=execdraw(L,-3);
5317: Ex0=Ex1=Ex2=10;
5318: if((U=R[1])>0){ /* string */
5319: if(U>20) U=16; /* adj 16,8,2,7,15 */
5320: if(R[0][0][0]>R[2][0][0]-(R[0][0][1]-R[0][0][0])/256) Ex0+=8*U; /* adj 256 */
5321: else Ex0+=2*U;
5322: if(R[0][0][1]<R[2][0][1]+(R[0][0][1]-R[0][0][0])/256) Ex1+=7*U;
5323: else Ex1+=2*U;
5324: if(R[0][1][1]<R[2][1][1]+(R[0][1][1]-R[0][1][0])/256) Ex2+=15;
5325: }
5326: R=[R[0][0],R[0][1],0,[Ex0,Ex1],[0,-Ex2]];
5327: if(length(P)>2 && P[2]==1)
5328: mycat0(["Box:",[R[0],R[1]], ", ext=",R[3],", shift=",R[4]],1);
5329: }else R=execdraw((length(P)>3)?P[3]:L,-2); /* Windows */
5330: XW=R[0];YW=R[1];
5331: if(length(R)>3){
5332: if(R[3]!=0 && R[3]!=[0,0]) Ex=R[3];
5333: if(length(R)>4) Sft=R[4];
5334: }
5335: if(type(X=getopt(ext))==4)
5336: Ex=(Ex0)?[X[0]+Ex[0],X[1]+Ex[1]]:X;
5337: if(type(M)<2){
5338: if(length(P)>1&&type(P[1])==1) M=P[1];
5339: else if((length(P)==1||P[1]==0||P[1]==1)&& PPP>0) M=PPP;
5340: if(M<2) M=400;
5341: if(Ex!=0 && type(Ex)==4){
5342: M-=Ex[0]+Ex[1];
5343: }
5344: M=(M/(XW[1]-XW[0]))*diagm(2,[1,-1]);
5345: }
5346: if(type(X=getopt(shift))==4) Sft=(Ex0)?[Sft[0]+X[0],Sft[1]+X[1]]:X;
5347: if(type(Sft)==4) Sft=[Sft[0],-Sft[1]];
5348: if(Ex!=0) Sft=[Sft[0]+Ex[0],Sft[1]];
5349: Org=[["shift",ptaffine(M,[-XW[0],-YW[1]]|shift=Sft)]];
5350: for(CT=0;CT<2;CT++){
5351: for(LT=L;LT!=[];LT=cdr(LT)){
5352: T=car(LT);
5353: if(!CT && T[0]!=2) continue;
5354: if(CT && T[0]==2) continue;
5355: if(T[0]==1){
5356: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
5357: D=car(TT);
5358: if(type(D[0][0])==4){
5359: for(DT=D;DT!=[];DT=cdr(DT)){
5360: V=car(DT);
5361: if(M) V=ptaffine(M,V|option_list=Org);
5362: draw_bezier(Id,Ind,V|option_list=T[1]);
5363: }
5364: }else{
5365: if(M) D=ptaffine(M,D|option_list=Org);
5366: draw_bezier(Id,Ind,D|option_list=T[1]);
5367: }
5368: }
5369: }else if(T[0]==2){ /* put */
5370: if(length(T)<4) continue;
5371: V=T[2];
5372: if(type(VLB)==4&&V[0]=="_") V=VLB;
5373: else if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
5374: if(length(T)>3&&type(T[3])==4&&length(T[3])>1&&T[3][1]==1) VLB=V;
5375: F++;MM=M;
5376: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
5377: if(!MM) MM=1;
5378: Sc=car(Sc)[1];
5379: if(type(Sc)==1) MM=MM*Sc;
5380: else if(type(Sc)==6) MM=MM*diagm(2,Sc);
5381: }
5382: if(MM) V=ptaffine(MM,V|option_list=Org);
5383: if(type(S=S0=T[3])==4) S=S0[0];
5384: if(length(T)>4) S=T[4]; /* subst. string */
5385: if(type(S0)==4&&type(S0[0])==4){
5386: if((Col=drawopt(S0[0][0],0))<0) Col=0; /* attrib. */
5387: if(type(S)!=7) S=rtostr(S0[0][1]);
5388: S=str_subst(S,[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
5389: if(type(Pos=drawopt(S0[0][0],2))==4)
5390: V=[V[0]+4*str_len(S)*Pos[0],V[1]-10*Pos[1]]; /* adjustable */
5391: }else S=str_subst(rtostr(S),[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
5392: V=[V[0]-str_len(S)*4,V[1]-8]; /* adjustable */
5393: draw_string(Id,Ind,V,S,Col);
5394: }else if(T[0]==3){ /* arrow */
5395: F++;
5396: T1=T[2];T2=T[3];
5397: if(M){
5398: T1=ptaffine(M,T1|option_list=Org);
5399: T2=ptaffine(M,T2|option_list=Org);
5400: }
5401: draw_bezier(Id,Ind,[T1,T2]|option_list=T[1]);
5402: }else if(T[0]==4){ /* line */
5403: F++;
5404: T1=T[2];T2=T[3];
5405: if(M){
5406: T1=ptaffine(M,T1|option_list=Org);
5407: T2=ptaffine(M,T2|option_list=Org);
5408: }
5409: V=delopt(T1=T[1],"opt"|inv=1);
5410: if(V!=[]&&str_str(V[1],".")>=0)
5411: T1=cons(["opt",cons("dotted,",V[1])],delopt(T1,"opt"));
5412: draw_bezier(Id,Ind,[T1,T2]|option_list=T1);
5413: }else if(T[0]==5){ /* TeX */
5414: mycat(rtostr(T[2]));
5415: if(F){
5416: S=str_tb(0,Out);
5417: Out=str_tb(0,0);
5418: F=0;
5419: if(S!=""){
5420: if(P[0]==2) dviout(xyproc(S)|keep=1);
5421: else LOut=cons(xyproc(S),LOut);
5422: }
5423: if(P[0]==2) dviout(T[2]|option_list=T[1]);
5424: else{
5425: LOut=cons(T[2],Out);
5426: }
5427: }
1.57 takayama 5428: }else if(T[0]==6){ /* plot */
5429: F++;
5430: if((T1=findin(T[1],LCOPT))>-1) T1=COLOPT(T1);
5431: else if(type(T1)!=1 && T1!=0) T1=0xffffff;
5432: for(T2=ptaffine(M,T[2]|option_list=Org);T2!=[];T2=cdr(T2))
5433: draw_obj(Id,Ind,[rint(car(T2)[0]),rint(car(T2)[1])],T1);
1.6 takayama 5434: }else if(Proc==1&&type(T[0])==2){
5435: if(length(T)<3) call(T[0],T[1]);
5436: else call(T[0],T[1]|option_list=T[2]);
5437: }
5438: }
5439: }
5440: S=(PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
5441: if(Ex==0&&Sft!=[0,0]) Ex=[0,0];
5442: return (Ex!=0&&length(P)>2&&P[2]==-1)?
5443: [S,0,0,[0,R[0],R[1],0,Ex,[Sft[0]-Ex[0],-Sft[1]]]]:S;
5444: }
5445: if(P[0]==1||P[0]==2){ /* TeX */
5446: Out=str_tb(0,0);LOut=[];F=0;
5447: if(getopt(cl)==1) dviout0(0);
5448: for(;L!=[];L=cdr(L)){
5449: T=car(L);Opt=T[1];
5450: if(type(T[0])>=2) continue;
5451: if(T[0]==0){
5452: XW=T[1];YW=T[2];
5453: if(length(P)>1&&type(P[1])==1&&P[1]<0)
5454: M=-P[1]/(XW[0]-XW[1]);
5455: }else if(T[0]==1){
5456: F++;
5457: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
5458: D=car(TT);
5459: if(type(D[0][0])==4){
5460: for(DT=D;DT!=[];DT=cdr(DT)){
5461: V=car(DT);
5462: if(M) V=ptaffine(M,V|option_list=Org);
5463: str_tb(xybezier(V|option_list=Opt),Out);
5464: }
5465: }else{
5466: if(M) D=ptaffine(M,D|option_list=Org);
5467: str_tb(xybezier(D|option_list=Opt),Out);
5468: }
5469: }
5470: }else if(T[0]==2){
5471: F++;V=T[2];
5472: Opt=delopt(Opt,"scale"|inv=1);
5473: MM=M;
5474: if(Opt!=[]){
5475: Opt=car(Opt)[1];
5476: if(type(Opt)==1) Opt=[Opt,Opt];
5477: if(Opt!=[1,1]){
5478: if(!MM) MM=1;
5479: MM=MM*diagm(2,[Opt[0],Opt[1]]);
5480: }
5481: }
5482: if(MM) V=ptaffine(MM,V|option_list=Org);
1.74 takayama 5483: if(length(T)>3){
5484: if(type(T2=T[3])==7) T2=[T2];
5485: V=append(V,T2);
5486: }
1.6 takayama 5487: str_tb(xyput(V),Out);
5488: }else if(T[0]==3){
5489: F++;
5490: T1=T[2];T2=T[3];
5491: if(M){
5492: T1=ptaffine(M,T1|option_list=Org);
5493: T2=ptaffine(M,T2|option_list=Org);
5494: }
5495: str_tb(xyarrow(T1,T2|option_list=Opt),Out);
5496: }else if(T[0]==4){
5497: F++;
5498: T1=T[2];T2=T[3];
5499: if(M){
5500: T1=ptaffine(M,T1|option_list=Org);
5501: T2=ptaffine(M,T2|option_list=Org);
5502: }
5503: str_tb(xyline(T1,T2|option_list=Opt),Out);
5504: }else if(T[0]==5){
5505: if(F){
5506: S=str_tb(0,Out);
5507: Out=str_tb(0,0);
5508: F=0;
5509: if(S!=""){
5510: if(P[0]==2) dviout(xyproc(S)|keep=1);
5511: else LOut=cons(xyproc(S),LOut);
5512: }
5513: if(P[0]==2) dviout(T[2]|option_list=T[1]);
5514: else LOut=cons(T[2],Out);
5515: }
1.57 takayama 5516: }else if(T[0]==6){ /* plot */
5517: F++;
5518: if(type(T[1])==7) T1=[T[1],"."];
5519: else T1=".";
5520: for(T2=ptaffine(M,T[2]|option_list=Org);T2!=[];T2=cdr(T2))
5521: str_tb(xypos([car(T2)[0],car(T2)[1],T1]),Out);
1.6 takayama 5522: }else if(T[0]==-2)
5523: str_tb(["%",T[1],"\n"],Out);
1.57 takayama 5524: else if(Proc==1&&type(T[0])==2){
1.6 takayama 5525: if(length(T)<3) call(T[0],T[1]);
5526: else call(T[0],T[1]|option_list=T[2]);
5527: }
5528: }
5529: S=str_tb(0,Out);
5530: if(P[0]==1){
5531: if(F) LOut=cons(xyproc(S),LOut);
5532: Out=str_tb(0,0);
5533: for(L=reverse(LOut);L!=[];L=cdr(L))
5534: str_tb(car(L),Out);
5535: return str_tb(0,Out);
5536: }
5537: if(F) dviout(xyproc(S));
5538: else dviout(" ");
5539: }
5540: }
5541:
5542: def execproc(L)
5543: {
5544: if(type(N=getopt(var))!=1&&N!=0) N=2;
5545: for(R=[];L!=[];L=cdr(L)){
5546: P=car(L);
5547: if(type(P[0])==2&&vtype(P[0])==3){
5548: if((VS=vars(cdr(P)))!=[]){
5549: for(I=0;I<N;I++){
5550: V=makev(["v",I+1]);
5551: if(findin(V,VS)>=0) P=mysubst(P,[V,R[I]]);
5552: }
5553: }
5554: if(length(P)<3) R=cons(call(P[0],P[1]),R);
5555: else R=cons(call(P[0],P[1]|option_list=P[2]),R);
5556: }
5557: }
5558: return (getopt(all)==1)?R:car(R);
5559: }
5560:
5561: def myswap(P,L)
5562: {
5563: X=makenewv(P);
5564: for(L=reverse(L);length(L)>1;L=cdr(L))
5565: P=subst(P,L[0],X,L[1],L[0],X,L[1]);
5566: return P;
5567: }
5568:
5569: def mysubst(P,L)
5570: {
5571: if(P==0) return 0;
1.29 takayama 5572: if(getopt(lpair)==1||(type(L[0])==4&&length(L[0])>2)) L=lpair(L[0],L[1]);
1.6 takayama 5573: Inv=getopt(inv);
5574: if(type(L[0]) == 4){
5575: while((L0 = car(L))!=[]){
5576: P = mysubst(P,(Inv==1)?[L0[1],L0[0]]:L0);
5577: L = cdr(L);
5578: }
5579: return P;
5580: }
5581: if(Inv==1) L=[L[1],L[0]];
5582: if(type(P) > 3){
5583: if(type(P)==7) return P;
5584: if(type(P)>7)
5585: return subst(P,L[0],L[1]);
5586: #ifdef USEMODULE
5587: return mtransbys(os_md.mysubst,P,[L]);
5588: #else
5589: return mtransbys(mysubst,P,[L]);
5590: #endif
5591: }
5592: P = red(P);
5593: if(type(P) == 3){
5594: A=mysubst(nm(P),L);B=mysubst(dn(P),L);
5595: return red(nm(A)/nm(B))*red(dn(B)/dn(A));
5596: }
5597: L1=(type(L[1])==3)?red(L[1]):L[1];X=L[0];
5598: if(ptype(L1,X)==3){
5599: LN=nm(L1);LD=dn(L1);
5600: Deg=mydeg(P,X);
5601: if(Deg <= 0) return P;
5602: V = newvect(Deg+1);
5603: for(V[I=Deg]=1;I >= 1;I--)
5604: V[I-1]=V[I]*LD;
5605: for(R = 0, I = Deg; I >= 0; I--)
5606: R = R*LN + mycoef(P,I,X)*V[I];
5607: return red(R/V[0]);
5608: }
5609: return subst(P,X,L1);
5610: }
5611:
5612: def mmulbys(FN,P,F,L)
5613: {
5614: Opt=getopt();
5615: if(type(F) <= 3){
5616: if(type(P) <= 3)
5617: return call(FN, cons(P,cons(F,L))|option_list=Opt);
5618: if(type(P) == 5){
5619: S = length(P);
5620: R = newvect(S);
5621: for(I = 0; I < S; I++)
5622: R[I] = call(FN, cons(P[I],cons(F,L))|option_list=Opt);
5623: return R;
5624: }else if(type(P) == 6){
5625: S = size(P);
5626: R = newmat(S[0],S[1]);
5627: for(I = 0; I < S[0]; I++){
5628: for(J = 0; J < S[1]; J++)
5629: R[I][J] = call(FN, cons(P[I][J],cons(F,L))|option_list=Opt);
5630: }
5631: return R;
5632: }
5633: }
5634: if(type(F) == 5){
5635: S = length(F);
5636: if(type(P) <= 3){
5637: R = newvect(S);
5638: for(I = 0; I < S; I++)
5639: R[I] = call(FN, cons(P,cons(F[I],L))|option_list=Opt);
5640: return R;
5641: }
5642: if(type(P) == 5){
5643: for(J=R=0; J<S; J++)
5644: R = radd(R, call(FN, cons(P[J],cons(F[J],L)))|option_list=Opt);
5645: return R;
5646: }
5647: T = size(P);
5648: R = newvect(T[0]);
5649: for(I = 0; I < T[0]; I++){
5650: for(J = 0; J < S; J++)
5651: R[I] = radd(R[I], call(FN, cons(P[I][J],cons(F[J],L))|option_list=Opt));
5652: }
5653: return R;
5654: }
5655: if(type(F) == 6){
5656: S = size(F);
5657: if(type(P) <= 3){
5658: R = newmat(S[0],S[1]);
5659: for(I = 0; I < S[0]; I++){
5660: for(J = 0; J < S[1]; J++)
5661: R[I][J] = call(FN, cons(P,cons(F[I][J],L))|option_list=Opt);
5662: }
5663: return R;
5664: }
5665: if(type(P) == 5){
5666: R = newvect(S[1]);
5667: for(J = 0; J < S[1]; J++){
5668: for(K = U = 0; K < S[0]; K++)
5669: U = radd(U, call(FN, cons(P[K],cons(F[K][J],L))|option_list=Opt));
5670: R[J] = U;
5671: }
5672: return R;
5673: }
5674: T = size(P);
5675: R = newmat(T[0],S[1]);
5676: for(I = 0; I < T[0]; I++){
5677: for(J = 0; J < S[1]; J++){
5678: for(K = U = 0; K < S[0]; K++)
5679: U = radd(U, call(FN, cons(P[I][K],cons(F[K][J],L)|option_list=Opt)));
5680: R[I][J] = U;
5681: }
5682: }
5683: return R;
5684: }
5685: erno(0);
5686: return 0;
5687: }
5688:
5689: def appldo(P,F,L)
5690: {
1.56 takayama 5691: if(getopt(Pfaff)==1){
5692: L = vweyl(L);
5693: X = L[0]; DX = L[1];
5694: for(I=mydeg(P,DX);I>0;I--){
1.78 takayama 5695: if(!(TP=mycoef(P,I,DX))) continue;
5696: P=red(P-TP*DX^I+TP*muldo(DX^(I-1),F,L));
1.56 takayama 5697: }
5698: return P;
5699: }
1.6 takayama 5700: if(type(F) <= 3){
5701: if(type(L) == 4 && type(L[0]) == 4)
5702: return applpdo(P,F,L);
5703: L = vweyl(L);
5704: X = L[0]; DX = L[1];
5705: J = mydeg(P,DX);
5706: for(I = R = 0; I <= J; I++){
5707: if(I > 0)
5708: F = mydiff(F,X);
5709: R = radd(R,mycoef(P,I,DX)*F);
5710: }
5711: return R;
5712: }
5713: #ifdef USEMODULE
5714: return mmulbys(os_md.appldo,P,F,[L]);
5715: #else
5716: return mmulbys(appldo,P,F,[L]);
5717: #endif
5718: }
5719:
5720: def appledo(P,F,L)
5721: {
5722: if(type(F) <= 3){
5723: L = vweyl(L);
5724: X = L[0]; DX = L[1];
5725: J = mydeg(P,DX);
5726: for(I = R = 0; I <= J; I++){
5727: if(I > 0)
5728: F = myediff(F,X);
5729: R = radd(R,mycoef(P,I,DX)*F);
5730: }
5731: return R;
5732: }
5733: #ifdef USEMODULE
5734: mmulbys(os_md.appledo,P,F,[L]);
5735: #else
5736: mmulbys(appledo,P,F,[L]);
5737: #endif
5738: }
5739:
5740: def muldo(P,Q,L)
5741: {
5742: if(type(Lim=getopt(lim))!=1) Lim=100;
5743: if(type(Q) <= 3){
5744: if(type(L) == 4 && type(L[0]) == 4)
5745: return mulpdo(P,Q,L|lim=Lim); /* several variables */
5746: R = rmul(P,Q);
5747: L = vweyl(L);
5748: X = L[0]; DX = L[1];
5749: if(X != 0){
5750: for(I = F = 1; ; I++){
5751: P = mydiff(P,DX);
5752: if(I>Lim){
5753: mycat(["Over", Lim,"derivations!"]);
5754: break;
5755: }
5756: if(P == 0)
5757: break;
5758: Q = mydiff(Q,X);
5759: if(Q == 0)
5760: break;
5761: F *= I;
5762: R = radd(R,P*Q/F);
5763: }
5764: }
5765: return R;
5766: }
5767: #ifdef USEMODULE
5768: return mmulbys(os_md.muldo,P,Q,[L]);
5769: #else
5770: return mmulbys(muldo,P,Q,[L]);
5771: #endif
5772: }
5773:
5774: def jacobian(F,X)
5775: {
5776: F=ltov(F);X=ltov(X);
1.30 takayama 5777: N=length(F);L=length(X);
5778: M=newmat(N,L);
1.6 takayama 5779: for(I=0;I<N;I++)
1.30 takayama 5780: for(J=0;J<L;J++) M[I][J]=red(diff(F[I],X[J]));
5781: if(N!=L||getopt(mat)==1) return M;
1.6 takayama 5782: return mydet(M);
5783: }
5784:
5785: def hessian(F,X)
5786: {
5787: X=ltov(X);
5788: N=length(X);
5789: M=newmat(N,N);
5790: for(I=0;I<N;I++){
5791: G=red(diff(F,X[I]));
5792: for(J=0;J<N;J++) M[I][J]=red(diff(G,X[J]));
5793: }
5794: if(getopt(mat)==1) return M;
5795: return mydet(M);
5796: }
5797:
5798: def wronskian(F,X)
5799: {
5800: N=length(F);
5801: M=newmat(N,N);
5802: for(I=0;F!=[];F=cdr(F),I++){
5803: M[I][0]=car(F);
5804: for(J=1;J<N;J++) M[I][J]=red(diff(M[I][J-1],X));
5805: }
5806: if(getopt(mat)==1) return M;
5807: return mydet(M);
5808: }
5809:
5810: def adj(P,L)
5811: {
5812: if(type(P) == 4)
5813: #ifdef USEMODULE
5814: return map(os_md.adj,mtranspose(P),L);
5815: #else
5816: return map(adj,mtranspose(P),L);
5817: #endif
5818: if(type(L) == 4 && type(L[0]) == 4)
5819: #ifdef USEMODULE
5820: return fmult(os_md.adj,P,L,[]);
5821: #else
5822: return fmult(adj,P,L,[]);
5823: #endif
5824: L = vweyl(L);
5825: X = L[0]; DX = L[1];
5826: P = R = subst(P, DX, -DX);
5827: for(I = 1; (R = mydiff(mydiff(R, X), DX)/I) != 0 && I < 100; I++)
5828: P = radd(P,R);
5829: return P;
5830: }
5831:
5832: def laplace1(P,L)
5833: {
5834: if(type(L) == 4 && type(L[0]) == 4)
5835: #ifdef USEMODULE
5836: return fmult(os_md.laplace,P,L,[]);
5837: #else
5838: return fmult(laplace,P,L,[]);
5839: #endif
5840: L = vweyl(L);
5841: X = L[0]; DX = L[1];
5842: P = adj(P, L);
5843: return subst(P,X,o_1,DX,X,o_1,DX);
5844: }
5845:
5846: def laplace(P,L)
5847: {
5848: if(type(L) == 4 && type(L[0]) == 4)
5849: #ifdef USEMODULE
5850: return fmult(os_md.laplace1,P,L,[]);
5851: #else
5852: return fmult(laplace1,P,L,[]);
5853: #endif
5854: L = vweyl(L);
5855: X = L[0]; DX = L[1];
5856: P = adj(P, L);
5857: return subst(P,X,o_1,DX,-X,o_1,-DX);
5858: }
5859:
5860: def mce(P,L,V,R)
5861: {
5862: L = vweyl(L);
5863: X = L[0]; DX = L[1];
1.56 takayama 5864: P = sftexp(laplace1(P,L),L,V,R|option_list=getopt());
1.6 takayama 5865: return laplace(P,L);
5866: }
5867:
5868: def mc(P,L,R)
5869: {
1.56 takayama 5870: return mce(P,L,0,R|option_list=getopt());
1.6 takayama 5871: }
5872:
5873: def rede(P,L)
5874: {
5875: Q = ltov(fctr(nm(red(P))));
5876: P = 1;
5877: if(type(L) < 4)
5878: L = [L];
5879: if(type(L[0]) < 4)
5880: L = [L];
5881: for( ; L != []; L = cdr(L)){
5882: DX = vweyl(car(L))[1];
5883: for(I = 1; I < length(Q); I++){
5884: if(mydeg(Q[I][0],DX) > 0){
5885: P *= (Q[I][0])^(Q[I][1]);
5886: Q[I]=[1,0];
5887: }
5888: }
5889: }
5890: return P;
5891: }
5892:
5893: def ad(P,L,R)
5894: {
5895: L = vweyl(L);
5896: DX = L[1];
5897: K = mydeg(P,DX);
5898: S = mycoef(P,0,DX);
5899: Q = 1;
5900: for(I=1; I <= K;I++){
5901: Q = muldo(Q,DX-R,L);
5902: S = radd(S,mycoef(P,I,DX)*Q);
5903: }
5904: return S;
5905: }
5906:
5907: def add(P,L,R)
5908: {
5909: return rede(ad(P,L,R),L);
5910: }
5911:
5912:
5913: def vadd(P,L,R)
5914: {
5915: L = vweyl(L);
5916: if(type(R) != 4)
5917: return 0;
5918: N = length(R);
5919: DN = 1; Ad = PW = 0;
5920: for( ; R != []; R = cdr(R), PW++){
5921: DN *= (T=1-car(R)[0]*L[0]);
5922: Ad = Ad*T-car(R)[1]*x^PW;
5923: }
5924: Ad /= DN;
5925: return add(P,L,Ad);
5926: }
5927:
5928: def addl(P,L,R)
5929: {
5930: return laplace1(add(laplace(P,L),L,R),L);
5931: }
5932:
5933: def cotr(P,L,R)
5934: {
5935: L = vweyl(L);
5936: X = L[0]; DX = L[1];
5937: T = 1/mydiff(P,DX);
5938: K = mydeg(P,DX);
5939: S = mysubst(mycoef(P,0,DX), [X, R]);
5940: Q = 1;
5941: for(I = 1; I <= K; I++){
5942: Q = muldo(Q, K*DX, L);
5943: S = radd(S,mysubst(mycoef(P,I,DX), [X, R])*Q);
5944: }
5945: }
5946:
5947: def rcotr(P,L,R)
5948: {
5949: return rede(cotr(P,L,R), L);
5950: }
5951:
5952: def muledo(P,Q,L)
5953: {
5954: if(type(Q)>3)
5955: #ifdef USEMODULE
5956: return mmulbys(os_md.muledo,P,Q,[L]);
5957: #else
5958: return mmulbys(muledo,P,Q,[L]);
5959: #endif
5960: R = P*Q;
5961: L = vweyl(L);
5962: X = L[0]; DX = L[1];
5963: for(I = F = 1; I < 100; I++){
5964: P = mydiff(P,DX);
5965: if(P == 0)
5966: break;
5967: Q = myediff(Q,X);
5968: if(Q == 0)
5969: break;
5970: F = rmul(F,I);
5971: R = radd(R,P*Q/F);
5972: }
5973: return R;
5974: }
5975:
5976:
5977: #if 1
5978: def mulpdo(P,Q,L)
5979: {
5980: if(type(Q)>3)
5981: #ifdef USEMODULE
5982: return mmulbys(os_md.mulpdo,P,Q,[L]);
5983: #else
5984: return mmulbys(mulpdo,P,Q,[L]);
5985: #endif
5986: if(type(Lim=getopt(lim))!=1) Lim=100;
5987: M = vweyl(car(L)); X= M[0]; DX = M[1];
5988: L = cdr(L);
5989: R = 0;
5990: for(I = 0; Q != 0 && I <= Lim; I++){
5991: if(I>Lim){
5992: mycat(["Over", Lim,"derivations!"]);
5993: break;
5994: }
5995: if(I > 0)
5996: P /= I;
5997: if(length(L)==0)
5998: R = radd(R,P*Q);
5999: else
6000: R = radd(R,mulpdo(P,Q,L));
6001: if(X==0) break;
6002: P = mydiff(P,DX);
6003: if(P == 0)
6004: break;
6005: Q = mydiff(Q,X);
6006: }
6007: if(I>Lim) mycat(["Over", Lim,"derivations!"]);
6008: return R;
6009: }
6010:
6011: #else
6012: def mulpdo(P,Q,L);
6013: {
6014: if(type(Q)>3)
6015: #ifdef USEMODULE
6016: return mmulbys(os_md.mulpdo,P,Q,[L]);
6017: #else
6018: return mmulbys(mulpdo,P,Q,[L]);
6019: #endif
6020: if(type(Lim=getopt(lim))!=1) Lim=100;
6021: N = length(L);
6022: VO = newvect(2*N);
6023: VN = newvect(2*N);
6024: for(I = J = 0; I < N; J += 2, I++){
6025: M = vweyl(L[I]);
6026: P = subst(P, VO[J]=M[0], VN[J]=strtov("o_"+rtostr(V[J])),
6027: VO[J+1]=M[1], VN[J+1] = strtov("o_"+rtostr(V[J+1])));
6028: }
6029: for(PQ = P*Q, I = 0; I < 2*N; I += 2){
6030: for(R = PQ, J = 1; J < Lim; J++){
6031: R = mydiff(R, VN[I+1])/J;
6032: if(R == 0)
6033: break;
6034: R = mydiff(R, VO[I]);
6035: if(R == 0)
6036: break;
6037: PQ = radd(PQ,R);
6038: }
6039: if(I==Lim) mycat(["Over", Lim,"derivations!"]);
6040: PQ = red(subst(PQ,VN[I],VO[I],VN[I+1],VO[I+1]));
6041: }
6042: }
6043: #endif
6044:
6045: def transpdosub(P,LL,K)
6046: {
1.49 takayama 6047: if(type(P)>3) return
6048: #ifdef USEMODULE
6049: mtransbys(os_md.transpdosub,P,[LL,K]);
6050: #else
6051: mtransbys(transpdosub,P,[LL,K]);
6052: #endif
1.6 takayama 6053: Len = length(K)-1;
6054: if(Len < 0 || P == 0)
6055: return P;
6056: KK=K[Len];
6057: if(type(KK)==4){
6058: KK0=KK[0]; KK1=KK[1];
6059: }else{
6060: L = vweyl(LL[Len]);
6061: KK0=L[1]; KK1=K[Len];
6062: }
6063: Deg = mydeg(P,KK0);
6064: K1 = reverse(cdr(reverse(K)));
6065: R = transpdosub(mycoef(P,0,KK0),LL,K1);
6066: for(I = M = 1; I <= Deg ; I++){
6067: M = mulpdo(M,KK1,LL);
6068: S = mycoef(P,I,KK0);
6069: if(Len > 0)
6070: S = transpdosub(S,LL,K1);
6071: R = radd(R,mulpdo(S,M,LL));
6072: }
6073: return R;
6074: }
6075:
6076: def transpdo(P,LL,K)
6077: {
6078: Len = length(K)-1;
6079: K1=K2=[];
6080: if(type(LL)!=4) LL=[LL];
6081: if(type(LL[0])!=4) LL=[LL];
1.49 takayama 6082: if(type(car(K)) < 4 && length(LL)!=length(K)) K = [K];
1.6 takayama 6083: if(getopt(ex)==1){
6084: for(LT=LL, KT=K; KT!=[]; LT=cdr(LT), KT=cdr(KT)){
6085: L = vweyl(LL[J]);
6086: K1=cons([L[0],car(KT)[0]],K1);
6087: K2=cons([L[1],car(KT)[1]],K2);
6088: }
6089: K2=append(K1,K2);
6090: }else{
1.49 takayama 6091: if(length(LL)==length(K) && type(car(K))!=4){
6092: for(DV=V=TL=[],J=length(LL)-1;J>=0;J--){
6093: TL=cons(vweyl(LL[J]),TL);
6094: V=cons(car(TL)[0],V);
6095: DV=cons(car(TL)[1],DV);
6096: }
6097: LL=TL;
6098: if(type(RK=solveEq(K,V|inv=1))!=4) return TK;
6099: if(!isint(Inv=getopt(inv))) Inv=0;
6100: if(iand(Inv,1)){J=K;K=RK;RK=J;}
6101: M=jacobian(RK,V|mat=1);
6102: M=mulsubst(M,[V,K]|lpair=1);
6103: RK=vtol(M*ltov(DV));
6104: if(Inv>1) return RK;
6105: K=lpair(K,RK);
6106: }
1.6 takayama 6107: for(J = length(K)-1; J >= 0; J--){
6108: L = vweyl(LL[J]);
1.49 takayama 6109: if(L[0]!= K[J][0]) K1=cons([L[0],K[J][0]],K1);
1.6 takayama 6110: K2 = cons(K[J][1],K2);
6111: }
6112: P = mulsubst(P, K1);
6113: }
6114: return transpdosub(P,LL,K2);
6115: }
6116:
6117: def translpdo(P,LL,M)
6118: {
6119: S=length(LL);
6120: L0=newvect(S);L1=newvect(S);
6121: K=newvect(S);
6122: for(J=0;J<S;J++){
6123: L = vweyl(LL[J]);
6124: L0[J]=L[0];
6125: L1[J]=L[1];
6126: }
6127: K=rmul(M,L0);
6128: for(T=[],J=0;J<S;J++)
6129: T=cons([L0[J],K[J]],T);
6130: P=mulsubst(P,T);
6131: K=rmul(myinv(M),L1);
6132: for(T=[],J=0;J<S;J++)
6133: T=cons([L1[J],K[J]],T);
6134: return mulsubst(P,T);
6135: }
6136:
6137: /*
6138: return [R, M, S] : R = M*P - S*Q
6139: deg(R,X) < deg(Q,X)
6140: */
6141: def rpdiv(P,Q,X)
6142: {
6143: if(P == 0)
6144: return [0,1,0];
6145: DQ = mydeg(Q,X);
6146: CO = mycoef(Q,DQ,X);
6147: S = 0;
6148: while((DP = mydeg(P,X)) >= DQ){
6149: R = mycoef(P,DP,X)/CO;
6150: S = radd(S,R*X^(DP-DQ));
6151: P = radd(P, -R*Q*X^(DP-DQ));
6152: }
6153: Lcm = lcm(dn(S),dn(P));
6154: Gcd = gcd(nm(S),nm(P));
6155: return [red(P*Lcm/Gcd), red(Lcm/Gcd),red(S*Lcm/Gcd)];
6156: }
6157:
6158: def texbegin(T,S)
6159: {
6160: if(type(Opt=getopt(opt))==7) Opt="["+Opt+"]\n";
6161: else Opt="\n";
1.47 takayama 6162: U=(str_chr(S,str_len(S)-1,"\n")<0)?"%\n":"";
6163: return "\\begin{"+T+"}"+Opt+S+U+"\\end{"+T+"}\n";
1.6 takayama 6164: }
6165:
6166: def mygcd(P,Q,L)
6167: {
6168: if((Dvi=getopt(dviout))==3 || Dvi==-3){ /* dviout=3 */
6169: if((Rev=getopt(rev))!=1) Rev=0;
6170: R=mygcd(P,Q,L|rev=Rev);
6171: if(type(L)<2) Var=0;
6172: else if(type(L)==2){
6173: Val=L;L=[0,L];
6174: }else if(type(L)==4){
6175: L=vweyl(L);
6176: Var=[[L[1],"\\partial"]];
6177: }
6178: S=mat([P],[Q]);T=mat([R[0]],[0]);
6179: M=mat([R[1],R[2]],[R[3],R[4]]);
6180: if(type(Val)==4)
6181: N=mdivisor(M,L|trans=1)[1];
6182: else N=myinv(M);
6183: Tb=str_tb(mtotex(S|var=Var),0);
6184: str_tb("&="+mtotex(N|var=Var)+mtotex(T|var=Var)+",\\\\\n",Tb);
6185: str_tb(mtotex(T|var=Var),Tb);
6186: str_tb("&="+mtotex(M|var=Var)+mtotex(S|var=Var)+".",Tb);
6187: Out=str_tb(0,Tb);
6188: if(Dvi<0) return Out;
6189: dviout(Out|eq="align*");
6190: return 1;
6191: }
6192: if((type(Dvi)==1||Dvi==0) && getopt(rev)!=1) V=[[P,Q]];
6193: else V=0;
6194: if(L==0){ /* integer case */
6195: if(type(P) > 1 || type(Q) > 1 || Q==0 /* P <= 0 || Q <= 0 */
6196: || dn(P) > 1 || dn(Q) > 1)
6197: return 0;
6198: CPP = CQQ = 1; CQP = CPQ = 0;
6199: P1 = P; Q1 = Q;
6200: /* P1 = CPP*P + CPQ*Q
6201: Q1 = CQP*P + CQQ*Q */
6202: while(Q1 != 0){
6203: Div1 = idiv(P1,Q1); Div2 = irem(P1,Q1);
6204: if(type(V)==4) V=cons([Div1,Div2],V);
6205: P1 = Q1 ; Q1 = Div2;
6206: TP = CQP; TQ = CQQ;
6207: CQP = CPP-Div1*CQP;
6208: CQQ = CPQ-Div1*CQQ;
6209: CPP = TP; CPQ = TQ;
6210: }
6211: if(V!=0){
6212: V=reverse(V);
6213: if((DVI=abs(Dvi))==0) return V;
6214: PT=P;QT=Q;
6215: if(DVI==1 || DVI==2){
6216: Tb=str_tb(0,0);
6217: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
6218: T=car(V);
6219: if(C++) str_tb(texcr(11),Tb);
6220: if(DVI==1){
6221: Qs=rtostr(QT);
6222: if(QT<0) Qs="("+Qs+")";
6223: if(T[1]>0) Qs=Qs+"+";
6224: if(T[1]!=0) Qs=Qs+rtostr(T[1]);
6225: str_tb(rtostr(PT)+"&="
6226: +rtostr(T[0])+"\\times"+Qs,Tb);
6227: }else{
6228: N=mat([T[0],1],[1,0]);
6229: if(C==1){
6230: str_tb(S0=mtotex(mat([PT],[QT])),Tb);
6231: M=N;
6232: }
6233: str_tb("&=",Tb);
6234: if(C>1) str_tb(mtotex(M),Tb);
6235: str_tb(mtotex(N),Tb);
6236: str_tb(S=mtotex(mat([QT],[T[1]])),Tb);
6237: if(C>1){
6238: str_tb("=",Tb);
6239: str_tb(mtotex(M=M*N),Tb);
6240: str_tb(S,Tb);
6241: }
6242: }
6243: PT=QT;QT=T[1];
6244: }
6245: if(DVI==2){
6246: str_tb(texcr(43)+S+"&=",Tb);
6247: str_tb(mtotex(myinv(M)),Tb);
6248: str_tb(S0,Tb);
6249: }
6250: Out=str_tb(0,Tb);
6251: if(Dvi>0){
6252: dviout(Out|eq="align*");
6253: return 1;
6254: }
6255: return Out;
6256: }
6257: }
6258: if(P1<0) return [-P1,-CPP,-CPQ,CQP,CQQ];
6259: return [P1, CPP, CPQ, CQP, CQQ];
6260: }
6261: if(type(L) == 2) /* polynomical case */
6262: L = [0,L];
6263: if(getopt(rev)==1 && L[0]!=0){
6264: R=mygcd(adj(P,L),adj(Q,L),L);
6265: return [adj(R[0],L),adj(R[1],L),adj(R[2],L),adj(R[3],L),adj(R[4],L)];
6266: }
6267: if(type(P) == 3)
6268: P = red(P);
6269: if(type(Q) == 3)
6270: Q = red(Q);
6271: CP=newvect(2,[1/dn(P),0]); CQ=newvect(2,[0,1/dn(Q)]);
6272: P=PT=nm(P); Q =QT=nm(Q);
6273: L = vweyl(L);
6274: while(Q != 0){
6275: R = divdo(P,Q,L);
6276: if(type(V)==4) V=cons(R,V);
6277: /* R[1] = R[2]*P - R[0]*Q
6278: = R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */
6279: /*
6280: P(n) |0 1 | P(n-1)
6281: = | |
6282: R[1] |R[2] -R[0]| P(n)
6283: P(n+1) = R[1], P(n) = P, P(n-1) = Q
6284: */
6285: P = Q;
6286: Q = R[1];
6287: {
6288: CT = dupmat(CQ);
6289: CQ = [R[2]*CP[0]-muldo(R[0],CQ[0],L),
6290: R[2]*CP[1]-muldo(R[0],CQ[1],L)];
6291: CP = CT;
6292: }
6293: }
6294: if(V!=0){
6295: V=reverse(V);
6296: if((DVI=abs(Dvi))==0) return V;
6297: if(type(L[0])<1) Var=L[1];
6298: else Var=[L[1],"\\partial"];
6299: if(DVI==1 || DVI==2){
6300: Tb=str_tb(0,0);
6301: PT=car(V)[0];QT=car(V)[1];
6302: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
6303: T=car(V);
6304: if(C++) str_tb(texcr(11),Tb);
6305: if(DVI==1){
6306: if(T[2]!=1){
6307: str_tb(monototex(T[2]),Tb);
6308: str_tb("(",Tb);
6309: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
6310: str_tb(")&=",Tb);
6311: }else{
6312: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
6313: str_tb("&=",Tb);
6314: }
6315: str_tb("(",Tb);
6316: str_tb(fctrtos(T[0]|var=Var,TeX=2),Tb);
6317: str_tb(")(",Tb);
6318: str_tb(fctrtos(QT|var=Var,TeX=2),Tb);
6319: if(T[1]!=0){
6320: str_tb(")+(",Tb);
6321: str_tb(fctrtos(T[1]|var=Var,TeX=2),Tb);
6322: }
6323: str_tb(")",Tb);
6324: }else{
6325: N=mat([red(T[0]/T[2]),1],[1,0]);
6326: if(C==1){
6327: str_tb(S0=mtotex(mat([PT],[QT])|var=Var),Tb);
6328: M=N;
6329: }
6330: str_tb("&=",Tb);
6331: if(C>1) str_tb(mtotex(M),Tb);
6332: str_tb(mtotex(N|var=Var),Tb);
6333: str_tb(S=mtotex(mat([QT],[T[1]])|var=Var),Tb);
6334: if(C>1){
6335: str_tb("=",Tb);
6336: str_tb(mtotex(M=muldo(M,N,L)|var=Var),Tb);
6337: str_tb(S,Tb);
6338: }
6339: }
6340: PT=QT;QT=T[1];
6341: }
6342: if(DVI==2){
6343: FT=fctr(PT);
6344: for(R=1;FT!=[];FT=cdr(FT)){
6345: if(mydeg(car(FT)[0],L[1])<1)
6346: for(J=car(FT)[1];J>0;J--) R*=car(FT)[0];
6347: }
6348: if(R!=1){
6349: str_tb(texcr(79),Tb);
6350: M=muldo(M,mat([R,0],[0,1]),L);
6351: str_tb(mtotex(M|var=Var),Tb);
6352: str_tb(S=mtotex(mat([PT/R],[QT])|var=Var),Tb);
6353: }
6354: str_tb(texcr(43)+S+"&=",Tb);
6355: if(type(Var)==4){
6356: N=mdivisor(M,L|trans=1);
6357: N=N[1];
6358: }else
6359: N=myinv(M);
6360: str_tb(mtotex(N|var=Var),Tb);
6361: str_tb(S0,Tb);
6362: }
6363: Out=str_tb(0,Tb);
6364: if(Dvi>0){
6365: dviout(Out|eq="align*");
6366: return 1;
6367: }
6368: return Out;
6369: }
6370: }
6371: Q = rede(P,L);
6372: R = red(P/Q);
6373: return [Q,red(CP[0]/R),red(CP[1]/R),red(CQ[0]/R),red(CQ[1]/R)];
6374: }
6375:
6376: def mylcm(P,Q,L)
6377: {
6378: Rev=(getopt(rev)==1)?1:0;
6379: if(Rev==1){
6380: P=adj(P); Q=adj(Q);
6381: }
6382: R = mygcd(P,Q,L);
6383: S=(type(L)<=2)?R[3]*P:muldo(R[3],P,L);
6384: S = nm(S);
6385: if(type(S) <= 1 && type(L) <= 1){
6386: if(S<0) S = -S;
6387: return S;
6388: }
6389: if(type(L) == 2)
6390: return easierpol(S,L);
6391: S=rede(easierpol(S,L[1]),L);
6392: return (Rev==1)?adj(S):S;
6393: }
6394:
6395: def sftpexp(P,LL,F,Q)
6396: {
6397: if(type(LL[0]) < 4)
6398: LL = [LL];
6399: for(L0=L1=[],LT=LL;LT!=[];LT=cdr(LT)){
6400: W=vweyl(car(LT));
6401: L0=cons(W,L0);
6402: D=mydiff(F,W[0]);
6403: if(D!=0) L1=cons(W[1]+Q*D/F,L1);
6404: else L1=cons(W[1],L1);
6405: }
6406: return rede(transpdosub(P,L0,L1),L0);
6407: }
6408:
6409: def applpdo(P,F,LL)
6410: {
6411: if(type(F)>3)
6412: #ifdef USEMODULE
6413: return mmulbys(os_md.applpdo,P,F,[LL]);
6414: #else
6415: return mmulbys(applpdo,P,F,[LL]);
6416: #endif
6417: L = vweyl(LL[0]);
6418: LL = cdr(LL);
6419: Deg = deg(P,L[1]);
6420: S = F;
6421: for(I = R = 0; I <= Deg ; I++){
6422: if(I > 0)
6423: S = mydiff(S,L[0]);
6424: if(LL == [])
6425: R = radd(R,mycoef(P,I,L[1])*S);
6426: else
6427: R = radd(R,applpdo(mycoef(P,I,L[1]), S, LL));
6428: }
6429: return R;
6430: }
6431:
6432: def tranlpdo(P,L,M)
6433: {
6434: N = length(L);
6435: R = size(M);
6436: if(R[0] != N || R[1] != N){
6437: print("Strange size");
6438: return;
6439: }
6440: InvM = M;
6441: if(InvM[1] == 0){
6442: print("Not invertible");
6443: return;
6444: }
6445: XL = newvector(N);
6446: DL = newvector(N);
6447: for(I = 0; I < 0; I++){
6448: R = vweyl(L[I]);
6449: XL[I] = R[0];
6450: DL[I] = R[1];
6451: }
6452: for(I = 0; I < N; I++){
6453: for(J = XX = D0 = 0; J < N; J++){
6454: XX = radd(XX,M[I][J]*XL[J]);
6455: DD = radd(DD, red(InvM[0][I][J]/InvM[1])*DL[J]);
6456: P = mysubst(P,[[XL[I],XX],[DL[I],DD]]);
6457: }
6458: }
6459: return P;
6460: }
6461:
6462: def divdo(P,Q,L)
6463: {
6464: if(L==0){
6465: R=P-idiv(P,Q)*Q;
6466: if(R<0){
6467: if(Q>0) R+=Q;
6468: else R-=Q;
6469: }
6470: return [(P-R)/Q,R,1];
6471: }
6472: L = vweyl(L);
6473: if(getopt(rev)==1){
6474: R=divdo(adj(P,L),adj(Q,L),L);
6475: return [adj(R[0],L),adj(R[1],L),R[2]];
6476: }
6477: X = L[0]; DX = L[1];
6478: S = 0;
6479: M = 1;
6480: I = mydeg(Q,DX);
6481: CQ = mycoef(Q,I,DX);
6482: while((J=mydeg(P,DX)) >= I){
6483: C = mycoef(P,J,DX);
6484: SR = red(C/CQ);
6485: if(dn(SR) != 1){
6486: M *= dn(SR);
6487: P *= dn(SR);
6488: S *= dn(SR);
6489: SR = nm(SR);
6490: }
6491: P -= muldo(SR*(DX)^(J-I),Q,L);
6492: S += SR*(DX)^(J-I);
1.70 takayama 6493: }
1.6 takayama 6494: return [S,P,M];
6495: }
6496:
6497: def qdo(P,Q,L)
6498: {
6499: L = vweyl(L); DX = L[1]; OD = deg(P,DX);
6500: V = newvect(OD+1);
6501: for(I = 0; I <= OD; I++){
6502: if(I)
6503: Q = muldo(DX,Q,L);
6504: S = divdo(Q,P,L);
6505: V[I] = S[1]*DX-S[2]*zz^I;
6506: }
6507: for(K = [], I = OD; I >= 0; I--)
6508: K = cons(DX^(I+1), K);
6509: R = lsol(V,K);
6510: S = length(R);
6511: for(I = P1 = 0; I < S; I++){
6512: if(type(R[I]) < 4 && mydeg(R[I],DX) == 0 && R[I] != 0
6513: && (mydeg(R[I],zz) <= mydeg(P,DX)))
6514: P1 = R[I];
6515: else if(type(R[I]) == 4 && R[I][0] == DX)
6516: P2 = R[I][1];
6517: }
6518: T=fctr(P1);
6519: for(I=0, S=length(T), P1=1; I<S; I++){
6520: if(mydeg(T[I][0],zz) > 0)
6521: P1 *= T[I][0]^(T[I][1]);
6522: }
6523: return subst([P1,P2],zz,DX);
6524: }
6525:
6526: def sqrtdo(P,L)
6527: {
6528: L = vweyl(L);
6529: P = toeul(P,L,0);
6530: V = -1;
6531: for(R = 0, Ord = mydeg(P,L[1]); Ord >= 0; Ord--){
6532: Q = coef(P,Ord,L[1]);
6533: M = mydeg(Q,L[0]);
6534: N = mymindeg(Q,L[0]);
6535: if(V < 0)
6536: V = M+N;
6537: else if(V != M+N){
6538: print("Cannot be transformed!");
6539: return;
6540: }
6541: Q = tohomog(red(Q/L[0]^N), [L[0]], z_z);
6542: if(irem(Ord,2))
6543: B = x-z_z;
6544: else
6545: B = x+z_z;
6546: Q = substblock(Q,x,B,z_zz);
6547: if(mydeg(Q,x) > 0){
6548: print("Cannot be transformed!");
6549: return;
6550: }
6551: R += mysubst(Q,[z_zz,x])*L[1]^Ord;
6552: }
6553: return fromeul(R,L,0);
6554: }
6555:
6556: def ghg(A,B)
6557: {
6558: R = dx;
6559: while(length(B)>0){
6560: R = muldo(x*dx+car(B),R,[x,dx]);
6561: B = cdr(B);
6562: }
6563: T = 1;
6564: while(length(A)>0){
6565: T = muldo(x*dx+car(A),T,[x,dx]);
6566: A = cdr(A);
6567: }
6568: return R-T;
6569: }
6570:
6571: def ev4s(A,B,C,S,T)
6572: {
6573: R4 = x^2*(x-1)^2;
6574: R3 = x*(x-1)*((2*A-2*B-8)*x-2*A+5);
6575: R2 = (-3/2*(A^2+B^2)+3*A*B+9*A-9*B-29/2+1/4*(S^2+T^2))*x^2
6576: +(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
6577: - (2*A+2*C-5)*(2*A-2*C-3)/4;
6578: 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
6579: +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
6580: #if 1
6581: + A^2*B
6582: #endif
6583: - B*C^2 - A^3/2+(2*A-3)*(S^2+T^2)/8;
6584: /* OK? for the above term added */
6585: R0 = -(A-B-1-S)*(A-B-1+S)*(A-B-1-T)*(A-B-1+T)/16;
6586: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
6587: }
6588:
6589: def b2e(A,B,C,S,T)
6590: {
6591: R4 = x^2*(x-1)^2;
6592: R3 = x*(x-1)*(2*x-1)*(2*c-5);
6593: R2 = (-6*C^2+24*C-25+1/2*S^2+1/2*T^2)*x^2
6594: +(6*C^2-24*C+25-1/2*S^2-1/2*T^2-A^2+B^2+A-B)*x
6595: +A^2-C^2-A+4*C-15/4;
6596: R1 = (2*C-3)*(2*C^2-6*C+5-1/2*S^2-1/2*T^2)*x
6597: +(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);
6598: R0 = -(2-2*C+S+T)*(2-2*C-S-T)*(2-2*C+S-T)*(2-2*C-S+T)/16;
6599: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
6600: }
6601:
6602:
6603: /*
6604: T^m = T(T-1)....(T-m+1)
6605: f(t) -> g(t)
6606:
6607: f(t) = a_mt^m + ... + a_1t+a_0
6608: g(x*dx) = a_m*x^m*dx^m + ... + a_1*x*dx+a_0
6609:
6610: ret: x(x-1)...(x-i+1)
6611: */
6612: def sftpow(X,I)
6613: {
6614: R = 1;
6615: for(J=0;J<I;J++)
6616: R *= X-J;
6617: return(R);
6618: }
6619:
6620: /*
6621: ret: x(x+K)(x+2*k)...(x+(i-1)*k)
6622: */
6623: def sftpowext(X,I,K)
6624: {
6625: R = 1;
6626: for(J=0;J<I;J++)
6627: R *= X+K*J;
6628: return(R);
6629: }
6630:
6631: def polinsft(F,A)
6632: {
6633: R = 0;
6634: while(F != 0){
6635: D = mydeg(F,A);
6636: C = mycoef(F,D,A);
6637: R += C*A^D;
6638: F -= C*sftpow(A,D);
6639: }
6640: return R;
6641: }
6642:
6643: def pol2sft(F,A)
6644: {
6645: S=getopt(sft);
6646: if(type(S)<0 || type(S)>2) S=1;
6647: R = 0;
6648: for(I = mydeg(F,A); I >= 0; I--)
6649: R = R*(A-I*S) + mycoef(F,I,A);
6650: return R;
6651: }
6652:
6653: def binom(P,N)
6654: {
1.20 takayama 6655: if(type(N)!=1 || N<=0) return 1;
1.6 takayama 6656: for(S=1;N>0;N--,P-=1) S*=P/N;
6657: return red(S);
6658: }
6659:
6660: def expower(P,R,N)
6661: {
6662: if(type(N)!=1 || N<0) return 0;
6663: for(S=S0=K=1;K<=N;K++,R-=1){
6664: S0*=P*R/K;S+=S0;
6665: }
6666: return red(S);
6667: }
6668:
6669: def seriesHG(A,B,X,N)
6670: {
1.20 takayama 6671: if(N==0) return 1;
1.6 takayama 6672: if(type(N)!=1 || N<0) return 0;
6673: if(type(X)<4){
6674: for(K=0,S=S0=1;K<N;K++){
6675: for(T=A; T!=[]; T=cdr(T)) S0*=car(T)+K;
6676: for(T=B; T!=[]; T=cdr(T)) S0/=car(T)+K;
6677: S0=red(S0*X/(K+1));
6678: DN=dn(S0);
6679: S=red((red(S*DN)+nm(S0))/DN);
6680: }
6681: return S;
6682: }
6683: S=0;
6684: for(K=0;K<=N;K++){
6685: for(I=0;I<=N-K;I++){
6686: C=1/sftpowext(1,I,1)/sftpowext(1,J,1);
6687: for(T=A[0];T!=[];T=cdr(T)) C*=sftpowext(car(T),I+K,1);
6688: for(T=A[1];T!=[];T=cdr(T)) C*=sftpowext(car(T),I,1);
6689: for(T=A[2];T!=[];T=cdr(T)) C*=sftpowext(car(T),K,1);
6690: for(T=B[0];T!=[];T=cdr(T)) C/=sftpowext(car(T),I+K,1);
6691: for(T=B[1];T!=[];T=cdr(T)) C/=sftpowext(car(T),I,1);
6692: for(T=B[2];T!=[];T=cdr(T)) C/=sftpowext(car(T),K,1);
6693: S+=red(C*X[0]^I*X[1]^K);
6694: }
6695: }
6696: return S;
6697: }
6698:
6699: def evalred(F)
6700: {
6701: Opt=getopt(opt);
6702: if(type(Opt)!=4){
6703: Opt=[];
6704: }else if(length(Opt)==2 && type(Opt[0])!=4) Opt=[Opt];
6705: for(;;){
1.17 takayama 6706: G=mysubst(F,[[tan(0),0],[asin(0),0],[atan(0),0],[sinh(0),0],[tanh(0),0],
6707: [log(1),0],[cosh(0),1],[exp(0),1]]);
1.6 takayama 6708: for(Rep=Opt; Rep!=[]; Rep=cdr(Rep))
6709: G=subst(G,car(Rep)[0],car(Rep)[1]);
6710: Var=vars(G);
6711: for(V=Var; V!=[]; V=cdr(V)){
1.17 takayama 6712: if(!(VV=args(CV=car(V)))) continue;
6713: if((functor(CV)==sin||functor(CV)==cos)){
6714: P=2*red(VV[0]/@pi);
6715: if(functor(CV)==sin) P=1-P;
6716: if(isint(P)){
6717: if(iand(P,1)) G=subst(G,CV,0);
6718: else if(!iand(P,3)) G=subst(G,CV,1);
6719: else G=subst(G,CV,-1);
6720: continue;
6721: }
6722: if(isint(P*=3/2)){
6723: if(iand(P,3)==1) G=subst(G,CV,1/2);
6724: else G=subst(G,CV,-1/2);
6725: }
6726: }
6727: for(;VV!=[];VV=cdr(VV))
6728: if(car(VV)!=(TV=evalred(car(VV)))) G=subst(G,car(VV),TV);
6729: if(functor(CV)!=pow || (args(CV)[0])!=1) continue;
6730: G=subst(G,CV,1);
1.6 takayama 6731: }
6732: if(G==F) return F;
6733: F=G;
6734: }
6735: }
6736:
6737: def seriesMc(F,N,V)
6738: {
6739: if(type(V)<4) V=[V];
6740: V=reverse(V);
6741: L=length(V);
6742: if(type(Opt=getopt(evalopt))!=4) Opt=[];
6743: P=newvect(L);
6744: G=newvect(L+1);
6745: G[0]=F;
6746: for(I=0;I<L;I++)
6747: G[I+1]=eval(evalred(subst(G[I],V[I],0)|opt=Opt));
6748: R=G[L];
6749: for(;;){
6750: for(M=0,I=0;I<L;I++){
6751: M+=P[I];
6752: if(M==N) break;
6753: }
6754: if(M<N){
6755: P[L-1]++;
6756: G[L-1]=mydiff(G[L-1],V[L-1]);
6757: G[L]=eval(evalred(mysubst(G[L-1],[V[L-1],0])|opt=Opt));
6758: }else{
6759: if(I--==0) break;
6760: P[I]++;
6761: G[I]=mydiff(G[I],V[I]);
6762: while(I++<L){
6763: G[I]=eval(evalred(mysubst(G[I-1],[V[I-1],0])|opt=Opt));
6764: if(I<L) P[I]=0;
6765: }
6766: }
6767: K=1;
6768: for(I=0;I<L;I++) K*=V[I]^P[I]/fac(P[I]);
6769: R+=G[L]*K;
6770: }
6771: return R;
6772: }
6773:
6774: def seriesTaylor(F,N,V)
6775: {
6776: G=F;
6777: if(isvar(V)) V=[V];
6778: if(length(V)==2 && type(car(V))!=4 && !isvar(V[1])) V=[V];
6779: for(V0=V1=[];V!=[];V=cdr(V)){
6780: if(type(T=car(V))!=4) T=[T];
6781: V0=cons(X=car(T),V0);
6782: if(length(T)==1 || T[1]==0){
6783: V1=cons(X,V1);continue;
6784: }
6785: S=my_tex_form(-T[1]);
6786: if(str_char(S,0,"-")!=0) S="+"+S;
6787: S="("+my_tex_form(X)+S+")";
6788: V1=cons([X,S],V1);
6789: F=red(subst(F,T[0],T[0]+T[1]));
6790: }
6791: V0=reverse(V0);V1=reverse(V1);
6792: F=seriesMc(F,N,V0|option_list=getopt());
6793: if(getopt(frac)==0) F=frac2n(F);
6794: T=getopt(dviout);
6795: if(type(T)!=1) T=0;
6796: F=fctrtos(F|var=V1,rev=1,TeX=(T==0||T==2)?2:3);
6797: if(getopt(small)==1) F=str_subst(F,"\\frac{","\\tfrac{");
6798: if(T<0 || T==1) F="\\begin{align}\\begin{split}\n"+
6799: my_tex_form(G)+"&="+F+"+\\cdots\n\\end{split}\\end{align}\n";
6800: if(T==1) dviout(F);
6801: else if(T==1) dviout(F|eq=4);
6802: return F;
6803: }
6804:
1.27 takayama 6805: def mulpolyMod(P,Q,X,N)
6806: {
6807: Red=(type(P)>2||type(Q)>2)?1:0;
6808: for(I=R=0;I<=N;I++){
6809: P0=mycoef(P,I,X);
6810: for(J=0;J<=N-I;J++){
6811: R+=P0*mycoef(Q,J,X)*X^(I+J);
6812: if(Red) R=red(R);
6813: }
6814: }
6815: return R;
6816: }
6817:
1.46 takayama 6818: def solveEq(L,V)
6819: {
6820: Inv=0;K=length(V);
6821: H=(getopt(h)==1)?1:0;
6822: if(getopt(inv)==1){
6823: if(K!=length(L)) return -5;
6824: Inv=1;
6825: VN=makenewv(vars(L)|num=K);
6826: for(TL=[],I=K-1;I>=0;I--) TL=cons(VN[I]-L[I],TL);
6827: S=solveEq(TL,V|h=H);
6828: if(type(S)!=4) return S;
6829: return mysubst(S,[VN,V]|lpair=1);
6830: }
6831: for(TL=[];L!=[];L=cdr(L)) TL=cons(nm(red(car(L))),TL);
6832: S=gr(TL,reverse(V),2);
6833: if(length(S)!=K) return -1;
6834: for(R=[],I=F=0;I<K;I++){
6835: TS=S[I];
6836: VI=lsort(vars(TS),V,2);
6837: if(length(VI)!=1) return -2;
6838: if((VI=car(VI))!=V[I]) return -3;
6839: if(mydeg(TS,VI)!=1){
6840: F=1;R=cons([VI,TS],R);
6841: }else R=cons(-red(mycoef(TS,0,VI)/mycoef(TS,1,VI)),R);
6842: }
6843: R=reverse(R);
6844: if(!F||H==1) return R;
6845: return -4;
6846: }
6847:
1.45 takayama 6848: /* Opt: f, var, ord, to, in, TeX */
6849: def baseODE(L)
6850: {
1.47 takayama 6851: SV=SVORG;
1.45 takayama 6852: if(type(TeX=getopt(TeX))!=1) TeX=0;
6853: if(type(F=getopt(f))!=1) F=0;
1.46 takayama 6854: if(isint(In=getopt(in))!=1) In=0;
1.45 takayama 6855: if(type(Ord=getopt(ord))!=1&&Ord!=0) Ord=2;
1.70 takayama 6856: Pages=getopt(pages);
6857: if(Pages!=1&&Pages!=2) Pages=0;
1.45 takayama 6858: if(Ord>3){
6859: Ord-=4; Hgr=1;
1.47 takayama 6860: }else Hgr=0;
1.70 takayama 6861: if(type(car(L0=L))==4&&type(L[1])==7){
1.45 takayama 6862: Tt=L[1];L=car(L);
6863: }
1.47 takayama 6864: M=N=length(L); SV=SVORG;
6865: if(type(Var=getopt(var))==4&&(In>0||length(Var)==N)){
1.45 takayama 6866: SV=Var;
6867: M=length(SV);
6868: if(type(car(SV))==2){
6869: for(R=[];SV!=[];SV=cdr(SV)) R=cons(rtostr(car(SV)),R);
6870: SV=reverse(R);
6871: }
1.47 takayama 6872: }else{
6873: if(N>10){
6874: R=[];
6875: for(K=M-1;K>9;K++) R=cons(SV[floor(K/10)-1]+SV[K%10],R);
6876: SV=append(SV,R);
6877: }
6878: for(Var=[],I=M-1;I>=0;I--) Var=cons(makev([SV[I]]),Var);
6879: }
6880: if(type(To=getopt(to))<2||type(To)>4) To=0;
1.70 takayama 6881: if(Ord<0){ /* cancell y1, z1,... by baseODE0() */
1.73 takayama 6882: if(Ord==-1) Ord=2;
6883: if(type(To)==4||!isvar(To)){
6884: L=L0=baseODE(L0|to=To,f=-3)[1];
6885: To=0;
6886: }
1.70 takayama 6887: R=baseODE0(L|option_list=
6888: delopt(getopt(),[["var",Var],["ord",Ord]]|inv=1));
6889: if(TeX){
6890: if(type(R)==4&&length(R)>1&&type(R[1])==4) R=R[1];
1.73 takayama 6891: if(type(To)==2 && !isvar(To)){
6892: S0=baseODE(L0|TeX=1,f=-1,to=To);
6893: V=baseODE0(L|step=-1,to=To);
6894: }else{
6895: S0=baseODE(L0|TeX=1,f=-1);
6896: V=baseODE0(L|step=-1,to=To);
6897: }
1.70 takayama 6898: T=eqs2tex(R,[V,2,Pages]);
6899: S=((F==1)?(Tt+"\n"):S0)+texbegin("align*",T);
6900: if(TeX==2) dviout(S);
6901: return S;
6902: }
6903: return R;
6904: }
6905: if(To&&!isvar(To)){
1.49 takayama 6906: if(type(To)!=4){
6907: To=red(To);
6908: for(K=0;K<length(Var);K++){
6909: I=mydeg(nm(To),Var[K]);J=mydeg(dn(To),Var[K]);
6910: if(I+J>0&&I<2&&J<2) break;
6911: }
6912: if(K==length(Var)) return -9;
6913: J=To;
6914: for(To=[],I=length(Var)-1;I>=0;I--)
6915: if(I!=K) To=cons(Var[I],To);
6916: To=cons(J,To);
6917: }
1.47 takayama 6918: if(type(To)==4){
6919: if(type(car(To))==4){
6920: R=1;To=car(To);
6921: }else R=0;
1.48 takayama 6922: if(type(IL=solveEq(To,Var|inv=1))!=4) return IL;
1.47 takayama 6923: if(R==1){
6924: R=To;To=IL;IL=R;
6925: }
6926: L=mulsubst(L,[Var,IL]|lpair=1);
6927: if(!In){ /* X_i'=\sum_j(\p_{x_j}X_i)*x_j' */
6928: for(TL=[],I=M-1;I>=0;I--){
6929: P=To[I];Q=mydiff(P,t);
6930: for(J=0;J<M;J++) Q=red(Q+mydiff(P,Var[J])*L[J]);
6931: TL=cons(Q,TL);
6932: }
6933: L=TL;
6934: }else{ /* x_i'=\sum_j(\p_{X_j}x_i)*X_j' */
6935: for(I=M-1;I>=0;I--){
6936: P=IL[I];Q=mydiff(P,t);
6937: for(J=0;J<M;J++){
6938: V=makev([SV[J],1]);
6939: Q=red(Q+mydiff(P,V)*V);
6940: }
6941: L=mysubst(L,[makev([SV[I],1]),TL[I]]);
6942: }
6943: for(TL=L,L=[],I=M-1;I>=0;I--) L=cons(num(TL[I]),L);
6944: }
6945: }
1.45 takayama 6946: }
1.73 takayama 6947: if(F==-3&&!TeX) return [Var,L];
1.48 takayama 6948: for(I=0;I<M;I++) L=subst(L,Var[I],makev([SV[I],0]));
1.45 takayama 6949: if(TeX){
6950: for(TL=L,I=0;I<M;I++)
1.47 takayama 6951: TL=subst(TL,makev([SV[I],0]),Var[I]);
1.45 takayama 6952: for(I=0;I<N;I++){
6953: if(I) S0+=",\\\\\n";
6954: if(In) S0+=" "+my_tex_form(TL[I])+"=0";
6955: else S0+=" "+SV[I]+"'\\!\\!\\! &= "+my_tex_form(TL[I]);
6956: }
6957: S0+=".\n";
6958: S0=texbegin("cases", S0);
6959: S0=texbegin("align",S0);
6960: if(type(Tt)==7) S0=Tt+"\n"+S0;
1.47 takayama 6961: if(F<0){
1.70 takayama 6962: if(TeX==2)dviout(S0);
1.45 takayama 6963: return S0;
6964: }
6965: }
1.47 takayama 6966: for(I=0,TL=[];L!=[];L=cdr(L),I++){
6967: T=car(L);
6968: if(!In) T=makev([SV[I],1])-T;
6969: TL=cons(nm(red(T)),TL);
1.45 takayama 6970: }
1.47 takayama 6971: if(isvar(To)){
1.48 takayama 6972: T=rtostr(To);
1.45 takayama 6973: IT=findin(T,SV);
6974: if(IT>=0 && IT<M){
6975: R=[SV[IT]];
6976: for(J=0;SV!=[];SV=cdr(SV),J++){
6977: if(J==IT) continue;
6978: R=cons(car(SV),R);
6979: }
6980: SV=reverse(R);
6981: }else{
6982: IT=0;
6983: mycat(["Cannot find variable", T, "!\n"]);
6984: }
6985: }
6986: for(S=1;S<M;S++){
6987: L=append(TL,L);
6988: TL=reverse(TL);
6989: for(RL=[];TL!=[];TL=cdr(TL)){
6990: if(In==0&&S==N-1&&length(TL)!=N-IT) continue;
1.47 takayama 6991: T=car(TL);R=mydiff(V,t);
1.45 takayama 6992: for(I=0;I<M;I++){
6993: for(J=0;J<=S;J++){
6994: V=makev([SV[I],J]|num=1);
1.47 takayama 6995: if((DR=mydiff(T,V))!=0) R+=DR*makev([SV[I],J+1]|num=1);
1.45 takayama 6996: }
6997: }
6998: RL=cons(R,RL);
6999: }
7000: TL=RL;
7001: }
7002: L=append(TL,L);
1.48 takayama 7003: for(I=0;I<M;I++) L=subst(L,makev([SV[I],0]),Var[I]);
1.70 takayama 7004: if(!isint(Vl=getopt(vl))) Vl=0;
7005: if(!Vl||Vl==1){
7006: V=[makev([SV[0]])];
7007: for(VV=[],J=1;J<=M;J++)
7008: V=cons(makev([SV[0],J]),V);
7009: for(I=1;I<M;I++)
7010: V=cons(makev([SV[I]]),V);
1.45 takayama 7011: if(F==-2){
7012: VV=cons(V,VV);
7013: V=[];
7014: }
1.70 takayama 7015: for(I=1;I<M;I++){
7016: for(J=1;J<M;J++) V=cons(makev((!Vl)?[SV[I],J]:[SV[J],I]),V);
7017: if(In) V=cons(makev([SV[0],M]),V);
7018: if(F==-2){
7019: VV=cons(V,VV);
7020: V=[];
7021: }
7022: }
7023: }else{
7024: for(V=VV=[],I=0;I<M;I++){
7025: for(J=0;J<M;J++) V=cons(J?makev([SV[I],J]):makev([SV[I]]),V);
7026: if(!I||In) V=cons(makev([SV[0],M]),V);
7027: if(F==-2){
7028: VV=cons(V,VV);
7029: V=[];
7030: }
7031: }
1.45 takayama 7032: }
7033: if(F>=0&&!chkfun("gr",0)){
7034: mycat("load(\"gr\"); /* <- do! */\n");
7035: F=-1;
7036: }
7037: if(F==-2) return [VV,L];
7038: if(F<0) return [V,L];
1.70 takayama 7039: LL=(Hgr==1)?hgr(L,V,Ord):gr(L,V,Ord);
1.45 takayama 7040: if(F==2) return [V,L,LL];
7041: if(Ord==2) P=LL[0];
7042: else{
7043: P=LL[length(LL)-1];
7044: for(RV=reverse(V), I=0;I<M+1;I++) RV=cdr(RV);
7045: if(lsort(vars(P),RV,2)!=[]){
7046: LL=tolex_tl(LL,V,Ord,V,2);P=LL[0];
7047: }
7048: }
7049: if(TeX){
1.70 takayama 7050: for(V0=[],I=1;I<=M;I++) V0=cons(makev([car(SV),I]),V0);
7051: T=eqs2tex(P,[V0,2,Pages]);
7052: if(!Vl||Vl==1){
7053: for(I=1,K=0;I<length(LL);I++){
7054: TV=makev([SV[I-K]]);
7055: if(findin(TV,vars(LL[I]))<0){
7056: K++;continue;
7057: }
7058: T+=eqs2tex(LL[I],[cons(TV,V0),2,Pages,1]);
7059: }
7060: }
7061: S=((F==1)?(Tt+"\n"):S0)+texbegin("align*",T);
1.45 takayama 7062: if(TeX==2) dviout(S);
7063: return S;
7064: }
7065: return (F==1)? P:[P,V,L,LL];
7066: }
7067:
1.70 takayama 7068:
7069: def eqs2tex(P,L)
7070: {
7071: if(isvar(L)) L=[0,L];
7072: if(type(L)!=4) L=[];
7073: Sgn=0;
7074: if(L!=[]){
1.71 takayama 7075: if(car(L)==0) L=[L];
7076: else if(length(L)>1 && isvar(L[1])) L=[L];
1.70 takayama 7077: R=car(L);L=cdr(L);Sgn=1;
7078: }else R=[];
7079: if(type(R)==4&&car(R)==0){
7080: Sgn=0;R=cdr(R);
7081: }
7082: if(L!=[]){
7083: Dic=car(L);L=cdr(L);
7084: }
7085: if(L!=[]){
7086: Pages=car(L);L=cdr(L);
7087: }
7088: if(L!=[]) Cont=car(L);
7089: if(type(P)==4){
7090: for(S="";P!=[];P=cdr(P)){
7091: S+=eqs2tex(car(P),[R,Dic,Pages,Cont]);
7092: if(!Cont) Cont=1;
7093: }
1.73 takayama 7094: /* S=str_subst(S,"\\\\&,\\\\",",\\\\&"); */
1.70 takayama 7095: if(getopt(dviout)==1) dviout(S|eq=6);
7096: return S;
7097: }
7098: if(type(R)==2) R=[R];
7099: if(Sgn){
7100: for(;R!=[];R=cdr(R))
7101: if((Deg=mydeg(P,car(R)))>0) break;
7102: if(Deg>0){
7103: CP=mycoef(P,Deg,car(R));
7104: if(cmpsimple(-CP,CP)<0) P=-P;
7105: }
7106: }
7107: S="&\\!\\!\\!";
7108: if(Cont)
7109: S=(Pages?",\\allowdisplaybreaks":",")+"\\\\\n"+S;
7110: S+=fctrtos(P|var=R,dic=Dic,TeX=3,pages=Pages);
7111: if(getopt(dviout)==1) dviout(S|eq=6);
7112: return S;
7113: }
7114:
1.71 takayama 7115: /* Opt: var, opt, dbg */
1.70 takayama 7116: def res0(P,Q,X)
7117: {
1.71 takayama 7118: if(!isvar(X)){
7119: if(!isvar(P)) return -1;
7120: Y=P;P=Q;Q=X;X=Y;
7121: }
7122: if(isvar(Var=getopt(var))) Var=[Var];
1.73 takayama 7123: else if(type(Var)!=4) Var=0;
7124: if(type(W=getopt(w))!=4) W=[];
7125: if(!isint(Opt=getopt(opt))&&type(Opt)!=4) Opt=0;
1.72 takayama 7126: if(type(Dbg=getopt(dbg))==4){
7127: Fct=Dbg[1];Dbg=Dbg[0];
7128: }
7129: if(!isint(Dbg)) Dbg=0;
1.70 takayama 7130: P=nm(P);Q=nm(Q);
1.71 takayama 7131: Fctr=isfctr(P)*isfctr(Q);
1.70 takayama 7132: DP=deg(P,X);DQ=deg(Q,X);
1.71 takayama 7133: if(DP==DQ&&nmono(coef(P,DP,X))<nmono(coef(Q,DQ,X))){
7134: R=P;P=Q;Q=R;
7135: R=DP;DP=DQ;DQ=R;
7136: }
1.70 takayama 7137: while(DQ>0){
7138: if(DP<DQ){
7139: R=P;P=Q;Q=R;
7140: R=DP;DP=DQ;DQ=R;
7141: if(Opt==-1) return [P,Q,DP,DQ];
7142: if(DQ<1) break;
7143: }
1.72 takayama 7144: if(Dbg){
7145: if(Dbg>=2) mycat([DP,"(",nmono(P), nmono(coef(P,DP,X)),") :",
7146: DQ, "(",nmono(Q),nmono(coef(Q,DQ,X)), ")"]);
7147: else mycat0([DP,":",DQ,","],0);
7148: }
1.70 takayama 7149: TQ=coef(Q,DQ,X);TP=coef(P,DP,X);
1.71 takayama 7150: if(Fctr){
7151: T=gcd(TP,TQ);M=red(TQ/T);
7152: if(Var&&M!=car(W)&&type(TV=vars(M))==4&&lsort(TV,Var,2)!=[]) W=cons(M,W);
7153: P=M*(P-coef(P,DP,X)*X^DP)-red(TP/T)*X^(DP-DQ)*(Q-coef(Q,DQ,X)*X^DQ);
7154: if(Var){
1.72 takayama 7155: #if 1
7156: if(Dbg>2) mycat0(">",0);
7157: for(S=SS=fctr(P),P=1,C=0;S!=[];S=cdr(S)){
1.71 takayama 7158: TV=vars(S0=car(S)[0]);
7159: if(type(TV)==4&&lsort(TV,Var,2)!=[]){
1.72 takayama 7160: for(TW=W;TW!=[];TW=cdr(TW)){
1.71 takayama 7161: if(gcd(car(TW),S0)!=1){
7162: S0=1;break;
7163: }
1.72 takayama 7164: }
7165: if(Dbg>1){
7166: if(S0==1) mycat(["Reduced by :",nmono(car(TW))]);
7167: else if(C++>0){
7168: mycat(["Product :", nmono(P), nmono(S0)]);
7169: if(Dbg==3){
7170: if(!Fct||Fct==[]){
1.73 takayama 7171: if(C>1) P=1;
1.72 takayama 7172: }else{
7173: if(car(Fct)==C){
7174: C=10000;Fct=cdr(Fct);P=1;
7175: }else S0=1;
7176: }
7177: }else if(Dbg==4) return [SS,Q,DP,DQ,W];
7178: }
7179: }
1.71 takayama 7180: P*=S0;
7181: }
7182: }
1.72 takayama 7183: #else
7184: for(TW=W;TW!=[];TW=cdr(TW)){
7185: if((C=gcd(P,car(TW)))!=1){
7186: P=red(P/C);
7187: if(Dbg>=2&&nmono(Q)>1) mycat(["Reduce :",nmono(C)]);
7188: }
7189: }
7190: #endif
1.70 takayama 7191: }
1.71 takayama 7192: }else{
7193: if(type(TQ)==1){
7194: Q/=TQ;
7195: P=P-TP*X^(DP-DQ)*Q;
7196: }else P=TQ*P-TP*X^(DP-DQ);
7197: if(deg(P,X)==DP) P-=coef(P,DP,X)*X^DP;
1.70 takayama 7198: }
7199: DP=deg(P,X);
1.73 takayama 7200: if(Opt==-2||(type(Opt)==4&&Opt[0]==DP&&Opt[1]==DQ)) return [P,Q,DP,DQ,W];
1.72 takayama 7201: }
7202: if(Dbg){
7203: if(Dbg>1) mycat([DP,"(",nmono(P), nmono(coef(P,DP,X)),") :",
7204: DQ, "(",nmono(Q), nmono(coef(Q,DQ,X)), ")"]);
7205: else mycat0([DP,":",DQ," "],0);
1.70 takayama 7206: }
1.73 takayama 7207: if(Opt==1) Q=[P,Q,DP,DQ,W];
1.70 takayama 7208: return (DQ==0)?Q:0;
7209: }
7210:
1.72 takayama 7211: /* Opt : f, var, ord, ord, step, f, to */
1.70 takayama 7212: def baseODE0(L)
7213: {
1.73 takayama 7214: if(!isint(Ord=getopt(ord))) Ord=-1;
7215: if(Ord==-1) Ord=2;
7216: if(Ord<O) Ord++;
1.70 takayama 7217: if(!isint(F=getopt(f))) F=0;
1.73 takayama 7218: if(!isint(Dbg=getopt(dbg))) Dbg=0;
7219: if(type(Step=getopt(step))==4) Dstep=Step;
7220: else Dstep=0;
7221: if(!isint(Step)) Step=0;
1.70 takayama 7222: if(F<0) Step=1;
7223: if(Step>0&&Ord>0) Ord=-1;
7224: N=length(L);
7225: if(type(To=getopt(to))==4&&length(To)==N){
7226: V=cdr(To);To=car(To);
7227: }
1.72 takayama 7228: if(!isvar(To)) To=V=0;
1.70 takayama 7229: if(type(SV=Var=getopt(var))!=4){
7230: SV=SVORG;
7231: if(N>10){
7232: R=[];
7233: for(K=N-1;K>9;K++) R=cons(SV[floor(K/10)-1]+SV[K%10],R);
7234: SV=append(SV,R);
7235: }
7236: for(Var=[],I=N-1;I>=0;I--) Var=cons(makev([SV[I]]),Var);
7237: }
7238: if((J=findin(To,Var))>0){
7239: TV=TL=[];
7240: for(I=N-1;I>=0;I--){
7241: if(I!=J){
7242: TV=cons(Var[I],TV);TL=cons(L[I],TL);
7243: }
7244: }
7245: Var=cons(Var[J],TV);L=cons(L[J],TL);
7246: }
7247: if(!To) To=car(SV);
7248: Q=car(L);
7249: V0=makev([To,1]);
7250: R=[V0-Q];V0=[V0];
7251: for(I=2;I<=N;I++){
7252: P=diff(t,Q);
7253: if(type(P)==3) P=red(P);
7254: for(TV=Var,TL=L;TV!=[];TV=cdr(TV),TL=cdr(TL)){
7255: P+=diff(Q,car(TV))*car(TL);
7256: if(type(P)==3) P=red(P);
7257: }
7258: Q=P;
7259: TV=makev([To,I]);
7260: R=cons(nm(TV-Q),R);
7261: V0=cons(TV,V0);
7262: }
7263: if(Step==-1) return V0;
7264: if(!V) V=cdr(Var);
7265: if(Ord<0){
7266: for(C=1,R0=[];V!=[];V=cdr(V),C++){
7267: TR=R=reverse(R);
7268: if(length(R)>1){ /* reduce common factor */
7269: P=car(TR);TR=cdr(TR);
1.72 takayama 7270: for(;TR!=[]&&P!=1;TR=cdr(TR))
1.70 takayama 7271: P=gcd(P,car(TR));
7272: if(P!=1){
7273: for(TR=[];R!=[];R=cdr(R)) TR=cons(red(car(R)/P),TR);
7274: R=reverse(TR);
7275: }
7276: }
7277: TR=[];
7278: TV=car(V);
7279: if(length(V)==1) V0=[car(V0)];
7280: if(C==Step) return [append(V,V0),R];
7281: while(R!=[]&&findin(TV,vars(car(R)))<0){
7282: TR=cons(car(R),TR);
7283: R=cdr(R);
7284: }
1.72 takayama 7285: R0=(F==2)?append(R,R0):cons(car(R),R0);
1.70 takayama 7286: if(R!=[]){
1.73 takayama 7287: for(W=[],P=car(R),R=cdr(R); R!=[]; R=cdr(R)){
1.72 takayama 7288: if(Dbg) mycat0(["\nStep ",C,"-",length(R)," ",TV,
7289: (type(Dbg)==4||Dbg>=2)?"\n":" "],0);
1.70 takayama 7290: if(findin(TV,vars(car(R)))<0){
7291: TR=cons(car(R),TR);
7292: continue;
7293: }
7294: if(Ord>-3){
1.73 takayama 7295: if(Dstep&&Dstep[0]==C&&Dstep[1]==length(R))
7296: return res0(P,car(R),TV|var=V0,opt=cdr(cdr(Dstep)),dbg=Dbg);
7297: else TQ=res0(P,car(R),TV|var=V0,opt=1,dbg=Dbg,w=W);
1.72 takayama 7298: if(Dbg==4&&type(car(TQ))==4) return TQ;
1.70 takayama 7299: if(Ord==-2) P=car(TQ);
1.73 takayama 7300: W=TQ[4];TQ=TQ[1];
1.72 takayama 7301: }else{
7302: TQ=res(TV,P,car(R));
7303: Q=fctr(TQ); /* irreducible one */
7304: for(TQ=1;Q!=[];Q=cdr(Q))
7305: if(lsort(V0,vars(car(Q)[0]),2)!=[]) TQ*=car(Q)[0];
7306: }
1.70 takayama 7307: TR=cons(TQ,TR);
7308: }
7309: }
7310: R=TR;
7311: }
1.71 takayama 7312: if(Dbg==1) mycat([]);
1.72 takayama 7313: return (F==1)?car(R):(F==2?append(R,R0):cons(car(R),R0));
1.70 takayama 7314: }
7315: V=append(V,[makev([To,N])]);
7316: if(Step==1) return [R,V];
7317: R=gr(R,V,Ord);
7318: return (F==1)?car(R):R; /* hgr(R,V,Ord); */
7319: }
7320:
7321:
1.26 takayama 7322: def taylorODE(D){
7323: Dif=(getopt(dif)==1)?1:0;
7324: if(D==0) return Dif?f:f_00;
1.27 takayama 7325: if(type(T=getopt(runge))!=1||ntype(T)!=0) T=0;
1.26 takayama 7326: if(type(F=getopt(f))!=7&&type(F)<2) F="f_";
7327: if(type(D)!=1||ntype(D)!=0||D<0||D>30) return 0;
7328: if(type(H=getopt(taylor))==4&&length(H)==2){
1.27 takayama 7329: if(type(Lim=getopt(lim))==2) DD=D;
7330: else if(type(Lim)==4){
7331: DD=Lim[1];Lim=Lim[0];
7332: }else Lim=0;
7333: for(R=I=0;I<=D;I++){
7334: if(I){
7335: if(Lim) H0=mulpolyMod(H0,H[0],Lim,DD);
7336: else H0*=H[0];
7337: }else H0=1;
7338: if(type(F)!=7) G=I?mydiff(G,x):F;
7339: for(J=0;J<=D-I;J++){
7340: if(J){
7341: if(Lim) H1=mulpolyMod(H1,H[1],Lim,DD);
7342: else H1*=H[1];
7343: }else H1=H0;
7344: if(type(F)==7) G=makev([F,I,J]);
7345: else if(J) G=mydiff(G,y);
7346: R+=G*H1/fac(I)/fac(J);
1.26 takayama 7347: }
7348: }
1.27 takayama 7349: if(Lim) R=os_md.polcut(R,DD,Lim);
7350: return R;
1.26 takayama 7351: }else{
7352: if(type(H=getopt(series))>=0||getopt(list)==1){
7353: if(type(F)!=7){
7354: for(PP=[F],I=1;I<D;I++)
7355: PP=cons(mydiff(car(PP),x)+mydiff(car(PP),y)*F,PP);
7356: if(type(H)<0) return PP;
7357: for(R=0,DD=D;DD>=1;DD--,PP=cdr(PP)) R+=car(PP)*H^DD/fac(DD);
7358: return red(R);
7359: }
7360: if(type(H)>=0) D--;
7361: PP=taylorODE(D-1|list=1);
7362: if(type(PP)!=4) PP=[PP];
7363: P=car(PP);
7364: }else P=taylorODE(D-1);
7365: for(R=I=0;I<D;I++){
7366: for(J=0;J<D-I;J++){
7367: Q=diff(P,makev([F,I,J]));
7368: if(Q!=0) R+=Q*(f_00*makev([F,I,J+1])+makev([F,I+1,J]));
7369: }
7370: }
7371: if(getopt(list)==1){
7372: R=cons(R,PP);
7373: if(Dif!=1) return R;
7374: }else if(type(H)>=0){
7375: R=y+R*H^(D+1)/fac(D+1);
7376: for(DD=D;DD>0;PP=cdr(PP),DD--) R+=car(PP)*H^(DD)/fac(DD);
7377: if(T){
1.35 takayama 7378: if(T<0){
7379: Dif=0;TT=-T;
7380: }else TT=T;
1.26 takayama 7381: K=newvect(TT);K[0]=Dif?f:f_00;
1.35 takayama 7382: if(getopt(c1)==1) K[0]=taylorODE(D|taylor=[c_1*H,0]);
1.26 takayama 7383: for(I=1;I<TT;I++){
7384: for(S=J=0;J<I;J++) S+=makev(["a_",I+1,J+1])*K[J];
1.35 takayama 7385: K[I]=taylorODE(D|taylor=[makev(["c_",I+1])*H,S*H],lim=[H,D]);
1.26 takayama 7386: }
7387: for(S=I=0;I<TT;I++) S+=makev(["b_",I+1])*K[I];
7388: S=S*H+y;
7389: R=S-R;
7390: if(T<0){
7391: for(V=[H],I=0;I<=D;I++)
7392: for(J=0;J<=D-I;J++) V=cons(makev([F,I,J]),V);
7393: return os_md.ptol(R,reverse(V)|opt=0);
7394: }
7395: }else T=0;
7396: }
7397: }
7398: if(Dif){
7399: for(I=0;I<=D;I++){
7400: for(J=0;J<=D;J++){
7401: if(I==0&&J==0){
7402: R=subst(R,f_00,f);
7403: continue;
7404: }
7405: V=makev([F,str_times("x",I),str_times("y",J)]);
7406: R=subst(R,makev([F,I,J]),V);
7407: }
7408: }
7409: }
7410: return R;
7411: }
7412:
1.6 takayama 7413: def toeul(F,L,V)
7414: {
7415: L = vweyl(L);
7416: X = L[0]; DX = L[1];
7417: I = mydeg(F,DX);
1.56 takayama 7418: if(getopt(raw)!=1){
1.6 takayama 7419: for(II=I; II>=0; II--){
1.56 takayama 7420: J = mydeg(P=mycoef(F,II,DX),X);
1.6 takayama 7421: if(II==I) S=II-J;
7422: else if(P!=0 && II-J>S) S=II-J;
7423: }
7424: F *= X^S;
1.56 takayama 7425: }
7426: if(V == "infty"){
7427: for(R=0; I >= 0; I--)
1.6 takayama 7428: R += red((mysubst(mycoef(F,I,DX),[X,1/X])*(x*DX)^I));
7429: return(subst(pol2sft(R,DX),DX,-DX));
7430: }
1.56 takayama 7431: for(R=0; I >= 0; I--)
1.6 takayama 7432: R += (red(mycoef(F,I,DX)/X^I))*DX^I;
7433: return pol2sft(R,DX);
7434: }
7435:
7436: /*
7437: def topoldif(P,F,L)
7438: {
7439: L = vweyl(L);
7440: P = nm(red(P));
7441: while(deg(P,L[1]) > 0){
7442: R = coef(P,0,L[0]);
7443: Q = red((P-R)/(F*L[0]);
7444: P = nm(Q)*zz+F*R*dn(Q);
7445: }
7446: }
7447: */
7448:
7449: def fromeul(P,L,V)
7450: {
7451: if(P == 0)
7452: return 0;
7453: L = vweyl(L);
7454: X = L[0]; DX = L[1];
7455: I = mydeg(P,DX);
7456: if(V == "infty"){
7457: P = subst(P,DX,-DX);
7458: J = mydeg(P,X);
7459: P = red(mysubst(P,[X,1/X])*X^J);
7460: }
7461: R = mycoef(P,0,DX);
7462: S = 1;
7463: for(S = J = 1; J <= I; J++){
7464: S = DX*(S*X + mydiff(S,DX));
7465: R += mycoef(P,J,DX)*S;
7466: }
1.56 takayama 7467: if(getopt(raw)!=1){
7468: while(mycoef(R,0,X) == 0)
7469: R = tdiv(R,X);
7470: }
1.6 takayama 7471: if(V != "infty" && V != 0)
7472: R = mysubst(R,[X,X-V]);
7473: return R;
7474: }
7475:
7476: def sftexp(P,L,V,N)
7477: {
7478: L = vweyl(L); DX = L[1];
1.56 takayama 7479: P = mysubst(toeul(P,L,V|opt_list=getpt()),[DX,DX+N]);
1.70 takayama 7480: return fromeul(P,L,V|option_list=getopt());
1.6 takayama 7481: }
7482:
7483:
7484: def fractrans(P,L,N0,N1,N2)
7485: {
7486: L = vweyl(L);
7487: if(N2 != "infty"){
7488: if(N0 == "infty")
7489: N0 = 0;
7490: else
7491: N0 = red(1/(N0-N2));
7492: if(N1 == "infty")
7493: N1 = 0;
7494: else
7495: N1 = red(1/(N1-N2));
7496: P = mysubst(P,[L[0],L[0]+N2]);
7497: P = fromeul(toeul(P,L,"infty"),L,0);
7498: }
7499: if(N0 != 0){
7500: P = mysubst(P,[L[0],L[0]+N0]);
7501: N1 -= N0;
7502: }
7503: if(N1 != 1)
7504: P = mysubst(P,[[L[0],L[0]/N1],[L[1],L[1]*N1]]);
7505: return P;
7506: }
7507:
7508: def soldif(P,L,V,Q,N)
7509: {
7510: L = vweyl(L); X = L[0]; DX = L[1];
7511: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
7512: DEG = mydeg(P,X);
7513: P0 = newvect(DEG+1);
7514: for(I = 0; I <= DEG; I++)
7515: P0[I] = coef(P,I,X);
7516: if(P0[0] == 0)
7517: return 0;
7518: if(subst(P0[0],DX,0) != 0){
7519: mycat([Q,"is not the exponent at", V])$
7520: return 0;
7521: }
7522: R = newvect(N+1);
7523: R[0] = 1;
7524: for(I = 1; I <= N; I++){
7525: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7526: S += mysubst(P0[K],[DX,I-K])*R[I-K];
7527: S = red(S);
7528: M = mysubst(P0[0],[DX,I]);
7529: if(M != 0){
7530: R[I] = -red(S/M);
7531: if(R1 != 0){
7532: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7533: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
7534: mysubst(P1[K],[DX,I-K])*R[I-K];
7535: R1[I] = -red(S/M);
7536: }
7537: }else{
7538: if(S == 0){
7539: if(R1 != 0){
7540: for(S = 0, K = 1; K <= DEG && K <= I; K++)
7541: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
7542: mysubst(P1[K],[DX,I-K])*R[I-K];
7543: }
7544: if(S == 0)
7545: continue;
7546: }
7547: R1 = newvect(N+1);
7548: for(K = 0; K < I; K++){
7549: R1[K] = R[K];
7550: R[K] = 0;
7551: }
7552: R1[I] = 0;
7553: P1 = newvect(DEG);
7554: for(K = 0; K <= DEG; K++)
7555: P1[K] = mydiff(P0[K], DX);
7556: M = mysubst(P1[0],[DX,I]);
7557: if(M == 0){
7558: cat(["multiple log at ", I])$
7559: return 0;
7560: }
7561: R[I] = -red(S/M);
7562: }
7563: }
7564: if(R1 != 0)
7565: return [R1, R];
7566: else
7567: return R;
7568: }
7569:
7570: def chkexp(P,L,V,Q,N)
7571: {
7572: L = vweyl(L); X = L[0]; DX = L[1];
7573: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
7574: P = fromeul(P,L,0);
7575: D = mydeg(P,DX);
7576: Z = mindeg(mycoef(P,D,DX), X) - (D-N);
7577: R = [];
7578: for(I = 0; I < Z; I++){
7579: S = mycoef(P,I,X);
7580: if(S != 0){
7581: for(J = mydeg(S,DX); J >= 0; J--){
7582: T = mycoef(S,J,DX);
7583: if(T != 0)
7584: R = cons(T,R);
7585: }
7586: }
7587: }
7588: return R;
7589: }
7590:
7591:
7592: def sqrtrat(P)
7593: {
7594: if(P==0) return 0;
7595: if(type(P)==3||type(P)==2){
7596: P=red(P);
7597: if(imag(dn(P))!=0||imag(nm(P))!=0){
7598: if(imag(dn(P))==0&&real(P)!=0){
7599: F=red(imag(P)/real(P));
7600: if(F==3^(1/2)||F==-3^(1/2)){
7601: if(eval(real(P))<0)
7602: return -real(P)+imag(P)*@i;
7603: else{
7604: if(eval(imag(P))>0) return imag(P)+real(P)*@i;
7605: else return -imag(P)-real(P)*@i;
7606: }
7607: }
7608: }
7609: return [];
7610: }
7611: F=fctr(dn(P));
7612: R=sqrtrat(car(F)[0]);
7613: for(F=cdr(F);F!=[];F=cdr(F)){
7614: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
7615: else return [];
7616: }
7617: F=fctr(nm(P));
7618: R=sqrtrat(car(F)[0])/R;
7619: for(F=cdr(F);F!=[];F=cdr(F)){
7620: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
7621: else return [];
7622: }
7623: return R;
7624: }
7625: if(ntype(P)==4){
7626: P0=real(P);P1=imag(P)/2;
7627: X=makenewv(P);
7628: for(R=fctr(X^4-P0*X^2-P1^2);R!=[];R=cdr(R)){
7629: RT=car(R)[0];
7630: if(deg(RT,X)==1){
7631: X=-mycoef(RT,0,X)/mycoef(RT,1,X);
7632: return X+P1/X*@i;
7633: }
7634: if(deg(RT,X)==2){
7635: if((D=mycoef(RT,1,X)^2-4*mycoef(RT,2,X)*mycoef(RT,0,X))<0) continue;
7636: X=(-mycoef(RT,1,X)+sqrtrat(D))/(2*mycoef(RT,2,X));
7637: return X+P1*sqrt2rat(1/X)*@i;
7638: }
7639: }
7640: D=P0^2+4*P1^2;
7641: if(P1>0) return ((sqrtrat(D)+P0)/2)^(1/2)+((sqrtrat(D)-P0)/2)^(1/2)*@i;
7642: return ((sqrtrat(D)+P0)/2)^(1/2)-((sqrtrat(D)-P0)/2)^(1/2)*@i;
7643: }else if(ntype(P)!=0) return [];
7644: if(P==1) return P;
7645: Dn=dn(P);Nm=nm(P);C=R=1;
7646: N=pari(factor,Dn);
7647: if(N){
7648: for(II=car(size(N))-1;II>=0;II--){
7649: if(iand(K=N[II][1],1)){
7650: R*=N[II][0];
7651: K++;
7652: }
7653: C/=N[II][0]^(K/2);
7654: }
7655: }
7656: N=pari(factor,Nm);
7657: if(N){
7658: for(II=car(size(N))-1;II>=0;II--){
7659: if(N[II][0]==-1){
7660: C*=@i;
7661: continue;
7662: }
7663: K=N[II][1];
7664: if(iand(K,1)){
7665: R*=N[II][0];
7666: K--;
7667: }
7668: if(K!=0) C*=N[II][0]^(K/2);
7669: }
7670: }
7671: if(R!=1) C*=R^(1/2);
7672: return C;
7673: }
7674:
7675: def fctri(F)
7676: {
7677: R=(iscoef(F,os_md.israt))?fctr(F):[[1,1],[F,1]];
7678: if(!iscoef(F,os_md.iscrat)||chkfun("af_noalg",0)==0) return R;
7679: X=makenewv(vars(F));
7680: for(S=[];R!=[];R=cdr(R)){
7681: if(length(Var=vars(R0=car(R)[0])) == 1 && (D=mydeg(R0,Var=car(Var))) > 0){
7682: if(imag(T=mycoef(R0,D,Var))!=0) R0/=T;
7683: T=af_noalg(real(R0)+imag(R0)*X,[[X,X^2+1]]);
7684: if(length(T)>1||T[0][1]>1){
7685: T=subst(T,X,@i);
7686: for(; T!=[];T=cdr(T)){
7687: if(vars(T[0])!=[])
7688: S=cons([car(T)[0],car(T)[1]*car(R)[1]],S);
7689: }
7690: continue;
7691: }
7692: }
7693: S=cons(R[0],S);
7694: }
7695: return reverse(S);
7696: }
7697:
7698: def getroot(F,X)
7699: {
7700: S=[];
7701: if(type(Cpx=getopt(cpx))!=1) Cpx=0;
7702: M=getopt(mult);
7703: if(type(F) == 3)
7704: F = nm(red(F));
7705: for(R=fctri(F); length(R)>0; R = cdr(R)){
7706: T=car(R);
7707: P=car(T);
7708: I=car(cdr(T));
7709: if(mydeg(P,X)>0){
7710: if(mydeg(P,X)==1){
7711: C = mycoef(P,1,X);
7712: P = X - red(P/C);
7713: }else if(mydeg(P,X)==2 && Cpx>0){
7714: C2=mycoef(P,2,X);C1=mycoef(P,1,X);C0=mycoef(P,0,X);
7715: C=sqrt2rat(C1^2-4*C0*C2);
7716: C0=[];
7717: if(type(C)==0&&ntype(C)==0&&pari(issquare,-C)) C0=sqrt(C);
7718: else if(Cpx>1) C0=sqrtrat(C);
7719: if(C0==[]&&Cpx>2) C0=C^(1/2);
7720: if(C0!=[]){
7721: if(M==1)
7722: S=cons([I,sqrt2rat((-C1+C0)/(2*C2))],S);
7723: else{
7724: for(II=I; II>0; II--)
7725: S=cons(sqrt2rat((-C1+C0)/(2*C2)),S);
7726: }
7727: P=sqrt2rat((-C1-C0)/(2*C2));
7728: }
7729: }else if(mydeg(P,X)==3 && Cpx>1){
7730: Omg=(-1+3^(1/2)*@i)/2;
7731: PP=P/mycoef(P,3,X);
7732: C2=mycoef(PP,2,X)/3;
7733: PP=subst(PP,X,X-C2);
7734: if((C1=mycoef(PP,1,X))==0){
7735: C0=mycoef(PP,0,X);
7736: if(real(C0)==0||imag(C0)==0){
7737: if(real(C0)==0){
7738: PP=getroot(X^3+imag(C0),X);
7739: if(length(PP)==3){
7740: for(;PP!=[];PP=cdr(PP)){
7741: if(imag(PP[0])==0){
7742: C0=PP[0]*@i;
7743: break;
7744: }
7745: }
7746: if(PP==[]) C0=0;
7747: }
7748: }else{
7749: if(C0>0) C0=C0^(1/3);
7750: else C0=-(-C0)^(1/3);
7751: }
7752: if(C0!=0){
7753: if(M==1){
7754: S=cons([I,C0-C2],S);
7755: S=cons([I,C0*Omg-C2],S);
7756: S=cons([I,C0*(-1-Omg)-C2],S);
7757: }else{
7758: for(II=I; II>0; II--){
7759: S=cons(C0-C2,S);
7760: S=cons(C0*Omg-C2,S);
7761: S=cons(C0*(-1-Omg)-C2,S);
7762: }
7763: }
7764: continue;
7765: }
7766: }
7767: }
7768: if(Cpx>2){
7769: Q=X^2+(mycoef(PP,1,X)/3)*X+mycoef(PP,0,X)^3;
7770: SQ=getroot(Q,X|cpx=2);
7771: SQ=SQ[0]^(1/3);SQ2=mycoef(PP,0,X)/SQ;
7772: if(M==1){
7773: S=cons([I,SQ+SQ2-C2],S);
7774: S=cons([I,SQ*Omg+SQ2*(-1-Omg)-C2],S);
7775: S=cons([I,SQ*(-1-Omg)+SQ2*Omg-C2],S);
7776: }else{
7777: for(II=I; II>0; II--){
7778: S=cons(SQ+SQ2-C2,S);
7779: S=cons(SQ*Omg+SQ2*(-1-Omg)-C2,S);
7780: S=cons(SQ*(-1-Omg)+SQ2*Omg-C2,S);
7781: }
7782: }
7783: continue;
7784: }
7785: }else if(mydeg(P,X)==4 && Cpx>0){
7786: C2=mycoef(P,3,X)/(4*mycoef(P,4,X));
7787: PP=subst(P,X,X-C2);
7788: if(mycoef(PP,1,X)==0){
7789: PP=mycoef(PP,4,X)*X^2+mycoef(PP,2,X)*X+(SQ2=mycoef(PP,0,X));
7790: SQ=getroot(PP,X|cpx=2);
7791: if(length(SQ)==2){
7792: if((C0=sqrtrat(SQ[0]))==[]){
7793: if(mycoef(PP,1,X)==0){
7794: if(SQ2<0) C0=(-SQ2)^(1/4);
7795: else C0=SQ2^(1/4)*(1+@i)/2;
7796: }
7797: else if(Cpx>2) C0=SQ[0]^(1/2);
7798: else C0=0;
7799: }
7800: if((C1=sqrtrat(SQ[1]))==[]){
7801: if(mycoef(PP,1,X)==0) C1=-C0;
7802: else C1=SQ[1]^(1/2);
7803: }
7804: if(C0!=0){
7805: if(M==1)
7806: S=append([[I,C0-C2],[I,-C0-C2],[I,C1-C2],[I,-C1-C2]],S);
7807: else{
7808: for(II=I; II>0; II--)
7809: S=append([C0-C2,-C0-C2,C1-C2,-C1-C2],S);
7810: }
7811: continue;
7812: }
7813: }
7814: }else{
7815: PP/=mycoef(PP,4,X);
7816: CC=mycoef(PP,2,X);C1=mycoef(PP,1,X);C0=mycoef(PP,0,X);
7817: SQ=getroot(X*(CC+X)^2-4*C0*X-C1^2,X|cpx=Cpx);
7818: if(length(SQ)>1){
7819: SQ=sqrt2rat(SQ[0]);
7820: SQ2=getroot(X^2-SQ,X|cpx=Cpx);
7821: if(length(SQ2)>1){
7822: C1=SQ2[0]*X-C1/SQ2[0]/2;
7823: C0=getroot(X^2+CC/2+SQ/2+C1,X|cpx=Cpx);
7824: C1=getroot(X^2+CC/2+SQ/2-C1,X|cpx=Cpx);
7825: if(length(C0)>1&&length(C1)>1){
7826: C0=[sqrt2rat(C0[0]-C2),sqrt2rat(C0[1]-C2),
7827: sqrt2rat(C1[0]-C2),sqrt2rat(C1[1]-C2)];
7828: if(M==1) for(II=0;II<4;II++) S=cons([I,C0[II]],S);
7829: else for(II=I; II>0; II--) S=append(C0,S);
7830: continue;
7831: }
7832: }
7833: }
7834: }
7835: }
7836: if(M==1)
7837: S=cons([I,P],S);
7838: else for( ; I>0; I--) S=cons(P,S);
7839: }
7840: }
7841: S=qsort(S);
7842: if(M==1) S=reverse(S);
7843: return S;
7844: }
7845:
7846: def expat(F,L,V)
7847: {
7848: L = vweyl(L);
7849: if(V == "?"){
7850: Ans = [];
7851:
7852: F = nm(red(F));
7853: S = fromeul(toeul(F,L,"infty"),L,0);
7854: S = mycoef(S,mydeg(S,L[1]),L[1]);
7855: if(mydeg(S,L[0]) > 0)
7856: Ans = cons(["infty", expat(F,L,"infty")],Ans);
7857:
7858: S = mycoef(F,mydeg(F,L[1]), L[1]);
7859: R = getroot(S,L[0]);
7860: for(I = 0; I < length(R); I++){
7861: if(I > 0 && R[I-1] == R[I])
7862: continue;
7863: if(mydeg(R[I], L[0]) <= 0)
7864: Ans = cons([R[I], expat(F,L,R[I])], Ans);
7865: else
7866: Ans = cons([R[I]], Ans);
7867: }
7868: return Ans;
7869: }
7870: return getroot(subst(toeul(F,L,V),L[0],0),L[1]);
7871: }
7872:
7873: def polbyroot(P,X)
7874: {
1.49 takayama 7875: if(isvar(V=getopt(var))&&length(P)>1&&isint(car(P))){
7876: for(Q=[],I=car(P);I<=P[1];I++) Q=cons(makev([V,I]),Q);
7877: P=Q;
7878: }
1.6 takayama 7879: R = 1;
7880: while(length(P)){
7881: R *= X-car(P);
7882: if(type(R)>2) R = red(R);
7883: P = cdr(P);
7884: }
7885: return R;
7886: }
7887:
7888: def polbyvalue(P,X)
7889: {
7890: R = 1; S = 0;
7891: while(length(P)){
7892: T = car(P);
7893: V0 = T[1] - mysubst(S,[X,T[0]]);
7894: if(V0 != 0){
7895: if(type(R) > 2) R = red(R);
7896: V1 = mysubst(R,[X,T[0]]);
7897: if(V1 == 0){
7898: erno(0);
7899: return 0;
7900: }
7901: S += (V0/V1)*R;
7902: if(type(S) > 2) S = red(S);
7903: }
7904: R *= X - T[0];
7905: P = cdr(P);
7906: }
7907: return S;
7908: }
7909:
7910:
7911: def pcoef(P,L,Q)
7912: {
7913: if(L==0)
7914: return 1;
7915: Coef=TP=0;
7916: if(type(Q)>=4){
7917: TP=1;
7918: V=Q[0];
7919: if(type(V)==4)
7920: V=ltov(V);
7921: else V=dupmat(V);
7922: N=length(V);
7923: if(type(Q[1])==5) MR=dupmat(Q[1]);
7924: else{
7925: MR=newvect(N);
7926: for(K=Q[1], I=0; I< N; I++){
7927: MR[I] = car(K);
7928: K = cdr(K);
7929: }
7930: }
7931: }else{
7932: V=ltov(vars(P));
7933: N=length(V);
7934: MR=newvect(N);
7935: for(I=0;I<N;I++){
7936: MR[I]=mydeg(Q,V[I]);
7937: Q=mycoef(Q,MR[I],V[I]);
7938: }
7939: if(type(Q)>1) return 0;
7940: }
7941: if(L==1){
7942: for(I=0;I<N;I++)
7943: P=mycoef(P,MR[I],V[I]);
7944: return P;
7945: }
7946: for(I=1;I<N;I++){ /* sorted by required degrees */
7947: for(K1=MR[I],K2=V[I],J=I-1; J>=0 && MR[J]<K1; J--);
7948: for(II=I-1;II>J;II--){
7949: MR[II+1]=MR[II];V[II+1]=V[II];
7950: }
7951: MR[II+1]=K1;V[II+1]=K2;
7952: }
7953: for(NN=N; N>0 && MR[N-1]==0; N--);
7954: Mon=[];Coe=[];Q=P;
7955: while(Q!=0){
7956: M=newvect(N);
7957: for(R=Q,F=I=0,MT=1;I<NN;I++){
7958: K=mydeg(R,V[I]);
7959: R=mycoef(R,K,V[I]);
7960: if(I<N) M[I]=K;
7961: if(K>0) MT*=V[I]^K;
7962: if(K>MR[I]) F=1;
7963: }
7964: Q -= R*MT;
7965: if(F==0){
7966: Mon=cons(M,Mon);
7967: Coe=cons(R,Coe);
7968: }
7969: }
7970: Mon=ltov(reverse(Mon));
7971: Coe=ltov(reverse(Coe));
7972: Len=length(Mon);
7973: S=newvect(Len);
7974: for(JL=0; JL<Len;JL++){
7975: if(L*Mon[JL][0]<MR[0]) break;
7976: }
7977: S[0]=L;
7978:
7979: K0=Mon[0][0];
7980: K=L*K0-MR[0];
7981: for(I=II=0;II<Len && K>=0;II++){
7982: if((K1=K0-Mon[0][II])>0){
7983: while(K>K1 && S[I]>0){
7984: S[I]--;S[II]++;
7985: K-=K1;
7986: I=II;
7987: K0=Mon[0][II];
7988: }
7989: }else break;
7990: }
7991:
7992: I=0;
7993: while(1){
7994: for(T=T0=J=JP=0; J<Len; J++){
7995: if(S[J]!=0){
7996: if(T0==0 && J>=JL) return Coef;
7997: JP=J;T0=1;
7998: T+=S[J]*Mon[J][I];
7999: }
8000: }
8001: if(T==MR[I]){
8002: if(++I<N) continue;
8003: for(TT=1,J=1; J<=L; J++) /* find a solution */
8004: TT*=J;
8005: for(J=0;J<Len;J++){
8006: if(S[J]!=0){
8007: TT*=Coe[J]^S[J];
8008: for(II=S[J]; II>1; II--)
8009: TT/=II;
8010: }
8011: }
8012: Coef+=TT;
8013: if(TP==1 && type(Coef)==3) Coef=red(Coef);
8014: if(JP<Len-2 && S[JP]>1){
8015: S[JP]-=2;S[JP+1]++;S[JP+2]++;
8016: }else{
8017: for(JT=JP-1;JT>=0&&S[JT]==0;JT--);
8018: if(JT<0) break;
8019: if(JT==JP-1){
8020: S[JT]--;
8021: if(JP<Len-1)
8022: S[JP+1]++;
8023: else
8024: S[JP]++;
8025: }else{
8026: S[JT]--;
8027: S[JT+1]+=S[JP]+1;
8028: S[JP]=0;
8029: }
8030: }
8031: I=0;
8032: continue;
8033: }
8034: if(JP<Len-1){
8035: for(JP1=JP+1;JP1<Len-1;JP1++){
8036: if(Mon[JP1][I]!=Mon[JP][I]) break;
8037: }
8038:
8039: if(I>0 && Mon[JP1][0] < Mon[JP][0]){
8040: S[JP]--;S[Len-1]++;JP=JP-1;
8041: }else{
8042:
8043: S[JP]--;
8044: if(JP1<Len){
8045: S[JP1]++;
8046: }else{
8047: S[JP1-1]++;
8048: }
8049: }
8050: }
8051: if(JP==Len-1){
8052: for(JT=JP-1;JT>=0 && S[JT]==0;JT--);
8053: if(JT<0) break;
8054: S[JT]--;
8055: if(JT==JP-1){
8056: S[JP]++;
8057: }else{
8058: S[JT+1]+=S[JP]+1;
8059: S[JP]=0;
8060: }
8061: }
8062: I=0;
8063: }
8064: return Coef;
8065: }
8066:
1.58 takayama 8067: def pmaj(P)
8068: {
8069: if(type(P)==4){
1.68 takayama 8070: Opt=getopt(var);
8071: Opt=(isvar(Opt))?[["var",Opt]]:[];
8072: for(Q=[];P!=[];P=cdr(P)) Q=cons(pmaj(car(P)|option_list=Opt),Q);
8073: if(Opt==[]) return reverse(Q);
1.58 takayama 8074: X=Opt[0][1];
1.68 takayama 8075: D=mydeg(Q,X);
8076: for(S=0;D>=0;D--) S+=lmax(mycoef(Q,D,X))*X^D;
1.58 takayama 8077: return S;
8078: }
8079: V=vars(P);
1.71 takayama 8080: Y=getopt(var);
8081: Abs=(Y==1)?1:0;
8082: if(!(K=length(V))) return Y==1?1:abs(P);
1.58 takayama 8083: for(R=0,D=deg(P,X=V[0]);D>=0;D--){
8084: Q=coef(P,D,X);
1.71 takayama 8085: if(Q!=0) R+=((type(Q)>1)?pmaj(Q|var=Abs):(Y==1?1:abs(Q)))*X^D;
1.58 takayama 8086: }
1.71 takayama 8087: if(isvar(Y)) for(;V!=[];V=cdr(V)) R=subst(R,car(V),Y);
1.58 takayama 8088: return R;
8089: }
8090:
1.6 takayama 8091: def prehombf(P,Q)
8092: {
8093: if((Mem=getopt(mem))!=1 && Mem!=-1)
8094: return prehombfold(P,Q);
8095: if(Q==0) Q=P;
8096: V=ltov(vars(P));
8097: N=length(V);
8098: for(I=1;I<N;I++){ /* sorted by required degrees */
8099: for(K=mydeg(P,V[I]),K1=V[I],J=I-1; J>=0 && mydeg(P,V[J])<K; J--);
8100: for(II=I-1;II>J;II--) V[II+1]=V[II];
8101: V[II+1]=K1;
8102: }
8103: S=newvect(N);T=newvect(N);U=newvect(N);
8104: for(R=P,M=1,Deg=I=0;I<N;I++){ /* extreme vector */
8105: Deg+=(S[I]=mydeg(R,V[I]));
8106: R=mycoef(R,S[I],V[I]);
8107: }
8108: DR=[[-1,0]];
8109: if((R1=N/Deg)!=1){
8110: DR=cons([-R1,0],DR);
8111: Sft=1;
8112: }else Sft=0;
8113: if(Deg%2==0) Sg=1;
8114: else Sg=-1;
8115: for(I=0,R=R2=1,QQ=Q; 2*I+Sft < Deg; I++){
8116: if(Mem==-1){
8117: print(I+1,0);print("/",0);print(idiv(Deg-Sft+1,2),0);print(" ",2);
8118: }
8119: Coef=0;
8120: Q=QQ;
8121: while(Q!=0){
8122: for(R=Q,J=0,RR=1;J<N;J++){
8123: T[J]=mydeg(R,V[J]);
8124: R=mycoef(R,T[J],V[J]);
8125: if(T[J]>0) RR*=V[J]^T[J];
8126: }
8127: Q-=R*RR;
8128: for(J=0,CC=R;J<N;J++){
8129: U[J]=I*S[J]+T[J];
8130: for(II=0; II<T[J]; II++)
8131: CC*=(U[J]-II);
8132: }
8133: CC*=pcoef(P,I+1,[V,U]);
8134: if(Mem==-1) print("*",2);
8135: Coef+=CC;
8136: }
8137: DR=cons([I,Coef],DR);
8138: DR=cons([-R1-1-I,Sg*Coef],DR);
8139: if(Mem==-1) print("");
8140: }
8141: P = polbyvalue(DR,s);
8142: return fctr(P);
8143: }
8144:
8145: def prehombfold(P,Q)
8146: {
8147: V = vars(P);
8148: if(Q==0) Q=P;
8149: for(Deg=0, R=P, V1=V, DD=[]; V1!=[]; V1=cdr(V1)){
8150: VT = car(V1);
8151: D = mydeg(R,VT);
8152: R = mycoef(R,D,VT);
8153: Deg += D;
8154: X = makev(["d",VT]);
8155: Q = subst(Q,VT,X);
8156: DD=cons([VT,X],DD);
8157: }
8158: DR=[[-1,0]];
8159: NV=length(V);
8160: if((R1=NV/Deg)!=1){
8161: DR=cons([-R1,0],DR);
8162: Sft=1;
8163: }else
8164: Sft=0;
8165: if(Deg%2==0)
8166: Sg=1;
8167: else Sg=-1;
8168: for(I = 0, R=R2=1; 2*I+Sft < Deg; I++){
8169: R = R2;
8170: R2 = R*P;
8171: S = appldo(Q,R2,DD);
8172: QQ = sdiv(S,R);
8173: DR=cons([I,QQ],DR);
8174: DR=cons([-R1-1-I,Sg*QQ],DR);
8175: }
8176: P = polbyvalue(DR,s);
8177: return fctr(P);
8178: }
8179:
8180: def sub3e(P0,P1,P2,N0,N1,N)
8181: {
8182: R = x^N0*(x-1)^N1*dx^N;
8183: for(V = I = 1, J = 1; I <= N; I++){
8184: S = 0;
8185: M = N-I;
8186: if(I <= N0){
8187: T = mycoef(P0,N0-I,x);
8188: S += T;
8189: R += T*x^(N0-I)*(x-1)^N1*dx^M;
8190: K1 = N0-I+1;
8191: }else
8192: K1 = 0;
8193: if(I <= N1){
8194: T = mycoef(P1,N1-I,x);
8195: S += T;
8196: R += T*x^N0*(x-1)^(N1-I)*dx^M;
8197: K2 = N0-1;
8198: }else
8199: K2 = N-I;
8200: for(K = K1; K <= K2; K++){
8201: if(K == K2){
8202: R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(M-K)*dx^M;
8203: continue;
8204: }
8205: R += strtov("r"+rtostr(V))*x^K*(x-1)^(M-K)*dx^M;
8206: S += strtov("r"+rtostr(V++));
8207: }
8208: }
8209: if(V > 1)
8210: mycat([V-1, "accessory parameters: r1,r2,..."]);
8211: return R;
8212: }
8213:
8214: def fuchs3e(P,Q,R)
8215: {
8216: return getbygrs([R,P,Q],3);
8217: }
8218:
8219: def okubo3e(P,Q,R)
8220: {
8221: if(getopt(opt)==1){
8222: N=length(R);
8223: M1=N-length(P);M2=N-length(Q);
8224: V=(M1-1)*(M2-1);
8225: if(V>0) mycat([V, "accessory parameters"]);
8226: return getbygrs([R,cons([M1,0],P),cons([M2,0],Q)],3);
8227: }
8228: S = 0;
8229: V = -1;
8230: L = newvect(3,[[],[],[]]);
8231: N = newvect(3,[0,0,0]);
8232: if(type(R) < 4){
8233: I = -1;
8234: V = 3;
8235: }else{
8236: I = 2;
8237: V = -1;
8238: }
8239: for( ; I >= 0; I--){
8240: if(I == 2)
8241: U = R;
8242: else if(I == 1)
8243: U = Q;
8244: else
8245: U = P;
8246: for( ; length(U); U = cdr(U)){
8247: T = car(U);
8248: if( T == "?"){
8249: if(V < 0)
8250: V = I;
8251: else
8252: return 0;
8253: }else{
8254: if(I == 2)
8255: L[I] = cons(-T, L[I]);
8256: else
8257: L[I] = cons(T, L[I]);
8258: S += T;
8259: }
8260: N[I]++;
8261: }
8262: }
8263: if(V == 3){
8264: N[2] = N[0] + N[1];
8265: P2 = x^N;
8266: for(I = 1; I <= N; I++)
8267: P2 += makev([R,I])*x^(N-I);
8268: }else{
8269: if(N[0]+N[1] != N[2]){
8270: print("Number of exponents are wrong",0);
8271: return -1;
8272: }
8273: S -= N[0]*N[1];
8274: if(V < 0){
8275: if(S != 0){
8276: mycat(["Viorate Fuchs relation ->",S]);
8277: return -2;
8278: }
8279: }else{
8280: if(V != 2)
8281: S = -S;
8282: L[V] = cons(S, L[V]);
8283: }
8284: P2 = polinsft(polbyroot(L[2],x),x);
8285: }
8286: P0 = polinsft(mysubst(polbyroot(L[0],x),[x,x+N[1]]),x);
8287: P1 = polinsft(mysubst(polbyroot(L[1],x),[x,x+N[0]]),x);
8288: return sub3e(P0,P1,P2,N[0],N[1],N[2]);
8289: }
8290:
8291: /* N = 2*M (N-M = M) or 2*M+1 (N-M = M+1)
8292: 0 : 0 1 ..... M-1 B B+1 ... B+N-M-2 A
8293: 1 : C C+1 ... C+M-1 0 1 .... N-M-2 N-M-1
8294: */
8295: def eosub(A,B,C,N)
8296: {
8297: M = N%2;
8298: P = [];
8299: Q = [];
8300: P = cons(A,P);
8301: for(I = 0; I < N-M-1; I++)
8302: P = cons(B+I,P);
8303: for(I = 0; I < M; I++)
8304: Q = cons(C+I,Q);
8305: P = okubo3e(P,Q,s);
8306:
8307: C = newvect(2);
8308: L = newvect(2);
8309: C[1] = chkexp(P,[x,dx],0,b,N-M-1);
8310: C[0] = chkexp(P,[x,dx],1,c,M);
8311: for(LL = K = 0; K < 2; K++){
8312: L[K] = length(C[K]);
8313: C[K] = ltov(C[K]);
8314: if(L[K] > LL)
8315: LL = L[K];
8316: }
8317: JJ = 0;
8318:
8319: for(I = 1; Do; I++){
8320: Do = 0;
8321: S = makev(["r",I]);
8322: for(J = JJ; J < LL; J++){
8323: JJ = LL;
8324: for(K = 0; K < 2; K++){
8325: if(J >= L[K] || C[K][J] == 0)
8326: continue;
8327: if(J < JJ)
8328: JJ = J;
8329: if(Do == 1){
8330: CC = C[K];
8331: CC[J] = mysubst(CC[J], [S, Var]);
8332: continue;
8333: }
8334: if(mydeg(C[K][J]) >= 1){
8335: if(mydeg(C[K][J]) > 1){
8336: print("Internal error");
8337: return;
8338: }
8339: Var = getroot(C[K][J],S);
8340: Var = Var[0];
8341: CC = C[K];
8342: CC[J] = 0;
8343: P = mysubst(P, [S, Var]);
8344: Do = 1;
8345: J = JJ - 1;
8346: K++;
8347: }
8348: }
8349: }
8350: }
8351: if(JJ != L){
8352: print("Internal error (non Rigid)");
8353: return;
8354: }
8355: return P;
8356: }
8357:
8358: def even4e(X,Y){
8359: if(length(X) != 4 || length(Y) != 2){
8360: print("Usage: even4e([a,b,c,d],[e,f])");
8361: print("0: 0 1 e f");
8362: print("1; 0 1 * *+1");
8363: print("infty: a b c d");
8364: return;
8365: }
8366: S = -3;
8367: for(I = 0; I < 4; I++){
8368: S += X[I];
8369: if(I < 2)
8370: S += Y[I];
8371: }
8372: S = -S/2;
8373: P = okubo3e(Y,[S,"?"],X);
8374: T = chkexp(P,x,1,S,2);
8375: T = getroot(T[0],r1);
8376: return mysubst(P,[r1,T[0]]);
8377: }
8378:
8379: def odd5e(X,Y)
8380: {
8381: if(length(X) != 5 || length(Y) != 2){
8382: print("Usage: spec6e([a,b,c,d,e],[f,g])");
8383: print("0: 0 1 f g g+1");
8384: print("1: 0 1 2 * *+1");
8385: print("infty: a b c d e");
8386: return;
8387: }
8388: S = -4;
8389: for(I = 0; I < 5; I++){
8390: S += X[I];
8391: if(I < 2)
8392: S += Y[I];
8393: }
8394: S = -(S + Y[1])/2;
8395: P = okubo3e([Y[0],Y[1],Y[1]+1],[S,"?"],X);
8396: T = chkexp(P,x,1,S,2);
8397: T = getroot(T[0],r1);
8398: P = mysubst(P,[r1,T[0]]);
8399: T = chkexp(P,x,0,Y[1],2);
8400: T = getroot(T[0],r2);
8401: return mysubst(P,[r2,T[0]]);
8402: }
8403:
8404: def extra6e(X,Y)
8405: {
8406: if(length(X) != 6 || length(Y) != 2){
8407: print("Usage: extra6e([a,b,c,d,e,f],[g,h])");
8408: print("0: 0 1 g g+1 h h+1");
8409: print("1: 0 1 2 3 * *+1");
8410: print("infty: a b c d e f");
8411: return;
8412: }
8413: S = -5;
8414: for(I = 0; I < 6; I++){
8415: S += X[I];
8416: if(I < 2)
8417: S += 2*Y[I];
8418: }
8419: S = -S/2;
8420: P = okubo3e([Y[0],Y[0]+1,Y[1],Y[1]+1],[S,"?"],X);
8421: T = chkexp(P,x,1,S,2);
8422: T = getroot(T[0],r1);
8423: P = mysubst(P,[r1,T[0]]);
8424: T = chkexp(P,x,0,Y[0],2);
8425: T = getroot(T[0],r3);
8426: P = mysubst(P,[r3,T[0]]);
8427: T = chkexp(P,x,0,Y[1],2);
8428: T = getroot(T[0],r2);
8429: return mysubst(P,[r2,T[0]]);
8430: }
8431:
8432: def rigid211(X,Y,Z)
8433: {
8434: if(length(X) != 2 || length(Y) != 2 || length(Z) != 2){
8435: print("Usage: rigid211([a,b],[c,d],[e,f])");
8436: print("0: 0 1 a b");
8437: print("1: 0 1 c d");
8438: print("infty: e e+1 f *");
8439: return;
8440: }
8441: P = okubo3e(X,Y,[Z[0],Z[0]+1,Z[1],"?"]);
8442: T = chkexp(P,x,"infty",Z[0],2);
8443: T = getroot(T[0],r1);
8444: return mysubst(P,[r1,T[0]]);
8445: }
8446:
8447: def solpokuboe(P,L,N)
8448: {
8449: if(type(N) > 1 || ntype(N) != 0 || dn(N) != 1){
8450: mycat(["Irrigal argument :", N]);
8451: return 0;
8452: }
8453: L = vweyl(L);
8454: DD=N+1;
8455: for(U = S = L[0]^N; U != 0; ){
8456: D = mydeg(U,L[0]);
8457: if(D>=DD){
8458: mycat(["Internal Error",D,DD]);
8459: return -1;
8460: }
8461: DD=D;
8462: UU = L[0]^D;
8463: R = appldo(P,UU,L);
8464: if(mydeg(R,L[0]) > D){
8465: printf("Bad operator\n");
8466: return 0;
8467: }
8468: CC = mycoef(R,D,L[0]);
8469: if(D == N){
8470: P -= (E = CC);
8471: U = R-E*U;
8472: continue;
8473: }
8474: if(CC == 0){
8475: printf("No polynomial\n");
8476: return 0;
8477: }
8478: CC= mycoef(U,D,L[0])/CC;
8479: S = red(S - UU*CC);
8480: U = red(U - R*CC);
8481: }
8482: return [nm(S),E];
8483: }
8484:
8485: def stoe(M,L,N)
8486: {
8487: L = vweyl(L);
8488: Size = size(M);
8489: S = Size[0];
1.80 takayama 8490: NN = -1;
1.6 takayama 8491: if(type(N) == 4){
8492: NN=N[0]; N=N[1];
1.80 takayama 8493: if(N==NN) return 1;
1.6 takayama 8494: }else if(N < 0){
8495: NN=-N; N=0;
8496: }
8497: if(S != Size[1] || N >= S || NN >= S)
8498: return;
8499: D = newmat(S+1,S+1);
8500: MN = dupmat(M);
8501: MD = newmat(S,S);
8502: DD = D[0];
1.80 takayama 8503: DD[N]=1; DD[S] = 1;
1.6 takayama 8504: for(Lcm = I = 1; ; ){
8505: DD = D[I];
8506: MM = MN[N];
8507: for(J = 0; J < S; J++){
8508: DD[J] = MM[J];
8509: Lcm = lcm(dn(DD[J]),Lcm);
8510: }
8511: DD[S] = L[1]^I;
8512: for(J = 0; J <= S; J++)
8513: DD[J] = red(DD[J]*Lcm);
8514: if(I++ >= S)
8515: break;
1.80 takayama 8516: if(I==S && NN>=0){
1.6 takayama 8517: DD = D[I];
1.80 takayama 8518: DD[S]=z_zz; DD[NN]=1;
1.6 takayama 8519: break;
8520: }
8521: Mm = dupmat(MN*M);
8522: for(J = 0; J < S; J++){
8523: for(K = 0; K < S; K++)
8524: MN[J][K] = red(diff(MN[J][K],L[0])+Mm[J][K]);
8525: }
8526: }
8527: #if 0
8528: P = fctr(mydet2(D));
8529: #else
8530: P = fctr(det(D));
8531: #endif
8532: for(I = R = 1; I < length(P); I++){
8533: if(mydeg(P[I][0],L[1]) > 0)
8534: R *= P[I][0]^P[I][1];
8535: }
1.80 takayama 8536: if(NN >= 0)
1.6 takayama 8537: R = -red(coef(R,0,z_zz)/coef(R,1,z_zz));
8538: return R;
8539: }
8540:
8541: def dform(L,X)
8542: {
8543: if(type(X)==2) X=[X];
8544: if(type(L[0])!=4) L=[L];
8545: if(type(X)==4) X=ltov(X);
8546: M=length(X);
8547: if(length(car(L))==2){
8548: R=newvect(M);
8549: for(LL=L; LL!=[]; LL=cdr(LL)){
8550: for(I=0; I<M; I++){
8551: RT=rmul(car(LL)[0],mydiff(car(LL)[1],X[I]));
8552: R[I] = (R[I]==0)?RT:radd(R[I],RT);
8553: }
8554: }
8555: Dif=getopt(dif);
8556: for(RR=[], I=M-1; I>=0; I--){
8557: if(Dif==1) RR=cons([1,R[I],X[I]],RR);
8558: else RR=cons([R[I],X[I]],RR);
8559: }
8560: if(Dif==1) RR=dform(RR,X);
8561: return RR;
8562: }else if(length(car(L))!=3) return L;
8563: N=M*(M-1)/2;
8564: R=newvect(N);
8565: S=newvect(N);
8566: for(LL=L; LL!=[]; LL=cdr(LL)){
8567: for(I=K=0; I<M; I++){
8568: for(J=I+1; J<M; J++, K++){
8569: if(LL==L) S[K]=[X[I],X[J]];
8570: LT=car(LL);
8571: R1=mydiff(LT[2],X[J]);
8572: R2=mydiff(-LT[2],X[I]);
8573: if(R2==0){
8574: if(R1==0) continue;
8575: R1=rmul(mydiff(LT[1],X[I]),R1);
8576: }else if(R1==0){
8577: R1=rmul(mydiff(LT[1],X[J]),R2);
8578: }else
8579: R1=rmul(mydiff(LT[1],X[I]),R1)+rmul(mydiff(LT[1],X[J]),R2);
8580: R1=rmul(LT[0],R1);
8581: R[K] = (R[K]==0)?R1:radd(R[K],R1);
8582: }
8583: }
8584: }
8585: for(RR=[],I=N-1; I>=0; I--)
8586: RR=cons([R[I],S[I][0],S[I][1]],RR);
8587: return RR;
8588: }
8589:
8590: def polinvsym(P,Q,Sym)
8591: {
8592: N = length(Q);
8593: T = polbyroot(Q,zz);
8594: for(I = 1; I <= N; I++){
8595: P = mysubst(P,[makev([Sym,I]), (-1)^I*coef(T,N-I,zz)]);
8596: }
8597: return P;
8598: }
8599:
8600: def polinsym(P,Q,Sym)
8601: {
8602: if(type(P) == 3){
8603: P = red(P);
8604: if(type(P) == 3){
8605: D = polinsym(dn(P),Q,Sym);
8606: if(D == 0)
8607: return 0;
8608: return polinsym(nm(P),Q,Sym)/D;
8609: }
8610: }
8611: N = length(Q);
8612: V = newvect(N+1);
8613: S = newvect(N+1);
8614: E = newvect(N+1);
8615: E0 = newvect(N+1);
8616: T = polbyroot(Q,zzz);
8617: for(J = 1; J <= N; J++){
8618: K = coef(T,N-J,zzz);
8619: if(J % 2)
8620: K = -K;
8621: S[J] = K;
8622: V[J] = makev([Sym,J]);
8623: }
8624: K = deg(P,Q[0]);
8625: for(J = 0; J <= N; J++)
8626: E0[J] = K+1;
8627: E[0] = K+1;
8628: while(deg(P,Q[0]) > 0){
8629: for(P0 = P, J = 1; J <= N; J++){
8630: E[J] = deg(P0,Q[J-1]);
8631: P0 = coef(P0,E[J],Q[J-1]);
8632: }
8633: /* P0*Q[0]^E[1]*Q[1]^E[2]*... E[1] >= E[2} >= ... */
8634: for(J = 1; J <= N; J++){
8635: if(E[J] < E0[J])
8636: break;
8637: if(E[J-1] < E[J])
8638: J = N;
8639: }
8640: if(J > N){
8641: print("Not symmetric");
8642: return 0;
8643: }
8644: for(J = 1; J <= N; J++)
8645: E0[J] = E[J];
8646: for(J = N; J > 1; J--){
8647: if(E[J] != 0)
8648: for(K = 1; K < J; K++)
8649: E[K] -= E[J];
8650: }
8651: for(R0 = P0, K = 1; K <= N; K++){
8652: if(E[K] > 0)
8653: P0 *= S[K]^E[K];
8654: R0 *= V[K]^E[K];
8655: }
8656: P += R0 - P0;
8657: }
8658: return P;
8659: }
8660:
8661: def tohomog(P,L,V)
8662: {
8663: while(length(L)>0){
8664: P = mysubst(P,[car(L),car(L)/V]);
8665: L = cdr(L);
8666: }
8667: P = red(P);
8668: N = mindeg(dn(P),V);
8669: if(N > 0)
8670: P = red(P*V^N);
8671: N = mindeg(dn(P),V);
8672: if(N > 0)
8673: P = red(P/(V^N));
8674: return P;
8675: }
8676:
8677: def substblock(P,X,Q,Y)
8678: {
8679: P = red(P);
8680: if(deg(dn(P),X) > 0)
8681: return substblock(nm(P),X,Q,Y)/substblock(dn(P),X,Q,Y);
8682: N = mydeg(Q,X);
8683: if(N < 1)
8684: return P;
8685: R = mycoef(Q,N,X);
8686: while(M = mydeg(P,X), M >= N)
8687: P = red(P - mycoef(P,M,X)*(Q-Y)*X^(M-N)/R);
8688: return P;
8689: }
8690:
8691: def okuboetos(P,L)
8692: {
8693: L = vweyl(L); X = L[0]; DX = L[1];
8694: N = mydeg(P,DX);
8695: C = mycoef(P,N,DX);
8696: K = mydeg(C,X);
8697: if(K > N){
8698: print("Irregular singularity at infinity")$
8699: return 0;
8700: }
8701: if(N > K)
8702: P *= x^(N-K);
8703:
8704: L = getroot(mycoef(P,N,DX),x);
8705: L = ltov(reverse(L));
8706: if(length(L) != N || N == 0){
8707: print("Cannot get exponents")$
8708: return 0;
8709: }
8710: if( type(LL = getopt(diag)) == 4 ){
8711: LL = ltov(LL);
8712: if(length(LL) != N){
8713: mycat(["Length of the option should be", N]);
8714: return 0;
8715: }
8716: Tmp = newvect(N);
8717: for(I = N-1; I >= 0; I--){
8718: for(LLT = LL[I], J = N-1; J >=0 ; J--){
8719: if(LLT == L[J] && Tmp[J] == 0){
8720: Tmp[J] = 1;
8721: break;
8722: }
8723: }
8724: if(J < 0){
8725: print("option is wrong");
8726: return 0;
8727: }
8728: }
8729: L = LL;
8730: }
8731: P /= mycoef(C,N,X);
8732: A = newmat(N,N);
8733: AT = newmat(N+1,N+1);
8734: Phi= newvect(N+1);
8735: Phi[0] = 1;
8736: for(J = 0; J < N; J++)
8737: Phi[J+1] = Phi[J]*(X-L[J]);
8738: for(ATT = AT[N], J = 0; J < N; J++)
8739: ATT[J] = mycoef(P,J,DX);
8740:
8741: for(K = 1; K <= N; K++){
8742: for(J = N; J >= K; J--){
8743: Aj = A[J-1];
8744: SIG = AT[J][J-K];
8745: for(I = 0; I <= K-2; I++)
8746: SIG += Aj[J-I-1]*AT[J-I-1][J-K];
8747: if(K == 1)
8748: DAT = mydiff(Phi[J-1],X);
8749: else
8750: DAT = mydiff(AT[J-1][J-K],X);
8751: Aj[J-K] = -SIG+(X-L[J-1])*DAT;
8752: Aj[J-K] /= Phi[J-K];
8753: Aj[J-K] = mysubst(Aj[J-K],[X,L[J-1]]);
8754: if(J < K+1) continue;
8755: ATj = AT[J-1];
8756: ATj[J-K-1] = SIG+Aj[J-K]*Phi[J-K];
8757: ATj[J-K-1] /= (X - L[J-1]);
8758: ATj[J-K-1] = red(ATj[J-K-1]-DAT);
8759: }
8760: }
8761:
8762: ATT = newmat(N,N);
8763: for(J = 0; J < N; J++){
8764: for(K = 0; K < N; K++){
8765: ATj = ATT[J];
8766: ATj[K] = AT[J][K];
8767: }
8768: ATj[J] = Phi[J];
8769: if(J < N-1){
8770: ATj = A[J];
8771: ATj[J+1] = 1;
8772: }
8773: }
8774: return [L,A,ATT];
8775: }
8776:
8777: def heun(X,P,R)
8778: {
8779: if(type(X) != 4 || length(X) != 5){
8780: print("Usage: huen([a,b,c,d,e],p,r)");
8781: print("0: 0 c");
8782: print("1: 0 d");
8783: print("p: 0 e");
8784: print("infty: a b");
8785: print("Fuchs relation: a+b+1 = c+d+e");
8786: return;
8787: }
8788: S = 1;
8789: V = -1;
8790: X = ltov(X);
8791: for(I = 0; I < 5; I++){
8792: if(X[I] == "?"){
8793: if(V >= 0)
8794: return;
8795: V = I;
8796: }else if(I < 2){
8797: S += X[I];
8798: }else
8799: S -= X[I];
8800: }
8801: if(V >= 0){
8802: if(V < 2)
8803: X[V] = -S;
8804: else
8805: X[V] = S;
8806: }else if(S != 0){
8807: mycat(["Fuch relation:", S,"should be zero!"]);
8808: return;
8809: }
8810: return
8811: x*(x-1)*(x-P)*dx^2
8812: + (X[2]*(x-1)*(x-P)+X[3]*x*(x-P)+X[4]*x*(x-1))*dx
8813: + X[0]*X[1]*(x-R);
8814: }
8815:
8816: def fspt(M,T)
8817: {
8818: if(type(M)==7) M=s2sp(M);
8819: if(T == 3) /* 3: cut 0 */
8820: return cutgrs(M);
8821: if(T == 4 || T== 5){ /* 4: short 5: long */
8822: for(MN = [] ; M != []; M = cdr(M)){
8823: MT = car(M);
8824: for(MNT = []; MT != []; MT = cdr(MT)){
8825: if(type(car(MT)) <= 3){
8826: if(T == 4) MNT = cons(car(MT),MNT);
8827: else MNT = cons([1,car(MT)],MNT);
8828: }else{
8829: if(T == 5 || car(MT)[0] > 1) MNT = cons(car(MT),MNT);
8830: else if(car(MT)[0] == 1) MNT = cons(car(MT)[1],MNT);
8831: }
8832: }
8833: MN = cons(reverse(MNT), MN);
8834: }
8835: return reverse(MN);
8836: }
8837: if(type(M[0][0]) == 4){
8838: for(MN = [] ; M != []; M = cdr(M)){
8839: MT = car(M);
8840: for(MNT = []; MT != []; MT = cdr(MT))
8841: MNT = cons(car(MT)[0], MNT);
8842: MN = cons(reverse(MNT), MN);
8843: }
8844: return fspt(reverse(MN),T);
8845: }
8846: if(T == 0) /* 0: sp */
8847: return M;
8848: for(MN = [] ; M != []; M = cdr(M)){
8849: MT = qsort(ltov(car(M)));
8850: L = length(MT);
8851: for(MNT = [], I = 0; I < L; I++)
8852: MNT = cons(MT[I], MNT);
8853: MN = cons(MNT, MN);
8854: }
8855: MN = reverse(MN);
8856: if(T==6) return MN; /* 7: sort */
8857: L = length(MN);
8858: for(M = MN; M != []; M = cdr(M)){
8859: for(I = 0, MT = car(M); MT != []; MT = cdr(MT))
8860: I += car(MT);
8861: if(OD == 0)
8862: OD = I;
8863: else if(OD != I || OD == 0)
8864: return 0;
8865: }
8866: ALL = [MN];
8867: RD=[];
8868: while(OD > 0){
8869: for(S = 0, MT = MN; MT != []; MT = cdr(MT))
8870: S += car(MT)[0];
8871: S -= (L-2)*OD;
8872: if(S <= 0){
8873: if(T==7) return [ALL[0],ALL[length(ALL)-1],RD];
8874: return (T==1)?MN:ALL;
8875: }
8876: RD=cons([S,0,0],RD);
8877: for(NP=0, M = [], MT = MN; MT != []; NP++, MT = cdr(MT)){
8878: MTT = car(MT);
8879: I = MTT[0] - S;
8880: if(I < 0){
8881: if(I+OD!=0) return 0;
8882: if(T==7) return [ALL[0],ALL[length(ALL)-1],cdr(RD)];
8883: return (T==1)?MN:ALL;
8884: }
8885: MTT = cdr(MTT);
8886: NC=1; DO=0;
8887: for(MNT = []; MTT != []; MTT = cdr(MTT)){
8888: if(MTT[0] > I){
8889: if(DO==0) RD=cons([MTT[0]-I,NP,NC++],RD);
8890: MNT = cons(MTT[0], MNT);
8891: }
8892: else if(MTT[0] <= I && I != 0){
8893: DO=1;
8894: MNT = cons(I, MNT);
8895: I = 0;
8896: if(MTT[0] > 0)
8897: MNT = cons(MTT[0], MNT);
8898: }
8899: }
8900: if(I > 0)
8901: MNT = cons(I,MNT);
8902: M = cons(reverse(MNT), M);
8903: }
8904: MN = reverse(M);
8905: ALL = cons(MN,ALL);
8906: OD -= S;
8907: }
8908: }
8909:
8910: def abs(X)
8911: {
8912: if(vars(X)!=[]) return todf(os_md.abs,[X]);
8913: if(type(X)==4){
8914: P=X[1];X=X[0];
8915: }else P=0;
8916: if(type(X)==1){
8917: if((T=ntype(X))<2 || T==3){
8918: if(X<0) X=-X;
8919: }else if(T==4) X=P?pari(abs,X,P):pari(abs,X);
8920: }
8921: return X;
8922: }
8923:
1.20 takayama 8924: def sgn(X)
8925: {
8926: if(X==0) return 0;
8927: if(type(X)==1){
8928: return (X>0)?1:-1;
8929: }
8930: if(type(X)==5) X=vtol(X);
8931: if(type(X)==4){
8932: for(W=0,Y=X;Y!=[];Y=cdr(Y))
8933: for(Z=cdr(Y);Z!=[];Z=cdr(Z))
8934: if(car(Y)>car(Z)) W++;
8935: if(getopt(val)==1) return W;
8936: return (iand(W,1))?-1:1;
8937: }
8938: }
8939:
1.6 takayama 8940: def calc(X,L)
8941: {
1.10 takayama 8942: if(type(X)<4||type(X)==7){
8943: if(type(L)==4||type(L)==7){
1.6 takayama 8944: V=L[1];
1.10 takayama 8945: if(type(X)!=7){
8946: if((L0=L[0])=="+") X+=V;
8947: else if(L0=="-") X-=V;
8948: else if(L0=="*") X*=V;
8949: else if(L0=="/") X/=V;
8950: else if(L0=="^") X^=V;
8951: }
8952: if((L0=L[0])==">") X=(X>V);
8953: else if(L0=="<") X=(X<V);
8954: else if(L0=="=") X=(X==V);
1.6 takayama 8955: else if(L0==">=") X=(X>=V);
8956: else if(L0=="<=") X=(X<=V);
8957: else if(L0=="!=") X=(X!=V);
1.10 takayama 8958: }else if(type(L)==7&&type(X)<4){
1.6 takayama 8959: if(L=="neg") X=-X;
8960: else if(L=="abs") X=abs(X);
8961: else if(L=="neg") X=-X;
8962: else if(L=="sqr") X*=X;
8963: else if(L=="inv") X=1/X;
8964: else if(L=="sgn"){
8965: if(X>0)X=1;
8966: else if(X<0) X=-1;
8967: }
8968: }
8969: }
8970: return X;
8971: }
8972:
1.23 takayama 8973: def tobig(X)
8974: {
8975: if((type(X)==1 && ntype(X)==3)||type(X)>3) return X;
8976: return eval(X*exp(0));
8977: }
8978:
1.6 takayama 8979: def isint(X)
8980: {
8981: if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1;
8982: return 0;
8983: }
8984:
8985: def israt(X)
8986: {
8987: if(X==0||(type(X)==1 && ntype(X)==0)) return 1;
8988: return 0;
8989: }
8990:
8991: def iscrat(X)
8992: {
8993: if(X==0 || (type(X)==1 && israt(real(X)) && israt(imag(X)))) return 1;
8994: return 0;
8995: }
8996:
8997: def isalpha(X)
8998: {
8999: return ((X>64&&X<91)||(X>96&&X<123))?1:0;
9000: }
9001:
9002: def isnum(X)
9003: {
9004: return (X>47&&X<58)?1:0;
9005: }
9006:
9007: def isalphanum(X)
9008: {
9009: return (isalpha(X)||isnum(X))?1:0;
9010: }
9011:
1.8 takayama 9012: def isdecimal(X)
9013: {
9014: if(type(X)!=7) return 0;
9015: F=S=0;
9016: L=strtoascii(X);
9017: while(L!=[]&&car(L)==32) L=cdr(L);
9018: if(L!=[]&&car(L)==45) L=cdr(L); /* - */
9019: while(L!=[]&&isnum(car(L))){
9020: F=1; L=cdr(L);
9021: }
9022: while(L!=[]&&car(L)<33){
9023: S=1;L=cdr(L);
9024: }
9025: if(L==[]) return F;
9026: else if(S||car(L)!=46) return 0; /* . */
9027: L=cdr(L);F=0;
9028: while(L!=[]&&isnum(car(L))){
9029: F=1; L=cdr(L);
9030: }
9031: while(L!=[]&&car(L)<33) L=cdr(L);
9032: return (L==[])?F:0;
9033: }
9034:
1.6 takayama 9035: def isvar(X)
9036: {
9037: return ([X]==vars(X)&&vtype(X)<3)?1:0;
9038: }
9039:
9040: def isyes(F)
9041: {
9042: if((CC=getopt(set))==1){
9043: IsYes=(type(F[0])==4)?F:[F];
9044: return 1;
9045: }else if(CC==0) return(IsYes);
9046: if(type(CC)!=7)
9047: CC=IsYes;
9048: for(;CC!=[]; CC=cdr(CC)){
9049: C=car(CC);
9050: V=call(C[0],cons(F,C[1]));
9051: if(type(C[2])!=4){
9052: if(V!=C[2]) break;
9053: }else{
9054: if(C[2][0]!="" && V<C[2][0]) break;
9055: if(C[2][1]!="" && V>C[2][1]) break;
9056: }
9057: }
9058: return (CC==[])?1:0;
9059: }
9060:
9061: def isall(FN,M)
9062: {
9063: if(type(M)<4 || type(M)>6) return ((*FN)(M)==0)?0:1;
9064: if(type(M)==4){
9065: for(;M!=[];M=cdr(M))
9066: if((*FN)(car(M))==0) return 0;
9067: }else if(type(M)==5){
9068: K=length(M);
9069: for(I=0;I<K;I++)
9070: if((*FN)(M[I])==0) return 0;
9071: }else if(type(M)==6){
9072: K=size(M)[0];
9073: for(I=0;I<K;I++)
9074: if (isall(FN,M[I])==0) return 0;
9075: }
9076: return 1;
9077: }
9078:
9079: def sproot(MP,T)
9080: {
9081: if((I=str_chr(T,0,","))>0){
9082: if(type(MP)==7) M=s2sp(MP);
9083: else M=chkspt(MP|opt=0);
9084: if(I==length(M[0])){
9085: N=s2sp(T);S=SM=SN=K=0;
9086: for(MM=M,NN=N;MM!=[];MM=cdr(MM),NN=cdr(NN),K++){
9087: for(MT=car(MM),NT=car(NN);MT!=[];MT=cdr(MT),NT=cdr(NT)){
9088: S+=car(MT)*car(NT);
9089: if(K==0){
9090: SM+=car(MT);SN+=car(NT);
9091: }
9092: }
9093: }
9094: return S-(length(M)-2)*SM*SN;
9095: }
9096: }
9097: MM=chkspt(MP|opt=7);
9098: if(T=="base") return MM;
9099: Keep=(getopt(keep)==1)?1:0;
9100: Null=getopt(null);
9101: Only=getopt(only);
9102: if(type(Only)!=1) Only=7;
9103: M0=MM[0];
9104: M1=MM[1];
9105: M=MM[2];
9106: if(T=="length") return length(M);
9107: if(T=="height"){
9108: for(J=2,S=M1[0][0],M2=M1; M2!=[]; M2=cdr(M2)){
9109: for(MT=cdr(car(M2)); MT!=[]; J++, MT=cdr(MT)){
9110: S+= J*car(MT);
9111: }
9112: J=1;
9113: }
9114: return S;
9115: }
9116: for(OD=0, MT=M1[0]; MT!=[]; MT=cdr(MT)) OD+=car(MT);
9117: if(T=="type"){
9118: R=newvect(OD+1);
9119: for(MT=M; MT!=[]; MT=cdr(MT)) R[MT[0][0]]++;
9120: for(RR=[],I=OD; I>0; I--)
9121: if(R[I]>0) RR=cons([R[I],I],RR);
9122: return RR;
9123: }
9124: if(T=="part"||T=="pair"||T=="pairs"){
9125: NP=length(M1);
9126: LM=newvect(NP);
9127: R=newvect(length(M));
9128: for(K=0; K<NP; K++) LM[K]=length(M1[K]);
9129: for(I=0,TM=M; TM!=[]; I++, TM=cdr(TM)){
9130: V=newvect(NP);
9131: for(K=0; K<NP; K++) V[K]=newvect(LM[K]);
9132: TP=car(TM);
9133: if(TP[2]==0){
9134: for(K=0;K<NP;K++) V[K][0]=1;
9135: for(J=0; J<I; J++){
9136: VJ=R[J][1];
9137: for(S=K=0;K<NP;K++) S+=VJ[K][0];
9138: for(OD=0,K=0;K<LM[0];K++) OD+=VJ[0][K];
9139: S-=(NP-2)*OD;
9140: for(K=0;K<NP;K++) VJ[K][0]-=S;
9141: }
9142: }else{
9143: K=TP[1]; P=TP[2];
9144: V[K][P-1]=-1; V[K][P]=1;
9145: for(J=0; J<I; J++){
9146: VJ=R[J][1];
9147: S=VJ[K][P]; VJ[K][P]=VJ[K][P-1]; VJ[K][P-1]=S;
9148: }
9149: }
9150: R[I]=[TP[0],V];
9151: }
9152: if(T=="pair"||T=="pairs"){
9153: MV=ltov(M1);
9154: for(K=0; K<NP; K++) MV[K] = ltov(MV[K]);
9155: for(RR=UU=SS=[],I=0; I<length(M); I++){
9156: V=newvect(NP); W=newvect(NP); U=newvect(NP);
9157: for(K=0; K<NP; K++){
9158: U[K]=newvect(LM[K]); V[K]=newvect(LM[K]); W[K]=newvect(LM[K]);
9159: }
9160: S=R[I][0];
9161: for(K=0; K<NP; K++){
9162: for(Q=J=0; J<LM[K]; J++){
9163: V[K][J] = S*(U[K][J] = R[I][1][K][J]);
9164: Q+=(W[K][J] = MV[K][J] - V[K][J]);
9165: }
9166: }
9167: if(Q>0 && iand(Only,1)==0) continue;
9168: if(Q==0 && iand(Only,2)==0) continue;
9169: if(Q<0 && iand(Only,4)==0) continue;
9170: for(K=0; K<NP; K++){
9171: V[K] = vtol(V[K]); W[K] = vtol(W[K]); U[K]=vtol(U[K]);
9172: }
9173: V=vtol(V); W=vtol(W);U=vtol(U);
9174: if(Q<0) S=-S;
9175: RR = cons([V,W], RR); UU = cons(U,UU); SS=cons(S,SS);
9176: }
9177: RR = reverse(RR); UU=reverse(UU); SS=reverse(SS);
9178: if(getopt(dviout)==1 && (Null!=1 || RR!=[])){
9179: Out=string_to_tb("\\begin{align}\\begin{split}"+s2sp(M1)+"&=");
9180: for(I=0,R=RR, U=UU; R!=[]; I++, R=cdr(R), U=cdr(U)){
9181: if(I>0) str_tb("\\\\\n &=",Out);
9182: if(T=="pairs"){
9183: if((S=SS[I])<0) S=-S;
9184: if(S>1) str_tb([my_tex_form(S),"("],Out);
9185: str_tb(s2sp(car(U)),Out);
9186: if(S>1) str_tb(")",Out);
9187: str_tb(" \\oplus ",Out);
9188: if(SS[I]<0){
9189: #ifdef USEMODULE
9190: str_tb(["-(",s2sp(mtransbys(os_md.abs,car(R)[1],[])),")"],Out);
9191: #else
9192: str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out);
9193: #endif
9194: }else
9195: str_tb(s2sp(car(R)[1]),Out);
9196: }else
9197: str_tb([s2sp(car(R)[0])," \\oplus ",s2sp(car(R)[1])],Out);
9198: }
9199: str_tb("\n\\end{split}\\end{align}",Out);
9200: dviout(str_tb(0,Out)|keep=Keep);
9201: }
9202: return RR;
9203: }
9204: for(I=0; I<length(M); I++){
9205: for(K=0; K<NP; K++) R[I][1][K] = vtol(R[I][1][K]);
9206: R[I] = [R[I][0],vtol(R[I][1])];
9207: }
9208: R = vtol(R);
9209: return [M0,M1,R];
9210: }
9211: }
9212:
9213: def spgen(MO)
9214: {
9215: Eq=(getopt(eq)==1)?1:0;
9216: Sp=getopt(sp);
9217: if(type(Sp)==7) Sp=s2sp(Sp);
9218: St=getopt(str);
9219: LP=getopt(pt);
9220: F=getopt(std);
9221: if(F!=1&&F!=-1) F=0;
9222: if(type(LP)==4){
9223: L0=LP[0]; L1=LP[1];
1.29 takayama 9224: }else if(type(LP)==1){
9225: L0=L1=LP;
1.6 takayama 9226: }else{
9227: L0=0; L1=MO+1;
9228: }
1.53 takayama 9229: if(M0<=0){
1.6 takayama 9230: MO=-MO;
9231: if(iand(MO,1)==1) return [];
1.53 takayama 9232: MO=MO/2;
9233: B=spbasic(-2*MO,0|str=1);
9234: if(L1<3) L1=MO+4;
1.6 takayama 9235: if(St!=1){
9236: for(R=[]; B!=[]; B=cdr(B)){
1.53 takayama 9237: RT= F?s2sp(car(B)|std=F): s2sp(car(B));
1.6 takayama 9238: if(length(RT)<L0 || length(RT)>L1) continue;
9239: R=cons(RT,R);
9240: }
9241: return reverse(R);
9242: }else{
9243: if(L0<=3 && L1>=MO+4) return B;
9244: for(R=[]; B!=[]; B=cdr(B)){
9245: RT=s2sp(T=car(B));
9246: if(length(RT)<L0 || length(RT)>L1) continue;
9247: if(F) T=s2sp(s2sp(T|std=K));
9248: R=cons(T,R);
9249: }
9250: return reverse(R);
9251: }
9252: }
9253: MP=(L1<MO+1)?L1:MO+1;
9254: LL=newvect(MO+1);
9255: R=newvect(MP+2);
9256: R0=newvect(MP+2);
9257: for(I=1; I<=MO; I++) LL[I]=[];
9258: if(type(Sp)==4){
9259: if(getopt(basic)==1) Sp=chkspt(Sp[6]);
9260: R=chkspt(Sp);
9261: if(R[1]>MO) return 0;
9262: LL[R[1]]=R;
9263: K=R[1];
9264: }
9265: if(K==1||type(Sp)!=4){
9266: LL[1]=[[[1]]];
9267: for(I=2; I<=MO && I<MP;I++){
9268: for(T=[], J=0; J<I+1; J++)
9269: T=cons([I-1,1],T);
9270: LL[I]=cons(T,LL[I]);
9271: }
9272: K=2;
9273: }
9274: for(OD=K; OD<MO; OD++){
9275: for(LT=LL[OD]; LT!=[]; LT=cdr(LT)){
9276: for(II=0,L=car(LT); L!=[]; II++, L=cdr(L)){
9277: R0[II]=R[II]=car(L);
9278: }
9279: for(; ;){
9280: for(S=-2*OD, I=0; I<II; I++){
9281: S += OD;
9282: if(R[I]!=[]) S-=car(R[I]);
9283: }
9284: --I;
9285: for(;S+OD<=MO && I<=MP;S+=OD,I++){
9286: if(S<=0) continue;
9287: for(J=0;J<=I;J++){
9288: if(J>=II){
9289: if(S<OD) break;
9290: }else
9291: if(S+((R[J]==[])?0:car(R[J]))<car(R0[J])) break;
9292: }
9293: if(--J>=I){
9294: V=newvect(I);
9295: RRR=[];
9296: for(;J>=0;J--){
9297: if(J>=II) RR=[OD,S];
9298: else{
9299: K=length(R[J]);
9300: RR=[S+((K==0)?0:car(R[J]))];
9301: K=length(R0[J])-K;
9302: for(RT=R0[J]; RT!=[]; K--,RT=cdr(RT)){
9303: if(K!=0) RR=cons(car(RT),RR);
9304: }
9305: }
9306: RRR=cons(reverse(RR),RRR);
9307: }
9308: RRR=qsort(reverse(RRR));
9309: if(findin(RRR,LL[S+OD])<0)
9310: LL[S+OD]=cons(RRR,LL[S+OD]);
9311: }
9312: }
9313: for(K=0; K<II; K++){
9314: if(R[K]!=[]){
9315: S=car(R[K]);
9316: while((R[K]=cdr(R[K]))!=[] && car(R[K])==S);
9317: break;
9318: }else R[K]=R0[K];
9319: }
9320: if(K>=II) break;
9321: }
9322: }
9323: }
9324: if(L0>0 || L1<MO+1 || St==1 || F){
9325: for(J=1; J<=MO; J++){
9326: for(RT=[],R=LL[J];R!=[];R=cdr(R)){
9327: L=length(T=car(R));
9328: if(L<L0 || L>L1) continue;
9329: if(F) T=s2sp(T|std=F);
9330: RT=cons((St==1)?s2sp(T):T,RT);
9331: }
9332: LL[J] = reverse(RT);
9333: }
9334: }
9335: if(Eq==1) return LL[MO];
9336: return LL;
9337: }
9338:
1.53 takayama 9339: def spbasic(Idx,D)
9340: {
9341: /*
9342: D<=3|Idx|+6, D<=|Idx|+2 (p>3), p<=|Idx|/2+4
9343: Idx=2*D^2-(D^2-\sum m_{j,\nu}^2); \sum(D-m_{j,1})>=2*D;
9344: \sum (m_{j,1)-m_{j,\nu})*m_{j,\nu)
9345: 0<=(2*D-\sum(D-m_{j,1})})*D=\sum_(m_{j,1}-m_{j,\mu})*m_{j,\nu} -|Idx|
9346: (-2,0) 13個 (9+3+?)
9347: (-4,0) 37個 (25+9+?)
9348: (-6,0) : 8.5sec ?sec 0.05sec 69個 (46+17+?)
1.54 takayama 9349: (-8,0) : 97 sec 1sec 0.13sec 113個 (73+29+?) <- (-2,0)
9350: (-10,0): 4sec 0.27sec 198個 (127+50+?)
9351: (-12,0) 28sec 4.2sec 0.64sec 291個 (182+76+?)
9352: (-14,0) 27sec 10.2sec 1.31sec 415個 (249+115+?)
9353: (-16,0) 34.0sec 2.47sec 647個 (395+172+?) <- (-4,0)
9354: (-18,0) 4.42sec 883個 (521+243+?) <- (-2,0)
9355: (-20,0) 8.17sec 1186個 (680+345+?)
1.53 takayama 9356: */
9357: Idx=-Idx;
9358: if((Str=getopt(str))!=1) Str=0;
9359: if(!isint(Idx)||!isint(Idx/2)||Idx<0||!isint(D)||D<0||D==1||D>3*Idx+6) return [];
9360: if(D==0){
9361: for(R=[],D=3*Idx+6;D>=2;D--) R=append(spbasic(-Idx,D|str=Str),R);
9362: return R;
9363: }
9364: if(!Idx){
9365: R=0;
9366: if(D==2) R="11,11,11,11";
9367: if(D==3) R="111,111,111";
9368: if(D==4) R="22,1111,1111";
9369: if(D==6) R="33,222,111111";
9370: if(!R) return [];
9371: return [(Str==1)?R:s2sp(R)];
9372: }
9373: if(D>Idx+2){
9374: L=3;
9375: if(D==3*Idx+6){
9376: 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]];
9377: return [(Str==1)?s2sp(R):R];
9378: }
9379: if(iand(D,1)&&(D-3)/2>Idx) return [];
9380: }else L=Idx/2+4;
1.54 takayama 9381: V=newvect(L);SV=newvect(L);
1.53 takayama 9382: for(S1=[],I=0;I<D;I++) S1=cons(1,S1);
9383: for(T=D-1;T>1;T--){
9384: K=D%T;
9385: if((T-K)*K<=Idx) break;
9386: }
9387: J=(T-K)*K;SJ=K^2+(D-K)*T;
9388: TV=K?[K]:[];
9389: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9390: for(I=0;I<L;I++){
1.54 takayama 9391: SV[I]=2*D^2-(I+1)*(D^2-J)-Idx;
1.53 takayama 9392: V[I]=TV;
9393: }
1.54 takayama 9394: if(SV[2]>0) return [];
1.53 takayama 9395: if(D>Idx+2 && V[0][0]+V[1][0]>=D && V[1][0]>1){
9396: T=V[1][0]-1;K=D%T;TV=K?[K]:[];
9397: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9398: V[1]=V[2]=TV;
9399: }
9400: for(R=[];;){
9401: if(D>Idx+2){
1.54 takayama 9402: if(3*V[0][0]<D) break;
9403: if(V[0][0]+V[1][0]>=D && (T=D-V[0][0]-1)>0){
1.53 takayama 9404: K=D%T;TV=K?[K]:[];
9405: for(I=(D-K)/T;I>0;I--) TV=cons(T,TV);
9406: V[1]=V[2]=TV;
9407: }
9408: S2=V[0][0]+V[1][0]+V[2][0]-D;
9409: if(V[0][0]+2*V[1][0]<D ||(S2<0&&V[1][0]==1) ){
9410: V[0]=V[1]=V[2]=nextpart(V[0]);
9411: T=V[0][0];
9412: T=D-2*T;
9413: if(T==0){
9414: V[1]=[D/2-1,1];
9415: V[2]=S1;
9416: }else if(T>0){
9417: J=D%T;
1.54 takayama 9418: K=J?[J]:[];
1.53 takayama 9419: for(J=(D-J)/T;J>0;J--) K=cons(T,K);
9420: V[2]=K;
9421: }
9422: continue;
9423: }
9424: if(S2<0||V[2][0]<=S2){
9425: V[1]=V[2]=nextpart(V[1]);
9426: continue;
9427: }else if(S2>0){
9428: T=V[2][0]-S2;J=D%T;
9429: K=J?[J]:[];
9430: for(J=(D-J)/T;J>0;J--) K=cons(T,K);
9431: V[2]=K;
9432: }
9433: }
9434: for(S=-2*D,IL=0;IL<L;IL++){
9435: S+=D-car(V[IL]);
9436: if(S>=0) break;
9437: }
1.54 takayama 9438: if((I=IL)==L){ /* reducible i.e. IL=L && S<0 */
1.53 takayama 9439: for(LL=L-1;LL>=0;LL--){
9440: if((K=car(V[LL]))+S>0){
9441: K+=S;
9442: for(TV=[],TD=D;TD>=K;TD-=K) TV=cons(K,TV);
9443: if(TD>0) V[LL]=append(TV,[TD]);
9444: else V[LL]=TV;
9445: break;
9446: }else{
9447: S+=K-1;
9448: V[LL]=S1;
9449: }
9450: }
9451: if(LL<0) break;
9452: continue;
9453: }
9454: for(S0=K=0;K<=IL;K++){
9455: ST=car(V[K]);J=V[K][length(V[K])-1];S0+=(ST-J)*J;
9456: if(S0>Idx) break;
9457: }
9458: if(S0>Idx && car(V[K])!=1){
9459: ST=car(V[K]);
9460: S0-=(ST-J)*J;
9461: for(ST--;ST>0;ST--){
9462: J=D%ST;
9463: if(S0+(ST-J)*J <= Idx) break;
9464: }
9465: V[K]=J?[J]:[];
9466: for(J=D-J;J>0;J-=ST) V[K]=cons(ST,V[K]);
9467: for(J=K+1;J<L;J++) V[J]=V[K];
9468: continue;
9469: }
9470:
9471: for(K=SS=0;K<L&&SS<=Idx;K++){
9472: ST=car(V[K]);
9473: for(S0=0,TV=cdr(V[K]);TV!=[];TV=cdr(TV)) S0+=(ST-car(TV))*car(TV);
1.54 takayama 9474: SS+=S0;
1.53 takayama 9475: }
1.54 takayama 9476: if(SS>Idx && K<=IL && K!=L){
9477: SS0=Idx-SS+S0;
9478: for(TV=car(V[K]);TV>1;TV--){
9479: U=D%TV;
9480: if((D-U)*U<=SS0) break;
9481: }
9482: if(TV==car(V[K])){
9483: K=K-1;
9484: V[K]=nextpart(V[K]); /* to be improves */
9485: }else{
9486: V[K]=U?[U]:[]; /* to be improved */
9487: for(J=D-U;J>0;J-=TV) V[K]=cons(TV,V[K]);
9488: }
1.53 takayama 9489: for(J=K+1;J<L;J++) V[J]=V[K];
9490: continue;
9491: }
9492:
9493: for(Ix=2*D^2+Idx,J=0;J<L;J++){
9494: IxF=Ix;
9495: for(Ix-=D^2,TV=V[J];TV!=[];TV=cdr(TV)) Ix+=car(TV)^2;
9496: if(Ix<=0) break;
9497: }
9498: if(Ix==0&&(J>=I||IL==2)){
9499: for(TR=[],K=J;K>=0;K--) TR=cons(V[K],TR);
9500: R=cons((Str==1)?s2sp(TR):TR,R);
9501: }
9502: if(J>=0 && J<L && Ix<=0){
9503: I=V[J][0];K=D%I;S0=(D-K)*I+K^2;
9504: if(I>1&& IxF-D^2+S0<0){
9505: for(V[J]=[],K=D-I;K>0;K--) V[J]=cons(1,V[J]);
9506: V[J]=cons(I,V[J]);
9507: V[J]=nextpart(V[J]);
9508: for(I=J+1;I<L;I++) V[I]=V[J];
9509: continue;
9510: }
9511: }
9512: if(J>=0 && J<L && Ix<=0 && car(V[J])>(U=V[J][length(V[J])-1])+1){
9513: TV=reverse(V[J]);
9514: for(S0=0,K=[];TV!=[];TV=cdr(TV),S0++){
9515: if((I=car(TV))<U+2||(length(TV)>1&&S0<2)){
9516: while(I-->0) K=cons(1,K);
9517: }else K=cons(car(TV),K);
9518: }
9519: V[I=J]=K;
9520: }else{
9521: if(J>=L) J=L-1;
9522: for(I=J;I>=0&&length(V[I])==D;I--);
9523: if(I<0) break;
9524: }
9525: V[I]=nextpart(V[I]); /* to be improved */
9526: for(J=I+1;J<L;J++) V[J]=V[I];
9527: }
9528: return R;
9529: }
9530:
1.6 takayama 9531: def spType2(L)
9532: {
9533: C=0;R=[];
9534: for(LT=L;LT!=[];LT=cdr(LT)){
9535: D=-1;LP=car(LT);
9536: for(LPT=LP;LPT!=[];LPT=cdr(LPT)){
9537: if(D==-1) D=car(LPT);
9538: else D=igcd(D,car(LPT));
9539: if(D==1){
9540: C++;break;
9541: }
9542: }
9543: if(C==2) return 0;
9544: R=cons(D,R);
9545: }
9546: if(C==0) return L;
9547: if(C==1){
9548: for(K=length(R)-1;R[K]!=1;K--);
9549: D=-1;
9550: for(I=length(R)-1;I>=0;I--){
9551: if(I==K) continue;
9552: if(D==-1) D=R[I];
9553: else D=igcd(D,R[I]);
9554: if(D==1) return 0;
9555: }
9556: }
9557: return L;
9558: }
9559:
9560:
9561: /* ret [#points, order, idx, Fuchs, reduction order, reduction exponents, fund] */
9562: def chkspt(M)
9563: {
9564: Opt= getopt(opt);
9565: Mat= getopt(mat);
9566: if(type(M)==7) M=s2sp(M);
1.28 takayama 9567: if(type(Opt) >= 0&&Opt!="idx"){
1.6 takayama 9568: if(type(Opt) == 7)
9569: Opt = findin(Opt, ["sp","basic","construct","strip","short","long","sort","root"]);
9570: if(Opt < 0){
9571: erno(2);
9572: return 0;
9573: }
9574: return fspt(M,Opt);
9575: }
9576: P = length(M);
9577: OD = -1;
9578: XM = newvect(P);
9579: Fu = 0;
9580: for( I = SM = SSM = 0; I < P; I++ ){
9581: LJ = length(M[I]);
9582: JM = JMV = 0;
9583: for(J = SM = 0; J < LJ; J++){
9584: MV = M[I][J];
9585: if(type(MV) == 4){
9586: Fu += MV[0]*MV[1];
9587: MV = MV[0];
9588: }
9589: if(MV > JMV){
9590: JM = J; JMV = MV;
9591: }
9592: SM += MV;
9593: SSM += MV^2;
9594: }
9595: if(OD < 0)
9596: OD = SM;
9597: else if(OD != SM){
1.28 takayama 9598: if(getopt(dumb)!=1) print("irregal partitions");
9599: return -1;
1.6 takayama 9600: }
9601: XM[I] = JM;
9602: }
9603: SSM -= (P-2)*OD^2;
9604: for(I = SM = JM = 0; I < P; I++){
9605: MV = M[I][XM[I]];
9606: if(type(MV) == 4){
9607: MV = MV[0]; JM = 1;
9608: }
9609: if(I == 0)
9610: SMM = MV;
9611: else if(SMM > MV)
9612: SMM = MV;
9613: SM += MV;
9614: }
9615: SM -= (P-2)*OD;
1.28 takayama 9616: if(Opt=="idx") return SSM;
1.6 takayama 9617: if(SM > SMM && SM != 2*OD){
1.28 takayama 9618: if(getopt(dumb)!=1) print("not realizable");
9619: return 0;
1.6 takayama 9620: }
9621: if(JM==1 && Mat!=1)
9622: Fu -= OD - SSM/2;
1.28 takayama 9623: return [P, OD, SSM, Fu, SM, XM, fspt(M,1)];
1.6 takayama 9624: }
9625:
9626: def cterm(P)
9627: {
9628: V = getopt(var);
9629: if(type(V) != 4)
9630: V=vars(P);
9631: for(; V !=[]; V = cdr(V))
9632: P = mycoef(P,0,car(V));
9633: return P;
9634: }
9635:
9636: def terms(P,L)
9637: {
9638: Lv=getopt(level);
9639: if(type(Lv)!=1) Lv=0;
9640: V=car(L);L=cdr(L);
9641: for(R=[],D=mydeg(P,V);D>=0; D--){
9642: if((Q=mycoef(P,D,V))==0) continue;
9643: if(L!=[]){
9644: R0=terms(Q,L|level=Lv+1);
9645: for(;R0!=[];R0=cdr(R0)) R=cons(cons(D,car(R0)),R);
9646: }else R=cons([D],R);
9647: }
9648: if(Lv>0) return R;
9649: R=qsort(R);
9650: Rev = getopt(rev); Dic=getopt(dic);
9651: if(Dic==1 && Rev==1) R=reverse(R);
9652: for(R0=[];R!=[];R=cdr(R)){
9653: for(RT=car(R),S=0;RT!=[];RT=cdr(RT)) S+=car(RT);
9654: R0=cons(cons(S,car(R)),R0);
9655: }
9656: if(Dic==1) return R0;
9657: if(Rev==1){
9658: for(R=[];R0!=[];R0=cdr(R0)){
9659: T=car(R0);
9660: R=cons(cons(-car(T),cdr(T)),R);
9661: }
9662: R0=R;
9663: }
9664: R0=qsort(R0);
9665: if(Rev==1){
9666: for(R=[];R0!=[];R0=cdr(R0)){
9667: T=car(R0);
9668: R=cons(cons(-car(T),cdr(T)),R);
9669: }
9670: R0=R;
9671: }
9672: return (Rev==1)?R0:reverse(R0);
9673: }
9674:
9675: def polcut(P,N,L)
9676: {
9677: if(type(L)==2) L=[L];
9678: M=getopt(top);
9679: if(type(M)!=1) M=0;
9680: T=terms(P,L);
9681: for(S=0;T!=[];T=cdr(T)){
9682: LT=car(T);
9683: if(LT[0]<M || LT[0]>N) continue;
9684: for(PW=1,LT=cdr(LT),V=L,Q=P;LT!=[];LT=cdr(LT),V=cdr(V)){
9685: Q=mycoef(Q,car(LT),car(V));PW*=car(V)^car(LT);
9686: }
9687: S+=Q*PW;
9688: }
9689: return S;
9690: }
9691:
9692: def redgrs(M)
9693: {
9694: Mat = getopt(mat);
9695: if(Mat!=1) Mat=0;
9696: R = chkspt(M|mat=Mat);
9697: if(type(R) < 4)
9698: return -1;
9699: if(R[4] <= 0)
9700: return 1-R[4];
9701: if(R[4] == 2*R[1])
9702: return 0;
9703: V = newvect(R[0]);
9704: Type = type(M[0][0]);
9705: if(Type > 3){
9706: Mu = Mat-1;
9707: for(I = 0; I < R[0]; I++)
9708: Mu += M[I][R[5][I]][1];
9709: }
9710: for(I = 0; I < R[0]; I++){
9711: IR = R[5][I]; L = []; MI = M[I]; MIE=MI[IR];
9712: for(J = length(MI)-1; J >= 0; J--){
9713: if(Type <= 3){
9714: VM = MI[J];
9715: if(J == IR){
9716: VM -= R[4];
9717: if(VM < 0) return -1;
9718: }
9719: L = cons(VM, L);
9720: }else{
9721: VM = MI[J][0];
9722: if(J == IR){
9723: VM -= R[4];
9724: if(VM < 0)
9725: return -1;
9726: if(I == 0)
9727: EV = 1-Mat-Mu;
9728: else
9729: EV = 0;
9730: }else{
9731: if(I == 0)
9732: EV = MI[J][1] - M[0][R[5][0]][1] + 1-Mat; /* + MX - Mu; */
9733: else
9734: EV = MI[J][1] - MIE[1] + Mu;
9735: }
9736: L = cons([VM,EV], L);
9737: /*
1.24 takayama 9738: if(R[2] >= 2){ */ /* rigid */
1.6 takayama 9739: /* P = dx^(R[1]);
9740: } */
9741: }
9742: }
9743: V[I] = L;
9744: }
9745: return [R[5], vtol(V)];
9746: }
9747:
9748: def cutgrs(A)
9749: {
9750: for(AL=[] ; A!=[]; A=cdr(A)){ /* AT: level 2 */
9751: for(ALT=[], AT=car(A); AT!=[]; AT=cdr(AT)){
9752: M = (type(car(AT)) < 4)?car(AT):car(AT)[0];
9753: if(M > 0)
9754: ALT = cons(car(AT), ALT); /* ALT: level 2 */
9755: }
9756: AL = cons(reverse(ALT), AL); /* AL: level 3 */
9757: }
9758: return reverse(AL);
9759: }
9760:
9761: def mcgrs(G, R)
9762: {
9763: NP = length(G);
9764: Mat = (getopt(mat)==1)?0:1;
1.36 takayama 9765: if(Mat==0 && type(SM=getopt(slm))==4){
1.24 takayama 9766: SM0=SM[0];SM1=anal2sp(SM[1],["*",-1]);
9767: if(findin(0,SM0)>=0){
9768: for(SM=[],I=length(G)-1;I>0;I--)
9769: if(findin(I,SM0)<0) SM=cons(I,SM);
9770: SM=[SM,SM1];
1.36 takayama 9771: G=mcgrs(G,R|mat=1,slm=SM);
1.24 takayama 9772: return [G[0],anal2sp(G[1],["*",-1])];
9773: }
9774: }else SM0=0;
1.6 takayama 9775: for(R = reverse(R) ; R != []; R = cdr(R)){
9776: GN = [];
9777: L = length(G)-1;
9778: RT = car(R);
9779: if(type(RT) == 4){
1.37 takayama 9780: if(length(RT)==L+1&&RT[0]!=0){
9781: R=cons(cdr(RT),cdr(R));
1.24 takayama 9782: R=cons(RT[0],R);
1.37 takayama 9783: R=cons(0,R);
1.24 takayama 9784: continue;
9785: } /* addition */
9786: RT = reverse(RT); S = ADS = 0;
1.37 takayama 9787: for(G = reverse(G); G != []; G = cdr(G), L--, RT=cdr(RT)){
9788: AD = car(RT);
1.24 takayama 9789: if(L > 0){
1.6 takayama 9790: S += AD;
1.24 takayama 9791: if(SM && findin(L,SM0)>=0) ADS+=AD;
9792: }else
1.6 takayama 9793: AD = -S;
9794: for(GTN = [], GT = reverse(car(G)); GT != []; GT = cdr(GT))
9795: GTN = cons([car(GT)[0],car(GT)[1]+AD], GTN);
9796: GN = cons(GTN, GN);
9797: }
9798: G = GN;
1.24 takayama 9799: if(SM0){
9800: for(ST=reverse(SM1),SM1=[]; ST!=[]; ST=cdr(ST))
9801: SM1 = cons([car(ST)[0],car(ST)[1]+ADS], SM1);
9802: }
1.6 takayama 9803: continue;
9804: }
1.24 takayama 9805: if(RT==0) continue;
9806: VP = newvect(L+1); GV = ltov(G); /* middle convolution */
1.6 takayama 9807: for(I = S = OD = 0; I <= L; I++){
9808: RTT = (I==0)?(Mat-RT):0;
9809: VP[I] = -1;
1.24 takayama 9810: for(J = M = K = 0, GT = GV[I]; GT != []; GT = cdr(GT), J++){
1.6 takayama 9811: if(I == 0)
9812: OD += car(GT)[0];
9813: if(car(GT)[1] == RTT && car(GT)[0] > M){
9814: S += car(GT)[0]-M;
1.36 takayama 9815: M=car(GT)[0];
1.6 takayama 9816: VP[I] = J;
9817: }
9818: }
1.24 takayama 9819: }
9820: S -= (L-1)*OD;
9821: for(GN = []; L >= 0; L--){
9822: GT = GV[L];
9823: RTT = (L==0)?(-RT):RT;
1.38 takayama 9824: GTN = (VP[L]>=0 || S == 0)?[]:[[-S,(L==0)?(Mat-RT):0]];
1.24 takayama 9825: for(J = 0; GT != []; GT = cdr(GT), J++){
9826: if(J != VP[L]){
9827: GTN = cons([car(GT)[0],car(GT)[1]+RTT], GTN);
9828: continue;
1.6 takayama 9829: }
1.24 takayama 9830: K = car(GT)[0] - S;
9831: if(K < 0){
9832: print("Not realizable");
9833: return;
9834: }
1.38 takayama 9835: if(K>0) GTN = cons([K,(L==0)?(Mat-RT):0], GTN);
1.24 takayama 9836: }
9837: GN = cons(reverse(GTN), GN);
9838: }
1.36 takayama 9839: if(SM0&&RT!=0){
9840: for(M0=M1=-OD,L=length(G)-1;L>=0;L--){
9841: if(findin(L,SM0)>=0){
9842: M0+=OD;
9843: if(VP[L]>=0) M0-=GV[L][VP[L]][0];
9844: }else{
9845: M1+=OD;
9846: if(VP[L]>=0) M1-=GV[L][VP[L]][0];
9847: }
9848: }
9849: SM2=[];
9850: if((Mx1=anal2sp(SM1,["max",1,-RT])[0])<0){
9851: if(M1>0) SM2=cons([M1,0],SM2);
1.38 takayama 9852: }else M1+=car(SM1[Mx1]);
1.36 takayama 9853: if((Mx0=anal2sp(SM1,["max",1,0])[0])<0){
9854: if(M0>0) SM2=cons([M0,RT],SM2);
1.38 takayama 9855: }else M0+=car(SM1[Mx0]);
1.36 takayama 9856: for(J=0;SM1!=[];J++,SM1=cdr(SM1)){
9857: if(J==Mx0){
9858: if(M0>0) SM2=cons([M0,-RT],SM2);
9859: }else if(J==Mx1){
9860: if(M1>0) SM2=cons([M1,0],SM2);
9861: }else SM2=cons([car(SM1)[0],car(SM1)[1]+RT],SM2);
1.6 takayama 9862: }
1.36 takayama 9863: SM1=reverse(SM2);
1.6 takayama 9864: }
9865: G = cutgrs(GN);
9866: }
1.36 takayama 9867: return SM0?[G,SM1]:G;
1.6 takayama 9868: }
9869:
1.38 takayama 9870: def spslm(M,TT)
9871: {
9872: R=getbygrs(M,1|mat=1);
9873: if(type(R)!=4||type(R[0])!=4||type(S=R[0][1])!=4){
9874: errno(0);return0;
9875: }
9876: if(S[1]!=[[1,0]]){
9877: print("Not rigid!");return0;
9878: }
9879: if((F=S[0][0][1])!=0){
9880: for(V=vars(F);V!=[];V=cdr(V)){
9881: if(mydeg(F,car(V))==1){
9882: T=lsol(F,car(V));
9883: break;
9884: }
9885: }
9886: if(V==[]){
9887: print("Violate Fuchs condition!");
9888: return0;
9889: }
9890: }
9891: for(P=[];R!=[];R=cdr(R))
9892: P=cons(car(R)[0],P);
9893: if(F!=0){
9894: S=mysubst(S,[car(V),T]);P=mysubst(P,[car(V),T]);
9895: }
9896: return mcgrs(S,P|mat=1,slm=[TT,[[1,0]]]);
9897: }
9898:
1.6 takayama 9899: /*
9900: F=0 : unify
9901: F=["add",S] :
9902: F=["sub",S] :
9903: F=["+",A,B] :
9904: F=["*",A,B] :
9905: F=["mul",K];
9906: F=["get",F,V] :
9907: F=["put",F,V] :
9908: F=["get1",F,V] :
9909: F=["put1",F,V] :
1.24 takayama 9910: F=["max"] :
9911: F=["max",F.V] :
1.6 takayama 9912: F=["put1"] :
9913: F=["val",F];
9914: F=["swap"];
9915: */
9916: def anal2sp(R,F)
9917: {
9918: if(type(F)==4&&type(F[0])==4){ /* multiple commands */
9919: for(;F!=[];F=cdr(F)) R=anal2sp(R,car(F));
9920: return R;
9921: }
9922: if(type(F)==7) F=[F];
9923: if(F==0){ /* unify */
9924: R=ltov(R);
9925: L=length(R);
9926: for(J=1;J<L;J++){
9927: for(I=0;I<J;I++){
9928: if(cdr(R[I])==cdr(R[J])){
9929: R[I]=cons(R[I][0]+R[J][0],cdr(R[I]));
9930: R[J]=cons(0,cdr(R[J]));
9931: break;
9932: }
9933: }
9934: }
9935: for(G=[],I=L-1;I>=0;I--)
9936: if(R[I][0]!=0) G=cons(R[I],G);
9937: if(length(G[0])==2){ /* sort by multiplicity */
9938: R=ltov(G);
9939: L=length(R);
9940: for(I=1;I<L;I++){
9941: for(J=I;J>0;J--){
9942: if(R[J-1][0]>R[J][0]) break;
9943: if(R[J-1][0]==R[J][0]){
9944: S1=rtostr(R[J-1][1]);S2=rtostr(R[J][1]);
9945: if((K=str_len(S1)-str_len(S2))<0) break;
9946: if(!K&&S1<S2) break;
9947: }
9948: S=R[J-1];R[J-1]=R[J];R[J]=S;
9949: }
9950: }
9951: G=vtol(R);
9952: }
9953: return G;
9954: }
9955: if(F[0]=="add") return append(R,F[1]);
1.24 takayama 9956: if(F[0]=="max"){
9957: if(length(F)==3) C=1;
9958: else C=0;
9959: M=-10^10;K=[-1];
9960: for(I=0;R!=[];R=cdr(R),I++){
9961: if(C>0&&car(R)[F[1]]!=F[2]) continue;
9962: if(M<car(R)[0]){
9963: M=car(R)[0];K=[I,car(R)];
9964: }
9965: }
9966: return K;
9967: }
1.6 takayama 9968: R=reverse(R);
9969: if(F[0]=="sub"){
9970: for(S=F[1];S!=[];S=cdr(S))
9971: R=cons(cons(-car(S)[0],cdr(car(S))),R);
9972: return reverse(R);
9973: }
9974: if(F[0]=="swap"){
9975: for(G=[];R!=[];R=cdr(R))
9976: G=cons([car(R)[0],car(R)[2],car(R)[1]],G);
9977: return G;
9978: }
9979: if(F[0]=="+"){
1.24 takayama 9980: L=length(F);
9981: for(G=[];R!=[];R=cdr(R)){
9982: for(S=[],I=L-1;I>0;I--) S=cons(car(R)[I]+F[I],S);
9983: G=cons(cons(car(R)[0],S),G);
9984: }
1.6 takayama 9985: return G;
9986: }
9987: if(F[0]=="*"){
1.24 takayama 9988: L=length(F);
9989: for(G=[];R!=[];R=cdr(R)){
9990: for(S=0,I=1;I<L;I++) S+=car(R)[I]*F[I];
9991: G=cons([car(R)[0],S],G);
9992: }
1.6 takayama 9993: return G;
9994: }
9995: if(F[0]=="mult"){
9996: K=F[1];
9997: for(G=[];R!=[];R=cdr(R)) G=cons(cons(K*car(R)[0],cdr(car(R))),G);
9998: return G;
9999: }
10000: if(F[0]=="get"){
10001: for(G=[];R!=[];R=cdr(R))
10002: if(car(R)[F[1]]==F[2]) G=cons(car(R),G);
10003: return G;
10004: }
10005: if(F[0]=="put"){
10006: if(F[1]==1){
10007: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[2]],G);
10008: }else{
10009: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
10010: }
10011: return G;
10012: }
10013: if(F[0]=="get1"){
10014: if(length(F)==2){
10015: for(G=[];R!=[];R=cdr(R)) G=cons([R[0][0],car(R)[F[1]]],G);
10016: return G;
10017: }
10018: for(G=[];R!=[];R=cdr(R))
10019: if(car(R)[F[1]]==F[2]) G=cons([R[0][0],car(R)[3-F[1]]],G);
10020: return G;
10021: }
10022: if(F[0]=="put1"){
10023: if(length(F)==1)
10024: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],car(R)[1]],G);
10025: else if(F[1]==1)
10026: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],F[2],car(R)[1]],G);
10027: else{
10028: for(G=[];R!=[];R=cdr(R)) G=cons([car(R)[0],car(R)[1],F[2]],G);
10029: }
10030: return G;
10031: }
10032: if(F[0]=="val"){
10033: V=(length(F)==1)?1:F[1];
10034: for(I=J=0;R!=[];R=cdr(R)){
10035: I+=car(R)[0];
10036: J+=car(R)[0]*car(R)[V];
10037: }
10038: return [I,J];
10039: }
10040: return 0;
10041: }
10042:
10043: /*
10044: G=0 get trivial common spct
10045: G="..,..," spectre type of 4 singular points
10046: P=["get"] all spct
10047: P=["get",L]
10048: L=n for variable x_n
10049: L=[m,n] for residue [m,n]
1.23 takayama 10050: L=[m,n,l] for residue [m,n,l]
1.6 takayama 10051: L=[[m,n],[m',n']] for common spct
1.23 takayama 10052: P=["eigen",I] decomposition of A_I
1.6 takayama 10053: P=["get0",[m,n],[m',n']] for the sum of residues
1.23 takayama 10054: P=["rest",[m,n]] restriction
1.6 takayama 10055: P=["swap",[m,n]] for symmetry
10056: P=["perm",[...]] for symmetry
10057: P=["deg"]
10058: P=["homog"]
10059: P=["sort"]
10060: P=[[[m,n],c],...] for addition
10061: P=[c] or [[c],...] for middle convolution wrt 0
10062: P=[m,c] or [[m,c],...] for general middle convolution
10063: P=[[a,b,c]] for special additions
10064: P=[[d,a,b,c]] for middle convotution and additions
10065: P=["multi",...] multiple commands
10066: P=0,1,3 : return sim. spectre of 4 singular points
10067: */
10068: def mc2grs(G,P)
10069: {
10070: if(G==0){
10071: G=[];
10072: for(I=4;I>=0;I--){
10073: V=lsort([0,1,2,3,4],[I],1);
10074: for(J=1;J<4;J++){
10075: for(T=[],K=3;K>0;K--)
10076: if(K!=J) T=cons(V[K],T);
10077: G=cons([[[V[0],V[J]],T],[1,0,0]],G);
10078: }
10079: }
10080: G=mc2grs(G,"sort");
10081: }else if(type(G)==7||(type(G)==4&&length(G)==4)){
10082: if(type(G)==7) G=s2sp(G);
10083: F=(getopt(top)==0)?1:0;
10084: K=[];
10085: if(type(P)==1&&iand(P,1)&&type(G[0][0])<4){
10086: G=s2sp(G|std=1);
10087: if(F) G=[G[1],G[2],G[3],G[0]];
10088: G=sp2grs(G,[d,c,b,a],[1,length(G[0]),-1]|mat=1);
10089: G=reverse(G);
10090: if(iand(P,3)==3){
10091: V=vars(G);
10092: for(H=L=[a,b,c,d];H!=[];H=cdr(H))
10093: if(findin(car(H),V)>=0) G=subst(G,car(H),makev([car(H),1]));
10094: G=shortv(G,[a,b,c,d]);
10095: V=vars(G);
10096: for(H=G[3];H!=[];H=cdr(H)){
10097: T=car(H)[1];
10098: if(type(T)>1&&!isvar(T)){
10099: K=[car(H)[0],T];
10100: break;
10101: }
10102: }
10103: }
10104: F=1;
10105: }
10106: if(F) G=[G[3],G[0],G[1],G[2]];
10107: S=cons(["anal",1],getopt());
10108: if(!(R=m2mc(G,0|option_list=S))) return R;
10109: for(G=0,R=cdr(R);R!=[];R=cdr(R)){
10110: TR=car(R)[0];
10111: if(TR[0]) G=mc2grs(G,[[TR[0]]]);
10112: G=mc2grs(G,[cdr(TR)]);
10113: }
10114: if(type(P)==1&&K!=[]){
10115: for(T=10;T<36;T++){
10116: if(findin(X=makev([T]),V)>=0) continue;
10117: F=K[0]*(X-K[1]);
10118: return [F,simplify(G,[F],4)];
10119: }
10120: }
10121: }
10122: if(type(P)<2) return G;
10123: F=0;
1.25 takayama 10124: if(type(P)==7||(type(P)==4&&
10125: (type(P[0])<4||(type(P[0])==4&&length(P[0])==2&&type(P[0][0])<4&&type(P[1])<4))
10126: )) P=[P];
1.6 takayama 10127: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
10128: Keep=(Dvi==2)?1:0;
10129: if(type(P)==4&&type(F=car(P))==7){
10130: if(F=="mult"){
10131: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
10132: return G;
10133: }
10134: if(F=="show"){
10135: for(R=str_tb(0,0);G!=[];){
10136: L=car(G);
10137: I=L[0][0];J=L[0][1];
10138: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1])
10139: +"}]&=\\left\\{",R);
10140: for(L=cdr(L);;){
10141: S=car(L);
10142: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
10143: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
10144: if((L=cdr(L))==[]) break;
10145: str_tb(",\\,",R);
10146: }
10147: str_tb("\\right\\}",R);
10148: if((G=cdr(G))==[]) break;
10149: str_tb(",\\\\\n",R);
10150: }
10151: R=texbegin("align*",str_tb(0,R));
10152: if(Dvi!=-1) dviout(R|keep=Keep);
10153: return R;
10154: }
10155: if(F=="show0"){
1.26 takayama 10156: if(type(Fig=getopt(fig))>0){
10157: PP=[[-1.24747,-5.86889],[1.24747,-5.86889],[3.52671,-4.8541],[5.19615,-3],
10158: [5.96713,-0.627171],[5.70634,1.8541],[4.45887,4.01478],[2.44042,5.48127],
10159: [0,6],[-2.44042,5.48127],[-4.45887,4.01478],[-5.70634,1.8541],
10160: [-5.96713,-0.627171],[-5.19615,-3],[-3.52671,-4.8541]];
10161: PL=[[1.8,-5.2],[5.7,-1.7],[3.2,5],[-3.6,4.7],[2.2,3],[-2.8,2.8],
10162: [-1.5,-1.4],[-3.2,-2.5],[0.76,-1.4],[-2,0.2]];
10163: PC=["black,dashed","green,dashed","red,dashed","blue,dashed",
10164: "black","cyan","green","blue","red","magenta"];
10165: N=["1","2","3","4","5","6","7","8","9","a","b","c","d","e","f"];
10166: 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],
10167: [2,9,14],[3,6,13]];
10168: TB=str_tb("\\draw\n",TB);
10169: if(type(Fig)==4){
10170: if(type(car(Fig))==1){
10171: PP=ptaffine(car(Fig)/12,PP);PL=ptaffine(car(Fig)/12,PL);
10172: Fig=cdr(Fig);
10173: }
10174: if(Fig!=[]&&length(Fig)==10) PC=Fig;
10175: }
10176: for(R=mc2grs(G,"show0"|dviout=-1),I=0;R!="";I++){ /* 頂点 */
10177: J=str_chr(R,0,",");
10178: if(J>0){
10179: S=str_cut(R,0,J-1);
10180: R=str_cut(R,J+1,1000);
10181: }else{
10182: S=R;R="";
10183: }
10184: T=(str_chr(S,0,"1")==0)?"":"[red]";
10185: str_tb(["node",T,"(",N[I],") at ",xypos(PP[I]),"{$",S,"$}\n"],TB);
10186: }
10187: for(S=PC,P=PL,I=0;I<4;I++){
10188: for(J=I+1;J<5;J++,S=cdr(S),P=cdr(P)){ /* 線の番号 */
10189: SS=car(S);
10190: if((K=str_chr(SS,0,","))>0) SS=sub_str(SS,0,K-1);
10191: str_tb(["node[",SS,"] at ",xypos(car(P)),
10192: "{$[",rtostr(I),rtostr(J),"]$}\n"],TB);
10193: }
10194: }
10195: str_tb(";\n",TB);
10196: for(I=0;I<10;I++){ /* 線 */
10197: S=car(PC);P0=car(PC);L0=car(LL);PC=cdr(PC);LL=cdr(LL);
10198: C=[N[L0[0]-1],N[L0[1]-1],N[L0[2]-1]];
10199: str_tb(["\\draw[",S,"] (", C[0],")--(",C[1],") (",
10200: C[0],")--(",C[2],") (",C[1],")--(",C[2],");\n"],TB);
10201: }
10202: R=str_tb(0,TB);
10203: if(TikZ==1&&Dvi!=-1) dviout(xyproc(R)|dviout=1,keep=Keep);
10204: return R;
10205: }
1.6 takayama 10206: for(S="",L=[];G!=[];G=cdr(G)){
10207: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
10208: TL=msort(TL,[-1,0]);
10209: if(Dvi){
10210: if(S!="") S=S+",";
10211: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
10212: if(car(T)==I) J++;
10213: else{
10214: if(I>0&&J>0){
10215: if(I>9) S=S+"("+rtostr(I)+")";
10216: else S=S+rtostr(I);
10217: if(J>1){
10218: if(J>9) S=S+"^{"+rtostr(J)+"}";
10219: else S=S+"^"+rtostr(J);
10220: }
10221: }
10222: I=car(T);J=1;
10223: }
10224: }
10225: }
10226: L=cons(TL,L);
10227: }
10228: if(Dvi){
1.43 takayama 10229: if(Dvi!=-1) dviout(S|eq=0);
1.6 takayama 10230: return S;
10231: }
10232: return reverse(L);
10233: }
10234: if(F=="sort"){
10235: G=ltov(G);L=length(G);
10236: for(I=0;I<L;I++){
10237: S=G[I][0];
10238: if(S[0][0]>S[0][1]) S=[[S[0][1],S[0][0]],S[1]];
10239: if(S[1][0]>S[1][1]) S=[S[0],[S[1][1],S[1][0]]];
10240: if(S[0]>S[1]){
10241: F=0;S=[S[1],S[0]];
10242: }
10243: if(S!=G[I][0]){
10244: if(F==0) G[I]=cons(S,anal2sp(cdr(G[I]),"swap"));
10245: else G[I]=cons(S,cdr(G[I]));
10246: }
10247: for(J=I;J>0;J--){
10248: if(G[J-1][0]<G[J][0]) break;
10249: S=G[J-1];G[J-1]=G[J];G[J]=S;
10250: }
10251: }
10252: return vtol(G);
10253: }
10254: if(F=="get"||F=="get0"){
10255: if(Dvi!=0) F="get";
10256: if(length(P)==1||type(P[1])<2){
10257: L=[];
10258: if(length(P)==1){
10259: for(I=3;I>=0;I--){
10260: for(J=4;J>I;J--) L=cons(mc2grs(G,[F,[I,J]]),L);
10261: }
10262: }else{
10263: for(I=P[1],J=4;J>=0;J--){
10264: if(I==J) continue;
10265: L=cons(mc2grs(G,[F,(I<J)?[I,J]:[J,I]]),L);
10266: }
10267: }
10268: if(Dvi){
10269: if(length(L)==10){
10270: R=ltov(L);
10271: if(R[6][0]==[1,4]){
10272: S=R[6];R[6]=R[7];R[7]=S;
10273: L=vtol(R);
10274: }
10275: }
10276: for(R=S=[],L=reverse(L);L!=[];L=cdr(L)){
10277: T=car(L);
10278: R=cons(cdr(T),R);
10279: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
10280: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
10281: }
10282: L=ltotex(R|opt="GRS",pre=S);
1.26 takayama 10283: if(type(D=getopt(div))==1 || type(D)==4) L=divmattex(L,D);
1.6 takayama 10284: if(Dvi>0) dviout(L|eq=0,keep=Keep);
10285: }
10286: return L; /* get all spct */
10287: }
10288: if(type(T=P[1])==4){
10289: if(F=="get0"&&length(P)==3&&type(I=P[1])==4&&type(J=P[2])==4){
10290: if(I[0]>I[1]) I=[I[1],I[0]];
10291: if(J[0]>J[1]) J=[J[1],J[0]];
10292: if(I[0]>I[0]){S=I;I=J;J=S;};
10293: K=lsort(I,J,0);
10294: if(length(K)==4){
1.24 takayama 10295: S=mc2grs(G,["get0",[I,J]]);
1.6 takayama 10296: return anal2sp(S,[["*",1,1],0]);
10297: }
10298: I=lsort(K,lsort(I,J,2),1);
10299: S=lsort([0,1,2,3,4],K,1);
1.24 takayama 10300: D=mc2grs(G,"deg");
1.6 takayama 10301: if(findin(4,S)<0) D=-D;
1.24 takayama 10302: J=mc2grs(G,["get0",[I,S]]);
1.6 takayama 10303: if(I[0]>S[0]) J=sp2grs(J,"swap");
10304: return anal2sp(J,[["+",0,D],["*",-1,1]]);
10305: }
10306: if(type(car(T))==4){
10307: if(T[0][0]>T[0][1]) T=[[T[0][1],T[0][0]],T[1]];
10308: if(T[1][0]>T[1][1]) T=[T[0],[T[1][1],T[1][0]]];
10309: if(T[0][0]>T[1][0]) T=[T[1],T[0]];
10310: for(PG=G;PG!=[];PG=cdr(PG))
10311: if(car(PG)[0]==T) return (F=="get")?car(PG):cdr(car(PG));
10312: return []; /* get common spct */
10313: }
1.23 takayama 10314: if(length(T)==3){
10315: T0=T;T=lsort([0,1,2,3,4],T,1);
10316: if(length(T)!=2) return [];
10317: }else T0=0;
1.6 takayama 10318: if(T[0]>T[1]) T=[T[1],T[0]];
10319: for(FT=0,PG=G;PG!=[];PG=cdr(PG)){
10320: if(car(PG)[0][0]==T){
10321: FT=1;break;
10322: }
10323: if(car(PG)[0][1]==T){
10324: FT=2;break;
10325: }
10326: }
10327: if(!FT) return [];
10328: L=anal2sp(cdr(car(PG)),[["get1",FT],0]);
1.23 takayama 10329: if(T0!=0){
10330: if((K=mc2grs(G,"deg"))!=0){
10331: if(T[1]!=4) K=-K;
10332: R=reverse(L);
10333: for(L=[];R!=[];R=cdr(R)) L=cons([car(R)[0],car(R)[1]+K],L);
10334: }
10335: T=T0;
10336: }
1.6 takayama 10337: return (F=="get")?cons(T,L):L;
10338: }
10339: }
1.27 takayama 10340: if(F=="rest"||F=="eigen"||F=="rest0"||F=="rest1"){
1.79 takayama 10341: if((Hg=getopt(homog))!=0) Hg=1;
10342: if(F!="eigen"&&Hg) G=mc2grs(G,"homog");
1.26 takayama 10343: if(length(P)==1){
10344: for(R=[],I=0;I<4;I++){
10345: for(J=I+1;J<5;J++){
1.79 takayama 10346: S=mc2grs(G,[F,[I,J]]|homog=Hg);
1.27 takayama 10347: if(S!=[]) R=cons(cons([I,J],S),R);
1.26 takayama 10348: }
10349: }
10350: R=reverse(R);
10351: if(Dvi){
10352: TB=str_tb(0,0);
1.27 takayama 10353: if(F=="rest0"||F=="rest1"){
1.26 takayama 10354: for(T=R;;){
10355: TT=car(T);
10356: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
10357: str_tb(["[",S,"]","&: "],TB);
10358: for(TR=[],TT=cdr(TT);TT!=[];TT=cdr(TT))
10359: TR=cons(car(TT)[1],TR);
10360: for(TR=qsort(TR);TR!=[];TR=cdr(TR))
10361: str_tb([s2sp(car(TR)|short=1,std=-1),"\\ \\ "],TB);
10362: if((T=cdr(T))==[]) break;
10363: str_tb("\\\\\n",TB);
10364: }
10365: }else{
10366: TB=str_tb(0,0);
10367: for(T=R;;){
10368: TT=car(T);
10369: S=rtostr(car(TT)[0])+rtostr(car(TT)[1]);
10370: str_tb(["[",S,"]",":\\ "],TB);
10371: for(TR=[],TT=cdr(TT);;){
10372: T0=car(TT);
10373: str_tb(["&",my_tex_form(car(T0)),"&&\\to\\ \n",
10374: ltotex(cdr(T0)|opt="GRS")],TB);
10375: if((TT=cdr(TT))==[]) break;
10376: str_tb("\\\\\n",TB);
10377: }
10378: if((T=cdr(T))==[]) break;
10379: str_tb("\\allowdisplaybreaks\\\\\n",TB);
10380: }
10381: }
10382: R=texbegin("align*",str_tb(0,TB));
10383: if(Dvi!=-1) dviout(R|keep=Keep);
10384: }
10385: return R;
10386: }
1.23 takayama 10387: I=P[1];
10388: if(I[0]>I[1]) I=[I[1],I[0]];
10389: L=lsort([0,1,2,3,4],I,1);
1.29 takayama 10390: if(F=="rest"&&length(P)==3){
10391: J=P[2];if(J[0]>J[1]) J=[J[1],J[0]];
10392: L=lsort(L,J,1);
10393: if(length(L)!=1) return 0;
10394: return [mc2grs(G,["get0",I]),mc2grs(G,["get0",[I[0],J[0]],[I[1],J[1]]]),
10395: mc2grs(G,["get0",[I[0],J[1]],[I[1],J[0]]]),mc2grs(G,["get0",[I[0],I[1],L[0]]])];
10396: }
1.23 takayama 10397: L=[[L[0],L[1]],[L[0],L[2]],[L[1],L[2]]];
1.24 takayama 10398: if(F!="eigen"){
10399: if(I==[0,4]) L=reverse(L);
10400: else{
10401: for(V=[],J=2;J>=0;J--){
10402: if(L[J][0]==0) V=cons([L[J][1],J],V);
10403: else{
10404: for(K=4;K>=0;K--){
10405: if(findin(K,L[J])<0){
10406: V=cons([K,J],V);break;
10407: }
10408: }
10409: }
10410: }
10411: V=qsort(V);
10412: L=[L[V[0][1]],L[V[1][1]],L[V[2][1]]];
10413: }
10414: }
1.23 takayama 10415: for(LL=[],T=L;T!=[];T=cdr(T))
10416: LL=cons(mc2grs(G,["get0",[I,car(T)]]),LL);
10417: LL=reverse(LL);
10418: for(R=[],Q=mc2grs(G,["get0",I]);Q!=[];Q=cdr(Q)){
1.24 takayama 10419: for(T=[],J=2;J>=0;J--){
10420: V=anal2sp(LL[J],["get1",(I[0]<L[J][0])?1:2,car(Q)[1]]);
10421: if(F=="rest"){
10422: if(I[0]==0){
10423: if(I[1]!=4){
10424: if(L[J][1]!=4) V=anal2sp(V,["+",-car(Q)[1]]);
10425: }else if (L[J][0]!=2) V=anal2sp(V,["+",-car(Q)[1]]);
10426: }else if(L[J][0]!=0) V=anal2sp(V,["+",-car(Q)[1]]);
10427: }
10428: T=cons(V,T);
10429: }
1.23 takayama 10430: R=cons(cons(car(Q)[1],T),R);
10431: }
1.27 takayama 10432: if(F=="rest0"||F=="rest1"){
10433: for(L=[];R!=[];R=cdr(R)){
10434: TR=cdr(car(R));
1.28 takayama 10435: if(F=="rest1"&&chkspt(TR|opt="idx")==2) continue;
1.27 takayama 10436: L=cons([car(R)[0],s2sp(chkspt(TR|opt=6))],L);
10437: }
1.23 takayama 10438: R=reverse(L);
10439: }
10440: return R;
10441: }
1.6 takayama 10442: if(F=="deg"){
10443: for(S=I=0;I<3;I++){
10444: for(J=I+1;J<4;J++){
10445: L=mc2grs(G,["get0",[I,J]]);
10446: L=anal2sp(L,"val");
10447: S+=L[1];
10448: }
10449: }
10450: return S/L[0];
10451: }
1.27 takayama 10452: if(F=="spct"||F=="spct1"){
10453: K=(F=="spct")?5:6;
1.6 takayama 10454: G=mc2grs(G,"get");
1.27 takayama 10455: M=newmat(5,K);
1.6 takayama 10456: for(;G!=[];G=cdr(G)){
10457: GT=car(G);I=GT[0][0];J=GT[0][1];
10458: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
10459: L=cons(car(GT)[0],L);
10460: }
10461: L=reverse(qsort(L));
10462: M[I][J]=M[J][I]=L;
10463: }
10464: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
10465: for(I=0;I<5;I++){
10466: S=-2*D^2;
10467: for(J=0;J<5;J++){
10468: if(I==J) continue;
10469: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
10470: }
10471: M[I][I]=S;
1.27 takayama 10472: if(K==6){
10473: for(S=[],J=4;J>=0;J--)
10474: if(I!=J) S=cons(M[I][J],S);
10475: R=chkspt(S|opt=2);
10476: M[I][5]=((L=length(R))>1)?s2sp(R[L-2]|short=1):"";
10477: }
1.6 takayama 10478: }
10479: if(Dvi){
10480: S=[];
10481: for(I=4;I>=0;I--){
1.27 takayama 10482: L=(K==6)?[M[I][5]]:[];
10483: L=cons(M[I][I],L);
1.6 takayama 10484: for(J=4;J>=0;J--){
10485: if(I==J) L=cons("",L);
10486: else L=cons(s2sp([M[I][J]]),L);
10487: }
10488: S=cons(L,S);
10489: }
1.27 takayama 10490: T=(K==6)?["reduction"]:[];
10491: S=cons(append([x0,x1,x2,x3,x4,"idx"],T),S);
10492: M=ltotex(S|opt="tab",hline=[0,1,z],
1.41 takayama 10493: vline=(K==6)?[0,1,z-2,z-1,z]:[0,1,z-1,z],
1.26 takayama 10494: left=["","$x_0$","$x_1$","$x_2$","$x_3$","$x_4$"]);
1.6 takayama 10495: if(Dvi>0) dviout(M|keep=Keep);
10496: }
10497: return M;
10498: }
10499: if(F=="swap"||F=="perm"){
10500: if(F=="perm") TR=P[1];
10501: else{
10502: TR=newvect(5,[0,1,2,3,4]);
10503: K=P[1][0];L=P[1][1];
10504: TR[K]=L;TR[L]=K;
10505: if(TR[4]!=4) G=mc2grs(G,"deg");
10506: }
10507: V=newvect(2);
10508: for(L=[],T=G;T!=[];T=cdr(T)){
10509: TP=car(T)[0];
10510: for(TQ=[],I=1;I>=0;I--){
10511: V=[TR[TP[I][0]],TR[TP[I][1]]];
10512: if(V[0]>V[1]) V=[V[1],V[0]];
10513: TQ=cons(V,TQ);
10514: }
10515: if(TQ[0][0]<TQ[1][0]){
10516: L=cons(cons(TQ,cdr(car(T))),L);
10517: continue;
10518: }
10519: TQ=[[TQ[1],TQ[0]]];
10520: for(TP=cdr(car(T));TP!=[];TP=cdr(TP))
10521: TQ=cons([car(TP)[0],car(TP)[2],car(TP)[1]],TQ);
10522: L=cons(reverse(TQ),L);
10523: }
10524: return mc2grs(L,"sort");
10525: }
10526: if(F=="homog"){
10527: V=mc2grs(G,"deg");
10528: return mc2grs(G,[[[2,3],-V]]);
10529: }else if(F=="deg"){
10530: R=mc2grs(G,4);
10531: for(V=0;R!=[];R++){
10532: for(TR=cdr(R);TR!=[];TR=cdr(TR))
10533: V+=car(TR)[0]*car(TR)[1];
10534: }
10535: return -V;
10536: }
10537: }
10538: if(type(F)!=4) return 0;
10539: if(type(P[0])!=4) P=[P];
10540: for(;P!=[];P=cdr(P)){
10541: if(type((S=P[0])[0])==4){ /* addition */
10542: T=P[0][0];
10543: if(T[0]>T[1]) T=[T[1],T[0]];
10544: T1=[T[0],4];T2=[T[1],4];
10545: for(L=[],PG=reverse(G);PG!=[];PG=cdr(PG)){
10546: R=car(PG);R0=R[0];F=0;K=P[0][1];
10547: if(R0[0]==T) F=1;
10548: else if(R0[1]==T) F=2;
10549: else if(getopt(unique)!=1){
10550: K=-K;
10551: if(R0[0]==T1||R0[0]==T2) F=1;
10552: else if(R0[1]==T1||R0[1]==T2) F=2;
10553: }
10554: if(F==0) L=cons(R,L);
10555: else{
10556: R1=anal2sp(cdr(R),(F==1)?["+",K,0]:["+",0,K]);
10557: L=cons(cons(R0,R1),L);
10558: }
10559: }
10560: G=L;
10561: }else if(type(S[0])<4){
10562: if(length(S)==1){ /* mc wrt0 4:cases */
10563: U=mc2grs(G,"deg");
10564: C=P[0][0];
10565: L=[];
10566: /* [[0,1],[2,3]] : [K=[0,k],J=[i,j]], S=[k,4] : 3 cases */
10567: for(K=1;K<4;K++){
10568: J=lsort([1,2,3],[K],1);
10569: K4=[K,4];K0=[0,K];
10570: G0=mc2grs(G,["get0",[K0,J]]);
10571: LT=anal2sp(G0,["+",C,0]);
10572: G0=mc2grs(G,["get0",J]);
10573: L0=anal2sp(G0,["put1",1,0]);
10574: LT=anal2sp(LT,["add",L0]);
10575: G0=mc2grs(G,["get0",K4]);
10576: L0=anal2sp(G0,[["put1",1,0],["+",0,U]]);
10577: LT=anal2sp(LT,["add",L0]);
10578: G0=mc2grs(G,["get0",[[0,J[0]],K4]]);
10579: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
10580: LT=anal2sp(LT,["sub",L0]);
10581: G0=mc2grs(G,["get0",[[0,J[1]],K4]]);
10582: L0=anal2sp(G0,[["get",1,0],["+",0,U]]);
10583: LT=anal2sp(LT,["sub",L0]);
10584: G0=mc2grs(G,["get0",[K0,J]]);
10585: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10586: LT=anal2sp(LT,["sub",L0]);
10587: G0=mc2grs(G,["get0",[[0,4],J]]);
10588: L0=anal2sp(G0,[["+",-C,0],["get",1,0]]);
10589: LT=anal2sp(LT,[["sub",L0],0]);
10590: L=cons(cons([K0,J],LT),L);
10591: }
10592: /* [[0,1],[2,4]] : [K,I]=[[0,k],[i,4]] S=[j,k] : 6 cases */
10593: for(K=1;K<4;K++){
10594: for(I=1;I<4;I++){
10595: if(I==K) continue;
10596: for(J=1;J<4;J++) if(J!=I&&J!=K) break;
10597: I4=[I,4];S=(J<K)?[J,K]:[K,J];K0=[0,K];
10598: G0=cdr(mc2grs(G,["get",[K0,I4]]));
10599: LT=anal2sp(G0,["+",C,0]);
10600: G0=cdr(mc2grs(G,["get",I4]));
10601: L0=anal2sp(G0,["put1",1,0]);
10602: LT=anal2sp(LT,["add",L0]);
10603: G0=cdr(mc2grs(G,["get",S]));
10604: L0=anal2sp(G0,[["put1",1,0],["+",0,-C-U]]);
10605: LT=anal2sp(LT,["add",L0]);
10606:
10607: G0=cdr(mc2grs(G,["get",[[0,I],S]]));
10608: L0=anal2sp(G0,[["get",1,0],["+",0,-C-U]]);
10609: LT=anal2sp(LT,["sub",L0]);
10610: G0=cdr(mc2grs(G,["get",[[0,J],I4]]));
10611: L0=anal2sp(G0,["get",1,0]);
10612: LT=anal2sp(LT,["sub",L0]);
10613: G0=cdr(mc2grs(G,["get",[K0,I4]]));
10614: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10615: LT=anal2sp(LT,["sub",L0]);
10616: G0=cdr(mc2grs(G,["get",[[0,4],S]]));
10617: L0=anal2sp(G0,[["get",1,C],["+",-C,-C-U]]);
10618: LT=anal2sp(LT,[["sub",L0],0]);
10619: L=cons(cons([K0,I4],LT),L);
10620: }
10621: }
10622: /* [[0,4],[2,3]] : [[0,4],J]=[[0,4],[i,j]] 3 cases */
10623: for(K=3;K>0;K--){
10624: J=lsort([1,2,3],[K],1);
10625: G0=mc2grs(G,["get0",[[0,4],J]]);
10626: LT=anal2sp(G0,["+",-C,0]);
10627: G0=mc2grs(G,["get0",J]);
10628: L0=anal2sp(G0,["put1",1,-C]);
10629: LT=anal2sp(LT,["add",L0]);
10630: G0=mc2grs(G,["get0",[K,4]]);
10631: L0=anal2sp(G0,[["put1",1,-C],["+",0,U]]);
10632: LT=anal2sp(LT,["add",L0]);
10633:
10634: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
10635: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
10636: LT=anal2sp(LT,["sub",L0]);
10637: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
10638: L0=anal2sp(G0,[["get",1,0],["+",-C,U]]);
10639: LT=anal2sp(LT,["sub",L0]);
10640: G0=mc2grs(G,["get0",[[0,K],J]]);
10641: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
10642: LT=anal2sp(LT,["sub",L0]);
10643: G0=mc2grs(G,["get0",[[0,4],J]]);
10644: L0=anal2sp(G0,[["get",1,C],["put",1,0]]);
10645: LT=anal2sp(LT,[["sub",L0],0]);
10646: L=cons(cons([[0,4],J],LT),L);
10647: }
10648: /* [[1,2],[3,4]] : [J,K]=[[i,j],[k,4]] 3 cases */
10649: for(K=3;K>0;K--){
10650: J=lsort([1,2,3],[K],1);
10651: if(K>1)
10652: LT=mc2grs(G,["get0",[J,[K,4]]]);
10653: else{
10654: LT=mc2grs(G,["get0",[[K,4],J]]);
10655: LT=anal2sp(LT,"swap");
10656: }
10657: G0=mc2grs(G,["get0",J]);
10658: L0=anal2sp(G0,[["put1"],["+",0,-C-U]]);
10659: LT=anal2sp(LT,["add",L0]);
10660: G0=mc2grs(G,["get0",[K,4]]);
10661: L0=anal2sp(G0,[["put1"],["+",U,0]]);
10662: LT=anal2sp(LT,["add",L0]);
10663:
10664: G0=mc2grs(G,["get0",[[0,J[0]],[K,4]]]);
10665: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
10666: LT=anal2sp(LT,["sub",L0]);
10667: G0=mc2grs(G,["get0",[[0,J[1]],[K,4]]]);
10668: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",U,0]]);
10669: LT=anal2sp(LT,["sub",L0]);
10670: G0=mc2grs(G,["get0",[[0,K],J]]);
10671: L0=anal2sp(G0,[["get1",1,0],["put1"],["+",0,-C-U]]);
10672: LT=anal2sp(LT,["sub",L0]);
10673: G0=mc2grs(G,["get0",[[0,4],J]]);
10674: L0=anal2sp(G0,[["get1",1,C],["put1"],["+",0,-C-U]]);
10675: LT=anal2sp(LT,[["sub",L0],0]);
10676: if(K==1){
10677: LT=anal2sp(LT,"swap");
10678: L=cons(cons([[K,4],J],LT),L);
10679: }else L=cons(cons([J,[K,4]],LT),L);
10680: }
10681: G=L;
10682: }else if(length(S)==2){ /* general mc */
10683: if(S[1]!=0){
10684: I=S[0];
10685: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
10686: G=mc2grs(G,[S[1]]);
10687: if(I!=0) G=mc2grs(G,["swap",[0,I]]);
10688: }
10689: }else if(length(S)==3||length(S)==4){ /* addition */
10690: for(I=1;I<4;I++,S=cdr(S))
10691: if(S[0]) G=mc2grs(G,[[[0,I],S[0]]]);
10692: if(length(S)==1 && S[0]) /* mc */
10693: G=mc2grs(G,[S[0]]);
10694: }
10695: }
10696: }
10697: return mc2grs(G,"sort");
10698: }
10699:
10700: def mcmgrs(G,P)
10701: {
10702: if(type(G)<2){
10703: if(G>1){
10704: N=G+2;G=[];
10705: for(I=1;I<=N;I++){
10706: for(J=1;J<N;J++){
10707: if(I==J) continue;
10708: for(K=J+1;K<=N;K++){
10709: if(I==K) continue;
10710: G=cons([[[0,I],[J,K]],[1,0,0]],G);
10711: }
10712: }
10713: }
10714: for(I=1;I<=N;I++){
10715: for(J=1;J<I;J++) G=cons([[[0,I],[0,J,I]],[1,0,0]],G);
10716: for(J=I+1;J<=N;J++) G=cons([[[0,I],[0,I,J]],[1,0,0]],G);
10717: }
10718: return reverse(G);
10719: }
10720: return 0;
10721: }
10722: if(type(G)==7) G=os_md.s2sp(G);
10723: if(type(G)!=4||type(G[0])!=4) return 0;
10724: if(type(G[0][0])!=4){ /* spectre type -> GRS */
10725: G=s2sp(G|std=1);
10726: L=length(G);
10727: for(V=[],I=L-2;I>=0;I--) V=cons(makev([I+10]),V);
10728: V=cons(makev([L+9]),V);
10729: G=sp2grs(G,V,[1,length(G[0]),-1]|mat=1);
10730: if(getopt(short)!=0){
10731: V=append(cdr(V),[V[0]]);
10732: G=shortv(G,V);
10733: }
10734: R=chkspt(G|mat=1);
10735: if(R[2] != 2 || R[3] != 0 || !(R=getbygrs(G,1|mat=1))) return 0;
10736: if(getopt(anal)==1) return R; /* called by mcmgrs() */
10737: if(!(G=mcmgrs(L-2,0))) return 0;
10738: for(R=cdr(R);R!=[];R=cdr(R)){
10739: TR=car(R)[0];
10740: if(TR[0]) G=mcmgrs(G,[[TR[0]]]);
10741: G=mcmgrs(G,[cdr(TR)]);
10742: }
10743: }
10744: L=length(G);
10745: for(N=4;N<25;N++){
10746: K=N^2*(N-1)/2;
10747: if(K>L) return 0;
10748: if(K==L) break;
10749: }
10750: if(type(P)<2) return G;
10751: F=0;
10752: if(type(P)==7||(type(P)==4&&type(P[0])<4)) P=[P];
10753: if((Dvi=getopt(dviout))!=1&&Dvi!=2&&Dvi!=-1) Dvi=0;
10754: Keep=(Dvi==2)?1:0;
10755: if(type(P)==4 && type(F=car(P))==7){
10756: if(F=="mult"){
1.24 takayama 10757: for(P=cdr(P);P!=[];P=cdr(P)) G=mc2grs(G,car(P)|option_list=getopt());
1.6 takayama 10758: return G;
10759: }
10760: if(F=="get"||F=="get0"){
10761: if(Dvi!=0) F="get";
10762: if(length(P)==2){
10763: if(type(P[1])==4){
10764: if(type(P[1][1])==4){ /* [[,],[,]] */
10765: for(PG=reverse(G);PG!=[];PG=cdr(PG)){
10766: TP=car(PG);
10767: if(TP[0]==P[1]) return (F=="get")?TP:cdr(TP);
10768: }
10769: return [];
10770: }
10771: if(P[1][0]==0){
10772: if(length(P[1])==2){ /* [0,] */
10773: for(J=1;J<=N;J++) if(J!=P[1][1]) break;
10774: for(K=J+1;K<=N;K++) if(K!=P[1][1]) break;
10775: L=mcmgrs(G,["get0",[P[1],[J,K]]]);
10776: L=anal2sp(L,["get1",1]);
10777: }else{ /* [0,*,*] */
10778: L=mcmgrs(G,["get0",[[P[1][0],P[1][1]],P[1]]]);
10779: L=anal2sp(L,["get1",2]);
10780: }
10781: }else{ /* [,] */
10782: for(J=1;J<=N;J++) if(J!=P[1][0]&&J!=P[1][1]) break;
10783: L=mcmgrs(G,["get0",[[0,J],P[1]]]);
10784: L=anal2sp(L,["get1",2]);
10785: }
10786: L=anal2sp(L,0);
10787: if(F=="get") L=cons(P[1],L);
10788: return L;
10789: }else{ /* I */
10790: for(L=[],I=P[1],J=0;J<=N;J++){
10791: if(I==J) continue;
10792: II=(I<J)?[I,J]:[J,I];
10793: L=cons(mcmgrs(G,[F,II]),L);
10794: }
10795: }
10796: }else{
10797: for(L=[],I=0;I<N;I++){
10798: for(J=I+1;J<=N;J++) L=cons(mcmgrs(G,[F,[I,J]]),L);
10799: }
10800: }
10801: if(Dvi){
10802: for(R=S=[];L!=[];L=cdr(L)){
10803: T=car(L);
10804: R=cons(cdr(T),R);
10805: if(S==[]) S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}\\\\\n";
10806: else S="A_{"+rtostr(T[0][0])+rtostr(T[0][1])+"}&"+S;
10807: }
10808: L=ltotex(R|opt="GRS",pre=S);
10809: if(type(V=getopt(div))!=4) V=[];
10810: if(V==[]&&(K=length(R))>10)
10811: for(I=9;I<K;I+=9) V=cons(I,V);
10812: V=reverse(V);
10813: if(V!=[]) L=divmattex(L,V);
10814: if(Dvi>0){
10815: if(V!=[]) dviout(L|keep=Keep);
10816: else dviout(L|eq=0,keep=Keep);
10817: }
10818: }else L=reverse(L);
10819: return L;
10820: }
10821: if(F=="show"){
10822: for(R=str_tb(0,0);G!=[];){
10823: L=car(G);
10824: I=L[0][0];J=L[0][1];
10825: str_tb("[A_{"+rtostr(I[0])+rtostr(I[1])+"}:A_{"+rtostr(J[0])+rtostr(J[1]),R);
10826: if(length(J)==3) str_tb(rtostr(J[2]),R);
10827: str_tb("}]&=\\left\\{",R);
10828: for(L=cdr(L);;){
10829: S=car(L);
10830: str_tb("["+my_tex_form(S[1])+":"+my_tex_form(S[2])+"]",R);
10831: if(S[0]!=1) str_tb("_{"+rtostr(S[0])+"}",R);
10832: if((L=cdr(L))==[]) break;
10833: str_tb(",\\,",R);
10834: }
10835: str_tb("\\right\\}",R);
10836: if((G=cdr(G))==[]) break;
10837: str_tb(texcr(43),R);
10838: }
10839: R=texbegin("align*",str_tb(0,R));
10840: if(Dvi!=-1) dviout(R|keep=Keep);
10841: return R;
10842: }
10843: if(F=="show0"){
10844: for(C=N*(N-1)*(N-2)/2,S="",L=[];G!=[];G=cdr(G)){
10845: for(TL=[],TG=cdr(car(G));TG!=[];TG=cdr(TG)) TL=cons(car(TG)[0],TL);
10846: TL=msort(TL,[-1,0]);
10847: if(Dvi){
10848: if(S!=""){
10849: if(--C==0) S=S+";";
10850: else S=S+",";
10851: }
10852: for(I=J=0,T=append(TL,[[0]]);T!=[];T=cdr(T)){
10853: if(car(T)==I) J++;
10854: else{
10855: if(I>0&&J>0){
10856: if(I>9) S=S+"("+rtostr(I)+")";
10857: else S=S+rtostr(I);
10858: if(J>1){
10859: if(J>9) S=S+"^{"+rtostr(J)+"}";
10860: else S=S+"^"+rtostr(J);
10861: }
10862: }
10863: I=car(T);J=1;
10864: }
10865: }
10866: }
10867: L=cons(TL,L);
10868: }
10869: if(Dvi){
1.43 takayama 10870: if(Dvi!=-1) dviout(S|eq=0,keep=Keep);
1.6 takayama 10871: return S;
10872: }
10873: return reverse(L);
10874: }
10875: if(F=="spct"){
10876: G=mcmgrs(G,"get");
10877: M=newmat(N+1,N+1);
10878: for(;G!=[];G=cdr(G)){
10879: GT=car(G);I=GT[0][0];J=GT[0][1];
10880: for(S=0,L=[],GT=cdr(GT);GT!=[];GT=cdr(GT)){
10881: L=cons(car(GT)[0],L);
10882: }
10883: L=reverse(qsort(L));
10884: M[I][J]=M[J][I]=L;
10885: }
10886: for(D=0,GT=M[0][1];GT!=[];GT=cdr(GT)) D+=car(GT);
10887: for(I=0;I<=N;I++){
10888: S=-(N-2)*D^2;
10889: for(J=0;J<=N;J++){
10890: if(I==J) continue;
10891: for(L=M[I][J];L!=[];L=cdr(L)) S+=car(L)^2;
10892: }
10893: M[I][I]=S;
10894: }
10895: if(Dvi){
10896: S=[];
10897: for(LS=[],I=N;I>=0;I--){
10898: L=[M[I][I]];
10899: for(J=N;J>=0;J--){
10900: if(I==J) L=cons("",L);
10901: else L=cons(s2sp([M[I][J]]),L);
10902: }
10903: S=cons(L,S);
10904: LS=cons("$x_"+rtostr(I)+"$",LS);
10905: }
10906: S=cons(append(LS,["idx"]),S);
10907: M=ltotex(S|opt="tab",hline=[0,1,z],vline=[0,1,z-1,z],left=cons("",LS));
10908: if(Dvi>0) dviout(M|keep=Keep);
10909: }
10910: return M;
10911: }
10912: if(F=="deg"){
10913: for(S=I=0;I<N-1;I++){
10914: for(J=I+1;J<N;J++){
10915: L=mcmgrs(G,["get0",[I,J]]);
10916: L=anal2sp(L,"val");
10917: S+=L[1];
10918: }
10919: }
10920: return S/L[0];
10921: }
10922: }
10923: L=[];
10924: if(type(F)!=4) return 0;
10925: if(type(P[0])!=4||length(P[0])==2) P=[P];
10926: for(;P!=[];P=cdr(P)){
10927: if(type(T=(S=car(P))[0])==4){ /* addition */
10928: if((K=P[0][1])!=0){
10929: if(T[0]>T[1]) T=[T[1],T[0]];
10930: T1=[T[0],N];T2=[T[1],N];
10931: T01=cons(0,T1);T02=cons(0,T2);
10932: for(PG=G;PG!=[];PG=cdr(PG)){
10933: R=car(PG);R0=R[0];K1=K2=0;
10934: TP=R0[0];
10935: if(TP==T) K1=K;
10936: else if(TP==T1||TP==T2) K1=-K;
10937: if(length(TP=R0[1])==2){
10938: if(TP==T) K2=K;
10939: else if(TP==T1||TP==T2) K2=-K;
10940: }else{
10941: S=0;
10942: if(findin(T[0],TP)>=0) S++;
10943: if(findin(T[1],TP)>=0) S++;
10944: if(S>0&&TP[2]==N) K2=-K;
10945: else if(S==2) K2=K;
10946: }
10947: R1=anal2sp(cdr(R),["+",K1,K2]);
10948: L=cons(cons(R0,R1),L);
10949: }
10950: G=reverse(L);
10951: }
10952: }else if(length(S)==1){ /* middle convolution */
10953: C=S[0];L=[];
10954: for(I=1;I<=N;I++){
10955: for(J=1;J<=N;J++){
10956: if(I==J) continue;
10957: for(K=J+1;K<=N;K++){ /* [[0,I],[J,K]] */
10958: if(I==K)continue;
10959: T=[[0,I],JK=[J,K]];
10960: if(I==N){
10961: LT=mcmgrs(G,["get0",T]);
10962: G0=mcmgrs(G,["get0",JK]);
10963: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10964: G0=mcmgrs(G,["get0",[0,J,K]]);
10965: LT=anal2sp(LT,["add",L0]);
10966: L0=anal2sp(G0,["put1",1,0]);
10967: LT=anal2sp(LT,["add",L0]);
10968: for(V=1;V<=N;V++){
10969: if(V==I){
10970: G0=mcmgrs(G,["get0",T]);
10971: L0=anal2sp(G0,["get",1,C]);
10972: }else if(V==J||V==K){
10973: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10974: L0=anal2sp(G0,["get",1,0]);
10975: }else{
10976: G0=mcmgrs(G,["get0",[[0,V],JK]]);
10977: L0=anal2sp(G0,["get",1,0]);
10978: }
10979: LT=anal2sp(LT,["sub",L0]);
10980: }
10981: LT=anal2sp(LT,["+",-C,0]);
10982: }else if(K==N){
10983: LT=mcmgrs(G,["get0",T]);
10984: LT=anal2sp(LT,["+",C,0]);
10985: G0=mcmgrs(G,["get0",JK]);
10986: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
10987: LT=anal2sp(LT,["add",L0]);
10988: G0=mcmgrs(G,["get0",[0,J,K]]);
10989: L0=anal2sp(G0,[["put1",1,0],["+",0,-C]]);
10990: LT=anal2sp(LT,["add",L0]);
10991: for(V=1;V<=N;V++){
10992: if(V==I){
10993: G0=mcmgrs(G,["get0",T]);
10994: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
10995: }else if(V==J){
10996: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
10997: L0=anal2sp(G0,[["get",1,0],["+",0,-C]]);
10998: }else if(V==N){
10999: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
11000: L0=anal2sp(G0,[["get",1,C],["+",-C,-C]]);
11001: }else{
11002: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11003: L0=anal2sp(G0,["get",1,0]);
11004: }
11005: LT=anal2sp(LT,["sub",L0]);
11006: }
11007: }else{
11008: G0=mcmgrs(G,["get0",T]);
11009: LT=anal2sp(G0,["+",C,0]);
11010: G0=mcmgrs(G,["get0",JK]);
11011: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
11012: LT=anal2sp(LT,["add",L0]);
11013: G0=mcmgrs(G,["get0",[0,J,K]]);
11014: L0=anal2sp(G0,["put1",1,0]);
11015: LT=anal2sp(LT,["add",L0]);
11016: for(V=1;V<=N;V++){
11017: if(V==I){
11018: G0=mcmgrs(G,["get0",T]);
11019: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
11020: }else if(V==J||V==K){
11021: G0=mcmgrs(G,["get0",[[0,V],[0,J,K]]]);
11022: L0=anal2sp(G0,["get",1,0]);
11023: }else if(V==N){
11024: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11025: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
11026: }else{
11027: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11028: L0=anal2sp(G0,["get",1,0]);
11029: }
11030: LT=anal2sp(LT,["sub",L0]);
11031: }
11032: }
11033: LT=anal2sp(LT,0);
11034: L=cons(cons(T,LT),L);
11035: }
11036: T=[[0,I],(I<J)?[0,I,J]:[0,J,I]]; /* [0,I], [0,I,J] */
11037: JK=(I<J)?[I,J]:[J,I];
11038: if(I==N){
11039: G0=mcmgrs(G,["get0",T]);
11040: LT=anal2sp(G0,["+",-C,0]);
11041: G0=mcmgrs(G,["get0",JK]);
11042: L0=anal2sp(G0,[["put1",1,-C],["mult",N-3]]);
11043: LT=anal2sp(LT,["add",L0]);
11044: G0=mcmgrs(G,["get0",T[1]]);
11045: L0=anal2sp(G0,["put1",1,-C]);
11046: LT=anal2sp(LT,["add",L0]);
11047: for(V=1;V<=N;V++){
11048: if(V==J){
11049: G0=mcmgrs(G,["get0",T]);
11050: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
11051: }else if(V==N){
11052: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
11053: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
11054: }else{
11055: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11056: L0=anal2sp(G0,[["get",1,0],["+",-C,0]]);
11057: }
11058: LT=anal2sp(LT,["sub",L0]);
11059: }
11060: LT=anal2sp(LT,["+",0,C]);
11061: }else if(J==N){
11062: G0=mcmgrs(G,["get0",T]);
11063: LT=anal2sp(G0,["+",C,0]);
11064: G0=mcmgrs(G,["get0",T[0]]);
11065: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
11066: LT=anal2sp(LT,["add",L0]);
11067: G0=mcmgrs(G,["get0",T[1]]);
11068: L0=anal2sp(G0,["put1",1,0]);
11069: LT=anal2sp(LT,["add",L0]);
11070: for(V=1;V<=N;V++){
11071: if(V==I){
11072: G0=mcmgrs(G,["get0",T]);
11073: L0=anal2sp(G0,[["get",1,0],["+",C,0]]);
11074: }else if(V==N){
11075: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
11076: L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
11077: }else{
11078: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11079: L0=anal2sp(G0,["get",1,0]);
11080: }
11081: LT=anal2sp(LT,["sub",L0]);
11082: }
11083: LT=anal2sp(LT,["+",0,-C]);
11084: }else{
11085: G0=mcmgrs(G,["get0",T]);
11086: LT=anal2sp(G0,["+",C,C]);
11087: G0=mcmgrs(G,["get0",JK]);
11088: L0=anal2sp(G0,[["put1",1,0],["mult",N-3]]);
11089: LT=anal2sp(LT,["add",L0]);
11090: G0=mcmgrs(G,["get0",T[1]]);
11091: L0=anal2sp(G0,[["put1",1,0],["+",0,C]]);
11092: LT=anal2sp(LT,["add",L0]);
11093: for(V=1;V<=N;V++){
11094: if(V==I){
11095: G0=mcmgrs(G,["get0",T]);
11096: L0=anal2sp(G0,[["get",1,0],["+",C,C]]);
11097: }else if(V==J){
11098: G0=mcmgrs(G,["get0",[[0,V],T[1]]]);
11099: L0=anal2sp(G0,[["get",1,0],["+",0,C]]);
11100: }else if(V==N){
11101: G0=mcmgrs(G,["get0",[[0,V],JK]]); L0=anal2sp(G0,[["get",1,C],["+",-C,0]]);
11102: }else{
11103: G0=mcmgrs(G,["get0",[[0,V],JK]]);
11104: L0=anal2sp(G0,["get",1,0]);
11105: }
11106: LT=anal2sp(LT,["sub",L0]);
11107: }
11108: }
11109: LT=anal2sp(LT,0);
11110: L=cons(cons(T,LT),L);
11111: }
11112: }
11113: for(G0=G=[];L!=[];L=cdr(L)){
11114: if(length(car(L)[0][1])==2) G0=cons(car(L),G0);
11115: else G=cons(car(L),G);
11116: }
11117: G=append(G0,G);
11118: }else{
11119: if(length(S)==N-1||length(S)==N){ /* [a_1,...,a_{N-1},c] */
11120: for(I=1;I<N;S=cdr(S),I++) G=mcmgrs(G,[[0,I],car(S)]);
11121: if(length(S)==1) G=mcmgrs(G,[S[0]]);
11122: }else return 0;
11123: }
11124: }
11125: return G;
11126: }
11127:
11128:
11129: def delopt(L,S)
11130: {
1.81 takayama 11131: if(getopt(get)==1){
11132: for(;L!=[];L=cdr(L)) if(car(L)[0]==S) return car(L)[1];
11133: return [];
11134: }
1.70 takayama 11135: if((Inv=getopt(inv))!=1&&Inv!=2) Inv=0;
11136: if(Inv&&type(S)==4&&type(car(S))==4){
11137: for(R=[];L!=[];L=cdr(L)){
11138: L0=car(L)[0];
11139: for(F=0,TS=[];S!=[];S=cdr(S)){
11140: if(!F&&L0==car(S)[0]){
11141: R=cons(car(S),R);
11142: F++;
11143: continue;
11144: }
11145: TS=cons(car(S),TS);
11146: }
11147: if(!F) R=cons(car(L),R);
11148: S=reverse(TS);
11149: }
11150: R=reverse(R);
11151: return Inv==1?append(S,R):append(R,S);
11152: }
1.6 takayama 11153: for(R=[];L!=[];L=cdr(L)){
11154: if(type(car(L))!=4) F=0;
11155: else if(type(S)==4) F=(findin(car(L)[0],S)<0)?0:1;
11156: else F=(car(L)[0]==S)?1:0;
11157: if(F==Inv) R=cons(car(L),R);
11158: }
11159: return reverse(R);
11160: }
11161:
11162: def str_char(S,N,L)
11163: {
11164: if(type(S)==7){
11165: if(type(L)==1) L=asciitostr([L]);
11166: return str_chr(S,N,L);
11167: }
11168: if(type(L)==7) L=strtoascii(L)[0];
11169: if(type(S)==4){
11170: M=N;
11171: while(M-->0) S=cdr(S);
11172: M=findin(L,S);
11173: return (M>=0)?findin(L,S)+N:-1;
11174: }else if(type(S)==5){
11175: K=length(S);
11176: for(I=N;I<K;I++)
11177: if(S[I]==L) return I;
11178: }
11179: return -1;
11180: }
11181:
11182: def str_pair(S,N,I,J)
11183: {
11184: if(type(I)==7) I=(II=strtoascii(I))[0];
11185: if(type(J)==7) J=(JJ=strtoascii(J))[0];
11186: if(type(S)==7) S=strtoascii(S);
11187: if(getopt(inv)==1){
11188: if(II!=0){
11189: I=asciitostr(reverse(II));
11190: IL=length(II);
11191: }else IL=1;
11192: if(JJ!=0) J=asciitostr(reverse(JJ));
11193: R=str_pair(reverse(S),length(S)-N-1,J,I);
11194: if(R>=0) R=length(S)-IL-R;
11195: return R;
11196: }
11197: if((SJIS=getopt(sjis))!=1) SJIS=0;
11198: if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){
11199: for(;;){
11200: MJ=str_str(S,N|top=JJ,sjis=SJIS);
11201: if(MJ>=0){
11202: MI=str_str(S,II|top=N,sjis=SJIS);
11203: if(MI<0 || MI>MJ){
11204: if(C==0) return MJ;
11205: C--; N=MJ+length(II);
11206: }else if(MI>=0){
11207: C++; N=MI+length(JJ);
11208: }
11209: }
11210: return -1;
11211: }
11212: }
11213: if(type(S)==4){
11214: M=N;
11215: while(M-->0) S=cdr(S);
11216: while(S!=[]){
11217: if(car(S)==I) C++;
11218: else if(car(S)==J){
11219: if(C==0) return N;
11220: C--;
11221: }
11222: S=cdr(S);N++;
11223: }
11224: }else if(type(S)==5){
11225: K=length(S);
11226: for(T=N;T<K && C>=0;T++){
11227: if(S[T]==I) C++;
11228: else if(S[T]==J){
11229: if(C==0) return T;
11230: C--;
11231: }
11232: }
11233: }
11234: return -1;
11235: }
11236:
11237:
11238: def str_cut(S,I,J)
11239: {
11240: if(type(S)==7) return sub_str(S,I,J);
11241: if((JJ=length(S))<=J) J=JJ-1;
11242: if(type(S)==5){
11243: for(L=[],K=J; K>=I; K--) L=cons(S[K],L);
11244: }else if(type(S)==4){
11245: J-=I;
11246: while(I-->0) S=cdr(S);
11247: for(L=[];J-->=0;S=cdr(S)) L=cons(car(S),L);
11248: L=reverse(L);
11249: }
11250: return asciitostr(L);
11251: }
11252:
11253: def str_str(S,T)
11254: {
11255: if(S==0) return -1;
11256: if(type(S) == 7)
11257: S = strtoascii(S);
11258: if(type(J=getopt(top))!=1 || J<0) J=0;
11259: LS=length(S);
11260: if(LS-J<1) return -1;
11261: if(type(S)==4){
11262: LS-=(J0=J);
11263: for( ; J>0 && S!=[]; S=cdr(S),J--);
11264: }
11265: if(type(JJ=getopt(end))!=1 && JJ!=0) JJ=LS;
11266: else JJ-=J0;
11267: if((SJIS=getopt(sjis))!=1) SJIS=0;
11268: if(JJ-J<0) return -1;
11269: /* search from J-th to JJ-th */
11270: if(type(T)==1) T=[T];
11271: else if(type(T)==7) T = strtoascii(T);
11272: else if(type(T)==4 && type(T[0])>3){
11273: for(K=(KF=-1)-J0; T!=[]; F++,T=cdr(T)){
11274: JK=str_str(S,car(T)|top=J,end=JJ,sjis=SJIS);
11275: if(JK>=0){
11276: JJ=(K=JK)-1; KF=F;
11277: if(J>JJ) break;
11278: }
11279: }
11280: return [KF,J0+K];
11281: }
11282: if(type(T)==4) T=ltov(T);
11283: LT = length(T);
11284: if(LT>0){
11285: LE = LS-LT;
11286: LP = T[0];
11287: if(JJ==0 ||(type(JJ)==1 && JJ<LE)) LE=JJ;
11288: if(type(S)==5){
11289: for(; J <= LE; J++){
11290: if(S[J] != LP){
11291: if(SJIS && (V=S[J])>128){
11292: if(V<160 || (V>223 && V<240)) J++;
11293: }
11294: continue;
11295: }
11296: for(I = 1; I < LT && S[I+J] == T[I]; I++);
11297: if(I >= LT) return J;
11298: }
11299: }else if(type(S)==4){
11300: for(; J<=LE; S=cdr(S),J++){
11301: if(car(S) != LP){
1.56 takayama 11302: if(SJIS && (V=car(S))>128){
11303: if((V<160 || (V>223 && V<240))&&S!=[]) {
11304: J++;S=cdr(S);
11305: }
1.6 takayama 11306: }
11307: continue;
11308: }
11309: for(ST=cdr(S), I = 1; I < LT && car(ST) == T[I]; I++, ST=cdr(ST));
11310: if(I >= LT) return J0+J;
11311: }
11312: }
11313: }
11314: return -1;
11315: }
11316:
11317: def str_times(S,N)
11318: {
11319: if(!isint(N)) return "";
11320: if(type(S)==7){
11321: for(Tb=str_tb(0,0);N-->0;)
11322: str_tb(S,Tb);
11323: return str_tb(0,Tb);
11324: }
11325: if(type(S)==4){
11326: for(LT=[],I=0;I<N;I++){
11327: if(type(car(S))==7){
11328: LT=cons(car(S),LT);
11329: S=cdr(S);
11330: if(S==[]) S=[[""]];
11331: }else if(type(car(S))==4){
11332: ST=car(S);
11333: for(J=0;I<N;I++){
11334: if(J==length(ST)) J=0;
11335: LT=cons(ST[J++],LT);
11336: }
11337: }
11338: }
11339: return reverse(LT);
11340: }
11341: return S;
11342: }
11343:
11344: def ssubgrs(M,L)
11345: {
11346: if(type(L)==7) L=s2sp(L);
11347: for(S=0, L=L, M=M; L!=[]; L=cdr(L), M=cdr(M)){
11348: for(LT=car(L), MT=car(M); LT!=[]; LT=cdr(LT), MT=cdr(MT)){
11349: S += car(LT)*car(MT)[1];
11350: }
11351: }
11352: return S;
11353: }
11354:
11355: def s2os(S)
11356: {
11357: return str_subst(S,[["\\","\\\\"],["\"","\\\""]],0);
11358: }
11359:
11360: def l2os(S)
11361: {
11362: if(type(S)==6)
11363: S=m2ll(S);
11364: else if(type(S)==5)
11365: S=vtol(S);
11366: else if(type(S)==7) return "\""+s2os(S)+"\"";
11367: else if(type(S)<4) return rtostr(S);
11368: if(type(S)==4){
11369: for(F=0,Tb=str_tb("[",0);S!=[];S=cdr(S)){
11370: if(F++) str_tb(", ",Tb);
11371: str_tb(l2os(car(S)),Tb);
11372: }
11373: str_tb("]",Tb);
11374: return str_tb(0,Tb);
11375: }
11376: return 0;
11377: }
11378:
11379: def r2os(S)
11380: {
11381: if(type(S)==6){
11382: for(T="",S=m2ll(S);S!=[];S=cdr(S)){
11383: if(T!="") T=T+","+r2os(car(S));
11384: else T=r2os(car(S));
11385: }
11386: return "mat("+T+")\n";
11387: }else if(type(S)==5){
11388: for(T="",S=v2l(S);S!=[];S=cdr(S)){
11389: if(T!="") T=T+","+r2os(car(S));
11390: else T=r2os(car(S));
11391: }
11392: return "vect("+T+")\n";
11393: }else if(type(S)<4) return rtostr(S);
11394: else if(type(S)==4){
11395: for(T="";S!=[];S=cdr(S)){
11396: if(T!="") T=T+","+r2os(car(S));
11397: else T=r2os(car(S));
11398: }
11399: return "["+T+"]";
11400: }else if(type(S)==7) return "\""+s2os(S)+"\"";
11401: return "";
11402: }
11403:
11404: def s2euc(S)
11405: {
11406: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
11407: if((C=car(L)) == 0x1b && length(L)>1) {
11408: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
11409: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
11410: Mode = 1;
11411: } else return 0;
11412: }else if(C == 0x28 && length(L)>1) { /* ( */
11413: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
11414: Mode = 0;
11415: }else if(C == 0x49) { /* I */
11416: Mode = 2;
11417: }else{
11418: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
11419: }
11420: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
11421: L=cdr(L);
11422: }else{
11423: R=cons(0x1b,R);R=cons(C,R);
11424: }
11425: }else if(C == 0x0e) {
11426: Mode = 2;
11427: }else if(C == 0x0f) {
11428: Mode = 0;
11429: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
11430: D=car(L=cdr(L));
11431: if(D>0x20 && D<0x7f) {
11432: R=cons(ior(C,0x80),R);R=cons(ior(D,0x80),R);
11433: } else return 0;
11434: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
11435: R=cons(0x8e,R); R=cons(ior(C,0x80),R);
11436: }else if(((C>0x80 && C<0xa0) || (C>0xdf && C<0xf0)) && length(L)>1) { /* ShiftJIS */
11437: D=car(L=cdr(L));
11438: if(D>0x3f && D<0xfd && D!=0x7f) {
11439: T=sjis2jis([C,D]);
11440: R=cons(ior(T[0],0x80),R); R=cons(ior(T[1],0x80),R);
11441: }else return 0;
11442: }else if(C>0x9f && C<0xe0) { /* HanKana */
11443: R=cons(0x8e,R); R=cons(C,R);
11444: }else if(C == 0x0a){
11445: CR++;
11446: }else if(C == 0x0d){
11447: R=cons(0x0d,R);
11448: CR=0;
11449: }else{
11450: while(CR-->0) R=cons(0x0d,R);
11451: R=cons(C,R);
11452: }
11453: }
11454: while(CR-->0) R=cons(0x0d,R);
11455: return asciitostr(reverse(R));
11456: }
11457:
11458: def s2sjis(S)
11459: {
11460: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
11461: if((C=car(L)) == 0x1b && length(L)>1) {
11462: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
11463: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
11464: Mode = 1;
11465: } else return 0;
11466: }else if(C == 0x28 && length(L)>1) { /* ( */
11467: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
11468: Mode = 0;
11469: }else if(C == 0x49) { /* I */
11470: Mode = 2;
11471: }else{
11472: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
11473: }
11474: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
11475: L=cdr(L);
11476: }else{
11477: R=cons(0x1b,R);R=cons(C,R);
11478: }
11479: }else if(C == 0x0e) {
11480: Mode = 2;
11481: }else if(C == 0x0f) {
11482: Mode = 0;
11483: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
11484: D=car(L=cdr(L));
11485: if(D>0x20 && D<0x7f) {
11486: T=jis2sjis([C,D]);
11487: R=cons(T[0],R);R=cons(T[1],R);
11488: } else return 0;
11489: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
11490: R=cons(ior(C,0x80),R);
11491: }else if(C>0xa0 && C<0xff && length(L)>1) { /* EUC */
11492: D=car(L=cdr(L));
11493: if(D>0xa0 && D<0xff) {
11494: T=jis2sjis([iand(C,0x7f),iand(D,0x7f)]);
11495: R=cons(T[0],R);R=cons(T[1],R);
11496: }else return 0;
11497: }else if(C == 0x0a){
11498: CR++;
11499: }else if(C == 0x0d){
11500: R=cons(0x0a,R);R=cons(0x0d,R);
11501: CR=0;
11502: }else{
11503: while(CR-->0){
11504: R=cons(0x0a,R);R=cons(0x0d,R);
11505: }
11506: R=cons(C,R);
11507: }
11508: }
11509: while(CR-->0){
11510: R=cons(0x0a,R);R=cons(0x0d,R);
11511: }
11512: return asciitostr(reverse(R));
11513: }
11514:
11515: def r2ma(S)
11516: {
11517: return evalma(S|inv=1);
11518: }
11519:
11520: def evalma(S)
11521: {
11522: L0=["\n","\d","{","}","[","]","Log","Exp","Sinh","Cosh","Tanh","Sin","Cos","Tan",
11523: "ArcSin","ArcCos","ArcTan"];
11524: L1=["", "" ,"[","]","(",")","log","exp","sinh","cosh","tanh","sin","cos","tan",
11525: "asin", "acos", "atan"];
11526: if(getopt(inv)==1){
11527: if(type(S)==6) S=m2ll(S);
11528: else if(type(S)==5) S=vtol(S);
11529: if(type(S)==4){
11530: for(L=[];S!=[];S=cdr(S)){
11531: if(type(car(S))==6) L=cons(m2ll(car(S)),L);
11532: else if(type(car(S))==5) L=cons(vtol(car(S)),L);
11533: else L=cons(car(S),L);
11534: }
11535: S=reverse(L);
11536: }else return 0;
11537: return str_subst(rtostr(S),cdr(cdr(L1)),cdr(cdr(L0)));
11538: }
11539: if(S==0){
11540: print("Mathematica text (terminated by ;) ?");
11541: purge_stdin();
11542: Tb=str_tb(0,0);
11543: for(;;){
11544: S=get_line();
11545: str_tb(S,Tb);
11546: if(str_char(S,0,";")>=0) break;
11547: }
11548: S=str_tb(0,Tb);
11549: }
11550: /*
11551: while((P=str_chr(S,0,";"))>=0){
11552: V0=evalma(str_cut(S,0,P+1));
11553: S=str_cut(S,P+1,length(S));
11554: }
11555: if((P=str_char(S,0,"="))>=0){
11556: X=strtoascii(str_cut(S,0,P));
11557: L=length(X);
11558: for(P0=P1=-1,I=0;I<L;I++){
11559: if(L(I)<=32) continue;
11560: if(isalphanum(L[I])){
11561: if(P0<0){
11562: if(isnum(L[I])) break;
11563: P0=I;
11564: }
11565: else if(P1!=I+1) break;
11566: P1=I;
11567: }
11568: }
11569: if(I==L && P0>=0){
11570: for(I==P0;I-->0;) X=cdr(X);
11571: if((X0=car(X))>96) X0-=32;
11572: Y=[X0];X=cdr(X);
11573: for(I=P1-P0;I-->0;X=cdr(X))
11574: Y=cons(car(X),Y);
11575: Y=cons(61,Y);
11576: Var=asciitostr(reverse(Y));
11577: S=str_cut(S,P,length(S));
11578: }
11579: }
11580: */
11581: S=eval_str(str_subst(S,L0,L1));
11582: if(type(S)==4){
11583: for(L=-1,T=S;T!=[];T=cdr(T)){
11584: if(type(T0=car(T))>4) break;
11585: if(type(T0)<4){
11586: if(L>=0) break;
11587: L=-2;continue;
11588: }
11589: if(L<-2) break;
11590: if(L==-1) L=length(T0);
11591: else if(L!=length(T0)) break;
11592: }
11593: if(T==[]){
11594: if(L>0) S=s2m(S);
11595: else S=ltov(S);
11596: }
11597: }
11598: /*
11599: if(S==0 && V0!=0) return V0;
11600: if(type(Var)==7){
11601: T=rtostr(S);
11602: if(type(S)==7) T="\""+T+"\"";
11603: S=eval_str(Var+T);
11604: mycat(["Define",Var]);
11605: }
11606: */
11607: return S;
11608: }
11609:
1.73 takayama 11610: def evalcoord(L)
11611: {
11612: if(type(L)==7) L=strtoascii(L);
11613: I=str_str(L,"(");
11614: if(I>=0) J=str_pair(L,I+1,"(",")");
11615: if(I<0 || J<I) return [0,[]];
11616: for(F=1,K=I+1;K<J;K++){
11617: C=L[K];
11618: if(C>32&&(C<40||C>58)){F=0;break;}
11619: }
11620: S0=str_cut(L,I+1,J-1);
11621: for(;J>=0;J--) L=cdr(L);
11622: while(L!=[]&&car(L)<33) L=cdr(L);
11623: if(F){
11624: S="["+S0+"]";
11625: return [eval_str(S),L];
11626: }else return [[S0],L];
11627: }
11628:
11629: def readTikZ(L)
11630: {
11631: if(type(L)!=4) L=strtoascii(L);
11632: R=[];
1.75 takayama 11633: CMD=["draw","fill","filldraw","shade","shadedraw","clip","pattern","node","begin"];
1.73 takayama 11634: while(L!=0&&L!=[]){
11635: while(L!=[]&&car(L)<33) L=cdr(L);
11636: if(L==[]) break;
1.75 takayama 11637: if(car(L)==34){ /* % */
1.73 takayama 11638: while(L!=[]&&car(L)!=10) L=cdr(L);
11639: continue;
11640: }
1.75 takayama 11641: if(car(L)!=92) {L=0;break;} /* \ */
11642: for(DF=0;DF<9;DF++) if(str_str(L,CMD[DF]|top=1,end=1)==1) break;
11643: if(DF<7){
1.73 takayama 11644: S=T=0;
11645: I=str_str(L,"(");J=str_str(L,"[");
11646: if(J>0&&I>J){
11647: K=str_str(L,"]");
11648: S=str_cut(L,J+1,K-1);
11649: }
11650: F0=F=0;C=[];
11651: while(L!=0&&L!=[]){
11652: V=evalcoord(L);
11653: L=V[1];
11654: if(L==[]) break;
11655: if(F0){
11656: if (!F) C=cons(0,C);
11657: else if(F0!=3) C=cons(1,C);
11658: }
11659: C=cons(V[0],C);
11660: F0=F;F=0;
11661: if(L[0]==34){ /* % */
11662: while(L!=[]&&car(L)!=10) L=cdr(L);
11663: continue;
11664: }
11665: if(!str_str(L,"..")){ /* .. */
11666: L=cdr(L);L=cdr(L);
11667: F=1;
11668: }else if(!str_str(L,"--")){ /* -- */
11669: L=cdr(L);L=cdr(L);
11670: F=2;
11671: }
11672: while(L!=[]&&car(L)<33) L=cdr(L);
11673: if(L==[]){L=0; break;}
11674: if(!str_str(L,"cycle")){
11675: if(F==2) C=cons(1,C);
11676: C=cons(-1,C);
11677: F0=F=0;
11678: continue;
11679: }
11680: if(!str_str(L,"and")||!str_str(L,"control"))
11681: F=3; /* control, and */
11682: else if(car(L)==59){ /* ; */
11683: L=cdr(L);
11684: break;
11685: }else if(isalpha(car(L))){
1.75 takayama 11686: T=[];
1.73 takayama 11687: while(car(L)!=40 && car(L)!=59){ /* ( ; */
11688: T=cons(car(L),T);
11689: if((L=cdr(L))==[]){L=0;break;}
11690: }
11691: T=asciitostr(reverse(T));
1.75 takayama 11692: if(car(L)==59){ /* ; */
1.73 takayama 11693: L=cdr(L);
11694: break;
11695: }
11696: F0=0;continue;
11697: }else if(F!=1&&F!=2){
11698: L=0;break;
11699: }
11700: }
11701: if(T){
1.75 takayama 11702: if(length(C)==1||length(C)==2) S=(!S)?["",T]:[S,T];
11703: else{
11704: L=0;break;
11705: }
1.74 takayama 11706: }
11707: S=(!S)? []:[["opt",S]];
1.75 takayama 11708: if(DF) S=S=cons(["cmd",CMD[DF]],S);
11709: if(T&&length(C)) R=cons((length(C)==1)?[3,S,C[0],DF]:[3,S,C[1],C[0]],R);
11710: else R=cons([1,S,reverse(C)],R);
11711: }else{ /* \node */
1.73 takayama 11712: U=0;
11713: I=str_str(L,"(");J=str_str(L,"[");
11714: if(J>0&&I>J){
11715: K=str_str(L,"]");
11716: U=str_cut(L,J+1,K-1);
11717: }
11718: V=evalcoord(L);
11719: C=V[0];L=V[1];
11720: J=str_str(L,"{");K=str_pair(L,J+1,"{","}");
11721: S=str_cut(L,J+1,K-1);
11722: if(U) S=[U,S];
1.75 takayama 11723: R=cons([2,[],C,[S]],R);
1.73 takayama 11724: for(;K>=0;K--) L=cdr(L);
11725: K=str_str(L,";");
11726: for(;K>=0;K--) L=cdr(L);
1.75 takayama 11727: };
1.73 takayama 11728: }
11729: if(!L){
11730: mycat("Can't understand!");
11731: return -1;
11732: }
1.75 takayama 11733: return reverse(R);
1.73 takayama 11734: }
11735:
1.6 takayama 11736: def i2hex(N)
11737: {
11738: Opt=getopt();
11739: if(type(N)==4 && isint(car(N))){
11740: #ifdef USEMODULE
11741: L=mtransbys(os_md.i2hex,N,[]|option_list=Opt);
11742: #else
11743: L=mtransbys(i2hex,N,[]|option_list=Opt);
11744: #endif
11745: return rtostr(L);
11746: }
11747: if(!isint(N) || N<0) return 0;
11748: if(!N) L=[];
11749: else{
11750: Cap=(getopt(cap)==1)?32:0;
11751: for(L=[];N!=0;N=ishift(N,4)){
11752: J=iand(N,15);
11753: L=cons(((J>9)?(87-Cap):48)+J,L);
11754: }
11755: }
11756: if(!isint(Min=getopt(min))) Min=2;
11757: for(Min-=length(L);Min-->0;)
11758: L=cons(48,L);
11759: if(getopt(num)==1){
11760: L=cons(120,L);L=cons(48,L);
11761: }
11762: return asciitostr(L);
11763: }
11764:
11765: def sjis2jis(L)
11766: {
11767: L1=L[1];
11768: if((L0=L[0])<=0x9f){
11769: if(L1<0x9f) L0=L0*2-0xe1;
11770: else L0=(L0*2)-0xe0;
11771: }else{
11772: if(L1<0x9f) L0=L0*2-0x161;
11773: else L0=L0*2-0x160;
11774: }
11775: if(L1<0x7f) return [L0,L1-0x1f];
11776: else if(L1<0x9f) return [L0,L1-0x20];
11777: return [L0,L1-0x7e];
11778: }
11779:
11780: def jis2sjis(L)
11781: {
11782: L1=L[1];
11783: if(iand(L0=L[0],1)){
11784: if(L1<0x60) L=[L1+0x1f];
11785: else L=[L1+0x20];
11786: }else L=[L1+0x7e];
11787: if(L0<0x5f) return cons(ishift(L0+0xe1,1),L);
11788: return cons(ishift(L0+0x161,1),L);
11789: }
11790:
11791: def verb_tex_form(P)
11792: {
11793: L = reverse(strtoascii(rtostr(P)));
11794: for(SS = []; L != []; L = cdr(L)){
11795: Ch = car(L); /* ^~\{} */
11796: if(Ch == 92 || Ch == 94 || Ch == 123 || Ch == 125 || Ch == 126){
11797: SS = append([92,Ch,123,125],SS); /* \Ch{} */
11798: if(Ch != 94 && Ch != 126) /* \char` */
11799: SS = append([92,99,104,97,114,96],SS);
11800: continue;
11801: }
11802: SS = cons(Ch, SS);
11803: if((Ch >= 35 && Ch <= 38) || Ch == 95) /* #$%&_ */
11804: SS = cons(92, SS); /* \Ch */
11805: }
11806: return asciitostr(SS);
11807: }
11808:
11809: def tex_cuteq(S,P)
11810: {
11811: if(P==0) return 0;
11812: if(S[P]==125){ /* } */
11813: if((Q=str_pair(S,P-1,"{","}"|inv=1))<0) return -1;
11814: if(Q<2||S[Q-1]!=95) return Q;
11815: return tex_cuteq(S,Q-2);
11816: }
11817: if(!isalphanum(S[Q=P--])) return -1;
11818: while(P>0&&isalphanum(S[P])) P--;
11819: if(S[P]==92){ /* \ */
11820: if(P==0) return P;
11821: else P--;
11822: }
11823: if(S[P]!=95||P==0) return Q; /* _ */
11824: return tex_cuteq(S,P-1);
11825: }
11826:
11827:
11828: def texket(S)
11829: {
11830: if(!isint(F=getopt(all))) F=0;
11831: if(type(S)==7){
11832: L=str_len(S);
11833: SS=strtoascii(S);
11834: }else{
11835: L=length(S);
11836: SS=S;
11837: }
11838: for(T="",I=I0=0;I<L-1;){
11839: J=str_char(SS,I,"(");
11840: if(J<0) break;
11841: if(J<L-1 && J>4 && str_str(SS,"\\left"|top=J-5,end=J-1)>=0){
11842: I=J+1;continue;
11843: }
11844: if((K=str_pair(SS,J+1,"(",")"))>=0){
11845: KK=str_char(SS,J+2,"(");
11846: if(KK>K||KK<0){
11847: if(F!=1){
11848: if(!F){
11849: for(N=J+1;N<K;N++) /* + - _ { } */
11850: if(!isalphanum(P=SS[N])&&findin(P,[32,43,45,95,123,125])<0) break;
11851: }else N=K;
11852: if(N==K){
11853: I=K+1;continue;
11854: }
11855: }
11856: T=T+str_cut(SS,I0,J-1)+"\\left"+str_cut(SS,J,K-1)+"\\right)";
11857: I0=I=K+1;
11858: }else{
11859: T=T+str_cut(SS,I0,J-1)+"\\left("+texket(str_cut(SS,J+1,K-1)|all=F) +"\\right)";
11860: I0=I=K+1;
11861: }
11862: }else break;
11863: }
11864: return T+str_cut(SS,I0,L);
11865: }
11866:
11867:
11868: def my_tex_form(S)
11869: {
11870: if(getopt(skip) != 1){
11871: if(type(S)==1 && S<0) return "-"+print_tex_form(-S);
11872: if(type(S)==6) return mtotex(S);
11873: S = print_tex_form(S);
11874: for(F=Top=0;(L=str_str(S,"\\verb`"|top=Top))>=0;Top=LV+1){
11875: F++;
11876: if(Top==0) Tb = string_to_tb("");
11877: LV = str_chr(S, L+6, "`");
11878: if(LV<0) LV=str_len(S);
11879: str_tb([my_tex_form(sub_str(S, Top, L-1)|skip=1), "\\texttt{"], Tb);
11880: str_tb([verb_tex_form(sub_str(S,L+6, LV-1)),"}"], Tb);
11881: Top=LV+1;
11882: }
11883: if(F>0){
11884: str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb);
11885: return tb_to_string(Tb);
11886: }
11887: }
11888: if(S==0) return "";
11889: S = ltov(strtoascii(S));
11890: L = length(S)-1;
11891: while(L >= 1 && S[L] == 10)
11892: L--;
11893: if((Fr=getopt(frac))!=0 && Fr!=1) Fr=2;
11894: for(I = L+1, T = K = 0, SS = []; --I >= 0; ){
11895: if(S[I] == 32 && I!=L){
11896: if(I==L) continue;
11897: if(findin(S[I+1], [32,40,41,43,45,123,125]) >= 0 /* " ()+-{}" */
11898: || (S[I+1] >= 49 && S[I+1] <= 57)) /* 1 - 9 */
11899: if(I == 0 || S[I-1] >= 32) continue;
11900: }
11901: if(Fr && S[I]>=48 && S[I]<=57){ /* 2/3 -> \tfrac{2}{3} */
11902: for(K=0,II=I; II>=0; II--){
11903: if(S[II]>=48 && S[II]<=57) continue;
11904: if(S[II]==47){ /* / */
11905: if(K>0) break;
11906: K=II;
11907: }else break;
11908: }
11909: if(K>II+1){
11910: SS=cons(125,SS);
11911: for(J=I; J>K; J--) SS=cons(S[J],SS);
11912: if(AMSTeX){
11913: SS=cons(123,SS);SS=cons(125,SS);
11914: }else{
11915: for(J=[114,101,118,111,92];J!=[];J=cdr(J)) /* \over */
11916: SS=cons(car(J),SS);
11917: }
11918: for(J=K-1;J>II;J--) SS=cons(S[J],SS);
11919: SS=cons(123,SS);
11920: if(AMSTeX){
11921: J=(Fr==2)?[99,97,114,102,116,92]:[99,97,114,102,92];
11922: for(;J!=[];J=cdr(J)) /* \tfrac */
11923: SS=cons(car(J),SS);
11924: }
11925: I=II+1;
11926: }else{
11927: for(;I>II;I--) SS = cons(S[I], SS);
11928: I++;
11929: }
11930: continue;
11931: }
11932: SS = cons(S[I], SS);
11933: }
1.52 takayama 11934: SS=str_subst(SS,"\n\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
1.6 takayama 11935: SS=str_subst(SS,"\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
11936: Subst=getopt(subst);
11937: Sub0=["{asin}","{acos}","{atan}"];
11938: Sub1=["\\arcsin ","\\arccos","\\arctan "];
11939: if(type(Subst) == 4){
11940: Sub0=append(Sub0,Subst[0]);Sub1=append(Sub1,Subst[1]);
11941: }
11942: SS = str_subst(SS,Sub0,Sub1|raw=1);
11943: S = ltov(SS);
11944: L = length(S);
11945: SS = [];
11946: while(--L >= 0){
11947: if(S[I=L] == 125){
11948: while(--I >= 0 && S[I] == 125);
11949: J = 2*I - L;
11950: if(J >= 0 && S[I] != 123){
11951: for(K = J; K < I && S[K] == 123; K++);
11952: if(K == I){
11953: if(J-- <= 0 || S[J] < 65 || S[J] > 122 || (S[J] > 90 && S[J] < 97)){
11954: SS = cons(S[I],SS);
11955: L = J+1;
11956: continue;
11957: }
11958: }
11959: }
11960: }
11961: SS = cons(S[L],SS);
11962: }
11963: RT=getopt(root);
11964: for(Top=0;;Top++){ /* ((x+1))^{y} , 1/y=2,3,...,9 */
11965: #if 1
11966: P=str_str(SS,["))^","^{\\tfrac{1}"]|top=Top);
11967: if(P[0]<0) break;
11968: Sq=0;
11969: if(P[0]==0){
11970: P=P[1];
11971: if((Q=str_pair(SS,P,"(",")"|inv=1))<0||SS[Q+1]!=40) continue;
11972: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
11973: && SS[P+14]==125){
11974: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
11975: }
11976: F=2;
11977: }else{
11978: P=P[1];
11979: if(SS[P+12]!=125||(Sq=(SS[P+11]-48))<2||Sq>9) break;
11980: if(SS[P-1]==125){
11981: if((Q=str_pair(SS,P-2,"{","}"|inv=1))<0) break;
11982: if(Q>1&&SS[Q-1]==95){
11983: if((Q=tex_cuteq(SS,Q-2))<0) break;
11984: F=0;
11985: }else F=1;
11986: }else{
11987: if(!isalphanum(SS[Q=P-1]) || (Q=tex_cuteq(SS,Q))<0) break;
11988: F=0;
11989: }
11990: if(RT!=2&&P-Q>32) break;
11991: }
11992: #else
11993: if((P=str_str(SS,"))^"|top=Top))<0 || (Q=str_pair(SS,P,"(",")"|inv=1))<0) break;
11994: else F=2;
11995: Sq=0;
11996: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
11997: && SS[P+14]==125){
11998: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
11999: }
12000: #endif
12001: for(I=0,S=[];SS!=[];SS=cdr(SS),I++){
12002: if(I==Q){
12003: if(Sq){
12004: S=append([116,114,113,115,92],S);
12005: if(Sq>2) S=append([93,Sq+48,91],S);
12006: S=cons(123,S);
12007: if(F==2) SS=cdr(SS);
12008: else if(F==0) S=cons(car(SS),S);
1.68 takayama 12009: }else if(F==2&&P-Q==3){ /* (2)^x -> 2^x */
1.6 takayama 12010: SS=cdr(SS);SS=cdr(SS);
12011: S=cons(123,S);S=cons(car(SS),S);S=cons(125,S);
12012: SS=cdr(SS);SS=cdr(SS);
12013: I+=3;
12014: }
12015: continue;
12016: }else if(I==P){
12017: if(Sq){
12018: if(F>0) S=cdr(S);
12019: S=cons(125,S);
12020: if(F==2) SS=cdr(SS);
12021: for(J=0;J<12;J++) SS=cdr(SS);
12022: }
12023: continue;
12024: }
12025: S=cons(car(SS),S);
12026: }
12027: SS=reverse(S);
12028: Top=P;
12029: }
1.68 takayama 12030: for(F=G=0,S=[];SS!=[];SS=cdr(SS)){ /* 22^x -> 2\cdot 2^x */
12031: if(F==1&&G!=-1&&car(SS)==123 && length(SS)>1 && isnum(SS[1]))
12032: S=append([116,111,100,99,92],S);
12033: G=F;
12034: if(car(SS)==125||car(SS)==95) F=-1;
12035: else F=isnum(car(SS));
12036: S=cons(car(SS),S);
12037: }
12038: S=asciitostr(reverse(S));
12039: /* S=asciitostr(SS); */
1.6 takayama 12040: if((K=getopt(ket))==1) S=texket(S);
12041: else if(K==2) S=texket(S|all=1);
12042: return S;
12043: }
12044:
12045: def smallmattex(S)
12046: {
12047: return str_subst(S,[["\\begin{pmatrix}","\\left(\\begin{smallmatrix}"],
12048: ["\\end{pmatrix}","\\end{smallmatrix}\\right)"],
12049: ["\\begin{Bmatrix}","\\left\\{\\begin{smallmatrix}"],
12050: ["\\end{Bmatrix}","\\end{smallmatrix}\\right\\}"],
12051: ["\\begin{bmatrix}","\\left[{\\begin{smallmatrix}"],
12052: ["\\end{bmatrix}","\\end{smallmatrix}\\right]"],
12053: ["\\begin{vmatrix}","\\left|\\begin{smallmatrix}"],
12054: ["\\end{vmatrix}","\\end{smallmatrix}\\right|"],
12055: ["\\begin{Vmatrix}","\\left\\|\\begin{smallmatrix}"],
12056: ["\\end{Vmatrix}","\\end{smallmatrix}\\right\\|"],
12057: ["\\begin{matrix}","\\begin{smallmatrix}"],
12058: ["\\end{matrix}","\\end{smallmatrix}"]],0);
12059: }
12060:
12061:
12062: def divmattex(S,T)
12063: {
12064: TF=["matrix","pmatrix","Bmatrix","bmatrix","vmatrix","Vmatrix"];
12065: TG=[0,"(","\\{","[","|","\\|"];
12066: TH=[0,")","\\}","]","|","\\|"];
12067: if(type(S)!=7) S=mtotex(S);
12068: S=strtoascii(S0=S);
12069: if((P0=str_str(S,"\\begin{"))<0 || (P1=str_str(S,"}"|top=P0+7))<0)
12070: return S0;
12071: F=str_cut(S,P0+7,P1-1);
12072: if((K=findin(F,TF))<0) return S0;
12073: Q=str_str(S,"\\end{"+F+"}");
12074: if(Q<0) return S0;
12075: for(J=P1+1;S[J]<33;J++);
12076: for(L0=L=[],I=J;J<Q;J++){
12077: if(S[J]==38){ /* & */
12078: if(I>=J) L0=cons(0,L0);
12079: else L0=cons(str_cut(S,I,J-1),L0);
12080: I=J+1;
12081: }
12082: if(S[J]==92&&S[J+1]==92){ /* \\ */
12083: if(I>=J) L0=cons(0,L0);
12084: else L0=cons(str_cut(S,I,J-1),L0);
12085: L=cons(reverse(L0),L);
12086: L0=[];
12087: J++;
12088: for(I=J+1;S[I]<33;I++);
12089: }
12090: }
12091: J--;
12092: if(S[J]<33) J--;
12093: if(I<=J) L0=cons(str_cut(S,I,J),L0);
12094: if(length(L0)>0) L=cons(reverse(L0),L);
12095: L=lv2m(reverse(L)); /* get matrix */
12096: if(T==0) return L;
1.26 takayama 12097: if(type(T)==1) T=[T];
1.6 takayama 12098: Size=size(L);S0=Size[0];
12099: if(type(T[0])!=4){
12100: S1=Size[1];
12101: T=append(T,[S1]);
12102: for(TT=[],I=0;T!=[];T=cdr(T)){
12103: J=car(T);
12104: if(J>S1) J=S1;
12105: for(T0=[];J>I;J--) T0=cons(J-1,T0);
12106: if(T0!=[]) TT=cons(T0,TT);
12107: I=car(T);
12108: }
12109: T=reverse(TT);
12110: }
12111: SS=length(T);
12112: St=str_tb(0,0);
12113: if(SS==1) St=str_tb("\\begin{"+F+"}\n",St);
12114: else{
12115: if(K>0) St=str_tb("&\\left"+TG[K],St);
12116: St=str_tb("\\begin{matrix}\n",St);
12117: }
12118: for(;T!=[];T=cdr(T)){
12119: for(I=0;I<S0;I++){
12120: for(J=0,TT=car(T);TT!=[];TT=cdr(TT),J++){
12121: if(J>0) St=str_tb("&",St);
12122: if(L[I][car(TT)]!=0) St=str_tb(L[I][car(TT)],St);
12123: }
12124: if(I<S0-1) St=str_tb("\\\\",St);
12125: St=str_tb("\n",St);
12126: }
12127: if(length(T)>1)
12128: St=str_tb("\\end{matrix}\\right.\\\\\n&\\quad\\left.\\begin{matrix}\n",St);
12129: else{
12130: if(SS==1) St=str_tb("\\end{"+F+"}\n",St);
12131: else St=str_tb("\\end{matrix}\\right"+TH[K]+"\n",St);
12132: }
12133: }
12134: S=str_tb(0,St);
12135: if(SS==1) return S;
12136: return texbegin("align*",S);
12137: }
12138:
12139: def str_subst(S, L0, L1)
12140: {
12141: if(type(S) == 7)
12142: S = strtoascii(S);
12143: if(type(S) == 4)
12144: S = ltov(S);
12145: SE = length(S);
12146: if(L1 == 0){
12147: for(L1 = L = [], L0 = reverse(L0); L0 != []; L0 = cdr(L0)){
12148: L = cons(car(L0)[0], L);
12149: L1 = cons(car(L0)[1], L1);
12150: }
12151: L0 = L;
12152: }
12153: if(type(L0)==7) L0 = [strtoascii(L0)];
12154: else{
12155: for(LT = []; L0 != []; L0 = cdr(L0))
12156: LT = cons(strtoascii(car(L0)), LT);
12157: L0 = ltov(LT);
12158: }
12159: E0 = length(L0);
12160: if(type(L1)==7) L1 = [strtoascii(L1)];
12161: else{
12162: for(LT = []; L1 != []; L1 = cdr(L1))
12163: LT = cons(strtoascii(car(L1)), LT);
12164: L1 = ltov(LT);
12165: }
12166: if(getopt(inv)==1){
12167: L2=L0;L0=L1;L0=L2;
12168: }
12169: if((SJIS=getopt(sjis))!=1) SJIS=0;
12170: for(J = JJ = 0, ST = []; J < SE; J++){
12171: SP = S[J];
12172: for(I = E0-1; I >= 0; I--){
12173: if(SP != L0[I][0] || J + (K = length(L0[I])) > SE)
12174: continue;
12175: while(--K >= 1)
12176: if(L0[I][K] != S[J+K]) break;
12177: if(K > 0) continue;
12178: for(KE = length(L1[I]), K = 0 ;K < KE; K++)
12179: ST = cons(L1[I][K],ST);
12180: J += length(L0[I])-1;
12181: break;
12182: }
12183: if(I < 0){
12184: ST = cons(S[J],ST);
12185: if(SJIS && (V=S[J])>128){
12186: if(V<160 || (V>223 && V<240)) ST = cons(S[J++],ST);
12187: }
12188: }
12189: }
12190: if(getopt(raw)==1) return reverse(ST);
12191: return asciitostr(reverse(ST));
12192: }
12193:
12194: def dviout0(L)
12195: {
1.70 takayama 12196: Cmd=["TikZ","TeXLim","TeXEq","DVIOUT","XYPrec","XYcm","XYLim","Canvas","TeXPages"];
1.6 takayama 12197: if(type(Opt=getopt(opt))==7){
12198: if((F=findin(Opt,Cmd)) < 0) return -1;
12199: if(L==-1){
12200: if(F<=3){
12201: if(F==0) V=TikZ;
12202: else if(F==1) V=TeXLim;
12203: else if(F==2) V=TeXEq;
12204: else V=iand(DVIOUTF,1);
12205: }else{
12206: if(F==4) V=XYPrec;
12207: else if(F==5) V=XYcm;
12208: else if(F==6) V=XYLim;
1.70 takayama 12209: else if(F==7) V=Canvas;
12210: else if(F==8) V=TeXPages;
1.6 takayama 12211: }
12212: return V;
12213: }
12214: if(F==0) TikZ=L;
12215: else if(F==2) TeXEq=L;
12216: else if(F==3){
12217: if(iand(DVIOUTF,1)==L)
12218: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
12219: else dviout0(4);
12220: return 1;
12221: }else if(F==7&&type(L)==4)
12222: Canvas=L;
12223: else if(L>0){
12224: if(F==1) TeXLim=L;
12225: else if(F==4) XYPrec=L;
12226: else if(F==5) XYcm=L;
12227: else if(F==6) XYLim=L;
1.70 takayama 12228: else if(F==8) TeXPages=L;
1.6 takayama 12229: }
12230: mycat0([Cmd[F],"=",L],1);
12231: return 1;
12232: }
12233: if(type(L) == 4){
12234: for( ; L != []; L = cdr(L)) dviout0(car(L));
12235: return 1;
12236: }
12237: if(type(L) == 7){
12238: if(L=="") dviout(" \n"|keep=1);
12239: else if(L=="cls") dviout0(0);
12240: else if(L=="show") dviout(" ");
12241: else if(L=="?") dviout0(3);
12242: else dviout("\\"+L+"\n"|keep=1);
12243: return 1;
12244: }
12245: if(L == 0)
12246: dviout(" "|keep=1,clear=1);
12247: else if(L == 1)
12248: dviout(" ");
12249: else if(L == 2)
12250: dviout(" "|clear=1);
12251: else if(L>10)
12252: dviout("\\setcounter{MaxMatrixCols}{"+rtostr(L)+"}%"|keep=1);
12253: else if(L < 0)
12254: dviout(" "|delete=-L,keep=1);
12255: else if(L == 3){
12256: mycat0(["DIROUT =\"", DIROUT,"\""],1);
12257: mycat0(["DVIOUTH=\"", DVIOUTH,"\""],1);
12258: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
12259: mycat0(["DVIOUTB=\"", DVIOUTB,"\""],1);
12260: mycat0(["DVIOUTL=\"", DVIOUTL,"\""],1);
12261: mycat(["Canvas =", Canvas]);
12262: mycat(["TeXLim =", TeXLim]);
1.70 takayama 12263: mycat(["TeXPages =", TeXPages]);
1.6 takayama 12264: mycat(["TeXEq =", TeXEq]);
12265: mycat(["AMSTeX =", AMSTeX]);
12266: mycat(["TikZ =", TikZ]);
12267: mycat(["XYPrec =", XYPrec]);
12268: mycat(["XYcm =", XYcm]);
12269: mycat(["XYLim =", XYLim]);
12270: }else if(L==4){
12271: Tmp=DVIOUTA; DVIOUTA=DVIOUTB; DVIOUTB=Tmp;
12272: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
12273: DVIOUTF++;
12274: }else if(L==5){
12275: if(!iand(DVIOUTF,1)) dviout0(4);
12276: }else if(L==6){
12277: TikZ=1;mycat("TikZ=1");
12278: }else if(L==7){
12279: TikZ=0;mycat("TikZ=0");
12280: }
12281: return 1;
12282: }
12283:
12284: def myhelp(T)
12285: {
12286: /* extern DVIOUT; */
12287: /* extern HDVI; */
12288: /* extern DVIOUTH; */
12289:
12290: if(type(T)==2){
12291: if(T==getbygrs){
12292: getbygrs(0,0);
12293: return 0;
12294: }
12295: else if(T==m2mc){
12296: m2mc(0,0);
12297: return 0;
12298: }
12299: else if(T==mgen){
12300: mgen(0,0,0,0);
12301: return 0;
12302: }
12303: else T=rtostr(T);
12304: }
12305: if(type(T)==4 && typeT[0]==7){
12306: if(length(T)==2 && type(T[1])==1){
12307: DVIOUTH="start "+T[0]+" -"+rtostr(T[1])+"-hyper:0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #r:%LABEL%";
12308: }else if(str_len(T[0])>2) DVIOUTH=T[0];
12309: mycat(["DVIOUTH="+DVIOUTH,"\nmyhelp(fn) is set!"]);
12310: return 0;
12311: }
12312: if(T==0){
12313: mycat([
12314: "myhelp(t) : show help\n",
12315: #ifdef USEMODULE
12316: " t : -1 (dvi), 1 (pdf) or os_md.getbygrs, os_md.m2mc, os_md.mgen\n",
12317: #else
12318: " t : -1 (dvi), 1 (pdf) or getbygrs, m2mc, mgen\n",
12319: #endif
12320: " \"fn\" : Help of the function fn\n",
12321: " [path,n] : path of dviout, n = # dviout\n",
12322: " [DVIOUTH] : Way to jump to the help of a function\n",
12323: " default: start dviout -2 \"%ASIRTOOT%\\help\\os_muldif.dvi\" #r:%LABEL%"
12324: ]);
12325: return 0;
12326: }
12327: if(type(T)==7){
12328: if(str_str(T,"os_md.")==0) T=str_cut(T,6,str_len(T)-1);
12329: Dr=str_subst(DVIOUTH,["%ASIRROOT%","%LABEL%"],[get_rootdir(),"r:"+str_subst(T,"_","")]);
12330: shell(Dr);
12331: return 0;
12332: }
12333: Dr=get_rootdir();
12334: if(T==-1) Dr+="\\help\\os_muldif.dvi";
12335: else Dr+="\\help\\os_muldif.pdf";
12336: if(!isMs()) Dr=str_subst(Dr,"\\","/");
12337: shell(Dr);
12338: return 0;
12339: }
12340:
12341: def isMs()
12342: {
12343: if(type(Tmp=getenv("TEMP"))!=7) {
12344: if (type(Tmp=getenv("TMP")) != 7) Tmp=getenv("HOME");
12345: }
12346: if(type(Tmp)==7 && str_chr(Tmp,0,"\\")==2) return 1;
12347: else return 0;
12348: }
12349:
12350: def tocsv(L)
12351: {
12352: if(type(L)==6) L=m2ll(L);
12353: else if(type(L)==5) L=vtol(L);
12354: Null=getopt(null);
12355: Tb=str_tb(0,0);
12356: for(LL=L; LL!=[]; LL=cdr(LL)){
12357: LT=car(LL);
12358: if(type(LT)==5) LT=vtol(LT);
12359: if(type(LT)<4) LT=[LT];
12360: for(N=0; LT!=[]; LT=cdr(LT),N++){
1.55 takayama 12361: if(N) str_tb(",",Tb);
1.6 takayama 12362: if((T=car(LT))==Null) continue;
12363: if(type(T)==7){
12364: K=str_len(T);
12365: T=str_subst(T,["\""],["\"\""]);
12366: if(str_len(T)>K||str_char(T,0,",")>=0) T="\""+T+"\"";
12367: str_tb(T,Tb);
12368: }else str_tb(rtostr(T),Tb);
12369: }
12370: str_tb("\n",Tb);
12371: }
1.16 takayama 12372: S=str_tb(0,Tb);
12373: if(type(EXE=getopt(exe))!=1&&EXE!=0&&type(EXE)!=7) return S;
12374: if(type(F)!=7){
1.18 takayama 12375: fcat(-1,0);
1.16 takayama 12376: F="risaout";
12377: if(EXE>=2&&EXE<=9) F+=rtostr(EXE);
12378: F=DIROUTD+F+".csv";
12379: }else F=S;
12380: if(EXE!=0 && access(F)) remove_file(F);
12381: fcat(F,S|exe=1);
12382: return 1;
1.6 takayama 12383: }
12384:
12385: def readcsv(F)
12386: {
12387: if((ID=open_file(F))<0) return -1;
12388: SJIS=isMs();
12389: L=[];
12390: if(type(V=getopt(eval))!=4){
12391: if(V=="all") V=1;
12392: else if(type(V)==1) V=[V];
12393: else V=[];
12394: }
1.9 takayama 12395: Eq=getopt(eq);
1.6 takayama 12396: Sp=getopt(sp);
12397: if(type(T=getopt(col))!=1) T=0;
12398: Null=getopt(null);
1.9 takayama 12399: if(type(Null)<0) Null=(Eq==1)?0:"";
1.6 takayama 12400: while((S=get_line(ID))!=0){
12401: S=strtoascii(S);
12402: N=length(S);
12403: for(I=J=F=0,LL=LT=[];I<N;I++){
12404: C=S[I];
12405: if(F==0){
12406: if(C<=32) continue;
12407: if(C==34){F=2;continue;}
12408: F=1;
12409: }
12410: if(F==2 && C==34){
12411: if(I<N-1&& S[I+1]==34){
12412: LT=cons(34,LT);I++;continue;
12413: }
12414: F=-2;
12415: }
12416: if(F==1){
12417: if((C==44&&Sp!=1)||(C<=32&&Sp==1)) F=-1;
12418: else if(C<32 && C!=9) continue;
12419: }
12420: if(SJIS && I<N-1 && ((C>128 && C<160)||(C>223 && C<240))){
12421: LT=cons(C,LT);LT=cons(S[++I],LT);continue;
12422: }
12423: if(F>0){
12424: LT=cons(C,LT);continue;
12425: }
12426: LS=asciitostr(reverse(LT));
1.9 takayama 12427: if(V==1||findin(++J,V)>=0){
12428: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
12429: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
12430: }
1.6 takayama 12431: if(!T || T==J) LL=cons(LS,LL);
12432: if(F==-2) while(++I<N && Sp!=1 && S[I]!=44);
12433: F=0;LT=[];
12434: }
12435: if(I<=N && (Sp!=1 || length(LT)>0)){ /* lastline */
12436: LS=asciitostr(reverse(LT));
1.9 takayama 12437: if(V==1||findin(++J,V)>=0){
12438: if(Eq==1) LS=(LS=="")?Null:eval_str(LS);
12439: else LS=(isdecimal(LS))?eval_str(LS):((LS=="")?Null:LS);
12440: }
1.6 takayama 12441: if(!T || T==J) LL=cons(LS,LL);
12442: }
12443: L=cons(reverse(LL),L);
12444: }
12445: close_file(ID);
12446: if(T) L=m2l(L|flat=1);
1.16 takayama 12447: L=reverse(L);
12448: return L;
1.6 takayama 12449: }
12450:
1.55 takayama 12451: def getline(ID)
12452: {
12453: if(isint(Maxlen=getopt(Max))>0) Maxlen=1024;
12454: if(type(CR=getopt(CR))!=4) CR=[13];
12455: if(type(LF=getopt(LF))!=4) LF=[10];
12456: S=[];
12457: for(I=0; I<1023; I++){
12458: C=get_byte(ID);
12459: if(C<0) return 0;
12460: if(findin(C,CR)>=0) continue;
12461: if(findin(C,LF)>=0) break;
12462: S=cons(C,S);
12463: }
12464: return asciitostr(reverse(S));
12465: }
12466:
1.6 takayama 12467: def showbyshell(S)
12468: {
12469: Id = getbyshell(S);
12470: if(Id<0) return Id;
12471: while((S=get_line(Id))!=0) print(S,2);
12472: return close_file(Id);
12473: }
12474:
12475:
12476: def getbyshell(S)
12477: {
12478: /* extern DIROUT; */
12479:
12480: Home=getenv("HOME");
12481: if(type(Home)!=7) Home="";
12482: if(type(Tmp=getenv("TEMP"))!=7 && type(Tmp=getenv("TMP")) != 7)
12483: Tmp=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
12484: Sep=isMs()?"\\":"/";
12485: F=Tmp+Sep+"muldif.tmp";
1.16 takayama 12486: if(type(S)<=1 && S>=0) close_file(S);
1.6 takayama 12487: remove_file(F);
12488: if(type(S)<=1) return -1;
12489: shell(S+" > \""+F+"\"");
12490: return open_file(F);
12491: }
12492:
1.69 takayama 12493: def isfctr(P)
12494: {
12495: if(type(P)>3) return 0;
12496: if(type(P)==3) return (!isfctr(nm(P))||!isfctr(dn(P)))?0:1;
12497: V=ptol(P,vars(P)|opt=0);
12498: for(;V!=[];V=cdr(V)){
12499: if(type(car(V))>1||ntype(car(V))>0) return 0;
12500: }
12501: return 1;
12502: }
12503:
1.6 takayama 12504: def show(P)
12505: {
12506: T=type(P);
12507: S=P;
12508: Var=getopt(opt);
1.69 takayama 12509: if((Raw=getopt(raw))!=1) Raw=0;
1.6 takayama 12510: if(Var=="verb"){
1.69 takayama 12511: S="{\\tt"+verb_tex_form(T)+"}\n\n";
12512: if(Raw) return S;
12513: dviout(S);return;
1.6 takayama 12514: }
12515: if(type(Var)<0) Var=getopt(var);
12516: if(T==6){
12517: if((Sp=getopt(sp))==1 || Sp==2)
12518: S=mtotex(P|lim=1,small=2,sp=Sp,null=1,mat="B");
12519: else if(type(Var)==4 || type(Var)==7)
12520: S=mtotex(P|lim=1,small=2,var=Var);
12521: else
12522: S=mtotex(P|lim=1,small=2);
12523: Size=size(P);
12524: Size=(Size[0]>Size[1])?Size[0]:Size[1];
12525: if(Size>10) dviout0(Size);
12526: }else if(T<=3){
12527: X=0;
12528: if(Var=="pfrac") X=var(P);
12529: else X=getopt(pfrac);
12530: if(isvar(X)){
1.69 takayama 12531: if(Raw) return pfrac(P,X|TeX=1);
12532: pfrac(P,X|dviout=1);return;
1.6 takayama 12533: }
1.69 takayama 12534: Opt=getopt();
12535: if(type(Var)!=2&&type(Var)!=4&&type(Var)!=7){
1.6 takayama 12536: if(isdif(P)!=0) Opt=cons(["var","dif"],Opt);
12537: else Opt=cons(["br",1],Opt);
12538: }
1.69 takayama 12539: if(!isfctr(P)){
12540: if(Raw) return my_tex_form(P);
12541: else{
12542: dviout(P); return;
12543: }
12544: }
12545: if(Raw) return fctrtos(P|option_list=cons(["TeX",3],Opt));
1.70 takayama 12546: fctrtos(P|option_list=cons(["pages",2],cons(["dviout",1],Opt)));return;
1.6 takayama 12547: }else if(T==4){
1.70 takayama 12548: F=0;N=length(getopt());
12549: if(Raw) N--;
12550: if(N==1){
12551: if(type(Var=getopt(var))>1){
12552: if(isvar(Var)) Var=[0,Var];
1.71 takayama 12553: else if(type(Var)==4&&Var[0]!=0) Var=cons(0,Var);
1.70 takayama 12554: else Var=0;
12555: }else if(type(Var=getopt(eqs))!=4) Var=0;
12556: }else if(N==0) Var=[];
12557: else Var=0;
12558: if(type(Var)==4){
12559: for(F=0,L=P;L!=[];L=cdr(L)){ /* */
12560: if(type(car(L))==2) F+=nmono(car(L));
12561: else{
12562: F=0;break;
12563: }
12564: }
12565: }
12566: if(F>50){
12567: S=texbegin("align*",eqs2tex(P,Var));
12568: if(Raw) return S;
12569: dviout(S);return;
12570: }
1.6 takayama 12571: if(type(Var)==4 || type(Var)==7){
12572: S=ltotex(P|option_list=getopt());
12573: if(Var=="text"){
1.69 takayama 12574: if(Raw) return S;
12575: dviout(S);return;
1.6 takayama 12576: }
12577: }else{
12578: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
12579: LL=car(L);
12580: if(type(LL)==4){
12581: if(F==0){
12582: T=type(LL[0]);
12583: if(T==4) F=2; /* [[[? */
12584: else if(T==1 || T==0) F=1; /* [[num,.. */
12585: }
12586: if(F==1){
12587: if(length(LL)!=2 || !isint(LL[0]) || LL[0]<0 || type(LL[1])>3)
12588: F=-1; /* [[num,rat],[num,rat],...] */
12589: }else if(F==2){
12590: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
12591: LLL=car(LLT); /* [[[num,rat],[num,rat],...],[[..],..]],....] */
12592: if(length(LLL)!=2 || !isint(LLL[0]) || LLL[0]<0 || type(LLL[1])>3)
12593: F=-1;
12594: }
12595: }
12596: }else if((F==0 || F==7) && type(LL)==7){
12597: F=7;
12598: }else F=-1;
12599: }
12600: if(F==1) S=ltotex(P|opt="spt");
12601: else if(F==2){
12602: M=mtranspose(lv2m(S));
1.69 takayama 12603: if(Raw) return show(M|sp=1,raw=1); /* GRS */
12604: show(M|sp=1);return;
1.6 takayama 12605: }else if(F==7) S=ltotex(P|opt="spts");
12606: else{
12607: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
12608: LL=car(L);
12609: if(type(LL)!=4){
12610: F=-1; break;
12611: }
12612: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
12613: T=type(LLL=car(LLT));
12614: if(T<7 && T!=4) F0++;
12615: else if(T==7){
12616: if(str_char(LLL,0,"\\")<0) F1++;
12617: else F2++;
12618: }else F=-1;
12619: }
12620: }
12621: }
12622: if(F==0 && F0>0 && (F1+F2)>0){ /* list of list of eq and str */
12623: if(F2>0) S=ltotex(P|opt=["cr","spts0"],str=1);
12624: else S=ltotex(P|opt=["cr","spts"]);
12625: }else{
12626: for(S="[";;){
12627: S+=my_tex_form(car(P));
12628: if((P=cdr(P))==[]){
12629: S+="]";break;
12630: }
12631: S+=",";
12632: }
12633: }
12634: }
12635: }else if(T==7){
1.71 takayama 12636: if(Var=="raw") S=P+"\n\n";
12637: else if(Var != "eq" &&str_str(P,"\\begin"|end=128)<0){
12638: if((TikZ&&str_str(P,"\\draw"|end=128)>=0)||(!TikZ&&str_str(P,"\\ar@"|end=128)>=0))
12639: S=xyproc(P);
1.72 takayama 12640: }else if(Var !="eq"){
12641: if(str_str(P,"\\begin{align")>=0 || str_str(P,"\\[")>=0
12642: || str_str(P,"\\begin{equation")>=0
12643: || (str_char(P,0,"^")<0 && str_char(P,0,"_")<0 && str_char(P,0,"&")<0))
12644: S=P+"\n\n";
12645: }
1.71 takayama 12646: if(P!=S){
12647: if(Raw) return S;
12648: dviout(S); return;
1.6 takayama 12649: }
12650: }
1.69 takayama 12651: if(Raw) return "\\begin{align}\\begin{split}\n &"+S+"\\end{split}\\end{align}";
12652: else dviout(S|eq=5);
1.6 takayama 12653: }
12654:
12655:
12656: /* options : eq = 1 - 8, clear=1, keep=1, delete=1, title=s,
12657: fctr=1, begin=s */
12658: def dviout(L)
12659: {
12660: /* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTB, DVIOUTL; */
12661:
12662: MyEq = [
12663: ["\\[\n ","\\]"],
12664: ["\\begin{align}\n","\\end{align}"],
12665: ["\\begin{gather}\n ","\\end{gather}"],
12666: ["\\begin{multline}\n ","\\\\[-15pt]\\end{multline}"],
12667: ["\\begin{align}\\begin{split}\n &","\\end{split}\\end{align}"],
12668: ["\\begin{align*}\n &","\\end{align*}"],
12669: ["\\begin{gather*}\n ","\\end{gather*}"],
12670: ["\\begin{equation}\n ","\\end{equation}"]
12671: ];
12672: if(!chkfun("print_tex_form", "names.rr"))
12673: return 0;
12674: Home=getenv("HOME");
12675: if(type(Home)!=7) Home="";
12676: Dir=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],[Home,get_rootdir(),"/"]);
12677: Dirout=Dir+(AMSTeX?"/out.tex":"/out0.tex");
12678: Risaout=(AMSTeX)?"risaout":"risaout0";
12679: Dirisa=Dir+"/"+Risaout+".tex";
12680: Viewer="dviout";
12681: SV=["c:/w32tex/dviout","c:/dviout"];
12682: Risatex=str_subst(AMSTeX?DVIOUTA:DVIOUTL,
12683: ["%HOME%","%ASIRROOT%","%TikZ%"],[Home,get_rootdir(),rtostr(TikZ)]);
12684: if(isMs() && !access(Risatex)){
12685: for(TV=SV; TV!=[]; TV=cdr(TV)){
12686: VV=car(TV)+"/dviout.exe";
12687: if(access(VV)){
12688: Viewer=str_subst(VV,"/","\\");
12689: break;
12690: }
12691: }
12692: output(Risatex);
12693: print("cd \""+str_subst(Dir,"/","\\")+"\"");
12694: print("latex -src=cr,display,hbox,math,par "+Risaout);
12695: print("start "+Viewer+" -1 \""+Dr+"\\tex\\"+Risaout+"\" 1000");
12696: output();
12697: }
12698: if(access(Dirisa) == 0){
12699: D0="\""+(isMs()?str_subst(Dir,"/","\\")+"\"":Dir);
12700: shell("mkdir "+D0);
12701: output(Dirisa);
12702: if(AMSTeX){
12703: print("\\documentclass[a4paper]{amsart}");
12704: print("\\usepackage{amsmath,amssymb,amsfonts}");
12705: }else
12706: print("\\documentclass[a4paper]{article}");
12707: print("\\pagestyle{empty}\n\\begin{document}\n\\thispagestyle{empty}");
12708: print(AMSTeX?"\\input{out}\n\\end{document}":"\\input{out0}\n\\end{document}");
12709: output();
12710: }
12711: if((K = getopt(delete)) >= 1){ /* delete */
12712: LC = 0;
12713: if(type(K) == 1 && K > 10) K = 10;
12714: if(type(K) == 4){
12715: K = qsort(K);
12716: LC = 1; /* specific lines */
12717: }
12718: Done = 1;
12719: Id = open_file(Dirout);
12720: if(Id >= 0){
12721: Buf = Buf0 = Buf1 = Key = "";
12722: PE = 0;
12723: if(type(K) == 1)
12724: BufE = newvect(K--);
12725: Dout = Dirout+"0";
12726: remove_file(Dout);
12727: output(Dout);
12728: while((S = get_line(Id)) != 0){
12729: if(LC){
12730: while(K != [] && car(K) < LC)
12731: K = cdr(K);
12732: if(K == [] || car(K) > LC)
12733: output(S);
12734: }
12735: if(Key == ""){
12736: if((P0 = str_str(S,"\\begin{")) == 0){
12737: Key = sub_str(S,7,str_str(S,"}")-1);
12738: if(findin(Key,["align", "gather","multline", "equation","align*"]) < 0)
12739: Key = "";
12740: else{
12741: Key = "\\end{"+Key+"}";
12742: if(!LC){
12743: if(Buf != ""){
12744: if(PE < K)
12745: BufE[PE++] = Buf1+Buf;
12746: else{
12747: if(K > 0){
12748: print(BufE[0]);
12749: for(I = 1; I < K; I++)
12750: BufE[I-1]=BufE[I];
12751: BufE[K-1] = Buf1+Buf;
12752: }else
12753: print(Buf1+Buf);
12754: Done = 0;
12755: }
12756: Buf1 = Buf0;
12757: Buf = Buf0 ="";
12758: }
12759: }
12760: }
12761: }
12762: if(Key == "" && !LC) Buf0 += S;
12763: }
12764: if(Key != ""){
12765: if(!LC) Buf += S;
12766: if(str_str(S,Key) >= 0){
12767: Key = "";
12768: if(LC) LC++;
12769: }
12770: }
12771: }
12772: output();
12773: close_file(Id);
12774: }
12775: if(Done==0){
12776: Id = open_file(Dout);
12777: if(Id >= 0){
12778: remove_file(Dirout);
12779: output(Dirout);
12780: while((S = get_line(Id)) != 0)
12781: print(S,0);
12782: output();
12783: close_file(Id);
12784: }
12785: remove_file(Dout);
12786: }else L=" ";
12787: }
12788: if(getopt(clear) == 1 || Done == 1){ /* clear */
12789: remove_file(Dirout);
12790: if(L == "" || L == " "){
12791: output(Dirout);
12792: print("\\centerline{Risa/Asir}");
12793: output();
12794: }
12795: }
12796: if(L != " "){
12797: Eq=1;
12798: Eqo = getopt(eq);
12799: Fc = getopt(fctr);
12800: if(Fc == 1 && (type(L) == 2 || type(L) == 3)){
12801: L = fctrtos(L|TeX=1);
12802: if(type(L) == 4)
12803: L = "\\fact{"+L[0]+"}{"+L[1]+"}";
12804: if(type(Eqo) != 0 && type(Eqo) !=7){
12805: Eqo=0;
12806: }
12807: }
12808: if(type(L) != 4 || getopt(mult) != 1)
12809: L = [L];
12810: if(type(Eqo)!=7 && (Eqo<1 || Eqo>8))
12811: Eqo = (AMSTeX==1)?TeXEq:1;
12812: Title = getopt(title);
12813: if(type(Title) == 7){
12814: output(Dirout);
12815: print(Title);
12816: output();
12817: }
12818: Sb = getopt(subst);
12819: for( ; L != []; L = cdr(L)){
12820: Eq = 1;
12821: if(type(LT=car(L)) != 7 && type(LT) != 21)
12822: LT = my_tex_form(LT);
12823: else if(type(getopt(eq)) < 0)
12824: Eq = 0;
12825: if(type(Sb) == 4)
12826: LT = str_subst(LT,Sb[0],Sb[1]);
12827: output(Dirout);
12828: if(Eq == 1){
12829: if(type(Eqo)==7)
12830: print(texbegin(Eqo,LT));
12831: else if(Eqo >= 1 && Eqo <= 8){
12832: mycat0([MyEq[Eqo-1][0],LT,"%"],1);
12833: print(MyEq[Eqo-1][1]);
12834: }else print(LT);
12835: }else print(LT);
12836: output();
12837: }
12838: }
12839: if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTB,0," ")<0
12840: && str_char(DVIOUTL,0," ")<0)
12841: Risatex="\""+Risatex+"\"";
12842: if(getopt(keep) != 1) shell(Risatex);
12843: return 1;
12844: }
12845:
12846: def rtotex(P)
12847: {
12848: S = my_tex_form(P);
12849: return (str_len(S) == 1)?S:"{"+S+"}";
12850: }
12851:
1.79 takayama 12852: def togreek(P,T)
12853: {
12854: R0=[a,b,c,d,e,i,k,l,m,n,o,p,r,s,t,u,x,z];
12855: R1=[alpha,beta,gamma,delta,epsilon,iota,kappa,lambda,
12856: mu,nu,omega,pi,rho,sigma,theta,tau,xi,zeta];
12857: if(T==0||T==[]) T=[a,b,c];
12858: for(S=[],TR=T;TR!=[];TR=cdr(TR)){
12859: if(type(TR[0])!=4){
12860: if((I=findin(car(TR),R0))>=0) S=cons([car(TR),R1[I]],S);
12861: }else if((I=findin(car(TR)[0],R0))>=0){
12862: for(U=car(TR)[1];U!=[];U=cdr(U))
12863: S=cons([makev([R0[I],car(U)]),makev([R1[I],car(U)])],S);
12864: }
12865: }
12866: if(getopt(raw)==1) return S;
12867: if(getopt(inv)==1) return mysubst(P,S|inv=1);
12868: else return mysubst(P,S);
12869: }
12870:
1.6 takayama 12871: def mtotex(M)
12872: {
12873: /* extern TexLim; */
12874:
12875: MB=mat(["(",")","p"],["\\{","\\}","B"],["[","]","b"],["|","|","v"],
12876: ["\\|","\\|","V"], [".",".",""]);
12877: if(type(MT=getopt(mat))==7){
12878: MT=findin(MT,["p","B","b","v","V",""]);
12879: if(MT<0) MT=0;
12880: }
12881: else MT=0;
12882: MT=MB[MT];
12883: if((F=getopt(small))!=1 && F!=2) F=0;
12884: Lim=getopt(lim);
12885: if(type(Lim)==1){
12886: if(Lim<30 && Lim!=0) Lim = TexLim;
12887: }else Lim=0;
12888: FL=getopt(len);
12889: Rw=getopt(raw);
12890: Sp=getopt(sp);
12891: Idx=getopt(idx);
12892: if(type(Idx)==4) Idx=ltov(Idx);
12893: if(type(Idx)==6 && length(Idx)==0) Idx=-1;
12894: Var=getopt(var);
12895: if(Lim>0) FL=1;
12896: Null=getopt(null);
12897: if(Null!=1 && Null!=2) Null=0;
12898: if(type(M)==5) M=lv2m([V]);
12899: else if(type(M)!=6) return monototex(M);
12900: S=size(M);
12901: if(FL==1){
12902: L=newmat(S[0],S[1]); LL=newvect(S[1]);
12903: }
12904: SS=newmat(S[0],S[1]);
12905: for(I=0; I<S[0]; I++){
12906: for(J=0; J<S[1]; J++){
12907: if(type(P=M[I][J])<=3){
12908: if(P!=0 || Null == 0 || (Null==2 && I==J)){
12909: SS[I][J]=(type(Var)>1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0);
12910: if(type(P)==1 && str_str(SS[I][J],"\\frac{-"|end=0)==0)
12911: SS[I][J]="-\\frac{"+str_cut(SS[I][J],7,100000);
12912: }
12913: }else if(type(P)==6){
12914: ST= mtotex(P|small=1,len=1);
12915: SS[I][J]=ST[0];
12916: L[I][J]=ST[1];
12917: }else if(type(P)==7){
12918: if(Rw==1) SS[I][J]=P;
12919: else SS[I][J]="\\text{"+P+"\}";
12920: }else if(type(P)==4 && length(P)==2 && P[0]>0 && (Sp==1 || Sp==2)){
12921: if(P[0]==1){
12922: SS[I][J]=fctrtos(P[1]|TeX=2,lim=0);
12923: }else{
12924: ST=my_tex_form(P[0]);
12925: if(Sp==2) ST="("+ST+")";
12926: SS[I][J]="["+fctrtos(P[1]|TeX=2,lim=0)+"]_";
12927: if(str_len(ST)<2) SS[I][J]+=ST;
12928: else SS[I][J]+="{"+ST+"}";
12929: }
12930: }else
12931: SS[I][J]=my_tex_form(P);
12932: if(FL==1) L[I][J]=texlen(SS[I][J]);
12933: }
12934: }
12935: if(Lim>0 || FL==1){
12936: for(LLL=J=0; J<S[1];J++){
12937: for(I=K=0; I<S[0];I++){
12938: if(K<L[I][J]) K=L[I][J];
12939: }
12940: LLL+=(LL[J]=K);
12941: }
12942: }
12943: if(Lim>0){
12944: if(F==2 && LLL>Lim-2*S[1]-2) F=1;
12945: if(F==1)
12946: Lim=idiv(Lim*6,5);
12947: if(LLL<=Lim-(2-F)*S[I]-2) Lim=0;
12948: }
12949: Mat=(F==1)?"smallmatrix}":"matrix}";
12950: if(F==1) Out=str_tb("\\left"+MT[0]+"\\begin{",0);
12951: else Out=str_tb((Lim==0)?"\\begin{"+MT[2]:"\\left"+MT[0]+"\\begin{",0);
12952: Out = str_tb(Mat,Out);
12953: for(I=II=LT=0; II<=S[0]; II++){
12954: if(Lim==0) II=S[0];
12955: if(II<S[0]){
12956: K=LL[II]+(2-F);
12957: if(I==II){
12958: LT+=K;
12959: continue;
12960: }
12961: if(LT+K<Lim-2) continue;
12962: LT=K;
12963: }
12964: for(I0=I; I<II; I++){
12965: if(I==I0){
12966: str_tb((I==0)?
12967: "\n ":
12968: "\\right.\\\\\n \\allowdisplaybreaks\\\\\n &\\ \\left.\\begin{"+Mat+"\n ", Out);
12969: if(Idx==1||Idx==0||type(Idx)==5){
12970: for(J=I; J<II; J++){
12971: if(type(Idx)!=4)
12972: str_tb("("+rtostr(J+Idx)+")",Out);
12973: else{
12974: JJ=length(Idx)-1;
12975: if(J<JJ) JJ=J;
12976: str_tb(my_tex_form(Idx[JJ]),Out);
12977: }
12978: if(J<II) str_tb(" & ",Out);
12979: }
12980: str_tb("\\\\\n ",Out);
12981: }
12982: }
12983: else str_tb("\\\\\n ",Out);
12984: for(J=0; J<S[1]; J++){
12985: if(J!=0) str_tb(" & ",Out);
12986: if(type(SS[I][J])==7) str_tb(SS[I][J],Out);
12987: }
12988: }
12989: Out=str_tb("\n\\end{", Out);
12990: if(II==S[0]) Out=str_tb((Lim==0&&F!=1)?MT[2]+Mat:Mat+"\\right"+MT[1],Out);
12991: else Out=str_tb(Mat+"\\right.",Out);
12992: }
12993: SS = str_tb(0,Out);
12994: if(FL!=1) return SS;
12995: if(F==1) LLL=idiv((LLL+S[1])*5+13,6);
12996: else LLL+=2*(1+S[1]);
12997: return [SS,LLL];
12998: }
12999:
13000: def sint(N,P)
13001: {
1.11 takayama 13002: if( type(N)==1 || N==0 ) {
1.6 takayama 13003: NT=ntype(N);
13004: if((type(Opt=getopt(str))==1 || Opt==0) && Opt>=0 && P>=0){
13005: if(Opt==2 || Opt==4 || Opt==0){
1.11 takayama 13006: if(N==0) return (Opt>0)?"0":0;
1.6 takayama 13007: Pw=0;
13008: if(NT==4){
13009: NN=abs(real(N));N1=abs(imag(N));
13010: if(NN<N1) NN=N1;
13011: }else NN=abs(N);
13012: while(NN<1 && NN>-1){
13013: Pw--;
13014: N*=10;NN*=10;
13015: }
13016: while(N>=10 || N<=-10){
13017: Pw++;
13018: N/=10;NN/=10;
13019: }
13020: if(Opt==0) return sint(N*10^Pw,P-Pw-1);
13021: S=(getopt(sqrt)==1)?sint(N,P|str=(Opt==4)?3:1,sqrt=1):sint(N,P|str=(Opt==4)?3:1);
13022: if(Pw==0) return S;
13023: if(NT==4)
13024: S="("+S+")";
13025: if(Pw==1){
13026: if(Opt==2)
13027: return S+"*10";
13028: else
13029: return S+"\\times10";
13030: }
13031: if(Opt==2)
13032: return S+"*10^("+rtostr(Pw)+")";
13033: else
13034: return S+"\\times10^{"+rtostr(Pw)+"}";
13035: }
13036: if(NT==4){
13037: NN=real(N);
13038: if(NN!=0){
13039: S=sint(NN,P|str=1);
13040: if(imag(N)>0) S=S+"+";
13041: }
13042: else S="";
13043: S=S+sint(imag(N),P|str=1)+((Opt==3)?((getopt(sqrt)==1)?"\\sqrt{-1}":"i"):"@i");
13044: return S;
13045: }
13046: if(N<0){
13047: N=-N;
13048: Neg="-";
13049: }else Neg="";
1.11 takayama 13050: N=rint(N*10^P)/10^P;
1.6 takayama 13051: NN=floor(N);
1.11 takayama 13052: NV=(N-NN+1)*10^P;
1.6 takayama 13053: NS=rtostr(NN);
13054: if(P<=0) return Neg+NS;
13055: if(NN==0 && getopt(zero)==0) NS="";
1.11 takayama 13056: return Neg+NS+"."+str_cut(rtostr(NV),1,P);
1.6 takayama 13057: }
13058: if(NT==4)
13059: return sint(real(N),P)+sint(imag(N),P)*@i;
13060: X = rint( N*10^P );
1.11 takayama 13061: return deval(X/10^P);
1.6 takayama 13062: }
13063: if( (type(N)==2) || (type(N)==3) ){
13064: NN = eval(N);
13065: if( type(NN)==1 )
13066: return sint(NN,P|option_list=getopt());
13067: else return N;
13068: }
1.8 takayama 13069: if( type(N)>3 && type(N) < 7)
1.6 takayama 13070: #ifdef USEMODULE
13071: return mtransbys(os_md.sint,N,[P]|option_list=getopt());
13072: #else
13073: return mtransbys(sint,N,[P]|option_list=getopt()));
13074: #endif
1.8 takayama 13075: return N;
1.6 takayama 13076: }
13077:
13078: def frac2n(N)
13079: {
13080: if((T=type(N))<0) return N;
13081: E=(getopt(big)==1)?eval(@e):0.1;
13082: if(T==1){
1.15 takayama 13083: if(ntype(N)==0) return (E*N)/E;
1.6 takayama 13084: else if(ntype(N)!=4) return N;
1.15 takayama 13085: else return (E*(1+@i)*N)/(E*(1+@i));
1.6 takayama 13086: }
13087: if(T==3||T==2){
13088: N=red(N);
13089: Nm=nm(N);Var=vars(Nm);V=car(Var);K=length(Var);
13090: for(S=0,I=mydeg(Nm,V);I>=0;I--) S+=frac2n(mycoef(Nm,I,V))*V^I;
13091: return S/dn(N);
13092: }
1.15 takayama 13093: if(T<4) return (E*N)/E;
1.6 takayama 13094: #ifdef USEMODULE
13095: return mtransbys(os_md.frac2n,N,[]|option_list=getopt());
13096: #else
13097: return mtransbys(frac2n,N,[]|option_list=getopt());
13098: #endif
13099: }
13100:
1.71 takayama 13101: /* Option : opt */
1.70 takayama 13102: def ptconvex(L)
13103: {
1.71 takayama 13104: if(!(isint(Opt=getopt(opt)))) Opt=0;
13105: L0=car(L);X=L0[0];Y=L0[1];
1.70 takayama 13106: for(TL=cdr(L);TL!=[];TL=cdr(TL)){ /* find the most left pt L0 */
1.71 takayama 13107: if(X<car(TL)[0]||(X==car(TL)[0]&&Y<car(TL)[1])) continue;
1.70 takayama 13108: L0=car(TL);X=car(L0);
13109: }
1.71 takayama 13110: if(Opt==3) return L0;
1.70 takayama 13111:
13112: R=[]; /* find a polygone through all points */
13113: X0=L0[0];Y0=L0[1];
13114: for(TL=L;TL!=[];TL=cdr(TL)){
1.71 takayama 13115: L0=car(TL);
13116: X=L0[0]-X0;Y=L0[1]-Y0;S=X^2+Y^2;
13117: L0=(!S)? append([-8,0],L0):append([(Y>0?Y^2:-Y^2)/S,S],L0);
13118: R=cons(L0,R);
1.70 takayama 13119: }
13120: L=qsort(R);
13121: if(Opt==2) return L;
13122:
1.71 takayama 13123: for(R=[],TL=L;TL!=[];TL=cdr(TL)){
13124: if(Opt==4){
13125: L0=car(TL);
13126: V=car(L0);
13127: L0=append(cdr(cdr(L0)),[V]);
13128: }else L0=cdr(cdr(car(TL)));
13129: R=cons(L0,R);
13130: }
13131: L=reverse(R);
13132: if(Opt==1) return L;
13133: R=[cons(V0=-8,L0=car(L))];
1.70 takayama 13134: for(TL=cdr(L);TL!=[];TL=cdr(TL)){
1.71 takayama 13135: V=darg(L0,L1=car(TL));
13136: if(V<-4) continue;
1.70 takayama 13137: while(V<V0){
13138: R=cdr(R);
1.71 takayama 13139: V0=car(car(R));
13140: V=darg(cdr(car(R)),L1);
1.70 takayama 13141: }
13142: if(V==V0) R=cdr(R);
1.71 takayama 13143: R=cons(cons(V0=V,L0=L1),R);
1.70 takayama 13144: }
1.71 takayama 13145: for(L=[],TL=R;TL!=[];TL=cdr(TL)) L=cons(cdr(car(TL)),L);
1.70 takayama 13146: return L;
13147: }
13148:
1.71 takayama 13149: def darg(P,Q)
13150: {
13151: if(type(car(P))==4){
13152: if((V=darg(Q[0],Q[1]))<-1) return -8;
13153: if((V-=darg(P[0],P[1]))>2){
13154: if((V-=4)>4) return -4;
13155: }else if(V<=-2) V+=4;
13156: return V;
13157: }
13158: X=Q[0]-P[0];Y=Q[1]-P[1];
13159: if(!(S=X^2+Y^2)) return -8;
13160: V=Y^2/S;
13161: if(Y<0) V=-V;
13162: return X<=0?2-V:V;
13163: }
13164:
13165: def dwinding(P,Q)
13166: {
13167: V=V0=V1=darg(P,Q0=car(Q));
13168: Q=cons(Q0,reverse(Q));
13169: for(Q=cdr(Q);Q!=[];Q=cdr(Q)){
13170: if((V2=darg(P,car(Q)))<-4) return 1/3;
13171: V1=V2-V1;
13172: if(V1==2||V1==-2) return 1/2;
13173: if(V1<-2) V1+=4;
13174: else if(V1>2) V1-=4;
13175: V+=V1;
13176: V1=V2;
13177: }
13178: return floor((V0-V+1/2)/4);
13179: }
13180:
1.6 takayama 13181: def xyproc(F)
13182: {
13183: if(type(Opt=getopt(opt))!=7) Opt="";
13184: if(type(Env=getopt(env))!=7)
13185: Env=(!TikZ)?"xy":"tikzpicture";
13186: if(F==1)
13187: return(Opt=="")?"\\begin{"+Env+"}\n":"\\begin{"+Env+"}["+Opt+"]\n";
13188: if(F==0) return "\\end{"+Env+"}\n";
13189: if(type(F)==7){
13190: F=xyproc(1|opt=Opt,env=Env)+F+xyproc(0|env=Env);
13191: if(getopt(dviout)==1) dviout(F);
13192: else return F;
13193: }
13194: }
13195:
13196: def xypos(P)
13197: {
13198: if(type(P[0])==7){
13199: if(P[0]=="") S="";
13200: else S=(!TikZ)?"\""+P[0]+"\"":"("+P[0]+")";
13201: }
13202: else{
13203: if(TikZ==0 && XYcm==1){
13204: X=sint(P[0]*10,XYPrec); Y=sint(P[1]*10,XYPrec);
13205: }else{
13206: X=sint(P[0],XYPrec); Y=sint(P[1],XYPrec);
13207: }
13208: S="("+rtostr(X)+","+rtostr(Y)+")";
13209: }
13210: if(!TikZ){
13211: if(length(P)>2 && (PP=P[2])!=""){
13212: S=S+" *";
13213: if(type(PP)==4 && length(PP)==2 && type(PP[0])==7){
13214: S=S+PP[0];
13215: PP=PP[1];
13216: }
13217: if(type(PP)==7){
13218: L=str_len(PP);
13219: if(str_chr(PP,0,"$")==0 && str_chr(PP,L-1,"$")==L-1){
13220: PP=str_cut(PP,1,L-2);
13221: }else S+="\\txt";
13222: }
13223: else PP=my_tex_form(PP);
13224: S=S+"{"+PP+"}";
13225: }
13226: if(length(P)>3){
13227: if(type(P[3])==7 && P[3]!="") S=S+"=\""+P[3]+"\"";
13228: if(length(P)>4 && type(P[4])==7) S=S+P[4];
13229: }
13230: }else{
13231: T="";
13232: if(length(P)>2 && (PP=P[2])!=""){
13233: F=1;
13234: if(type(PP)==4){
13235: if(length(PP)==2 && type(PP[0])==7){
13236: T="["+PP[0]+"]";
13237: PP=PP[1];
13238: }
13239: }
13240: if(type(PP)!=7) PP="$"+my_tex_form(PP)+"$";
13241: S=S+"{"+PP+"}";
13242: }else F=0;
13243: if(length(P)>3){
13244: if(type(P[3])==7 && P[3]!="") T=T+"("+P[3]+")";
13245: else if(P[3]==1) T=T+"(_)";
13246: if(length(P)>4 && type(P[4])==7) S=S+P[4];
13247: }
13248: if(length(P)>2){
13249: if(F) S="node"+T+" at"+S;
13250: else S="coordinate"+T+" at"+S;
13251: }
13252: }
13253: return S;
13254: }
13255:
13256: def xyput(P)
13257: {
1.81 takayama 13258: if(type(T=car(P))==4||type(car(P)==5)){
13259: P=cdr(P);P=cons(T[1],P);P=cons(T[0],P);
13260: }
1.6 takayama 13261: if((type(Sc=getopt(scale))==1 && Sc!=1) || type(Sc)==4){
13262: if(type(Sc)==1) Sc=[Sc,Sc];
13263: Sx=Sc[0];Sy=Sc[1];
13264: if(length(P)>2)
13265: P1=cons(Sy*P[1],cdr(cdr(P)));
13266: else P1=[Sy*P[1]];
13267: P=cons((type(P[0])==7)?P[0]:(Sx*P[0]),P1);
13268: }
13269: if(!TikZ) return "{"+xypos(P)+"};\n";
13270: return "\\"+xypos(P)+";\n";
13271: }
13272:
13273: def xyline(P,Q)
13274: {
13275: if(!TikZ) return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n";
13276: if(type(T=getopt(opt))!=7) T="";
13277: else T="["+T+"]";
13278: if(length(P)<3 && length(Q)<3)
13279: return "\\draw"+T+xypos(P)+"--"+xypos(Q)+";\n";
13280: if(length(P)==2) P=[P[0],P[1],"","_0"];
13281: else if(length(P)==3 || (length(P)==4 && P[3]==""))
13282: P=[P[0],P[1],P[2],"_0"];
13283: else if(length(P)>4 && P[3]=="")
13284: P=[P[0],P[1],P[2],"_0",P[4]];
13285: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
13286: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
13287: Q=[Q[0],Q[1],Q[2],"_1"];
13288: else if(length(Q)>4 && Q[3]=="")
13289: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
13290: return "\\draw "+T+xypos(P)+" "+xypos(Q)+"("+P[3]+")--("+Q[3]+");\n";
13291: }
13292:
13293: def xylines(P)
13294: {
13295: Lf=getopt(curve);
13296: if(type(Lf)!=1) Lf=0;
13297: SS=getopt(opt);
13298: SF=(SS==0)?1:0;
13299: if((Proc=getopt(proc))==1||Proc==2||Proc==3){
13300: OL=cons(["opt",0],delopt(getopt(),["opt","proc"]));
13301: R=xylines(P|option_list=OL);
13302: OP=(type(SS)<0)?[]:((type(SS)==4)?[["opt",SS[0]],["cmd",SS[1]]]:[["opt",SS]]);
13303: return [1,OP,R];
13304: }
13305: if(type(SS)!=7 && type(SS)!=4){
13306: if(Lf==0 && !TikZ) SS="@{-}";
13307: else SS="";
13308: }
13309: if(type(Sc=getopt(scale))==1 || type(Sc)==4){
13310: if(type(Sc)==1) Sc=[Sc,Sc];
13311: Sx=Sc[0];Sy=Sc[1];
13312: if(Sx!=1 || Sy!=1){
13313: for(PP=[], P0=P; P0!=[]; P0=cdr(P0)){
13314: PT=car(P0);
13315: if((type(PT)!=4 && type(PT)!=5) || (type(PT[0])!=1 && PT[0]!=0))
13316: PP=cons(PT,PP);
13317: else{
13318: if(length(PT)>2 && type(PT)==4)
13319: P1=cons(Sy*PT[1],cdr(cdr(PT)));
13320: else P1=[Sy*PT[1]];
13321: PP=cons(cons(Sx*PT[0],P1),PP);
13322: }
13323: }
13324: P=reverse(PP);
13325: }
13326: }
13327: if(type(Cl=CL0=getopt(close))!=1) Cl=0;
13328: if((Vb=getopt(verb))!=1&&type(Vb)!=4) Vb=0;
13329: if(type(Lf)!=1 || Lf==0){ /* lines */
13330: if(TikZ||SF){
13331: for(L=[],F=0,PT=P;PT!=[];PT=cdr(PT)){
13332: if(type(car(PT))<4){
13333: L=cons(car(PT),L);
13334: F=0;
13335: }else{
13336: if(F++>1) L=cons(1,L);
13337: L=cons(car(PT),L);
13338: }
13339: }
13340: if(Cl==1){
13341: L=cons(1,L);L=cons(-1,L);
13342: }
13343: if(L) L=reverse(L);
13344: if(SF) return L;
13345: if(type(SS)!=4) S=xybezier(L|opt=SS);
13346: else S=xybezier(L|opt=SS[0],cmd=SS[1]);
13347:
13348: }else{
13349: Out = str_tb(0,0);
13350: for(PT=P; PT!=[]; ){
13351: PS1=car(PT);
13352: PT=cdr(PT);
13353: if(PT==[]){
13354: if(Cl==1) PS2=car(P);
13355: else PS2=0;
13356: }else PS2=car(PT);
13357: str_tb(xyarrow(PS1,PS2|opt=SS),Out);
13358: }
13359: S=str_tb(0,Out);
13360: }
13361: }else if(Lf==2){ /* B-spline */
13362: if(SF) return P;
13363: if(!TikZ){
13364: Out = str_tb("{\\curve{",0);
13365: for(PT=P;PT!=[];PT=cdr(PT)){
13366: if(car(PT)==0){
13367: str_tb("}};\n{\\curve{",Out);
13368: continue;
13369: }
13370: if(PT!=P) str_tb("&",Out);
13371: str_tb(xypos([car(PT)[0],car(PT)[1]]),Out);
13372: }
13373: str_tb("}};\n",Out);
13374: S=str_tb(0,Out);
13375: }else Out=str_tb(xybezier(P|opt=SS),0);
13376: for(I=0;I<2;I++){
13377: Q=car(P);
13378: if(length(Q)>2)
13379: str_tb(xyput(Q),Out);
13380: P=reverse(P);
13381: }
13382: S=str_tb(0,Out);
13383: }else{ /* extended Bezier */
13384: RTo=getopt(ratio);
13385: if(type(Acc=getopt(Acc))!=1) Acc=0;
13386: if(type(RTo)!=1 || RTo>1.5 || RTo<0.001) RTo=0;
13387: if(Cl==1){
13388: PR=reverse(P);
13389: PT=car(PR);
13390: PR=cons(P[0],PR);
13391: PR=cons(P[1],PR);
13392: P=cons(PT,reverse(PR));
13393: }else if(Cl==-1) Cl=1;
13394: for(L=P2=P3=0,PT=P;;){
13395: P1=P2;P2=P3;P3=P4;
13396: P4=(PT==[])?0:car(PT);
13397: if(PT==[] && (Cl==1 || P3==0)) break;
13398: PT=cdr(PT);
13399: if(P3==0) str_tb("%\n", Out);
13400: if(P2==0 || P3==0 || (Cl==1 && P1==0)) continue;
13401: if(L!=0){
13402: if(car(L)==P2)
13403: L=cons(1,L);
13404: else{
13405: L=cons(0,L); L=cons(P2,L);
13406: }
13407: }else L=[P2];
13408: X=P3[0]-P2[0];Y=P3[1]-P2[1];
13409: DL1=DL2=0;DL=Acc?sqrt(X^2+Y^2):dsqrt(X^2+Y^2);
13410: if(P4!=0){
13411: XD1=P4[0]-P2[0];YD1=P4[1]-P2[1];DL1=Acc?sqrt(XD1^2+YD1^2):dsqrt(XD1^2+YD1^2);
13412: }
13413: if(P1!=0){
13414: XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];DL2=Acc?sqrt(XD2^2+YD2^2):dsqrt(XD2^2+YD2^2);
13415: }
13416: if(RTo!=0)
13417: R=RTo;
13418: else if(DL1>0 && DL2>0){
13419: Cos=(XD1*XD2+YD1*YD2)/(DL1*DL2);
13420: RT=4/(3*(Acc?sqrt((1+Cos)/2):dsqrt((1+Cos)/2))+3);
13421: R=DL*RT/(DL1+DL2);
13422: }else if(DL1!=0)
13423: R=DL/(2*DL1);
13424: else if(DL2!=0)
13425: R=DL/(2*DL2);
13426: if(DL2!=0) L=cons([P2[0]+R*XD2,P2[1]+R*YD2],L);
13427: if(DL1!=0) L=cons([P3[0]-R*XD1,P3[1]-R*YD1],L);
13428: L=cons([P3[0],P3[1]],L);
13429: }
13430: if(CL0==1) L=cons(-1,cdr(L));
13431: if(L!=0) L=reverse(L);
13432: if(SF) return L;
13433: if(type(SS)==4)
13434: S=xybezier(L|opt=SS[0],cmd=SS[1],verb=Vb);
13435: else
13436: S=xybezier(L|opt=SS,verb=Vb);
13437: }
13438: if(getopt(dviout)!=1) return S;
13439: xyproc(S|dviout=1);
13440: }
13441:
13442: def saveproc(S,Out)
13443: {
13444: if(type(Out)==4){
13445: Out=cons(S,Out);
13446: return Out;
13447: }else{
13448: str_tb(S,Out);
13449: return Out;
13450: }
13451: }
13452:
1.18 takayama 13453: def xygrid(X,Y)
13454: {
13455: for(RR=[],I=0,Z=X;I<2;I++){
1.19 takayama 13456: U=Z[2];L=LL=[];M=Z[3];
13457: if(Z[1]==1||Z[1]==-1){
1.18 takayama 13458: if(type(M)==4) L=M;
13459: else{
1.19 takayama 13460: if(U*(-dlog(1-1/20)/dlog(10))>=M){
1.18 takayama 13461: L=cons([1,2,1/10],L);
1.19 takayama 13462: LL=cons([1,2,1/2],LL);
13463: }else if(U*(-dlog(1-1/10)/dlog(10))>=M)
1.18 takayama 13464: L=cons([1,2,1/5],L);
13465: else if(U*(-dlog(1-1/4)/dlog(10))>=M)
13466: L=cons([1,2,1/2],L);
1.19 takayama 13467: if(U*(-dlog(1-1/50)/dlog(10))>=M){
1.18 takayama 13468: L=cons([2,5,1/10],L);
1.19 takayama 13469: LL=cons([2,5,1/2],LL);
13470: }else if(U*(-dlog(1-1/25)/dlog(10))>=M)
1.18 takayama 13471: L=cons([2,5,1/5],L);
13472: else if(U*(-dlog(1-1/10)/dlog(10))>=M)
13473: L=cons([2,5,1/2],L);
1.19 takayama 13474: if(U*(-dlog(1-1/100)/dlog(10))>=M){
1.18 takayama 13475: L=cons([5,10,1/10],L);
1.19 takayama 13476: LL=cons([5,10,1/2],LL);
13477: }
1.18 takayama 13478: else if(U*(-dlog(1-1/50)/dlog(10))>=M)
13479: L=cons([5,10,1/5],L);
13480: else if(U*(-dlog(1-1/20)/dlog(10))>=M)
13481: L=cons([5,10,1/2],L);
1.19 takayama 13482: L=cons(L,cons(LL,[[[1,10,1]]]));
1.18 takayama 13483: }
13484: R=scale(L|scale=U);
1.19 takayama 13485: if(Z[1]==-1){
13486: for(LL=[];R!=[];R=cdr(R)){
13487: for(L=[],T=car(R);T!=[];T=cdr(T)) L=cons(U-car(T),L);
13488: LL=cons(reverse(L),LL);
13489: }
13490: R=reverse(LL);
13491: }
1.18 takayama 13492: }else if(Z[1]==0){
13493: if(type(M)==4){
13494: R=scale(M|f=x,scale=U);
13495: }else{
13496: V=0;
13497: if(U/10>=M) V=1/10;
13498: else if(U/5>=M) V=1/5;
13499: else if(U/2>=M) V=1/2;
13500: R=[];
13501: if(V>0){
13502: UU=U*V;
13503: for(R=[],J=UU;J<U;J+=UU) R=cons(J,R);
13504: }
1.19 takayama 13505: if(V==1/10) L=[U/2];
13506: else L=[];
13507: R=cons(R,cons(L,[[0,U]]));
1.18 takayama 13508: }
13509: }else if(type(Z[1])==4){
13510: R=Z[1];
1.19 takayama 13511: if(length(R)==0||type(R[0])!=4) R=[[],[],R];
1.18 takayama 13512: }else return 0;
1.19 takayama 13513: K=length(R);
13514: S=newvect(K);
13515: for(J=0;J<K;J++){
13516: for(S[J]=[],JJ=0;JJ<=Z[0];JJ+=U){
13517: for(P=R[J];P!=[];P=cdr(P))
13518: if(car(P)+JJ<=Z[0]) S[J]=cons(car(P)+JJ,S[J]);
13519: }
13520: }
13521: for(J=0;J<K;J++) S[J]=lsort(S[J],[],1);
13522: for(U=[],J=K-1;J>0;J--){
13523: U=lsort(S[J],U,0);S[J-1]=lsort(S[J-1],U,1);
1.18 takayama 13524: }
1.19 takayama 13525: RR=cons(vtol(S),RR);
1.18 takayama 13526: Z=Y;
13527: }
13528: if((Raw=getopt(raw))==1) return RR;
13529: SS=[];
13530: if(type(Sf=getopt(shift))==7){
13531: Sx=Sf[0];Sy=Sf[1];
13532: }else Sx=Sy=0;
13533: for(I=0;I<2;I++){
13534: for(S0=[],L=RR[I];L!=[];L=cdr(L)){
13535: for(S=[],T=car(L);T!=[];T=cdr(T)){
13536: if(S!=[]) S=cons(0,S);
13537: if(I==0){
13538: S=cons([X[0]+Sx,car(T)+Sy],S);
13539: S=cons([Sx,car(T)+Sy],S);
13540: }else{
13541: S=cons([car(T)+Sx,Y[0]+Sy],S);
13542: S=cons([car(T)+Sx,Sy],S);
13543: }
13544: }
13545: S0=cons(S,S0);
13546: }
13547: SS=cons(reverse(S0),SS);
13548: }
13549: SS=reverse(SS);
13550: if(Raw==2) return SS;
13551: if(length(Y)<5) T=[["",""]];
13552: else if(type(Y[4])==4) T=[Y[4]];
13553: else T=[Y[4],Y[4]];
13554: if(length(X[4])==4) T=cons([""],T);
13555: else if(type(X[4])==4) T=cons(X[4],T);
13556: else T=cons([X[4]],T);
13557: for(Sx=Sy=[],I=0;I<2;I++){
13558: TT=T[I];
13559: for(V=SS[I];V!=[];V=cdr(V)){
13560: Op=car(TT);
13561: if(length(TT)>1) TT=cdr(TT);
13562: if(car(V)==[]) continue;
13563: if(Op=="") S=xylines(car(V));
13564: else S=xylines(car(V)|opt=Op);
13565: if(I==0) Sx=cons(S,Sx);
13566: else Sy=cons(S,Sy);
13567: }
13568: }
13569: for(S="",Sx=reverse(Sx), Sy=reverse(Sy);Sx!=[]&&Sy!=[];){
13570: if(Sx!=[]){
13571: S+=car(Sx);Sx=cdr(Sx);
13572: }
13573: if(Sy!=[]){
13574: S+=car(Sy);Sy=cdr(Sy);
13575: }
13576: }
13577: return S;
13578: }
13579:
13580:
1.22 takayama 13581: def addIL(I,L)
1.18 takayama 13582: {
1.22 takayama 13583: if(I==0){
13584: for(R=[];L!=[];L=cdr(L)) R=addIL(car(L),R);
13585: return reverse(R);
1.18 takayama 13586: }
1.22 takayama 13587: if(type(In=getopt(in))==1){
13588: if(In==-1){
13589: J=JJ=I[1];I=I[0];
13590: for(R=[];L!=[];L=cdr(L)){
13591: J=lmin([car(L)[0],JJ]);
13592: if(J>I) R=cons([I,J],R);
13593: I=lmax([car(L)[1],I]);
13594: }
13595: if(I<JJ) R=cons([I,JJ],R);
13596: return reverse(R);
13597: }else{
13598: for(;L!=[];L=cdr(L)){
13599: if(car(L)[0]>I) return 0;
13600: if(car(L)[1]>=I){
13601: if(In==3) return car(L);
13602: if(In==1||(I!=car(L)[0]&&I!=car(L)[1])) return 1;
13603: return 2;
13604: }
13605: }
13606: return 0;
13607: }
13608: }
13609: I0=car(I);I1=I[1];
13610: for(F=0,R=[];L!=[];L=cdr(L)){
13611: if(I0>car(L)[1]){
13612: R=cons(car(L),R);
13613: continue;
13614: }
13615: if(I0<=car(L)[1]){
13616: I0=lmin([I0,car(L)[0]]);
13617: if(I1<car(L)[0]){
13618: R=cons([I0,I1],R);
13619: for( ;L!=[];L=cdr(L)) R=cons(car(L),R);
13620: F=1;
13621: break;
13622: }
13623: I1=lmax([I1,car(L)[1]]);
13624: }
13625: }
13626: if(!F) R=cons([I0,I1],R);
13627: return reverse(R);
1.18 takayama 13628: }
13629:
13630: def xy2curve(F,N,Lx,Ly,Lz,A,B)
13631: {
1.22 takayama 13632: Raw=getopt(raw);
13633: if(type(Gap=getopt(gap))==4){
13634: MG=Gap[1];Gap=car(Gap);
13635: }else MG=3;
13636: if(type(Gap)!=1 && Gap!=0) Gap=0.7;
13637: if(type(Dvi=getopt(dviout))<1) Dvi=0;
13638: OL=[["dviout",Dvi]];
13639: if(type(Opt=getopt(opt))<1) Opt=0;
13640: else OL=cons(["opt",Opt],OL);
13641: if(type(Sc=getopt(scale))!=1 && type(Sc)!=4) Sc=[1,1,1];
13642: else if(type(Sc)!=4) Sc=[Sc,Sc,Sc];
13643: else if(length(Sc)!=3) Sc=[Sc[0],Sc[1],Sc[1]];
13644: M=diagm(3,Sc);
13645: if(A!=0||B!=0){
13646: if(type(A)==6) M=A;
13647: else M=mrot([0,-B,-A]|deg=1)*M;
13648: V=M*newvect(3,[x,y,z]);
13649: Fx=compdf(V[0],[x,y,z],F);Fy=compdf(V[1],[x,y,z],F);Fz=compdf(V[2],[x,y,z],F);
13650: }else{
13651: for(I=0;I<3;I++){
13652: if(type(T=F[I])!=4) T=f2df(T);
13653: if(type(T)==4) T=cons(car(T)*Sc[I],cdr(T));
13654: else T*=Sc[I];
13655: if(I==0) Fx=T;
13656: else if(I==1) Fy=T;
13657: else Fz=T;
13658: }
13659: }
13660: if(Raw==5||!Gap)
13661: return (Dvi||!Gap)? xygraph([Fy,Fz],N,Lx,Ly,Lz|option_list=OL):[Fx,Fy,Fz];
1.18 takayama 13662: R=xygraph([Fy,Fz],N,Lx,Ly,Lz|raw=2);
1.22 takayama 13663: R0=cdr(car(R));R1=R[1];
13664: for(LT=[];R0!=[];R0=cdr(R0),R1=cdr(R1))
13665: if(car(R0)!=0) LT=cons([R1[0],R1[1]],LT);
13666: LT=reverse(LT);
1.19 takayama 13667: if(N<0){
13668: Be=xylines(car(R)|curve=1,proc=3,close=-1);
13669: LT=reverse(cdr(LT));
13670: LT=reverse(cdr(LT));
13671: }
13672: else Be=xylines(car(R)|curve=1,proc=3);
1.18 takayama 13673: Be=cdr(cdr(Be));
1.22 takayama 13674: Be=lbezier(car(Be));
13675: if(Raw==4) return [Be,LT,Lx];
13676: X=ptcombz(Be,0,0);
13677: Var=(length(Lx)==3)?car(Lx):x;
13678: if(type(Eq=getopt(eq))!=1) Eq=0.01;
13679: if(TikZ==1){
13680: Gap/=10;Eq/=10;
1.18 takayama 13681: }
13682: for(R=[],XT=X;XT!=[];XT=cdr(XT)){
13683: V=car(XT);
1.22 takayama 13684: U=LT[V[0][0]];
13685: T=U[0]*V[1][0]+U[1]*(1-V[1][0]);
13686: VV=myfdeval(Fx,[Var,T]);
13687: U=LT[V[0][1]];
1.18 takayama 13688: T=U[0]*V[1][1]+U[1]*(1-V[1][1]);
1.22 takayama 13689: VV-=myfdeval(Fx,[Var,T]);
13690: if(abs(VV)<Eq) continue;
13691: I=(VV<0)?0:1;
13692: R=cons([V[0][I],V[1][I],V[0][1-I],V[1][1-I]],R);
1.18 takayama 13693: }
13694: R=qsort(R);
1.22 takayama 13695: if(Raw==3) return [Be,R];
13696: Db=newvect(L=length(Be));
13697: for(I=0;I<L;I++) Db[I]=[];
13698: for(TR=R;TR!=[];TR=cdr(TR)){
13699: V1=ptbezier(Be,[I=car(TR)[0],P=car(TR)[1]])[1];
13700: V2=ptbezier(Be,[car(TR)[2],car(TR)[3]])[1];
13701: T=dsqrt(1-dvangle(V1,V2)^2);
13702: if(T<1/MG) T=MG;
13703: GP=Gap/T;
13704: W=GP/dnorm(V1);
13705: Db[I]=addIL([P-W,P+W],Db[I]);
13706: if(P-W<0 && I>0) Db[I-1]=addIL([P-W+1,1],Db[I-1]);
13707: if(P+W>1 && I+1<L) Db[I+1]=addIL([0,P+W-1],Db[I+1]);
13708: }
13709: Db=vtol(Db);
13710: for(Bf=[];Be!=[];Be=cdr(Be),Db=cdr(Db)){
13711: if(car(Db)==[]) Bf=cons(car(Be),Bf);
13712: else{
13713: D=addIL([0,1],car(Db)|in=-1);
13714: for(;D!=[];D=cdr(D))
13715: Bf=cons(tobezier(car(Be)|inv=car(D)),Bf);
13716: }
13717: }
13718: Bf=reverse(Bf);
13719: if(Raw==2) return Bf;
13720: OL=[];
13721: if(Opt){
13722: if(type(Opt)==4&&length(Opt)>1) OL=[["opt",Opt[0]],["cmd",Opt[1]]];
13723: else OL=[["opt",Opt]];
13724: }else OL=[];
13725: S=xybezier(lbezier(Bf|inv=1)|option_list=OL);
13726: if(Raw==1||!Dvi) return S;
13727: return xyproc(S|dviout=Dvi);
13728: }
13729:
13730: def rungeKutta(F,N,Lx,Y,IY)
13731: {
13732: if((Pr=getopt(prec))==1){
13733: One=eval(exp(0));
13734: }else{
1.58 takayama 13735: One=deval(exp(0));Pr=0;
1.22 takayama 13736: }
1.57 takayama 13737: if(!isint(FL=getopt(mul))||!FL) FL=1;
1.22 takayama 13738: if(length(Lx)>2){
13739: V=car(Lx);Lx=cdr(Lx);
13740: }else V=x;
1.58 takayama 13741: if(Pr==1) Lx=[eval(Lx[0]),eval(Lx[1])];
13742: else Lx=[deval(Lx[0]),deval(Lx[1])];
1.22 takayama 13743: if(type(Y)==4){
13744: if((Sing=getopt(single))==1||type(F)!=4)
13745: F=append(cdr(Y),[F]);
13746: L=length(Y);
13747: for(TF=[];F!=[];F=cdr(F))
13748: TF=cons(f2df(car(F)),TF);
13749: F=reverse(TF);
13750: }else{
13751: L=1;
13752: F=f2df(F);
13753: }
13754: if(getopt(val)==1) V1=1;
13755: else V1=0;
1.57 takayama 13756: if(FL>0) N*=FL;
1.58 takayama 13757: H=(Lx[1]-Lx[0])/N*One;H2=H/2;
1.22 takayama 13758: FV=findin(V,vars(F));
13759: K=newvect(4);
13760: if(L==1){
13761: R=[[T=Lx[0],S=IY]];
13762: if(!H) return R;
1.57 takayama 13763: for(C=0;C<N;C++){
1.22 takayama 13764: for(I=0;I<4;I++){
13765: if(I==0) W=[[V,T],[Y,S]];
13766: else if(I==3) W=[[V,T+H],[Y,S+H*K[2]]];
13767: else W=[[V,T+H2],[Y,S+H2*K[I-1]]];
13768: if(FV<0) W=cdr(W);
13769: K[I]=Pr?myfeval(F,W)*One:myfdeval(F,W);
13770: }
13771: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
1.57 takayama 13772: if(FL>0&&!((C+1)%FL)) R=cons([deval(T),S],R);
1.22 takayama 13773: }
13774: }else{
13775: T=Lx[0];
13776: R=[cons(T,V1?[car(IY)]:IY)];
13777: S=ltov(IY);
13778: if(!H) return R;
1.57 takayama 13779: for(C=0;C<N;C++){
1.22 takayama 13780: for(I=0;I<4;I++){
13781: if(I==0) W=cons([V,T ],lpair(Y,vtol(S)));
13782: else if(I==3) W=cons([V,T+H ],lpair(Y,vtol(S+H*K[2])));
13783: else W=cons([V,T+H2],lpair(Y,vtol(S+H2*K[I-1])));
13784: if(FV<0) W=cdr(W);
13785: for(TK=[],TF=F;TF!=[];TF=cdr(TF)){
13786: TK=cons(Pr?myfeval(car(TF),W)*One:myfdeval(car(TF),W),TK);
13787: }
13788: K[I]=ltov(reverse(TK));
13789: }
13790: S+=(K[0]+2*K[1]+2*K[2]+K[3])*H/6;T+=H;
13791: TS=vtol(S);
1.58 takayama 13792: if(FL<0||(C+1)%FL) continue;
1.22 takayama 13793: if(V1) TS=[car(TS)];
1.58 takayama 13794: R=cons(cons(deval(T),TS),R);
1.22 takayama 13795: }
13796: }
1.58 takayama 13797: L=(FL<0)?(V1?S[0]:S):reverse(R);
13798: return L;
1.57 takayama 13799: }
13800:
13801: def pwTaylor(F,N,Lx,Y,Ly,M)
13802: {
1.68 takayama 13803: /* Pr:bigfloat, V1:last, Sf: single, Tf: autonomous, */
1.58 takayama 13804: if(!isint(FL=getopt(mul))||!FL) FL=1;
13805: if(getopt(val)==1) V1=1;
13806: else V1=0;
1.59 takayama 13807: if(length(Lx)>2){
13808: V=car(Lx);Lx=cdr(Lx);
13809: }else V=t;
13810: if(!isvar(T=getopt(var))) V=t;
13811: if(isint(Pr=getopt(prec))&&Pr>0){
13812: One=eval(exp(0));
13813: if(Pr>9){
13814: setprec(Pr);
13815: ctrl("bigfloat",1);
13816: }
13817: Pr=1;
13818: }else{
13819: One=deval(exp(0));Pr=0;
13820: }
13821: if(Pr==1) Lx=[eval(Lx[0]),eval(Lx[1])];
13822: else Lx=[deval(Lx[0]),deval(Lx[1])];
1.68 takayama 13823: Sf=(type(F)!=4)?1:0;
1.59 takayama 13824: if(type(Y)==4){
13825: if(type(F)!=4) F=append(cdr(Y),[F]);
13826: }else Y=[Y];
13827: if(type(Ly)!=4) Ly=[Ly];
1.68 takayama 13828: if(findin(V,vars(F))>=0){
13829: if(type(F)!=4) F=[F];
13830: Tf=1;F=cons(1,subst(F,V,z_z));Y=cons(z_z,Y);Ly=cons(car(Lx),Ly);
13831: }else Tf=0; /* Tf: autonomous */
1.60 takayama 13832: ErF=0;
1.59 takayama 13833: if(type(Er=getopt(err))==4){
1.61 takayama 13834: if(length(Er)==2) ErF=Er[1]; /* ErF&1: Raw, ErF&2: relative, ErF&4: add Sol */
1.60 takayama 13835: Er=car(Er);
13836: };
13837: if(!isint(Er)||Er<0) Er=0; /* 基準解を返す */
1.59 takayama 13838: if(FL>0) N*=FL;
13839: S=vtol(pTaylor(F,Y,M|time=V));
13840: FM=pmaj(F|var=x);
13841: LS=length(S);
13842:
13843: if(type(Vw=getopt(view))==4){ /* Dislay on Canvas */
1.61 takayama 13844: Glib_math_coordinate=1;
1.68 takayama 13845: glib_window(car(Vw)[0], car(Vw)[2],car(Vw)[1],car(Vw)[3]);
1.67 takayama 13846: if(length(car(Vw))==6) Vr=[car(Vw)[4],car(Vw)[5]];
13847: else Vr=0;
1.66 takayama 13848: if(length(Vw)>1){
13849: if(type(Cl=Vw[1])==4) Cl=map(os_md.trcolor,Cl);
13850: else Cl=trcolor(Cl);
13851: }else Cl=0;
1.59 takayama 13852: if(length(Vw)>2){
13853: Mt=Vw[2];
13854: if(LS==1){
13855: if(type(Mt)>1) Mt=0;
13856: }else{
1.68 takayama 13857: if(type(Mt)!=6||((Ms=size(Mt)[0])!=2&&Ms!=3)) Mt=0;
13858: if(Ms!=3) Vr=0;
1.59 takayama 13859: }
1.68 takayama 13860: if(Tf&&type(Mt)==6) Mt=newbmat(2,2,[[1,0],[0,Mt]]);
1.59 takayama 13861: }else Mt=0;
13862: if(!Mt){
1.68 takayama 13863: if(LS>1+Tf){
1.67 takayama 13864: if(Vr){
1.68 takayama 13865: Mt=newmat(3,LS);Mt[2+Tf][2+Tf]=1;
1.67 takayama 13866: }
13867: else Mt=newmat(2,LS);
1.68 takayama 13868: Mt[Tf][Tf]=Mt[Tf+1][Tf+1]=1;
1.59 takayama 13869: }else Mt=1;
1.68 takayama 13870: if(LS==1+Tf||Sf) glib_putpixel(Lx[0],Mt*Ly[Tf]|color=mcolor(Cl,0));
1.59 takayama 13871: else{
1.67 takayama 13872: YT=Mt*ltov(Ly);
1.66 takayama 13873: glib_putpixel(YT[0],YT[1]|color=mcolor(Cl,0));
1.59 takayama 13874: }
13875: }
13876: }else Vw=0;
13877:
1.68 takayama 13878: T=Lx[0];
13879: RE=R=(Tf)?[Ly]:[cons(T,Ly)];
1.59 takayama 13880: H=(Lx[1]-Lx[0])/N*One;
1.65 takayama 13881:
13882: Ck=N+1;CB=10;Ckm=2;MM=2;C1=1;
13883: if(Ck<5) Ck=100;
13884: if(type(Inf=getopt(Inf))==4&&length(Inf)>1&&Inf[0]>4){ /* explosion */
1.59 takayama 13885: Ck=Inf[0];Ckm=Inf[1];
13886: if(length(Inf)>2) MM=Inf[2];
1.67 takayama 13887: if(!isint(MM)||MM<1) MM=2;
1.59 takayama 13888: if(length(Inf)>3) C1=Inf[3];
1.60 takayama 13889: if(type(C1)!=1||C1<0) C1=1;
1.65 takayama 13890: if(length(Inf)>4) CB=Inf[4];
13891: }else if(isint(Inf)&&Inf>0&&Inf<100){
13892: MM=Inf+1;Ck=100;
1.59 takayama 13893: }else Inf=0;
1.60 takayama 13894: Ckm*=Ck;
1.65 takayama 13895:
1.66 takayama 13896: SS=subst(S,V,H);N0=N;
1.59 takayama 13897: if(Er>0){
1.61 takayama 13898: HE=H/(Er+1);SSE=subst(S,V,HE);LyE=Ly;
1.59 takayama 13899: }
1.65 takayama 13900: for(C=CC=CF=0;C<N;C++,CC++){
1.59 takayama 13901: if(CC>=Ck){ /* check explosion */
13902: CC=0;
13903: D0=dnorm(Ly|max=1);
1.65 takayama 13904: if(Er&&CF){
13905: DE=dnorm(ladd(LyE,Ly,-1)|max=1);
13906: if(CB*DE>D0) break;
13907: }
1.59 takayama 13908: for(Dy=F,TY=Y,TL=Ly;TY!=[];TY=cdr(TY),TL=cdr(TL))
13909: Dy=subst(Dy,car(TY),One*car(TL));
13910: D1=dnorm(Dy|max=1);D2=subst(FM,x,2*D0+C1);D3=D1+D2;
1.60 takayama 13911: HH=2*(D0+C1)/Ckm;
1.59 takayama 13912: if(HH<H*D3){
1.60 takayama 13913: HH/=D3;
13914: while(H>HH) H/=2;
13915: if(H*7/5<HH) H*=7/5;
13916: if(H*6/5<HH) H*=6/5;
1.59 takayama 13917: SS=subst(S,V,H);
13918: if(Er){
1.65 takayama 13919: CF++;
1.59 takayama 13920: HE=H/(Er+1);
13921: SSE=subst(S,V,HE);
13922: }
13923: if(MM>1) N*=MM;
13924: MM=0;
13925: }
13926: CC=0;
13927: }
13928:
13929: T+=H;
13930: for(Dy=SS,TY=Y,TL=Ly;TY!=[];TY=cdr(TY),TL=cdr(TL))
13931: Dy=subst(Dy,car(TY),One*car(TL));
13932: Ly=Dy;
13933:
13934: if(Er>0){ /* estimate error */
1.60 takayama 13935: for(CE=0;CE<=Er;CE++){
1.59 takayama 13936: for(Dy=SSE,TY=Y,TL=LyE;TY!=[];TY=cdr(TY),TL=cdr(TL))
13937: Dy=subst(Dy,car(TY),One*car(TL));
13938: LyE=Dy;
13939: }
13940: }
13941: if(FL<0||(C+1)%FL) continue;
13942: if(Vw){
1.68 takayama 13943: if(LS==1+Tf||Sf) CR=CC/N0;
1.59 takayama 13944: else{
1.67 takayama 13945: YT=Mt*ltov(Ly);
13946: CR=(!Vr)?CC/N0:(YT[2]-Vr[0])/(Vr[1]-Vr[0]);
1.59 takayama 13947: }
1.68 takayama 13948: if(LS==1+Tf||Sf) glib_putpixel(deval(T),Mt*Ly[Tf]|color=mcolor(Cl,CR));
1.67 takayama 13949: else glib_putpixel(YT[0],YT[1]|color=mcolor(Cl,CR));
1.59 takayama 13950: continue;
13951: }
1.68 takayama 13952: TR=(V1)?[car(Ly)]:Ly;
13953: if(!Tf) TR=cons((Inf)?eval(T):deval(T),TR);
1.59 takayama 13954: R=cons(TR,R);
13955: if(Er){
1.68 takayama 13956: TRE=(V1)?[car(LyE)]:LyE;
13957: if(!Tf) TRE=cons((Inf)?eval(T):deval(T),TRE);
1.59 takayama 13958: RE=cons(TRE,RE);
13959: }
13960: }
13961: if(Vw) return 1;
13962: L=(FL<0)?((V1)?car(Ly):Ly):reverse(R);
13963: if(Er){ /* Estimate error */
13964: LE=(FL<0)?((V1)?car(LyE):LyE):reverse(RE);
13965: if(FL>0){
13966: for(S=L,T=LE,D=[];S!=[];S=cdr(S),T=cdr(T)) D=cons(os_md.ladd(car(S),car(T),-1),D);
13967: F=map(os_md.dnorm,reverse(D));
1.60 takayama 13968: if(iand(ErF,2)){ /* relative error */
1.61 takayama 13969: G=llget(LE,-1,[0]);
13970: G=map(os_md.dnorm,G);
1.60 takayama 13971: for(R=[];G!=[];G=cdr(G),F=cdr(F)){
13972: if(car(G)) R=cons(car(F)/car(G),R);
13973: else R=cons(0,R);
13974: }
13975: F=reverse(R);
13976: }
13977: if(!iand(ErF,1)) F=map(os_md.nlog,F);
13978: if(!iand(ErF,8)) F=map(deval,F);
1.59 takayama 13979: }else if(V1){
13980: D=ladd(L,LE,-1);F=dnorm(D);
1.60 takayama 13981: if(iand(ErF,2)){
13982: G=dnorm(cdr(L));
13983: if(!G) D/=G;
13984: else D=1;
13985: }
13986: F=(!iand(ErF,1))?nlog(D):D;
13987: if(!iand(ErF,8)) F=deval(F);
1.59 takayama 13988: }else{
1.60 takayama 13989: D=abs(L-LE);
13990: if(iand(ErF,2)){
13991: G=abs(L);
13992: if(!G) D/=G;
13993: else D=1;
1.58 takayama 13994: }
1.60 takayama 13995: F=(!iand(ErF,1))?nlog(D):D;
13996: if(!iand(ErF,8)) F=deval(F);
1.58 takayama 13997: }
1.61 takayama 13998: return iand(ErF,4)?[L,F,LE]:[L,F];
1.57 takayama 13999: }
1.58 takayama 14000: return L;
1.18 takayama 14001: }
14002:
1.6 takayama 14003: def xy2graph(F0,N,Lx,Ly,Lz,A,B)
14004: {
1.18 takayama 14005: /* (x,y,z) -> (z sin B + x cos A cos B + y sin A cos B,
14006: -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */
1.6 takayama 14007: if((Proc=getopt(proc))==1||Proc==2){
14008: OPT0=[["proc",3]];
14009: }else{
14010: Proc=0;OPT0=[];
14011: }
14012: if(type(DV=getopt(dviout))==4){
14013: S=["ext","shift","cl","dviout"];
14014: OL=delopt(getopt(),S);
14015: OL=cons(["proc",1],OL);
14016: R=xy2graph(F0,N,Lx,Ly,Lz,A,B|option_list=OL);
14017: OL=delopt(getopt(),S|inv=1);
14018: return execdraw(R,DV|optilon_list=OL);
14019: }
14020: if(N==0 || N>100 || N<-100) N=-16;
14021: if(N<0){
14022: N=-N;N1=-1;N2=NN+1;
14023: }else{
14024: N1=0;N2=NN=N;
14025: }
14026:
14027: Ratio=Ratio2=1;
14028: if(type(Sc=Sc0=getopt(scale))!=1 && type(Sc)!=4) Sc=1;
14029: if(type(Sc)==4){
14030: Ratio=Sc[1]/Sc[0];
14031: if(length(Sc)>2) Ratio2=Sc[2]/Sc[0];
14032: Sc=Sc[0];
14033: }
14034: if(type(Vw=getopt(view))!=1) Vw=0;
14035: if(type(Raw=getopt(raw))!=1) Raw=0;
14036: if(type(M1=getopt(dev))==1) M2=M1;
14037: else if(type(M1)==4){
14038: M2=M1[1];M1=M1[0];
14039: }else M1=0;
14040: if(type(M3=getopt(acc))!=1 || (M3<0.5 && M3>100)) M3=1;
14041: if(M1<=0) M1=16;
14042: if(M2<=0) M2=16;
14043: OL=[["para",1],["scale",Sc]];
14044: if(Raw==1) OL=cons(["raw",1],OL);
14045: if(type(Prec=getopt(prec))>=0) OL=cons(["prec",Prec],OL);
14046: L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]);
14047: Lx=[deval(Lx[0]),deval(Lx[1])];
14048: Ly=[deval(Ly[0]),deval(Ly[1])];
14049: Lz=[deval(Lz[0]),deval(Lz[1])];
14050: A=(A0=A)%360;
14051: F00=F0;
14052: if(type(F0)<4){
14053: FC=f2df(F0);
14054: if(findin(z,Vars=vars(FC))>=0 && findin(x,Vars)<0 && findin(y,Vars)<0)
14055: F0=[w,[z,0,x+y*@i],[w,os_md.abs,FC]];
14056: }
14057: if(type(Org=getopt(org))==4){ /* shift origin */
14058: Lx=[Lx[0]-Org[0],Lx[1]-Org[0]];
14059: Ly=[Ly[0]-Org[1],Ly[1]-Org[1]];
14060: Lz=[Lz[0]-Org[2],Lz[1]-Org[2]];
14061: F0=mysubst(F0,[[x,x+Org[0]],[y,y+Org[1]]]);
14062: if(type(F0)==4){
14063: F0=cons(F0[0]-Org[2],cdr(F0));
14064: }
14065: else F0-=Org[2];
14066: }else Org=[0,0,0];
14067: Cpx=getopt(cpx);
14068: if(type(Cpx)<0){
14069: if(str_str(rtostr(F0),"@i")>=0) Cpx=1;
14070: else Cpx=0;
14071: }
14072: if(A<0) A+=360;
14073: if(A<90){
14074: Sh=1;F1=F0;Cx=x-Org[0];Cy=y-Org[1];
14075: }else if(A<180){ /* x -> y, y -> -x */
14076: Sh=2;A-=90; F1=mulsubst(F0,[[x,-y],[y,x]]);
14077: LL=Ly;Ly=[-Lx[1],-Lx[0]];Lx=LL;Cx=y-Org[1];Cy=-x+Org[0];
14078: }else if(A<270){
14079: Sh=3;A-=180; F1=subst(F0,[[x,-x],[y,-y]]);
14080: Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];Cx=-x+Org[0];Cy=-y+Org[1];
14081: }else{
14082: Sh=4;A-=270;F1=mulsubst(F0,[[x,y],[y,-x]]);
14083: LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;Cx=-y+Org[1];Cy=x-Org[0];
14084: }
14085: A=@pi*A/180; B=@pi*B/180;
14086: if(A==0) A=@pi/3;
14087: if(B==0) B=@pi/12;
14088: NN=N*M2;
14089: Ac=dcos(deval(A)); As=dsin(deval(A));
14090: if(Ac<=0.087 || As<=0.087){
14091: mycat(["Unsuitable angle",A0,"(6-th argument)!"]);
14092: return -1;
14093: }
14094: Bc=Ratio*dcos(deval(B)); Bs=dsin(deval(B));
14095: if(Bc<0){
14096: mycat("Unsuitable angle (7-th argument)!");
14097: return -1;
14098: }
14099: /*
14100: z = f(x,y) => X=-As*x+Ac*y, Y= Bc*f(x,y)-Bsc*x-Bss*y
14101: Out X-coord is in [X0,X1], dvided by Dev segments
14102: J-th segment of Y-coord : ZF[J]==1 => [Z0[0],Z1[J]]
14103: */
14104: Bsc=Bs*Ac;Bss=Bs*As;
14105: if(Ratio2!=1){
14106: if(Sh%2==1){
14107: Ac*=Ratio2;Bss*=Ratio2;
14108: }else{
14109: As*=Ratio2;Bsc*=Ratio2;
14110: }
14111: }
14112: CX=-As*Cx+Ac*Cy;CY=Bc*(z-Org[2])-Bsc*Cx-Bss*Cy;
14113: if(type(Dvi=getopt(dviout))!=1 && getopt(trans)==1) return [CX*Sc,CY*Sc];
14114: if(type(N1=getopt(inf))==1){
14115: if(Proc) Dvi=N1;
14116: else if(Dvi<=0) Dvi=-N1;
14117: }
14118: X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1];
14119: F1=mysubst(F1,[@pi,deval(@pi)]);
14120: Tf=type(F1=f2df(F1|opt=0));
14121: if(Tf!=4) F=Bc*F1-Bsc*x-Bss*y;
14122: else F=append([Bc*F1[0]-Bsc*x-Bss*y],cdr(F1));
14123: Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN;
14124: if(type(Err=getopt(err))==1)
14125: F=mysubst(F,[[x,x+Err*Dx/1011.23],[y,y+Err*Dy/1101.34]]);
14126: Out=(Proc)?[]:str_tb(0,0);
14127: Dev=N*M1;
14128: XD=(X1-X0)/Dev;
14129: OLV=newvect(2,[OL,OL]);
14130: if(type(Ura=getopt(opt))==4 || type(Ura)==7){
14131: if(type(Ura)==7) Ura=[Ura,Ura];
14132: else{
14133: OLV[0]=cons(["opt",Ura[0]],OL);
14134: OLV[1]=cons(["opt",Ura[1]],OL);
14135: }
14136: }
14137: for(KC=0; KC<=1; KC++){ /* draw curves */
14138: Z0=newvect(Dev+1); Z1=newvect(Dev+1); ZF=newvect(Dev+1);
14139: for(I=0; I<=NN; I++){
14140: FV=I%M2;
14141: if(KC==0){
14142: X=x; Y=Ly[1]-I*Dy; LX=Lx; DD=Dx; G=mysubst(F,[y,Y]);
14143: if(!FV){
14144: if(!Proc) str_tb(["%y=",rtostr(Y),"\n"],Out);
14145: else Out=cons([-2,"y="+rtostr(Y)],Out);
14146: }
14147: }else{
14148: X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=mysubst(F,[[x,X],[y,Y]]);
14149: if(!FV){
14150: if(!Proc) str_tb(["%x=",rtostr(X),"\n"],Out);
14151: else Out=cons([-2,"x="+rtostr(X)],Out);
14152: }
14153: }
14154: XX=-As*X+Ac*Y; A1=coef(XX,1,x); A0=coef(XX,0,x); /* XX = A1*x + A0, x = (XX-A0)/A1 */
14155: if(!FV && Vw==1){
14156: if(Proc) Out=cons(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1,proc=3),Out);
14157: else str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1),Out);
14158: continue;
14159: }
14160: V=VT=LX[1];
14161: J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD;
14162: if(J0<J1){
14163: J0=ceil(J0); J1=floor(J1); JD=1; /* fixed x: y: dec => (x,z):(dec,inc) */
14164: }else{
14165: J0=floor(J0); J1=ceil(J1); JD=-1; /* fixed y: x: dec => (x,z):(inc,inc) */
14166: }
14167: for(FF=1,J=J1;;J-=JD){
14168: V1=VT;
14169: VT=(X0+J*XD-A0)/A1;GG=mysubst(G,[x,VT]);
14170: if(Cpx>=1) VV=myeval(GG);
14171: else VV=(Tf==4)? mydeval(GG):deval(GG); /* J -> V */
14172: if(ZF[J]==0 || VV<=Z0[J] || VV>=Z1[J]){ /* visible */
14173: if(FF==0){
14174: V0=(VT+V1)/2;
14175: if(!FV && Vw==-1 && Raw!=1){ /* draw doted line */
14176: K=ceil(M3*(V-V0)/(M2*DD));
14177: if(N1<0) K=-K;
14178: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"],["scale",Sc],["para",1]]);
14179: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|
14180: option_list=OPT),Out);
14181: }
14182: V=V0;
14183: }
14184: if(ZF[J]==0){
14185: ZF[J]=1; Z0[J]=Z1[J]=VV;
14186: }else if(VV<=Z0[J]) Z0[J]=VV;
14187: else Z1[J]=VV;
14188:
14189: if(VV>=Z1[J]) FF=1;
14190: else if(VV<=Z0[J]) FF=-1;
14191: }else{
14192: if(FF!=0){
14193: V0=(VT+V1)/2;
14194: K=ceil(M3*(V-V0)/(M2*DD));
14195: if(N1<0) K=-K;
14196: if(!FV){
14197: OPT=append(OPT0,OLV[(1-FF)/2]);
14198: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
14199: }
14200: V=V0;
14201: }
14202: FF=0;
14203: }
14204: if(J==J0) break;
14205: }
14206: if(FV) continue;
14207: V0=LX[0];K=ceil(M3*(V-V0)/(M2*DD));
14208: if(N1<0) K=-K;
14209: if(FF!=0){
14210: if(Raw!=1){
14211: OPT=append(OPT0,OLV[(1-FF)/2]);
14212: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
14213: }else if(Vw==-1 && Raw!=1){
14214: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"]]);
14215: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
14216: }
14217: }
14218: }
14219: }
14220: OptSc=(Sc==1)?[]:[["scale",Sc]];
14221: if(type(LZ=getopt(ax))==4){ /* draw box */
14222: FC=0;
14223: if(length(LZ)==3) FC=LZ[2];
14224: P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*(LZ[0]-Org[0])-Bsc*Lx[1]-Bss*Ly[1]]);
14225: Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]);
14226: Vy=newvect(2,[Ac*(Ly[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]);
14227: Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]);
14228: OL=OL0=append(OPT0,OL);
14229: if(TikZ && type(Ura)==4 && length(Ura)>2) OL0=cons(["opt",Ura[2]],OL);
14230: LL=[[P0+Vz,P0+Vx+Vz],[P0,P0+Vx]];
14231: if(Bs>0){
14232: LL=cons([P0+Vy+Vz,Pz=P0+Vx+Vy+Vz],LL);
14233: LL=cons([P0+Vx+Vz,Pz],LL);
14234: PP=Pz-Vz;
14235: }
14236: else{
14237: LL=cons([P0+Vy,Pz=P0+Vx+Vy+Vz],LL);
14238: LL=cons([P0+Vx,Pz],LL);
14239: PP=Pz+Vz;
14240: }
14241: J=ceil((PP[0]-X0)/XD+0.5);
14242: LL=append([[P0+Vy,P0+Vy+Vz],[P0+Vy,P0+Vy+Vz],[P0+Vx,P0+Vx+Vz],[P0,P0+Vz],
14243: [P0+Vz,P0+Vy+Vz],[P0,P0+Vy]],LL);
14244: for(LL=reverse(LL);LL!=[];LL=cdr(LL)) Out=saveproc(xylines(car(LL)|option_list=OL0),Out);
14245: if(Dev>4) Dev2=ceil(Dev/2);
14246: if(FC<0 && Raw!=1){
14247: if(TikZ){
14248: if(type(Ura)==4 && length(Ura)>2)
14249: OL1=cons(["opt",Ura[2]+",dotted"],OL);
14250: else OL1=cons(["opt","dotted"],OL);
14251: }else OL1=cons(["opt","@{.}"],OL);
14252: if(FC==-8) FC=0;
14253: }
14254: for(I=0;I<3;I++){ /* box with hidden part */
14255: if(I==1) Pz=PP-Vx;
14256: else if(I==2) Pz=PP-Vy;
14257: LP=Pz-PP;
14258: for(FV=-1,K=0;K<=Dev2; K++){
14259: PPx=PP[0]+(K/Dev2)*LP[0]; PPy=PP[1]+(K/Dev2)*LP[1];
14260: J=ceil((PPx-X0)/XD);
14261: if(K!=Dev2 && (J<0||J>Dev)) continue;
14262: if(K!=Dev2 && (ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){ /* visible */
14263: if(FV!=1){
14264: FV=1;
14265: PPP=[PPx,PPy];
14266: }
14267: }else{
14268: if(FV!=0){
14269: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
14270: FV=0;
14271: }
14272: }
14273: }
14274: }
14275: if(FC!=0 && Raw!=1){ /* show coordinate*/
14276: if(iand(FC,4)){
14277: Sub=1;
14278: if(TikZ){
14279: S0="\\scriptsize";S1="";
14280: }else{
14281: S0="{}_{"; S1="}";
14282: }
14283: }else Sub=0;
14284: if(iand(FC,2))
14285: LLL=[[1,0,P0+Vx,(TikZ)?"right":"+!L"],[3,0,P0+Vy,(TikZ)?"left":"+!R"]];
14286: else LL=[];
14287: if(Bs>0){
14288: LLL=cons([0,0,P0,(TikZ)?"below":"+!U"],LLL);
14289: LLL=cons([2,1,P0+Vx+Vy+Vz,(TikZ)?"above":"+!D"],LLL);
14290: }else{
14291: LLL=cons([2,0,P0+Vx+Vy,(TikZ)?"below":"+!U"],LLL);
14292: LLL=cons([0,1,P0+Vz,(TikZ)?"above":"+!D"],LLL);
14293: }
14294: for(TLL=LLL;TLL!=[];TLL=cdr(TLL)){
14295: TL=car(TLL);LL=L[(Sh+TL[0])%4];
14296: if(Cpx==0 || Cpx==3){
14297: S=ltotex([LL[0],LL[1],LZ[TL[1]]]|opt="coord");
14298: SS="("+rtostr(LL[0]) +","+rtostr(LL[1])+","+rtostr(LZ[TL[1]])+")";
14299: }else{
14300: S=ltotex([LL[0]+LL[1]*@i,LZ[TL[1]]]|opt="coord",cpx=Cpx);
14301: SS="("+rtostr(LL[0])+"+"+rtostr(LL[1])+"i,"+ rtostr(LZ[TL[1]])+")";
14302: }
14303: if(TikZ) S="$"+S+"$";
14304: if(Sub) S=S0+S+S1;
14305: if(!TikZ) S="$"+S+"$";
14306: if(Proc) Out=cons([2,OptSc,[TL[2][0],TL[2][1]],[[TL[3],S]],SS],Out);
14307: else str_tb(xyput([TL[2][0],TL[2][1],[TL[3],S]]|option_list=OptSc),Out);
14308: }
14309: }
14310: }
14311: if(type(Pt=getopt(pt))==4){ /* option pt=[] */
14312: if(type(Pt[0])<4) Pt=[[Pt]];
14313: if(length(Pt)>1&&type(Pt[1])!=4) Pt=[Pt];
14314: for(PT=Pt;PT!=[];PT=cdr(PT)){
14315: PP=car(PT);
14316: if(type(PP)==4 && length(PP)==3 && type(PP[0])<2 && type(PP[2])<2) PP=[PP];
14317: P=car(PP);
14318: if(type(P)==7) Q=[P,0];
14319: else if(P==1) Q=["_",0];
14320: else Q=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
14321: if(length(PP)>1 && type(PP[1])==4 && length(PP[1])==3){ /* draw line */
14322: PP=cdr(PP);P=car(PP);
14323: if(type(P)==7) Q1=P;
14324: else if(P==1) Q="_";
14325: else Q1=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
14326: if(length(PP)<2 || PP[1]==0 || iand(PP[1],1)) OL2="";
14327: else OL2=(TikZ)?"dotted":"@{.}";
14328: if(length(PP)>2 && type(PP[2])==7){
14329: if(OL2=="") OL2=PP[2];
14330: else{
14331: if(TikZ) OL2=OL2+",";
14332: OL2=OL2+PP[2];
14333: }
14334: }
14335: OL1=OL;
14336: if(OL2!="") OL1=cons(["opt",OL2],OL1);
14337: if(length(PP)<2 || PP[1]>=0)
14338: Out=saveproc(xylines([Q,Q1]|option_list=OL1),Out);
14339: else{
14340: LP0=Q1[0]-Q[0];LP1=Q1[1]-Q[1];
14341: for(FV=-1,K=0;K<=Dev2; K++){
14342: PPx=Q[0]+(K/Dev2)*LP0; PPy=Q[1]+(K/Dev2)*LP1;
14343: J=ceil((PPx-X0)/XD);
14344: if(K!=Dev2 && (J<0 || J>Dev || ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){
14345: /* visible */
14346: if(FV!=1){
14347: FV=1;
14348: PPP=[PPx,PPy];
14349: }
14350: }else{
14351: if(FV!=0){
14352: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
14353: FV=0;
14354: }
14355: }
14356: }
14357: }
14358: continue;
14359: }
14360: if(length(PP)==1) S="$\\bullet$";
14361: else if(type(PP[1])==7) S=PP[1];
14362: else if(type(PP[1])==4){
14363: if(length(PP[1])>1 && type(PP[1][1])!=7)
14364: S=cons(car(PP),cons("$\\bullet$",cdr(cdr(PP))));
14365: else S=PP[1];
14366: }else S="$\\bullet$";
14367: if(length(PP)<=2){
14368: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S]],Out);
14369: else str_tb(xyput([Q[0],Q[1],S]|option_list=OptSc),Out);
14370: }else if(!TikZ){
14371: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S,"",PP[2]]],Out);
14372: else str_tb(xyput([Q[0],Q[1],S,"",PP[2]]|option_list=OptSc),Out);
14373: }else{
14374: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],cons(S,cdr(cdr(PP)))],Out);
14375: else str_tb(xyput(append([Q[0],Q[1],S],cdr(cdr(PP)))|option_list=OptSc),Out);
14376: }
14377: }
14378: }
14379: if(Proc){
14380: S=reverse(Out);
14381: if(Proc==1||Proc==3){
14382: for(W=[],I=0;I<2;I++) for(J=0;J<2;J++) for(K=0;K<2;K++)
14383: W=cons(mysubst([CX*Sc,CY*Sc],[[x,Lx[I]],[y,Ly[J]],[z,Lz[K]]]),W);
14384: W=ptbbox(W);
14385: S=cons([0,W[0],W[1],(TikZ)?1:1/10],S);
14386: }
14387: }else S=str_tb(0,Out);
14388: if(type(Dvi)!=1||(Proc&&abs(Dvi)<2)) return S;
14389: Lout=[];
14390: if(abs(Dvi)>=2){
14391: /* show title */
14392: L0=[];
14393: Title=getopt(title);
14394: if(type(Title)!=7)
14395: Title=(type(F00)==4)?("\\texttt{"+verb_tex_form(F00)+"}"):my_tex_form(F00);
14396: if(type(Title)==7){
14397: T=my_tex_form(L[3][0])+"\\le x\\le "+my_tex_form(L[1][0])+",\\,"+
14398: my_tex_form(L[3][1])+"\\le y\\le "+my_tex_form(L[1][1])+")";
14399: if(Proc){
14400: if(Cpx>=1) L0=[[5,[["eq",1]],"|"+Title+"|\\quad(z=x+yi,\\ "+T]];
14401: else L0=[[5,[["eq",1]],"z="+Title+"\\ \\ ("+T]];
14402: }else{
14403: if(Cpx>=1) dviout("|"+Title+"|\\quad(z=x+yi,\\ "+T|eq=1,keep=1);
14404: else dviout("z="+Title+"\\ \\ ("+T|eq=1,keep=1);
14405: }
14406: }
14407: A=rint(deval(180*A/@pi))+90*(Sh-1);
14408: if(A>=180) A-=180;
14409: B=rint(deval(180*B/@pi));
14410: if(abs(Dvi)>=3){
14411: T="\\text{angle } ("+my_tex_form(A)+"^\\circ,"+my_tex_form(B)+"^\\circ)";
14412: if(Ratio!=1 || Ratio2!=1) T=T+"\\quad\\text{ratio }1:"
14413: +my_tex_form(sint(Ratio2,2))+":"+my_tex_form(sint(Ratio,2));
14414: if(Proc) L0=cons([5,[["eq",1]],T],L0);
14415: else dviout(T|eq=1,keep=1);
14416: }
14417: SS="% range "+rtostr([L[3][0],L[1][0]])+"x"+rtostr([L[3][1],L[1][1]])+
14418: " angle ("+ rtostr(A) +","+ rtostr(B)+") dev=";
14419: if(M1==M2) SS=SS+rtostr(M1);
14420: else SS=SS+rtostr([M1,M2]);
14421: if(M3!=1) SS=SS+" acc="+rtostr(M3);
14422: if(type(Sc0)>=0) SS=SS+" scale="+rtostr(Sc0);
14423: if(Proc){
14424: S=cons([5,[],SS],S);
14425: for(;L0!=[];L0=cdr(L0)) S=cons(car(L0),S);
14426: return S;
14427: }
14428: if(Dvi>0){
14429: dviout(SS|keep=1);
14430: dviout(xyproc(S)|eq=8);
14431: }else Lout=[SS,S];
14432: }else{
14433: if(Dvi>0) dviout(xyproc(S));
14434: else Lout=[S];
14435: }
14436: if(getopt(trans)==1) return cons([CX*Sc,CY*Sc],Lout);
14437: if(Dvi<0) return Lout;
14438: }
14439:
1.20 takayama 14440: def orthpoly(N)
14441: {
14442: F=0;
14443: if(type(P=getopt(pol))==7){
14444: for(L=["Le","Ge","Tc","2T","Ja","He","La","Se"];L!=[];L=cdr(L),F++)
14445: if(str_str(P,car(L)|end=2)==0) break;
14446: }else P=0;
14447: if(type(D=N)==4) D=N[0];
14448: if(!isint(D)||D<0) return 0;
14449: if(F==0) return seriesHG([-D,D+1],[1],(1-x)/2,D);
14450: 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));
14451: if(F==2) return seriesHG([-D,D],[1/2],(1-x)/2,D);
14452: if(F==3){
14453: if(D==0) return 0;
14454: return orthpoly([D-1,1]|pol="Ge");
14455: }
14456: if(F==4) return red(seriesHG([-D,D+N[1]],[N[2]],x,D));
14457: if(F==5){
14458: for(S=I=1;I<=D;I+=2) S*=I;
14459: if(iand(D,1)) return seriesHG([-(D-1)/2],[3/2],x^2/2,D-1)*x*S*(-1)^((D-1)/2);
14460: else return seriesHG([-D/2],[1/2],x^2/2,D)*S*(-1)^(D/2);
14461: }
14462: if(F==6){
14463: NN=(type(N)==4)?N[1]:0;
14464: return red(seriesHG([-D],[NN+1],x,D)*binom(D+NN,D));
14465: }
14466: if(F==7){
14467: NN=N[1];
14468: for(S=1,I=1;I<=D;I++) S+=(-1)^I*binom(D,I)*binom(D+I,I)*sftpow(x,I)/sftpow(NN,I);
14469: return S;
14470: }
14471: return 0;
14472: }
14473:
14474: def schurpoly(L)
14475: {
14476: N=length(L);
14477: for(R=[],I=1;L!=[];L=cdr(L),I++) R=cons(car(L)+N-I,R);
14478: L=reverse(R);
14479: if(type(X=getopt(var))!=4){
14480: V=(type(X)>1)?X:"x";
14481: for(X=[],I=0;I<N;I++) X=cons(makev([V,N-I]),X);
14482: }
14483: M=newmat(N,N);
14484: for(I=0;I<N;I++)
14485: for(J=0;J<N;J++) M[I][J]=X[I]^L[J];
14486: P=det(M);
14487: for(I=0;I<N;I++)
14488: for(J=I+1;J<N;J++) P=sdiv(P,X[I]-X[J]);
14489: return P;
14490: }
14491:
1.6 takayama 14492: def fouriers(A,B,X)
14493: {
1.20 takayama 14494: if((Y=getopt(y))==0||type(Y)>0) Y=deval(Y);
14495: else Y=0;
14496: if((V=getopt(const))==0||type(V)>0){
14497: V=myfeval(V,Y);
14498: K=1;
14499: }else K=0;
1.6 takayama 14500: if(A!=[]&&type(car(A))>1){
1.20 takayama 14501: for(C=[],I=A[1];I>=K;I--) C=cons(myf2eval(car(A),I,Y),C);
14502: if(K) C=cons(0,C);
1.6 takayama 14503: A=C;
14504: }
1.20 takayama 14505: if(K){
14506: if(A!=[]) A=cdr(A);
14507: A=cons(V,A);
14508: }
1.6 takayama 14509: if(B!=[]&&type(car(B))>1){
1.20 takayama 14510: for(C=[],I=B[1];I>0;I--) C=cons(myf2eval(car(B),I,Y),C);
1.6 takayama 14511: B=C;
14512: }
1.20 takayama 14513: L=length(B)+1;
14514: if(length(A)>=L) L=length(A)+1;
14515: if(type(Sum=getopt(sum))>0){
14516: if(Sum==1) Sum=1-x;
14517: else if(Sum==2) Sum=[(z__)/(3.1416*x),[z__,os_md.mysin,3.1416*x]];
14518: else Sum=f2df(Sum);
14519: C=[];
14520: if(A!=[]){
14521: C=cons(car(A),C);
14522: A=cdr(A);
14523: }
14524: for(I=1;A!=[];A=cdr(A),I++) C=cons(car(A)*myf2eval(Sum,I/L,L),C);
14525: A=reverse(C);
14526: for(C=[],I=1;B!=[];B=cdr(B),I++) C=cons(car(B)*myf2eval(Sum,I/L,L),C);
14527: B=reverse(C);
14528: }
1.6 takayama 14529: if(getopt(cpx)==1){
1.20 takayama 14530: if(type(X=eval(X))>1) return todf([os_md.fouriers,[["cpx",1]]],[[A],[B],[X]]);
1.6 takayama 14531: V=dexp(@i*X);
14532: for(C=A,P=1,I=0;C!=[];C=cdr(C),I++){
1.20 takayama 14533: R+=S*car(C)*P;
1.6 takayama 14534: P*=V;
14535: }
14536: V=dexp(-@i*X);
14537: for(C=B,P=1,I=0;C!=[];C=cdr(C),I++){
14538: P*=V;
14539: R+=car(C)*P;
14540: }
14541: return R;
14542: }
14543: if(type(X=eval(X))>1) return todf(os_md.fouriers,[[A],[B],[X]]);
14544: for(C=A,I=0;C!=[];C=cdr(C),I++)
14545: R+=car(C)*mycos(I*X);
14546: for(C=B,I=1;C!=[];C=cdr(C),I++)
14547: R+=car(C)*mysin(I*X);
14548: return R;
14549: }
14550:
14551:
14552: def myexp(Z)
14553: {
14554: if(type(Z=eval(Z))>1) return todf(os_md.myexp,[Z]);
14555: if((Im=imag(Z))==0) return dexp(Z);
14556: return dexp(real(Z))*(dcos(Im)+@i*dsin(Im));
14557: }
14558:
14559: def mycos(Z)
14560: {
14561: if(type(Z=eval(Z))>1) return todf(os_md.mycos,[Z]);
14562: if((Im=imag(Z))==0) return dcos(Z);
14563: V=myexp(Z*@i);
14564: return (V+1/V)/2;
14565: }
14566:
14567: def mysin(Z)
14568: {
14569: if(type(Z=eval(Z))>1) return todf(os_md.mysin,[Z]);
14570: if((Im=imag(Z))==0) return dsin(Z);
14571: V=myexp(Z*@i);
14572: return (1/V-V)*@i/2;
14573: }
14574:
14575: def mytan(Z)
14576: {
14577: if(type(Z=eval(Z))>1) return todf(os_md.mytan,[Z]);
1.17 takayama 14578: if((Im=imag(Z))==0) return dtan(Z);
1.6 takayama 14579: V=myexp(2*Z*@i);
14580: return @i*(1-V)/(1+V);
14581: }
14582:
14583: def mylog(Z)
14584: {
14585: if(type(Z=eval(Z))>1) return todf(os_md.mylog,[Z]);
1.58 takayama 14586: if(imag(Z)==0&&Z>=0) return dlog(Z);
1.6 takayama 14587: return dlog(dabs(Z))+@i*myarg(Z);
14588: }
14589:
1.57 takayama 14590: def nlog(X)
14591: {
14592: return mylog(X)/dlog(10);
14593: }
14594:
1.6 takayama 14595: def mypow(Z,R)
14596: {
14597: if(type(Z=eval(Z))>1||type(R=eval(R))>1) return todf(os_md.mypow,[Z,R]);
14598: if(Z==0) return 0;
14599: if(isint(2*R)){
14600: if(R==0) return 1;
14601: if(isint(R)) return Z^R;
14602: V=dsqrt(Z);
14603: if(R==1/2) return V;
14604: return Z^(R-1/2)*V;
14605: }
14606: return myexp(R*mylog(Z));
14607: }
14608:
14609: def myarg(Z)
14610: {
1.83 ! takayama 14611: if(type(Z=map(eval,Z))==4||type(Z)==5){
1.6 takayama 14612: if(length(Z)!=2) return todf(os_md.myarg,[Z]);
14613: Re=Z[0];Im=Z[1];
14614: }else if(type(Z)>1){
14615: return todf(os_md.myarg,[Z]);
14616: }else {
14617: Im=imag(Z);Re=real(Z);
14618: }
14619: if(Re==0) return (Im<0)?-deval(@pi)/2:deval(@pi)/2;
14620: V=datan(Im/Re);
14621: if(Re>0) return V;
14622: return (V>0)?(V-deval(@pi)):(V+deval(@pi));
14623: }
14624:
14625: def myatan(Z)
14626: {
14627: if(type(Z=eval(Z))>1) return todf(os_md.myatan,[Z]);
14628: if((Im=imag(Z))==0) return datan(Z);
14629: mylog((1-Z*@i)/(1+Z*@i))*@i/2;
14630: }
14631:
14632: def myasin(Z)
14633: {
14634: if(type(Z=eval(Z))>1) return todf(os_md.myasin,[Z]);
14635: return deval(@pi/2)-myacos(Z);
14636: }
14637:
14638: def frac(X)
14639: {
14640: if(type(X=eval(X))>1) return todf(os_md.frac,[X]);
14641: return (ntype(X)==3)? pari(frac,X):(X-floor(X));
14642: }
14643:
14644: def myacos(Z)
14645: {
14646: if(type(Z=eval(Z))>1) return todf(os_md.myacos,[Z]);
14647: if(imag(Z)==0 && Z<=1 && Z>=-1) return dacos(Z);
14648: return mylog(Z-dsqrt(Z^2-1))*@i;
14649: }
14650:
14651: def arg(Z)
14652: {
14653: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.arg,[Z]);
14654: return (type(Z)==4)?pari(arg,Z[0],Z[1]):arg(sqrt,Z);
14655: }
14656:
14657: def sqrt(Z){
14658: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.sqrt,[Z]);
14659: R=(type(Z)==4)?Z[1]:Z;
14660: if(ntype(R)==0){
14661: if(R==0) return 0;
14662: if(R>0){
14663: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R));
14664: }else{
14665: R=-R;
14666: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R))*@i;
14667: }
14668: }
14669: return (type(Z)==4)?pari(sqrt,Z[0],Z[1]):pari(sqrt,Z);
14670: }
14671:
14672: def gamma(Z)
14673: {
14674: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.gamma,[Z]);
14675: return (type(Z)==4)?pari(gamma,Z[0],Z[1]):pari(gamma,Z);
14676: }
14677:
14678: def lngamma(Z)
14679: {
14680: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.lngamma,[Z]);
14681: return (type(Z)==4)?pari(lngamma,Z[0],Z[1]):pari(lngamma,Z);
14682: }
14683:
14684: def digamma(Z)
14685: {
14686: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.digamma,[Z]);
14687: return (type(Z)==4)?pari(digamma,Z[0],Z[1]):pari(digamma,Z);
14688: }
14689:
14690: def dilog(Z)
14691: {
14692: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.dilog,[Z]);
14693: return (type(Z)==4)?pari(dilog,Z[0],Z[1]):pari(dilog,Z);
14694: }
14695:
14696: def erfc(Z)
14697: {
14698: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.erfc,[Z]);
14699: return (type(Z)==4)?pari(erfc,Z[0],Z[1]):pari(erfc,Z);
14700: }
14701:
14702: def zeta(Z)
14703: {
14704: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.zeta,[Z]);
14705: return (type(Z)==4)?pari(zeta,Z[0],Z[1]):pari(zeta,Z);
14706: }
14707:
14708: def eta(Z)
14709: {
14710: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.eta,[Z]);
14711: return (type(Z)==4)?pari(eta,Z[0],Z[1]):pari(eta,Z);
14712: }
14713:
14714: def jell(Z)
14715: {
14716: if(vars(Z=map(eval,V))>1) return todf(os_md.jell,[Z]);
14717: return (type(Z)==4)?pari(jell,Z[0],Z[1]):jell(jell,Z);
14718: }
14719:
14720: def evals(F)
14721: {
14722: if(type(F)==7){
14723: if(type(Del=getopt(del))!= 7) return eval_str(F);
14724: S=strtoascii(Del);K=length(S);
14725: if(K==0) return [eval_str(F)];
14726: Raw=getopt(raw);
14727: F=strtoascii(F);L=[];T1=0;
14728: do{
14729: T2=str_str(F,S|top=T1);
14730: if(T2<0) T2=10000;
14731: FT=str_cut(F,T1,T2-1);
14732: L=cons((Raw==1)?FT:evals(FT),L);
14733: T1=T2+K;
14734: }while(T2!=10000);
14735: return reverse(L);
14736: }
14737: if(type(F)==4){
14738: if(type(S=car(F))==7){
14739: S+="(";
14740: for(I=0,FT=cdr(F); FT!=[]; I++,FT=cdr(FT)){
14741: if(type(ST=car(FT))!=7) ST=rtostr(ST);
14742: if(I>0) S=S+","+ST;
14743: else S=S+ST;
14744: }
14745: S=S+")";
14746: return eval_str(S);
14747: }else return call(S,cdr(F));
14748: }
14749: return F;
14750: }
14751:
14752: def myval(F)
14753: {
14754: if(type(F)!=4){
14755: F=f2df(sqrt2rat(F));
14756: if(type(F)!=4) return F;
14757: };
14758: if(length(F)==1) V=car(F);
14759: else for(V=car(F),F=cdr(F); F!=[];){
14760: FT=car(F);
14761: if(type(G=FT[1])==2){
14762: if(length(FT)>2){
14763: FT2=myval(FT[2]);
14764: if(length(FT)>3) FT3=myval(FT[3]);
14765: };
14766: X=red(FT2/@pi);Vi=-red(FT2*@i/@pi);W=red(FT2/@e);
14767: if(G==os_md.mypow && FT3==1/2){
14768: G=os_md.sqrt;
14769: FT=[FT[0],G,FT[2]];
14770: }
14771: if((T=findin(G,
14772: [sin,os_md.mysin,cos,os_md.mycos,tan,os_md.mytan]))>=0
14773: &&(isint(6*X)||isint(4*X))){
14774: if(T==2||T==3){
14775: T=0;X=1/2-X;
14776: }
14777: X=X-floor(X/2)*2;
14778: if(T==0||T==1){
14779: if(X>1){
14780: S=-1;X-=1;
14781: }else S=1;
14782: if(X>1/2) X=1-X;
14783: if(X==0) R=0;
14784: else if(X==1/6) R=1/2;
14785: else if(X==1/4) R=2^(1/2)/2;
14786: else if(X==1/3) R=3^(1/2)/2;
14787: else R=1;
14788: R*=S;
14789: }else{
14790: if(X>1) X-=1;
14791: if(X>1/2){
14792: S=-1;V=1-X;
14793: }else S=1;
14794: if(X==0) R=0;
14795: else if(X==1/6) R=3^(1/2)/3;
14796: else if(X==1/4) R=1;
14797: else if(X==1/3) R=3^(1/2);
14798: else R=2^512;
14799: R*=S;
14800: }
14801: }else if((G==exp||G==os_md.myexp)&&(isint(FT2)||isint(6*Vi)||isint(4*Vi))){
14802: if(isint(FT2)) R=@e^FT2;
14803: else R=myval([z+w*@i,[z,cos,Vi*@pi],[w,sin,Vi*@pi]]);
14804: }else if((G==pow||G==os_md.mypow) && (isint(FT3)||FT2==1||FT2==0)){
14805: if(FT2==0) R=0;
14806: else if(FT2==1) R=1;
14807: else R=FT2^FT3;
14808: }else if(G==os_md.abs&&ntype(P=eval(FT2))<4){
14809: R=FT2;
14810: if(P<0) R=-R;
14811: }else if((G==os_md.sqrt||G==dsqrt)&&type(FT2)<2&&ntype(FT2)==0)
14812: R=sqrtrat(FT2);
14813: else if((G==os_md.mylog||G==dlog)&&(FT2==@e||FT2==1))
14814: R=(FT2==1)?0:1;
14815: else if(length(FT)==3) R=eval((*G)(myeval(FT2)));
14816: #ifdef USEMODULE
14817: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
14818: #else
14819: else R=call(G,map(myeval,cdr(cdr(FT))));
14820: #endif
14821: }
14822: else if(G==0) R=FT[2];
14823: #ifdef USEMODULE
14824: else R=eval(call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]));
14825: #else
14826: else R=eval(call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]));
14827: #endif
14828: V=mysubst(V,[FT[0],R]);
14829: F=mysubst(cdr(F),[FT[0],R]);
14830: }
14831: if(type(V)<4 && !iscoef(V,os_md.iscrat)) V=eval(V);
14832: #if 0
14833: return (type(V)<4)?myeval(V):mtransbys(os_md.myeval,V,[]);
14834: #else
14835: return V;
14836: #endif
14837: }
14838:
14839: /* -1:空 0:整数 1:有理数 2:Gauss整数 3:Gauss有理数 4:それ以外の複素数 */
14840: /* def vntype(F)
14841: {
14842: if((T=type(F))<2){
14843: if(T<0) return -1;
14844: if((Tn=ntype(F))==0){
14845: return (isint(F))?0:1;
14846: }
14847: if(Tn==4){
14848: if(ntype(real(F))==0&&ntype(real(F))==0)
14849: return (isint(F)&&isint(F))?2:3;
14850: return 4;
14851: }
14852: }
14853: if(T==2){
14854: V=vars(F);
14855: if((VV=lsort(V,[@e,@pi],1))==[]){
14856: FT=mycoef(
14857: }else{
14858: if(length(VV)==1){
14859: }else
14860: }
14861: }else if(T==3){
14862:
14863: }
14864: }
14865: */
14866:
14867:
14868: def myeval(F)
14869: {
14870: if(type(F)!=4) V=F;
14871: else if(length(F)==1) V=car(F);
14872: else for(V=car(F),F=cdr(F); F!=[];){
14873: FT=car(F);
14874: if(type(G=FT[1])==2){
14875: if(length(FT)==3) R=(*G)(myeval(FT[2]));
14876: #ifdef USEMODULE
14877: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
14878: #else
14879: else R=call(G,map(myeval,cdr(cdr(FT))));
14880: #endif
14881: }
14882: else if(G==0) R=myeval(FT[2]);
14883: #ifdef USEMODULE
14884: else R=call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]);
14885: #else
14886: else R=call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]);
14887: #endif
14888: V=mysubst(V,[FT[0],R]);
14889: F=mysubst(cdr(F),[FT[0],R]);
14890: }
14891: return (type(V)<4)?eval(V):mtransbys(eval,V,[]);
14892: }
14893:
14894: def mydeval(F)
14895: {
14896: if(type(F)!=4) V=F;
14897: else if(length(F)==1) V=car(F);
14898: else for(V=car(F),F=cdr(F); F!=[]; ){
14899: FT=car(F);
14900: if(type(G=FT[1])==2){
14901: if(length(FT)==3) R=(*G)(myeval(FT[2]));
14902: #ifdef USEMODULE
14903: else R=call(G,map(os_md.mydeval,cdr(cdr(FT))));
14904: #else
14905: else R=call(G,map(mydeval,cdr(cdr(FT))));
14906: #endif
14907: }
14908: else if(G==0) R=mydeval(FT[2]);
14909: #ifdef USEMODULE
14910: else R=call(G[0],map(os_md.mydeval,cdr(cdr(FT)))|option_list=G[1]);
14911: #else
14912: else R=call(G[0],map(mydeval,cdr(cdr(FT)))|option_list=G[1]);
14913: #endif
14914: V=mysubst(V,[FT[0],R]);
14915: F=mysubst(cdr(F),[FT[0],R]);
14916: }
14917: return (type(V)<4)?deval(V):mtransbys(deval,V,[]);
14918: }
14919:
14920: def myfeval(F,X)
14921: {
14922: if(type(X)==4){
14923: if(isvar(X[0])&&length(X)==2)
14924: return mydeval(mysubst(F,[X[0],X[1]]));
14925: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
14926: for(Y=X;Y!=[];Y=cdr(Y))
14927: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
14928: return myeval(F);
14929: }
14930: }
14931: return myeval(mysubst(F,[x,X]));
14932: }
14933:
14934: def myf2eval(F,X,Y)
14935: {
14936: return myeval(mysubst(F,[[x,X],[y,Y]]));
14937: }
14938:
14939: def myf3eval(F,X,Y,Z)
14940: {
14941: return myeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
14942: }
14943:
14944: def myfdeval(F,X)
14945: {
14946: if(type(X)==4){
14947: if(isvar(X[0])&&length(X)==2)
14948: return mydeval(mysubst(F,[X[0],X[1]]));
14949: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
14950: for(Y=X;Y!=[];Y=cdr(Y))
14951: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
14952: return mydeval(F);
14953: }
14954: }
14955: return mydeval(mysubst(F,[x,X]));
14956: }
14957:
14958: def myf2deval(F,X,Y)
14959: {
14960: return mydeval(mysubst(F,[[x,X],[y,Y]]));
14961: }
14962:
14963: def myf3deval(F,X,Y,Z)
14964: {
14965: return mydeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
14966: }
14967:
14968: def df2big(F)
14969: {
14970: AG=[[os_md.mysin,sin],[os_md.mycos,cos],[os_md.mytan,tan],[os_md.myasin,asin],
14971: [os_md.acos,acos],[os_md,atan,atan],[os_md.myexp,exp],[os_md.mylog,log],[os_md.mypow,pow]];
14972: if(getopt(inv)!=1) return mysubst(F,AG);
14973: else return mysubst(F,AG|inv=1);
14974:
14975: }
14976:
14977: def f2df(F)
14978: {
14979: if(type(Opt=getopt(opt))!=1) Opt=0;
14980: if(iand(Opt,1)){
14981: if(Opt>0) F=map(eval,F);
14982: else F=map(deval,F);
14983: }
14984: Cpx=getopt(cpx);
14985: if(type(F)==4 && iand(Opt,2)==0) return F;
14986: K=getopt(level);
14987: if(type(K)!=1) K=0;
14988: AG=[sin,cos,tan,asin,acos,atan,exp,sinh,cosh,tanh,log,pow];
14989: AGd=[os_md.mysin,os_md.mycos,os_md.mytan,os_md.myasin,os_md.myacos,
14990: os_md.myatan,os_md.myexp,os_md.myexp,os_md.myexp,os_md.myexp,
14991: os_md.mylog,os_md.sqrt,os_md.myexp];
14992: for(R=[],I=0,Arg=vars(F);Arg!=[];Arg=cdr(Arg)){
14993: Fn=functor(car(Arg));
14994: if(vtype(Fn)!=3) continue;
14995: V=args(car(Arg));
14996: for(PAG=AG,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)){
14997: if(Fn==car(PAG)){
14998: if(K==0) L="z__";
14999: else L="z"+rtostr(K)+"__";
15000: if(I==0) VC=makev([L]);
15001: else VC=makev([L,I]);
15002: I++;
15003: VC0=VC;
15004: if(Fn==sinh || Fn==cosh || Fn==tanh){
15005: VC=makev([L,I++]);
15006: if(Fn==sinh)
15007: R=cons([VC0,0,(VC^2-1)/(2*VC)],R);
15008: else if(Fn==cosh)
15009: R=cons([VC0,0,(VC^2+1)/(2*VC)],R);
15010: else
15011: R=cons([VC0,0,(VC^2-1)/(VC^2+1)],R);
15012: }
15013: if(Fn==pow && (V[1]!=1/2||Cpx==1)){
15014: #if 0
15015: R0=f2df(V[1]*((type(V[0])==1)?dlog(V[0]):log(V[0]))|level=K+1);
15016: PAGd=cdr(PAGd);
15017: #else
15018: R=cons([VC,os_md.mypow,V[0],V[1]],R);
15019: F=mysubst(F,[car(Arg),VC0]);
15020: Arg=cons(0,vars(F));
15021: break;
15022: #endif
15023: }else R0=f2df(V[0]|level=K+1);
15024: R=cons([VC,car(PAGd),R0],R);
15025: F=mysubst(F,[car(Arg),VC0]);
15026: Arg=cons(0,vars(F));
15027: break;
15028: }
15029: }
15030: }
15031: if(R==[]) return F;
15032: if(Cpx==1){
15033: for(PAG=P,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd))
15034: R=mysubst(R,[car(PADd),car(PAG)]);
15035: }
15036: return cons(F,reverse(R));
15037: }
15038:
15039: def todf(F,V)
15040: {
15041: if(type(V)!=4) V=[V];
15042: for(R=[];V!=[];V=cdr(V)){
15043: R=cons(f2df(car(V)),R);
15044: }
15045: V=reverse(R);
15046: Z=makenewv([F,V]);
15047: return [Z,cons(Z,cons(F,V))];
15048: }
15049:
15050: def compdf(F,V,G)
15051: {
15052: FL=["abs","floor","rint","zeta","gamma","arg","real","imag","conj"];
15053: FS=[os_md.abs,floor,rint,os_md.zeta,os_md.gamma,os_md.myarg,real,imag,conj];
15054: if(type(F)==7){
15055: if(str_str(F,"|")==0){
15056: F="abs("+str_cut(F,1,str_len(F)-2)+")";
15057: }else if(str_str(F,"[")==0){
15058: F="floor("+str_cut(F,1,str_len(F)-2)+")";
15059: }
15060: I=str_str(F,"(");
15061: Var=x;
15062: if(I>0){
15063: J=str_pair(F,I+1,"(",")");
15064: if(J<0) return 0;
15065: Var=eval_str(str_cut(F,I+1,J-1));
15066: Var=f2df(Var);
15067: F0=str_cut(F,0,I-1);
15068: }
15069: if((I=findin(F0,FL))<0&&(I=findin(F,FL))<0) F=f2df(eval_str(F));
15070: else F=[z__,[z__,FS[I],Var]];
15071: }
15072: if(type(F)!=4) F=f2df(F);
15073: if(type(G)!=4) G=f2df(G);
1.20 takayama 15074: if(V==G) return F; /* subst(F(V),V,G) */
1.6 takayama 15075: VF=vars(F);VG=vars(G);
1.20 takayama 15076: if(type(V)==4){
15077: for(VT=[],VV=V;VV!=[];VV=cdr(VV)){
15078: if(findin(car(VV),VF)>=0){
15079: X=makenewv(append(VF,VG));
15080: VF=cons(X,VF);
15081: F=mysubst(F,[car(VV),X]);
15082: VT=cons(X,VT);
15083: }else VT=cons(car(VV),VT);
15084: }
15085: for(V=reverse(VT);V!=[];V=cdr(V),G=cdr(G)) F=compdf(F,car(V),car(G));
15086: return F;
15087: }
1.6 takayama 15088: for(E=I=0;I<30;I++){
15089: for(J=0;J<30;J++){
15090: X=makev(["z__",I,J]);
15091: if(findin(X,VF)<0 && findin(X,VG)<0){
15092: E=1;break;
15093: }
15094: }
15095: if(E) break;
15096: }
15097: if(!E) return 0;
15098: if(type(G)<4) return mysubst(F,[V,G]);
15099: if(type(F)<4) F=[F]; /* return compdf([X,[X,0,F]],V,G); */
15100: F=mysubst(F,[V,X]);
15101: if(isvar(G[0])){
15102: G=mysubst(G,[G[0],X]);
15103: if(length(G)==2&&type(G[1])==4&&G[1][0]==X) G=G[1];
15104: G=cons(G,cdr(F));
15105: }
15106: else G=cons([X,0,G],cdr(F));
15107: return cons(car(F),G);
15108: }
15109:
15110: def fzero(F,LX)
15111: {
15112: if(length(LX)==3){
15113: V=LX[0];LX=cdr(LX);
15114: }else V=x;
15115: LX1=eval(LX[0]);LX2=eval(LX[1]);
15116: if(getopt(zero)==1){
15117: if(getopt(cont)==1) CT=1;
15118: else CT=0;
15119: if(getopt(trans)!=1 && type(F)<4) F=f2df(F);
15120: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
15121: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
15122: V1=myeval(mysubst(F,[V,X1=LX1]));
15123: V2=myeval(mysubst(F,[V,X2=LX2]));
15124: if(V1>0){
15125: V0=V1;V1=V2;V2=V0;
15126: X0=X1;X1=X2;X2=X0;
15127: }
15128: if(V1<0 && V2>0){
15129: D=(V2-V1)*1024;
15130: for(I=0; I<Dev; I++){
15131: /* mycat([D,X1,V1,X2,V2]) ; */
15132: if(iand(I,1)) X0=(X1+X2)/2;
15133: else X0=(V2*X1-V1*X2)/(V2-V1);
15134: V0=myeval(mysubst(F,[V,X0]));
15135: if(V0==0||V0==V1||V0==V2) return [X0,V0];
15136: if(V0<0){
15137: if(!CT && V0+D<0) return [];
15138: V1=V0;X1=X0;
15139: }else{
15140: if(!CT && V0>D) return [];
15141: V2=V0;X2=X0;
15142: }
15143: }
15144: X0=(V2*X1-V1*X2)/(V2-V1);
15145: return [X0,myeval(mysubst(F,[V,X0]))];
15146: }
15147: if(V0==0) return [X0,V0];
15148: if(V1==0) return [X1,V1];
15149: return [];
15150: }
15151: if(type(F)<4) F=f2df(F);
15152: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
15153: L=[];
15154: if(type(F)<4){
15155: if(type(F)==3) F=nm(red(F));
15156: if((Deg=deg(F,V))<=2){
15157: if(Deg==2){
15158: D=(C1=coef(F,1,V))^2-4*(C2=coef(F,2,V))*coef(F,0,V);
15159: if(D>=0){
15160: R=dsqrt(D);
15161: if((S=(-C1+R)/(2*C2))>=LX1&&S<=LX2) L=[[S,mysubst(F,[V,S])]];
15162: if(D!=0 && (S=(-C1-R)/(2*C2))>=LX1&&S<=LX2) L=cons([S,mysubst(F,[V,S])],L);
15163: }
15164: L=qsort(L);
15165: }else if(Deg==1&&(S=-coef(F,0,V)/coef(F,1,V))>=LX1&&S<=LX2)
15166: L=[[S,mysubst(F,[V,S])]];
15167: return L;
15168: }
15169: for(L=[];S!=[];S=cdr(S))
15170: if(car(S)>=LX1&&car(S)<=LX2) L=cons([car(S),mysubst(F,[V,car(S)])],L);
15171: return qsort(L);
15172: }
15173: if(type(Div=getopt(mesh))!=1 || Div<=0)
15174: Div = 2^(10);
15175: W=(LX2-LX1)/Div;
15176: for(I=V2=0;I<=Div;I++){
15177: X1=X2;X2=LX1+I*W;V1=V2;
15178: if((V2=myeval(mysubst(F,[V,X2])))==0)
15179: L=cons([X2,V2],L);
15180: if(V1*V2<0){
15181: L0=fzero(F,[V,X1,X2]|zero=1,trans=1);
15182: if(L0!=[]) L=cons(L0,L);
15183: }
15184: }
15185: return reverse(L);
15186: }
15187:
15188: def fmmx(F,LX)
15189: {
15190: if(length(LX)==3){
15191: V=LX[0];LX=cdr(LX);
15192: }else V=x;
15193: LX1=eval(LX[0]);LX2=eval(LX[1]);
15194: FT=F;
15195: if(getopt(trans)!=1 && type(F)<4) FT=f2df(FT);
15196: FT=mysubst(FT,[[@pi,eval(@pi)],[@e,eval(@e)]]);
15197: if(type(G=getopt(dif))>=1){
15198: if(G==1) G=os_md.mydiff(F,V);
15199: L=fzero(G,[V,LX1,LX2]|option_list=getopt());
15200: R=[[LX1,myeval(mysubst(FT,[V,LX1]))]];
15201: for(I=0;L!=[];L=cdr(L),I++){
15202: X=car(L)[0];
15203: if(X==LX1) continue;
15204: R=cons([X,myeval(mysubst(FT,[V,X]))],R);
15205: }
15206: if(X!=LX2) R=cons([LX2,myeval(mysubst(FT,[V,LX2]))],R);
15207: if(getopt(mmx)!=1) return reverse(R);
15208: for(Mi=Ma=car(R);R!=[];R=cdr(R)){
15209: if(car(R)[1]>Ma[1]) Ma=car(R);
15210: else if(car(R)[1]<Mi[1]) Mi=car(R);
15211: }
15212: return [Mi,Ma];
15213: }
15214: if(type(Div=getopt(mesh))!=1 || Div<=0)
15215: Div = 2^(10);
15216: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
15217: W=(LX2-LX1)/Div;
15218: for(I=V2=V3=0;I<=Div;I++){
15219: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
15220: V3=myeval(mysubst(FT,[V,X3]));
15221: if(I==0) L=[[X3,V3]];
15222: if(I<2) continue;
15223: if((V1-V2)*(V2-V3)<0){
15224: X02=X2;V02=V2;X03=X3;V03=V3;
15225: for(J=0; J<Dev && X1!=X3; J++){
15226: X12=(X1+X2)/2;V12=myeval(mysubst(FT,[V,X12]));
15227: if((V1-V12)*(V12-V2)<=0){
15228: X3=X2;V3=V2;X2=X12;V2=V12;continue;
15229: }
15230: X23=(X2+X3)/2;V23=myeval(mysubst(FT,[V,X23]));
15231: if((V12-V2)*(V2-V23)<=0){
15232: X1=X12;V1=V12;X3=X23;V3=V23;continue;
15233: }
15234: if((V2-V23)*(V23-V3)<=0){
15235: X1=X2;V1=V2;X2=X23;V2=V23;continue;
15236: }
15237: }
15238: L=cons([X2,V2],L);
15239: X2=X02;V2=V02;X3=X03;V3=V03;
15240: }
15241: }
15242: L=cons([LX2,myeval(mysubst(FT,[V,LX2]))],L);
15243: if(getopt(mmx)!=1) return L;
15244: for(Mi=Ma=car(L);L!=[];L=cdr(L)){
15245: if(car(L)[1]>Ma[1]) Ma=car(L);
15246: else if(car(L)[1]<Mi[1]) Mi=car(L);
15247: }
15248: return [Mi,Ma];
15249: }
15250:
15251: def flim(F,L)
15252: {
15253: FD=f2df(F);
15254: Lim0=4;Lim=12;FS=1;
15255: if(type(Pc=getopt(prec))==1){
15256: if((Pc>1&&Pc<31)||Pc>-5) Lim+=Pc;
15257: }
15258: if(type(Pc=getopt(init))==1 && Pc>0) FS*=Pc;
15259: if(type(L)==7) L=[L];
15260: else if(type(L)<2){
15261: K=flim(F,["+",L]|option_list=getopt());
15262: if(K=="") return K;
15263: K1=flim(F,["-",L]|option_list=getopt());
15264: if(K1=="") return K1;
15265: if(type(K)==7||type(K1)==7){
15266: if(K!=K1) return "";
15267: return K;
15268: }
15269: if(abs(K)<10^(-5)){
15270: if(abs(K1)<10^(-5)) return (K1+K)/2;
15271: else return "";
15272: }
15273: if(abs((K1-K)/K)<10^(-4)) return (K1+K)/2;
15274: return "";
15275: }
15276: if(type(L)!=4||type(L[0])!=7) return "";
15277: if(L[0]=="-"||L[0]=="-infty"){
15278: FS=-FS;
15279: }else if(L[0]!="+"&&L[0]!="infty") return "";
15280: FI=(length(L)==1)?1:0;
15281: for(Inf=0,I=Lim0;I<Lim;I++){
15282: D1=FS*8^I;D2=8*D1;
15283: if(FI==0){
15284: D1=1/D1;D2=1/D2;
15285: }
15286: if(D1>D2){
15287: D=D1;D1=D2;D1=D;
15288: X1=D1;X2=D2;
15289: }
15290: if(FI==0){
15291: D1+=L[1];D2+=L[1];
15292: }
15293: K=fmmx(FD,[D1,D2]|mmx=1,mesh=16,dev=4);
15294: if(I>Lim0){
15295: if(DF<K[1][1]-K[0][1]&&DF>10^(-8)&&DF<10^7){
15296: if(I>Lim0+1){
15297: if(Inf==0) return "";
15298: }else Inf=1;
15299: }else if(Inf==1) return "";
15300: }
15301: DF=K[1][1]-K[0][1];
15302: }
15303: if(Inf==1){
15304: if(K[0][1]>10^8) return "+";
15305: else if(K[1][1]<-10^8) return "-";
15306: return "";
15307: }
15308: V=(myfeval(FD,D1)+1.0)-1.0;
15309: if(V!=0 && abs(V)<10^(-9)) return 0;
15310: return V;
15311: }
15312:
15313: def fcont(F,LX)
15314: {
15315: if(length(LX)==3){
15316: V=LX[0];LX=cdr(LX);
15317: }else V=x;
15318: LX1=eval(LX[0]);LX2=eval(LX[1]);
15319: if(getopt(trans)!=1 && type(F)<4) FT=f2df(F);
15320: if(type(Div=getopt(mesh))!=1 || Div<=0)
15321: Div = 2^(10);
15322: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
15323: W=(LX2-LX1)/Div;
15324: if((Df=getopt(dif))!=1){
15325: Df=0;
15326: }else{
15327: if(Dev==16) Dev=6;
15328: WD=W/2^(Dev+1);
15329: }
15330: F=FT;
15331: C=2;
15332: for(I=V2=V3=0;I<=Div;I++){
15333: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
15334: V3=myeval(mysubst(F,[V,X3]));
15335: if(Df){
15336: if(I==Div) break;
15337: V3=(myeval(mysubst(F,[V,X3+WD]))-V3)/WD;
15338: }
15339: if(I==0) L=[[X3,V3]];
15340: if(I<2) continue;
15341: if(C*dabs(2*V2-V1-V3) > dabs(V1-V3)){
15342: X01=X1;V01=V1;X02=X2;V02=V2;X03=X3;V03=V3;
15343: for(J=0; X01!=X03; J++){
15344: if(dabs(V01-V02)>dabs(V02-V03)){
15345: X03=X02;V03=V02;
15346: }else{
15347: X01=X02;V01=V02;
15348: }
15349: if(J==Dev) break;
15350: X02=(X01+X02)/2;
15351: V02=myeval(mysubst(F,[V,X02]));
15352: if(Df) V02=(myeval(mysubst(F,[V,WD]))-V02)/WD;
15353: if(C*dabs(2*V02-V01-V03) < dabs(V01-V03)) break;
15354: }
15355: if(J==Dev||X01==X03) L=cons([X01,X03,V03-V01],L);
15356: }
15357: }
15358: return reverse(L);
15359: }
15360:
1.57 takayama 15361: def xyplot(L,LX,LY)
15362: {
1.63 takayama 15363: Vw=getopt(view);
15364: if(type(Vw)!=1 && type(Vw)!=7 && Vw!=0) Vw=-1;
15365: if(!LX){
15366: L0=llget(L,1,[0]|flat=1);
1.71 takayama 15367: LX=[lmin(L0),LXm=lmax(L0)];
15368: S=SX=LX[1]-LX[0];
1.63 takayama 15369: if(S>0){
15370: if(Vw) LX=[LX[0]-S/32,LX[1]+S/32];
15371: }else LX=[LX[0]-1,LX[0]+1];
1.64 takayama 15372: }
15373: LX=map(deval,LX);
1.63 takayama 15374: if(!LY){
15375: L0=llget(L,1,[1]|flat=1);
1.71 takayama 15376: LY=[lmin(L0),LYm=lmax(L0)];
15377: S=SY=LY[1]-LY[0];
1.63 takayama 15378: if(S>0){
15379: if(Vw) LY=[LY[0]-S/32,LY[1]+S/32];
15380: }else LY=[LY[0]-1,LY[0]+1];
1.64 takayama 15381: }
15382: LY=map(deval,LY);
1.63 takayama 15383: if(getopt(raw)==1) mycat([LX,LY]);
15384: if(Vw!=-1){
15385: if(Vw!=1){
15386: if(type(Vw)==7) Vw=trcolor(Vw);
15387: Opt=[["color",Vw]];
15388: }else Opt=[];
15389: Glib_math_coordinate=1;
15390: glib_window(LX[0],LY[0],LX[1],LY[1]);
15391: for(; L!=[];L=cdr(L))
15392: glib_putpixel(car(L)[0],car(L)[1]|option_list=Opt);
1.71 takayama 15393: if((AX=getopt(ax))==1||AX==2){
15394: if(LY[0]<0&&LY[1]>0){
15395: glib_line(LX[0],0,LX[1],0);
15396: if(AX==2&&LXm>0){
15397: E=floor(dlog(LXm)/dlog(10));
15398: V=floor(LXm*10^(-E)+1/128)*10^E;
15399: glib_line(V,0,V,SY/64);
15400: glib_print(V,-SY/128,rtostr(V));
15401: }
15402: }
15403: if(LX[0]<0&&LX[1]>0){
15404: glib_line(0,LY[0],0,LY[1]);
15405: if(AX==2&&LYm>0){
15406: E=floor(dlog(LYm)/dlog(10)+1/64);
15407: V=floor(LYm*10^(-E)+1/128)*10^E;
15408: glib_line(0,V,SX/64,V);
15409: glib_print(SX/96,V,rtostr(V));
15410: }
15411:
15412: }
15413: }
1.63 takayama 15414: return [LX,LY];
15415: }
1.57 takayama 15416: Opt=getopt();Opt0=delopt(Opt,["dviout","proc"]);
1.64 takayama 15417: if(type(R=getopt(to))!=4) To=[12,8];
15418: R=[To[0]/(LX[1]-LX[0]),RY=To[1]/(LY[1]-LY[0])];
15419: R=[sint(R[0],4|str=0),sint(R[1],4|str=0)];
15420: S="% ";
15421: if(type(C=getopt(scale))!=1&&type(C)!=4){
15422: Opt0=cons(["scale",R],Opt0);
15423: S+="scale="+rtostr(R)+", ";
15424: }
1.65 takayama 15425: S+=rtostr(LX)+", "+rtostr(LY)+"\n";
1.64 takayama 15426: for(L0=[],TL=L;TL!=[];TL=cdr(TL)){
1.57 takayama 15427: TTL=map(deval,car(TL));
15428: if(TTL[0]<LX[0]||TTL[0]>LX[1]||TTL[1]<LY[0]||TTL[1]>LY[1]){
15429: S+=xylines(reverse(L0)|option_list=Opt0);
15430: L0=[];
15431: }else{
15432: L0=cons(TTL,L0);
15433: }
15434: }
15435: if(length(L0)>1) S+=xylines(reverse(L0)|option_list=Opt0);
1.64 takayama 15436: AX=getopt(ax);Opt=delopt(Opt0,"opt");
1.65 takayama 15437: if(type(AX)==4) S+="% axis\n"+xygraph([0,0],0,LX,LX,LY|option_list=Opt);
1.64 takayama 15438: else if((LX[0]<=0&&LX[1]>=0)||(LY[0]<=0&&LY[1]>=0))
1.65 takayama 15439: S+="% axis\n"+xygraph([0,0],0,LX,LX,LY|option_list=cons(["ax",[0,0]],Opt));
1.57 takayama 15440: if(getopt(dviout)!=1) return S;
15441: xyproc(S|dviout=1);
1.64 takayama 15442: return [LX,LY];
1.57 takayama 15443: }
15444:
1.63 takayama 15445: def xyaxis(A,X,Y)
15446: {
15447: if(isint(Vw=getopt(view))&&Vw!=0){
15448: CL=getopt(opt);
15449: if(type(CL)==7) CL=trcolor(CL);
15450: if(type(CL)!=0) CL=0;
15451: if(CL) Opt=[[color,CL]];
15452: else Opt=[];
15453: Glib_math_coordinate=1;
15454: UX=(X[1]-X[0])/50;UY=(Y[1]-Y[0])/50;
15455: glib_window(X[0],Y[0],X[1],Y[1]);
15456: glib_line(A[0],Y[0],A[0],Y[1]|option_list=Opt);
15457: glib_line(X[0],A[1],X[1],A[1]|otpion_list=Opt);
15458: if(length(A)>2&&A[2]){
15459: I0=-floor((A[0]-X[0])/A[2]);I1=floor((X[1]-A[0])/A[2]);
15460: for(I=I0;I<=I1;I++){
15461: IX=A[0]+A[2]*I;
15462: if(iand(Vw,2)) glib_print(IX-UX,A[1]-UY/2,rtostr(IX));
15463: glib_line(IX,A[1],IX,A[1]+UY);
15464: }
15465: }
15466: if(length(A)>3&&A[3]){
15467: I0=-floor((A[1]-Y[0])/A[3]);I1=floor((Y[1]-A[1])/A[3]);
15468: for(I=I0;I<=I1;I++){
15469: IY=A[1]+A[3]*I;
15470: if(iand(Vw,4)) glib_print(A[0]-UX*2,IY+UY,rtostr(IY));
15471: glib_line(A[0],IY,A[0]+UX,IY);
15472: }
15473: }
15474: return;
15475: }
15476: Opt=getopt();
15477: Opt=cons(["ax",A],Opt);
15478: return xygraph([0,0],0,[0,1],X,Y|option_list=Opt);
15479: }
15480:
1.6 takayama 15481: def xygraph(F,N,LT,LX,LY)
15482: {
15483: if((Proc=getopt(proc))!=1&&Proc!=2&&Proc!=3) Proc=0;
15484: if(type(DV=getopt(dviout))==4){
15485: OL=delopt(getopt(),["dviout","shift","ext","cl"]);
15486: OL=cons(["proc",1],OL);
15487: R=xygraph(F,N,LT,LX,LY|option_list=OL);
15488: OL=delopt(getopt(),["shift","ext","cl"]|inv=1);
15489: return execdraw(R,DV|optilon_list=OL);
15490: }
15491: if(N==0) N=32;
15492: if(N<0){
15493: N=-N;
15494: N1=-1; N2=N+1;
15495: }else{
15496: N1=0; N2=N;
15497: }
15498: if(length(LT)==3 && isvar(LT[0])==1){
15499: TT=LT[0]; LT=cdr(LT);
15500: F=mysubst(F,[TT,x]);
15501: }
15502: if(LX==0) LX=LT;
15503: if((Acc=getopt(Acc))!=1) Acc=0;
15504: if(Acc){
15505: LX=[eval(LX[0]),eval(LX[1])];
15506: LY=[eval(LY[0]),eval(LY[1])];
15507: LT=[eval(LT[0]),eval(LT[1])];
15508: }else{
15509: LX=[deval(LX[0]),deval(LX[1])];
15510: LY=[deval(LY[0]),deval(LY[1])];
15511: LT=[deval(LT[0]),deval(LT[1])];
15512: }
15513: TD=(LT[1]-LT[0])/N;
15514: if(type(Mul=getopt(scale))!=1){
15515: if(type(Mul)==4){
15516: MulX=Mul[0]; MulY=Mul[1];
15517: }else MulX=MulY=1;
15518: }else MulX=MulY=Mul;
15519: if(type(Org=getopt(org))==4){
15520: Orgx=Org[0];Orgy=Org[1];
15521: }else Orgx=Orgy=0;
15522: if(type(F)!=4 || (getopt(para)!=1 && length(F)>1 && type(F[0])<4 && type(F[1])==4)) {
15523: if(getopt(rev)!=1){
15524: F1=x; /* LX[0]+(LX[1]-LX[0])*(x-LT[0])/(TD*N); */
15525: F2=F;
15526: }else{
15527: F1=F;
15528: F2=x; /* LY[0]+(LY[1]-LY[0])*(x-LT[0])/(TD*N); */
15529: }
15530: }else{
15531: F1=F[0]; F2=F[1];
15532: }
15533: if(F1==0 || F2==0) LT=[];
15534: if(length(LT)==2){
15535: if(Acc){
15536: for(LTT=[],I=N2;I>=N1;I--)
15537: LTT=cons(eval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
15538: }else{
15539: for(LTT=[],I=N2;I>=N1;I--)
15540: LTT=cons(deval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
15541: }
15542: LT=LTT;
15543: }
15544: Cpx=getopt(cpx);
15545: if(Cpx!=1 && (str_str(rtostr(F1),"@i")>=0 || str_str(rtostr(F2),"@i")>=0))
15546: Cpx=1;
15547: if(type(Cpx)<0) Cpx=0;
15548: if(!Acc){
15549: if(type(F1)<4) F1=f2df(F1);
15550: if(type(F2)<4) F2=f2df(F2);
15551: }
15552: if(type(Err=getopt(err))==1){
15553: F1=mysubst(F1,[x,x+Err*TD/1001.23]);
15554: F2=mysubst(F2,[x,x+Err*TD/1001.23]);
15555: }
15556: if(type(F1)==4 || type(F2)==4){
15557: Dn=1;
15558: }else Dn=dn(F1)*dn(F2);
15559: for(V=[],PT=LT;PT!=[]; PT=cdr(PT)){
15560: T=car(PT);
15561: if(myfeval(Dn,T)==0){
15562: V=cons(0,V); continue;
15563: }
15564: if(Cpx>0||Acc){
15565: X=myfeval(F1,T);Y=myfeval(F2,T);
15566: }else{
15567: X=myfdeval(F1,T);Y=myfdeval(F2,T);
15568: }
15569: if((N1==0||(PT!=LT&&length(PT)!=1)) && (X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1]))
15570: V=cons(0,V);
15571: else
15572: V=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],V);
15573: }
15574: V=reverse(V);
15575: Gap0=Gap=Arg=0;
15576: if(type(Prec=getopt(prec))<0)
15577: Level=0;
15578: else if(Prec==0) Level=4;
15579: else if(type(Prec)==1){
15580: Level=Prec;
15581: if(Level<0){
15582: Level=-Level;
15583: Gap0=1;
15584: }
15585: }else if(type(Prec)==4){
15586: Level=Prec[0];
15587: if(length(Prec)>1) Arg=Prec[1];
15588: if(length(Prec)>2) Gap0=Prec[2];
15589: }
15590: if(Level>0){
15591: if(Level>16) Level=16;
15592: if(Arg<=0) Arg=30;
15593: else if(Arg>120) Arg=120;
15594: Arg=Acc?eval(@pi*Arg/180):deval(@pi*Arg/180);
15595: SL=dcos(Arg);
15596: }
15597: if(Gap0>0){
15598: if(Gap0<2) Gap0=16;
15599: else if(Gap0>512) Gap0=512;
15600: Gap=((MulX*(LX[1]-LX[0]))^2+(MulY*(LY[1]-LY[0]))^2)/(Gap0^2);
15601: }
15602: for(I=0;I<Level;I++){
15603: for(F=K=G=0,NV=NLT=[],PLT=LT,PV=V;PLT!=[];K++,PLT=cdr(PLT),PV=cdr(PV)){
15604: TG=0;D0=D1;CLT0=CLT;CV0=CV;CV=car(PV);CLT=car(PLT);
15605: if(length(PV)>1){
15606: if((CV1=car(cdr(PV)))!=0 && CV!=0)
15607: D1=[CV[0]-CV1[0],CV[1]-CV1[1]];
15608: else D1=0;
15609: }else K=-1; /* ? */
15610: if(K>0 &&(((D1==0||D0==0)&&(CV0!=0||CV!=0||CV1!=0)) || dvangle(D0,D1)<SL ||
15611: (Gap>0 && type(D0)==4 && (TG=(D0[0]^2+D0[1]^2-Gap)>0)))){
15612: G++;T1=(CLT0+CLT)/2;
15613: if(F==0 && (CV0!=0 || CV!=0)){
15614: if(myfdeval(Dn,T1)==0){
15615: NV=cons(0,NV); NLT=cons(T1,NLT);
15616: }
15617: if(Cpx>0||Acc){
15618: X=myfeval(F1,T1);Y=myfeval(F2,T1);
15619: }else{
15620: X=myfdeval(F1,T1);Y=myfdeval(F2,T1);
15621: }
15622: if(K==1 && N1<0){
15623: NV=[];NLT=[];
15624: }
15625: if((K>1||N1==0)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
15626: NV=cons(0,NV);NLT=cons(T1,NLT);F=0;
15627: }else{
15628: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T1,NLT);
15629: }
15630: }
15631: NV=cons(CV,NV);NLT=cons(CLT,NLT);
15632: if(!TG&&(CV0!=0||CV1!=0)){
15633: T2=(car(cdr(PLT))+CLT)/2;
15634: if(myfdeval(Dn,T2)==0){
15635: NV=cons(0,NV); NLT=cons(CLT,NLT);
15636: }
15637: if(Cpx>0||Acc){
15638: X=myfeval(F1,T2);Y=myfeval(F2,T2);
15639: }else{
15640: X=myfdeval(F1,T2);Y=myfdeval(F2,T2);
15641: }
15642: if((N1==0||length(PV)!=2)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
15643: NV=cons(0,NV);NLT=cons(T1,NLT);
15644: }else{
15645: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T2,NLT);
15646: }
15647: }
15648: if(length(PV)==2 && N1==-1) break;
15649: F=1;
15650: }else{
15651: F=0;NV=cons(CV,NV);NLT=cons(CLT,NLT);
15652: }
15653: }
15654: V=reverse(NV);LT=reverse(NLT);
15655: if(G==0) break;
15656: }
15657: if(Gap>0){
15658: for(NV=[],PV=V;PV!=[];PV=cdr(PV)){
15659: NV=cons(P0=car(PV),NV);
15660: if(length(PV)>1 && P0!=0 && PV[1]!=0
15661: && (P0[0]-PV[1][0])^2+(P0[1]-PV[1][1])^2>Gap) NV=cons(0,NV);
15662: }
15663: V=reverse(NV);
15664: }
1.18 takayama 15665: if((Raw=getopt(raw))==1) return V;
15666: if(Raw==2) return [V,LT];
1.6 takayama 15667: OL=[["curve",1]];OLP=[];
15668: if(type(C=getopt(ratio))==1){
15669: OL=cons(["ratio",C],OL);OLP=cons(["ratio",C],OLP);
15670: }
15671: if(Acc==1) OL=cons(["Acc",1],OL);
15672: if(N1<0) OL=cons(["close",-1],OL);
15673: if(type(Opt=getopt(opt))!=7 && type(Opt)!=4){
15674: if(Opt==0) return xylines(V|option_list=cons(["opt",0],OL));
15675: }
15676: OL=cons(["opt",(Proc)?0:Opt],OL);
15677: if(type(Opt)>=0) OLP=cons(["opt",Opt],OLP);
15678: if(type(Vb=getopt(verb))==1||type(Vb)==4){
15679: OL=cons(["verb",Vb],OL);OLP=cons(["verb",Vb],OL);
15680: }
15681: if(Proc){
15682: S=(Proc==1)?
15683: [[0,[MulX*(LX[0]-Orgx),MulX*(LX[1]-Orgx)],[MulY*(LY[0]-Orgy),MulY*(LY[1]-Orgy)],
15684: (TikZ)?1:1/10]]:[];
15685: S=cons([1,OLP,xylines(V|option_list=OL)],S);
15686: if(Proc==3) return car(S);
15687: }else S=xylines(V|option_list=OL);
15688: if(type(Pt=getopt(pt))==4){
15689: if(type(Pt[0])!=4) Pt=[Pt];
15690: if(length(Pt)>1 && type(Pt[1])!=4) Pt=[Pt];
15691: for(PT=Pt;PT!=[];PT=cdr(PT)){
15692: PP=car(PT);
15693: if(type(PP[0])!=4) PP=[PP];
15694: P=car(PP);PP=cdr(PP);
15695: Qx=MulX*(P[0]-Orgx);Qy=MulY*(P[1]-Orgy);
15696: if(length(PP)>0 && type(PP[0])==4){ /* draw line */
15697: P=car(PP);
15698: Q1x=MulX*(P[0]-Orgx);Q1y=MulY*(P[1]-Orgy);
15699: if(length(PP)<1 || car(PP)==0 || iand(car(PP),1))
15700: OL=["opt",(TikZ)?"-":"@{-}"];
15701: else OL=["opt",(TikZ)?".":"@{.}"];
15702: if(Proc) S=cons([1,OL,[[Qx,Qy],[Q1x,Q1y]]],S);
15703: else S=S+xylines([[Qx,Qy],[Q1x,Q1y]]|optilon_list=OL);
15704: continue;
15705: }
15706: if(length(PP)==0 || type(car(PP))!=7) SS="$\\bullet$";
15707: else SS=car(PP);
15708: if(length(PP)<=1){
15709: if(Proc) S=cons([2,[],[Qx,Qy],[SS]],S);
15710: else S=S+xyput([Qx,Qy,SS]);
15711: }else{
15712: if(Proc) S=cons([2,[],[Qx,Qy],[[SS],"",PP[1]]],S);
15713: S=S+xyput([Qx,Qy,SS,"",PP[1]]);
15714: }
15715: }
15716: }
15717: if(type(Ax=getopt(ax))==4){ /* draw axis */
15718: Adx0=Ady0=0; Adx1=Ady1=0.1;
15719: if(!TikZ){
15720: if(!XYcm) Adx1=Ady1=1;
15721: LOp="@{-}"; LxOp="+!U"; LyOp="+!R";
15722: }else{
15723: LOp="-"; LxOp="below"; LyOp="left";
15724: }
15725: LOp0=LOp1=LOp;
15726: LxOO=(Ax[1]==LY[0])?LxOp:(TikZ)?"below left":"+!UR";
15727: if(type(AxOp=getopt(axopt))>0){
15728: if(type(AxOp)==1){
15729: if(AxOp>0) Adx1=Ady1=AxOp;
15730: else if(AxOp<0){
15731: Adx1=Ady1=0; Adx0=Ady0=AxOp;
15732: }
15733: }else if(type(AxOp)==4){
15734: if(type(T=car(AxOp))==4 && length(AxOp)>1){
15735: if(type(T)==7){
15736: LxOp=T; LyOp=AxOp[1];
15737: }else if(type(T)==4){
15738: Ay0=T[0]; Ay1=T[1]; Ax0=AxOp[1][0]; Ax1=AxOp[1][1];
15739: if(length(T)>2) LxOp=T[2];
15740: if(length(AxOp[1])>2) LyOp=AxOp[1][2];
15741: }
15742: }
15743: if(length(AxOp)>2 && type(AxOp[2])==7) LxOO=AxOp[2];
15744: if(length(AxOp)>3 && type(AxOp[3])==7) LOp0=AxOp[3];
15745: if(length(AxOp)>4 && type(AxOp[4])==7) LOp1=AxOp[4];
15746: }
15747: if(type(AxOp)==7) LOp0=AxOp;
15748: }
15749: if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */
15750: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp0]]:[],
15751: [MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],[MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]],S);
15752: else S=S+xyarrow([MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],
15753: [MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]|opt=LOp0);
15754: if(length(Ax)>2){
15755: D=Ax[2];
15756: if(type(D)==1 && D>0){
15757: I0=ceil((LX[0]-Ax[0])/D); I1=floor((LX[1]-Ax[0])/D);
15758: for(DD=[],I=I0; I<=I1; I++){
15759: if(length(Ax)<5) DD=cons(I*D,DD);
15760: else if(Ax[4]==0) DD=cons([I*D,I*D+Ax[0]],DD);
15761: else if(Ax[4]==1) DD=cons([I*D,I*D],DD);
15762: else if(Ax[4]==2) DD=cons([I*D,I],DD);
15763: }
15764: D=DD;
15765: }
15766: if(type(D)==4){
15767: for(;D!=[]; D=cdr(D)){
15768: T=car(D);
15769: if(type(T)==4) T=car(T);
15770: X=MulX*(T+Ax[0]-Orgx); Y=MulY*(Ax[1]-Orgy);
15771: if(T!=0){
15772: if(Proc) S=cons([3,(type(LOp1)>=0)?[["opt",LOp1]]:[],[X,Y+Ady0],[X,Y+Ady1]],S);
15773: else S=S+xyarrow([X,Y+Ady0],[X,Y+Ady1]|opt=LOp1);
15774: }
15775: if(type(car(D))==4){
15776: Arg=[(T==0)?LxOO:LxOp,D[0][1]];
15777: if(Proc) S=cons([2,[],[X,Y+Ady0],[Arg]],S);
15778: else S=S+xyput([X,Y+Ady0,Arg]);
15779: }
15780: }
15781: }
15782: }
15783: }
15784: if(Ax[1]>=LY[0] && Ax[1]<=LY[1]){ /* draw marks on y-axis */
15785: if(Proc) S=cons([3,[["opt",LOp0]],
15786: [MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
15787: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]],S);
15788: else S=S+xyarrow([MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
15789: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]|opt=LOp0);
15790: if(length(Ax)>3){
15791: D=Ax[3];
15792: if(type(D)==1 && D>0){
1.57 takayama 15793: I0=ceil((LY[0]-Ax[1])/D); I1=floor((LY[1]-Ax[1])/D);
1.6 takayama 15794: for(DD=[],I=I0; I<=I1; I++){
15795: if(length(Ax)<5) DD=cons(I*D,DD);
15796: else if(I!=0){
15797: if(Ax[4]==0) DD=cons([I*D,I*D+Ax[1]],DD);
15798: if(Ax[4]==1) DD=cons([I*D,I*D],DD);
15799: if(Ax[4]==2) DD=cons([I*D,I],DD);
15800: }
15801: }
15802: D=DD;
15803: }
15804: if(type(D)==4){
15805: for(;type(D)==4&&D!=[]; D=cdr(D)){
15806: T=car(D);
15807: if(type(T)==4) T=car(T);
15808: X=MulX*(Ax[0]-Orgx); Y=MulY*(T+Ax[1]-Orgy);
15809: if(T!=0){
15810: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp1]]:[],
15811: [X+Adx0,Y],[X+Adx1,Y]],S);
15812: else S=S+xyarrow([X+Adx0,Y],[X+Adx1,Y]|opt=LOp1);
15813: }
15814: if(type(car(D))==4){
15815: if(Proc) S=cons([2,[],[X,Y+Ady0],[[LyOp,D[0][1]]]],S);
15816: else S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]);
15817: }
15818: }
15819: }
15820: }
15821: }
15822: }
15823: if(Proc) return reverse(S);
15824: if(getopt(dviout)!=1) return S;
15825: xyproc(S|dviout=1);
15826: }
15827:
15828: def xyarrow(P,Q)
15829: {
15830: Cmd = ["fill","filldaw","shade","shadedraw","clip ","pattern","path ","node","coordinate"];
15831: if(type(P)<4) return "%\n";
15832: SS=getopt(opt);
15833: if(!TikZ){
15834: if(type(Q)<4) return "";
15835: S="{"+xypos(P)+" \\ar";
15836: if(type(SS)==7) S=S+SS;
15837: return S+" "+xypos(Q)+"};\n";
15838: }
15839: if(type(SS)==4 && length(SS)>1){
15840: if(length(SS)>2) SU=SS[2];
15841: ST=SS[1];
15842: SS=SS[0];
15843: }
15844: if(type(SS)!=7) SS="->";
15845: if(type(ST)!=7) ST=" -- ";
15846: if(type(SU)!=7) SU="";
15847: if(type(S=getopt(cmd))==7) S="\\"+S;
15848: else S="\\draw";
15849: if(type(Q)!=4){
15850: if(Q>0 && Q<=length(Cmd)) S="\\"+Cmd[Q-1]+"";
15851: if(SS!="-") S=S+"["+SS+"]";
15852: if(SU!="") SU="["+SU+"]";
15853: return S+xypos(P)+ST+SU+";\n";
15854: }
1.8 takayama 15855: if(SS!="-"&&SS!="") S=S+"["+SS+"]";
1.6 takayama 15856: if(length(P)<3 && length(Q)<3)
15857: return S+xypos(P)+ST+xypos(Q)+SU+";\n";
15858: if(length(P)==2) P=[P[0],P[1],"","_0"];
15859: else if(length(P)==3 || (length(P)==4 && P[3]==""))
15860: P=[P[0],P[1],P[2],"_0"];
15861: else if(P[3]=="")
15862: P=[P[0],P[1],P[2],"_0",P[4]];
15863: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
15864: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
15865: Q=[Q[0],Q[1],Q[2],"_1"];
15866: else if(Q[3]=="")
15867: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
15868: return S+xypos(P)+" "+xypos(Q)+"("+P[3]+")"+ST+"("+Q[3]+")"+SU+";\n";
15869: }
15870:
15871: def xyarrows(P,Q,R)
15872: {
15873: PQ=newvect(4);
15874: PQ[0]=(type(P[0])!=4)?f2df(P[0]):P[0];
15875: PQ[1]=(type(P[1])!=4)?f2df(P[1]):P[1];
15876: PQ[2]=(type(Q[0])!=4)?f2df(Q[0]):Q[0];
15877: PQ[3]=(type(Q[1])!=4)?f2df(Q[1]):Q[1];
15878: if(type(R[0])!=4) R=[R];
15879: TR=R[0];NX=TR[2];X=X0=TR[0];DX=(TR[1]-TR[0])/NX;
15880: if(length(R)==2){
15881: TR=R[1];NY=TR[2];Y=TR[0];DY=(TR[1]-TR[0])/NY;
15882: }else{
15883: NY=1;Y=DY=0;
15884: }
15885: if(type(L=getopt(abs))!=1) L=0;
15886: if(type(Sc=getopt(scale))!=1) Sc=0;
15887: OL=[];
15888: if(type(Opt=getopt(opt))==7) OL=cons(["opt",Opt],OL);
15889: Tb=str_tb(0,0);
15890: for(J=0;J<NY;Y+=DY,J++){
15891: for(I=0,X=X0;I<NX;I++,X+=DX){
15892: PX=myf2eval(PQ[0],X,Y);PY=myf2eval(PQ[1],X,Y);
15893: VX=myf2eval(PQ[2],X,Y);VY=myf2eval(PQ[3],X,Y);
15894: if(L>0){
15895: C=dnorm([VX,VY]);
15896: if(C!=0){
15897: VX*=L/C;VY*=L/C;
15898: }
15899: }
15900: if(Sc){
15901: VX*=Sc;VY*=Sc;
15902: }
15903: if(VX||VY) str_tb(xyarrow([PX,PY],[PX+VX,PY+VY]|optilon_list=OL),Tb);
15904: }
15905: }
15906: return str_tb(0,Tb);
15907: }
15908:
15909: def polroots(L,V)
15910: {
15911: INIT=1;
15912: if(type(CF=getopt(comp))!=1) CF=0;
15913: OL=getopt();
15914: if(CF>32){
15915: CF-=64;
15916: INIT=0;
15917: }else OL=cons(["comp",CF+64],delopt(OL,"comp"));
15918: if(type(V)==4&&length(V)==1){
15919: L=L[0];V=V[0];
15920: }
15921: Lim=Lim2=[];
15922: if(type(L)<4){
15923: if(type(Lim=getopt(lim))==4){
1.17 takayama 15924: if(type(Lim[0])!=4){
15925: if(!isvar(Lim[0])) Lim=cons(V,[Lim]);
15926: Lim=[Lim];
15927: }
15928: if(!isvar(Lim[0][0])) Lim=[cons(V,Lim)];
1.6 takayama 15929: Lim=delopt(Lim,V|inv=1);
15930: if(Lim!=[]){
15931: Lim=Lim[0];
15932: if(length(Lim)==3) Lim2=Lim[2];
15933: Lim=Lim[1];
15934: }
15935: }else{
15936: Lim=Lim2=[];
15937: }
15938: if((CF==-2||CF==-1||CF==2)&&iscoef(L,os_md.israt)){ /* Rat+Comp, Rat+Real or Rat */
15939: S=(CF==-1)?getroot(L,V|cpx=1):getroot(L,V);
15940: for(RR=[],F=x;S!=[];S=cdr(S)){
15941: if(findin(V,vars(C=car(S)))<0){ /* Rational solution */
15942: if(type(C)<2){
15943: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15944: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15945: }
15946: if(F!=C) RR=cons(F=C,RR);
15947: }else if(CF<0){ /* Irrational solution */
15948: if((R=pari(roots,mysubst(C,[V,x])))!=0){
15949: for(R=vtol(R);R!=[];R=cdr(R))
15950: if((C=car(R))!=F && ntype(C)<CF+6){
15951: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15952: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15953: RR=cons(F=C,RR);
15954: }
15955: }
15956: }
15957: }
15958: return qsort(RR);
15959: }
15960: R=pari(roots,subst(L,V,x));
15961: if(R==0){
15962: R=[0];
15963: if(CF==1){
15964: for(R=[0],I=mydeg(L,V);I>1; I--)
15965: R=cons(0,R);
15966: }
15967: return R;
15968: }
15969: if(CF==1){ /* Complex */
15970: if(Lim==[]&&Lim2==[]) return vtol(R);
15971: for(L=[],I=length(R)-1;I>=0;I--){
15972: C=R[I];
15973: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
15974: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
15975: L=cons(C,L);
15976: }
15977: return L;
15978: }
15979: for(L=[],F=x,I=length(R)-1;I>=0;I--){ /* Real */
15980: if(ntype(R[I])<4 && F!=R[I]){
15981: if(Lim!=[] && (R[I]<Lim[0]||R[I]>Lim[1])) continue;
15982: L=cons(F=R[I],L);
15983: }
15984: }
15985: return qsort(L);
15986: }
15987: if(SS==0&&INIT==1){
15988: SS=polroots(L,V|option_list=OL);
15989: if(SS!=0) return SS;
1.18 takayama 15990: for(C=0;SS==0&&C<5;C++){
1.6 takayama 15991: I=(C==0)?1:(iand(random(),0xff)-0x80);
15992: for(LL=[],K=length(L)-1;K>=0;K--){
15993: for(Q=0,J=length(L)-1;J>=0;J--)
15994: Q+=L[J]*(I+K)^J;
15995: LL=cons(Q,LL);
15996: }
15997: SS=polroots(LL,V|option_list=OL);
15998: if(SS!=0) return SS;
15999: }
16000: return SS;
16001: }
16002: C=2^(-32);
16003: if(type(getopt(err))==1) C=err;
16004: if((N=length(V))!=length(L)) return [];
16005: if(N==1) return polroots(L[0],V[0]|option_list=OL);
16006: for(L1=[],I=1;I<N;I++){
16007: Res=res(V[0],L[I-1],L[I]);
16008: if(type(Res)<2) return Res;
16009: L1=cons(res(V[0],L[I-1],L[I]),L1);
16010: }
16011: R=polroots(L1,V1=cdr(V)|option_list=OL);
16012: if(type(R)<2) return R;
16013: for(SS=[];R!=[];R=cdr(R)){
16014: RS=(N==2)?[car(R)]:car(R);
16015: for(I=0,L0=L[0];I<N-1;I++) L0=mysubst(L0,[V1[I],RS[I]]);
1.17 takayama 16016: if(L0==0) return 0;
1.6 takayama 16017: S0=polroots(L0,V[0]|option_list=OL);
16018: if(type(S0)<2) return S0;
16019: for(S=S0;S!=[];S=cdr(S)){
16020: S0=cons(car(S),RS);
16021: for(LT=cdr(L);LT!=[];LT=cdr(LT)){
16022: for(I=0,TV=car(LT);I<N;I++) TV=mysubst(TV,[V[I],S0[I]]);
16023: if(abs(TV)>C) break;
16024: }
16025: if(LT==[]) SS=cons(S0,SS);
16026: }
16027: }
16028: return reverse(SS);
16029: }
16030:
1.71 takayama 16031: def lsub(P)
16032: {
16033: if((T=type(P[0]))==4){
16034: Q=reverse(P[1]);P=reverse(P[0]);
16035: for(R=[];P!=[];P=cdr(P),Q=cdr(Q)) R=cons(car(Q)-car(P),R);
16036: return R;
16037: }else if(T==5){
16038: L=length(P[0]);Q=P[1];P=P[0];
16039: R=newvect(L);
16040: for(V=[],L--;L>=0;L--) R[L]=Q[L]-P[L];
16041: return R;
16042: }
16043: return P;
16044: }
16045:
16046: def dext(P,Q)
16047: {
16048: P=lsub(P);Q=lsub(Q);
16049: return P[0]*Q[1]-P[1]*Q[0];
16050: }
16051:
1.83 ! takayama 16052: def ptinversion(P)
! 16053: {
! 16054: if(type(P)==4&&type(P[1])==4){
! 16055: for(R=[];P!=[];P=cdr(P))
! 16056: R=cons(ptinversion(car(P)|option_list=getopt()),R);
! 16057: return reverse(R);
! 16058: }
! 16059: if(type(V=getopt(org))!=0) V=[0,0];
! 16060: if(P==[0,0]) return 0;
! 16061: if(type(P[0])==4){
! 16062: R=P[1];P=P[0];
! 16063: }
! 16064: X=P[0]-V[0];Y=P[1]-V[1];N=X^2+Y^2;
! 16065: if(getopt(bar)==1) S=1;
! 16066: else S=-1;
! 16067: if(!R){
! 16068: if(!N) return 0;
! 16069: return [X/N+V[0],S*Y/N+V[1]];
! 16070: }
! 16071: N-=R^2;
! 16072: if(!N){
! 16073: if(X+R!=0) X0=X+R;
! 16074: else X0=X-R;
! 16075: S=[];
! 16076: S=cons(ptinversion([X0,Y]|option_list=getopt()),S);
! 16077: if(Y+R!=0) Y0=Y+R;
! 16078: else Y0=Y-R;
! 16079: return cons(ptinversion([X,Y0]|option_list=getopt()),S);
! 16080: }
! 16081: return [[X/N+V[0],S*Y/N+V[1]],R/N];
! 16082: }
! 16083:
1.6 takayama 16084: def ptcommon(X,Y)
16085: {
16086: if(length(X)!=2 || length(Y)!=2) return 0;
16087: if(type(X[1])==4){ /* X is a line */
16088: if((In=getopt(in))==-1||In==-2||In==-3){
16089: X0=(X[0][0]+X[1][0])/2;X1=(X[0][1]+X[1][1])/2;
16090: X=[[X0,X1],[X0+X[1][1]-X[0][1],X1-X[1][0]+X[0][0]]];
16091: if(In==-1&&type(Y[1])==4) return ptcommon(Y,X|in=-2);
16092: /* for the second line */
16093: if(In==-3) In=1;
16094: else In=0;
16095: }else if(In==2||In==3){
16096: X=(X[1][0]-X[0][0])+(X[1][1]-X[0][1])*@i;
16097: if(X==0) return 0;
16098: Y=(Y[1][0]-Y[0][0])+(Y[1][1]-Y[0][1])*@i;
16099: X=myarg(Y/X);
16100: return (In==2)?X:(X*180/deval(@pi));
16101: }else if(In!=1) In=0;
16102: if(type(Y[0])<=3){
16103: if(In==1){
16104: return [(Y[1]*X[0][0]+Y[0]*X[1][0])/(Y[0]+Y[1]),
16105: (Y[1]*X[0][1]+Y[0]*X[1][1])/(Y[0]+Y[1])];
16106: }
16107: XX=X[1][0]-X[0][0];YY=X[1][1]-X[0][1];
16108: Arg=(length(Y)<2)?0:Y[1];
16109: Arg=deval(Arg);
16110: if(Arg!=0){
16111: S=dcos(Arg)*XX-dsin(Arg)*YY;
16112: YY=dsin(Arg)*XX+dcos(Arg)*YY;
16113: XX=S;
16114: }
16115: S=dnorm([XX,YY]);
16116: if(S!=0){
16117: XX*=Y[0]/S;YY*=Y[0]/S;
16118: }
16119: return [X[1][0]+XX,X[1][1]+YY];
16120: }
16121: S=[X[0][0]+(X[1][0]-X[0][0])*x_,X[0][1]+(X[1][1]-X[0][1])*x_];
16122: if(type(Y[1])==4){ /* Y is a line */
16123: T=[Y[0][0]+(Y[1][0]-Y[0][0])*y_-S[0],
16124: Y[0][1]+(Y[1][1]-Y[0][1])*y_-S[1]];
16125: R=lsol(T,[x_,y_]);
1.71 takayama 16126: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
16127: /* unique sol of parameters */
16128: if(In && (R[0][1]<0||R[0][1]>1||R[1][1]<0||R[1][1]>1) ) return 0;
16129: return subst(S,x_,R[0][1],y_,R[1][1]);
1.6 takayama 16130: }
1.71 takayama 16131: if((type(R[0])>0&&type(R[0])<4)||(type(R[1])>0&&type(R[1])<4)) return 0; /* no solution */
16132: F=0;
16133: if(X[0]==X[1]) F=1;
16134: else if(Y[0]==Y[1]) F=2;
16135: if(!In){
16136: if(!F) return 1;
16137: else if(F==1) return X[0];
16138: else if(F==2) return Y[0];
16139: }
16140: X0=X[0];X1=X[1];
16141: if(X0>X1){R=X0;X0=X1;X1=R;}
16142: Y0=Y[0];Y1=Y[1];
16143: if(Y0>Y1){R=Y0;Y0=Y1;Y1=R;}
16144: if(X0<Y0) X0=Y0;
16145: if(Y0>Y1) X1=Y1;
16146: if(X0>X1) return 0;
16147: if(X0<X1) return [X0,X1];
16148: return X0;
1.6 takayama 16149: }else if(Y[1]==0){ /* orth */
16150: T=[Y[0][0]+(X[1][1]-X[0][1])*y_-S[0],
16151: Y[0][1]-(X[1][0]-X[0][0])*y_-S[1]];
16152: R=lsol(T,[x_,y_]);
16153: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
16154: if(!In||(R[0][1]>=0&&R[0][1]<=1))
16155: return subst(S,x_,R[0][1],y_,R[1][1]);
16156: }
16157: return (X[0]==X[1])?0:1;
16158: }else if(type(Y[1])==1 && Y[1]>0){ /* circle */
16159: T=(S[0]-Y[0][0])^2+(S[1]-Y[0][1])^2-Y[1]^2;
16160: D=mycoef(T,1,x_)^2-4*mycoef(T,0,x_)*mycoef(T,2,x_);
16161: if(D==0){
16162: V=mycoef(T,1,x_)/(2*mycoef(T,2,x_));
16163: if(!in||(V>=0&&V<=1)) return [subst(S,x_,V)];
16164: }
16165: else if((type(D)==1&&D>0)){
16166: D=dsqrt(D);
16167: V=-(mycoef(T,1,x_)+D)/(2*mycoef(T,2,x_));
16168: if(!In||(V>=0&&V<=1)) L=[subst(S,x_,V)];
16169: else L=[];
16170: V=(D-mycoef(T,1,x_))/(2*mycoef(T,2,x_));
16171: if(!In||(V>=0&&V<=1)) L=cons(subst(S,x_,V),L);
16172: if(length(L)>0) return L;
16173: }
16174: }
16175: return 0;
16176: }
16177: if(type(Y[1])==4 || X[1]==0) return ptcommon(Y,X);
16178: /* X is a circle */
16179: if(Y[1]==0){ /* tangent line */
16180: if(Y[0][0]==X[0][0]+X[1] || Y[0][0]==X[0][0]-X[1]) L=[[Y[0][0],X[0][1]]];
16181: else L=[];
16182: P=(Y[0][0]+x_-X[0][0])^2+(Y[0][1]+x_*y_-X[0][1])^2-X[1]^2;
16183: Q=mycoef(P,1,x_)^2-4*mycoef(P,2,x_)*mycoef(P,0,x_);
16184: for(R=polroots(Q,y_);R!=[];R=cdr(R)){
16185: X0=-subst(mycoef(P,1,x_)/(2*mycoef(P,2,x_)),y_,car(R));
16186: L=cons([Y[0][0]+X0,Y[0][1]+car(R)*X0],L);
16187: }
16188: }else{ /* Y is a circle */
16189: P=(x_-X[0][0])^2+(y_-X[0][1])^2-X[1]^2;
16190: Q=(x_-Y[0][0])^2+(y_-Y[0][1])^2-Y[1]^2;
16191: V=(X[0][0]!=Y[0][0])?[x_,y_]:[y_,x_];
16192: R=subst(P,V[0],T=lsol(P-Q,V[0]));
16193: if(type(T[0])<4) return (T[0]==0)?1:0;
16194: S=polroots(R,V[1]);
16195: for(L=[];S!=[];S=cdr(S)){
16196: R=subst(T,V[1],car(S));
16197: if(V[0]==x_) L=cons([R,car(S)],L);
16198: else L=cons([S,R],L);
16199: }
16200: }
16201: if(length(L)!=0) return L;
16202: return 0;
16203: }
16204:
1.71 takayama 16205:
16206: def ptcontain(P,L)
16207: {
16208: if(type(car(P))==4){
16209: if((C=getopt(common))!=1) C=0;
16210: if((F0=ptcontain(P[0])&&!C)) return F0;
16211: if((F1=ptcontain(P[1])&&!C)) return F1;
16212: if(F0&&F1) return P; /* include */
16213: L=cons(L[2],L); /* outside part exists */
16214: for(I=1,R=[];I<4;I++,L=cdr(L)){
16215: if(!(F[I]=ptcotain(P,[L[0],L[1]]))){
16216: if(C) continue;
16217: return -1;
16218: }
16219: if(type(F[I])==4&&length(F[I])==2) /* infinite points */
16220: return F[I];
16221: else R=cons(F[I],R);
16222: }
16223: if(R==[]) return 0; /* no intersection */
16224: if(F1==1) return [P[0],car(R)];
16225: if(F2==1) return [P[1],car(R)];
16226: if(length(R)>1 && R[0]==R[1]) R=cdr(R);
16227: return R;
16228: }
16229: if(dext([L[0],L[1]],[L[0],L[2]])<0) L=[L[0],L[2],L[1]];
16230: L=cons(L[2],L);
16231: for(I=F=1;I<4;I++,L=cdr(L)){
16232: if((V=dext([L[0],L[1]],[L[0],P])) < 0) return 0;
16233: if(!V) F++;
16234: }
16235: return F;
16236: }
16237:
1.6 takayama 16238: def tobezier(L)
16239: {
16240: if((Div=getopt(div))==1||Div==2){
16241: if(length(L)!=4) return [tobezier(L|inv=[0,1/2]),tobezier(L|inv=[1/2,1])];
16242: if(type(L)==4) L=ltov(L);
16243: if(type(L[0])==4)
16244: L=[ltov(L[0]),ltov(L[1]),ltov(L[2]),ltov(L[3])];
16245: S=[(L[0]+3*L[1]+3*L[2]+L[3])/8];
16246: T=[L[3]];
16247: S=cons((L[0]+2*L[1]+L[2])/4,S);
16248: T=cons((L[2]+L[3])/2,T);
16249: S=cons((L[0]+L[1])/2,S);
16250: T=cons((L[1]+2*L[2]+L[3])/4,T);
16251: S=cons(L[0],S);
16252: T=cons((L[0]+3*L[1]+3*L[2]+L[3])/8,T);
16253: return [S,T];
16254: }
16255: if(Div>2&&Div<257){
16256: L=tobezier(L);
16257: for(R=[],I=Div-1;I>=0;I--)
16258: R=cons(tobezier(L|inv=[I/Div,(I+1)/Div]),R);
16259: return R;
16260: }
16261: if((V=getopt(inv))==1 || type(V)>3){
16262: if(type(L[0])>3 && type(V)>3) L=tobezier(L);
16263: if(type(V)>3 && length(V)>2) V2=V[2];
16264: if(type(V2)!=2) V2=t;
16265: if(type(V)>3) L=subst(L,V2,(V[1]-V[0])*V2+V[0]);
16266: N=mydeg(L,V2);
16267: for(R=[],I=0;I<=N;I++){
16268: RT=mycoef(L,I,V2);
16269: R=cons(RT/binom(N,I),R);
16270: L-=RT*V2^I*(1-V2)^(N-I);
16271: }
16272: return reverse(R);
16273: };
16274: N=length(L)-1;
16275: V=newvect(2);
16276: for(I=0;I<=N;I++,L=cdr(L)){
16277: if(type(X=car(L))==4) X=ltov(X);
16278: V+=X*binom(N,I)*t^I*(1-t)^(N-I);
16279: }
16280: return V;
16281: }
16282:
16283: def cutf(F,X,VV)
16284: {
16285: if(type(car(V=VV))==2){
16286: Y=[car(V),X];
16287: V=cdr(V);
16288: }else Y=X;
16289: if(type(X)>1){
16290: Y=(type(Y)==4)?Y[0]:x;
16291: V1=makenewv(F);
16292: if(X==Y||Y==x){
16293: V2=makenewv([F,V1]);
16294: F=mysubst(F,[Y,V2]);
16295: V=cons(V2,V);
16296: }
16297: return [V1,[V1,os_md.cutf,[F],X,[V]]];
16298: }
16299: if(car(V)!=[] && X<car(V)[0]) return myfeval(car(V)[1],Y);
16300: for(V=cdr(V); ;V=R){
16301: if((R=cdr(V))==[]){
16302: if(car(V)!=[] && car(V)[0]<X) return myfeval(car(V)[1],Y);
16303: return myfeval(F,Y);
16304: }
1.20 takayama 16305: if(car(V)==[]||X>car(V)[0]) continue;
1.6 takayama 16306: if(X==car(V)[0]) return car(V)[1];
16307: return myfeval(F,Y);
16308: }
16309: }
16310:
1.12 takayama 16311: def fsum(F,L)
1.6 takayama 16312: {
1.12 takayama 16313: if(getopt(df)==1){
16314: F=f2df(F);
16315: }else Sub=getopt(subst);
1.6 takayama 16316: if(type(L[0])==2){
16317: X=L[0];
16318: L=cdr(L);
16319: }else X=0;
16320: V=(length(L)>2)?L[2]:1;
16321: for(R=0,I=L[0];;I+=V){
16322: if(V==0||(I-L[1])*V>0) return R;
1.12 takayama 16323: R+=(Sub==1)?subst(F,X?X:x,I):os_md.myfeval(F,X?[X,I]:I);
1.6 takayama 16324: }
16325: }
16326:
16327: def periodicf(F,L,X)
16328: {
16329: if(type(L)==4) L=[eval(L[0]),eval(L[1])];
16330: else L=eval(L);
16331: if(isvar(X)){
1.20 takayama 16332: Y=makenewv([X,F]);
16333: Z=makenewv([X,Y,F]);
1.16 takayama 16334: return [Z,[Z,os_md.periodicf,[mysubst(F,[x,Y])],(type(L)==4)?[L]:L,[[Y,X]]]];
16335: }
16336: if(type(X)==4){
16337: V=X[0];
16338: X=X[1];
16339: }else V=x;
16340: if(type(F)==5){
16341: X=eval(X);
16342: return myfeval(F[floor(X/L)%length(F)],[V,X-floor(X/L)*L]);
1.6 takayama 16343: }
16344: if(type(L)==4){
16345: X-=floor((X-L[0])/(L[1]-L[0]))*(L[1]-L[0]);
16346: return myfeval(F,[V,X]);
16347: }
16348: }
16349:
16350: def cmpf(X)
16351: {
16352: if(type(X)>3){
16353: if(type(L)==7) return [S_Fc,Dx,S_Ic,S_Ec,S_EC,S_Lc];
16354: S_Lc=0;
16355: if(type(S_Fc=X[0])!=4) S_Fc=f2df(S_Fc);
16356: S_Ic=X[1];
16357: if(length(S_Ic)>2){
16358: S_Fc=mysubst(S_Fc,[S_Ic[0],x]);
16359: S_Ic=cdr(S_Ic);
16360: }
16361: S_Dc=(type(S_Ic[0])==7)?1:0;
16362: if(type(S_Ic[1])==7) S_Dc=ior(S_Dc,2);
16363: if(type(S_Ec=getopt(exp))!=1) S_Ec=0;
16364: if(S_Ec<=0){
16365: S_EC=-S_Ec;
16366: if(S_EC==0) S_EC=1;
16367: if(S_Dc==3) S_EC*=2;
16368: else S_EC/=4;
16369: if(type(F=X[0])==3&&vars(F)==[x]&&(D=deg(nm(F),x))==deg(dn(F),x)-2){
16370: S_Lc=S_EC*coef(nm(F),D,x)/coef(dn(F),D+2,x);
16371: }
16372: }else{
16373: S_EC=S_Ec;
16374: if(S_Dc==3) S_EC*=12;
16375: else S_EC/=6;
16376: }
16377: if(type(S_Fc)==3) S_Fc=red(S_Fc);
16378: S_EC=1/S_EC;
16379: return [z_,[z_,os_md.cmpf,x]];
16380: }
16381: if(X<=0 && iand(S_Dc,1)) return S_Lc;
16382: if(X>=1 && iand(S_Dc,2)) return S_Lc;
16383: if(S_Dc==3){
16384: if(S_Ec>0){
16385: Y0=dexp(1/X)*S_EC;
16386: Y1=dexp(1/(1-X))*S_EC;
16387: return myfeval(S_Fc,Y1-Y0)*(Y0/X^2+Y1/(1-X)^2);
16388: }
16389: return myfeval(S_Fc,S_EC/(1-X)-S_EC/X)*(S_EC/(1-X)^2+S_EC/X^2);
16390: }
16391: if(S_Dc==1){
16392: if(S_Ec>0){
16393: Y=dexp(1-1/X);
16394: R=myfeval(S_Fc,S_EC*(Y-1)+I[1])*Y;
16395: }
16396: else R=myfeval(S_Fc,I[1]+(1-1/X)*S_EC);
16397: return R*S_EC/X^2;
16398: }
16399: if(S_Dc==2){
16400: if(S_Ec>0){
16401: Y=dexp(X/(1-X));
16402: R=myfeval(S_Fc,S_EC*(Y-1)+S_Ic[0])*Y;
16403: }else R=myfeval(S_Fc,S_EC*X/(1-X)+S_Ic[0]);
16404: return R*S_EC/(1-X)^2;
16405: }
16406: X=S_Ic[0]+(S_Ic[1]-S_Ic[0])*X;
16407: return myfeval(S_Fc,X)/(S_Ic[1]-Ic[0]);
16408: }
16409:
16410: def fresidue(P,Q)
16411: {
16412: if(iscoef(Q,os_md.israt)) S=fctr(Q);
16413: else S=[[Q,1]];
16414: for(R=[];S!=[];S=cdr(S)){
16415: T=car(S);
16416: if((D=mydeg(T[0],z))==0) continue;
16417: L=[];
16418: if(iscoef(T[0],os_md.iscrat)) L=getroot(T[0],z|cpx=2);
16419: if(findin(z,vars(L))>=0) L=[];
16420: if(L==[]) L=polroots(T[0],z|comp=-1);
16421: for(;L!=[];L=cdr(L)){
16422: QQ=Q;
16423: for(I=T[1]; I>1;I--) QQ=mydiff(QQ,z);
16424: for(U=0,W=I=T[1];I>0;I--,W++){
16425: QQ=diff(QQ,z);
16426: U+=subst(QQ,z,L[0])*(z-L[0])^(W-T[1])/fac(W);
16427: }
16428: UD=mydiff(U,z);
16429: for(I=T[1],K=1,PP=P; I>1;I--,K++)
16430: PP=diff(PP,z)*U-K*PP*UD;
16431: QQ=subst(PP,z,L[0])/subst(U,z,L[0])^K;
16432: /* if(D==2) QQ=sqrt2rat(QQ); */
16433: R=cons([L[0],sqrt2rat(QQ)],R);
16434: }
16435: }
16436: if(type(L=getopt(cond))==4){
16437: for(S=[];R!=[];R=cdr(R)){
16438: Z=car(R);
16439: for(LL=L;LL!=[];LL=cdr(LL)){
16440: X=real(car(Z));Y=imag(car(Z));
16441: if(myf3eval(car(LL),X,Y,car(Z))<=0) break;
16442: }
16443: if(LL==[]) S=cons(Z,S);
16444: }
16445: R=reverse(S);
16446: }
16447: if((Sum=getopt(sum))==1||Sum==2){
16448: for(S=0;R!=[];R=cdr(R)) S+=car(R)[1];
16449: if(Sum==2) S*=2*@pi*@i;
16450: return sqrt2rat(S);
16451: }
16452: return R;
16453: }
16454:
16455: def fint(F,D,V)
16456: {
16457: if(((L=length(V))==2 || (L==3&&isvar(V[0])<3))
16458: && (type(V[L-1])==7||(type(V[L-1])<3&&type(eval(V[L-1]))<2)))
16459: /* real integral */
16460: return areabezier([F,D,V]|option_list=getopt());
16461: /* complex integral */
16462: if(L>1&&type(V[1])==4&&type(V[1][1])<4){
16463: if(type(V[0])==4&&type(V[0][0])<2){
16464: for(R=[],VT=car(V),VV=cdr(V);VV!=[];VV=cdr(VV),VT=VU){
16465: if((VU=car(VV))==-1) VU=car(V);
16466: R=cons([ptcommon([VT,VU],[t,1-t]|in=1),[0,1]],R);
16467: }
16468: V=reverse(R);
16469: }
16470: else if(L==2) V=[V];
16471: }
16472: Opt=cons(["cpx",1],getopt());
16473: for(R=0;V!=[];V=cdr(V)){
16474: VT=car(V);
16475: X=car(VT)[0];XD=red(diff(X,t));
16476: Y=car(VT)[1];YD=red(diff(Y,t));
16477: F=mysubst(F,[[x,X],[y,Y],[z,X+@i*Y]]);
16478: if(type(F)==4)
16479: FF=cons(F[0]*(XD+@i*YD),cdr(F));
16480: else FF=red(F*(XD+@i*YD));
16481: R+=areabezier([FF,D,cons(t,VT[1])]|option_list=Opt);
16482: }
16483: return R;
16484: }
16485:
16486: def areabezier(V)
16487: {
16488: if(getopt(cpx)==1){
16489: Opt=delopt(getopt(),"cpx");
16490: F=V[0];
16491: if(!isvar(Var=V[2][0])) Var=x;
16492: if(type(F)==3 && vars(F)==[Var] && imag(dn(F))!=0){
16493: F=(nm(F)*conj(dn(F)))/(dn(F)*conj(dn(F)));
16494: V0=red(real(nm(F))/dn(F));
16495: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
16496: V0=red(imag(nm(F))/dn(F));
16497: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
16498: }
16499: if(getopt(Acc)!=1) F=f2df(F);
16500: V0=compdf([o,[o,real,o_]],o_,F);
16501: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
16502: V0=compdf([o,[o,imag,o_]],o_,F);
16503: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
16504: }
16505: if(type(V[0])!=4 || vars(V[0][0])!=0){
16506: Mx=[-2.0^(512),2.0^(512)];
16507: I=length(V[2]);
16508: if(type(V[2][I-1])==7||type(V[2][I-2])==7){ /* infinite interval */
16509: if(type(Ec=getopt(exp))==1) R=cmpf([V[0],V[2]]|exp=Ec);
16510: else R=cmpf([V[0],V[2]]);
16511: V=[R,V[1],[0,1]];
16512: }
16513: if(type((Int=getopt(int)))==1 && type(V[0])<4 && (V1=V[1])>=0){
16514: if(Int==2&&iand(V1,1)) V1++;
16515: if(!V1) V1=32;
16516: Opt=cons(["raw",1],getopt());
16517: W=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
16518: SS=W[0][1];
16519: for(S0=S1=0,I=0,L=W;L!=[] && I<=V1;I++, L=cdr(L)){
16520: if(iand(I,1)) S1+=car(L)[1];
16521: else S0+=car(L)[1];
16522: if (I==V1) SS+=car(L)[1];
16523: }
16524: VV=deval(V[2][1]-V[2][0]);
16525: if(Int==2)
16526: return (2*S0+4*S1-SS)*VV/(3*V1);
16527: else
16528: return (2*S0+2*S1-SS)*VV/(2*V1);
16529: }
16530: Opt=cons(["opt",0],getopt());
16531: V=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
16532: }
16533: if(type(V[0][0])!=4) V=os_md.lbezier(V);
16534: for(S=0; V!=[]; V=cdr(V)){
16535: B=tobezier(car(V));
16536: P=intpoly(B[1]*diff(B[0],t),t);
16537: S+=mysubst(P,[t,1]);
16538: }
16539: return S;
16540: }
16541:
16542: def velbezier(V,L)
16543: {
16544: if(L==0) L=[t,0,1];
16545: else L=[(length(L)==3)?L[2]:t,L[0],L[1]];
16546: for(R=[],II=length(V)-1;II>=0;II--){
16547: S=fmmx(diff(V[II],L[0]|dif=1),L|dif=1);
16548: for(U=0;S!=[];S=cdr(S)) if((T=abs(car(S)[1]))>U) U=T;
16549: R=cons(U,R);
16550: }
16551: return R;
16552: }
16553:
16554: def ptbezier(V,L)
16555: {
16556: if(type(V[0])==4&&type(V[0][0])!=4) V=lbezier(V);
16557: K=length(V);
16558: if(type(L)<2){
16559: if(L<0) return K;
16560: if(L>=K-1) L=[K-1,1];
16561: else{
16562: L0=floor(L);
16563: if(L0>=K-1) L0=K-1;
16564: L=[L0,L-L0];
16565: }
16566: }
16567: if(L[0]>=0) B=V[L[0]];
16568: else B=V[K+L[0]];
16569: B=tobezier(B);
16570: BB=[diff(B[0],t),diff(B[1],t)];
16571: return [subst(B,t,L[1]),subst(BB,t,L[1])];
16572: }
16573:
1.70 takayama 16574: /*
16575: def isroot(P,Q,I)
16576: {
16577: if(subst(P,X,X0=I[0])*subst(P,X,I[1])<=0) return 1;
16578: XM=(I[1]+I[0])/2;W=XM-X0;
16579: if(W<0) W=-W;
16580: X=var(P);
16581: if(!Q) Q=diff(P,X);
16582: Q=subst(Q,X,X+I2);D=deg(Q,X);
16583: for(M=0,P=1,I=deg(Q,X);I<=D;I++){
16584: V=coef(Q,I,X);
16585: M+=(V<0?-V:V)*P;
16586: P*=W;
16587: }
16588: V=subst(P,X,X0);
16589: if(V<0) V=-V;
16590: return (V-M<=0) 2:0;
16591: }
16592: */
16593:
16594: def sgnstrum(L,V)
16595: {
16596: X=var(car(L));
16597: if(X==0) X=var(L[1]);
16598: for(F=N=0;L!=[];L=cdr(L)){
16599: P=car(L);
16600: if(type(V)==7){
16601: C=coef(P,D=deg(P,X),X);
16602: if(V=="-"&&iand(D,1)) C=-C;
16603: }else C=subst(P,X,V);
16604: if(!C) continue;
16605: if(C*F<0) N++;
16606: F=C;
16607: }
16608: return N;
16609: }
16610:
16611: def polstrum(P)
16612: {
16613: X=vars(P0=P);
16614: if(!length(X)) return [];
16615: X=car(X);
16616: if(isfctr(P)){
16617: D=gcd(P,Q=diff(P,X));
16618: P=sdiv(P,D);
16619: if(getopt(mul)==1&&type(getopt(num))<0)
16620: return append(polstrum(D|mul=1),[P]);
16621: }
16622: D=deg(P,X);
16623: P=P/coef(P,deg(P,X),X);
16624: Q=diff(P,X)/D;
16625: for(L=[Q,P];D>0;){
16626: R=urem(P,Q);
16627: if((D=deg(R,X))<0) break;
16628: C=coef(R,D,X);
16629: if(C>0) C=-C;
16630: R/=C;
16631: L=cons(R,L);
16632: P=Q;Q=R;
16633: }
16634: if(type(N=getopt(num))>0){
16635: if(getopt(mul)!=1){
16636: if(type(N)==1) N=["-","+"];
16637: return sgnstrum(L,N[0])-sgnstrum(L,N[1]);
16638: }
16639: if(!isfctr(P0)) return -1;
16640: R=polstrum(P0|mul=1);
16641: for(C=0;R!=[];R=cdr(R)) C+=polstrum(car(R)|num=N);
16642: return C;
16643: }
16644: return reverse(L);
16645: }
16646:
1.71 takayama 16647: def iceil(X)
16648: {
16649: S=(X>0)?1:-1;
16650: X*=S;
16651: if(X>1) X=ceil(X);
16652: else if(X>1/2) X=1;
16653: else if(X) X=1/floor(1/X);
16654: return S*X;
16655: }
16656:
1.70 takayama 16657: def polradiusroot(P)
16658: {
16659: X=var(P);D=deg(P,X);
16660: if(D<1) return -1;
16661: C=coef(P,D,X);
16662: P/=-C;
16663: Int=getopt(int);
16664: if(getopt(comp)==1){
16665: for(ND=0,TD=0;TD<D;TD++) if(coef(P,TD,X)!=0) ND++;
16666: for(V=0,TD=0;TD<D;TD++){
16667: TV=eval((abs(coef(P,TD,X))*ND)^(1/(D-TD)));
16668: if(V<TV) V=TV;
16669: }
1.71 takayama 16670: return (Int==1)? iceil(X):X;
1.70 takayama 16671: }
16672: for(N0=N1=0,TD=0;TD<D;TD++){
16673: if(!(C=coef(P,TD,X))) continue;
16674: if(C>0){
16675: N2++;
16676: if(!iand(D-TD,1)) N1++;
16677: }else if(iand(D-TD,1)) N1++;
16678: }
16679: for(V1=V2=0,TD=0;TD<D;TD++){
16680: if(!(C=C1=coef(P,TD,X))) continue;
16681: if(C>0){
16682: TV=eval((C*N2)^(1/(D-TD)));
16683: if(V2<TV) V2=TV;
16684: }
16685: if(iand(D-TD,1)) C=-C;
16686: if(C>0){
16687: TV=eval((C*N1)^(1/(D-TD)));
16688: if(V1<TV) V1=TV;
16689: }
16690: }
1.71 takayama 16691: return Int?[-iceil(V1),iceil(V2)]:[-V1,V2];
1.70 takayama 16692: }
16693:
1.71 takayama 16694: /* step, num, strum */
1.70 takayama 16695: def polrealroots(P)
16696: {
16697: if(type(MC=getopt(step))==4){
16698: MC1=MC[1];MC=car(MC);
16699: }else if(isint(MC)&&MC>1&&MC<10001) MC1=MC;
1.71 takayama 16700: else MC1=MC=32;
16701: if(type(I=getopt(in))!=4){
16702: I=polradiusroot(P);
1.70 takayama 16703: W=(I[1]-I[0])/1024;
16704: I=[I[0]-W,I[1]+W];
16705: }
16706: if(type(L=type(getopt(strum)))!=4) L=polstrum(P);
16707: N0=sgnstrum(L,I[0]);N1=sgnstrum(L,I[1]);
16708: P=car(L);X=var(P);
1.71 takayama 16709: if(N0<=N1) return []; /* [L,I,N0,N1]; */
1.70 takayama 16710: LT=[[0,I[0],I[1],N0,N1]];R=[];
1.71 takayama 16711: Z=eval(exp(0));
1.70 takayama 16712: while(LT!=[]){
16713: T=car(LT);LT=cdr(LT);
16714: C=T[0];X0=T[1];X1=T[2];N0=T[3];N1=T[4];
16715: if(N0<=N1)continue;
16716: if(N0==N1+1){
1.71 takayama 16717: V0=subst(P,X,X0);
16718: V1=subst(P,X,X1);
1.70 takayama 16719: while(C++<MC1){
1.71 takayama 16720: V2=subst(P,X,X2=(X0+X1)/2*Z);
1.70 takayama 16721: if((V0>0&&V2>0)||(V0<0&&V2<0)) X0=X2;
16722: else X1=X2;
16723: }
16724: R=cons([X0,X1,1],R);
16725: continue;
16726: }
16727: while(++C<MC){
1.71 takayama 16728: N2=sgnstrum(L,X2=(X0+X1)/2*Z);
1.70 takayama 16729: if(N0>N2){
1.71 takayama 16730: if(N2>N1) LT=cons([C,X2,X1,N2,N1],LT);
1.70 takayama 16731: X1=X2;
16732: N1=N2;
16733: if(N0==N1+1){
16734: LT=cons([C,X0,X1,N0,N1],LT);
1.71 takayama 16735: C=MC+1;
1.70 takayama 16736: }
16737: }else{
16738: X0=X2;
16739: N0=N2;
16740: }
16741: }
1.71 takayama 16742: if(C!=MC+2) R=cons([X0,X1,N0-N1],R);
16743: }
16744: if(isint(Nt=getopt(nt)) && Nt>0){
16745: if(Nt>256) Nt=256;
16746: Q=diff(P,X);
16747: for(S=[],TR=R;TR!=[];TR=cdr(TR)){
16748: if(car(TR)[2]>1) continue;
16749: V0=subst(P,X,car(TR)[0]);
16750: V1=subst(P,X,car(TR)[1]);
16751: if(abs(V0)<abs(V1))
16752: X0=car(TR)[0];
16753: else{
16754: X0=car(TR)[1];V0=V1;
16755: }
16756: for(Tn=Nt;Tn>0;Tn--){
16757: X1=X0-V0/subst(Q,X,X0);
16758: V1=subst(P,X,X1);
16759: if(abs(V1)>=abs(V0)) break;
16760: X0=X1;V0=V1;
16761: }
16762: S=cons(X0,S);
16763: }
16764: for(TR=R;TR!=[];TR=cdr(TR))
16765: if(car(TR)[2]>1) S=cons(car(TR),S);
16766: return reverse(S);
1.70 takayama 16767: }
16768: return reverse(cons(P,R));
16769: }
16770:
16771: /*
16772: def ptcombezier0(P,Q)
16773: {
16774: PB=subst(tobezier(P|div=1),t,s);
16775: QB=tobezier(Q|Div=1);
16776: Z=res(PB[0]-QB[0],PB[1]-QB[1],s);
16777: D=pmaj(diff(Z,t)|val=t);
16778: }
16779: */
16780:
1.6 takayama 16781: def ptcombezier(P,Q,T)
16782: {
16783: if(type(T)<2){
16784: if(T<2) T=20; /* default */
16785: return ptcombezier(P,Q,[0,0,1,T]);
16786: }
16787: V=T[2]/2;;
16788: PB=tobezier(P|div=1);
16789: PP=[ptbbox(PB[0]),ptbbox(PB[1])];
16790: QB=tobezier(Q|div=1);
16791: QQ=[ptbbox(QB[0]),ptbbox(QB[1])];
16792: for(L=[],I=0;I<2;I++){
16793: for(J=0;J<2;J++){
16794: if(!iscombox(PP[I],QQ[J])) continue;
16795: if(T[3]<=1) return
16796: [[T[0]+(I+0.5)*V,T[1]+(J+0.5)*V,
16797: [(PP[I][0][0]+PP[I][0][1])/2,(PP[I][1][0]+PP[I][1][1])/2]]];
16798: else{
16799: #if 0
16800: U=PB[I][0];V=PB[I][length(PB[I])-1];
16801: if(abs(A=(U[0]-V[0]))>abs(B=(U[1]-V[I])))
16802: M=mat([1,0],[-B/A,1]);
16803: else if(U!=V)
16804: M=mat([1,-A/B],[0,1]);
16805: else continue;
16806: if(!iscombox(ptbox(ptaffine(M,PB[I])),ptbox(ptaffine(M,QB[J])))) continue;
16807: #endif
16808:
16809: LN=ptcombezier(PB[I],QB[J],[T[0]+I*V,T[1]+J*V,V,T[3]-1]);
16810: #if 0
16811: L=append(LN,L);
16812: #else
16813: if(LN!=[]){
16814: if(L==[]) L=LN;
16815: else for(VV=3*V/2^T[3];LN!=[];LN=cdr(LN)){
16816: for(LT=L;LT!=[];LT=cdr(LT)){
16817: if(abs(car(LN)[0]-car(LT)[0])<VV&&abs(car(LN)[1]-car(LT)[1])<VV) break;
16818: }
16819: }
16820: }
16821: if(length(L)>32){ /* Too many points */
16822: I=J=2;
16823: }
16824: #endif
16825: }
16826: }
16827: }
16828: return L;
16829: }
16830:
16831:
16832: def ptcombz(P,Q,T)
16833: {
16834: if(P==Q) Q=0;
16835: if(type(P[0][0])!=4) P=P0=lbezier(P);
16836: if(Q==0){
16837: Q=P;F=1;
16838: }
16839: else if(type(Q[0][0])!=4) Q=lbezier(Q);
16840: for(R=[],I=0,Q0=Q;P!=[];P=cdr(P),I++){
16841: for(J=0,Q=Q0;Q!=[];Q=cdr(Q),J++){
16842: if(F==1&&I<J+2) break;
16843: if((RT=ptcombezier(car(P),car(Q),T))!=[]){
16844: RT=cons([I,J],RT);
16845: R=cons(RT,R);
16846: }
16847: }
16848: }
16849: if((Red=getopt(red))==1||Red==2){
16850: if(type(M=getopt(prec))!=1) M=12;
16851: for(F=0,T=P0;T!=[];T=cdr(T)){
16852: for(S=car(T);S!=[];S=cdr(S)){
16853: if(type(ST=car(S))==4 && type(ST[0])<2){
16854: if(F++==0){
16855: X0=X1=ST[0];Y0=Y1=ST[1];
16856: }else{
16857: if(ST[0]<X0) X0=ST[0];
16858: if(ST[0]>X1) X1=ST[0];
16859: if(ST[1]<Y0) Y0=ST[1];
16860: if(ST[1]>Y1) Y1=ST[1];
16861: }
16862: }
16863: }
16864: }
16865: V0=(X1-X0)/2^M;V1=(Y1-Y2)/2^M;
16866: for(RR=[],RT=R;RT!=[];RT=cdr(RT))
16867: for(S=cdr(car(RT));S!=[];S=cdr(S)) RR=cons(car(S)[2],RR);
16868: RR=ltov(RR);L=length(RR);
16869: for(I=0;I<L;I++)
16870: for(K=1,J=I+1;K!=0&&J<L;J++)
16871: if(abs(RR[I][0]-RR[J][0])<V0 && abs(RR[I][1]-RR[J][1])<V1) RR[I]=K=0;
16872: R0=[];
16873: I=L-1;
16874: if(Red==2){
16875: for(;I>=0;I--) if(RR[I]!=0) R0=cons(RR[I],R0);
16876: }else{
16877: for(RT=R;RT!=[];RT=cdr(RT)){
16878: R00=[car(RT)[0]];
16879: for(S=cdr(car(RT));S!=[];S=cdr(S),I--)
16880: if(RR[L-I-1]!=0) R00=cons(car(S),R00);
16881: if(length(R00)>1) R0=cons(reverse(R00),R0);
16882: }
16883: }
16884: return R0;
16885: }
16886: return reverse(R);
16887: }
16888:
16889: def draw_bezier(ID,IDX,B)
16890: {
16891: if(getopt(init)==1){
16892: S_FDot=0;
16893: return;
16894: }
16895: if(type(Col=getopt(col))!=1&&Col!=0) Col=0;
16896: Dot=0;
16897: if(type(Opt=getopt(opt))==7){
16898: if(!Col){
16899: Col=drawopt(Opt,0);
16900: if(Col==-1) Col=0;
16901: }
16902: T=drawopt(Opt,3);
16903: if(iand(T,2)){
16904: M=iand(T,1)?1/8:1/4;
16905: for(C=Col,Col=I=0;I<20;I+=8)
16906: Col+=ishift(0xff-(floor((0xff-iand(0xff,ishift(C,I)))*M)),-I);
16907: }
16908: if(iand(T,4)) Dot=2; /* 2 or 3 or 4 or 6 */
16909: else if(iand(T,8)) Dot=4;
16910: }
16911: if(type(B)==4 && (type(B[0])==4||type(B[0])==5) && type(B[0][0])<2) B=lbezier(B);
16912: else if(type(B)==5) B=[vtol(B)];
16913: for(;B!=[];B=cdr(B)){
16914: if(vars(F=car(B))==[]){
16915: #if 1
16916: if(length(F)<3&&!Dot){ /* line or point */
16917: if(length(F)>0){
16918: G=[rint(F[0][0]),rint(F[0][1])];
16919: if(length(F)==1) draw_obj(ID,IDX,G,Col);
16920: else{
16921: G=[G[0],G[1],rint(F[1][0]),rint(F[1][1])];
16922: draw_obj(ID,IDX,G,Col);
16923: }
16924: }
16925: continue;
16926: }
16927: #endif
16928: if(length(F)<2) continue;
16929: F=tobezier(F);
16930: }
16931: N=velbezier(F,0);
16932: N=(N[0]>N[1])?N[0]:N[1];
16933: if(!N) N=1;
16934: for(I=0;I<=N;I++,S_FDot++){
16935: if(Dot!=iand(S_FDot,Dot)) continue;
16936: G=subst(F,t,I/N);
16937: G=[rint(G[0]),rint(G[1])];
16938: if(G!=G0){
16939: draw_obj(ID,IDX,G,Col);
16940: G0=G;
16941: }
16942: }
16943: }
16944: if(S_FDot-->=2^32) S_FDot=0;
16945: return 0;
16946: }
16947:
1.29 takayama 16948:
16949: /*
16950: def redbezier(L)
16951: {
16952: V=newvect(4);ST=0;
16953: for(R=[],I=0,T=L;T=[];T=cdr(T){
16954: if(type(car(T))<4){
16955: F=0;
16956: if(I==3)
16957: if(car(T)==0){
16958: }else if(car(T)==1){
16959: }else if(car(T)==-1){
16960: if(I<3) V[I++]=ST;
16961: }
16962: }else if(I==3){
16963: if(R==[] || car(R)!=1){
16964: R=cons(V[0],R);
16965: if(ST==0) ST=V[0];
16966: }
16967: for(J=1;J<3;J++) R=cons(V[J],R);
16968: while((T=cdr(T))!=[]){
16969: R=cons(car(T),R);
16970: if(type(car(R))<4)
16971: }
16972: }else{
16973: if(ST==0) ST=car(T);
16974: V[I++]= car(T);
16975: }
16976: }
16977: }
16978: */
16979:
1.6 takayama 16980: def lbezier(L)
16981: {
16982: if((In=getopt(inv))==1||In==2||In==3){
16983: for(F=0,R=[];L!=[];L=cdr(L)){
16984: LT=car(L);
16985: if(F==car(LT)) R=cons(1,R);
16986: else{
16987: if(R!=[]&&F!=0) R=cons(0,R);
16988: R=cons(G=car(LT),R);
1.72 takayama 16989: if(In==3) In=2;
1.6 takayama 16990: }
16991: for(LT=cdr(LT);LT!=[];LT=cdr(LT))
16992: R=cons(car(LT),R);
16993: if((F=car(R))==G&&In==1){
16994: R=cons(-1,cdr(R));
16995: F=0;
16996: }
16997: }
16998: if(In==3 && car(R)==G) R=cons(-1,cdr(R));
16999: return reverse(R);
17000: }
17001: for(F=0,RT=R=[];L!=[];L=cdr(L)){
17002: if(type(T=car(L))==4||type(T)==5){
17003: if(F==0){
17004: FT=T;F=1;
17005: }
17006: RT=cons(T,RT);
17007: }else if(T==0){
1.72 takayama 17008: if(RT!=[]) R=cons(reverse(RT),R);
1.6 takayama 17009: RT=[];F=0;
17010: }else if(T==1){
17011: if(RT!=[]){
17012: R=cons(reverse(RT),R);
17013: RT=[car(RT)];
17014: }else{
17015: RT=[];F=0;
17016: }
17017: }else if(T==-1){
17018: RT=cons(FT,RT);
17019: R=cons(reverse(RT),R);
17020: RT=[];F=0;
17021: }
17022: }
17023: if(RT!=[]) R=cons(reverse(RT),R);
17024: return reverse(R);
17025: }
17026:
17027:
17028: def xybezier(L)
17029: {
1.72 takayama 17030: if(type(L)==4&&type(car(L))==4&&type(car(L)[0])==4) L=lbezier(L|inv=1);
1.6 takayama 17031: if(L==0 || (LS=length(L))==0) return "";
17032: Out=str_tb(0,0);
17033: if(type(VF=getopt(verb))==4){
17034: if(type(car(VF))>3){
17035: VFS=VF;VF=1;
17036: }else{
17037: VFS=cdr(VF);VF=car(VF);
17038: }
17039: }else VFS=["$\\bullet$","$\\times$"];
17040: if(VF!=1 && VF!=2) VF=0;
17041: if(!TikZ){
17042: if(VF) Ob=str_tb(0,0);
17043: T="\n**\\crv{";
17044: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+Opt;
17045: L00=Q=L[I0=0];S=S1="";
17046: for(F=0,I=1;I<=LS;I++){
17047: P=Q;Q=(I==LS)?0:L[I];
17048: if(type(Q)==4){
17049: if(F==0){
17050: S1="";L0=P;F=1;
17051: continue;
17052: }else if(F==1)
17053: F=2;
17054: else if(F==2){
17055: S1=S1+"&";
17056: }
17057: S1=S1+xypos(P);
17058: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
17059: }else{
17060: if(Q==0){
17061: if(F>0){
17062: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
17063: if(VF){
17064: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
17065: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
17066: }
17067: F=0;
17068: }
17069: }else if(Q==1){
17070: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
17071: if(VF){
17072: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
17073: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
17074: }
17075: F=1;
17076: }else if(Q==-1){
17077: if(F==2)
17078: S1=S1+"&";
17079: str_tb("{"+xypos(L0)+";"+xypos(L00)+T+S1+xypos(P)+"}};\n",Out);
17080: if(VF) str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
17081: F=0;
17082: }
17083: if(F==1){
17084: if(I<LS-1 && type(L[I+1])<2){
17085: if(L[I+1]==-1){
17086: str_tb("{"+xypos(P)+";"+xypos(L00)+T+"}};\n",Out);
17087: }
17088: if(VF) str_tb(xyput([P[0][0],P[0][1],VFS[0]]),Ob);
17089: F=0;
17090: }
17091: }
17092: while(++I<LS && type(L[I])<2);
17093: if(I>=LS) break;
17094: if(F==1){
17095: Q=P;I--;F=0;
17096: }else L00=Q=L[I];
17097: }
17098: }
17099: }else{
17100: if(type(T=getopt(cmd))==7){
17101: if(T!="") T="\\"+T;
17102: }else T="\\draw";
17103: if((Rel=getopt(relative))==1) VF=0;
17104: if(VF) Ob=str_tb(0,0);
17105: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+"["+Opt+"]";
17106: Out=str_tb(T,0);
17107: Q=L[0];
17108: for(F=M=0,I=1;I<=LS;I++){
17109: P=Q; Q=(I==LS)?0:L[I];
17110: if(++M>XYLim){
17111: str_tb("\n",Out);M=1;
17112: }
17113: if(type(Q)==4 || type(Q)==5 || type(Q)==7){
17114: if(F==0){
17115: str_tb(" ",Out);
17116: F=1;
17117: }else if(F==1){
17118: str_tb(" .. controls ",Out);
17119: F=2;
17120: }else if(F==2){
17121: str_tb(" and ",Out);
17122: F=2;
17123: }
17124: PP=xypos(P);
17125: if(Rel==1 && F==2) PP="+"+PP;
17126: str_tb(PP,Out);
17127: if(VF&&((F<2)||length(VFS)>1))
17128: str_tb(xyput([P[0],P[1],(F<2)?VFS[0]:VFS[1]]),Ob);
17129: }else{
17130: /* if(I<LS-1) VF=0; */
17131: if(Q==0||Q==1){
17132: PP=xypos(P);
17133: if(Rel==1) PP="+"+PP;
17134: str_tb(((F==0)?" ":((F==1)?" -- ":" .. "))+PP,Out);
17135: if(VF) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
17136: F=Q;
17137: }else if(Q==-1){
17138: PP=xypos(P);
17139: if(Rel==1) PP="+"+PP;
17140: if(F==1)
17141: str_tb("..controls "+PP+" .. cycle",Out);
17142: else if(F==2)
17143: str_tb(" and "+PP+" .. cycle",Out);
17144: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
17145: F=0;
17146: }
17147: if(F==1){
17148: if(I<LS-1){
17149: if(L[I+1]==-1){
17150: str_tb(" -- cycle",Out);
17151: I=I+1;
17152: F=0;
17153: }
17154: else if(type(L[I+1])<2) F=0;
17155: }
17156: }
17157: while(++I<LS && type(L[I])<2);
17158: if(I>=LS) break;
17159: Q=L[I];
17160: }
17161: }
17162: str_tb(";\n",Out);
17163: }
17164: if(VF) str_tb(str_tb(0,Ob),Out);
17165: return str_tb(0,Out);
17166: }
17167:
17168: def xybox(L)
17169: {
17170: K=length(L);
1.76 takayama 17171: P=L[0];Q=L[1];
1.75 takayama 17172: if(K==2)
17173: LL=[ P, [P[0],Q[1]], Q, [Q[0],P[1]] ];
17174: else{
17175: R=L[2];
17176: LL=[ P, R, Q, [P[0]+Q[0]-R[0],P[1]+Q[1]-R[1]] ];
17177: }
17178: Opt=getopt();
17179: SS=getopt(opt);
17180: FL=getopt(color);
17181: if(TikZ&&type(SS)<1&&K==2){
17182: if(type(FL)==4){
17183: F=FL[0];
17184: if(length(FL)>1) CMD=FL[1];
17185: }else if(type(FL)==7) F=FL;
17186: else F="";
17187: F=cons(F,["rectangle"]);
17188: if(CMD) return xyarrow(P,Q|opt=F,cmd=CMD);
17189: else return xyarrow(P,Q|opt=F);
17190: }
17191: if(type(SS)!=7&&!TikZ) Opt=cons(["opt","@{-}"],Opt);
17192: Opt=cons(["close",1],Opt);
17193: return xylines(LL|option_list=Opt);
17194: }
17195:
17196: def xyang(S,P,Q,R)
17197: {
17198: Opt=delopt(getopt(),"ar");
1.81 takayama 17199: if(type(S)>2) S=dnorm([S,P]);
1.75 takayama 17200: if(type(Prec=getopt(prec))!=1) Prec=0;
17201: if(type(Q)>2){
1.82 takayama 17202: if(isint(S)&&S<0&&S>-8){
17203: if((S=-S)==6||S==7){
17204: H=ptcommon([Q,R],[P,0]);
17205: if(S==6) return xyang(H,P,0,0|option_list=getopt()); /* 円 */
17206: return xylines([P,H]|option_list=getopt()); /* 垂線 */
17207: }
17208: O=pt5center(P,Q,R);
17209: if(S==2) H=P; /* 外心 */
1.75 takayama 17210: else{
1.82 takayama 17211: if(S>2) S++; /* 内心，傍心 */
17212: H=ptcommon([P,Q],[O[S],0]);
1.75 takayama 17213: }
1.82 takayama 17214: return xyang(H,O[S],0,0|option_list=getopt());
17215: }
17216: if(type(Ar=getopt(ar))!=1) Ar=0;
17217: if(isint(R)){
17218: if(R==1||R==-1){ /* 直角 */
17219: P1=ptcommon([Q,P],[-S,0]);
17220: S*=R;
17221: P2=ptcommon([P,P1],[S,@pi/2]);
17222: P3=ptcommon([P1,P2],[S,@pi/2]);
17223: return xylines([P1,P2,P3]|option_list=Opt);
17224: }else if((AR=abs(R))==0||AR==2||AR==3||AR==4||AR>=10){ /* 矢印 */
17225: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
17226: if(R<0) Ang+=3.14159;
17227: if(AR>10) X=deval(@pi/180*AR);
17228: else{
17229: ANG=[0.7854,0.5236,1.0472];
17230: X=(AR==0)?1.5708:ANG[AR-2];
17231: }
17232: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
17233: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; /* 矢先 */
17234: L=(X==0)?[U,V]:[U,P,V];
17235: if(X&&iand(Ar,2)){
17236: L=append([V],L);
17237: if((X=ptcommon([P,Q],[U,V]|in=1))!=0) P=X;
17238: }
17239: if(iand(Ar,1))
17240: L=append([Q,P,0],L); /* 心棒 */
17241: return xylines(L|option_list=Opt);
17242: }else if(AR>4&&AR<9){
17243: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
17244: ANG=[0.7854,0.5236,0.3927,0.2618];
17245: X=ANG[AR-5];
17246: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
17247: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)];
17248: W=ptcommon([P,U],[P,Q]|in=-2);
17249: W1=[(U[0]+P[0]+W[0])/3,(U[1]+P[1]+W[1])/3];
17250: W2=[(V[0]+P[0]+W[0])/3,(V[1]+P[1]+W[1])/3];
17251: L=iand(Ar,2)?[V,U,1,W1,P,1,W2,V]:[U,W1,P,1,W2,V];
17252: if(iand(Ar,1)){
17253: if(iand(Ar,2)) P=ptcommon([P,Q],[U,V]);
17254: L=append([Q,P,0],L);
17255: };
17256: if(type(Sc=getopt(scale))>0){
17257: if(type(Sc)==1) Sc=[Sc,Sc];
17258: L=ptaffine(diagm(2,Sc),L);
17259: }
17260: Opt=delopt(Opt,"proc");
17261: if(getopt(proc)==1) return append([2,Opt],L);
17262: S=xybezier(L|option_list=Opt);
17263: if(getopt(dviout)!=1) return S;
17264: dviout(xyproc(S));
17265: return 1;
1.75 takayama 17266: }
17267: }
17268: }
17269: if(type(Q)<3){
17270: X=deval(Q); Y=deval(R);
17271: }else{
17272: X=myarg([Q[0]-P[0],Q[1]-P[1]]);
17273: Y=myarg([R[0]-P[0],R[1]-P[1]]);
17274: }
17275: if(Prec>2) N=8;
17276: else if(Prec==2) N=6;
17277: else if(Prec==1) N=4;
17278: else N=3;
17279: U=deval(@pi)*2/N;
17280: if(X==Y||Y-X>6.28318){
17281: for(L=[],I=N-1;I>=0;I--) L=cons([P[0]+S*dcos(I*U),P[1]+S*dsin(I*U)],L);
17282: return xylines(L|option_list=append([["curve",1],["close",1]],Opt));
17283: }
17284: for(M=1;(Y-X)/M>U;M++);
17285: for(L=[],I=M+1;I>-2;I--){
17286: Ang=X+(Y-X)*I/M;
17287: L=cons([P[0]+S*dcos(Ang),P[1]+S*dsin(Ang)],L);
17288: }
17289: if(getopt(ar)!=1) return xylines(L|option_list=append([["curve",1],["close",-1]],Opt));
17290: OL=delopt(Opt,["dviout","opt","proc"]);
17291: S=xylines(L|option_list=append([["curve",1],["close",-1],["opt",0]],OL));
17292: T=xylines([P,L[1]]|option_list=cons(["opt",0],OL));
17293: S=ptaffine("close",[S,T]); /* connect curves */
17294: if(getopt(opt)==0) return S;
17295: OL=(type(SS=getopt(opt))>1)?[["opt",SS]]:[];
17296: if(type(T=getopt(proc))==1 && T>=1 && T<=3) return [1,OL,S];
17297: if(OL==[]) S=xybezier(S);
17298: else S=(type(SS)==7)? xybezier(S|opt=SS):xybezier(S|opt=SS[0],cmd=SS[1]);
17299: if(getopt(dviout)==1) return xyproc(S|dviout=1);
17300: return S;
17301: }
17302:
17303: def xyoval(P,L,R)
17304: {
17305: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
17306: if(length(Arg)>2)
17307: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180,@pi*Arg[2]/180];
17308: else
17309: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
17310: }
17311: if(type(Arg)==4){
17312: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
17313: if(length(Arg)>2) Arg2=deval(Arg[2]);
17314: if(Arg1<Arg0 || Arg0<-7) return 0;
17315: }
17316: if(type(Prec=getopt(prec))!=0) Prec=0;
17317: if((Ar=getopt(ar))!=1) Ar=0;
17318: L=xyang(L,[0,0],Arg0,Arg1|prec=Prec,opt=0,ar=Ar);
17319: Sc=getopt(scale);
17320: if(type(Sc=getopt(scale))<1) Sc=[1,1];
17321: else if(type(Sc)==1) Sc=[Sc,Sc];
17322: M=mat([1,0],[0,R]);
17323: L=ptaffine(M,L|shift=P);
17324: M=mat([Sc[0],0],[0,Sc[1]]);
17325: L=ptaffine(M,L|arg=Arg2);
17326: if((Opt=getopt(opt))==0) return L;
17327: Opt=(type(Opt)>1)? [["opt2",Opt]]:[];
17328: if(getopt(proc)==1) return [1,Opt,L];
17329: S=xybezier(L|option_list=getopt());
17330: if(getopt(dviout)==1){
17331: xyproc(S|dviout=1);
17332: return 1;
17333: }
17334: return S;
17335: }
17336:
17337: def xycirc(P,R)
17338: {
17339: ST=getopt(opt);
17340: if(type(ST)<0) ST="";
17341: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
17342: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
17343: }
17344: /* Is it OK?
17345: if(TikZ==0 && XYcm==1){
17346: R*=10; P=[P[0]*10,P[1]*10];
17347: }
17348: */
17349: if(type(Arg)==4){
17350: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
17351: if(Arg1<=Arg0 || Arg0<-7 || Arg1-Arg0>7) return 0;
17352: if(type(ST)==7)
17353: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
17354: [P[1]-R-1,P[1]+R+1]|opt=ST);
17355: else
17356: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
17357: [P[1]-R-1,P[1]+R+1]);
17358: if(getopt(close)==1){
17359: S=S+xyline([0,0],
17360: [deval(subst(R*cos(x)+P[0],x,Arg0)),deval(subst(R*sin(x)+P[0],x,Arg0))]);
17361: S=S+xyline([0,0],
17362: [deval(subst(R*cos(x)+P[0],x,Arg1)),deval(subst(R*sin(x)+P[0],x,Arg1))]);
17363: }
17364: return S;
17365: }
17366: if(TikZ){
17367: SP="";
17368: if(length(P)>2) SP=P[2];
17369: if(type(SP)!=7) SP="$"+my_tex_form(SP)+"$";
17370: if(R==0){
17371: if(ST!="") ST=ST+",";
17372: return "\\node ["+ST+"circle,draw]"+xypos([P[0],P[1]])+ "{"+SP+"};\n";
17373: }
17374: if(type(R)!=7) R=rtostr(deval(R));
17375: if(ST!="") ST="["+ST+"]";
17376: S="\\draw "+ST+xypos([P[0],P[1]])+" circle [radius="+R+"]";
17377: if(SP!="") S=S+" node at"+xypos([P[0],P[1]])+" {"+SP+"}";
17378: return S+";\n";
17379: }
17380: S="{"+xypos([P[0],P[1]]);
17381: if(length(P)>2){
17382: SP=P[2];
17383: if(type(P)!=7) SP=my_tex_form(SP);
17384: S=S+" *+{"+SP+"}";
17385: }
17386: S =S+" *\\cir";
17387: if(R!=0){
17388: R=deval(R);
17389: S=S+"<"+rtostr(R)+((XYcm)?"cm>":"mm>");
17390: }
17391: S = S+"{";
17392: if(type(ST)==7) S=S+ST;
17393: return S+"}};\n";
17394: }
17395:
17396: def xypoch(W,H,R1,R2)
17397: {
17398: if(H>R1||2*H>R2){
17399: errno(0);
17400: return;
17401: }
17402: if(type(Ar=getopt(ar))!=1) Ar=TikZ?0.25:2.5;
17403: T1=dasin(H/R1);S1=R1*dcos(T1);
17404: T2=dasin(H/R2);S2=R2*dcos(T2);
17405: T3=dasin(2*H/R2);S3=R2*dcos(T3);
17406: S=xyline([R1,0],[W-R1,0]);
17407: S+=xyang(R1,[W,0],-@pi,@pi-T1);
17408: S+=xyline([S2,H],[W-S1,H]);
17409: S+=xyang(R2,[0,0],T2,2*@pi-T3);
17410: S+=xylines([[S3,-2*H],[W-H-R2,-2*H],[W-H-R2,2*H],[W-S3,2*H]]);
17411: S+=xyang(R2,[W,0],-@pi+T2,@pi-T3);
17412: S+=xyline([W-T2,-H],[W-T2,-H]);
17413: S+=xyang(R1,[0,0],0,2*@pi-T1);
17414: S+=xyline([W-S2,-H],[S1,-H]);
17415: if(Ar>0){
17416: S+=xyang(Ar,[W/2,0],[0,0],8);
17417: S+=xyang(Ar,[W/2,-2*H],[0,-2*H],8);
17418: S+=xyang(Ar,[W/2-Ar,-H],[W,-H],8);
17419: S+=xyang(Ar,[W/2-Ar,H],[W,H],8);
17420: S+=xyang(Ar,[W-S3,2*H],[W-H-R2,2*H],8);
17421: }
17422: S+=xyput([R1,0,"$\\bullet$"]);
17423: S+=xyput([0,0,"$\\times$"]);
17424: S+=xyput([W,0,"$\\times$"]);
17425: if(TikZ) S=str_subst(S,";\n\\draw","\n");
17426: return S;
17427: }
1.33 takayama 17428:
1.72 takayama 17429: def xycircuit(P,S)
17430: {
17431: if(type(Sc=getopt(scale))!=1) Sc=1;
17432: if(type(Opt0=getopt(opt))!=7) Opt0="";
1.73 takayama 17433: if(type(At=getopt(at))!=1) At=(S=="E"||S=="EE")?1:1/2;
1.72 takayama 17434: Rev=(getopt(rev)==1)?-1:1;
17435: if(type(P)==4&&type(car(P))==4&&P[0][0]==P[1][0]) Rev=-Rev;
1.75 takayama 17436: W=R=B2=B3=0;Opt=Opt2=Opt3="";
1.73 takayama 17437: if(S=="L"||S=="VL"||S=="LT"){
1.72 takayama 17438: G=[1/8*x-2/5*cos(x)+2/5,1/2*sin(x)+1/2];
17439: B=xygraph(G,-21,[0,7*@pi],[-1,10],[-2,2]|scale=0.3/1.06466,opt=0);
17440: B=append(B,[1,[1,0]]);
17441: B=append([[0,0],car(B),1],cdr(B));
17442: W=1;Opt="thick";
17443: if(S=="VL"){
17444: B2=xyang(0.2,[0.5+0.4*Rev,0.45],[0.5-0.435*Rev,-0.3],3|ar=3,opt=0);
17445: Opt2="thick,fill";
1.73 takayama 17446: }else if(S=="LT"){
17447: 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]];
17448: Opt2="thick";
1.72 takayama 17449: }
1.73 takayama 17450: }else if(S=="C"||S=="VC"||S=="C+"||S=="C-"||S=="CT"){
1.72 takayama 17451: B=[[0,-0.2],[0,0.2],0,[0.15,-0.2],[0.15,0.2]];
17452: W=0.15;Opt="very thick";
17453: if(S=="VC"){
17454: B2=xyang(0.2,[1/3+0.075,0.3*Rev],[-1/3+0.075,-0.3*Rev],3|ar=3,opt=0);
17455: Opt2="thick,fill";
1.73 takayama 17456: }else if(S=="CT"){
17457: B2=[[1/3+0.075,0.3*Rev],[-1/3+0.075,-0.3*Rev],0,[1/3+0.125,0.244*Rev],
17458: [1/3+0.025,0.356*Rev]];
17459: Opt2="thick";
17460: }else if(S=="C+")
1.72 takayama 17461: 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 17462: 0,[0.29,0.04*Rev],[0.29,0.24*Rev],0,[0.19,0.14*Rev],[0.39,0.14*Rev]];
17463: else if(S=="C-")
17464: B2=[[0,0.05],[0.15,-0.05],0,[0,0.15],[0.15,0.05],0,[0,-0.05],[0.15,-0.15]];
17465: }else if(S=="R"||S=="VR"||S=="VR3"||S=="RT"){
1.72 takayama 17466: for(I=0,B=[[0,0]];I<12;I++)
17467: if(iand(I,1)) B=cons([I,(-1)^((I+1)/2)],B);
17468: B=reverse(cons([12,0],B));
17469: B=xylines(B|scale=[1/18,0.15],opt=0);
17470: W=2/3;Opt="thick";
17471: if(S=="VR"){
17472: B2=xyang(0.2,[2/3,0.3*Rev],[0,-0.3*Rev],3|ar=3,opt=0);
17473: Opt2="thick,fill";
1.73 takayama 17474: }else if(S=="RT"){
17475: B2=[[2/3,0.3*Rev],[0,-0.3*Rev],0,[0.717,0.244*Rev],[0.617,0.357*Rev]];
17476: Opt2="thick";
1.72 takayama 17477: }else if(S=="RN3"){
17478: B2=xyang(0.2,[1/3,0.2*Rev],[1/3,0.5*Rev],3|ar=3,opt=0);
17479: Opt2="thick,fill";
17480: }
1.73 takayama 17481: }else if(S=="RN"||S=="VRN"||S=="RN3"||S=="NRT"){
1.72 takayama 17482: B=xylines([[0,0.1],[2/3,0.1],[2/3,-0.1],[0,-0.1],[0,0.1]]|opt=0);
17483: W=2/3;Opt="thick";
17484: if(S=="VRN"){
17485: B2=xyang(0.2,[2/3,0.3*Rev],[0,-0.3*Rev],3|ar=3,opt=0);
17486: Opt2="thick,fill";
17487: }else if(S=="RN3"){
17488: B2=xyang(0.2,[1/3,0.2*Rev],[1/3,0.5*Rev],3|ar=3,opt=0);
17489: Opt2="thick,fill";
1.73 takayama 17490: }else if(S=="NRT"){
17491: B2=[[2/3,0.3*Rev],[0,-0.3*Rev],0,[0.717,0.244*Rev],[0.617,0.357*Rev]];
17492: Opt2="thick";
1.72 takayama 17493: }
17494: }else if(S=="circle"){
17495: W=1;
17496: B=xyang(0.5,[0.5,0],0,0|opt=0);
17497: }else if(S=="gap"){
17498: W=0.3;
17499: B=xyang(0.15,[0.15,0],0,3.1416|opt=0);
17500: }else if(S=="E"){
17501: W=0.1;
17502: 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 17503: }else if(S=="EE"){
17504: W=0.15;
17505: 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 17506: }else if(S=="Cell"){
17507: W=0.1;
17508: B=[[0,-0.2],[0,0.2]];
17509: B2=[[0.1,-0.1],[0.1,0.1]];Opt2="very thick";
17510: }else if(S=="Cell2"){
17511: W=0.3;
17512: B=[[0,-0.2],[0,0.2],0,[0.2,-0.2],[0.2,0.2]];
17513: B2=[[0.1,-0.1],[0.1,0.1],0,[0.3,-0.1],[0.3,0.1]];Opt2="very thick";
1.73 takayama 17514: }else if(S=="Cells"){
17515: W=0.6;
17516: B=[[0,-0.2],[0,0.2],0,[0.5,-0.2],[0.5,0.2],0,[0.1,0],[0.18,0],0,
17517: [0.24,0],[0.34,0],0,[0.40,0],[0.5,0]];
17518: B2=[[0.1,-0.1],[0.1,0.1],0,[0.6,-0.1],[0.6,0.1]];Opt2="very thick";
1.72 takayama 17519: }else if (S=="Sw"){
17520: W=0.5;
17521: B=xyang(0.05,[0.05,0],0,0|opt=0);
17522: B0=ptaffine(1,B|shift=[0.4,0]);
17523: B=ptaffine("union",[B,B0]);
17524: B=ptaffine("union",[B,[[0.0908,0.025*Rev],[0.45,0.17*Rev]]]);
17525: }else if(S=="D"){
17526: W=0.3;Opt="thick";
17527: B=[[0,0],[0.3,0.173],0,[0.3,0.173],[0.3,-0.173],0,[0.3,-0.173],[0,0],0,
17528: [0,0.173],[0,-0.173]];
1.75 takayama 17529: }else if(S=="NPN"||S=="PNP"||S=="NPN0"||S=="PNP0"){
17530: W=0.6;
17531: C=[[0.6,0],[0.37,0.23],[0,0],[0.23,0.23]];
17532: if(Rev==-1) C=[C[2],C[3],C[0],C[1]];
17533: if(S=="PNP"||S=="PNP0") C=[C[1],C[0],C[2],C[3]];
17534: B=[[0,0],[0.23,0.23],0,[0.6,0],[0.37,0.23],0,[0.3,0.23],[0.3,0.6]];
17535: B=ptaffine("union",[xyang(0.15,C[0],C[1],18|ar=1,opt=0),B]);
17536: if(S=="PNP"||S=="NPN") B=ptaffine("union",[xyang(0.3354,[0.3,0.15],0,0|opt=0),B]);
17537: B2=[[0.07,0.23],[0.53,0.23]];
17538: Opt2="very thick";
17539: }else if(S=="JN"||S=="JP"){
17540: W=0.6;
17541: B=[[0,0],[0.2,0],1,[0.2,0.23],0,[0.6,0],[0.4,0],1,[0.4,0.23],0,[0.3,0.23],[0.3,0.6]];
17542: C=[[0.3,0.23],[0.3,0.4854]];
17543: if(S=="JP") C=reverse(C);
17544: B=ptaffine("union",[B,xyang(0.15,C[0],C[1],18|opt=0)]);
17545: B=ptaffine("union",[B,xyang(0.3354,[0.3,0.15],0,0|opt=0)]);
17546: B2=[[0.07,0.23],[0.53,0.23]];
17547: Opt2="very thick";
1.72 takayama 17548: }else if(S=="") R=(Opt0=="")?xyline(P[0],P[1]):xyline(P[0],P[1]|opt=Opt0);
17549: else if(S=="arrow") R=xyang(0.2*Sc,P[1],P[0],3|ar=1,opt=Opt0);
17550: else if(type(S)==4&&type(car(S))==7){
17551: if(type(car(P))!=4) P=[P];
17552: for(R="";P!=[];P=cdr(P)) R+=xyput([car(P)[0],car(P)[1],car(S)]);
17553: }
17554: if(W){
17555: R="";
17556: if(type(P)==4){
17557: if(type(car(P))==4){
17558: T=ptcommon([[0,0],[1,0]],P|in=2);
17559: L=dnorm(P);
17560: W*=Sc;
17561: L1=L*At-W/2;L2=L*(1-At)-W/2;
17562: if(L1>0){
17563: P1=[P[0][0]+L1*dcos(T),P[0][1]+L1*dsin(T)];
17564: R+=xyline(P[0],P1);
17565: }
17566: if(L2>0){
17567: P2=[P[1][0]-L2*dcos(T),P[1][1]-L2*dsin(T)];
17568: R+=xyline(P2,P[1]);
17569: }
17570: B=ptaffine(Sc,B|shift=P1,arg=T);
17571: if(B2) B2=ptaffine(Sc,B2|shift=P1,arg=T);
1.75 takayama 17572: if(B3) B3=ptaffine(Sc,B3|shift=P1,arg=T);
1.72 takayama 17573: }else{
17574: B=ptaffine(Sc,B|shift=P1);
17575: if(B2) B2=ptaffine(Sc,B2|shift=P1);
1.75 takayama 17576: if(B3) B3=ptaffine(Sc,B3|shift=P1);
1.72 takayama 17577: }
17578: }else{
17579: B=ptaffine(Sc,B);
17580: if(B2) B2=ptaffine(Sc,B2);
1.75 takayama 17581: if(B3) B3=ptaffine(Sc,B3);
1.72 takayama 17582: }
17583: if(Opt=="") Opt=Opt0;
17584: else if(Opt0!="") Opt=Opt+","+Opt0;
17585: R+=(Opt=="")?xybezier(B):xybezier(B|opt=Opt);
17586: if(B2){
17587: if(Opt2=="") Opt2=Opt0;
17588: else if(Opt0!="") Opt2=Opt2+","+Opt0;
17589: R+=(Opt2=="")?xybezier(B2):xybezier(B2|opt=Opt2);
17590: }
1.75 takayama 17591: if(B3){
17592: if(Opt3=="") Opt3=Opt0;
17593: else if(Opt0!="") Opt3=Opt3+","+Opt0;
17594: R+=(Opt3=="")?xybezier(B3):xybezier(B3|opt=Opt3);
17595: }
1.72 takayama 17596: }
17597: return R;
17598: }
17599:
17600:
1.6 takayama 17601: def ptaffine(M,L)
17602: {
17603: if(type(L)!=4&&type(L)!=5){
17604: erno(0);return L;
17605: }
17606: if(type(M)==7){ /* connect lists */
17607: if(M=="reverse"){
17608: for(LO=LR=[],F=0,LT=L; LT!=[]; LT=cdr(LT)){
17609: if(type(P=car(LT))==4 || type(P)==7){
17610: LR=cons(P,LR);
17611: continue;
17612: }else{
17613: if(P==-1){
17614: LL=reverse(LR);
17615: LO=append(reverse(cons(-1,cdr(LL))),LO);
17616: LO=cons(car(LL),LO);
17617: LR=[];
17618: }else if(P==1){
17619: LR=cons(car(LR),cons(1,cdr(LR)));
17620: }else if(P==0 || length(LT)==1){
17621: if(LO!=[] && car(LO)!=0 && (type(car(LO))==4 || car(LO)==1))
17622: LO=cons(0,LO);
17623: LO=append(LR,LO);
17624: if(length(LT)>1&&length(LO)>0&&car(LO)!=0) LO=cons(0,LO);
17625: LR=[];
17626: }
17627: }
17628: }
17629: return append(LR,LO);
17630: }
17631: if(type(L[0][0])!=4) L=[L];
17632: LO=[];
17633: if(M=="connect" || M=="close" || M=="loop"){
17634: Top=car(car(L));
17635: for(K=1,LL=L; LL!=[]; LL=cdr(LL)){
17636: for(F=0,LT=car(LL); LT!=[]; LT=cdr(LT),F++){
17637: if((LTT=car(LT))==0) LTT=1;
17638: if(F==0 && LO!=[]){
17639: LO0=car(LO);
17640: if(car(LO)!=1&&length(LO)>1) LO=cons(1,LO);
17641: if(LTT==LO0) continue;
17642: else LO=cons(1,cons(LTT, LO));
17643: }else LO=cons(LTT, LO);
17644: }
17645: }
17646: if(M!="connect"){
17647: if(Top==car(LO) || car(LO)==1 || M=="loop")
17648: LO=cons(-1,cdr(LO));
17649: else
17650: LO=cons(-1,cons(1,LO));
17651: }
17652: return reverse(LO);
17653: }
17654: if(M=="union"){
17655: for(LL=reverse(L); LL!=[]; LL=cdr(LL)){
17656: if(LO!=[]) LO=cons(0,LO);
17657: LO=append(car(LL),LO);
17658: }
17659: L=LO;
17660: }
17661: return L;
17662: }
17663: if(type(Arg=getopt(deg))==1)
17664: Arg=@pi*Arg/180;
17665: else Arg=getopt(arg);
17666: if(type(Arg)==2) Arg=deval(Arg);
17667: if(type(Arg)==1)
17668: M=M*mat([dcos(Arg),-dsin(Arg)],[dsin(Arg),dcos(Arg)]);
17669: if(type(Sft=getopt(org))==4){
17670: Sft=ltov(Sft);
17671: Sft-=M*Sft;
17672: }else Sft=ltov([0,0]);
17673: if(type(V=getopt(shift))==4)
17674: Sft+=ltov(V);
17675: if(getopt(proc)==1){
17676: if(Sft!=0&<ov(Sft)!=[0,0]) Sft=[["shift",vtol(Sft)]];
17677: else Sft=[];
17678: for(LO=[],LT=L;LT!=[];LT=cdr(LT)){
17679: if(type(car(T=car(LT)))<2){
17680: if((P=car(T))==0){ /* exedraw 0 */
17681: 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]]];
17682: V=ptbbox(ptaffine(M,V|option_list=Sft));
17683: L1=cdr(cdr(cdr(T)));
17684: LO=cons(append([0,V[0],V[1]],L1),LO);
17685: continue;
17686: }else if(P==1){ /* exedraw 1 */
17687: L1=[];
17688: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
17689: D=car(TT);
17690: if(type(D[0][0])==4){
17691: for(L2=[],DT=D;DT!=[];DT=cdr(DT))
17692: L2=cons(ptaffine(M,car(DT)|option_list=Sft),L2);
17693: L1=cons(reverse(L2),L1);
17694: }else L1=cons(ptaffine(M,D|option_list=Sft),L1);
17695: }
17696: LO=cons(append([1,T[1]],reverse(L1)),LO);
17697: continue;
17698: }else if(P>=2 && P<=5){
17699: L1=ptaffine(M,cdr(cdr(T))|optilon_list=Sft);
17700: LO=cons(append([P,T[1]],L1),LO);
17701: continue;
17702: }
17703: }
17704: LO=cons(T,LO);
17705: }
17706: return reverse(LO);
17707: }
17708: F=0;
17709: if(type(L)==4){
17710: for(LT=L; LT!=[]; LT=cdr(LT)){
17711: if((T=type(car(LT)))==4||T==5){
17712: F=1; break;
17713: }
17714: }
17715: }
17716: if(F==0) return (Sft==0)?ptaffine(M,[L])[0]:ptaffine(M,[L]|shift=vtol(Sft))[0];
17717: for(LO=[],LT=L; LT!=[]; LT=cdr(LT)){
17718: if(((T=type(P=car(LT)))!=4 && T!=5)||type(P[0])>3) LO=cons(P,LO);
17719: else{
17720: if(T==4) P=ltov(P);
17721: V=M*P;
17722: if(Sft!=0) V+=Sft;
17723: if(T==4) V=vtol(V);
17724: LO=cons(V,LO);
17725: }
17726: }
17727: return reverse(LO);
17728: }
17729:
17730: def ptlattice(M,N,X,Y)
17731: {
17732: if(type(S=getopt(scale))!=1) S=1;
17733: if(type(Cond=getopt(cond))!=4) Cond=[];
17734: Line=getopt(line);
17735: if(Line==1 || Line==2) F=newmat(M,N);
17736: else Line=0;
17737: if(type(Org=getopt(org))==4) Org=ltov(Org);
17738: else Org=newvect(length(X));
17739: X=ltov(X); Y=ltov(Y);
17740: for(L=[],I=M-1;I>=0;I--){
17741: for(P0=P1=0,J=N-1;J>=0;J--){
17742: P=Org+I*X+J*Y;
17743: for(C=Cond; C!=[]; C=cdr(C))
17744: if(subst(car(C),x,P[0],y,P[1])<0) break;
17745: if(C!=[]) continue;
17746: if(Line) F[I][J]=1;
17747: else L=cons(vtol(S*P),L);
17748: }
17749: }
17750: if(Line==0) return L;
17751: for(I=M-1;I>=0;I--){
17752: for(T0=0,T1=J=N-1;J>=0;J--){
17753: if((K=F[I][J])!=0){
17754: if(T0==0) T0=J;
17755: else T1=J;
17756: }
17757: if(K==0 || T1==0){
17758: if(T1<T0){
17759: L=cons(vtol(S*(Org+I*X+T0*Y)), L);
17760: L=cons(vtol(S*(Org+I*X+T1*Y)), L);
17761: L=cons(0,L);
17762: }
17763: T0=0; T1=N-1;
17764: }
17765: }
17766: }
17767: for(J=N-1;J>=0;J--){
17768: for(T0=0,T1=I=M-1;I>=0;I--){
17769: if((K=F[I][J])!=0){
17770: if(T0==0) T0=I;
17771: else T1=I;
17772: }
17773: if(K==0 || T1==0){
17774: if(T1<T0){
17775: L=cons(vtol(S*(Org+T0*X+J*Y)), L);
17776: L=cons(vtol(S*(Org+T1*X+J*Y)), L);
17777: L=cons(0,L);
17778: }
17779: T0=0; T1=M-1;
17780: }
17781: }
17782: }
17783: return cdr(L);
17784: }
17785:
17786: def ptpolygon(N,R)
17787: {
17788: if(type(S=getopt(scale))!=1) S=1;
17789: if(type(Org=getopt(org))!=4) Org=[0,0];
17790: Pi=deval(@pi);
17791: if(type(Arg=getopt(deg))==1)
17792: Arg=Pi*Arg/180;
17793: else Arg=getopt(arg);
17794: if(type(Arg)==2) Arg=deval(Arg);
17795: if(type(Arg)!=1) Arg=0;
17796: Arg -= Pi*(1/2+1/N);
17797: D=Pi*2/N;
17798: for(L=[],I=N-1; I>=0; I--)
17799: L=cons([S*(Org[0]+R*dcos(Arg+I*D)),S*(Org[1]+R*dsin(Arg+I*D))],L);
17800: return L;
17801: }
17802:
17803: def ptwindow(L,X,Y)
17804: {
17805: if(type(S=getopt(scale))==1){
17806: X=[S*X[0],S*X[1]]; Y=[S*Y[0],S*Y[1]];
17807: }
17808: for(R=[],LT=L;LT!=[];LT=cdr(LT)){
17809: P=car(LT);
17810: if(P[0]<X[0] || P[0]>X[1] || P[1]<Y[0] || P[1]>Y[1])
17811: R=cons(0,R);
17812: else R=cons(P,R);
17813: }
17814: return reverse(R);
17815: }
17816:
1.81 takayama 17817: def pt5center(P,Q,R)
17818: {
1.83 ! takayama 17819: /* P=[1,[0,0]];Q=[[0,0],[1,0]];R=[[0,0],[0,1]]; */
! 17820: if(length(P)==2&&type(P[0])==4){ /* circle */
! 17821: if(type(Q)==4&&type(Q[1])==4){ /* line */
! 17822: A=myarg(lsub(Q));B=myarg(lsub(R));X0=ptcommon(Q,R);
! 17823: M=mrot(-A);N=mrot(A);X=M*ltov(X0);O=M*ltov(P[0]);
! 17824: if(!(L=B-A)) return 0;
! 17825: Pi=deval(@pi);for(;L<0;L+=Pi);for(;L>Pi;L-=Pi);
! 17826: XX=X[0]+y*deval(cos(L/2))/deval(sin(L/2));
! 17827: XY=X[1]+y;
! 17828: if(getopt(neg)==1){
! 17829: XX=subst(XX,y,-y);XY=subst(XY,y,-y);
! 17830: }
! 17831: /* mycat([[P[0],O],XX,XY]); */
! 17832: V=(XX-O[0])^2+(XY-O[1])^2;
! 17833: /* mycat(V-(y+P[0])^2); */
! 17834: S=polroots(V-(y+P[1])^2,y);
! 17835: S=append(polroots(V-(y-P[1])^2,y),S);
! 17836: S=qsort(S);V=ltov([XX,XY]);
! 17837: /* mycat([S,V,M,N,M*N]); */
! 17838: for(R0=[],ST=S;ST!=[];ST=cdr(ST)) R0=cons([vtol(N*subst(V,y,car(ST))), car(ST)],R0);
! 17839: /* mycat(R0); */
! 17840: for(R=[],F=1;R0!=[];R0=cdr(R0)){
! 17841: if(car(R0)[1]>=0) R=cons(car(R0),R);
! 17842: else{
! 17843: if(F){
! 17844: F=0; R=reverse(R);
! 17845: }
! 17846: R=cons(car(R0),R);
! 17847: }
! 17848: }
! 17849: /* mycat(R); */
! 17850: if(!F) R=reverse(R);
! 17851: return R;
! 17852: }
! 17853: }
1.81 takayama 17854: L=newvect(7);
17855: L[2]=ptcommon([P,Q],[P,R]|in=-1);
17856: Q1=ptcommon([P,R],[Q,0]);R1=ptcommon([P,Q],[R,0]);
17857: L[3]=ptcommon([Q,Q1],[R,R1]);
17858: P=ltov(P);Q=ltov(Q);R=ltov(R);
17859: A=dnorm([Q,R]);B=dnorm([P,R]);C=dnorm([P,Q]);
17860: L[0]=vtol((P+Q+R)/3);
17861: L[1]=vtol((A*P+B*Q+C*R)/(A+B+C));
17862: L[4]=vtol((-A*P+B*Q+C*R)/(-A+B+C));
17863: L[5]=vtol((A*P-B*Q+C*R)/(A-B+C));
17864: L[6]=vtol((A*P+B*Q-C*R)/(A+B-C));
17865: return vtol(L);
17866: }
17867:
1.6 takayama 17868: def lninbox(L,W)
17869: {
17870: if(L[0]==L[1]) return 0;
17871: R=newvect(2);C=newvect(2);
17872: for(J=0;J<2;J++){
17873: C[J]=L[1][J]-L[0][J];
17874: if(C[J]!=0){
17875: R[J]=[(W[J][0]-L[0][J])/C[J],(W[J][1]-L[0][J])/C[J]];
17876: if(R[J][0]>R[J][1]) R[J]=[R[J][1],R[J][0]];
17877: }
17878: }
17879: if(R[0]==0) R[0]=R[1];
17880: if(R[1]==0) R[1]=R[0];
17881: S0=(R[0][0]<R[1][0])?R[1][0]:R[0][0];
17882: S1=(R[0][1]<R[1][1])?R[0][1]:R[1][1];
17883: if(getopt(in)==1){
17884: if(S0<0) S0=0;
17885: if(S1>1) S1=1;
17886: }
17887: if(S0>S1) return 0;
17888: 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]];
17889: }
17890:
17891: def ptbbox(L)
17892: {
17893: J=length(L[0]);
17894: if((Box=getopt(box))==1){
17895: for(R=[],I=0;I<J;I++){
17896: P=car(LT=L)[I][0];Q=car(LT)[I][1];
17897: for(;LT!=[];LT=cdr(LT)){
17898: if((type(T=car(LT))==4 || type(T)==5) && length(T)==J){
17899: if(T[I][0]<P) P=T[I][0];
17900: if(T[I][1]>Q) Q=T[I][1];
17901: }
17902: }
17903: R=cons([P,Q],R);
17904: }
17905: }else if(type(Box)==4) return ptbbox([ptbbox(L),Box]|box=1);
17906: else{
17907: for(R=[],I=0;I<J;I++){
17908: P=Q=car(LT=L)[I];LT=cdr(LT);
17909: for(;LT!=[];LT=cdr(LT)){
17910: if((type(T=car(LT))==4||type(T)==5) && type(T[0])<2 && length(T)==J){
17911: if((V=T[I])<P) P=V;
17912: else if(V>Q) Q=V;
17913: }
17914: }
17915: R=cons([P,Q],R);
17916: }
17917: }
17918: return reverse(R);
17919: }
17920:
17921: def iscombox(S,T)
17922: {
17923: for(;S!=[];S=cdr(S),T=cdr(T))
17924: if(car(S)[0]>car(T)[1] || car(S)[1]<car(T)[0]) return 0;
17925: return 1;
17926: }
17927:
17928: def ptcopy(L,V)
17929: {
17930: if(type(V[0])!=4) V=[V];
17931: for(F=0,LL=[]; V!=[]; V=cdr(V)){
17932: if(F) LL=append(LL,[0]);
17933: F++;
17934: LL=append(LL,ptaffine(1,L|shift=car(V)));
17935: }
17936: }
17937:
1.58 takayama 17938: def regress(L)
17939: {
17940: E=deval(exp(0));
17941: for(S0=T0=0,S=L;S!=[];S=cdr(S)){
17942: S0+=car(S)[0]*E;T0+=car(S)[1]*E;
17943: }
17944: K=length(L);S0/=K;T0/=K;
17945: for(SS=TT=0,S=L;S!=[];S=cdr(S)){
17946: SS+=(car(S)[0]-S0)^2*E;TT+=(car(S)[1]-T0)^2*E;
17947: ST+=(car(S)[0]-S0)*(car(S)[1]-T0)*E;
17948: }
17949: if(!SS||!TT) return [];
17950: A=ST/SS;
17951: L=[A,A*S0-T0,ST/dsqrt(SS*TT),S0,dsqrt(SS/K),T0,dsqrt(TT/K)];
17952: if(isint(N=getopt(sint))){
17953: R=reverse(L);
17954: for(L=[];R!=[];R=cdr(R)) L=cons(sint(car(R),N|str=0),L);
17955: }
17956: return L;
17957: }
17958:
1.6 takayama 17959: def average(L)
17960: {
1.32 takayama 17961: if(getopt(opt)=="co"){
17962: S0=average(L[0]);V0=car(S0);
17963: S1=average(L[1]);V1=car(S1);
17964: L0=os_md.m2l(L[0]|flat=1);
17965: L1=os_md.m2l(L[1]|flat=1);
17966: for(S=0;L0!=[];L0=cdr(L0),L1=cdr(L1))
17967: S+=(car(L0)-V0)*(car(L1)-V1);
17968: S/=S0[1]*S1[1]*S0[2];
17969: S=[S,S0,S1];
17970: }else{
17971: L=os_md.m2l(L|flat=1);
17972: M0=M1=car(L);
17973: for(I=SS=0, LT=L; LT!=[]; LT=cdr(LT), I++){
17974: S+=(V=car(LT));
17975: SS+=V^2;
17976: if(V<M0) M0=V;
17977: else if(V>M1) M1=V;
17978: }
17979: SS=dsqrt(SS/I-S^2/I^2);
17980: S=[deval(S/I),SS,I,M0,M1];
1.6 takayama 17981: }
1.8 takayama 17982: if(isint(N=getopt(sint))) S=sint(S,N);
17983: return S;
1.6 takayama 17984: }
17985:
17986: def m2ll(M)
17987: {
17988: for(R=[],I=size(M)[0]-1; I>=0; I--)
17989: R=cons(vtol(M[I]),R);
17990: return R;
17991: }
17992:
17993: def madjust(M,W)
17994: {
17995: if(type(Null=getopt(null))<0) Null=0;
17996: if(type(M)==4 && type(M[0])==4){
17997: M=lv2m(M|null=Null);
17998: return m2ll(madjust(M,W|null=Null));
17999: }
18000: S=size(M);
18001: if(W<0){
18002: W=-W;
18003: T0=ceil(S[0]/W);
18004: T1=S[1]*W;
18005: N=newmat(T0,T1);
18006: for(I=0; I<T0; I++){
18007: for(K=0; K<W; K++){
18008: II=K*T0+I;
18009: for(J=0; J<S[1]; J++)
18010: N[I][S[1]*K+J]=(II<S[0])?M[II][J]:Null;
18011: }
18012: }
18013: }else{
18014: T1=W;
18015: T0=S[0]*(D=ceil(S[1]/T1));
18016: N=newmat(T0,T1);
18017: for(K=0; K<D; K++){
18018: for(J=0; J<W;J++){
18019: JJ=W*K+J;
18020: for(I=0; I<S[0]; I++)
18021: N[S[0]*K+I][J]=(JJ<S[1])?M[I][JJ]:Null;
18022: }
18023: }
18024: }
18025: return N;
18026: }
18027:
18028: def texcr(N)
18029: {
18030: if(!isint(N) || N<0 || N>127) return N;
18031: S=(iand(N,8))? "\\allowdisplaybreaks":"";
18032: if(iand(N,2)) S=S+"\\\\";
18033: if(iand(N,16)) S=S+"\\pause";
18034: if(iand(N,1)) S=S+"\n";
18035: if(iand(N,4)) S=S+"& ";
18036: else if(!iand(N,1)) S=S+" ";
18037: if(iand(N,64)) S=S+"=";
18038: if(iand(N,32)) S=","+S;
18039: return S;
18040: }
18041:
18042: def ltotex(L)
18043: {
18044: /* extern TeXLim; */
18045:
18046: if(type(L)==5)
18047: L = vtol(L);
18048: if(type(L) != 4)
18049: return my_tex_form(L);
18050: Opt=getopt(opt);
18051: Pre=getopt(pre);
18052: if(type(Var=getopt(var))<1) Var=0;
18053: Cr2="\n";
18054: if(type(Cr=getopt(cr))==4){
18055: Cr2=Cr[1];Cr=Cr[0];
18056: }
18057: if(isint(Cr)) Cr=texcr(Cr);
18058: if(type(Cr)!=7) Cr="\\\\\n & "; /* Cr=7 */
18059: if(type(Opt)==7) Opt=[Opt];
18060: if(type(Opt)!=4)
18061: Op = -1;
18062: else{
18063: Op=findin(Opt[0],["spt","GRS","Pfaff","Fuchs","vect","cr","text","spts","spts0",
18064: "dform","tab", "graph","coord"]);
18065: Opt=cdr(Opt);
18066: }
18067: if(Op==0){ /* spt */
18068: Out = str_tb("\\left\\{\n ",0);
18069: for(CC=0; L!=[]; L=cdr(L), CC++){
18070: if(CC>0) str_tb(",\\, ",Out);
18071: TP=car(L);
18072: if(Op!=0)
18073: str_tb(my_tex_form(TP),Out);
18074: else if(TP[0]==1)
18075: str_tb(my_tex_form(TP[1]),Out);
18076: else
18077: str_tb(["[", my_tex_form(TP[1]), "]_", rtotex(TP[0])],Out);
18078: }
18079: str_tb("%\n\\right\\}\n",Out);
18080: }else if(Op==1){ /* GRS */
18081: Out = string_to_tb("\\begin{Bmatrix}\n");
18082: if(type(Pre)==7) str_tb(Pre,Out);
18083: MC=length(M=ltov(L));
18084: for(ML=0, I=length(M); --I>=0; ){
18085: if(length(M[I]) > ML) ML=length(M[I]);
18086: }
18087: for(I=0; I<ML; I++){
18088: for(CC=J=0; J<MC; J++, CC++){
18089: if(length(M[J]) <= I){
18090: if(CC > 0) str_tb(" & ",Out);
18091: }else if(M[J][I][0] <= 1){
18092: if(M[J][I][0] == 0) str_tb(" & ",Out);
18093: else
18094: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
18095: }else
18096: str_tb([((!CC)?" [":" & ["), my_tex_form(M[J][I][1]), "]_",
18097: rtotex(M[J][I][0])], Out);
18098: }
18099: str_tb((I<ML-1)?"\\\\\n":"\n", Out);
18100: }
18101: str_tb("\\end{Bmatrix}",Out);
18102: }else if(Op==2){ /* Pfaff */
18103: V=monototex(Opt[0]);
18104: Out = string_to_tb("d"+V+"= \\Biggl(");
18105: Opt=cdr(Opt);
18106: II=length(Opt);
18107: for(I=0; I<II; I++){
18108: str_tb([(I>0)?" + ":" ",mtotex(L[I]),"\\frac{d",monototex(Opt[I]),"}{",
18109: my_tex_form(Opt[I]),(I==II-1)?"}\n":"}\n\\\\&\n"],Out);
18110: }
18111: str_tb(["\\Biggr)",V,"\n"],Out);
18112: }else if(Op==3){ /* Fuchs */
18113: Out = string_to_tb("\\frac{d");
18114: V=my_tex_form(Opt[0]);
18115: str_tb([V,"}{d",my_tex_form(Opt[1]),"}="] ,Out);
18116: Opt=cdr(Opt); Opt=cdr(Opt);
18117: II=length(Opt);
18118: for(I=0; I<II; I++){
18119: str_tb([(I>0)?" +":"\\Biggl(", " \\frac{",
18120: my_tex_form(L[I]),"}{", my_tex_form(Opt[I]),"}\n"],Out);
18121: }
18122: str_tb(["\\Biggr)",V,"\n"],Out);
18123: }else if(Op==4){ /* vect */
18124: Out=str_tb(mtotex(matc(L)|lim=0,var=Var),0);
18125: }else if(Op==5 || Op==6){ /* cr or text */
18126: Out = str_tb(0,0);
18127: if(type(Lim=getopt(lim))!=1) Lim=0;
18128: else if(Lim<30&&Lim>0) Lim=TeXLim;
18129: Str=getopt(str);
18130: if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1)
18131: Str=2;
18132: for(K=I=0; L!=[]; I++, L=cdr(L)){
18133: LT=car(L);
18134: if((!Lim||Op==6)&&I>0) str_tb((Op==5)?Cr:"\n",Out);
18135: if(Op==6){
18136: if(type(LT)==7){
18137: str_tb([LT," "],Out);
18138: I=-1;
18139: continue;
18140: }
18141: str_tb("$",Out);
18142: }
18143: KK=0;
18144: if(Str>0 && type(LT)==4 && Opt!=[])
18145: S=ltotex(LT|opt=car(Opt),lim=0,str=Str,cr=Cr2,var=Var);
18146: else if(type(LT)==6){
18147: if(Lim>0){
18148: S=mtotex(LT|var=Var,lim=0,len=1);
18149: KK=S[1];
18150: S=S[0];
18151: }else S=mtotex(LT|var=Var,lim=0);
18152: }else if(type(LT)==3 || type(LT)==2)
18153: S=fctrtos(LT|TeX=2,lim=0,var=Var);
18154: else S=my_tex_form(LT);
18155: if(Op!=6&&I>0&&Lim){
18156: if(Lim<0){
18157: if(I%(-Lim)==0)
18158: str_tb((Op==5)?Cr:"\n",Out);
18159: }else if((K+=(KK=(KK)?KK:texlen(S)))>Lim){
18160: str_tb((Op==5)?Cr:"\n",Out);
18161: K=KK;
18162: }
18163: }
18164: str_tb(S,Out);
18165: if(Op==6) str_tb("$",Out);
18166: }
18167: }else if(Op==7||Op==8){ /* spts, spts0 */
18168: if(type(Lim=getopt(lim))!=1 || (Lim<30 && Lim!=0))
18169: Lim=TeXLim;
18170: Str=getopt(str);
18171: Out = str_tb(0,0);
18172: for(K=0; L!=[]; L=cdr(L)){
18173: LT=car(L);
18174: KK=0;
18175: if(type(LT)==7 && Str==1) S=LT;
18176: else if(type(LT)==3 || type(LT)==2)
18177: S=fctrtos(LT|TeX=2,lim=0,var=Var);
18178: else if(type(LT)==6){
18179: if(Lim){
18180: S=mtotex(LT|var=Var,lim=0,len=1);
18181: KK=S[1];
18182: S=S[0];
18183: }else S=mtotex(LT|var=Var,lim=0);
18184: }else
18185: S=my_tex_form(LT);
18186: if(Lim!=0){
18187: if(!KK) KK=texlen(S);
18188: if(K>0 && K+KK>Lim){
18189: str_tb(Cr,Out);
18190: K=0;
18191: }
18192: }
18193: if(K>0){
18194: str_tb((Op==7)?"\\ ":" ",Out);
18195: if(type(LT)>3 && type(LT)<7) str_tb("%\n",Out);
18196: }
18197: str_tb(S,Out);
18198: K+=KK;
18199: if(OP==7) K++;
18200: }
18201: }else if(Op==9){ /* dform */
18202: Out=str_tb(0,0);
18203: for(I=0;L!=[];L=cdr(L),I++){
18204: for(J=0,LT=car(L); LT!=[]; LT=cdr(LT),J++){
18205: if(J==0){
18206: if((V=car(LT))==0) continue;
18207: if(I>0){
18208: if(type(V)==1){
18209: if(V<0){
18210: str_tb("-",Out);
18211: V=-V;
18212: }
18213: else str_tb("+",Out);
18214: if(V==1 && length(LT)>1) continue;
18215: str_tb(monototex(V),Out);
18216: continue;
18217: }
18218: else str_tb("+",Out);
18219: }
18220: }else if(J>0) str_tb((J>1)?"\\wedge d":"\\,d",Out);
18221: V=monototex(car(LT));
18222: if(V<"-" || V>=".") str_tb(V,Out);
18223: else str_tb(["(",V,")"],Out);
18224: }
18225: }
18226: }else if(Op==10 && type(L)==4 && type(car(L))==4){ /* tab */
18227: if(type(Null=getopt(null))<0) Null="";
18228: if(getopt(vert)==1){
18229: M=lv2m(L|null=Null);
18230: L=m2ll(mtranspose(M));
18231: }
18232: if(type(W=getopt(width))==1)
18233: L=madjust(L,W|null=Null);
18234: LV=ltov(L);
18235: S=length(LV);
18236: #if 1
18237: if(type(T=getopt(left))==4){
18238: T=str_times(T,S);
18239: for(L=[],I=0;I<S;I++){
18240: L=cons(cons(car(T),LV[I]),L);
18241: T=cdr(T);
18242: }
18243: LV=reverse(L);
18244: }
18245: if(type(T=getopt(right))==4){
18246: T=str_times(T,S);
18247: for(L=[],I=0;I<S;I++){
18248: L=cons(append(LV[I],[car(T)]),L);
18249: T=cdr(T);
18250: }
18251: LV=reverse(L);
18252: }
18253: for(I=CS=0; I<S; I++)
18254: if(length(LV[I])>CS) CS=length(LV[I]);
18255: if(type(T=getopt(top))==4){
18256: LV=cons(str_times(T,CS),vtol(LV));
18257: S++;
18258: }
18259: if(type(T=getopt(last))==4){
18260: LV=append(vtol(LV),[str_times(T,CS)]);
18261: S++;
18262: }
18263: #else
18264: for(I=CS=0; I<S; I++)
18265: if(length(LV[I])>CS) CS=length(LV[I]);
18266: #endif
18267: if(type(Title=getopt(title))!=7) Title="";
18268: if(type(Vline=getopt(vline))!=4) Vline=[0,CS];
18269: else Vline=subst(Vline,z,CS);
18270: for(VV=[],VT=Vline;VT!=[];VT=cdr(VT)){
18271: if(type(T=car(VT))==4 && T[1]>0){
18272: for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV);
18273: }else VV=cons(T,VV);
18274: }
18275: Vline=qsort(VV);
18276: Out=str_tb("\\begin{tabular}{",0);
18277: if(type(Al=getopt(align))==7 && str_len(Al)>1){
18278: str_tb(Al,Out);
18279: }else{
18280: if(type(Al)!=7 || str_len(Al)<1) Al="r";
18281: for(I=0;I<=CS;I++){
18282: if(I!=0) str_tb(Al,Out);
18283: while(Vline!=[] && car(Vline)==I){
18284: str_tb("|",Out);
18285: Vline=cdr(Vline);
18286: }
18287: }
18288: }
18289: str_tb("}",Out);
18290: if(Title!="")
18291: str_tb("\n\\multicolumn{"+rtostr(CS)+"}{c}{"+Title+"}\\\\",Out);
18292: if(type(Hline=getopt(hline))!=4) Hline=[0,S];
18293: else Hline=subst(Hline,z,S);
18294: for(VV=[],VT=Hline;VT!=[];VT=cdr(VT)){
18295: if(type(T=car(VT))==4 && T[1]>0){
1.14 takayama 18296: for(I=T[0];I<=S;I+=T[1]) VV=cons(I,VV);
1.6 takayama 18297: }else VV=cons(T,VV);
18298: }
18299: Hline=qsort(VV);
18300: while(Hline!=[] && car(Hline)==0){
18301: str_tb(" \\hline\n",Out);
18302: Hline=cdr(Hline);
18303: }
18304: /*
18305: if(type(getopt(left))==4) CS++;
18306: if(type(getopt(right))==4) CS++;
18307: if(type(T=getopt(top))==4){
18308: LV=cons(str_times(T,CS),vtol(LV));
18309: S++;
18310: }
18311: if(type(T=getopt(last))==4){
18312: LV=append(vtol(LV),[str_times(T,CS)]);
18313: S++;
18314: }
18315: if(type(T=getopt(left))==4){
18316: T=str_times(T,S);
18317: for(L=[],I=0;I<S;I++){
18318: L=cons(cons(car(T),LV[I]),L);
18319: T=cdr(T);
18320: }
18321: LV=reverse(L);
18322: }
18323: if(type(T=getopt(right))==4){
18324: T=str_times(T,S);
18325: for(L=[],I=0;I<S;I++){
18326: L=cons(append(LV[I],[car(T)]),L);
18327: T=cdr(T);
18328: }
18329: LV=reverse(L);
18330: }
18331: */
18332: for(I=0; I<S; I++){
18333: for(C=0,LT=LV[I];C<CS; C++){
18334: if(LT!=[]){
18335: P=car(LT);
18336: if(type(P)!=7) P="$"+my_tex_form(P)+"$";
18337: if(P!="") str_tb(P,Out);
18338: LT=cdr(LT);
18339: }
18340: if(C<CS-1) str_tb("& ",Out);
18341: }
18342: str_tb("\\\\",Out);
18343: while(Hline!=[] && car(Hline)==I+1){
18344: str_tb(" \\hline",Out);
18345: Hline=cdr(Hline);
18346: }
18347: str_tb("\n",Out);
18348: }
18349: str_tb("\\end{tabular}\n",Out);
18350: }else if(Op==11){ /* graph */
1.10 takayama 18351: if(type(Strip=getopt(strip))!=1) Strip=0;
18352: if(type(MX=getopt(max))!=1) MX=0;
18353: if(type(ML=getopt(mult))!=1) ML=0;
18354: if((REL=getopt(relative))!=1) REL=0;
18355: CL=getopt(color);
18356: OL=delopt(getopt(),["color","strip","mult"]);
18357: if(ML==1&&type(CL)==4){
18358: LL=L[1];L=L[0];K=length(L);S=T="";
18359: if(!MX){
18360: MX=vector(length(L[0]));
18361: for(LT=L;LT!=[];LT=cdr(LT)){
18362: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
18363: if(REL==1) MX[I]+=car(LTT);
18364: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
18365: }
18366: }
18367: MX=lmax(MX);
18368: OL=cons(["max",MX],OL);
18369: }
18370: if(REL==1) MX=newvect(length(L[0]));
18371: for(I=0;I<K;I++){
18372: for(R=[],J=length(L[I]);--J>=0;){
18373: if(REL==1){
18374: R=cons([MX[J],V=MX[J]+L[I][J]],R);
18375: MX[J]=V;
18376: }else R=cons([(!I)?0:L[I-1][J],L[I][J]],R);
18377: }
18378: OP=cons(["color",CL[I]],OL);
18379: S+=ltotex([R,LL]|option_list=cons(["value",0],cons(["strip",(!I)?1:2],OP)));
18380: T+=ltotex([R,LL]|option_list=cons(["strip",3],OP));
18381: }
18382: return(!Strip)?xyproc(S+T):(S+T);
18383: }else if(!TikZ) CL=0;
18384: if(type(Line=getopt(line))!=1){
18385: if(type(Line)==4){
18386: if(type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
18387: Opt=Line[1]; Line=Line[0];
18388: }else if(ML==1){
18389: OL=delopt(OL,"line");
18390: LL=L[1];L=L[0];K=length(L);S="";
18391: if(!MX){
1.15 takayama 18392: MX=newvect(length(L[0]));
1.10 takayama 18393: for(LT=L;LT!=[];LT=cdr(LT)){
18394: for(I=0,LTT=car(LT);LTT!=[];I++,LTT=cdr(LTT)){
18395: if(REL==1) MX[I]+=car(LTT);
18396: else if(MX[I]<car(LTT)) MX[I]=car(LTT);
18397: }
18398: }
18399: MX=lmax(MX);
18400: OL=cons(["max",MX],OL);
18401: }
1.15 takayama 18402: for(I=0;I<K;I++)
18403: S+=ltotex([L[I],LL]|option_list
1.10 takayama 18404: =cons(["line",Line[I]],cons(["strip",(!I)?1:2],OL)));
18405: return(!Strip)?xyproc(S):S;
18406: }
18407: }else Line=0;
18408: }else Opt="@{-}";
18409: Width=8; Hight=3; WRet=1/2; HMerg=(getopt(horiz)==1)?0.3:0.2;
1.6 takayama 18410: if(!TikZ){
1.7 takayama 18411: Width*=10; Hight*=10; HMerg*=10;
1.6 takayama 18412: }
1.10 takayama 18413: VMerg=HMerg;
18414: if(type(Shift=getopt(shift))!=1)
18415: Shift=0;
1.6 takayama 18416: if(type(V=getopt(size))==4){
18417: Width=V[0];Hight=V[1];
18418: if(length(V)>2) WRet=V[2];
1.10 takayama 18419: if(length(V)>3) VMerg=VMerg=V[3];
18420: if(length(V)>4) HMerg=V[4];
1.6 takayama 18421: }
18422: Val=getopt(value);
18423: if(!isint(Val)) Val=-1;
18424: if(type(Line=getopt(line))!=1){
18425: if(type(Line)==4 && type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
18426: Opt=Line[1]; Line=Line[0];
18427: }else Line=0;
18428: }else Opt="@{-}";
18429: if(type(car(L))==4){
18430: LL=L[1]; L=L[0];
18431: }else LL=[];
18432: if(Line==-1){
18433: for(Sum=0, LT=L; LT!=[]; LT=cdr(LT)){
18434: if((S=car(LT))<=0) return 0;
18435: Sum+=S;
18436: }
1.16 takayama 18437: for(R=[],LT=L;LT!=[];LT=cdr(LT)) R=cons(car(LT)/Sum,R);
1.6 takayama 18438: R=reverse(R);
18439: Opt0=Opt*2/3;
1.10 takayama 18440: Out=str_tb((Strip>0)?0:xyproc(1),0);
1.16 takayama 18441: if(type(CL)!=4) str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out);
1.6 takayama 18442: for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){
1.16 takayama 18443: SS=S+RT[0];
18444: if(type(CL)==4){
18445: str_tb(xyang(Opt,[0,0],(0.25-SS)*6.2832,(0.25-S)*6.2832|ar=1,opt=car(CL)),Out);
18446: if(length(CL)>0) CL=cdr(CL);
18447: }else str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out);
18448: T=(S+SS)/2;
18449: S=SS;
1.6 takayama 18450: if(LT!=[]){
1.16 takayama 18451: str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),car(LT)]),Out);
1.6 takayama 18452: LT=cdr(LT);
18453: }
18454: }
1.10 takayama 18455: if(!Strip) str_tb(xyproc(0),Out);
1.6 takayama 18456: return str_tb(0,Out);
18457: }
18458: if(MX==0){
18459: for(MX=0,LT=L; LT!=[]; LT=cdr(LT))
18460: if(car(LT)>MX) MX=car(LT);
18461: }
18462: MX-=Shift;
18463: S=length(L);
18464: WStep=Width/S;
18465: WWStep=WStep*WRet;
1.10 takayama 18466: HStep=(Hight<0)?-Hight:Hight/MX;
1.7 takayama 18467: if(LL!=[]&&length(LL)==S-1) WS2=WStep/2;
18468: else WS2=0;
1.10 takayama 18469: Out=str_tb((Strip>0)?0:xyproc(1),0);
18470: Hori=getopt(horiz);
18471: if(Strip<2){
18472: if(Hori==1) str_tb(xyline([0,0],[0,Width-WStep+WWStep]),Out);
18473: else str_tb(xyline([0,0],[Width-WStep+WWStep,0]),Out);
18474: }
1.6 takayama 18475: for(I=0,LT=L;LT!=[]; LT=cdr(LT),I++){
1.10 takayama 18476: XP=WStep*I; XPM=XP+WWStep/2;
18477: if(type(LTT=car(LT))==4){
18478: YP0=(car(LTT)-Shift)*HStep;YP=(LTT[1]-Shift)*HStep;
18479: VL=LTT[1];
18480: if(REL) VL-=LTT[0];
18481: }else{
18482: YP0=0;YP=(LTT-Shift)*HStep;VL=LTT;
18483: }
18484: if(Hori==1){
18485: if(Line!=0){
18486: if(I>0)
18487: str_tb(xyarrow([XPM,YP],[XPM-WStep,YPP]|opt=Opt),Out);
18488: if(Val!=0)
18489: str_tb(xyput([YP+HMerg, XPM,car(LT)]),Out);
18490: if(Line==2)
18491: str_tb(xyput([YP,XPM,"$\\bullet$"]),Out);
18492: YPP=YP;
18493: }else if(YP!=0 || Val==1){
18494: if(Strip!=3){
18495: if(CL) str_tb(xybox([[YP,XP+WWStep], [YP0,XP]]|color=CL),Out);
18496: else str_tb(xybox([[YP,XP+WWStep],[YP0,XP]]),Out);
18497: }
18498: if(Val!=0) str_tb(xyput([(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),XPM,VL]),Out);
18499: }
18500: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([-VMerg,XPM+WS2,LL[I]]),Out);
18501: }else{
18502: if(Line!=0){
18503: if(I>0)
18504: str_tb(xyarrow([XPM-WStep,YPP],[XPM,YP]|opt=Opt),Out);
18505: if(Val!=0)
18506: str_tb(xyput([XPM,YP+HMerg,car(LT)]),Out);
18507: if(Line==2)
18508: str_tb(xyput([XPM,YP,"$\\bullet$"]),Out);
18509: YPP=YP;
18510: }else if(YP!=0 || Val==1){
18511: if(Strip!=3){
18512: if(CL) str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]|color=CL),Out);
18513: else str_tb(xybox([[XP,YP0],[XP+WWStep,YP]]),Out);
18514: }
18515: if(Val!=0) str_tb(xyput([XPM,(YP<0||REL==1)?(YP-HMerg):(YP+HMerg),VL]),Out);
1.6 takayama 18516: }
1.10 takayama 18517: if(LL!=[]&&I<length(LL)&&Strip<2) str_tb(xyput([XPM+WS2,-VMerg,LL[I]]),Out);
1.6 takayama 18518: }
18519: }
1.10 takayama 18520: if(!Strip)str_tb(xyproc(0),Out);
1.6 takayama 18521: }else if(Op==12){ /* coord */
18522: Out=str_tb("(",0);
18523: for(LT=L;;){
18524: X=car(LT);
18525: if(type(X)>3 || imag(X)==0) str_tb(my_tex_form(X),Out);
18526: else{
18527: XR=real(X);XI=imag(X);
18528: S=monototex(imag(X));
18529: if(S=="1") S="";
18530: else if(S=="- 1") S="-";
18531: if(getopt(cpx)==2) S=S+"\\sqrt{-1}";
18532: else S=S+"i";
18533: if(XR!=0){
18534: if(str_char(S,0,"-")==0) S=monototex(XR)+S;
18535: else S=monototex(XR)+"+"+S;
18536: }
18537: str_tb(S,Out);
18538: }
18539: if((LT=cdr(LT))==[]) break;
18540: else str_tb(",",Out);
18541: }
18542: str_tb(")",Out);
18543: }
18544: else return my_tex_form(L);
18545: S = str_tb(0,Out);
18546: return (getopt(small)==1)?smallmattex(S):S;
18547: }
18548:
18549:
18550: def str_tb(L,TB)
18551: {
18552: if(type(TB) == 0) TB = "";
18553: if(L == 0)
18554: return (type(TB) == 7)?string_to_tb(TB):tb_to_string(TB);
18555: if(type(L) == 7)
18556: L = [L];
18557: else if(type(L) != 4){
18558: erno(0);
18559: return 0;
18560: }
18561: if(type(TB) <= 7)
18562: TB = string_to_tb((type(TB)==7)?TB:"");
18563: for(; L != []; L = cdr(L))
18564: write_to_tb(car(L), TB);
18565: return TB;
18566: }
18567:
18568: /*
18569: def redgrs(M,T)
18570: {
18571: L = [zzz];
18572: for(I=S=0,Eq=[],MT=M; MT!=[]; I++, MT=cdr(MT)){
18573: for(J=LS=0, N=car(MT); N!=[]; N=cdr(N)){
18574: X = makev([z,I,z,J]);
18575: L=cons(X,L);
18576: LS += X;
18577: S += car(N)[1]*X;
18578: }
18579: Eq = cons(LS-zzz,Eq);
18580: }
18581: Eq = cons(S-T,Eq);
18582: Sol= lnsol(Eq,L);
18583: for(LS=[],S=Sol; S!=[]; S=cdr(S)){
18584: T=car(S);
18585: if(type(S)!=4) return 0;
18586: LS=cons(car(S)[0],LS);
18587: }
18588: }
18589: */
18590:
18591: /* T=0 : all reduction
18592: =1 : construction procedure
18593: =2 : connection coefficient
18594: =3 : operator
18595: =4 : series expansion
18596: =5 : expression by TeX
18597: =6 : Fuchs relation
18598: =7 : All
18599: =8 : basic
18600: =9 : ""
18601: =10: irreducible
18602: =11: recurrence */
18603: def getbygrs(M, TT)
18604: {
18605: /* extern TeXEq; */
18606:
18607: if(type(M)==7) M=s2sp(M);
18608: if(type(M) != 4 || TT =="help"){
18609: mycat(
18610: ["getbygrs(m,t) or getbygrs(m,[t,s_1,s_2,...]|perm=?,var=?,pt=?,mat=?)\n",
18611: " m: generalized Riemann scheme or spectral type\n",
18612: " t: reduction, construct, connection, series, operator, TeX, Fuchs, irreducible, basic, recurrence,\n",
18613: " All\n",
18614: " s: TeX dviout simplify short general operator irreducible top0 x1 x2 sft\n",
18615: "Ex: getbygrs(\"111,21,111\", [\"All\",\"dviout\",\"operator\",\"top0\"])\n"]);
18616: return 0;
18617: }
18618: if(type(TT) == 4){
18619: T = TT[0];
18620: T1 = cdr(TT);
18621: }else{
18622: T = TT;
18623: T1 = [];
18624: }
18625: if(type(T) == 7)
18626: T = findin(T,["reduction","construct","connection", "operator", "series",
18627: "TeX", "Fuchs", "All", "basic", "", "irreducible", "recurrence"]);
18628: TeX = findin("TeX", T1);
18629: Simp = findin("simplify", T1);
18630: Short = findin("short", T1);
18631: Dviout= findin("dviout", T1);
18632: General=findin("general", T1);
18633: Op =findin("operator", T1);
18634: Irr =findin("irreducible", T1);
18635: Top0 =findin("top0",T1);
18636: X1 =findin("x1",T1);
18637: X2 =findin("x2",T1);
18638: Sft =findin("sft",T1);
18639: Title = getopt(title);
18640: Mat = getopt(mat);
18641: if(Mat!=1 || T<0 ||(T!=0&&T!=1&&T!=5&&T!=6&&T!=8&&T!=10&&T!=9)) Mat = 0;
18642: if(findin("keep",T1) >= 0)
18643: Keep = Dviout = 1;
18644: else Keep = 0;
18645: if(Dviout >= 0 || T == 5) TeX = 1;
18646: for(J = 0, MM = M; J == 0 && MM != []; MM = cdr(MM)){
18647: for(MI = car(MM); MI != []; MI = cdr(MI)){
18648: if(type(car(MI)) != 1 || car(MI) <= 0){
18649: J = 1; break;
18650: }
18651: }
18652: }
18653:
18654: /* spectral type -> GRS */
18655: if(J == 0){
18656: for(R = [], S = J = 0, MM = M; MM != []; MM = cdr(MM), J++){
18657: MT = qsort(car(MM));
18658: R = cons(reverse(MT), R);
18659: if(J == 1){
18660: S = length(MT)-1;
18661: if(MT[S] > MT[0]) S = 0;
18662: }
18663: }
18664: M = reverse(R);
18665: R = getopt(var);
18666: if(type(R)<1){
18667: for(R = [], I = J-1; I >= 0; I--)
18668: R = cons(asciitostr([97+I]), R);
18669: }
18670: Sft=(Sft>=0)?1:0;
18671: if(General < 0)
18672: Sft=-Sft-1;
18673: M = sp2grs(M,R,Sft|mat=Mat);
18674: }
18675: for(M0=[],MM=M;MM!=[];MM=cdr(MM)){ /* change "?" -> z_z */
18676: for(M1=[],Mm=car(MM);Mm!=[];Mm=cdr(Mm)){
18677: Mt=car(Mm);
18678: if(type(Mt)==4 && Mt[1]=="?"){
18679: M1=cons([Mt[0],z_z],M1);
18680: continue;
18681: }else if(type(Mt)==7 && Mt=="?"){
18682: M1=cons(z_z,M1);
18683: continue;
18684: }
18685: M1=cons(Mt,M1);
18686: }
18687: M0=cons(reverse(M1),M0);
18688: }
18689: M = fspt(reverse(M0),5); /* short -> long */
18690: if(findin(z_z,vars(M))>=0)
18691: M=subst(M,z_z,lsol(chkspt(M|mat=Mat)[3],z_z)); /* Fuchs relation */
18692: NP = length(M);
18693: Perm = getopt(perm);
18694: if(type(Perm) == 4)
18695: M = mperm(M,Perm,0);
18696: if(T == 9){ /* "" */
18697: if(Short >= 0)
18698: M = chkspt(M|opt=4,mat=Mat);
18699: return M;
18700: }
18701: R = [0,M];
18702: ALL = [R];
18703:
18704: while(type(R = redgrs(R[1]|mat=Mat)) == 4)
18705: ALL = cons(R, ALL);
18706: if(R < 0)
18707: return 0;
18708:
18709: /* TeX */
18710: if(TeX >= 0 && !chkfun("print_tex_form", "names.rr"))
18711: return 0;
18712: if(Dviout >= 0 && type(Title) == 7)
18713: dviout(Title|keep=1);
18714: if(T == 7 && Dviout >= 0){
18715: S=["keep","simplify"];
18716: if(Top0 >= 0)
18717: S = cons("top0",S);
18718: getbygrs(M,cons(5,S)|title="\\noindent Riemann Scheme",mat=Mat);
18719: Same = 0;
18720: if(R > 0){
18721: MM = getbygrs(M,8|mat=Mat); /* basic GRS */
18722: MS = chkspt(MM|opt=0,mat=Mat); /* spectral type */
18723: if(M != MM)
18724: getbygrs(MM,cons(5,S)|title="Basic Riemann Scheme",mat=Mat);
18725: else{
18726: dviout("This is a basic Riemann Scheme.\n\n\\noindent"|keep=1);
18727: Same = 1;
18728: }
18729: dviout(MS|keep=1);
18730: }
18731: if(chkspt(ALL[0][1]|mat=Mat)[3] != 0)
18732: getbygrs(M,cons(6,S)|title="Fuchs condition",mat=Mat);
18733: if(Same == 0){
18734: M1 = M[1];
18735: if(M1[length(M1)-1][0]==1 && Mat!=1){
18736: M1=M[2];
18737: if(M1[length(M1)-1][0] == 1){
18738: getbygrs(M,cons(2,S)|title="Connection formula");
18739: if(M1[length(M[0][0])-1][0] == 1 && R==0)
18740: getbygrs(M,cons(11,S)|title="Recurrence relation shifting the last exponents at $\\infty$, 0, 1");
18741: }
18742: getbygrs(M,cons(1,S)|title="Integral representation");
18743: getbygrs(M,cons(4,S)|title="Series expansion");
18744: }
18745: if(Irr < 0){
18746: TI="Irreduciblity $\\Leftrightarrow$ any value of the following linear forms $\\notin\\mathbb Z$";
18747: if(R > 0)
18748: TI += " + fundamental irreducibility";
18749: getbygrs(M,cons(10,S)|title=TI,mat=Mat);
18750: dviout("which coorespond to the decompositions"|keep=1);
18751: sproot(chkspt(M|opt=0),"pairs"|dviout=1,keep=1);
18752: }
18753: }
18754: if(Op >= 0 && Mat!=1) getbygrs(M,cons(3,S)|title="Operator");
18755: dviout(" ");
18756: return 1;
18757: }
18758: if(T == 0 && TeX >= 0){
18759: T = 1; TeX = 16;
18760: }
18761: /* Fuchs */
18762: Fuc = chkspt(ALL[0][1]|Mat=mat)[3];
18763: if(Fuc == 0) Simp = -1;
18764: if(type(Fuc) == 1){
18765: print("Violate Fuchs condition");
18766: return 0;
18767: }
18768: if(T == 6){
18769: if(Dviout >= 0) dviout(Fuc|eq=0,keep=Keep);
18770: return (TeX >= 0)?my_tex_form(Fuc):Fuc;
18771: }
18772: Fuc = [Fuc];
18773: /* Generelized Riemann scheme */
18774: if(T == 5){
18775: M = ltov(M);
18776: for(ML=0, I=0; I<NP; I++){
18777: L = length(M[I]);
18778: if(L > ML) ML = L;
18779: }
18780: Out = string_to_tb("P\\begin{Bmatrix}\nx=");
18781: if(Top0 < 0)
18782: write_to_tb("\\infty & ",Out);
18783: Pt = getopt(pt);
18784: if(type(Pt) == 4){
18785: for(J = 3; J < NP; J++){
18786: str_tb(["& ",rtotex(car(Pt))],Out);
18787: Pt = cdr(Pt);
18788: }
18789: }
18790: else if(X2>=0)
18791: str_tb("0 & x_2",Out);
18792: else
18793: str_tb((X1>=0)?"x_1 & x_2":"0 & 1",Out);
18794: for(J = 3; J < NP; J++)
18795: str_tb(["& x_",rtotex(J)],Out);
18796: if(Top0 >= 0)
18797: write_to_tb("& \\infty",Out);
18798: write_to_tb("\\\\\n",Out);
18799: for(I = 0; I < ML; I++){
18800: for(CC = 0, J = (Top0 >= 0)?1:0; ; J++, CC++){
18801: if(J == NP){
18802: if(Top0 < 0) break;
18803: J = 0;
18804: }
18805: if(length(M[J]) <= I){
18806: if(CC > 0) write_to_tb(" & ",Out);
18807: }else if(M[J][I][0] <= 1){
18808: if(M[J][I][0] == 0) str_tb(" & ",Out);
18809: else
18810: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
18811: }else{
18812: str_tb([((!CC)?"[":" & ["), my_tex_form(M[J][I][1]),
18813: (Mat==1)?"]_{":"]_{("],Out);
18814: str_tb([my_tex_form(M[J][I][0]),(Mat==1)?"}":")}"],Out);
18815: }
18816: if(Top0 >= 0 && J == 0)
18817: break;
18818: }
18819: if(I == 0)
18820: str_tb("&\\!\\!;x",Out);
18821: str_tb("\\\\\n",Out);
18822: }
18823: str_tb("\\end{Bmatrix}",Out);
18824: Out = str_tb(0,Out);
18825: if(Dviout >= 0)
18826: dviout(Out|eq=0,keep=Keep);
18827: return Out;
18828: }
18829:
18830: /* Reduction */
18831: if(T == 0){
18832: if(Simp >= 0)
18833: ALL = simplify(ALL,Fuc,4);
18834: return reverse(ALL);
18835: }
18836: LA = length(ALL) - 1;
18837: NP = length(ALL[0][1]);
18838:
18839: /* irreducible */
18840: if(T == 10){
18841: for(IR=[], I = 0; I < LA; I++){
18842: AI = ALL[I]; AIT = AI[1];
18843: K = AI[0][0];
18844: P = -AIT[0][K][1];
18845: P -= cterm(P);
18846: IR = cons(P, IR);
18847: for(J = 0; J < NP; J++){
18848: K = AI[0][J];
18849: for(L = length(AIT[J]) - 1; L >= 0 ; L--){
18850: if(L == K || AIT[J][L][0] <= AIT[J][K][0])
18851: continue;
18852: P = AIT[J][L][1] - AIT[J][K][1];
18853: Q = cterm(P);
18854: if(dn(Q)==1)
18855: P -= Q;
18856: IR = cons(P,IR);
18857: }
18858: }
18859: }
18860: P=Fuc[0];
18861: Q=cterm(P);
18862: if(type(Q)==1 && dn(Q)==1){
18863: for(F=0,V=vars(P);V!=[];V=cdr(V)){
18864: R=mycoef(P,1,car(V));
18865: if(type(R)!=1 || Q%R!=0){
18866: F=1; break;
18867: }
18868: }
18869: if(F==0){
18870: P-=Q;
18871: Simp=0;
18872: }
18873: }
18874: if(Simp >= 0){
18875: IR=simplify(IR,[P],4);
18876: for(R=[]; IR!=[]; IR=cdr(IR)){
18877: P=car(IR);
18878: Q=cterm(P);
18879: if(dn(Q)==1) P-=Q;
18880: R=cons(P,R);
18881: }
18882: IR=R;
18883: }
18884: for(R=[]; IR!=[]; IR=cdr(IR)){
18885: P=car(IR);
18886: if(str_len(rtostr(P)) > str_len(rtostr(-P)))
18887: P = -P;
18888: R = cons(P,R);
18889: }
18890: R = ltov(R);
18891: #ifdef USEMODULE
18892: R = qsort(R,os_md.cmpsimple);
18893: #else
18894: R = qsort(R,cmpsimple);
18895: #endif
18896: R = vtol(R);
18897: if(TeX >= 0){
18898: Out = string_to_tb("");
18899: for(I=L=K=0; R!=[]; R=cdr(R),I++){
18900: K1 = K;
18901: RS = my_tex_form(car(R));
18902: K = nmono(car(R));
18903: L += K;
18904: if(I){
18905: if(K1 == K && L < 30)
18906: str_tb("\\quad ",Out);
18907: else{
18908: L = K;
18909: str_tb((TeXEq==5)?["\\\\%\n &"]:["\\\\%\n "],Out);
18910: }
18911: }
18912: str_tb(RS,Out);
18913: }
18914: R = Out;
18915: if(Dviout>=0){
18916: dviout(R|eq=0,keep=Keep);
18917: return 1;
18918: }
18919: }
18920: return R;
18921: }
18922:
18923: AL = []; SS = 0;
18924: for(I = 0; I <= LA; I++){
18925: AI = ALL[I]; AIT = AI[1]; /* AIT: GRS */
18926: if(I > 0){
18927: for(S = J = 0; J < NP; J++){
18928: GE = AIT[J][AI0[J]][1];
18929: S += GE;
18930: if(J == 0)
18931: SS = [];
18932: else
18933: SS = cons(GE,SS);
18934: }
18935: SS = cons(1-Mat-S, reverse(SS));
18936: }
18937: AI0 = AI[0];
18938: AL = cons([SS, cutgrs(AIT)], AL);
18939: }
18940: AL = reverse(AL);
18941: AD = newvect(NP);
18942: ALT = AL[0][1];
18943: for(J = 1; J < NP; J++){
18944: /* AD[J] = ALT[J][0][1]; [J][?][1] <- [J][?][0]: max */
18945: for(MMX=0, K = KM = length(ALT[J])-1; K >= 0; K--){
18946: if(MMX <= ALT[J][K][0]){
18947: if(J == 1 && MMX == ALT[J][K][0])
18948: continue;
18949: KM = K;
18950: MMX = ALT[J][K][0];
18951: }
18952: }
18953: AD[J] = ALT[J][KM][1];
18954: }
18955: AL = cdr(AL);
18956: AL = cons([vtol(AD), ALT], AL);
18957: AL = cons([0, mcgrs(ALT, [vtol(-AD)]|mat=Mat)], AL);
18958: if(Simp >= 0 && T != 3)
18959: AL = simplify(AL,Fuc,4);
18960: /* Basic */
18961: if(T == 8){
18962: ALT = AL[0][1];
18963: if(TeX >= 0){
18964: if(Dviout >= 0){
18965: return getbygrs(ALT,["TeX","dviout","keep"]);
18966: }
18967: return getbygrs(ALT,"TeX");
18968: }
18969: if(Short >= 0)
18970: ALT = chkspt(ALT|opt=4);
18971: return ALT;
18972: }
18973:
18974: /* Construct */
18975: if(T == 1){
18976: if(TeX >= 0){
18977: L = length(AL);
18978: I = Done = 0; Out0=Out1=""; NM = DN = [];
18979: if(TeX != 16){
18980: AL11=AL[L-1][1][1];
18981: AT = AL11[length(AL11)-1];
18982: if(type(AT) == 4){
18983: PW = (AT[0] > 1)?"":AT[1];
18984: }else PW = AT;
18985: }
18986: Out = string_to_tb("");
18987: while(--L >= 0){
18988: if(TeX == 16){
18989: if(Done)
18990: write_to_tb(":\\ ", Out);
18991: write_to_tb(getbygrs(AL[L][1],(Top0>=0)?["TeX", "top0"]:"TeX"|mat=Mat), Out);
18992: Done = 1;
18993: if(L != 0) write_to_tb((TeXEq==5)?
18994: "\\\\%\n&\\leftarrow ":"\\\\%\n\\leftarrow ", Out);
18995: }
18996: ALT = AL[L][0];
18997: if(TeX != 16){
18998: V1 = (I==0)?"x":V2;
18999: V2 = /* (I==0 && L<=2)?"s": */
19000: "s_"+rtotex(I);
19001: }else V1=V2="x";
19002: JJ = (type(ALT) == 4)?length(ALT):0;
19003: if(I > 0 && L > 0)
19004: write_to_tb("\n ", Out);
19005: for(Outt = "", J = 1; J < JJ; J++){
19006: if(ALT[J] == 0) continue;
19007: if(J == 1) Outt += V1;
19008: else if(J == 2) Outt += "(1-"+V1+")";
19009: else Outt += "(x_"+rtotex(J)+"-"+V1+")";
19010: Outt += "^"+ rtotex(ALT[J]);
19011: }
19012: if(TeX != 16) write_to_tb(Outt, Out);
19013: else if(Outt != "")
19014: str_tb(["\\mathrm{Ad}\\Bigl(",Outt,"\\Bigr)"], Out);
19015: if(JJ == 0){
19016: if(I != 0)
19017: Out1 = "ds_"+rtotex(I-1)+Out1;
19018: continue;
19019: }
19020: if(ALT[0] == 0) continue;
19021: Out0 += "\\int_p^{"+V1+"}";
19022: if(TeX == 16)
19023: str_tb(["mc_",rtotex(ALT[0])], Out);
19024: else{
19025: str_tb(["(",V1,"-",V2,")^",rtotex(-1+ALT[0])], Out);
19026: AL11=AL[L-1][1][1];
19027: AT = AL11[length(AL11)-1];
19028: if(type(AT) == 4) AT = AT[1];
19029: DN = cons(ALT[0]+AT+1,DN);
19030: NM = cons(AT+1,cons(ALT[0],NM));
19031: }
19032: if(L != 2) Out1 += "d"+V2;
19033: I++;
19034: }
19035: if(R){
19036: if(I == 0) Ov = "x";
19037: else Ov = "s_"+rtotex(I-1);
19038: Out1 = "u_B("+Ov+")"+Out1;
19039: }
19040: if(TeX != 16){
19041: Out0 = string_to_tb(Out0);
19042: str_tb([Out, Out1], Out0);
19043: Out = Out0;
19044: NM = simplify(NM, Fuc, 4);
19045: DN = simplify(DN, Fuc, 4);
19046: DNT = lsort(NM,DN,"reduce");
19047: NMT = DNT[0]; DNT = DNT[1];
19048: if(NMT != [] && PW != ""){
19049: write_to_tb((TeXEq==5)?"\\\\\n &\\sim\\frac{\n"
19050: :"\\\\\n \\sim\\frac{\n", Out);
19051: for(PT = NMT; PT != []; PT = cdr(PT))
19052: str_tb([" \\Gamma(",my_tex_form(car(PT)), ")\n"], Out);
19053: write_to_tb(" }{\n", Out);
19054: for(PT = DNT; PT != []; PT = cdr(PT))
19055: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
19056: write_to_tb(" }", Out);
19057: if(R > 0) write_to_tb("C_0", Out);
19058: write_to_tb("x^"+rtotex(PW) +"\\ \\ (p=0,\\ x\\to0)", Out);
19059: }
19060: }else
19061: Out = str_tb(0, Out);
19062: if(Dviout >= 0){
19063: dviout(Out|eq=0,keep=Keep);
19064: return 1;
19065: }
19066: return O;
19067: }
19068: if(Short >= 0){
19069: for(ALL = [] ; AL != []; AL = cdr(AL)){
19070: AT = car(AL);
19071: ALL = cons([AT[0], chkspt(AT[1]|opt=4)], ALL);
19072: }
19073: AL = reverse(ALL);
19074: }
19075: return AL; /* AL[0][1] : reduced GRS, R==0 -> rigid */
19076: }
19077:
19078: if(T == 2 || T == 4 || T == 11){
19079: for(I = (T==2)?2:1; I >= (T==11)?0:1; I--){
19080: ALT = M[I];
19081: if(ALT[length(ALT)-1][0] != 1){
19082: mycat(["multiplicity for",I,":",ALT[length(ALT)-1][1],
19083: "should be 1"]);
19084: return;
19085: }
19086: }
19087: }
19088: LA++;
19089: NM = DN = [];
19090:
19091: /* Three term relation */
19092: if(T == 11){
19093: if(R > 0){
19094: print("This is not rigid\n");
19095: return 0;
19096: }
19097: for(I = 0; I <= LA; I++){
19098: if(I > 0){
19099: AI = AL[I][0]; /* operation */
19100: if(AI[0] != 0){
19101: DN = cons(simplify(AI1+1,Fuc,4),DN);
19102: NM = cons(simplify(AI1+AI[0]+1,Fuc,4),NM);
19103: }
19104: }
19105: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
19106: }
19107: DNT = lsort(NM,DN,"reduce");
19108: if(TeX < 0) return DNT;
19109: NMT = DNT[0]; DNT = DNT[1];
19110: Out = str_tb("u_{0,0,0}-u_{+1,0,-1}=\\frac{","");
19111: for(PT = NMT; PT != []; PT = cdr(PT))
19112: str_tb(["(",my_tex_form(car(PT)),")"], Out);
19113: str_tb(["}\n{"],Out);
19114: for(PT = DNT; PT != []; PT = cdr(PT))
19115: str_tb(["(",my_tex_form(car(PT)),")"], Out);
19116: write_to_tb("}u_{0,+1,-1}",Out);
19117: if(Dviout >= 0){
19118: dviout(Out|eq=0,keep=Keep);
19119: return 1;
19120: }
19121: return Out;
19122: }
19123:
19124: AD=newvect(NP);
19125: for(I = 0; I <= LA; I++){
19126: if(I > 0){
19127: AI = AL[I][0]; /* operation */
19128: if(T == 2 && AI[0] != 0){
19129: DN = cons(simplify(-AI2,Fuc,4), cons(simplify(AI1+1,Fuc,4),DN));
19130: NM = cons(simplify(-AI2-AI[0],Fuc,4), cons(simplify(AI1+AI[0]+1,Fuc,4),
19131: NM));
19132: }
19133: for(J = 1; J < NP; J++)
19134: AD[J] += simplify(AI[J],Fuc,4);
19135: }
19136: if(T == 2){
19137: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
19138: ALT = AL[I][1][2]; AI2 = ALT[length(ALT)-1][1];
19139: if(I == 0){
19140: C3 = AI1; C4 = AI2;
19141: }
19142: }
19143: }
19144:
19145: /* Connection */
19146: if(T == 2){
19147: DNT = lsort(NM,DN,"reduce");
19148: NMT = DNT[0]; DNT = DNT[1];
19149: if(TeX < 0) return [NMT,DNT,AD];
19150: C0 = M[1][length(M[1])-1][1];
19151: C1 = M[2][length(M[2])-1][1];
19152: M = AL[0][1];
19153: C3 = M[1][length(M[1])-1][1];
19154: C4 = M[2][length(M[2])-1][1];
19155: Out = str_tb(["c(0\\!:\\!", my_tex_form(C0),
19156: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C1),")"], "");
19157: if(R > 0 && AMSTeX == 1 && (TeXEq == 4 || TeXEq == 5)){
19158: write_to_tb("\\\\\n", Out);
19159: if(TeXEq == 5) write_to_tb(" &", Out);
19160: }
19161: write_to_tb("=\\frac{\n",Out);
19162: for(PT = NMT; PT != []; PT = cdr(PT))
19163: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
19164: write_to_tb(" }{\n",Out);
19165: for(PT = DNT; PT != []; PT = cdr(PT))
19166: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n",Out);
19167: write_to_tb(" }", Out);
19168: for(J = 3; J < length(AD); J++){
19169: if(AD[J] == 0) continue;
19170: str_tb(["\n (1-x_", rtotex(J), "^{-1})^", rtotex(AD[J])], Out);
19171: }
19172: if(R != 0)
19173: str_tb(["\n c_B(0\\!:\\!", my_tex_form(C3),
19174: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C4), ")"], Out);
19175: Out = tb_to_string(Out);
19176: if(Dviout >= 0){
19177: dviout(Out|eq=0,keep=Keep);
19178: return 1;
19179: }
19180: return Out;
19181: }
19182:
19183: /* Series */
19184: if(T == 4){
19185: AL11 = AL[0][1][1];
19186: V = AL11[length(AL11)-1][1];
19187: S00 = -V; S01 = (R==0)?[]:[[0,0]];
19188: S1 = S2 = [];
19189: for(Ix = 1, ALL = cdr(AL); ALL != []; ){
19190: ALT = ALL[0][0];
19191: if(ALT[0] != 0){ /* mc */
19192: for(Sum = [], ST = S01; ST != []; ST = cdr(ST))
19193: Sum = cons(car(ST)[0], Sum);
19194: S1 = cons(cons(S00+1,Sum), S1);
19195: S2 = cons(cons(S00+1+ALT[0],Sum),S2);
19196: S00 += ALT[0];
19197: }
19198: ALL = cdr(ALL);
19199: for(I = 1; I < length(ALT); I++){ /* addition */
19200: if(I == 1){
19201: S00 += ALT[1];
19202: if(ALL == [])
19203: S00 = [S00];
19204: }else{
19205: if(ALT[I] == 0)
19206: continue;
19207: if(ALL != []){
19208: S1 = cons([-ALT[I],Ix],S1);
19209: S2 = cons([1,Ix],S2);
19210: S01= cons([Ix,I],S01);
19211: Ix++;
19212: }else
19213: S00 = cons([ALT[I],I],S00);
19214: }
19215: }
19216: }
19217: S00 = reverse(S00);
19218: S01 = qsort(S01); S1 = qsort(S1); S2 = qsort(S2);
19219: if(Simp >= 0){
19220: S00 = simplify(S00,Fuc,4);
19221: S01 = simplify(S01,Fuc,4);
19222: S1 = simplify(S1,Fuc,4);
19223: S2 = simplify(S2,Fuc,4);
19224: SS = lsort(S1,S2,"reduce");
19225: S1 = SS[0]; S2 = SS[1];
19226: }
19227:
19228: if(TeX >= 0){
19229: /* Top linear power */
19230: TOP = Ps = Sm = "";
19231: for(TOP = Ps = Sm = "", ST = cdr(S00); ST != []; ST = cdr(ST)){
19232: SP = car(ST);
19233: if(SP[0] != 0){
19234: if(SP[1] == 2)
19235: TOP += "(1-x)^"+rtotex(SP[0]);
19236: else
19237: TOP += "(1-x/x_"+rtotex(SP[1])+")^"+rtotex(SP[0]);
19238: }
19239: }
19240: /* Top power */
19241: PW = my_tex_form(car(S00));
19242: if(PW == "0")
19243: PW = "";
19244: NP = length(AL[0][1]);
19245: PWS = newvect(NP);
19246: for(I = 0; I < NP; I++)
19247: PWS[I] = "";
19248: for(S = S01, I = 0; S != []; S = cdr(S), I++){
19249: SI = rtotex(car(S)[0]);
19250: if(I > 0) Sm += ",\\ ";
19251: Sm += "n_"+SI+"\\ge0";
19252: if(PW != "")
19253: PW += "+";
19254: PW += "n_"+SI;
19255: if(car(S)[1] > 2)
19256: PWS[car(S)[1]] += "-n_"+rtotex(car(S)[0]);
19257: else if(car(S)[1] == 0)
19258: Ps = "C_{n_0}"+Ps;
19259: }
19260: for(I = 3; I < NP; I++){
19261: if(PWS[I] != "")
19262: Ps += "x_"+rtotex(I)+"^{"+PWS[I]+"}";
19263: }
19264: Out = str_tb([TOP, Ps, "x^{", PW, "}"], "");
19265: /* Gamma factor */
19266: for(I = 0, SS = S1; I <= 1; I++, SS = S2){
19267: PW = string_to_tb("");
19268: for(PW1=""; SS != [] ; SS = cdr(SS)){
19269: for(J = 0, SST = car(SS); SST != []; SST = cdr(SST), J++){
19270: if(J == 0){
19271: JJ = (car(SST) == 1)?((length(SST)==2)?(-1):0):1;
19272: if(JJ > 0)
19273: str_tb(["(", my_tex_form(car(SST)), ")_{"], PW);
19274: else if(JJ == 0)
19275: PW1 = "(";
19276: }else{
19277: if(JJ > 0){
19278: if(J > 1) write_to_tb("+", PW);
19279: str_tb(["n_", rtotex(car(SST))], PW);
19280: }else{
19281: if(J > 1) PW1 += "+";
19282: PW1 += "n_"+rtotex(car(SST));
19283: }
19284: }
19285: }
19286: if(JJ > 0) write_to_tb("}", PW);
19287: else PW1 += (JJ == 0)?")!":"!";
19288: }
19289: if(I == 0)
19290: Out0 = "\\frac";
19291: Out0 += "{"+tb_to_string(PW)+PW1+"}";
19292: PW = string_to_tb(""); PW1 = "";
19293: }
19294: if(Out0 == "\\frac{}{}")
19295: Out0 = "";
19296: Out = "\\sum_{"+Sm+"}"+Out0 + Top + tb_to_string(Out);
19297: if(length(S01) == 1){
19298: Out = str_subst(Out, "{n_"+SI+"}", "n");
19299: Out = str_subst(Out, "n_"+SI, "n");
19300: }
19301: if(Dviout >= 0)
19302: dviout(Out|eq=0,keep=Keep);
19303: return Out;
19304: }
19305: return [cons(S00, S01), S1, S2];
19306: }
19307:
19308: /* Operator */
19309: if(T==3){
19310: Fuc0 = car(Fuc);
19311: if(Fuc0 != 0){ /* Kill Fuchs relation */
19312: for(V = vars(Fuc0); V != []; V = cdr(V)){
19313: VT = car(V);
19314: if(deg(Fuc0,VT) == 1){
19315: AL = mysubst(AL, [VT, -red(coef(Fuc0,0,VT)/coef(Fuc0,1,VT))]);
19316: break;
19317: }
19318: }
19319: if(V == []){
19320: print("Fuchs condition has no variable with degree 1");
19321: return 0;
19322: }
19323: }
19324: L = newvect(NP);
19325: Pt = getopt(pt);
19326: for(I = NP-1; I >= 1; I--){
19327: if(type(Pt) == 4)
19328: L[I] = Pt[I-1];
19329: else if(I >= 3 || X1 >= 0 || (X2 >= 0 && I >= 2))
19330: L[I] = makev(["x_", I]);
19331: else L[I] = I-1;
19332: }
19333: if(R){ /* non-rigid basic */
19334: MM = AL[0][1]; /* Riemann scheme */
19335: for(OD = 0, MT = car(MM); MT != []; MT = cdr(MT))
19336: OD += car(MT)[0];
19337: for(V = DN = [], M = MM; M != []; M = cdr(M)){
19338: MT = car(M); /* exponents */
19339: for(K = KM = 0, NT = []; ; K++){
19340: for(J = 0, P = 1, MTT = MT; MTT != []; MTT = cdr(MTT)){
19341: if(J == 0 && car(MTT)[1] == 0)
19342: KM = car(MTT)[0];
19343: for(KK = car(MTT)[0] - K -1; KK >= 0; KK--)
19344: P *= (dx-car(MTT)[1]-KK);
19345: }
19346: if(P == 1) break;
19347: NT = cons(P,NT);
19348: }
19349: V = cons(reverse(NT), V);
19350: DN = cons(KM, DN);
19351: }
19352: V = ltov(reverse(V)); /* conditions for GRS */
19353: DN = ltov(reverse(DN)); /* dims of local hol. sol. */
19354: for(J = OD; J >= 0; J--){
19355: for(I = Q = 1; I < NP; I++){
19356: if(J > DN[I])
19357: Q *= (x-L[I])^(J-DN[I]);
19358: }
19359: K = mydeg(Q,x);
19360: if(J == OD){
19361: P = Q*dx^J;
19362: DM = K;
19363: }else{
19364: for(I = DM-OD+J-K; I >= 0; I--){
19365: X = makev(["r",J,"_",I]);
19366: P += Q*x^I*X*dx^J;
19367: }
19368: }
19369: }
19370: for(R = [], I = 0; I < NP; I++){
19371: Q = toeul(P, [x,dx], (I==0)?"infty":L[I]); /* Euler at I-th pt */
19372: for(VT = V[I], J=0; VT != [] ; VT = cdr(VT), J++){
19373: if(car(VT) != 0)
19374: R = cons(rpdiv(coef(Q,J,x), car(VT), dx)[0], R); /* equations */
19375: }
19376: }
19377: for(RR = RRR = [], I = OD-1; I>=0; I--){
19378: RR = [];
19379: for(RT = R; RT != [] ; RT = cdr(RT)){
19380: if( (VT = mycoef(car(RT), I, dx)) != 0)
19381: RR = cons(VT, RR); /* real linear eqs */
19382: }
19383: J = mydeg(mycoef(P,I,dx),x);
19384: for(S = 0, VVV = []; J >= 0; J--){
19385: X = makev(["r",I,"_",J]);
19386: VVV = cons(X, VVV); /* unknowns */
19387: }
19388: RR = lsol(RR,VVV);
19389: LN = length(RR);
19390: for(K=0; K<LN; K++){
19391: RRT = RR[K];
19392: if(type(RRT) != 4) continue;
19393: R = mysubst(R,RRT);
19394: P = mysubst(P,RRT);
19395: }
19396: }
19397: }else /* Rigid case */
19398: P = dx^(AL[0][1][0][0][0]);
19399: /* additions and middle convolutions */
19400: for(ALT = AL; ALT != []; ALT = cdr(ALT)){
19401: AI = car(ALT)[0];
19402: if(type(AI) != 4) continue;
19403: V = ltov(AI);
19404: if(V[0] != 0) P = mc(P,x,V[0]);
19405: for(I = 1; I < NP; I++){
19406: if(V[I] != 0)
19407: P = sftexp(P,x,L[I],-V[I]);
19408: }
19409: }
19410: P = (Simp>=0)? simplify(P,Fuc,4|var=[dx]):simplify(P,Fuc,4);
19411: if(TeX >= 0){
19412: Val = 1;
19413: if(mydeg(P,dx) > 2 && AMSTeX == 1 && TeXEq > 3)
19414: Val = (TeXEq==5)?3:2;
19415: Out = fctrtos(P|var=[dx,"\\partial"],TeX=Val);
19416: if(Dviout < 0) return Out;
19417: dviout(Out|eq=0,keep=Keep);
19418: return 1;
19419: }
19420: return P;
19421: }
19422: return 0;
19423: }
19424:
19425: def mcop(P,M,S)
19426: {
19427: for(V=[],ST=S;ST!=[];ST=cdr(ST))
19428: if(isvar(VT=car(ST))) V=cons(vweyl(VT),V);
19429: V=reverse(V);
19430: N=length(V);
19431: for(MT=M;MT!=[];MT=cdr(MT)){
19432: T=car(MT);
19433: if(T[0]!=0)
19434: P=mc(P,V[0],T[0]);
19435: for(TT=cdr(T),ST=cdr(S);ST!=[];TT=cdr(TT),ST=cdr(ST))
19436: if(car(TT)!=0) P=sftpexp(P,V,S[0]-ST[0],-car(TT));
19437: }
19438: return P;
19439: }
19440:
19441: /* option: zero, all, raw */
19442: def shiftop(M,S)
19443: {
19444: if(type(M)==7) M=s2sp(M);
19445: if(type(S)==7) S=s2sp(S);
19446: Zero=getopt(zero);
19447: NP=length(M);
19448: for(V=L=[],I=NP-1; I>=0; I--){
19449: V=cons(strtov(asciitostr([97+I])),V);
19450: if(I>2) L=cons(makev(["y_", I-1]),L);
19451: else L=cons(I-1,L);
19452: }
19453: if(type(M[0][0])==4){
19454: F=1;RS=M;SS=S;
19455: R=chkspt(M);
19456: if(R[2]!=2 || R[3]!=0){
19457: mycat("GRS is not valid!");return 0;
19458: }
19459: for(; S!=[]; S=cdr(S)){
19460: if(nmono(S[0][0])!=1) break;
19461: if(isint(S[0][1]-S[0][0])==0) break;
19462: }
19463: if(S!=[]){
19464: mycat("Error in shift!"); return 0;
19465: }
19466: }else{
19467: F=0;
19468: RS=sp2grs(M,V,[1,length(M[0]),1]);
19469: for(SS=S0=[],I=0; I<NP; I++){
19470: for(J=F=0; J<length(M[I]); J++){
19471: if(I==0 && J==length(M[0])-1) break;
19472: if((U=S[I][J])!=0){
19473: if(isint(U)!=1){
19474: mycat("Error in shift!"); return 0;
19475: }
19476: VT=RS[I][J][1];
19477: SS=cons([VT,VT+U],SS);
19478: }else if(I>0 && Zero==1 && F==0){
19479: RS=mysubst(RS,[RS[I][J][1],0]);
19480: F=J+1;
19481: }
19482: }
19483: if((F>0 && J==2) || (I==0 && J==1)){
19484: J=(I==0)?0:2-F; VT=RS[I][J][1];
19485: S0=cons([VT,strtov(asciitostr([strtoascii(rtostr(VT))[0]]))],S0);
19486: }
19487: }
19488: }
19489: RS1=mysubst(RS,SS);
19490: if(F==1){
19491: R=chkspt(RS1);
19492: if(R[2]!=2 || R[3]!=0){
19493: mycat("Error in shift!");
19494: return 0;
19495: }
19496: }
19497: R=getbygrs(RS,1); R1=getbygrs(RS1,1);
19498: RT=R[0][1][0];
19499: if(length(RT)!=1 || RT[0][0]!=1){
19500: mycat("Not rigid!");
19501: return 0;
19502: }
19503: P=dx;Q=Q1=1;
19504: for(RT = R, RT1=R1; RT != []; RT = cdr(RT), RT1=cdr(RT1)){
19505: V=car(RT)[0]; V1=car(RT1)[0];
19506: if(type(V) != 4) continue;
19507:
19508: if(V[0] != 0){
19509: P = mc(P,x,V[0]); /* middle convolution */
19510: QT = mc(Q,x,V[0]);
19511: }else QT=Q;
19512: D0=mydeg(Q,dx);D0T=mydeg(QT,dx);
19513: C0=red(mycoef(Q,D0,dx)/mycoef(QT,D0T,dx));
19514: if(C0!=1) QT=red(C0*QT);
19515:
19516: if(V1[0] != 0) Q1T = mc(Q1,x,V1[0]);
19517: else Q1T=Q1;
19518: D1=mydeg(Q1,dx);D1T=mydeg(Q1T,dx);
19519: C1=red(mycoef(Q1,D1,dx)/mycoef(Q1T,D1T,dx));
19520: if(C1!=1) Q1T=red(C1*Q1T);
19521: DD=(V[0]-V1[0])+(D0-D0T)-(D1-D1T);
19522: if(DD>0){
19523: QT=muldo(dx^DD,QT,[x,dx]);
19524: D0T+=DD;
19525: }else if(DD<0){
19526: Q1T=muldo(dx^(-DD),Q1T,[x,dx]);
19527: D1T-=DD;
19528: }
19529: C=mylcm(dn(QT),dn(Q1T),x);
19530: if(C!=1){
19531: QT=red(C*QT); Q1T=red(C*Q1T);
19532: }
19533: Q=QT;Q1=Q1T;
19534: for(I = 1; I < NP; I++){
19535: if(V[I]!=0){
19536: P = sftexp(P,x,L[I],-V[I]); /* addition u -> (x-L[I])^V[I]u */
19537: QT = sftexp(QT,x,L[I],-V[I]);
19538: }
19539: if(V1[I]!=0)
19540: Q1T = sftexp(Q1T,x,L[I],-V1[I]);
19541: }
19542: C=red(mycoef(QT,D0T,dx)*mycoef(Q1,D1T,dx)/(mycoef(Q,D0T,dx)*mycoef(Q1T,D1T,dx)));
19543: Q=red(dn(C)*QT);Q1=red(nm(C)*Q1T);
19544: for(I = 1; I < NP; I++){
19545: if((J=V[I]-V1[I])!=0){
19546: if(J>0) Q1*=(x-L[I])^J;
19547: else Q*=(x-L[I])^(-J);
19548: }
19549: while((QT=tdiv(Q,x-L[I]))!=0){
19550: if((Q1T=tdiv(Q1,x-L[I]))!=0){
19551: Q=QT;Q1=Q1T;
19552: }else break;
19553: }
19554: }
19555: }
19556: P1=mysubst(P,SS);
19557: if(type(S0)==4 && S0!=[]){
19558: P=mysubst(P,S0); Q=mysubst(Q,S0);
19559: P1=mysubst(P1,S0); Q1=mysubst(Q1,S0);
19560: RS=mysubst(RS,S0); RS1=mysubst(RS1,S0);
19561: }
19562: R=mygcd(Q1,P1,[x,dx]);
19563: if(findin(dx,vars(R[0]))>=0){
19564: mycat("Some error!");
19565: return 0;
19566: }
19567: Q=muldo(R[1]/R[0],Q,[x,dx]);
19568: R=divdo(Q,P,[x,dx]);
19569: Q=red(R[1]/R[2]);
19570: R=fctr(nm(Q));
19571: QQ=Q/R[0][0];
19572: R1=fctr(dn(QQ));
19573: for(RR=cdr(R1); RR!=[]; RR=cdr(RR)){
19574: VT=vars(car(RR)[0]);
19575: if(findin(x,VT)<0 && findin(dx,VT)<0){
19576: for(I=car(RR)[1];I>0;I--) QQ=red(QQ*car(RR)[0]);
19577: }
19578: }
19579: Raw=getopt(raw);
19580: Dviout=getopt(dviout);
19581: if(Dviout==1) Raw=4;
19582: if(Raw!=1){
19583: for(RR=cdr(R); RR!=[]; RR=cdr(RR)){
19584: VT=vars(car(RR)[0]);
19585: if(findin(x,VT)<0 && findin(dx,VT)<0){
19586: for(I=car(RR)[1];I>0;I--) QQ=red(QQ/car(RR)[0]);
19587: }
19588: }
19589: }
19590: if(Raw==2||Raw==3||Raw==4){
19591: R=mygcd(QQ,P,[x,dx]); /* R[0]=R[1]*QQ + R[2]*P */
19592: Q1=red(R[0]/R[2]);
19593: for(Q=1,RR=cdr(fctr(nm(Q1))); RR!=[]; RR=cdr(RR)){
19594: VT=vars(car(RR)[0]);
19595: if(findin(x,VT)<0){
19596: for(I=car(RR)[1];I>0;I--) Q*=car(RR)[0];
19597: }
19598: }
19599: if(Raw==3) QQ=[QQ,Q];
19600: else if(Raw==4) /* Q=Q*R[1]/R[0]*QQ+Q/R[0]*P */
19601: QQ=[QQ,Q,red(R[1]*Q/R[0])];
19602: else QQ=Q;
19603: }
19604: F=getopt(all);
19605: if(Dviout==1){
19606: Pre = " x=\\infty & 0 & 1";
19607: for(I=3; I<NP; I++) Pre = Pre+"& "+rtostr(L[I]);
19608: Pre = Pre+"\\\\\n";
19609: PW=str_tb(ltotex(RS|opt="GRS",pre=Pre),0);
19610: str_tb(
19611: "=\\{u\\mid Pu=0\\}\\\\\n&\\underset{Q_2}{\\overset{Q_1}{\\rightleftarrows}}\n",PW);
19612: str_tb([ltotex(RS1|opt="GRS",pre=Pre),"\\\\\n"],PW);
19613: R=fctrtos(QQ[0]|TeX=3,var=[dx,"\\partial"]);
19614: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
19615: str_tb(["Q_1&=",R,"\\\\\n"],PW);
19616: R=fctrtos(QQ[2]|TeX=3,var=[dx,"\\partial"]);
19617: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
19618: str_tb(["Q_2&=",R,"\\\\\n"],PW);
19619: str_tb(["Q_2Q_1&\\equiv ",fctrtos(QQ[1]|TeX=3),"\\mod W(x)P"],PW);
19620: if(F==1)
19621: str_tb(["\\\\\nP&=",fctrtos(P|TeX=3,var=[dx,"\\partial"])],PW);
19622: dviout(str_tb(0,PW)|eq=0,title="Shift Operator");
19623: }
19624: if(F==1) return [QQ,P,RS,P1,RS1];
19625: else if(F==0) return QQ;
19626: return [QQ,P,RS];
19627: }
19628:
1.56 takayama 19629:
19630: def shiftPfaff(A,B,G,X,M)
19631: {
19632: if(type(G)==4){
19633: G0=G[1];G1=G[0];
19634: }
19635: if(type(G)==6){
19636: G=map(red,G);
19637: G0=llcm(G);G1=map(red,G0*G);
19638: }
19639: if(type(G)==3){
19640: G=red(G);G0=dn(G);G1=nm(G);
19641: }
19642: if(type(M)==4){
19643: M0=M[0];M1=M[1];
19644: }else{
19645: M0=M;M1=0;
19646: }
19647: X=vweyl(X);
19648: D0=mydeg(G0,X[0]);D1=mydeg(G1,X[0]);
19649: if(M1>=0){
19650: D=(D1-M1>D0)?D1-M1:D0;
19651: G0=muldo(X[1]^D,G0,X);G1=muldo(X[1]^(D+M1),G1,X);
19652: }else{
19653: D=(D0+M1>D1)?D0+M1:D1;
19654: G0=muldo(X[1]^(D-M1),G0,X);G1==muldo(X[1]^D,G1,X);
19655: }
19656: G0=map(mc,G0,X,M0);G1=map(mc,G1,X,M0+M1);
19657: G0=appldo(G0,A,X|Pfaff=1);
19658: G1=sppldo(G1,B,X|Pfaff=1);
19659: return rmul(myinv(G0),G1);
19660: }
19661:
1.6 takayama 19662: def conf1sp(M)
19663: {
19664: if(type(M)==7) M=s2sp(M);
19665: L0 = length(M);
19666: L1 = length(M[L0-1]);
19667: X2 = getopt(x2);
19668: Conf= getopt(conf);
19669: if(Conf != 0)
19670: Conf = -1;
19671: if((X2==1 || X2==-1) && Conf != 0){
19672: X1 = 0;
19673: X = x_1;
19674: }else{
19675: X1 = 1;
19676: X = x_2;
19677: }
19678: G = sp2grs(M,a,[L0,L1]);
19679: for(I = 0; I < L0-1; I++){
19680: V = makev([a,I-Conf,0]);
19681: G = subst(G,V,0);
19682: }
19683: L2 = length(M[1]);
19684: for(I=J=S0=S1=0; I < L2; I++){
19685: S1 += G[1][I][0];
19686: while(S0 < S1){
19687: S0 += G[0][J][0];
19688: if((V=G[0][J][1]) != 0)
19689: G = mysubst(G,[V,V-G[1][I][1]]);
19690: J++;
19691: }
19692: if(S0 > S1){
19693: print("Error in data!");
19694: return 0;
19695: }
19696: }
19697: if(Conf==0){
19698: for(L=[], I=L0-2; I>=0; I--)
19699: L=cons(I,L);
19700: L=cons(L0-1,L);
19701: P = getbygrs(G,["operator","x2"]|perm=L);
19702: }else if(X1)
19703: P = getbygrs(mperm(G,[[1,2]],[]), ["operator","x2"]);
19704: else
19705: P = getbygrs(G,["operator","x1"]);
19706: if(Conf==0)
19707: P=nm(mysubst(P,[X,c]));
19708: else{
19709: P = nm(mysubst(P,[X,1/c]));
19710: if(X2==-1){
19711: for(I=2; I<L0; I++){
19712: V=makev(["x_",I]); VC=makev([c,I]);
19713: P = nm(mysubst(P,[V,1/VC]));
19714: }
19715: }
19716: }
19717: for(I = 1; I < L2; I++){
19718: X = G[1][I][1];
19719: P = nm(mysubst(P,[X,X/c]));
19720: }
19721: VS = vars(P);
19722: while(VS!=[]){
19723: V = car(VS);
19724: if(str_chr(rtostr(V),0,"r")==0){
19725: CV = mycoef(P,1,V);
19726: D = mymindeg(CV,c);
19727: if(D > 0) P = mysubst(P,[V,V/c^D]);
19728: CV = mycoef(P,1,V);
19729: DD = mydeg(CV,dx);
19730: CVV = mycoef(CV,DD,dx);
19731: CD1 = mydeg(CVV,x);
19732: CD = (X==x1)?0:CD1;
19733: while(CD>=0 && CD<=CD1){
19734: CC = mycoef(CVV,CD,x);
19735: if(type(CC)==1){
19736: VT = mycoef(mycoef(mycoef(P,DD,dx),CD,x),0,V)/CC;
19737: if(VT != 0) P = mysubst(P,[V,V-VT]);
19738: break;
19739: }
19740: if(X==x1) CD++;
19741: else CD--;
19742: }
19743: while(subst(P,c,0,V,0) == 0)
19744: P = red(mysubst(P,[V,c*V])/c);
19745: }
19746: VS =cdr(VS);
19747: }
19748: return P;
19749: }
19750:
1.44 takayama 19751: /* ((1)(1)) ((1)) 111|11|21 [[ [2,[ [1,[1]],[1,[1]] ]], [1,[[1,[1]]]] ]] */
19752: /* (11)(1),111 111|21,111 [[[2,[1,1]],[1,[1]]],[1,1,1]] */
19753: def s2csp(S)
19754: {
19755: if(type(S)!=7){
19756: U="";
19757: if(type(N=getopt(n))>0){
19758: for(D=0,S=reverse(S);S!=[];S=cdr(S),D++){
19759: if(D) U=","+U;
19760: T=str_subst(rtostr(car(S)),","," ");
19761: U=str_cut(T,1,str_len(T)-2)+U;
19762: }
19763: V=strtoascii(U);
19764: for(R=[];V!=[];V=cdr(V)){
19765: if((CC=car(V))==91){ /* [ */
19766: if(length(V)>1 && V[1]==91) V=cdr(V);
19767: for(I=1;(CC=V[I])!=91&&CC!=93;I++);
19768: if(CC==91){
19769: R=cons(40,R); /* ( */
19770: while(I--) V=cdr(V);
19771: }else{
19772: V=cdr(V);
19773: while(--I) R=cons(car(V),R);
19774: }
19775: }else if(CC==93){ /* ] */
19776: R=cons(41,R);
19777: if(length(V)>1 && V[1]==93) V=cdr(V);
19778: }else R=cons(CC,R);
19779: }
19780: return asciitostr(reverse(R));
19781: }
19782: for(;S!=[];S=cdr(S)){
19783: if(U!="") U=U+",";
19784: for(D=0,TU="",T=car(S);T!=[];D++){
19785: if(type(car(T))==4){
19786: R=lpair(T,0);
19787: T=R[0];R1=m2l(R[1]|flat=1);
19788: }else R1=[];
19789: if(D) TU="|"+TU;
19790: TU=s2sp([T])+TU;
19791: T=R1;
19792: }
19793: U=U+TU;
19794: }
19795: return U;
19796: }
19797: S=strtoascii(S);
1.45 takayama 19798: if(type(N=getopt(n))>0){
19799: S=ltov(S);
19800: L=length(S);
19801: R="";
19802: for(I=J=N=0, V=[];J<L;J++){
19803: if(S[J]==72) I=J; /* ( */
19804: else if(S[J]>47&&S[J]<58) N=N*10+S[J]-48;
19805: else{
19806: if(N>0){
19807: V=cons(N,V);
19808: N=0;
19809: }
19810: if(S[J]==41){ /* ) */
19811:
19812: }else if(S[J]==44){ /* , */
19813:
19814: }
19815: }
19816: }
19817: }
1.44 takayama 19818: for(P=TS=[],I=D=0; S!=[]; S=cdr(S)){
19819: if((C=car(S))==44){ /* , */
19820: P=cons(D,P);D=0;
19821: }else if(C==124){ /* | */
19822: D++;C=44;
19823: }
19824: TS=cons(C,TS);
19825: }
19826: S=reverse(TS);
19827: P=reverse(cons(D,P));
19828: U=s2sp(asciitostr(S));
19829:
19830: for(R=[];P!=[];P=cdr(P),U=cdr(U)){
19831: D=car(P);R0=car(U);
19832: while(D--){
19833: U=cdr(U);
19834: for(U0=car(U),R2=[];U0!=[];U0=cdr(U0)){
19835: for(R1=[],N=car(U0);N>0;R0=cdr(R0)){
19836: R1=cons(car(R0),R1);
19837: if(type(car(R0))==4) N-=car(R0)[0];
19838: else N-=car(R0);
19839: }
19840: R2=cons([car(U0),reverse(R1)],R2);
19841: }
19842: R0=reverse(R2);
19843: }
19844: R=cons(R0,R);
19845: }
19846: return reverse(R);
19847: }
19848:
19849:
1.36 takayama 19850: def partspt(S,T)
19851: {
1.40 takayama 19852: if(length(S)>length(T)) return [];
1.38 takayama 19853: if(type(Op=getopt(opt))!=1) Op=0;
1.40 takayama 19854: else{
19855: VS=ltov(S);
19856: L=length(S)-1;
19857: VT=ltov(qsort(T));
19858: }
1.38 takayama 19859: if(length(S)==length(T)){
1.40 takayama 19860: if(S==T||qsort(S)==qsort(T)) R=S;
1.38 takayama 19861: else return [];
1.40 takayama 19862: }else if(getopt(sort)==1){
19863: S0=S1=[];
19864: for(;S!=[]&&car(S)==car(T);S=cdr(S),T=cdr(T))
19865: S0=cons(car(S),S0);
19866: if(S!=[]&&car(S)<car(T)) return [];
19867: S0=reverse(S0);
19868: for(S=reverse(S),T=reverse(T);S!=[],car(S)==car(T);S=cdr(S),T=cdr(T))
19869: S1=cons(car(S),S1);
19870: if(car(S)!=[]&&car(S)<cat(T)) return [];
19871: R=partspt(reverse(S),reverse(T));
19872: if(S1!=[]){
19873: for(R0=[];R!=[];R=cdr(R))
19874: R0=cons(append(car(R),S1),R0);
19875: R=reverse(R0);
19876: }
19877: if(S0!=[]){
19878: for(R0=[];R!=[];R=cdr(R))
19879: R0=cons(append(S0,car(R)),R0);
19880: R=reverse(R0);
19881: }
1.38 takayama 19882: }else{
19883: for(R=[];;){
19884: for(I=J=P=0;I<L;I++){
19885: P=VS[I];
19886: X=100000;
19887: while((P-=(Y=VT[J++]))>0){
19888: if(X<Y) break;
19889: X=Y;
19890: }
19891: if(X<Y||P<0) break;
19892: }
19893: if(!P&&X>=Y) R=cons(vtol(VT),R);
19894: if(!vnext(VT)) break;
19895: }
1.36 takayama 19896: }
1.38 takayama 19897: if(Op){
19898: for(W=[];R!=[];R=cdr(R)){
19899: for(I=0,S=VS[0],K=U=[],TR=car(R);TR!=[];TR=cdr(TR)){
19900: K=cons(car(TR),K);
19901: if(!(S-=car(K))){
19902: U=cons([VS[I],reverse(K)],U);
19903: K=[];
19904: S=VS[++I];
19905: if(I==L){
19906: U=cons([S,cdr(TR)],U);
19907: break;
19908: }
19909: }
1.36 takayama 19910: }
1.38 takayama 19911: W=cons(reverse(U),W);
19912: }
19913: R=W;
19914: if(iand(Op,1)){
1.40 takayama 19915: for(R=[];W!=[];W=cdr(W))
1.38 takayama 19916: R=cons(reverse(qsort(car(W))),R);
19917: R=lsort(R,[],1);
19918: }
19919: if(Op==3){
19920: for(W=[];R!=[];R=cdr(R)){
19921: for(S=[],TR=car(R);TR!=[];TR=cdr(TR))
19922: S=append(S,car(TR)[1]);
19923: W=cons(S,W);
1.36 takayama 19924: }
1.38 takayama 19925: R=reverse(W);
1.36 takayama 19926: }
19927: }
1.38 takayama 19928: return R;
1.36 takayama 19929: }
19930:
1.38 takayama 19931: #if 0
1.36 takayama 19932: def confspt(S,T)
19933: {
19934: R=[];
19935: LS=length(S);LT=length(T);
19936: if(LS<LT) return R;
19937: if(LS==LT){
19938: return(S==T)? return [[S,T]]:R;
19939: }
19940: R=[];
19941: for(ST=S,S0=T0=[],TT=T;ST!=[];ST=cdr(ST),TT=cdr(TT)){
19942: if(car(ST)>car(TT)) return R;
19943: if(car(ST)==car(TT){
19944: S0=cons(car(ST));T0=cons(car(TT));
19945: LS--;LT--;continue;
19946: }
19947: V=car(TT);D=LS-LT;
19948: for(P=[ST],DD=D;DD>0;){
19949: VD=V-car(car(ST));
19950: }
19951: }
19952: }
19953: #endif
19954:
1.76 takayama 19955: def vConv(K,I,J)
19956: {
19957: if(type(X=getopt(var))!=7) X="a";
19958: if(getopt(e)==2) return subst(vConv(K,I+1,J+1),makev([X,1]),0);
19959: if(J>K){L=J;J=K;K=L;}
19960: if(K>I||J<1||K+J<I+1) return 0;
19961: if(K+J==I+1) return 1;
19962: else
19963: #if 1
19964: L=I-K<J-2?I-K+1:J;
19965: for(S=0,M=0;M<L;M++) S+=(makev([X,K+M])-makev([X,J-M-1]))*vConv(K+M,I,J-M-1|var=X);
19966: return S;
19967: #else
19968: return vConv(K+1,I,J-1|var=X)+(makev([X,K])-makev([X,J-1]))*vConv(K,I,J-1|var=X);
19969: #endif
19970: }
19971:
1.50 takayama 19972: def mcvm(N)
19973: {
19974: X=getopt(var);
19975: if((Z=getopt(z))!=1) Z=0;
19976: if(type(N)==4){
19977: if((K=length(N))==1&&isvar(X)) X=[X];
19978: if(type(X)!=4){
1.76 takayama 19979: for(X=[],I=0;I<K;I++) X=cons(asciitostr([97+I]),X); /* a,b,... */
1.50 takayama 19980: X=reverse(X);
19981: }
1.76 takayama 19982: if((E=getopt(e))==1||E==2){
19983: if(length(N)==4) N=cdr(N);
19984: if(length(N)==3) return vConv(N[0],N[1],N[2]|var=X,e=E);
1.50 takayama 19985: }
19986: for(M=[],I=S=0;I<K;Z=0,I++){
19987: M=cons(mcvm(N[I]|var=X[I],z=Z),M);
19988: S+=N[I];
19989: }
19990: M=newbmat(K,K,reverse(M));
1.52 takayama 19991: NR=N;
1.50 takayama 19992: N=S;
19993: }else{
19994: if(type(X)==7) X=strtov(X);
19995: if(!isvar(X)) X=a;
19996: M=newmat(N,N);
19997: for(I=0;I<N;I++){
19998: V=makev([X,I+1]);
19999: for(J=0;J<=I;J++){
20000: R=polbyroot([1,J],V|var=X);
20001: if(Z==1) R*=V;
20002: M[I][J]=R;
20003: }
20004: }
20005: }
1.52 takayama 20006: if((Get=getopt(get))==1){
1.50 takayama 20007: for(R=[],I=0;I<N;I++){
20008: U=newmat(N,N);
20009: for(J=0;J<N;J++) U[J][J]=M[J][I];
1.56 takayama 20010: R=cons(rmul(rmul(myinv(M),U),M),R);
1.50 takayama 20011: }
20012: return reverse(R);
1.52 takayama 20013: }else if(Get==2||Get==3||Get==4){
1.51 takayama 20014: for(V=[],I=N;I>0;I--) V=cons(makev(["a0",I]),V);
20015: MI=myinv(M);
20016: V=ltov(V)*MI;
20017: for(R=[],I=0;I<N;I++){
20018: for(J=I+1;J<N;J++){
20019: K=newmat(N,N);
20020: K[I][I]=V[J];K[I][J]=-V[J];K[J][J]=V[I];K[J][I]=-V[I];
1.56 takayama 20021: R=cons(rmul(rmul(MI,K),M),R);
1.51 takayama 20022: }
20023: }
1.52 takayama 20024: R=reverse(R);
20025: if(Get==2||length(NR)!=2||Z==1) return R;
20026: for(V1=[],I=NR[0];I>0;I--) V1=cons(os_md.makev([X[0],I]),V1);
20027: for(V2=[],I=NR[1];I>0;I--) V2=cons(os_md.makev([X[1],I]),V2);
20028: R=subst(R,car(V1),0,car(V2),0);
20029: V1=subst(V1,car(V1),0);
20030: V2=subst(V2,car(V2),0);
20031: for(V=[],S=V1;S!=[];S=cdr(S)) for(T=V2;T!=[];T=cdr(T)) V=cons(car(T)-car(S),V);
20032: V=reverse(V);
20033: Mx=length(V);
20034: for(A0=[],I=J=NR[0]-1;J>=0;I+=--J) for(K=0;K<NR[1];K++,I++) A0=cons(R[I],A0);
20035: A0=reverse(A0);
20036: for(F0=[],T=1,I=Mx-1;I>=0;I--) F0=cons(1/(x-V[I]), F0);
20037: MV=confexp([F0,V]|sym=3);
20038: RR=newvect(Mx);
20039: 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]);
1.76 takayama 20040: for(RR0=RR,VV=append(cdr(V1),cdr(V2));VV!=[];VV=cdr(VV)) RR0=subst(RR0,car(VV),0);
1.52 takayama 20041: RR0=vtol(RR0);
20042: return (Get==3)?[RR,RR0]:RR0;
1.50 takayama 20043: }
20044: return M;
20045: }
1.36 takayama 20046:
1.34 takayama 20047: def confexp(S)
20048: {
1.52 takayama 20049: if((Sym=getopt(sym))==1||Sym==2||Sym==3){
1.51 takayama 20050: D=polbyroot(S[1],x);
1.52 takayama 20051: for(R=[],T=S[0];T!=[];T=cdr(T)){
20052: M=D*car(T);
20053: if(type(M)>3) M=map(red,M);
20054: else M=red(M);
20055: R=cons(M,R);
20056: }
1.51 takayama 20057: R=reverse(R);
20058: if(Sym==2) return R;
20059: M=length(R);N=length(S[1]);
20060: E=newmat(M,N);
20061: for(I=0;I<M;I++){
20062: for(J=0;J<N;J++) E[I][J]=mycoef(R[I],N-J-1,x);
20063: }
1.52 takayama 20064: if(Sym==3){
20065: for(R=[],P=1,T=S[1];T!=[];T=cdr(T)) R=cons(P/=(x-car(T)),R);
20066: R=confexp([reverse(R),S[1]]|sym=1);
20067: return E*myinv(R);
20068: }
1.51 takayama 20069: return E;
20070: }
1.35 takayama 20071: if(type(S[0])==4){
1.52 takayama 20072: for(E=[];S!=[];S=cdr(S)) E=cons(confexp(car(S),E));
1.35 takayama 20073: return reverse(E);
20074: }
1.34 takayama 20075: V=x;E=[];
20076: for(P=0,Q=[],ST=S;ST!=[];ST=cdr(ST)){
20077: Q=cons(car(ST)[0],Q);
20078: P+=car(ST)[1]/(V-car(ST)[0]);
20079: P=red(P);
20080: }
20081: P=red(P*polbyroot(Q,V));
20082: Q=cdr(reverse(Q));
20083: for(I=(length(W=Q));I>=0;I--){
20084: C=mycoef(P,I,V);
20085: P-=C*polbyroot(W,V);
20086: W=cdr(W);
20087: E=cons(red(C),E);
20088: }
20089: return reverse(E);
20090: }
20091:
1.6 takayama 20092: def pgen(L,VV)
20093: {
20094: if(type(L[0])<4) L=[L];
20095: if(type(L)==4) L=ltov(L);
20096: K=length(L);
20097: V=newvect(K);
20098: if(type(Sum=getopt(sum))!=1) Sum=0;
20099: if((Num=getopt(num))!=1) Num=0;
20100: if((Sep=getopt(sep))!=1) Sep=0;
20101: if(type(Shift=getopt(shift))!=1) Shift=0;
20102: for(;;){
20103: for(PP=1,R=[],II=K-1; II>=0; II--){
20104: R=cons(V[II]+Shift,R);
20105: if(II>0 && Sep==1) R=cons("_",R);
20106: PP*=L[II][0]^V[II];
20107: }
20108: P+=makev(cons(VV,R)|num=Num)*PP;
20109: for(I=0;I<K;){
20110: if(++V[I]<=L[I][1]){
20111: if(Sum>0){
20112: for(S=II=0;II<K;) S+=V[II++];
20113: if(S>Sum){
20114: V[I++]=0;
20115: continue;
20116: }
20117: }
20118: }else{
20119: V[I++]=0;
20120: continue;
20121: }
20122: break;
20123: }
20124: if(I>=K) return P;
20125: }
20126: }
20127:
20128: def diagm(M,A)
20129: {
20130: return mgen(M,0,A,1);
20131: }
20132:
20133: def mgen(M,N,A,S)
20134: {
20135: if(M==0 && N==0){
20136: mycat([
20137: "mgen(m,n,a,s|sep=1) : generate a matrix of size m x n\n",
20138: " n : a number or \"diagonal\", \"highdiag\", \"lowdiag\",\"skew\",\"symmetric\",\"perm\" = 0,-1,-2,..\n",
20139: " a : a symbol or list (ex. a, [a], [a,b,c], [1,2,3])\n",
20140: " s : 0 or 1 (shift of suffix)\n"
20141: ]);
20142: return 0;
20143: }
20144: if(type(N)==7) N=-findin(N,["diag","highdiag","lowdiag","skew","symmetric","perm"]);
20145: Sep=(getopt(sep)==1)?1:0;
20146: if(S < 0 || S > 2)
20147: S = 0;
20148: if(M+S > 30 || N+S > 30){
20149: erno(1);
20150: return;
20151: }
20152: if(N==-5){
20153: NM=newmat(M,M);
20154: for(I=0;I<M;I++,A=cdr(A)) NM[I][car(A)-S]=1;
20155: return NM;
20156: }
20157: if(type(A) == 4)
20158: L = length(A)-1;
20159: else
20160: L = -1;
20161: if(N <= 0 && N >= -2){
20162: MM = newmat(M,M);
20163: J = K = 0;
20164: if(N == -1){
20165: K = 1; M--;
20166: }else if(N == -2){
20167: J = 1; M--;
20168: }
20169: for(I = 0; I < M; I++){
20170: if(L >= 0)
20171: MM[I+J][I+K] = A[(I > L)?L:I];
20172: else if(type(A)==7 || isvar(A))
20173: MM[I+J][I+K] = makev([A,S+I]|sep=Sep);
20174: else
20175: MM[I+J][I+K] = A;
20176: }
20177: return MM;
20178: }
20179: K = N;
20180: if(K < 0) N = M;
20181: MM = newmat(M,N);
20182: for(I = 0; I < M; I++){
20183: if(L >= 0)
20184: AA = rtostr(A[(I > L)?L:I]);
20185: else
20186: AA = rtostr(A)+rtostr(I+S);
20187: if(AA>="0" && AA<=":"){
20188: erno(0); return;
20189: }
20190: for(J = 0; J < N; J++){
20191: if(K < 0){
20192: if(I > J) continue;
20193: if(K == -3 && I == J) continue;
20194: }
20195: MM[I][J] = makev([AA,J+S]|sep=Sep);
20196: }
20197: }
20198: if(K < 0){
20199: for(I = 0; I < M; I++){
20200: for(J = 0; J < I; J++)
20201: MM[I][J] = (K == -4)?MM[J][I]:-MM[J][I];
20202: }
20203: }
20204: return MM;
20205: }
20206:
20207: def newbmat(M,N,R)
20208: {
20209: S = newvect(M);
20210: T = newvect(N);
20211: IM = length(R);
1.50 takayama 20212: if(type(car(R))!=4 && M==N && M==IM){
20213: for(RR=TR=[],I=0;I<M;I++){
20214: for(TR=[R[I]],J=0;J<I;J++) TR=cons(0,TR);
20215: RR=cons(TR,RR);
20216: }
20217: R=reverse(RR);
20218: }
1.6 takayama 20219: for(I = 0; I < IM; I++){
20220: RI = R[I];
20221: JM = length(RI);
20222: for(J = 0; J < JM; J++){
20223: RIJ = RI[J];
20224: if(type(RIJ) == 6){
20225: S[I] = size(RIJ)[0];
20226: T[J] = size(RIJ)[1];
20227: }
20228: }
20229: }
20230: for(I = K = 0; I < M; I++){
20231: if(S[I] == 0)
20232: S[I] = 1;
20233: K += S[I];
20234: }
20235: for(J = L = 0; J < N; J++){
20236: if(T[J] == 0)
20237: T[J] = 1;
20238: L += T[J];
20239: }
20240: M = newmat(K,L);
20241: if(type(Null=getopt(null))>0){
20242: for(I=0;I<K;I++){
20243: for(J=0;J<L;J++) M[I][J]=Null;
20244: }
20245: }
20246: for(I0 = II = 0; II < IM; I0 += S[II++]){
20247: RI = R[II];
20248: JM = length(RI);
20249: for(J0 = JJ = 0; JJ < JM; J0 += T[JJ++]){
20250: if((RIJ = RI[JJ]) == 0)
20251: continue;
20252: Type = type(RIJ);
20253: for(I = 0; I < S[II]; I++){
20254: for(J = 0; J < T[JJ]; J++){
20255: if(Type == 6)
20256: M[I0+I][J0+J] = RIJ[I][J];
20257: else if(Type == 4 || Type == 5)
20258: M[I0+I][J0+J] = (I>0)?RIJ[I]:RIJ[J];
20259: else
20260: M[I0+I][J0+J] = RIJ;
20261: }
20262: }
20263: }
20264: }
20265: return M;
20266: }
20267:
20268: def unim(S)
20269: {
20270: if(!Rand++) random(currenttime());
20271: if(!isint(Wt=getopt(wt))||Wt<0||Wt>10) Wt=2;
20272: if(!isint(Xa=getopt(abs)) || Xa<1)
20273: Xa=9;
20274: if((Xaa=Xa)>10) Xaa=10;
20275: if(Xaa%2) Xaa++;
20276: Xh=Xaa/2;
20277: if(type(S0=SS=S)==4){
20278: Int=(getopt(int)==1)?1:0;
20279: U=[1,1,1,1,1,1,1,1,1,1,1,1,2,2,3,4];
20280: M=newmat(S[0],S[1]);
20281: SS=cdr(S);SS=cdr(SS);
20282: if(Rk=length(SS)) L=SS;
20283: else{
20284: L=[0];
20285: I=(S[0]>S[1])?S[1]:S[0];
20286: if(I<=2) return 0;
20287: if(!isint(Rk=getopt(rank))||Rk<1||Rk>S[0]||Rk>S[1])
20288: Rk=random()%(I-1)+2;
20289: for(I=1;I<Rk;){
20290: P=random()%(S[1]+Wt)-Wt;
20291: if(P<=0) P=1;
20292: if(findin(P,L)!=0){
20293: L=cons(P,L);
20294: I++;
20295: }
20296: }
20297: }
20298: L=ltov(qsort(L));
20299: M[0][L[0]]=1;
20300: for(I=1;I<Rk;I++){
20301: P=Int?1:U[random()%length(U)];
20302: if(P>Xa) P=Xa;
20303: M[I][L[I]]=(random()%2)?P:(-P);
20304: }
20305: for(I=0;I<Rk;I++){
20306: if(I!=0&&abs(M[I][L[I]])>1) M[K=random()%I][KK=L[I]]=1;
20307: I0=(I==0)?1:L[I]+1;
20308: I1=(I==Rk-1)?S[1]:L[I+1];
20309: for(J=I0;J<I1;J++){
20310: for(K=1;K<=Xa;K++){
20311: P=random()%(I+1);
20312: if((random()%2)==1) M[P][J]++;
20313: else M[P][J]--;
20314: }
20315: }
20316: }
20317: S=M;
20318: Res=(getopt(res)==1)?dupmat(S):0;
20319: }
20320: Conj=0;
20321: if(type(S)<2){
20322: if(S<2||S>20) return 0;
20323: if(getopt(conj)==1){
20324: M=S+Wt;
20325: if(M>15) M=10;
20326: M0=floor((M-1)/2);
20327: for(R=[],I=0;I<S;I++) R=cons(random()%M-M0,R);
20328: R=qsort(R);
20329: M=diagm(S,R);
20330: if(getopt(diag)!=1){
20331: for(I=1;I<S;I++)
20332: if(M[I-1][I-1]==M[I][I] && random()%2) M[I-1][I]=1;
20333: }
20334: if(M[0][0]==M[S-1][S-1]){
20335: for(I=1;I<S;I++) if(M[I-1][I]==1) break;
20336: if(I==S){
20337: if(M[0][0]>0) M[0][0]--;
20338: else M[S-1][S-1]++;
20339: }
20340: }
20341: if(getopt(res)==1) RR=diagm(S,[1]);
20342: S1=S;
20343: Res=dupmat(S=M);
20344: if(isint(I=getopt(int))&&I>1&&random()%I==0){
20345: K=S[0][0];L=K+1;
20346: for(I=1;I<S1;I++){
20347: if(S[I][I]>L && S[I-1][I]==0 && (I==S1-1||S[I][I+1]==0)){
20348: L=S[I][I];
20349: if(RR){
20350: RR[I][I]=L-K;RR[0][I]=1;
20351: }
20352: S[0][I]=1;
20353: if(!(random()%3)) break;
20354: }
20355: }
20356: if(random()%3==0){
20357: for(I=0;I<S1-1;I++){
20358: if(iand(S[I][I],1)&&S[I][I+1]==1){
20359: for(J=I+2;J<S1&&S[I][J]==0;J++);
20360: if(J<S1) continue;
20361: for(J=I-1;J>=0&&S[J][I]==0;J--);
20362: if(J>=0) continue;
20363: S[I][I+1]=2;
20364: for(J=0;J<S1;J++) RR[I][J]*=2;
20365: break;
20366: }
20367: }
20368: }
20369: }
20370: }else{
20371: M=diagm(S,[1]);
20372: S1=S;
20373: }
20374: }
20375: if(type(S)==6){
20376: M=dupmat(S);
20377: S=size(S);
20378: S1=S[1];S=S[0];
20379: Nt=1;
20380: if(getopt(conj)==1&&S==S1) Conj=1;
20381: }
20382: if(!isint(Ct=getopt(time)))
20383: Ct=(S>3||S1>3)?100:200;
20384: if(getopt(both)==1){
20385: OL=delopt(getopt(),"both");
20386: M=unim(mtranspose(M)|option_list=OL);
20387: M=mtranspose(M);
20388: }
20389: Mx=20;
20390: for(I=K=LL=0;I<Ct+Mx;I++){
20391: P=random()%S;Q=random()%S;
20392: if(3*K>Ct) T=random()%Xaa-Xh;
20393: else if(5*K<Ct) T=random()%2-1;
20394: else T=random()%4-2;
20395: if(T>=0) T++;
20396: if(P==Q) continue;
20397: for(G=0,J=S1-1;J>=0;J--){
20398: if((H=abs(M[Q][J]+M[P][J]*T))>Xa&&(!Conj||J!=P)) break;
20399: if(K<Mx&&!Conj) G=igcd(G,H);
20400: }
20401: if(K<Mx && G>1) J=1;
20402: if(J>0) continue;
20403: if(J<0&&Conj==1){
20404: for(J=S1-1;J>=0;J--)
20405: if(J!=Q&&abs(M[J][P]-M[J][Q]*T)>Xa) break;
20406: if(J<0&&abs(M[Q][P]-M[Q][Q]*T+M[P][P]*T-M[P][Q]*T^2)>Xa) J=1;
20407: if(J<0&&M[P][P]==M[Q][Q]){
20408: LF=0;
20409: for(L=S1-1;J>=0;J--) if(L!=Q&&M[J][Q]!=0) LF++;
20410: for(L=S1-1;J>=0;J--) if(L!=P&&M[P][J]!=0) LF++;
20411: if(!LF) J=1;
20412: }
20413: }
20414: if(J<0){
20415: for(J=S1-1;J>=0;J--)
20416: M[Q][J]+=M[P][J]*T;
20417: if(Conj==1)
20418: for(J=S1-1;J>=0;J--) M[J][P]-=M[J][Q]*T;
20419: if(RR) for(J=S1-1;J>=0;J--) RR[Q][J]+=RR[P][J]*T;
20420: K++;
20421: }
20422: if(K%5==0){
20423: if(!Nt) M=mtranspose(M);
20424: else if(!Conj&&K%2==0){
20425: for(F=0;F<S;F++){
20426: if((V=lgcd(M[F]))>1){
20427: for(L=0;L<S1;L++) M[F][L]/=V;
20428: }
20429: }
20430: }
20431: }
20432: if(I>Ct){
20433: for(L=S-1;L>=0;L--){
20434: for(F=0,J=S1-1;J>=0;J--)
20435: if(M[L][J]!=0) F++;
20436: if(F<2){
20437: F=-1;break;
20438: }
20439: else F=0;
20440: }
20441: if(F<0 && LL++<5){
20442: I=(CT-CT%2)/2;K=1;
20443: }
20444: if(I>Ct) break;
20445: }
20446: }
20447: if(RR){
20448: for(I=F=0;I<S1;I++){
20449: V=Res[I][I];
20450: for(J=I+1;J<S1;J++){
20451: if(Res[J][J]!=V) break;
20452: for(LP=0;LP<2;LP++){
20453: if(J==S1-1||Res[J][J+1]==0){
20454: if(I==0||Res[I-1][I]==0){
20455: for(VL=VS=[],K=0;K<S1;K++){
20456: VL=cons(RR[K][J],VL);VS=cons(RR[K][I],VS);
20457: }
20458: VR=ldev(VL,VS);
20459: if(VR[0]){
20460: for(K=S1-1,VN=VR[1];K>=0;K--,VN=cdr(VN))
20461: RR[K][J]=car(VN);
20462: F=1;
20463: }
20464: }
20465: }
20466: K=I;I=J;J=K;
20467: }
20468: }
20469: if(F&&I==S1-1){
20470: F=0;I=-1;
20471: }
20472: }
20473: if(getopt(int)==1){
20474: N=mtranspose(M);
20475: for(F=I=0;I<S1;I++) if(lgcd(M[I])>1||lgcd(N[I])>1) F++;
20476: if(F){
20477: for(F=I=0;I<S1;I++){
20478: if(Res[I][I]==-1) F=ior(F,1);
20479: else if(Res[I][I]==1) F=ior(F,2);
20480: }
20481: C=0;
20482: if(!iand(F,1)) C=1;
20483: else if(!iand(F,2)) C=-1;
20484: if(C){
20485: for(I=0;I<S1;I++){
20486: M[I][I]+=C;Res[I][I]+=C;
20487: }
20488: }
20489: }
20490: }
20491: if(getopt(rep)!=1){
20492: for(Lp=0;Lp<5;Lp++){
20493: F=(M==Res||abs(lmax(RR))>Xa*10||abs(lmin(RR))>Xa*10)?1:0;
20494: for(I=0;!F&&I<S1&&Lp<4;I++){
20495: for(K=L=J=0;J<S1;J++){
20496: if(M[I][J]) K++;
20497: if(M[J][I]) L++;
20498: }
20499: if(K<2||L<2) F=1;
20500: }
20501: if(!F) break;
20502: R=unim(S0|option_list=cons(["rep",1],getopt()));
20503: M=R[0];Res=R[1];RR=R[3];
20504: }
20505: }
20506: }
20507: if(Res==0) return M;
20508: if(RR){
20509: for(I=K=V=0;I<S1;I++){
20510: for(J=0;J<S1;J++){
20511: if(RR[J][I]>0) V++;
20512: else if(RR[J][I]<0) V--;
20513: }
20514: if(I<S1-1&&Res[I][I+1]!=0) continue;
20515: if(V<0){
20516: for(;K<=I;K++) RR=colm(RR,K,-1);
20517: }
20518: K=I+1;V=0;
20519: }
20520: }
20521: if(getopt(rep)!=1){
20522: if((F=getopt(dviout))==1){
20523: if(getopt(conj)==1){
20524: if(RR) show([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
20525: }else{
20526: if(type(Lim=getopt(lim))==1)
20527: mtoupper(M,0|step=1,opt=7,dviout=1,pages=1,lim=Lim);
20528: else mtoupper(M,0|step=1,opt=7,dviout=1,pages=1);
20529: }
20530: }else if(F==-1){
20531: if(getopt(conj)==1){
20532: if(RR) return ltotex([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
20533: }else{
20534: if(type(Lim=getopt(lim))==1)
20535: return mtoupper(M,0|step=1,opt=7,pages=1,lim=Lim,dviout=-1);
20536: else return mtoupper(M,0|step=1,opt=7,pages=1,dviout=-1);
20537: }
20538: }
20539: }
20540: if(RR==0) return[M,Res];
20541: return [M,Res,myinv(RR),RR];
20542: }
20543:
20544: def pfrac(F,X)
20545: {
20546: F = red(F);
20547: FN = nm(F);
20548: FD = dn(F);
20549: if(mydeg(FD,X) == 0)
20550: return [[F,1,1]];
20551: R = rpdiv(FN,FD,X);
20552: FN = R[0]/R[1];
20553: R0 = R[2]/R[1];
20554: FC = fctr(FD);
20555: RT=[];
20556: if(getopt(root)==2){
20557: for(FE=[],FT=FC;FT!=[];FT=cdr(FT)){
20558: if(mydeg(P=car(FT)[0],X)==4 && vars(P)==[X] && pari(issquare,C=mycoef(P,4,X))){
20559: if((S=mycoef(P,3,X)/4/C)!=0) P=subst(P,X,X-S);
20560: if(mycoef(P,1,X)==0 && pari(issquare,C0=mycoef(P,0,X))){
20561: C=sqrtrat(C);C0=sqrtrat(C0);C1=2*C*C0-mycoef(P,2,X);
20562: if(C1>0){
20563: FE=cons([C*(X+S)^2-C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
20564: FE=cons([C*(X+S)^2+C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
20565: RT=cons(C1,RT);
20566: continue;
20567: }
20568: }
20569: }
20570: FE=cons(car(FT),FE);
20571: }
20572: FC=reverse(FE);
20573: }
20574: N = Q = 0;
20575: L = [];
20576: for(I = length(FC)-1; I >= 0; I--){
20577: if((D = mydeg(FC[I][0],X)) == 0) continue;
20578: for(K=1; K<=FC[I][1]; K++){
20579: for(J=P=0; J < D; J++){
20580: V = makev(["zz_",++N]);
20581: P = P*X + V;
20582: L = cons(V,L);
20583: }
20584: Q += P/(FC[I][0]^K);
20585: Q = red(Q);
20586: }
20587: }
20588: L=reverse(L);
20589: Q = nm(red(red(Q*FD)-FN));
20590: Q = ptol(Q,X);
20591: S = lsol(Q,L);
20592: R = (R0==0)?[]:[[R0,1,1]];
20593: for(N=0,I=length(FC)-1; I >= 0; I--){
20594: if((D = mydeg(FC[I][0],X)) == 0) continue;
20595: for(K=1; K<=FC[I][1]; K++){
20596: for(P=J=0; J < D; N++,J++)
20597: P = P*X + S[N][1];
20598: if(P!=0) R = cons([P,FC[I][0],K],R);
20599: }
20600: }
20601: for(;RT!=[];RT=cdr(RT)){
20602: RTT=car(RT);
20603: R=mtransbys(os_md.substblock,R,[RTT^(1/2),(RTT^(1/2))^2,RTT]);
20604: }
20605: TeX=getopt(TeX);
20606: if((Dvi=getopt(dviout))==1||TeX==1){
20607: V=strtov("0");
20608: for(S=L=0,RR=R;RR!=[];RR=cdr(RR),L++){
20609: RT=car(RR);
20610: S+=(RT[0]/RT[1]^RT[2])*V^L;
20611: }
20612: if(TeX!=1) fctrtos(S|var=[V,""],dviout=1);
20613: else return fctrtos(S|var=[V,""],TeX=3);
20614: }
20615: return reverse(R);
20616: }
20617:
20618: def cfrac(X,N)
20619: {
20620: F=[floor(X)];
20621: if(N<0){
20622: Max=N=-N;
20623: }
20624: X-=F[0];
20625: if(Max!=1)
20626: M=mat([F[0],1],[1,0]);
20627: for(;N>0 && X!=0;N--){
20628: X=1/X;
20629: F=cons(Y=floor(X),F);
20630: X-=Y;
20631: if(Max){
20632: M0=M[0][0];M1=M[1][0];
20633: M=M*mat([Y,1],[1,0]);
20634: if(M[0][0]>Max) return M0/M1;
20635: }
20636: }
20637: return (Max==0)?reverse(F):M[0][0]/M[1][0];
20638: }
20639:
20640: def sqrt2rat(X)
20641: {
20642: if(type(X)>3) return X;
20643: X=red(X);
20644: if(getopt(mult)==1){
20645: for(V=vars(X);V!=[];V=cdr(V)){
20646: T=funargs(F=car(V));
20647: if(type(T)==4&&length(T)>1){
20648: Y=T[1];
20649: Z=sqrt2rat(Y);
20650: if(Y!=Z){
20651: if(length(T)==2){
20652: T0=T[0];
20653: X=subst(X,F,T0(Z));
20654: }else if(T[0]==pow)
20655: X=subst(X,F,Y^T[2]);
20656: }
20657: }
20658: }
20659: }
20660: for(V=vars(X);V!=[];V=cdr(V)){ /* r(x)^(1/2+n) -> r(x)^n*r(x)^(1/2) */
20661: T=args(Y=car(V));
20662: if(functor(Y)==pow&&T[1]!=1/2&&isint(T2=2*T[1])){
20663: if(iand(T2,1)){
20664: R=(T[0])^(1/2);T2--;
20665: }else R=1;
20666: R*=T[0]^(T2/2);
20667: X=red(subst(X,Y,R));
20668: }
20669: }
20670: D=dn(X);N=nm(X);
20671: if(imag(D)!=0){
20672: N*=conj(D);
20673: D*=conj(D);
20674: return sqrt2rat(N/D);
20675: }
20676: for(V=vars(N);V!=[];V=cdr(V)){ /* (r(x)^(n/m))^k */
20677: T=args(Y=car(V));
20678: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
20679: Dn=dn(T[1]);Nm=nm(T[1]);
20680: N=substblock(N,Y,Y^Dn,T[0]^Nm);
20681: }
20682: }
20683: for(V=vars(D);V!=[];V=cdr(V)){
20684: T=args(Y=car(V));
20685: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
20686: Dn=dn(T[1]);Nm=nm(T[1]);
20687: D=substblock(D,Y,Y^Dn,T[0]^Nm);
20688: }
20689: }
20690: for(V=vars(D);V!=[];V=cdr(V)){
20691: T=args(Y=car(V));
20692: if(functor(Y)==pow&&T[1]==1/2&&mydeg(D,Y)==1){
20693: N*=mycoef(D,0,Y)-mycoef(D,1,Y)*Y;
20694: N=mycoef(N,0,Y)+mycoef(N,1,Y)*Y+mycoef(N,2,Y)*T[0];
20695: D=mycoef(D,0,Y)^2-mycoef(D,1,Y)^2*T[0];
20696: X=red(N/D);
20697: D=dn(X);N=nm(X);
20698: break;
20699: }
20700: }
20701: X=red(N/D);
20702: D=dn(X);N=nm(X);
20703: for(V=vars(D);V!=[];V=cdr(V)){
20704: T=args(Y=car(V));
20705: if(functor(Y)==pow&&T[1]==1/2)
20706: D=substblock(D,T[0]^T[1],(T[0]^T[1])^2,T[0]);
20707: }
20708: for(V=vars(N);V!=[];V=cdr(V)){
20709: T=args(Y=car(V));
20710: if(functor(Y)==pow&&T[1]==1/2)
20711: N=substblock(N,T[0]^T[1],(T[0]^T[1])^2,T[0]);
20712: }
20713: for(V=vars(N);V!=[];V=cdr(V)){
20714: T=args(Y=car(V));
20715: if(functor(Y)==pow&&T[1]==1/2){
20716: Ag=T[0];
20717: R=S=1;
20718: An=fctr(nm(Ag));
20719: CA=An[0][0];
20720: if(CA<0){
20721: CA=-CA;R=-1;
20722: }
20723: if(type(I=sqrtrat(CA))<2) S=I;
20724: else R*=CA;
20725: for(An=cdr(An);An!=[];An=cdr(An)){
20726: Pw=car(An)[1];I=iand(Pw,1);
20727: if(I) R*=car(An)[0];
20728: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
20729: }
20730: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
20731: Pw=car(An)[1];I=iand(Pw,1);
20732: if(I) R/=car(An)[0]^I;
20733: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
20734: }
20735: if(S!=1) N=subst(N,Y,R^(1/2)*S);
20736: }
20737: }
20738: for(V=vars(N);V!=[];V=cdr(V)){
20739: T=args(Y=car(V));
20740: if(functor(Y)==pow&&T[1]==1/2){
20741: C=mycoef(N,1,Y);
20742: for(VC=vars(C);VC!=[];VC=cdr(VC)){
20743: TC=args(YC=car(VC));
20744: if(functor(YC)==pow&&TC[1]==1/2){
20745: Ag=red(T[0]*TC[0]);
20746: R=S=1;
20747: An=fctr(nm(Ag));
20748: CA=An[0][0];
20749: if(CA<0){
20750: CA=-CA;R=-1;
20751: }
20752: if(type(I=sqrtrat(CA))<2) S=I;
20753: else R*=CA;
20754: for(An=cdr(An);An!=[];An=cdr(An)){
20755: Pw=car(An)[1];I=iand(Pw,1);
20756: if(I) R*=car(An)[0];
20757: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
20758: }
20759: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
20760: Pw=car(An)[1];I=iand(Pw,1);
20761: if(I) R/=car(An)[0]^I;
20762: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
20763: }
20764: CC=mycoef(C,1,YC);
20765: N=N-CC*YC*Y+CC*R^(1/2)*S;
20766: }
20767: }
20768: }
20769: }
20770: return red(N/D);
20771: }
20772:
20773: def cfrac2n(X)
20774: {
20775: if(type(L=getopt(loop))==1&&L>0)
20776: C=x;
20777: else{
20778: C=0;L=0;
20779: }
20780: if(L>1){
20781: for(Y=[];L>1;L--){
20782: Y=cons(car(X),Y);
20783: X=cdr(X);
20784: }
20785: if(X!=[]){
20786: P=cfrac2n(X|loop=1);
20787: for(V=P,Y=reverse(Y);Y!=[];Y=cdr(Y))
20788: V=sqrt2rat(car(Y)+1/V);
20789: return V;
20790: }else{
20791: C=0;X=reverse(Y);
20792: }
20793: }
20794: for(V=C,X=reverse(X);X!=[];X=cdr(X)){
20795: if(V!=0) V=1/V;
20796: V+=car(X);
20797: }
20798: if(C!=0){
20799: V=red(V);P=dn(V)*x-nm(V);
20800: S=getroot(P,x|cpx=2);
20801: T=map(eval,S);
20802: V=(T[0]>0)?S[0]:S[1];
20803: }
20804: return V;
20805: }
20806:
20807: def s2sp(S)
20808: {
20809: if(getopt(short)==1){
20810: if(type(F=getopt(std))==1) S=s2sp(S|std=F);
20811: if(type(S)!=7) S=s2sp(S);
20812: L=strtoascii(S);
20813: for(LS=[],F=C=0;L!=[];L=cdr(L)){
20814: if((G=car(L))!=F){
20815: LS=cons(G,LS);C=0;
20816: }else if(C<3){
20817: LS=cons(G,LS);
20818: }else if(C==3){
20819: LS=cdr(LS);LS=cdr(LS);
20820: LS=cons(94,LS);LS=cons(52,LS);
20821: }else if(C==9){
20822: LS=cdr(LS);LS=cons(97,LS);
20823: }else{
20824: K=car(LS);LS=cdr(LS);LS=cons(K+1,LS);
20825: }
20826: C++;F=G;
20827: }
20828: return asciitostr(reverse(LS));
20829: }
20830: if(type(F=getopt(std))==1){
20831: F=(F>0)?1:-1;
20832: if(type(S)==7) S=s2sp(S);
20833: for(L=[];S!=[];S=cdr(S))
20834: L=cons(os_md.msort(car(S),[-1,0]),L);
20835: return os_md.msort(L,[F,2]);
20836: }
20837: if(type(S)==7){
20838: S = strtoascii(S);
20839: if(type(S) == 5) S = vtol(S);
20840: for(N=0,R=TR=[]; S!=[]; S=cdr(S)){
20841: if(car(S)==45) /* - */
20842: N=1;
20843: else if(car(S)==47) /* / */
20844: N=2;
20845: if(N>0){
20846: while(car(S)<48&&car(S)!=40) S=cdr(S);
20847: }
20848: if((T=car(S))>=48 && T<=57) TR=cons(T-48,TR);
20849: else if(T>=97) TR=cons(T-87,TR);
20850: else if(T>=65 && T<=90) TR=cons(T-29,TR); /* A-Z */
20851: else if(T==44){
20852: R=cons(reverse(TR),R);
20853: TR=[];
20854: }else if(T==94){ /* ^ */
20855: S=cdr(S);
20856: if(car(S)==40){ /* ( */
20857: S=cdr(S);
20858: for(T=0; car(S)!=41 && S!=[]; S=cdr(S)){
20859: V=car(S)-48;
20860: if(V>=10) V-=39;
20861: T=10*T+V;
20862: }
20863: }else{
20864: while(car(S)<48) S=cdr(S);
20865: T=car(S)-48;
20866: if(T>=10) T-=39;
20867: }
20868: while(--T>=1) TR=cons(car(TR),TR);
20869: }else if(T==40){ /* ( */
20870: S=cdr(S);
20871: if(N==1){
20872: N=0; NN=1;
20873: }else NN=0;
20874: if(car(S)==45){ /* - */
20875: S=cdr(S);
20876: NN=1-NN;
20877: }
20878: for(I=0; I<2; I++){
20879: for(V=0; (SS=car(S))!=41 && SS!=47 && S!=[]; S=cdr(S)){
20880: T=SS-48;
20881: if(T>=10) T-=39;
20882: V=10*V+T;
20883: }
20884: if(NN==1){
20885: V=-V; NN=0;
20886: }
20887: TR=cons(V,TR);
20888: if(SS!=47) break;
20889: else{
20890: N=2; S=cdr(S);
20891: }
20892: }
20893: }else if(T==60){
20894: for(V=[],S=cdr(S);S!=[]&&car(S)!=62;S=cdr(S))
20895: V=cons(car(S),V);
20896: if(car(S)!=62) continue;
20897: TR=cons(eval_str(asciitostr(reverse(V))),TR);
20898: }else if(T<48) continue;
20899: if(N==1){
20900: T = car(TR);
20901: TR=cons(-T,cdr(TR));
20902: N=0;
20903: }else if(N==2){
20904: T=car(TR); TR=cdr(TR);
20905: TR=cons(car(TR)/T,cdr(TR));
20906: N=0;
20907: }
20908: }
20909: return reverse(cons(reverse(TR),R));
20910: }else if(type(S)==4){
20911: Num=getopt(num);
20912: for(R=[]; ; ){
20913: if(type(TS=car(S))!=4) return;
20914: for(; TS!=[]; TS=cdr(TS)){
20915: V=car(TS);
20916: if(type(V)>1||(type(V)==1&&ntype(V)>0)){
20917: V="<"+rtostr(V)+">";
20918: R=append(reverse(strtoascii(V)),R);
20919: continue;
20920: }
20921: if(dn(V)>1){
20922: P=reverse(strtoascii(rtostr(V)));
20923: R=append(P,cons(40,R));
20924: R=cons(41,R);
20925: continue;
20926: }
20927: if(V<0 && V>-10){
20928: V=-V;
20929: R=cons(45,R);
20930: }
20931: if(V<0 || V>35 || (V>9 && Num==1)){
20932: P=reverse(strtoascii(rtostr(V)));
20933: R=append(P,cons(40,R));
20934: V=41;
20935: }else if(V<10) V+=48;
20936: else V+=87;
20937: R=cons(V,R);
20938: }
20939: if((S=cdr(S))==[]) break;
20940: R=cons(44,R);
20941: }
20942: return asciitostr(reverse(R));
20943: }
20944: return 0;
20945: }
20946:
20947: def sp2grs(M,A,L)
20948: {
20949: MM = [];
20950: T0 = 0;
20951: Mat=getopt(mat);
20952: if(Mat!=1) Mat=0;
20953: if(type(M)==7) M=s2sp(M);
20954: if((LM = length(M)) > 10 && type(A) < 4)
20955: CK = 1;
20956: Sft = (type(L)==1)?L:0;
20957: if(type(L)==4 && length(L)>=3)
20958: Sft = L[2];
20959: if(Sft < 0){
20960: T0 = 1;
20961: Sft = -Sft-1;
20962: }
20963: for(I = LM-1; I >= 0; I--){
20964: MI = M[I]; MN = [];
20965: if(CK == 1 && length(MI) > 10){
20966: erno(1);
20967: return;
20968: }
20969: if(type(A) == 4)
20970: AA = rtostr(A[I]);
20971: else
20972: AA = rtostr(A)+rtostr(I);
20973: for(J = LM = length(MI)-1; J >= 0; J--){
20974: V = MI[J];
20975: if(type(V) > 3)
20976: V = V[0];
20977: if(T0 == 0 || I == 0)
20978: MN = cons([V, makev([AA,J+Sft])], MN);
20979: else{
20980: if(LM == 1)
20981: MN = cons([V, (J==0)?0:makev([AA])], MN);
20982: else if(I == 1 && Mat == 0)
20983: MN = cons([V, (J==length(MI)-1)?0:makev([AA,J+Sft])], MN);
20984: else
20985: MN = cons([V, (J==0)?0:makev([AA,J])], MN);
20986: }
20987: }
20988: MM = cons(MN, MM);
20989: }
20990: if(type(L) == 4 && length(L) >= 2){
20991: R = chkspt(MM|mat=Mat); /* R[3]: Fuchs */
20992: AA = var(MM[L[0]-1][L[1]-1][1]);
20993: if(AA==0) AA=var(R[3]);
20994: if(AA!=0 && (P = mycoef(R[3],1,AA))!=0){
20995: P = -mycoef(R[3], 0, AA)/P;
20996: MM = mysubst(MM,[AA,P]);
20997: }
20998: }
20999: return MM;
21000: }
21001:
21002: def intpoly(F,X)
21003: {
21004: if((T=ptype(F,X))<4){
21005: if(T<3){ /* polynomial */
21006: if(type(C=getopt(cos))>0){
21007: V=vars(F);
21008: Z=makenewv(V);
21009: W=makenewv(cons(Z,V));
21010: Q=intpoly(F,X|exp=Z);
21011: Q=(subst(Q,Z,@i*C)*(Z+@i*W)+subst(Q,Z,-@i*C)*(Z-@i*W))/2;
21012: return [mycoef(Q,1,Z),mycoef(Q,1,W)];
21013: }
21014: if(type(C=getopt(sin))>0){
21015: Q=intpoly(F,X|cos=C);
21016: return [-Q[1],Q[0]];
21017: }
21018: if(type(C=getopt(log))>0){
21019: Q=intpoly(F,X);
21020: if(C[0]==0) return [Q,0];
21021: if(length(C)<3) C=[C[0],C[1],1];
21022: Q-=subst(Q,X,-C[1]/C[0]);
21023: if(iscoef(Q,os_md.israt)) Q=red(Q);
21024: if(C[2]==0) return [Q];
21025: S=subst(-Q*C[0]*C[2],X,X-C[1]/C[0]);
21026: for(R=0,D=mydeg(S,X);D>0;D--) R+=mycoef(S,D,X)*X^(D-1);
21027: R=subst(R,X,X+C[1]/C[0]);
21028: return cons(Q,intpoly(R,X|log=[C[0],C[1],C[2]-1]));
21029: }
21030: if(type(C=getopt(exp))>0){
21031: D = mydeg(F,X);
21032: for(P=Q=F/C;D>=0;D--){
21033: Q=-mydiff(Q,X)/C;
21034: P+=Q;
21035: }
21036: return P;
21037: }
21038: for(P=0,I=mydeg(F,X);I >= 0;I--)
21039: P += mycoef(F,I,X)*X^(I+1)/(I+1);
21040: return P;
21041: }
21042: R=pfrac(F,X|root=2); /* rational */
21043: for(P=0;R!=[];R=cdr(R)){
21044: if(type(V=getopt(dumb))==5){
21045: for(PF=[],RR=R;RR!=[];RR=cdr(RR))
21046: PF=cons(RR[0][0]/RR[0][1]^RR[0][2],PF);
21047: PF=[cons(X,reverse(PF))];
21048: if(P) PF=cons([1,P],PF);
21049: V[0]=cons(PF,V[0]);
21050: }
21051: RT=car(R);
21052: if(mydeg(RT[1],X)==0) P+=intpoly(RT[0]*RT[2],X);
21053: else if((Deg=mydeg(RT[1],X))==1){
21054: if(RT[2]>1) P+=RT[0]*RT[1]^(1-RT[2])/(1-RT[2])/mycoef(RT[1],1,X);
21055: else P+=RT[0]*log(RT[1])/mycoef(RT[1],1,X);
21056: P=red(P);
21057: }else if(Deg==2){
21058: D1=diff(RT[1],X);C1=mycoef(D1,1,X);
21059: B=2*C1*mycoef(RT[1],0,X)-mycoef(RT[1],1,X)^2; /* ax^2+bx+c => B=4ac-b^2 */
21060: B=sqrt2rat(B);
21061: N=RT[0];
21062: for(I=RT[2];I>0&&N!=0;I--){
21063: C0=mycoef(N,1,X)/C1;N-=C0*D1;
21064: if(C0){
21065: if(I>1) P-=C0/RT[1]^(I-1)/(I-1);
21066: else P+=C0*log(RT[1]);
21067: }
21068: if(I>1){
21069: BB=B/C1;
21070: P+=N*X/RT[1]^(I-1)/(I-1)/BB;
21071: N*=(2*I-3)/(I-1)/BB;
21072: }else{
21073: if(type(BR=sqrtrat(B))>3){
21074: mycat(["Cannot obtain sqare root of ",B]);
21075: return [];
21076: }
21077: if(real(nm(BR))!=0){
21078: P+=(2*N/BR)*atan(sqrt2rat(D1/BR|mult=1));
21079: }else{
21080: BR*=@i;BRI=sqrt2rat(1/BR);
21081: R1=(-mycoef(RT[1],1,X)+BR)/C1;
21082: R2=(-mycoef(RT[1],1,X)-BR)/C1;
21083: P+=N*BRI*log( /* sqrt2rat */((x-R1)/(x-R2)));
21084: }
21085: }
21086: P=red(P);
21087: }
21088: P=sqrt2rat(P);
21089: }else{
21090: mycat(["Cannot get an indefinite integral of ",F]);
21091: return [];
21092: }
21093: }
21094: Q=simplog(P,X);
21095: if(type(V)==5&&nmono(P)!=nmono(Q)) V[0]=cons([[1,red(P)]],V[0]);
21096: return red(Q);
21097: }
21098: return [];
21099: }
21100:
21101: def fshorter(P,X)
21102: {
21103: Q=sqrt2rat(P);
21104: R=trig2exp(Q,X|inv=1);
21105: if(str_len(fctrtos(R))<str_len(fctrtos(Q))) Q=R;
21106: Var=pfargs(Q,X|level=1);
21107: for(C=F=0,R=1,V=Var;V!=[];V=cdr(V)){
21108: if(findin(car(V)[1],[cos,sin,tan])>=0){
21109: if(!C){
21110: F=car(V)[2];
21111: }else{
21112: R=red(car(V)[2]/F);
21113: if(type(R)!=1) break;
21114: F/=dn(R);
21115: }
21116: C++;
21117: }
21118: }
21119: if(getopt(period)==1) return F;
21120: if(!isint(Log=getopt(log))) Log=0;
21121: if(V==[]&&F!=0){
21122: if(iand(Log,1)){
21123: H=append(cdr(fctr(nm(Q))),cdr(fctr(dn(Q))));
21124: for(L=0;H!=[];H=cdr(H))
21125: L+=str_len(rtostr(car(H)[0]));
21126: }else L=str_len(fctrtos(Q));
21127: S=trig2exp(P,X);
21128: for(T=[sin(F),tan(F),cos(F),sin(F/2),cos(F/2),tan(F/2)];T!=[];T=cdr(T)){
21129: R=trig2exp(S,X|inv=car(T));
21130: if(iand(Log,1)){
21131: H=append(cdr(fctr(nm(R))),cdr(fctr(dn(R))));
21132: for(K=0;H!=[];H=cdr(H))
21133: K+=str_len(rtostr(car(H)[0]));
21134: }else K=str_len(fctrtos(R));
21135: if(K<L){
21136: Q=R;L=K;
21137: }
21138: }
21139: }
21140: return Q;
21141: }
21142:
21143: def isshortneg(P)
21144: {
21145: return(str_len(rtostr(P))>str_len(rtostr(-P)))?1:0;
21146: }
21147:
21148: def simplog(R,X)
21149: {
21150: for(V=[],Var=pfargs(R,X);Var!=[];Var=cdr(Var)){
21151: VT=car(Var);
21152: if(VT[1]==log && ptype(R,VT[0])==2 && mydeg(R,VT[0])==1)
21153: V=cons([VT[0],VT[2],mycoef(R,1,VT[0])],V);
21154: }
21155: for(;V!=[];V=cdr(V)){
21156: VT=car(V);
21157: for(V2=cdr(V);V2!=[];V2=cdr(V2)){
21158: Dn=1;
21159: if((C=red(car(V2)[2]/VT[2]))!=1&&C!=-1){
21160: if(getopt(mult)==1&&type(C)==1&&ntype(C)==0){
21161: Dn=dn(C);C*=Dn;
21162: }else continue;
21163: }
21164: Log=red(VT[1]^Dn*car(V2)[1]^(Dn*C));
21165: L=str_len(rtostr(dn(Log)))-str_len(rtostr(nm(Log)));
21166: if(L>0 || (L==0&&isshortneg(VT[2])) ){
21167: Dn=-Dn;Log=1/Log;
21168: }
21169: R=mycoef(R,0,VT[0]);R=mycoef(R,0,car(V2)[0]);
21170: return(R+VT[2]*log(Log)/Dn);
21171: }
21172: }
21173: return R;
21174: }
21175:
21176: def integrate(P,X)
21177: {
21178: Dvi=getopt(dviout);
21179: if(type(I=getopt(I))==4){
21180: if((R=integrate(P,X))==[]) II="?";
21181: else if(type(I[0])>3||type(I[1])>3){
21182: R=subst(R,X,x);
21183: V=flim(R,I[0]);VV=flim(R,I[1]);
21184: if(V==""||VV=="") II="?";
21185: else if(type(V)==7||type(VV)==7){
21186: if(V==VV) II="?";
21187: else II=(VV=="+"||V=="-")?"\\infty":"-\\infty";
21188: }else{
21189: II=VV-V;
21190: if(II>10^10) II="\\infty";
21191: else if(II<-10^10) II="-\\infty";
21192: }
21193: }else{
21194: V=subst(R,X,I[1])-subst(R,X,I[0]);
21195: VV=myval(V);
21196: II=(type(VV)>=2||ntype(VV)<1)?VV:evalred(V);
21197: }
21198: if(type(Dvi)!=1) return II;
21199: I=ltov(I);
21200: for(J=0;J<2;J++){
21201: if(type(I[J])>3){
21202: if(type(I[J])==4&&length(I[J])>1) I[J]=I[J][1];
21203: else I[J]=(J==0)?"-\\infty":"\\infty";
21204: }
21205: if(type(I[J])<4) I[J]=my_tex_form(I[J]);
21206: }
21207: S=(type(II)==7)?II:my_tex_form(II);
21208: S="\\int_{"+I[0]+"}^{"+I[1]+"}"+monototex(P)+"\\,d"+my_tex_form(X)+"&="+S;
21209: if(Dvi==1) dviout(texbegin("align",S));
21210: return S;
21211: }
21212: if(isint(Dvi)==1){
21213: if(Dvi==2||getopt(dumb)==-1){
21214: V=newvect(1);V[0]=[];
21215: }else V=0;
21216: if((RR=integrate(P,X|dumb=V))==[]) return R;
21217: S=fshorter(RR,X);
21218: VV=[X];
21219: if(V!=0){
21220: R=cons([[1,RR]],V[0]);
21221: if(S!=RR) R=cons([[1,RR=S]],R);
21222: for(V=FR=[];R!=[];R=cdr(R))
21223: if(car(R)!=FR) V=cons(FR=car(R),V);
1.21 takayama 21224: Var=varargs(V|all=2);
1.6 takayama 21225: for(S0=[x0,x1,x2,x3],S=[t,s,u,v,w];S0!=[]&&S!=[];){
21226: if(findin(car(S0),Var)<0){
21227: S0=cdr(S0); continue;
21228: }
21229: if(findin(car(S),Var)>=0){
21230: S=cdr(S); continue;
21231: }
21232: V=subst(V,[car(S0),car(S)]);S0=cdr(S0);S=cdr(S);
21233: }
21234: if(Dvi==-2) return V;
21235: S1="\\,dx&";
21236: }else{
21237: V=[[],[[1,RR=S]]];
21238: S1="\\,dx";
21239: }
21240: if(type(P)>2){
21241: if(type(nm(P))<2){
21242: P=P*dx;S1=V?"&":"";
21243: }
21244: S=fctrtos(P|TeX=2,lim=0);SV0=my_tex_form(P);
21245: if(str_len(SV0)<str_len(S)) S=SV0;
21246: }else S=monototex(P);
21247: if(Dvi!=-2) S="\\int "+S+S1;
21248: else S="";
21249: for(L=[],V=cdr(V);V!=[];V=cdr(V)){
21250: CL=car(V);S0=["="]; /* a line */
21251: for(FL=0;CL!=[];CL=cdr(CL),FL++){
21252: CT=car(CL); /* a term */
21253: if((Y=CT[0])==0){ /* a variable */
21254: CT=cdr(CT);
21255: if(length(CT)>2) CT=cdr(CT);
21256: S0=["\\qquad(",CT[0],"=",CT[1],")"];
21257: break;
21258: }else{
21259: for(FT=0,S2=[],CT=cdr(CT);CT!=[];CT=cdr(CT),FT++){
21260: SV=fctrtos(car(CT)|TeX=2,lim=0);SV0=my_tex_form(car(CT));
21261: if(str_len(SV0)<str_len(SV)) SV=SV0;
21262: if(FL||FT||(F&&type(Y)<2)) SV=minustos(SV);
21263: S2=append(["+",SV],S2);
21264: }
21265: S2=reverse(cdr(S2));
21266: if(type(Y)>1){
21267: if(length(S2)>1){
21268: S1="\\int\\left(";S3="\\right)\\,d";
21269: }else{
21270: S1="\\int";S3="\\,d";
21271: }
21272: S2=cons(S1,append(S2,[S3,Y]));
21273: if(findin(Y,VV)<0) VV=cons(Y,VV);
21274: }
21275: if(FL) S0=append(S0,cons("+",S2));
21276: else S0=append(S0,S2);
21277: }
21278: }
21279: L=append([S0],L);
21280: };
21281: V=pfargs(RR,X|level=1);
21282: for(Var=[];V!=[];V=cdr(V)) Var=cons(car(V)[0],Var);
21283: Var=reverse(Var);
21284: if(!isint(J=getopt(frac))) J=0;;
21285: if(!iand(J,4)&&(!iand(J,2)||length(Var)==1)&&(iand(J,8)==8||ptype(RR,Var)==2)){
21286: F=1;
21287: if(iand(J,1)){
21288: K=str_len(fctrtos(RR));
21289: I=str_len(fctrtos(RR|var=Var));
21290: if(I>=K) F=0;
21291: }
21292: if(F){
21293: V=[fctrtos(RR|var=Var,TeX=2)];
21294: if(Dvi!=-2) V=cons("=",V);
21295: if(length(L)>0) L=cdr(L);
21296: L=append([V],L);
21297: }
21298: }else if(ptype(RR,X)==2){
21299: L=cdr(L);
21300: V=[fctrtos(RR|var=X,TeX=2)];
21301: if(Dvi!=-2) V=cons("=",V);
21302: L=append([V],L);
21303: }
21304: S=texket(S+ltotex(reverse(L)|opt=["cr","spts0"],str=1));
21305: if(getopt(log)!=1){
21306: for(V=[];VV!=[];VV=cdr(VV))
21307: V=cons(strtoascii(my_tex_form(car(VV))),V);
21308: S1=strtoascii("\\log");
21309: for(F=1;F;){ /* log(log(x)) */
21310: F=FT=0;
21311: S0=strtoascii(S); /* log(x) -> log|x| */
21312: L=length(S0);
21313: S2=str_tb(0,0);
21314: for(I=0;;){
21315: if(I>=L||(J=str_str(S0,S1|top=I+FT))<0){
21316: S=str_tb(0,S2)+str_cut(S0,I,100000);
21317: break;
21318: }
21319: if((K=str_str(S0,40|top=J+4))<0
21320: ||(K!=J+4&&K!=J+9)||(N=str_pair(S0,K+1,40,41))<0){
21321: FT=J-I+4;continue;
21322: }
21323: FT=0;
21324: if(str_str(S0,V|top=K+1,end=N-1)[0]<0) S2=str_tb(str_cut(S0,I,N),S2);
21325: else{
21326: /* log(a) -> log(a) */
21327: F=1;
21328: if(N<L-1&&S0[N+1]==94){ /* log(x)^2 -> (log|x|)^2 */
21329: S2=str_tb([str_cut(S0,I,J-1),"\\left(",str_cut(S0,J,K-1),
21330: "|",str_cut(S0,K+1,N-1),"|\\right)"],S2);
21331: }
21332: else S2=str_tb([str_cut(S0,I,K-1),"|",str_cut(S0,K+1,N-1),"|"],S2);
21333: }
21334: I=N+1;
21335: }
21336: }
21337: }
21338: if(Dvi>0){
21339: dviout(texbegin("align*",S));
21340: return 1;
21341: }
21342: return S;
21343: } /* end of dviout */
21344: SM=["Cannot integrate",P,"at present"];
21345: P=sqrt2rat(P|mult=1);
21346: Dumb2=1;Dumb3=0;W=newvect(1);W[0]=[];
21347: if(type(Dumb=getopt(dumb))==5){
21348: Dumb2=Dumb3=Dumb;D2=W;
21349: }else if(!isint(Dumb)) Dumb=0;
21350: if(Dumb==-1){
21351: Dumb2=Dumb3=-1;
21352: }
21353: if(type(Dumb)!=5) D2=Dumb2;
21354: if(!isint(Mul=getopt(mult))) Mul=0;
21355: else Mul++;
21356: if(type(VAR=getopt(var))!=4) VAR=[];
21357: if(type(P)>4) return [];
21358: if(iand(T=ptype(P=red(P),X),63)>3||Mul>4){
21359: if(Dumb!=1) mycat(SM);
21360: return [];
21361: }
21362: if(Dumb==-1) mycat(["integrate", P]);
21363: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
21364: if(T<4 && (T<3||iscoef(P,os_md.israt))){
21365: if(Dumb==-1) mycat(["rational function",P]);
21366: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
21367: return intpoly(P,X|dumb=Dumb); /* rational function */
21368: }
21369: Var=pfargs(P,X);
21370: for(F=0,VV=Var;VV!=[];VV=cdr(VV)){
21371: /* p(x)*log(x^2-1), @e^x, a^x, f(x)^(m/n) etc.->simplify */
21372: V=car(VV);
21373: if(V[1]==log && (T=ptype(V[2],X))>1 && T<4){
21374: if(mydeg(dn(V[2]),X)>0||mydeg(nm(V[2]),X)>1){
21375: FC=pfctr(V[2],X);RV=1;
21376: if(length(FC)>2){
21377: RR=0;RV=1;
21378: if((F0=car(FC)[0])!=1){
21379: if(type(F0)!=1 && F0<0){
21380: for(FT=cdr(FT);FT!=[];FT=cdr(FT)){
21381: if(iand(car(FT)[1],1)){
21382: RV=-1;F0=-F0;break;
21383: }
21384: }
21385: }
21386: }
21387: if(F0!=1) RR=log(F0);
21388: for(FC=cdr(FC);FC!=[];FC=cdr(FC)){
21389: if(RV==-1&&iand(car(FC)[1],1)==1){
21390: RR+=car(FC)[1]*log(-car(FC)[0]);
21391: RV=1;
21392: }else
21393: RR+=car(FC)[1]*log(car(FC)[0]);
21394: }
21395: P=subst(P,V[0],RR);
21396: F=1;
21397: }
21398: }
21399: F=1;
21400: }else if(V[1]==pow){
21401: if(ptype(V[2],X)==1){
21402: F=1;
21403: if(V[2]==@e){ /* @e^(f(x)) */
21404: P=subst(P,V[0],exp(V[3]));
21405: }else P=subst(P,V[0],exp(log(V[2])*V[3]));
21406: }else if(type(V[3])<=1 && ntype(V[3])==0){ /* r(x)^(m/n) */
21407: if((Pw=floor(V[3]))!=0){
21408: R=V[2]^Pw;
21409: if((PF=V[3]-Pw)!=0) R*=V[2]^PF;
21410: P=subst(P,V[0],R);
21411: F=1;
21412: V=[V[2]^PF,V[1],V[2],PF];
21413: }
21414: if(ptype(nm(V[2]),X)<2&&V[3]>0){ /* (1/p(x))^(m/n) */
21415: P=subst(P,V[0],V[2]*red(1/V[2])^(1-V[3]));
21416: F=0;VV=cons(0,Var=pfargs(P,X));continue;
21417: }
21418: if(ptype(V[2],X)<4&&(K=dn(V[3]))>1){
21419: V2=red(V[2]);
21420: DN=mydeg(nm(V2),X);DD=mydeg(dn(V2),X);
21421: if(DN+DD>1){
21422: VF=pfctr(V2,X);
21423: R=car(VF)[0]^(car(VF)[1]);RR=0;
21424: for(VF=cdr(VF);VF!=[];VF=cdr(VF)){
21425: TV=car(VF);TM=TV[1];
21426: while(abs(TM)>=K){
21427: RR=1;
21428: if(TM>0){
21429: TM-=K;
21430: RR*=TV[0]^nm(V[3]);
21431: }else{
21432: TM+=K;
21433: RR/=TV[0]^nm(V[3]);
21434: }
21435: }
21436: if(TM!=0) R*=TV[0]^TM;
21437: }
21438: if(RR){
21439: P=subst(P,V[0],RR*red(R)^(V[3]));F=1;
21440: F=0;VV=cons(0,Var=pfargs(P,X));continue;
21441: }
21442: }
21443: }
21444: }
21445: }
21446: }
21447: if(F){
21448: P=sqrt2rat(P|mult=1);
21449: Var=pfargs(P=red(P),X);T=ptype(P,X);
21450: if(T<4 && (T<3||iscoef(P,os_md.israt))){
21451: if(Dumb==-1) mycat(["rational function",P]);
21452: else if(type(Dumb)==5){
21453: Dumb[0]=cons([[X,P]],Dumb[0]);
21454: return intpoly(P,X|dumb=Dumb3);
21455: }
21456: return intpoly(P,X); /* rational function */
21457: }
21458: }
21459: #if 1
21460: for(P0=P,V=pfargs(P,X|level=1);V!=[];V=cdr(V)) /* P:tan(x) -> P0:sin(x)/cos(x) */
21461: if(car(V)[1]==tan) P0=red(subst(P0,car(V)[0],sin(car(V)[2])/cos(car(V)[2])));
21462: if(iand(ptype(P0,X),128)){ /* (log f)'=f'/f */
21463: for(Df=cdr(fctr(dn(P0)));Df!=[];Df=cdr(Df)){
21464: if(!iand(ptype(car(Df)[0],X),64)) continue;
21465: Q=car(Df)[0]^(car(Df)[1]);QQ=red(dn(P0)/Q);
21466: DQ=red(diff(Q,X)*QQ);
21467: if(type(C=DQ/nm(P0))<2&&C!=0){
21468: PP=0;DN=[1];
21469: }else for(DN=cdr(fctr(DQ));DN!=[];DN=cdr(DN)){
21470: Y=car(DN)[0];
21471: if(!iand(ptype(Y,X),64)||(I=mydeg(nm(P0),Y))!=mydeg(DQ,Y)
21472: || ptype((C=red(mycoef(nm(P0),I,Y)/mycoef(DQ,I,Y))),X)>1||C==0) continue;
21473: PP=red(P0-C*diff(Q,X)/Q);
21474: if(nmono(P0)>nmono(PP)) break;
21475: }
21476: if(DN!=[]){
21477: R=C*log(Q);
21478: if(PP==0){
21479: if(P!=P0&&type(Dumb)==5) Dumb[0]=cons([[X,P0]],Dumb[0]);
21480: return R;
21481: }
21482: W[0]=[];
21483: S=integrate(PP,X|dumb=D2);
21484: if(S!=[]){
21485: if(type(Dumb)==5){
21486: Dumb[0]=cons([[X,red(P0-PP),PP]],Dumb[0]);
21487: TD=W[0];
21488: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21489: if(car(TD)[0][0]){
21490: WL=cons([1,R],car(TD));
21491: Dumb[0]=cons(WL,Dumb[0]);
21492: }
21493: else Dumb[0]=cons(car(TD),Dumb[0]);
21494: }
21495: }
21496: return red(R+S);
21497: }
21498: }
21499: }
21500: }
21501: #endif
21502: if((length(Var)==1||getopt(exe)==1) && /* p(x)*atan(q(x))^m+r(x), etc */
21503: findin((VT=car(Var))[1],[atan,asin,acos,log])>=0 && ptype(P,VT[0])==2 &&
21504: (VT[1]!=log||(T!=65&&T!=66)||mydeg(VT[2],X)!=1)){ /* exclude x*log(x+1)^2 */
21505: for(R=0,D=mydeg(P,VT[0]);D>=0;D--){
21506: Q=S=mycoef(P,D,VT[0]);
21507: if(S){
21508: if(D>0){
21509: if((Q=integrate(S,X|mult=Mul))==[]) return Q;
21510: }else{
21511: W[0]=[];
21512: if((Q=integrate(S,X|dumb=D2,var=VAR,mult=Mul))==[]) return Q;
21513: if(type(Dumb)==5){
21514: TD=W[0];
21515: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21516: if(car(TD)[0][0]){
21517: WL=cons([1,R],car(TD));
21518: Dumb[0]=cons(WL,Dumb[0]);
21519: }
21520: else Dumb[0]=cons(car(TD),Dumb[0]);
21521: }
21522: if(car(Dumb[0])!=[[1,R],[1,Q]])
21523: Dumb[0]=cons([[1,R,Q]],Dumb[0]);
21524: }
21525: return red(R+Q);
21526: }
21527: }else if(D>0) continue;
21528: if(D==0){
21529: if(Q!=0&&type(Dumb)==5) Dumb[0]=cons([[1,R,Q]],Dumb[0]);
21530: return red(Q+R);
21531: }
21532: R0=Q*VT[0]^D;
21533: P=(P0=P)-S*VT[0]^D-Q*diff(VT[0]^D,X);
21534: if(mydeg(P,VT[0])>=D){ /* (x+1)*log(x)/x^2 */
21535: if(mydeg(P,VT[0])==D &&
21536: ptype(C=red(mycoef(P,D,VT[0])/diff(VT[0],X)),VT[0])<2){
21537: P=P0-(S*VT[0]^D+Q*diff(VT[0]^D,X)+C*diff(VT[0]^(D+1),X)/(D+1));
21538: R0+=C*VT[0]^(D+1)/(D+1);
21539: }else{
21540: P=P0;
21541: if(Dumb!=1) mycat(SM);
21542: return [];
21543: }
21544: }
21545: if(type(Dumb)==5){
21546: if(P) Dumb[0]=cons([R?[1,R,R0]:[1,R0],[X,P]],Dumb[0]);
21547: else if(R!=0) Dumb[0]=cons([[1,R,R0]],Dumb[0]);
21548: }
21549: R+=R0;
21550: }
21551: }
21552: if(length(Var)==1 && (VT=car(Var))[1]==pow && mydeg(P,VT[0])==1 && (PT=ptype(VT[2],X))<4){
21553: PR=mycoef(P,0,VT[0]);
21554: if(RR!=0){
21555: RR=integrate(RR,X|dumb=Dumb3,var=Var);
21556: if(RR==[]) return RR;
21557: }
21558: PW=VT[3];
21559: if((D=mydeg(nm(V2=VT[2]),X))==2&&PT==2){ /* f(x)*(ax^2+bx+c)^(m/2)+r(x) */
21560: if(isint(2*PW)){
21561: C2=mycoef(V20=V2,2,X);F=1;
21562: if((C21=sqrtrat(C2))==[]) return [];
21563: if(imag(C21)!=0){
21564: if(real(C21)!=0) return [];
21565: C21=C21/@i;F=-1;
21566: }
21567: if(type(C21)>3) return [];
21568: P=subst(P,X,X/C21);VT=mysubst(VT,[X,X/C21]);V2=VT[2];
21569: C1=mycoef(V2,1,X)/F/2;
21570: if(C1!=0){
21571: P=subst(P,X,X-C1);VT=mysubst(VT,[X,X-C1]);V2=VT[2];
21572: }
21573: C0=mycoef(V2,0,X);
21574: if((C01=sqrtrat(C0))==[]) return [];
21575: if(imag(nm(C01))!=0){
21576: if(real(nm(C01))!=0) return [];
21577: C01=C01/@i;G=-1;
21578: }else G=1;
21579: if(type(C01)>3||(F==-1&&G==-1)) return [];
21580: Y=makenewv([P,VAR]|var=x);
21581: if(F==-1){ /* (c^2-x^2)^(1/2) */
21582: Q=subst(P,VT[0],(C01*cos(Y))^(2*PW),X,YX=C01*sin(Y))
21583: *C01*cos(Y)/C21;
21584: SY=(C21*X+C1);CY=V20;YY=asin(sqrt2rat((C21*X+C1)/C01|mult=1));
21585: }else if(G==-1){ /* (x^2-c^2)^(1/2) */
21586: Q=subst(P,VT[0],(C01*sin(Y)/cos(Y))^(2*PW),X,YX=C01/cos(Y))
21587: *C01*sin(Y)/cos(Y)^2/C21;
21588: SY=V20;CY=1/(C21*X+C1);YY=acos(sqrt2rat(C01*(C21*X+C1)|mult=1));
21589: }else{ /* (x^2+c^2)^(1/2) */
21590: Q=subst(P,VT[0],(C01/cos(Y))^(2*PW),X,YX=C01*sin(Y)/cos(Y))
21591: *C01/cos(Y)^2/C21;
21592: CY=V20; YY=atan(sqrt2rat((C21*X+C1)/C01|mult=1));
21593: }
21594: if(Dumb==-1) mycat([C21*X+C1,"=",YX]);
21595: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,C21*X+C1,YX]],Dumb[0]);
21596: Q=sqrt2rat(Q);
21597: QQ=red(substblock(nm(Q),sin(Y),sin(Y)^2,1-cos(Y)^2)
21598: /substblock(dn(Q),sin(Y),sin(Y)^2,1-cos(Y)^2));
21599: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
21600: QQ=red(substblock(nm(Q),cos(Y),cos(Y)^2,1-sin(Y)^2)
21601: /substblock(dn(Q),cos(Y),cos(Y)^2,1-sin(Y)^2));
21602: if(cmpsimple(QQ,Q|comp=2)<0) Q=QQ;
21603: if((Q=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var)))==[]) return [];
21604: Q=trig2exp(Q,Y|inv=cos(Y));
21605: for(V=vars(Q);V!=[];V=cdr(V)){
21606: FA=funargs(car(V));
21607: if(type(FA)==4&&FA[0]==log){
21608: QQ=trig2exp(FA[1],Y|inv=cos(Y));
21609: Q=mycoef(Q,0,car(V))+mycoef(Q,1,car(V))*log(QQ);
21610: }
21611: }
21612: if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21613: if(F==-1) Q=subst(Q,sin(Y),SY/C01,cos(Y),CY^(1/2)/C01,Y,YY);
21614: else if(G==-1){
21615: Q=red(subst(Q,sin(Y),SY^(1/2)*cos(Y)/C01));
21616: Q=red(subst(Q,cos(Y),C01*CY,Y,YY));
21617: }else{
21618: Q=red(subst(Q,sin(Y),(C21*X+C1)*cos(Y)/C01));
21619: Nm=substblock(nm(Q),cos(Y),C01^2/CY,cos(Y)^2);
21620: Nm=subst(Nm,cos(Y),C01/CY^(1/2));
21621: Dn=substblock(dn(Q),cos(Y),C01^2/CY,cos(Y)^2);
21622: Dn=subst(Dn,cos(Y),C01/CY^(1/2));
21623: Q=red(subst(Nm/Dn,Y,YY));
21624: }
21625: if(findin(Y,vars(Q))>=0) return [];
21626: for(R=[],Var=vars(Q);Var!=[];Var=cdr(Var)){
21627: VT=funargs(V=car(Var));
21628: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60&&mydeg(Q,V)==1)
21629: R=cons([mycoef(Q,1,V),V],R);
21630: }
21631: if(length(R)==2 && (R[0][0]==R[1][0]||R[0][0]+R[1][0]==0)){
21632: R0=args(R[0][1])[0];R1=args(R[1][1])[0];
21633: if(R[0][0]==R[1][0]) S=R0*R1;
21634: else S=R1/R0;
21635: Q=mycoef(Q,0,R[0][1]);Q=mycoef(Q,0,R[1][1]);
21636: Q+=R[1][0]*log(red(S));
21637: }
21638: for(Var=vars(Q);Var!=[];Var=cdr(Var)){
21639: VT=funargs(car(Var));
21640: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60){
21641: S=trig2exp(VT[1],X|inv=cos(X),arc=1);
21642: if(ptype(dn(S),X)<2 && mydeg(Q,car(Var))==1
21643: && ptype(mycoef(Q,1,car(Var)),X)<2){
21644: S=nm(S);
21645: SF=fctr(S);
21646: S/=SF[0][0];
21647: }
21648: if(cmpsimple(S,-S)>0) S=-S;
21649: Q=subst(Q,car(Var),log(S));
21650: }
21651: } /* x/(1-x^2)^(1/2) */
21652: if(type(Q=red(Q+RR))==2&&type(Dumb)!=5) Q-=cterm(Q);
21653: if(Dumb==-1) mycat(["->",Q]);
21654: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21655: return Q;
21656: }
21657: }else if(D==1 && mydeg(Dn=dn(V2),X)<2 && type(PW)==1 && ntype(PW)==0 &&
21658: (V2!=X||ptype(mycoef(P,1,VT[0]),X)>2)){ /* p(x)((ax+b)/(cx+d))^(m/n) */
21659: PN=nm(PW);PD=dn(PW);
21660: Y=makenewv([P,VAR]|var=x);Q=Y^PD*Dn-nm(V2);F=-mycoef(Q,0,X)/mycoef(Q,1,X);
21661: Q=red(subst(P,VT[0],Y^PN,X,F)*diff(F,Y));
21662: if(Dumb==-1) mycat([Y,"=",V2^(1/PD)]);
21663: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,V2^(1/PD)]],Dumb[0]);
21664: if((Q=integrate(Q,Y|dumb=Dumb3,var=cons(X,Var)))==[]) return [];
21665: Q=red(Q);
21666: QN=subst(substblock(nm(Q),Y,Y^PD,V2),Y,V2^(1/PD));
21667: QD=subst(substblock(dn(Q),Y,Y^PD,V2),Y,V2^(1/PD));
21668: Q=red(QN/QD+RR);
21669: if(Dumb==-1) mycat(["->",Q]);
21670: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21671: return Q;
21672: }
21673: }else if(length(Var)==2 && /* r(x,(ax+b)^(1/2),(cx+d)^(1/2)) */
21674: (VT=car(Var))[1]==pow && ptype(VT[2],X)==1 && mydeg(VT[2],X)==1 && VT[3]==1/2 &&
21675: (VS=car(car(Var)))[1]==pow && ptype(VS[2],X)==1 && mydeg(VS[2],X)==1 && VS[3]==1/2){
21676: Y=makenewv([P,VAR]|var=x);R=(Y^2-myceof(VS[0],0,X))/(C=mycoef(VS[0],1,X));
21677: if(Dumb==-1) mycat([Y,"=",VS[0]]);
21678: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,VD[0]]],Dumb[0]);
21679: R=integrate(subst(P,VS[0],Y,X,R)*2*Y/C,Y|dumb=Dumb3,var=cons(X,Var));
21680: if(R!=[]){
21681: R=subst(substblock(R,Y,VS[0],Y^2),Y,VS[0]);
21682: if(Dumb==-1) mycat(["->",R]);
21683: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21684: }
21685: return R;
21686: }
21687: if(T==65||T==66){ /* polynomial including sin, exp etc */
21688: for(F=0,VT=Var;VT!=[];VT=cdr(VT)){
21689: VTT=car(VT);
21690: if(ptype(VTT[2],X)>2||mydeg(VTT[2],X)>1) F=ior(F,256); /* compos. or rat. or nonlin. */
21691: K=findin(VTT[1],[cos,sin,tan,exp,log,pow]);
21692: F=ior(F,2^(K+1)); /* 1:other,2:cos,4:sin,8:tan,16:exp,32:log,64:pow */
21693: if((Deg=mydeg(P,VTT[0]))>1&&K!=4) F=ior(F,1024); /* nonlinear */
21694: if(K==5 && (ptype(VTT[3],X)!=0 || VTT[2]!=x||Deg>1)) F=ior(F,8192); /* pow */
21695: for(;Deg>0;Deg--){ /* coef */
21696: if(ptype(mycoef(P,Deg,VTT[0]),X)>2){
21697: if(K==4||K==5) F=ior(F,2048); /* exp, log */
21698: else F=ior(F,4096);
21699: }
21700: }
21701: }
21702: if(!iand(F,1+8+64+256+512+2048+8192)){ /* cos,sin,exp,log^n,x^c */
21703: if(iand(F,1024+4096)&&!iand(F,32+64)){ /* cos,sin,exp */
21704: if(type(Dumb)==5){
21705: S=trig2exp(P,X|inv=1);
21706: if(P!=S) Dumb[0]=cons([[X,S]],Dumb[0]);
21707: }
21708: R=integrate(trig2exp(P,X),X);
21709: if(R!=[]) S=trig2exp(R,X|inv=1);
21710: R=fshorter(S,X);
21711: if(type(Dumb)==5&&R!=S){
21712: Dumb[0]=cons([[1,S]],Dumb[0]);
21713: }
21714: return R;
21715: }
21716: for(R=0,VT=Var;VT!=[];VT=cdr(VT)){
21717: CV=car(VT);
21718: C0=mycoef(CV[2],0,X);C1=mycoef(CV[2],1,X);
21719: Q=mycoef(P,1,CV[0]);
21720: if(CV[1]==sin||CV[1]==cos){
21721: TR=(CV[1]==sin)?intpoly(Q,X|sin=C1):intpoly(Q,X|cos=C1);
21722: R+=TR[0]*cos(CV[2])+TR[1]*sin(CV[2]);
21723: }else if(CV[1]==exp){
21724: QT=exp(CV[2]);
21725: for(V2=vars(C1);V2!=[];V2=cdr(V2)){ /* exp(2*log(a)*x) => a^(2*x) */
21726: if(vtype(VA=car(V2))==2&&functor(VA)==log){
21727: if(ptype(C1,VA)!=2||mydeg(C1,VA)==1&&mycoef(C1,0,VA)==0){
21728: QT=args(VA)[0]^(red(C1/VA)*X);
21729: if(C0!=0) QT*=exp(C0);
21730: break;
21731: }
21732: }
21733: }
21734: R+=intpoly(Q,X|exp=C1)*QT;
21735: }else if(CV[1]==pow)
21736: R+=intpoly(Q,X|pow=CV[2])*x^CV[2];
21737: else if(CV[1]==log){
21738: for(Deg=mydeg(P,CV[0]);Deg>0; Deg--){
21739: Q=mycoef(P,Deg,CV[0]);
21740: TR=intpoly(Q,X|log=[C1,C0,Deg]);
21741: for(I=0;TR!=[];I++,TR=cdr(TR)){
21742: if(I==Deg) R+=car(TR)-subst(car(TR),X,0);
21743: else R+=car(TR)*CV[0]^(Deg-I);
21744: }
21745: }
21746: }
21747: P=mycoef(P,0,CV[0]);
21748: }
21749: R+=intpoly(P,X);
21750: return R;
21751: }
21752: }
21753: for(K=0,VX=[],VT=Var;VT!=[];VT=cdr(VT)){ /* contain only both pow and trig */
21754: VTT=car(VT);
21755: if(findin(VTT[1],[cos,sin,tan])>=0){
21756: if(ptype(VTT[2],X)!=2||mydeg(VTT[2],X)!=1) break;
21757: VX=cons(VTT,VX);
21758: }else if(VTT[1]==pow) K=1;
21759: else break;
21760: }
21761: if(VT==[]&&K==1&&VX!=[]){
21762: D=VX[0][2];
21763: if(VX[0][1]==tan) D*=2;
21764: for(VT=cdr(VX);VT!=[];VT=cdr(VT)){
21765: K=VT[0][2]/D;
21766: if(VT[0][1]==tan) K*=2;
21767: if(type(K)!=1||ntype(K)!=0) break;
21768: D/=dn(K);
21769: }
21770: if(VT==[]){
21771: Y=makenewv([P,VAR]|var=x);
21772: for(Q=P,VT=VX;VT!=[];VT=cdr(VT)){
21773: VTT=car(VT);
21774: if(VTT[1]==cos||VTT[1]==sin){
21775: VV=trig2exp(VTT[0],X|inv=cos(D));
21776: VV=subst(VV,cos(D),(1-Y^2)/(1+Y^2),sin(D),2*Y/(Y^2+1));
21777: }else if(VTT[1]==tan){
21778: VV=trig2exp(VTT[0],X|inv=tan(D/2));
21779: VV=subst(VV,tan(D),Y);
21780: }
21781: Q=subst(Q,VTT[0],VV);
21782: }
21783: Q*=2/(Y^2+1);
21784: if(diff(Q,X)==0){
21785: if(Dumb==-1) mycat([Y,"=",tan(D/2)]);
21786: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,tan(D/2)]],Dumb[0]);
21787: R=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var));
21788: if(R!=[]){
21789: if(Dumb==-1) mycat(["->",R]);
21790: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21791: return sqrt2rat(subst(R,Y,tan(D/2))|mult=1);
21792: }
21793: }
21794: }
21795: }
21796: if(T>65||iand(F,8)){ /* rational for functions or tan */
21797: if(findin(X,vars(P))<0){
21798: for(XV=XE=0,VT=Var;VT!=[];VT=cdr(VT)){
21799: VTT=car(VT);
21800: if(mydeg(VTT[2],X)!=1) break;
21801: if(VTT[1]==cos||VTT[1]==sin||VTT[1]==tan){
21802: K=red(VTT[2]/X);
21803: if(type(K)>1||ntype(K)>0) break;
21804: if(XV==0) XV=K;
21805: else XV/=dn(K/XV);
21806: if(VTT[1]==tan) P=red(subst(P,VTT[0],sin(VTT[2])/cos(VTT[2])));
21807: }else if(VTT[1]==exp){
21808: K=red(VTT[2]/X);
21809: if(type(K)>1||ntype(K)>0) break;
21810: if(XE==0) XE=K;
21811: else XE/=dn(K/XE);
21812: }else break;
21813: }
21814: if(VT==[]&&XE*XV==0){
21815: if(XE){
21816: if(XE<0) XE=-XE;
21817: Y=makenewv([P,VAR]|var=x);
21818: for(F=0,VT=Var;VT!=[];VT=cdr(VT),F++){
21819: VTT=car(VT);C=red(VTT[2]/X/XE);
21820: P=subst(P,VTT[0],Y^C);
21821: if(!F){
21822: if(Dumb==-1) mycat([Y^C,"=",VTT[0]]);
21823: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y^C,VTT[0]]],Dumb[0]);
21824: }
21825: }
21826: P/=XE*Y;
21827: Q=integrate(P,Y|dumb=Dumb3,var=cons(X,VAR));
21828: if(Q==[]) return [];
21829: Q=subst(Q,Y,exp(XE*X));
21830: Q=trig2exp(Q,X);
21831: if(Dumb==-1) mycat(["->",Q]);
21832: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
21833: return Q;
21834: }
21835: P=trig2exp(nm(P),X|inv=cos(XV*X))/trig2exp(dn(P),X|inv=cos(XV*X));
21836: Y=makenewv([P,VAR]|var=x);
21837: Q=red(subst(P,sin(XV*X),Y*cos(XV*X)));
21838: Q=substblock(nm(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))/
21839: (substblock(dn(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))*(Y^2+1));
21840: Q=red(Q);
21841: if(ptype(Q,X)<2){
21842: XV*=2;P=Q;
21843: }else{
21844: 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);
21845: P=red(P);
21846: }
21847: if(Dumb==-1){
21848: mycat([Y,"=",tan(XV*X/2)]);
21849: mycat(["integrate",P]);
21850: }else if(type(Dumb)==5) Dumb[0]=cons([[Y,P]],cons([[0,Y,tan(XV*X/2)]],Dumb[0]));
21851: R=intpoly(P,Y|dumb=Dumb);
21852: if(R==[]) return R;
21853: if(Dumb==-1) mycat(["->",R]);
21854: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21855: for(Log=1,K=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
21856: VTT=car(Var);
21857: if(VTT[1]==log){
21858: C=mycoef(R,1,VTT[0]);
21859: VT2=VTT[2];
21860: if(K==0){
21861: K=C;Log=VT2;
21862: if(K<0){
21863: K=-K;Log=1/Log;
21864: }
21865: }else{
21866: if((V=red(C/K))<0){
21867: VT2=1/VT2;V=-V;
21868: }
21869: if(type(V)>1||ntype(V)>0){
21870: Log=1;break;
21871: }
21872: if(isint(V)) Log*=VT2^V;
21873: else{
21874: D=dn(V);K/=D;
21875: Log=Log^D*VT2^nm(V);
21876: }
21877: }
21878: RR=mycoef(RR,0,VTT[0]);
21879: }
21880: }
21881: if(Log!=1){
21882: R=RR;
21883: if(type(Dumb)==5){
21884: if(RR) Dumb[0]=cons([[1,K*log(Log),RR]],Dumb[0]);
21885: else Dumb[0]=cons([[1,K*log(Log)]],Dumb[0]);
21886: }
21887: Log=red(subst(red(Log),Y,sin(XV*X/2)/cos(XV*X/2)));
21888: Log=fshorter(Log,X|log=1); /* log(cos(2*x)+1)=-2*log(cos(x)) */
21889: Nm=fctr(nm(Log));
21890: for(T=[];Nm!=[];Nm=cdr(Nm)){
21891: if(ptype(car(Nm)[0],X)>1) T=cons(car(Nm),T);
21892: }
21893: Nm=fctr(dn(Log));
21894: for(;Nm!=[];Nm=cdr(Nm)){
21895: if(ptype(car(Nm)[0],X)>1) T=cons([car(Nm)[0],-car(Nm)[1]],T);
21896: }
21897: for(I=0,Nm=T;T!=[];T=cdr(T)){
21898: if(I=0) I=abs(car(T)[1]);
21899: else I=igcd(I,car(T)[1]);
21900: }
21901: for(Log=1;Nm!=[];Nm=cdr(Nm)) Log*=car(Nm)[0]^(car(Nm)[1]/I);
21902: K*=I;
21903: if(cmpsimple(nm(Log),dn(Log))<0){
21904: K=-K;Log=red(1/Log);
21905: }
21906: Log=K*log(Log);
21907: if(type(Dumb)==5){
21908: if(RR) Dumb[0]=cons([[1,Log,RR]],Dumb[0]);
21909: else Dumb[0]=cons([[1,Log]],Dumb[0]);
21910: }
21911: }else Log=0;
21912: for(Atan=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
21913: VTT=car(Var);
21914: if(VTT[1]==atan){
21915: W=subst(VTT[2],Y,sin(XV*X/2)/cos(XV*X/2));
21916: W=trig2exp(W,X|inv=1);
21917: V2=funargs(dn(W));
21918: if(type(V2)==4&&length(V2)==2){
21919: V3=V2[1]*mycoef(R,1,VTT[0]);
21920: Z=0;
21921: if(V2[0]==cos)
21922: Z=red(W*cos(V2[1])/sin(V2[1]));
21923: else if(V2[0]==sin){
21924: Z=red(W*sin(V2[1])/cos(V2[1]));
21925: V3=-V3;
21926: }
21927: if(Z==1){
21928: Atan+=V3;W=0;
21929: }else if(Z==-1){
21930: Atan-=V3;W=0;
21931: }
21932: }
21933: R0=mycoef(R,0,VTT[0]);
21934: if(W!=0) Atan+=subst(R-R0,VTT[0],atan(W)); /* atan(W); */
21935: R=R0;
21936: }
21937: }
21938: if(R!=0){
21939: R=subst(R,Y,sin(XV*X/2)/cos(XV*X/2));
21940: R=red(R);
21941: R=trig2exp(nm(R),X|inv=1)/trig2exp(dn(R),X|inv=1);
21942: }
21943: if(type(Dumb)==5){
21944: F=0;WL=[];
21945: if(R){
21946: WL=cons(R,WL);
21947: F++;
21948: }
21949: if(Atan){
21950: WL=cons(Atan,WL);
21951: F++;
21952: }
21953: if(Log){
21954: WL=cons(Log,WL);
21955: F++;
21956: }
21957: WL=cons(1,WL);
21958: if(F>1) Dumb[0]=cons([WL],Dumb[0]);
21959: }
21960: R=red(R+Log+Atan);
21961: if(Dumb==-1) mycat(["->",R]);
21962: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
21963: return fshorter(R,X);
21964: }
21965: }
21966: }
21967: VT=pfargs(Q=P,X|level=1);
21968: V=(iand(ptype(P,X),7)<3)?[X]:[];
21969: for(;VT!=[];VT=cdr(VT))
21970: if(ptype(P,car(VT)[0])<3) V=cons(car(VT)[0],V);
21971: if(length(V)>0){ /* 1/x+tan(x)+... etc.: sums */
21972: for(R=0;V!=[];V=cdr(V)){
21973: T=mycoef(Q,0,car(V));
21974: W[0]=[];
21975: S=integrate(TD=red(Q-T),X|dumb=D2,mult=Mul,exe=1);
21976: if(S==[]) continue;
21977: if(type(Dumb)==5){
21978: WL=0;
21979: if(T!=0) WL=[[X,TD,T]];
21980: if(R!=0) WL=cons([1,R],WL);
21981: if(WL) Dumb[0]=cons(WL,Dumb[0]);
21982: TD=W[0];
21983: if(R!=0||T!=0){
21984: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
21985: if(car(TD)[0][0]){
21986: WL=(!T)?[]:[[X,T]];
21987: WL=append(car(TD),WL);
21988: if(R!=0) WL=cons([1,R],WL);
21989: }else WL=car(TD);
21990: Dumb[0]=cons(WL,Dumb[0]);
21991: }
21992: }else Dumb[0]=append(TD,Dumb[0]);
21993: }
21994: R+=S;Q=T;
21995: if(!Q) return red(R);
21996: }
21997: W[0]=[];
21998: if(P!=Q&&type(S=integrate(Q,X|dumb=D2,mult=Mul))<4){
21999: RR=red(R+S);
22000: if(type(Dumb)==5){
22001: TD=W[0];
22002: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
22003: if(car(TD)[0][0]){
22004: WL=cons([1,R],car(TD));
22005: Dumb[0]=cons(WL,Dumb[0]);
22006: }
22007: else Dumb[0]=append(TD,Dumb[0]);
22008: }
22009: if(nmono(R)+nmono(S)!=nmono(RR)) Dumb[0]=cons([[1,R,S]],Dumb[0]);
22010: }
22011: return RR;
22012: }
22013: }
22014: if(Dumb!=1) mycat(SM);
22015: return [];
22016: }
22017:
22018: def fimag(P)
22019: {
22020: for(V=vars(P);V!=[];V=cdr(V)){
22021: Q=[];
22022: if(vtype(VF=car(V))==2){
22023: VAA=args(VF);
22024: if(VAA==[]) continue;
22025: VA=sqrt2rat(VAA[0]);
22026: if(functor(VF)==exp){
22027: if(imag(VA)!=0){
22028: R=(real(VA)!=0)?exp(real(VA)):1;
22029: Q=subst(P,VF,R*(cos(imag(VA))+sin(imag(VA))*@i));
22030: }
22031: }else if(functor(VF)==pow){
22032: VA=sqrt2rat(VAA[1]);
22033: if(imag(VA)!=0){
22034: R=(real(VA)!=0)?VAA[0]^(real(VA)):1;
22035: L=(VAA[0]!=@e)?log(VAA[0]):1;
22036: Q=subst(P,VAA[0]^(VAA[1]),R*(cos(L*imag(VA))+sin(L*imag(VA))*@i));
22037: }else if(VAA[1]!=(V0=fimag(VA)))
22038: Q=subst(P,VAA[0]^(VAA[1]),VAA[0]^(V0));
22039: }
22040: V0=VA;
22041: if(length(VAA)==1&&(VAA[0]!=V0||VA!=(V0=fimag(VA))))
22042: Q=subst(P,VF,subst(VF,VAA[0],V0));
22043: }
22044: if(Q!=[]&&P!=Q){
22045: P=Q;V=cons(0,vars(P));
22046: }
22047: }
22048: return P;
22049: }
22050:
22051:
22052: def trig2exp(P,X)
22053: {
22054: if(iand(ptype(P,X),128)){
22055: OL=getopt();
22056: Nm=trig2exp(nm(P),X|option_list=OL);
22057: Dn=trig2exp(dn(P),X|option_list=OL);
22058: R=red(Nm/Dn);
22059: if(getopt(arc)==1) return sqrt2rat(R);
22060: }
22061: if((Inv=getopt(inv))==1||type(Inv)==2){
22062: for(VT=T=vars(P);T!=[];T=cdr(T)){
22063: if(findin(functor(car(T)),[cos,sin,tan])>=0){
22064: P=trig2exp(P,X);VT=vars(P);break;
22065: }
22066: }
22067: for(;VT!=[];VT=cdr(VT)){
22068: if(functor(CT=car(VT))==exp){
22069: if((Re=real(args(CT)[0]))!=0){
22070: if(isint(Re)) S=@e^Re;
22071: else S=exp(Re);
22072: }else S=1;
22073: if((Im=imag(args(CT)[0]))!=0){
22074: Q=nm(Im);Q=mycoef(Q,mydeg(Q,X),X);
22075: if(-Q>Q) S*=cos(-Im)-@i*sin(-Im);
22076: else S*=cos(Im)+@i*sin(Im);
22077: }
22078: P=subst(P,CT,S);
22079: }
22080: }
22081: P=red(P);
22082: U=vars(Inv);
22083: if(length(U)!=1||((F=functor(car(U)))!=sin&&F!=cos&&F!=tan)) return P;
22084: XX=args(car(U))[0];
22085: if(mydeg(XX,X)!=1) return P;
22086: if(!isvar(XX)) P=subst(P,X,(X-mycoef(XX,0,X))/mycoef(XX,1,X));
22087: for(VT=vars(P);VT!=[];VT=cdr(VT)){
22088: if(vtype(CT=car(VT))<2) continue;
22089: TX=args(CT)[0];
22090: if(mydeg(TX,X)!=1) continue;
22091: if(!isint(C1=mycoef(TX,1,X))) continue;
22092: if((C0=mycoef(TX,0,X))==0){
22093: CC=1;CS=0;
22094: }else if(vars(C0)==[@pi]){
22095: CC=myval(cos(C0));
22096: if(CC!=0&&type(CC)==1&&ntype(CC)!=0){
22097: CC=cos(C0);CS=sin(C0);
22098: }else CS=myval(sin(C0));
22099: }else{
22100: CC=cos(C0);CS=sin(C0);
22101: }
22102: K=C1;
22103: if(K<0) K=-K;
22104: for(CC1=0,I=K;I>=0;I-=2) CC1+=(-1)^((K-I)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I);
22105: 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);
22106: if(C1<0) CS1=-CS1;
22107: if((TF=functor(CT))==cos) P=subst(P,cos(TX),CC1*CC-CS1*CS);
22108: else if(TF==sin) P=subst(P,sin(TX),CS1*CC+CC1*CS);
22109: }
22110: if(F==sin)
22111: P=substblock(P,cos(X),cos(X)^2,1-sin(X)^2);
22112: else{
22113: P=substblock(P,sin(X),sin(X)^2,1-cos(X)^2);
22114: if(F==tan){
22115: P=subst(P,sin(X),cos(X)*tan(X));
22116: P=substblock(P,cos(X),cos(X)^2,1/(tan(X)^2+1));
22117: }
22118: }
22119: if(!isvar(XX)) P=subst(P,X,XX);
22120:
22121: if(getopt(arc)==1){
22122: for(VT=vars(P);VT!=[];VT=cdr(VT)){
22123: FA=funargs(car(VT));
22124: if(type(FA)==4&&(FA[0]==cos||FA[0]==sin)&&ptype(FA[1],X)>60){
22125: VTT=vars(FA[1]);
22126: if(type(FA[1])!=2||length(VTT)!=1) break;
22127: FB=funargs(VTT[0]);
22128: if(type(FB)!=4||(FF=findin(FB[0],[asin,acos,atan]))<0) break;
22129: if(!isint(2*(C=mycoef(FA[1],1,VTT[0])))||mycoef(FA[1],0,VTT[0])!=0) break;
22130: if(C==1/2){
22131: if(FF==1){
22132: U=(FA[0]==cos)?(1+FB[1])/2:(1-FB[1])/2;
22133: P=subst(P,car(VT),red(U)^(1/2));
22134: }else if(FF==2){
22135: if(FA[0]==sin){
22136: FB1=red(FB[1]);
22137: Nm=nm(FB1);CC=fctr(Nm)[0][0];Dn=dn(FB1);
22138: if(CC<0) CC=-CC;
22139: Nm/=CC;Dn/=CC;
22140: NN=Nm^2+Dn^2;
22141: P=subst(P,car(VT),((NN)^(1/2)-Dn)/Nm*cos(FA[1]));
22142: }
22143: }
22144: P=red(P);
22145: }else if(C==1){
22146: if(FF==1){
22147: if(FA[0]==cos) P=subst(P,car(VT),FB[1]);
22148: else P=subst(P,car(VT),(1-FB[1])^(1/2));
22149: }else if(FF==0){
22150: if(FA[0]==sin) P=subst(P,car(VT),FB[1]);
22151: else P=subst(P,car(VT),(1-FB[1])^(1/2));
22152: }
22153: P=red(P);
22154: }
22155: }
22156: }
22157: P=sqrt2rat(P);
22158: }
22159: return red(P);
22160: }
22161: Var=pfargs(P,X);
22162: for(VT=Var;VT!=[];VT=cdr(VT)){
22163: CT=car(VT);
22164: if(CT[1]==cos)
22165: P=subst(P,CT[0],exp(CT[2]*@i)/2+exp(-CT[2]*@i)/2);
22166: else if(CT[1]==sin)
22167: P=subst(P,CT[0],exp(-CT[2]*@i)*@i/2-exp(CT[2]*@i)*@i/2);
22168: else if (CT[1]==tan)
22169: P=subst(P,CT[0],(exp(-CT[2]*@i)*@i-exp(CT[2]*@i)*@i)/(exp(CT[2]*@i)+exp(-CT[2]*@i)));
22170: else if(CT[1]==pow){
22171: if(ptype(CT[2],X)>1) continue;
22172: if(CT[2]==@e) P=subst(P,CT[0],exp(CT[3]));
22173: else P=subst(P,CT[0],exp(log(CT[2])*exp(CT[3])));
22174: }
22175: }
22176: P=red(P);
22177: for(PP=1,Lp=(dn(P)==1)?1:0;Lp<2;Lp++){
22178: PP=1/PP;
22179: U=(Lp==0)?dn(P):nm(P);
22180: if(U==1) continue;
22181: Var=vars(U);
22182: for(R=[],VT=Var;VT!=[];VT=cdr(VT))
22183: if(functor(car(VT))==exp) R=cons(car(VT),R);
22184: RR=os_md.terms(U,R);
22185: for(Q=0,RRT=RR;RRT!=[];RRT=cdr(RRT)){
22186: for(S=0,CT=cdr(car(RRT)),CR=R,UT=U;CR!=[];CR=cdr(CR),CT=cdr(CT)){
22187: UT=mycoef(UT,car(CT),car(CR));S+=car(CT)*args(car(CR))[0];
22188: }
22189: if(S==0) Q+=UT;
22190: else Q+=UT*exp(S);
22191: }
22192: PP*=Q;
22193: }
22194: return PP;
22195: }
22196:
22197: def powsum(N)
22198: {
22199: if (N < 0) return 0;
22200: if (N == 0) return x;
22201: P = intpoly(N*powsum(N-1),x);
22202: C = subst(P,x,1);
22203: return P+(1-C)*x;
22204: }
22205:
22206: def bernoulli(N)
22207: {
22208: return mydiff(powsum(N),x) - N*x^(N-1);
22209: }
22210:
22211: /* linfrac01([x,y]) */
1.77 takayama 22212: /* (x_0,x_1,x_2,x_3,...,x_{q+3})=(x,0,1,y_1,...,y_q,\infty)
1.6 takayama 22213:
22214: T=0 (x_2,x_1,x_3,x_4,...)
22215: T=-j (x_1,x_2,..,x_{j-1},x_{j+1},x_j,x_{j+2},...)
22216: T=1 (1-x_1,1-x_2,1-x_3,1-x_4,...)
22217: T=2 (1/x_1,1/x_2,1/x_3,1/x_4,...)
1.77 takayama 22218: T=3 (1/x_1,x_2/x_1,x_3/x_1,x_4/x_1,...)
1.78 takayama 22219: ...
1.6 takayama 22220: */
22221: def lft01(X,T)
22222: {
1.77 takayama 22223: S=0;
1.6 takayama 22224: if(type(X)==4){
1.77 takayama 22225: if(type(car(X))==4){
22226: S=X[1];X=car(X);
22227: }
1.6 takayama 22228: K=length(X);
22229: if(K>=1) D=1;
22230: }
22231: if(D==0) return 0;
1.77 takayama 22232: if(type(T)==4&&(length(T)==K+3||length(T)==2)){
22233: for(U=[],I=K+2;I>=0;I--) U=cons(I,U);
22234: if(length(T)==2) T=mperm(U,[T],0);
22235: L=sexps(T);
22236: for(R=[X,S];L!=[];L=cdr(L)){
22237: if(!(I=car(L))) I=4;
22238: /* else if(I==1) I=1; */
22239: else if(I==2) I=5;
22240: else if(I==K+1) I=6;
22241: else if(I>2) I=2-I;
22242: R=lft01(R,I);
1.6 takayama 22243: }
22244: return R;
22245: }
1.77 takayama 22246: if(!S) S=getopt(tr);
22247: if(type(S)==4&&length(S)==K+3){
22248: D=2;
22249: }else if(S==1) for(S=[],I=K+2;I>=0;I--) S=cons(I,S);
22250: else S=0;
22251: if(T<=0){ /* y_i <-> y_{i+1}, y_0=x=x_0, y_i=x_{i+2} */
22252: R=mperm(X,[[-T,1-T]],0);
22253: if(S){
22254: if(!T) S=mperm(S,[[0,3]],0);
22255: else S=mperm(S,[[2-T,3-T]],0); /* : J J=3,...,K; */
22256: R=[R,S];
1.6 takayama 22257: }
22258: return R;
1.77 takayama 22259: }else if(T==1){ /* (x_1=0, x_2=1) : 1 */
22260: for(R=[];X!=[];X=cdr(X)) R=cons(1-car(X),R);
22261: if(S) S=mperm(S,[[1,2]],0);
22262: }else if(T==2){ /* (x_1=0, x_{K+2}=infty) */
22263: for(R=[]; X!=[]; X=cdr(X)) R=cons(red(1/car(X)),R);
22264: if(S) S=mperm(S,[[1,K+2]],0);
22265: }else if(T==3){ /* (x_0=x, x_2=1) */
22266: T=car(X);
22267: for(R=[red(1/T)],X=cdr(X); X!=[]; X=cdr(X)) R=cons(red(car(X)/T),R);
22268: if(S) S=mperm(S,[[0,2]],0);
22269: }else if(T==4){ /* (x_0=x,x_1=0) : 0 */
22270: T=car(X);
22271: for(R=[red(T/(T-1))],X=cdr(X); X!=[]; X=cdr(X)) R=cons(red((T-car(X))/(T-1)),R);
22272: if(S) S=mperm(S,[[0,1]],0);
22273: }else if(T==5){ /* (x_2=1,x_3=y) : 2 */
22274: T=X[1];
22275: for(R=[1/T,red(X[0]/T)],X=cdr(cdr(X));X!=[]; X=cdr(X)) R=cons(red(car(X)/T),R);
22276: if(S) S=mperm(S,[[2,3]],0);
22277: }else if(T==6){ /* (x_{K+1}=y_{K-1}, x_{K+2}=infty) : K+1 */
22278: T=X[K-1];
22279: for(R=[];length(X)>1;X=cdr(X)) R=cons(red(car(X)*(1-T)/(car(X)-T)),R);
22280: R=cons(1-T,R);
22281: if(S) S=mperm(S,[[K+1,K+2]],0);
22282: }else if(T==7){ /* x_2=1 <-> x_{K+2}=infty */
22283: for(R=[];X!=[];X=cdr(X)) R=cons(red(car(X)/(car(X)-1)),R);
22284: if(S) S=mperm(S,[[2,K+2]],0);
22285: }else return 0;
22286: R=reverse(R);
22287: return S?[R,S]:R;
1.6 takayama 22288: }
22289:
22290: def linfrac01(X)
22291: {
1.77 takayama 22292: if(type(X)==4){
22293: K=length(X)-2;
22294: if(type(car(X))==4){
22295: for(U=[],I=K+4;I>=0;I--) U=cons(I,U);
22296: X=[car(X),U];
22297: }else U=0;
1.6 takayama 22298: }
22299: if(K>3 && getopt(over)!=1) return(-1);
22300: II=(K==-1)?3:4;
22301: for(CC=C=1,L=[X]; C!=0; CC+=C){
22302: for(F=C,C=0,R=L; F>0; R=cdr(R), F--){
22303: P=car(R);
22304: for(I=-K; I<II; I++){
22305: S=lft01(P,I);
22306: if(findin(S,L) < 0){
22307: C++; L=cons(S,L);
22308: }
22309: }
22310: }
22311: }
1.77 takayama 22312: return reverse(L);
1.6 takayama 22313: }
22314:
22315:
22316: def varargs(P)
22317: {
1.21 takayama 22318: if((All=getopt(all))!=1&&All!=2) All=0;
1.6 takayama 22319: V=vars(P);
22320: for(Arg=FC=[];V!=[];V=cdr(V)){
1.21 takayama 22321: if(vtype(CV=car(V))==0&&All!=0){
1.6 takayama 22322: Arg=lsort([CV],Arg,0);
22323: }
22324: if(vtype(CV)!=2) continue;
22325: if(findin(F=functor(CV),FC)<0) FC=cons(F,FC);
22326: for(AT=vars(args(CV));AT!=[];AT=cdr(AT)){
22327: if(vtype(X=car(AT))<2){
22328: if(findin(X,Arg)<0) Arg=cons(X,Arg);
22329: }else if(vtype(X)==2){
22330: R=varargs(X);
22331: if(R[1]!=[]){
22332: Arg=lsort(R[1],Arg,0);
22333: FC=lsort(R[0],FC,0);
22334: }
22335: }
22336: }
22337: }
1.21 takayama 22338: Arg=reverse(Arg);
22339: return (All==2)?Arg:[reverse(FC),Arg];
1.6 takayama 22340: }
22341:
22342: def pfargs(P,X)
22343: {
22344: if(type(L=getopt(level))!=1) L=0;
22345: for(Var=[],V=vars(P);V!=[];V=cdr(V)){
22346: if(vtype(car(V))==2){
22347: VT=funargs(car(V));
22348: if(length(VT)>1){
22349: if(L<2 &&(ptype(VT[1],X)>1 || (length(VT)>2 && ptype(VT[2],X)>1)))
22350: Var=cons(cons(car(V),VT),Var);
22351: if(L!=1 && (R=pfargs(VT[1],X|level=L-1))!=[]) Var=append(R,Var);
22352: }
22353: }
22354: }
22355: return reverse(Var);
22356: }
22357:
22358: def ptype(P,L)
22359: {
22360: if((T=type(P))<2 || T>3) return T;
22361: if(type(L)!=4) L=[L];
22362: F=0;
22363: if(lsort(L,varargs(dn(P))[1],2)!=[]) F=128;
22364: if(lsort(L,varargs(nm(P))[1],2)!=[]) F+=64;
22365: if(lsort(L,vars(dn(P)),2)!=[]) return F+3;
22366: return (lsort(L,vars(nm(P)),2)==[])?(F+1):(F+2);
22367: }
22368:
22369: def nthmodp(X,N,P)
22370: {
22371: X=X%P;
22372: for(Z=1;;){
22373: if((W=iand(N,1))==1) Z=(Z*X)%P;
22374: if((N=(N-W)/2)<=0) return Z;
22375: X=irem(X*X,P);
22376: }
22377: }
22378:
22379: def issquaremodp(X,P)
22380: {
22381: N=getopt(power);
22382: if(!isint(N)) N=2;
22383: if(P<=1 || !isint(P) || !pari(ispsp,P) || !isint(X) || !isint(N) || N<1){
22384: errno(0);
22385: return -2;
22386: }
22387: M=(P-1)/igcd(N,P-1);
22388: if((X%=P) == 0) return 0;
22389: if(X==1 || M==P-1) return 1;
22390: return (nthmodp(X,M,P)==1)?1:-1;
22391: }
22392:
22393: def iscoef(P,F)
22394: {
22395: if(P==0) return 1;
22396: if(type(P)==1) return F(P);
22397: if(type(P)==2) {
22398: X=var(P);
22399: for(I=deg(P,X); I>=0; I--){
22400: if(!iscoef(mycoef(P,I,X),F)) return 0;
22401: }
22402: }else if(type(P)==3){
22403: if(!iscoef(nm(P),F)||!iscoef(dn(P),F)) return 0;
22404: }else if(type(P)==4){
22405: for(;P!=[];P=cdr(P)) if(!iscoef(P,F)) return 0;
22406: }else if(type(P)>4 && type(P)<7) return iscoef(m2l(PP),F);
22407: else return 0;
22408: return 1;
22409: }
22410:
22411: def rootmodp(X,P)
22412: {
22413: X%=P;
22414: if(X==0) return [0];
22415: N=getopt(power);
22416: PP=pari(factor,P);
22417: P0=PP[0][0]; P1=PP[0][1];
22418: P2=pari(phi,P);
22419: if(!isint(N)) N=2;
22420: N%=P2;
22421: if(P0==2 || size(PP)[0]>1){
22422: for(I=1,R=[]; I<P2; I++)
22423: if(nthmodp(I,N,P)==X) R=cons(I,R);
22424: return qsort(R);
22425: }
22426: Y=primroot(P);
22427: if(Y==0) return 0;
22428: Z=nthmodp(Y,N,P);
22429: G=igcd(N,P2);
22430: P3=P2/G;
22431: for(I=0, W=1; I<P3;I++){
22432: if(W==X) break;
22433: W=(W*Z)%P;
22434: }
22435: if(I==P3) return [];
22436: W=nthmodp(Y,I,P);
22437: Z=nthmodp(Y,P3,P);
22438: for(I=0,R=[];;){
22439: R=cons(W,R);
22440: if(++I>=G) break;
22441: W=(W*Z)%P;
22442: }
22443: return qsort(R);
22444: }
22445:
22446: def primroot(P)
22447: {
22448: PP=pari(factor,P);
22449: P0=PP[0][0]; P1=PP[0][1];
22450: S=size(PP);
22451: if(S[0]>1 || !isint(P) || P0<=2){
22452: print("Not odd prime(power)!");
22453: return 0;
22454: }
22455: if(isint(Ind=getopt(ind))){
22456: Ind %= P;
22457: if(Ind<=0 || igcd(Ind,P)!=1 || (Z=primroot(P))==0){
22458: print("Not exist!");
22459: return 0;
22460: }
22461: P2=P0^(P1-1)*(P0-1);
22462: for(I=1,S=1; I<P2; I++)
22463: if((S = (S*Z)%P) == Ind) return I;
22464: return 0;
22465: }
22466: if(getopt(all)==1){
22467: I=primroot(P);
22468: P2=P0^(P1-1)*(P0-1);
22469: for(L=[],J=1; J<P2; J++){
22470: if(P1>1 && igcd(P0,J)!=1) continue;
22471: if(igcd(P0-1,J)!=1) continue;
22472: L=cons(nthmodp(I,J,P),L);
22473: }
22474: return qsort(L);
22475: }
22476: if(PP[0][1]>1){
22477: I=primroot(P0);
22478: P2=P0^(P1-2)*(P0-1);
22479: if(nthmodp(I,P2,P)==1) I+=P0;
22480: return I;
22481: }
22482: F=pari(factor,P-1);
22483: SF=size(F)[0];
22484: for(I=2; I<P; I++){
22485: for(J=0; J<SF; J++)
22486: if(nthmodp(I,(P-1)/F[J][0],P)==1) break;
22487: if(J==SF) return I;
22488: }
22489: }
22490:
22491: def rabin(P,X)
22492: {
22493: for(M=0,Q=P-1;iand(Q,1)==0;M++,Q/=2);
22494: Z=nthmodp(X,Q,P);
22495: for(N=M;M>0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P);
22496: return (M<N&&(M==0||Z==1))?0:1;
22497: }
22498:
22499: def powprimroot(P,N)
22500: {
22501: if(P<3) P=3;
22502: FE=getopt(exp);
22503: if(FE!=1) FE=0;
22504: if((Log=getopt(log))==1||Log==2) FE=-1;
22505: else if(Log==3){
22506: FE=-2;
22507: for(PP=1, L0=["$r$","$p/a$"];;){
22508: PP=pari(nextprime,PP+1);
22509: if(PP>=P) break;
22510: L0=cons(PP, L0);
22511: }
22512: L0=reverse(L0);
22513: }
22514: if(FE==0) All=getopt(all);
22515: for(I=0, PP=P, LL=[]; I<N; I++,PP++){
22516: PP=pari(nextprime,PP);
22517: if(All==1){
22518: PR=primroot(PP|all=1);
22519: LL=cons(cons(PP,PR),LL);
22520: continue;
22521: }
22522: PR=primroot(PP);
22523: if(FE==-2){ /* log=3 */
22524: LT=cdr(L0);LT=cdr(L0);
22525: for(L=[PP];LT!=[];LT=cdr(LT))
22526: L=cons(primroot(PP|ind=car(LT)),L);
22527: LL=cons(reverse(L),LL);
22528: if(I<N-1) L0=append(L0,[PP]);
22529: }else if(FE){
22530: for(J=1, L=[PP], K=1; J<PP; J++){
22531: if(FE==-1){ /* log=1,2 */
22532: K=primroot(PP|ind=J);
22533: if(K==0 && Log==2) K=PP-1;
22534: }
22535: else K=(K*PR)%PP; /* exp=1 */
22536: L=cons(K,L);
22537: }
22538: LL=cons(reverse(L),LL);
22539: }else
22540: LL=cons([PP,PR],LL); /* default */
22541: }
22542: LL=reverse(LL);
22543: if(!FE) return LL;
22544: PP--;
22545: if(FE==-2) return append(LL,[L0]);
22546: for(I=1,L=["$p$"];I<PP; I++) L=cons(I,L);
22547: return cons(reverse(L),LL);
22548: }
22549:
22550: def ntable(F,II,D)
22551: {
22552: F=f2df(F|opt=-1);
22553: Df=getopt(dif);
1.16 takayama 22554: Str=getopt(str);
1.6 takayama 22555: if(Df!=1) Df=0;
1.16 takayama 22556: L=[];
22557: if(type(D)==4){
22558: if(type(II[0])==4){
22559: T1=II[0][1]-II[0][0];T2=II[1][1]-II[1][0];
22560: for(L0=[],I=0;I<D[0];I++){
22561: for(R=[],J=0;J<D[1];J++)
22562: R=cons(myf2eval(F,II[0][0]+I*T1/D[0],II[1][0]+J*T2/D[1]),R);
22563: L=cons(reverse(R),L);L0=cons(II[0][0]+I*T1/D[0],L0);
22564: }
22565: }else{
22566: for(T=II[1]-II[0],L0=[],I=0;I<D[0];I++){
22567: for(R=[],J=0;J<D[1];J++)
22568: R=cons(myfdeval(F,II[0]+I*T/D[0]+J*T/D[0]/D[1]),R);
22569: L=cons(reverse(R),L);L0=cons(II[0]+I*T/D[0],L0);
22570: }
22571: }
22572: L=reverse(L);L0=reverse(L0);
22573: if(type(Str)==4){
22574: L0=mtransbys(os_md.sint,L0,[Str[0]]|str=1,zero=0);
22575: L=mtransbys(os_md.sint,L,[Str[1]]|str=1,zero=0);
22576: if(Df==1){
22577: for(DT=[],RT=L,I=0;RT!=[];){
22578: for(LT=[],TT=car(RT);TT!=[];TT=cdr(TT)){
22579: VV=car(TT);
22580: if((J=str_char(VV,0,"."))>=0){
22581: if(J==0) VV=str_cut(VV,1,10000);
22582: else VV=str_cut(VV,0,J-1)+str_cut(VV,J+1,10000);
22583: }
22584: V1=eval_str(VV);
22585: if(I++) LT=cons(V1-V0,LT);
22586: V0=V1;
22587: }
22588: DT=cons(LT,DT);
22589: if((RT=cdr(RT))==[]){
22590: VE=rint(myfdeval(F,II[1])*10^Str[1]);
22591: DT=cons([VE-V0],DT);
22592: }
22593: }
22594: for(I=0,D=[],TT=DT;TT!=[];TT=cdr(TT)){
22595: if(!I++) V=car(TT)[0];
22596: else{
22597: T1=reverse(cons(V,car(TT)));
22598: V=car(T1);
22599: if(length(TT)>1) T1=cdr(T1);
22600: D=cons(T1,D);
22601: }
22602: }
22603: for(DD=[],TT=D;TT!=[];TT=cdr(TT))
22604: DD=cons([os_md.lmin(car(TT)),os_md.lmax(car(TT))],DD);
22605: DD=reverse(DD);
22606: L=lsort(L,DD,"append");
22607: }
22608: }
22609: L=lsort(L,L0,"cons");
22610: if(type(Top=getopt(top))==4||getopt(TeX)==1){
22611: if(type(Top)==4){
22612: K=length(L[0])-length(Top);
22613: if(K>0&&K<4){
22614: if(K>1){
22615: Top=append(Top,["",""]);
22616: K-=2;
22617: }
22618: if(K) Top=cons("",Top);
22619: }
22620: L=cons(Top,L);
22621: }
22622: if(type(H=getopt(hline))!=4) H=[0,1,z];
22623: if(type(V=getopt(vline))!=4) V=[0,1,(DF)?z-2:z];
22624: if(type(T=getopt(title))!=7) Out=ltotex(L|opt="tab",hline=H,vline=V);
22625: else Out=ltotex(L|opt="tab",hline=H,vline=V,title=T);
22626: if(Df) Out=str_subst(Out,"\\hline","\\cline{1-"+rtostr(length(L[0])-2)+"}");
22627: return Out;
22628: }
22629: return L;
22630: }
1.6 takayama 22631: for(L=[],I=0;I<=D;I++){
22632: X=II[0]+I*T/D;
22633: L=cons([X,myfdeval(F,X)],L);
22634: }
22635: if(Df==1){
22636: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
22637: if(LD==[]) LD=cons([car(LL)[0],car(LL)[1],0],LD);
22638: else LD=cons([car(LL)[0],car(LL)[1],abs(car(LL)[1]-car(LD)[1])],LD);
22639: }
22640: L=reverse(LD);
22641: }
1.16 takayama 22642: if(type(Str)==4){
1.6 takayama 22643: if(length(Str)==1) Str=[Str[0],Str[0]];
1.16 takayama 22644: if(Df==1 && length(Str)==2) Str=[Str[0],Str[1],Str[1]];
1.6 takayama 22645: for(S=Str,Str=[];S!=[];S=cdr(S)){
22646: if(type(car(S))!=4) Str=cons([car(S),3],Str);
22647: else Str=cons(car(S),Str);
22648: }
22649: Str=reverse(Str);
22650: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
22651: for(K=[],J=length(Str); --J>=0; )
22652: K=cons(sint(car(LL)[J],Str[J][0]|str=Str[J][1]),K);
22653: LD=cons(K,LD);
22654: }
22655: L=LD;
22656: }else
22657: L=reverse(L);
22658: if(type(M=getopt(mult))==1){
22659: Opt=[["opt","tab"],["vline",[[0,2+Df]]],["width",-M]];
22660: if(type(T=getopt(title))==7)
22661: Opt=cons(["title",T],Opt);
22662: if(type(Tp=getopt(top))==4)
22663: Opt=cons(["top",Tp],Opt);
22664: L=ltotex(L|option_list=Opt);
22665: }
22666: return L;
22667: }
22668:
22669: def distpoint(L)
22670: {
22671: L=m2l(L|flat=1);
22672: if(getopt(div)==5) Div=5;
22673: else Div=10;
22674: V=newvect(100/Div);
22675: for(LT=L,LL=[],N=0; LT!=[]; LT=cdr(LT)){
22676: if(type(K=car(LT))>1||K<0){
22677: N++; continue;
22678: }
22679: LL=cons(K,LL);
22680: T=idiv(K,Div);
22681: if(Div==10 && T>=9) T=9;
22682: else if(Div==5 && T>=19) T=19;
22683: V[T]++;
22684: }
22685: V=vtol(V);
22686: if((Opt=getopt(opt))=="data") return V;
22687: Title=getopt(title);
22688: OpList=[["opt","tab"]];
22689: if(type(Title=getopt(title)) == 7)
22690: OpList=cons(["title",Title],OpList);
22691: if(Opt=="average"){
22692: T=isMs()?["平均点","標準偏差","最低点","最高点","受験人数"]:
22693: ["average","deviation","min","max","examinees"];
22694: L=average(LL);
22695: L=[sint(L[0],1),sint(L[1],1),L[3],L[4],L[2]];
22696: if(N>0){
22697: T=append(T,[isMs()?"欠席者":"absentees"]);L=append(L,[N]);
22698: }
22699: OpList=cons(["align","c"],OpList);
22700: return ltotex([T,L]|option_list=OpList);
22701: }
22702:
22703: if(getopt(opt)=="graph"){
22704: Mul=getopt(size);
22705: if(Div==5){
22706: V0=["00","05","10","15","20","25","30","35","40","45","50","55",
22707: "60","65","70","75","80","85","90","95"];
22708: if(type(Mul)!=4){
22709: Size = (TikZ)?[12,3,1/2,0.2]:[120,30,1/2,2];
22710: }
22711: }else{
22712: V0=["00-","10-","20-","30-","40-","50-","60-","70-","80-","90-"];
22713: if(type(Mul)!=4){
22714: Size = (TikZ)?[8,3,1/2,0.2]:[80,30,1/2,2];
22715: }
22716: }
22717: return ltotex([V,V0]|opt="graph",size=Size);
22718: }
22719: if(Div==5)
22720: V0=["00--04","05--09","10--14","15--19", "20--24", "25--29", "30--34", "35-39",
22721: "40--44", "45--49","50--54", "55--59","60--64", "65--69",
22722: "70--74", "75--79","80--84", "85--89","90--94", "95--100"];
22723: else
22724: V0=["00--09","10--19","20--29","30--39","40--49","50--59","60--69",
22725: "70--79","80--89","90--100"];
22726: Title=getopt(title);
22727: return ltotex([V0,V]|option_list=OpList);
22728: }
22729:
22730: def keyin(S)
22731: {
1.46 takayama 22732: mycat0(S,0);
1.6 takayama 22733: purge_stdin();
22734: S=get_line();
22735: L=length(S=strtoascii(S));
22736: if(L==0) return "";
22737: return str_cut(S,0,L-2);
22738: }
22739:
22740: def init() {
1.16 takayama 22741: LS=["DIROUT","DVIOUTA","DVIOUTB","DVIOUTH","DVIOUTL","TeXLim","TeXEq","TikZ",
1.6 takayama 22742: "XYPrec","XYcm","Canvas"];
22743: if(!access(get_rootdir()+"/help/os_muldif.dvi")||!access(get_rootdir()+"/help/os_muldif.pdf"))
22744: mycat(["Put os_muldif.dvi and os_muldif.pdf in", get_rootdir()+(isMs()?"\\help.":"/help.")]);
22745: if(!isMs()){
22746: DIROUT="%HOME%/asir/tex";
22747: DVIOUTA=str_subst(DVIOUTA,[["\\","/"],[".bat",".sh"]],0);
22748: DVIOUTB=str_subst(DVIOUTB,[["\\","/"],[".bat",".sh"]],0);
22749: DVIOUTL=str_subst(DVIOUTL,[["\\","/"],[".bat",".sh"]],0);
22750: DVIOUTH="%ASIRROOT%/help/os_muldif.pdf";
22751: }
22752: Home=getenv("HOME");
22753: if(type(Home)!=7) Home="";
22754: for(Id=-7, F=Home; Id<-1;){
22755: G = F+"/.muldif";
22756: if(access(G)) Id = open_file(G);
22757: else Id++;
22758: if(Id==-6) F+="/asir";
22759: else if(Id==-5) F=get_rootdir();
22760: else if(Id==-4) F+="/bin";
22761: else if(Id==-3) F=get_rootdir()+"/lib-asir-contrib";
22762: }
22763: if(Id>=0){
22764: while((S=get_line(Id))!=0){
1.18 takayama 22765: if(type(P=str_str(S,LS))==4 && (P0=str_char(S,P[1]+4,"="))>0){
1.6 takayama 22766: if(P[0]<5){
22767: P0=str_chr(S,P0+1,"\"");
22768: if(P0>0){
22769: for(P1=P0;(P2=str_char(S,P1+1,"\""))>0; P1=P2);
22770: if(P1>P0+1){
22771: SS=str_cut(S,P0+1,P1-1);
22772: SS=str_subst(SS,["\\\\","\\\""],["\\","\""]);
22773: if(P[0]==0) DIROUT=SS;
22774: else if(P[0]==1) DVIOUTA=SS;
22775: else if(P[0]==2) DVIOUTB=SS;
22776: else if(P[0]==3) DVIOUTH=SS;
22777: else if(P[0]==4) DVIOUTL=SS;
22778: }
22779: }
22780: if(P0<0 || P1<P0+2) mycat(["Error! Definiton of", LS[P[0]],
22781: "in .muldif"]);
22782: }else{
22783: SV=eval_str(str_cut(S,P0+1,str_len(S)-1));
1.16 takayama 22784: if(P[0]==5) TeXLim=SV;
22785: else if(P[0]==6) TeXEq=SV;
22786: else if(P[0]==7) TikZ=SV;
22787: else if(P[0]==8) XYPrec=SV;
22788: else if(P[0]==9) XYcm=SV;
1.18 takayama 22789: else if(P[0]==10) Canvas=SV;
1.6 takayama 22790: }
22791: }
22792: }
22793: close_file(Id);
22794: }
22795: chkfun(1,0);
22796: }
22797:
22798: #ifdef USEMODULE
22799: endmodule;
22800: os_md.init()$
22801: #else
22802: init()$
22803: #endif
22804:
22805: end$