![[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.4 ! takayama 1: /* $OpenXM: OpenXM/src/asir-contrib/packages/src/os_muldif.rr,v 1.3 2015/08/27 11:02:20 takayama Exp $ */
1.1 takayama 2: /* The latest version will be at ftp://akagi.ms.u-tokyo.ac.jp/pub/math/muldif
3: scp os_muldif.[dp]* ${USER}@lemon.math.kobe-u.ac.jp:/home/web/OpenXM/Current/doc/other-docs
4: */
5: #define USEMODULE 1
6: /* #undef USEMODULE */
7:
8: /* os_muldif.rr (Library for Risa/Asir)
1.4 ! takayama 9: * Toshio Oshima (Nov. 2007 - May. 2016)
1.1 takayama 10: *
11: * For polynomials and differential operators with coefficients
12: * in rational funtions (See os_muldif.pdf)
13: *
14: * "Tab = 4 column" is best
15: */
16:
17: ord([zz,dz,dy,dx])$
18:
19: #ifdef USEMODULE
20: module os_md;
21: static Muldif.rr$
22: static TeXEq$
23: static TeXLim$
24: static DIROUT$
25: static DVIOUTL$
26: static DVIOUTA$
1.3 takayama 27: static DVIOUTB$
1.1 takayama 28: static DVIOUTH$
1.3 takayama 29: static DVIOUTF$
30: static LCOPT$
31: static COLOPT$
32: static LPOPT$
33: static LFOPT$
1.1 takayama 34: static ErMsg$
35: static FLIST$
36: static IsYes$
1.3 takayama 37: static XYPrec$
38: static XYcm$
39: static TikZ$
40: static XYLim$
1.4 ! takayama 41: static Canvas$
1.3 takayama 42: static ID_PLOT$
1.4 ! takayama 43: static Rand$
! 44: localf spType2$
1.1 takayama 45: localf erno$
46: localf chkfun$
47: localf makev$
1.4 ! takayama 48: localf makenewv$
1.1 takayama 49: localf vweyl$
50: localf mycat$
51: localf mycat0$
52: localf findin$
53: localf countin$
54: localf mycoef$
55: localf mydiff$
56: localf myediff$
57: localf m2l$
58: localf m2ll$
59: localf mydeg$
1.4 ! takayama 60: localf pfctr$
1.1 takayama 61: localf mymindeg$
62: localf m1div$
63: localf mulsubst$
64: localf cmpsimple$
65: localf simplify$
66: localf monotos$
1.4 ! takayama 67: localf minustos$
1.1 takayama 68: localf monototex$
69: localf vnext$
70: localf ldict$
71: localf ndict$
72: localf nextsub$
73: localf nextpart$
74: localf transpart$
75: localf trpos$
76: localf sprod$
77: localf sinv$
78: localf slen$
79: localf sord$
80: localf vprod$
1.3 takayama 81: localf dvangle$
82: localf dvprod$
83: localf dnorm$
1.1 takayama 84: localf mulseries$
85: localf pluspower$
86: localf vtozv$
87: localf dupmat$
88: localf matrtop$
1.3 takayama 89: localf mytrace$
1.1 takayama 90: localf mydet$
91: localf mperm$
92: localf mtranspose$
93: localf mtoupper$
94: localf mydet2$
95: localf myrank$
96: localf meigen$
1.3 takayama 97: localf transm$
1.1 takayama 98: localf vgen$
99: localf mmc$
100: localf lpgcd$
101: localf mdivisor$
102: localf mdsimplify$
103: localf m2mc$
104: localf easierpol$
105: localf mykernel$
106: localf myimage$
107: localf mymod$
108: localf mmod$
1.3 takayama 109: localf ladd$
1.4 ! takayama 110: localf lchange$
1.3 takayama 111: localf llsize$
1.1 takayama 112: localf llbase$
113: localf lsort$
1.3 takayama 114: localf lmax$
115: localf lmin$
1.4 ! takayama 116: localf lgcd$
! 117: localf ldev$
1.1 takayama 118: localf lsol$
119: localf lnsol$
1.3 takayama 120: /* localf psol$ */
1.1 takayama 121: localf m2v$
122: localf lv2m$
123: localf m2lv$
124: localf s2m$
1.3 takayama 125: localf c2m$
1.1 takayama 126: localf m2diag$
127: localf myinv$
128: localf madjust$
129: localf mpower$
1.3 takayama 130: localf mrot$
1.1 takayama 131: localf texlen$
132: localf isdif$
133: localf fctrtos$
134: localf texlim$
135: localf fmult$
136: localf radd$
137: localf getel$
138: localf ptol$
139: localf rmul$
140: localf mtransbys$
1.3 takayama 141: localf drawopt$
142: localf execdraw$
143: localf execproc$
1.1 takayama 144: localf mysubst$
1.3 takayama 145: localf evals$
1.4 ! takayama 146: localf myval$
1.3 takayama 147: localf myeval$
148: localf mydeval$
149: localf myfeval$
150: localf myf2eval$
151: localf myf3eval$
152: localf myfdeval$
153: localf myf2deval$
154: localf myf3deval$
155: localf myexp$
156: localf mycos$
157: localf mysin$
158: localf mytan$
159: localf myarg$
160: localf myasin$
161: localf myacos$
162: localf myatan$
163: localf mylog$
1.4 ! takayama 164: localf mypow$
! 165: localf arg$
! 166: localf sqrt$
1.3 takayama 167: localf gamma$
168: localf lngamma$
169: localf digamma$
170: localf dilog$
171: localf zeta$
172: localf eta$
173: localf jell$
1.4 ! takayama 174: localf frac$
1.3 takayama 175: localf erfc$
1.4 ! takayama 176: localf fouriers$
! 177: localf todf$
1.3 takayama 178: localf f2df$
1.4 ! takayama 179: localf df2big$
1.3 takayama 180: localf compdf$
181: localf fzero$
182: localf fmmx$
1.4 ! takayama 183: localf flim$
1.3 takayama 184: localf fcont$
1.4 ! takayama 185: localf fresidue$
1.1 takayama 186: localf mmulbys$
187: localf appldo$
188: localf appledo$
189: localf muldo$
190: localf adj$
191: localf laplace1$
192: localf laplace$
193: localf mce$
194: localf mc$
195: localf rede$
196: localf ad$
197: localf add$
198: localf vadd$
199: localf addl$
200: localf cotr$
201: localf rcotr$
202: localf muledo$
203: localf mulpdo$
204: localf transpdosub$
205: localf transpdo$
206: localf translpdo$
207: localf rpdiv$
208: localf mygcd$
209: localf mylcm$
210: localf sftpexp$
211: localf applpdo$
212: localf tranlpdo$
213: localf divdo$
214: localf qdo$
215: localf sqrtdo$
216: localf ghg$
217: localf ev4s$
218: localf b2e$
219: localf sftpow$
220: localf sftpowext$
221: localf polinsft$
222: localf pol2sft$
1.3 takayama 223: localf polroots$
1.4 ! takayama 224: localf fctri$
1.1 takayama 225: localf binom$
226: localf expower$
227: localf seriesHG$
1.3 takayama 228: localf seriesMc$
229: localf seriesTaylor$
230: localf evalred$
1.1 takayama 231: localf toeul$
232: localf fromeul$
233: localf sftexp$
234: localf fractrans$
235: localf soldif$
236: localf chkexp$
1.4 ! takayama 237: localf sqrtrat$
1.1 takayama 238: localf getroot$
239: localf expat$
240: localf polbyroot$
241: localf polbyvalue$
242: localf pcoef$
243: localf prehombf$
244: localf prehombfold$
245: localf sub3e$
246: localf fuchs3e$
247: localf okubo3e$
248: localf eosub$
249: localf even4e$
250: localf odd5e$
251: localf extra6e$
252: localf rigid211$
253: localf solpokuboe$
254: localf stoe$
255: localf dform$
256: localf polinvsym$
257: localf polinsym$
258: localf tohomog$
259: localf substblock$
260: localf okuboetos$
261: localf heun$
262: localf fspt$
263: localf abs$
264: localf calc$
265: localf isint$
1.3 takayama 266: localf israt$
1.4 ! takayama 267: localf iscrat$
1.1 takayama 268: localf isalpha$
269: localf isnum$
270: localf isalphanum$
271: localf isvar$
272: localf isyes$
273: localf isall$
1.3 takayama 274: localf iscoef$
275: localf iscombox$
1.1 takayama 276: localf sproot$
277: localf spgen$
278: localf chkspt$
279: localf cterm$
280: localf terms$
281: localf polcut$
282: localf redgrs$
283: localf cutgrs$
284: localf mcgrs$
1.4 ! takayama 285: localf mc2grs$
! 286: localf add2grs$
! 287: localf sub2grs$
! 288: localf join2grs$
1.3 takayama 289: localf delopt$
1.1 takayama 290: localf str_char$
291: localf str_pair$
292: localf str_cut$
293: localf str_str$
1.3 takayama 294: localf str_subst$
295: localf str_times$
296: localf str_tb$
1.4 ! takayama 297: localf strip$
1.3 takayama 298: localf i2hex$
299: localf sjis2jis$
300: localf jis2sjis$
301: localf s2os$
302: localf l2os$
303: localf r2os$
304: localf s2euc$
305: localf s2sjis$
306: localf r2ma$
307: localf evalma$
1.1 takayama 308: localf ssubgrs$
309: localf verb_tex_form$
1.4 ! takayama 310: localf tex_cuteq$
1.1 takayama 311: localf my_tex_form$
1.4 ! takayama 312: localf texket$
1.1 takayama 313: localf smallmattex$
314: localf dviout0$
315: localf myhelp$
316: localf isMs$
317: localf showbyshell$
1.3 takayama 318: localf readcsv$
319: localf tocsv$
1.1 takayama 320: localf getbyshell$
321: localf show$
322: localf dviout$
323: localf rtotex$
324: localf mtotex$
325: localf ltotex$
1.3 takayama 326: localf texbegin$
327: localf texcr$
1.4 ! takayama 328: localf texsp$
1.1 takayama 329: localf getbygrs$
1.4 ! takayama 330: localf mcop$
1.1 takayama 331: localf shiftop$
332: localf conf1sp$
333: localf pgen$
1.3 takayama 334: localf diagm$
1.1 takayama 335: localf mgen$
336: localf madj$
337: localf newbmat$
1.4 ! takayama 338: localf unim$
1.1 takayama 339: localf pfrac$
340: localf cfrac$
341: localf cfrac2n$
1.4 ! takayama 342: localf sqrt2rat$
1.1 takayama 343: localf s2sp$
344: localf sp2grs$
1.4 ! takayama 345: localf fimag$
! 346: localf trig2exp$
1.1 takayama 347: localf intpoly$
1.4 ! takayama 348: localf integrate$
! 349: localf simplog$
! 350: localf fshorter$
! 351: localf isshortneg$
! 352: localf intrat$
1.1 takayama 353: localf powsum$
354: localf bernoulli$
355: localf lft01$
356: localf linfrac01$
357: localf nthmodp$
358: localf issquaremodp$
359: localf rootmodp$
360: localf rabin$
361: localf primroot$
1.4 ! takayama 362: localf varargs$
1.1 takayama 363: localf ptype$
1.4 ! takayama 364: localf pfargs$
1.1 takayama 365: localf average$
366: localf sint$
1.3 takayama 367: localf frac2n$
1.1 takayama 368: localf xyproc$
369: localf xypos$
370: localf xyput$
371: localf xybox$
372: localf xyline$
373: localf xylines$
374: localf xycirc$
375: localf xybezier$
1.3 takayama 376: localf lbezier$
377: localf draw_bezier$
378: localf tobezier$
379: localf velbezier$
1.4 ! takayama 380: localf ptbezier$
! 381: localf cutf$
! 382: localf fsum$
! 383: localf fint$
! 384: localf periodicf$
! 385: localf cmpf$
! 386: localf areabezier$
1.3 takayama 387: localf saveproc$
1.1 takayama 388: localf xygraph$
389: localf xy2graph$
390: localf xyarrow$
1.3 takayama 391: localf xyang$
392: localf xyoval$
393: localf ptcommon$
1.1 takayama 394: localf ptcopy$
395: localf ptaffine$
396: localf ptlattice$
397: localf ptpolygon$
398: localf ptwindow$
1.3 takayama 399: localf ptbbox$
400: localf lninbox$
401: localf ptcombezier$
402: localf ptcombz$
1.1 takayama 403: localf lchange$
404: localf init$
1.3 takayama 405: localf powprimroot$
406: localf distpoint$
407: localf ntable$
408: localf keyin$
1.1 takayama 409: #else
410: extern Muldif.rr$
411: extern TeXEq$
412: extern TeXLim$
413: extern DIROUT$
414: extern DVIOUTL$
415: extern DVIOUTA$
1.3 takayama 416: extern DVIOUTB$
1.1 takayama 417: extern DVIOUTH$
1.3 takayama 418: extern DVIOUTF$
419: static LCOPT$
420: static COLOPT$
421: static LPOPT$
422: static LFOPT$
423: extern TikZ$
1.1 takayama 424: extern ErMsg$
425: extern FLIST$
426: extern IsYes$
1.3 takayama 427: extern XYPrec$
428: extern XYcm$
429: extern TikZ$
430: extern XYLim$
1.4 ! takayama 431: extern Canvas$
1.3 takayama 432: extern ID_PLOT$
1.4 ! takayama 433: extern Rand$
1.1 takayama 434: #endif
1.4 ! takayama 435: static S_Fc,S_Dc,S_Ic,S_Ec,S_EC,S_Lc$
! 436: static S_FDot;
1.1 takayama 437: extern AMSTeX$
1.4 ! takayama 438: Muldif.rr="00160601"$
1.1 takayama 439: AMSTeX=1$
440: TeXEq=5$
441: TeXLim=80$
1.3 takayama 442: TikZ=0$
443: XYcm=0$
444: XYPrec=3$
445: XYLim=4$
1.4 ! takayama 446: Rand=0$
1.1 takayama 447: DIROUT="%HOME%\\tex"$
448: DVIOUTL="%ASIRROOT%\\bin\\risatex0.bat"$
449: DVIOUTA="%ASIRROOT%\\bin\\risatex.bat"$
1.3 takayama 450: DVIOUTB="%ASIRROOT%\\bin\\risatex1%TikZ%.bat"$
1.1 takayama 451: DVIOUTH="start dviout -2 -hyper=0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #%LABEL%"$
1.3 takayama 452: DVIOUTF=0$
453: LCOPT=["red","green","blue","yellow","cyan","magenta","black","white","gray"]$
454: COLOPT=[0xff,0xff00,0xff0000,0xffff,0xffff00,0xff00ff,0,0xffffff,0xc0c0c0]$
455: LPOPT=["above","below","left","right"]$
456: LFOPT=["very thin","thin","dotted","dashed"]$
1.4 ! takayama 457: Canvas=[400,400]$
1.3 takayama 458:
1.1 takayama 459: ErMsg = newvect(3,[
460: "irregal argument", /* 0 */
461: "too big size", /* 1 */
462: "irregal option" /* 2 */
463: ])$
464: FLIST=0$
465: IsYes=[]$
1.3 takayama 466: ID_PLOT=-1$
1.1 takayama 467:
468: def erno(N)
469: {
470: /* extern ErMsg; */
471: print(ErMsg[N]);
472: }
473:
474: def chkfun(Fu, Fi)
475: {
476: /* extern FLIST; */
477: /* extern Muldif.rr; */
478:
479: if(type(Fu) <= 1){
480: if(Fu==1)
481: mycat(["Loaded os_muldif Ver.", Muldif.rr, "(Toshio Oshima)"]);
482: else
483: mycat(["Risa/Asir Ver.", version()]);
484: return 1;
485: }
486: if(type(FLIST) < 4)
487: FLIST = flist();
488: if(type(Fu) == 4){
489: for(; Fu != [] ;Fu = cdr(Fu))
490: if(chkfun(car(Fu),Fi) == 0) return 0;
491: return 1;
492: }
493: if(findin(Fu, FLIST) >= 0)
494: return 1;
495: FLIST = flist();
496: if(findin(Fu, FLIST) >= 0)
497: return 1;
498: if(type(Fi)==7){
499: mycat0(["load(\"", Fi,"\") -> try again!\n"],1);
500: load(Fi);
501: }
502: return 0;
503: /*
504: if(type(Fi) == 7)
505: Fi = [Fi];
506: for( ; Fi != []; Fi = cdr(Fi))
507: load(car(Fi));
508: FLIST = flist();
509: return (findin(Fu,FLIST)>=0)?1:0;
510: */
511: }
512:
513: def makev(L)
514: {
515: S = "";
516: Num=getopt(num);
517: while(length(L) > 0){
518: VL = car(L); L = cdr(L);
519: if(type(VL) == 7)
520: S = S+VL;
521: else if(type(VL) == 2 || VL < 10)
522: S = S+rtostr(VL);
523: else if(VL<46 && Num!=1)
524: S = S+asciitostr([VL+87]);
525: else
526: S = S+rtostr(VL);
527: }
528: return strtov(S);
529: }
530:
1.4 ! takayama 531: def makenewv(L)
! 532: {
! 533: if((V=getopt(var))<2) V="z_";
! 534: else if(isvar(V)) V=rtostr(V);
! 535: if(type(N=getopt(num))!=1) N=0;
! 536: Var=vars(L);
! 537: for(Va=Var;Va!=[];Va=cdr(Va))
! 538: if(vtype(car(Va))==2) Var=append(vars(args(car(Va))),Var);
! 539: for(XX=[],I=J=0;;I++){
! 540: X=strtov(V+rtostr(I));
! 541: if(findin(X,Var)<0){
! 542: XX=cons(X,XX);
! 543: if(++J>N) return X;
! 544: else if(J==N) return reverse(XX);
! 545: }
! 546: }
! 547: }
! 548:
1.1 takayama 549: def vweyl(L)
550: {
551: if(type(L) == 4){
552: if(length(L) == 2)
553: return L;
554: else
555: return [L[0],makev(["d",L[0]])];
1.3 takayama 556: }
557: /* else if(type(L)<2) return L; */
558: return [L,makev(["d", L])];
1.1 takayama 559: }
560:
561: def mycat(L)
562: {
563: if(type(L) != 4){
564: print(L);
565: return;
566: }
567: Opt = getopt(delim);
568: Del = (type(Opt) >= 0)?Opt:" ";
569: Opt = getopt(cr);
570: CR = (type(Opt) >= 0)?0:1;
571: while(L != []){
572: if(Do==1)
573: print(Del,0);
574: print(car(L),0);
575: L=cdr(L);
576: Do = 1;
577: }
578: if(CR) print("");
579: }
580:
581: def mycat0(L,T)
582: {
583: Opt = getopt(delim);
584: Del = (type(Opt) >= 0)?Opt:"";
585: while(L != []){
586: if(Do==1)
587: print(Del,0);
588: print(car(L),0);
589: L=cdr(L);
590: Do = 1;
591: }
592: if(T) print("");
593: }
594:
595: def findin(M,L)
596: {
597: if(type(L)==4){
598: for(I = 0; L != []; L = cdr(L), I++)
599: if(car(L) == M) return I;
600: }else if(type(L)==5){
601: K=length(L);
602: for(I = 0; I < K; I++)
603: if(L[I] == M) return I;
604: }else return -2;
605: return -1;
606: }
607:
608: def countin(S,M,L)
609: {
610: if(type(L)==4){
611: for(N=0; L!=[]; L=cdr(L))
612: if(car(L)>=S && car(L)<=M) N++;
613: }else if(type(L)==5){
614: K=length(L);
615: for(I = 0; I < K; I++)
616: if(L[I]>=S && L[I]<=M) N++;
617: }else return -2;
618: return N;
619: }
620:
621: def mycoef(P,N,X)
622: {
623: if(type(P) < 3)
624: return coef(P,N,X);
625: if(type(P) >= 4)
1.3 takayama 626: #ifdef USEMODULE
627: return map(os_md.mycoef,P,N,X);
628: #else
1.1 takayama 629: return map(mycoef,P,N,X);
1.3 takayama 630: #endif
1.1 takayama 631: if(deg(dn(P), X) > 0){
632: P = red(P);
633: if(deg(dn(P), X) > 0)
634: return 0;
635: }
636: return red(coef(nm(P),N,X)/dn(P));
637: }
638:
639: def mydiff(P,X)
640: {
641: if(X == 0)
642: return 0;
643: if(type(P) < 3)
644: return diff(P,X);
645: if(type(P) >= 4)
1.3 takayama 646: #ifdef USEMODULE
647: return map(os_md.mydiff,P,X);
648: #else
1.1 takayama 649: return map(mydiff,P,X);
1.3 takayama 650: #endif
1.1 takayama 651: if(deg(dn(P),X) == 0)
652: return red(diff(nm(P),X)/dn(P));
653: return red(diff(P,X));
654: }
655:
656: def myediff(P,X)
657: {
658: if(X == 0)
659: return 0;
660: if(type(P) < 3)
661: return ediff(P,X);
662: if(type(P) >= 4)
1.3 takayama 663: #ifdef USEMODULE
664: return map(os_md.myediff,P,X);
665: #else
1.1 takayama 666: return map(myediff,P,X);
1.3 takayama 667: #endif
1.1 takayama 668: if(deg(dn(P),X) == 0)
669: return red(ediff(nm(P),X)/dn(P));
670: return red(X*diff(P,X));
671: }
672:
673: def m2l(M)
674: {
675: if(type(M) < 4)
676: return [M];
677: if(type(M) == 4){
678: if(type(car(M))==4 && getopt(flat)==1){
679: for(MM = []; M!=[]; M=cdr(M))
680: MM = append(MM,car(M));
681: return MM;
682: }
683: return M;
684: }
685: if(type(M) == 5)
686: return vtol(M);
687: S = size(M);
688: for(MM = [], I = S[0]-1; I >= 0; I--)
689: MM = append(vtol(M[I]), MM);
690: return MM;
691: }
692:
693: def mydeg(P,X)
694: {
695: if(type(P) < 3)
696: return deg(P,X);
697: II = -1;
698: Opt = getopt(opt);
699: if(type(P) >= 4){
700: S=(type(P) == 6)?size(P)[0]:0;
701: P = m2l(P);
702: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
703: if( (DT = mydeg(car(P),X)) == -2)
704: return -2;
705: if(DT > Deg){
706: Deg = DT;
707: II = I;
708: }
709: }
710: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
711: }
712: P = red(P);
713: if(deg(dn(P),X) == 0)
714: return deg(nm(P),X);
715: return -2;
716: }
717:
1.4 ! takayama 718: def pfctr(P,X)
! 719: {
! 720: P=red(P);
! 721: if((T=ptype(P,X))>3) return [];
! 722: if(T==3){
! 723: G=pfctr(dn(P),X);
! 724: F=pfctr(nm(P),X);
! 725: R=[[car(F)[0]/car(G)[0],1]];
! 726: for(F=cdr(F);F!=[];F=cdr(F)) R=cons(car(F),R);
! 727: for(G=cdr(G);G!=[];G=cdr(G)) R=cons([car(G)[0],-car(G)[1]],R);
! 728: return reverse(R);
! 729: }
! 730: F=fctr(nm(P));
! 731: for(R=[],C=1/dn(P);F!=[];F=cdr(F))
! 732: if(mydeg(car(F)[0],X)>0) R=cons(car(F),R);
! 733: else C*=car(F)[0]^car(F)[1];
! 734: return cons([C,1],reverse(R));
! 735: }
! 736:
1.1 takayama 737: def mymindeg(P,X)
738: {
739: if(type(P) < 3)
740: return mindeg(P,X);
1.3 takayama 741: II = -1;T=60;
1.1 takayama 742: Opt = getopt(opt);
743: if(type(P) >= 4){
744: S=(type(P) == 6)?size(P)[0]:0;
745: P = m2l(P);
746: for(I = 0, Deg = -3; P != []; P = cdr(P), I++){
747: if(car(P) == 0)
748: continue;
749: if( (DT = mydeg(car(P),X)) == -2)
750: return -2;
751: if(DT < Deg || Deg == -3){
1.3 takayama 752: if(DT==0){
753: if(type(car(P))>=T) continue;
754: T=type(car(P));
755: }
1.1 takayama 756: Deg = DT;
757: II = I;
758: }
759: }
760: return (Opt==1)?([Deg,(S==0)?II:[idiv(II,S),irem(II,S)]]):Deg;
761: }
762: P = red(P);
763: if(deg(dn(P),X) == 0)
764: return mindeg(nm(P),X);
765: return -2;
766: }
767:
768: def m1div(M,N,L)
769: {
770: L = (type(L) <= 3)?[0,L]:vweyl[L];
771: DX = L[1]; X = L[0];
772: if(mydeg(N,DX) != 0)
773: return 0;
774: DD = mydeg(M,DX);
775: MM = M;
776: while( (Deg=mydeg(MM,DX)) > 0){
777: MC = mycoef(MM,Deg,DX)*DX^(Deg-1);
778: MS = radd(MC, MS);
779: MM = radd(MM, muldo(MC,radd(-DX,N),L));
780: }
781: return [MM, MS];
782: }
783:
784:
785: def mulsubst(F,L)
786: {
787: N = length(L);
788: if(N == 0)
789: return F;
790: if(type(L[0])!=4) L=[L];
1.4 ! takayama 791: if(getopt(inv)==1){
! 792: for(R=[];L!=[];L=cdr(L)) R=cons([car(L)[1],car(L)[0]],R);
! 793: L=reverse(R);
! 794: }
1.1 takayama 795: if(length(L)==1) return mysubst(F,L);
796: L1 = newvect(N);
797: for(J = 0; J < N ; J++)
798: L1[J] = uc();
799: L2 = newvect(N);
800: for(J = 0; J < N; J++){
801: S = L[J][1];
802: for(I = 0; I < N; I++)
803: S = mysubst(S,[L[I][0],L1[I]]);
804: L2[J] = S;
805: }
806: for(J = 0; J < N; J++)
807: F = mysubst(F, [L[J][0],L2[J]]);
808: for(J = 0; J < N; J++)
809: F = mysubst(F, [L1[J],L[J][0]]);
810: return F;
811: }
812:
813: def cmpsimple(P,Q)
814: {
815: T = getopt(comp);
816: if(P == Q)
817: return 0;
818: D = 0;
819: if(type(T) < 0)
820: T = 7;
821: if(iand(T,1))
822: D = length(vars(P)) - length(vars(Q));
823: if(!D && iand(T,2))
824: D = nmono(P) - nmono(Q);
825: if(!D && iand(T,4))
826: D = str_len(rtostr(P)) - str_len(rtostr(Q));
827: if(!D){
828: if(P > Q) D++;
829: else D--;
830: }
831: return D;
832: }
833:
834: def simplify(P,L,T)
835: {
836: if(type(P) > 3)
1.3 takayama 837: #ifdef USEMODULE
838: return map(os_md.simplify,P,L,T);
839: #else
1.1 takayama 840: return map(simplify,P,L,T);
1.3 takayama 841: #endif
1.1 takayama 842: if(type(L[0]) == 4){
843: if(length(L[0]) > 1)
1.3 takayama 844: #if USEMODULE
845: return fmult(os_md.simplify,P,L,[T]);
846: #else
1.1 takayama 847: return fmult(simplify,P,L,[T]);
1.3 takayama 848: #endif
1.1 takayama 849: L = L[0];
850: }
851: if(type(Var=getopt(var)) == 4 && Var!=[]){
852: if(type(P) == 3)
853: return simplify(nm(P),P,L,T|var=Var)/simplify(dn(P),P,L,T|var=Var);
854: V = car(Var);
855: if((I = mydeg(P,V)) > 0){
856: Var = cdr(Var);
857: for(Q=0; I>=0 ; I--)
858: Q += simplify(mycoef(P,I,V), L, T|var=Var)*V^I;
859: return Q;
860: }
861: }
862: if(length(L) == 1){
863: L = car(L);
864: for(V = vars(L); V != []; V = cdr(V)){
865: VT = car(V);
866: if(deg(L,VT) != 1) continue;
867: P = simplify(P, [VT, -red(coef(L,0,VT)/coef(L,1,VT))], T);
868: }
869: return P;
870: }
871: Q = mysubst(P,[L[0],L[1]]);
872: return (cmpsimple(P,Q|comp=T) <= 0)?P:Q;
873: }
874:
875: def monotos(P)
876: {
877: if(nmono(P) <= 1)
878: return rtostr(P);
879: return "("+rtostr(P)+")";
880: }
881:
1.4 ! takayama 882:
1.1 takayama 883: def monototex(P)
884: {
1.4 ! takayama 885: Q=my_tex_form(P);
! 886: if(nmono(P)<2 && (getopt(minus)!=1 || str_str(Q,"-"|top=0,end=0)<0))
! 887: return Q;
! 888: return "("+Q+")";
! 889: }
! 890:
! 891: def minustos(S)
! 892: {
! 893: if(str_str(S,"-"|top=0,end=0)<0) return S;
! 894: return "("+S+")";
1.1 takayama 895: }
896:
897: def vnext(V)
898: {
899: S = length(V);
900: for(I = S-1; I > 0; I--){
901: if(V[I-1] < V[I]){
902: V0 = V[I-1];
903: for(J = I+1; J < S; J++)
904: if(V0 >= V[J]) break;
905: V[I-1] = V[--J];
906: V[J] = V0;
907: for(J = S-1; I < J; I++, J--){
908: V0 = V[I];
909: V[I] = V[J];
910: V[J] = V0;
911: }
912: return 1;
913: }
914: }
915: return 0;
916: }
917:
918: def ldict(N, M)
919: {
920: Opt = getopt(opt);
921: R = S = [];
922: for(I = 2; N > 0; I++){
923: R = cons(irem(N,I), R);
924: N = idiv(N,I);
925: }
926: L = LL = length(R);
927: T=newvect(LL+1);
928: while(L-- > 0){
929: V = car(R); R = cdr(R);
930: for(I = J = 0; J <= V ; I++){
931: if(T[I] == 0)
932: J++;
933: }
934: T[I-1] = 1;
935: S = cons(LL-I+1, S);
936: }
937: for(I = 0; I <= LL; I++){
938: if(T[I] == 0){
939: S = cons(LL-I, S);
940: break;
941: }
942: }
943: if(M == 0)
944: return S;
945: if(M <= LL){
946: print("too small size");
947: return 0;
948: }
949: T = [];
950: for(I = --M; I > LL; I--)
951: T = cons(I,T);
952: S = append(S,T);
953: if(Opt == 2 || Opt == 3)
954: S = reverse(S);
955: if(Opt != 1 && Opt != 3)
956: return S;
957: for(T = []; S != []; S = cdr(S))
958: T = cons(M-car(S),T);
959: return T;
960: }
961:
962: def ndict(L)
963: {
964: Opt = getopt(opt);
965: R = [];
966: if(Opt != 1 && Opt != 2)
967: L = reverse(L);
968: T = (Opt == 1 || Opt == 3)?1:0;
969: for( ; L != []; L = cdr(L)){
970: for(I = 0, V = car(L), LT = cdr(L); LT != []; LT = cdr(LT))
971: if(T == 0){
972: if(V < car(LT)) I++;
973: }else if (V > car(LT)) I++;
974: R = cons(I, R);
975: }
976: R = reverse(R);
977: for(V = 0, I = length(R); I > 0; R = cdr(R), I--)
978: V = V*I + car(R);
979: return V;
980: }
981:
982:
983: def nextsub(L,N)
984: {
985: if(type(L) == 1){
986: for(LL = [], I = L-1; I >= 0; I--)
987: LL = cons(I,LL);
988: return LL;
989: }
990: M = length(L = ltov(L));
991: K = N-M;
992: for(I = M-1; I >= 0; I--)
993: if(L[I] < I+K) break;
994: if(I < 0)
995: return 0;
996: for(J = L[I]+1; I < M; I++, J++)
997: L[I] = J;
998: return vtol(L);
999: }
1000:
1001: def nextpart(L)
1002: {
1003: if(car(L) <= 1)
1004: return 0;
1005: for(I = 0, L = reverse(L); car(L) == 1; L=cdr(L))
1006: I++;
1007: I += (K = car(L));
1008: R = irem(I,--K);
1009: R = (R==0)?[]:[R];
1010: for(J = idiv(I,K); J > 0; J--)
1011: R = cons(K,R);
1012: L = cdr(L);
1013: while(L!=[]){
1014: R = cons(car(L), R);
1015: L = cdr(L);
1016: }
1017: return R;
1018: }
1019:
1020: def transpart(L)
1021: {
1022: L = reverse(L);
1023: for(I=1, R=[]; L!= []; I++){
1024: R = cons(length(L), R);
1025: while(L != [] && car(L) <= I)
1026: L = cdr(L);
1027: }
1028: return reverse(R);
1029: }
1030:
1031: def trpos(A,B,N)
1032: {
1033: S = newvect(N);
1034: for(I = 0; I < N; I++)
1035: S[I]=(I==A)?B:((I==B)?A:I);
1036: return S;
1037: }
1038:
1039: def sprod(S,T)
1040: {
1041: L = length(S);
1042: V = newvect(L);
1043: while(--L >= 0)
1044: V[L] = S[T[L]];
1045: return V;
1046: }
1047:
1048: def sinv(S)
1049: {
1050: L = length(S);
1051: V = newvect(L);
1052: while(--L >= 0)
1053: V[S[L]] = L;
1054: return V;
1055: }
1056:
1057: def slen(S)
1058: {
1059: L = length(S);
1060: for(V = 0, J = 2; J < L; i++){
1061: for(I = 0; I < J; I++)
1062: if(S[I] > S[J]) V++;
1063: }
1064: return V;
1065: }
1066:
1067: def sord(W,V)
1068: {
1069: L = length(W);
1070: W0 = nevect(L);
1071: V0 = newvect(L);
1072: for(I = F = C = 0; I < L; I++){
1073: C = 0;
1074: if( (W1 = W[I]) > (V1 = V[I]) ){
1075: if(F < 0) C = 1;
1076: else if(F==0) F = 1;
1077: }else if(W1 < V1){
1078: if(F > 0) C = 1;
1079: else if(F==0) F = -1;
1080: }
1081: for(J = I;--J >= 0 && W0[J] > W1; ) W0[J+1] = W0[J];
1082: W0[J+1] = W1;
1083: for(J = I;--J >= 0 && V0[J] > V1; ) V0[J+1] = V0[J];
1084: V0[J+1] = V1;
1085: if(C){
1086: for(J = I; J >= 0; J--){
1087: if((W1=W0[J]) == (V1=V0[J])) continue;
1088: if(W1 > V1){
1089: if(F < 0) return 2;
1090: }
1091: else if(F > 0) return 2;
1092: }
1093: }
1094: }
1095: return F;
1096: }
1097:
1098: def vprod(V1,V2)
1099: {
1100: for(R = 0, I = length(V1)-1; I >= 0; I--)
1101: R = radd(R, rmul(V1[I], V2[I]));
1102: return R;
1103: }
1104:
1.3 takayama 1105: def dnorm(V)
1106: {
1107: if(type(V)<2) return dabs(V);
1108: R=0;
1109: if(type(V)!=4)
1110: for (I = length(V)-1; I >= 0; I--) R+= V[I]^2;
1111: else{
1112: if(type(V[0])>3){
1113: V=ltov(V[0])-ltov(V[1]);
1114: return dnorm(V);
1115: }
1116: for(;V!=[]; V=cdr(V)) R+=car(V)^2;
1117: }
1118: return dsqrt(R);
1119: }
1120:
1121: def dvprod(V1,V2)
1122: {
1123: if(type(V1)<2) return V1*V2;
1124: R=0;
1125: if(type(V1)!=4)
1126: for(I = length(V1)-1; I >= 0; I--)
1127: R += V1[I]*V2[I];
1128: else{
1129: for(; V1!=[]; V1=cdr(V1),V2=cdr(V2))
1130: R+=car(V1)*car(V2);
1131: }
1132: return R;
1133: }
1134:
1135: def dvangle(V1,V2)
1136: {
1137: if(V2==0 && type(V1)==4 && length(V1)==3 &&
1138: (type(V1[0])==4 || type(V1[0])==5 || type(V1[1])==4 || type(V1[1])==5 ||
1139: type(V1[2])==4 || type(V1[2])==5) ){
1140: if(V1[0]==0 || V1[1]==0 || V1[2]==0) return 1;
1141: PV2=V1[1];
1142: if(type(PV2)==4){
1143: PV2=ltov(PV2);
1144: return dvangle(PV2-ltov(V1[0]),ltov(V1[2])-PV2);
1145: }else
1146: return dvangle(PV2-V1[0],V1[2]-PV2);
1147: }
1148: if((L1=dnorm(V1))==0 || (L2=dnorm(V2))==0) return 1;
1149: return dvprod(V1,V2)/(L1*L2);
1150: }
1151:
1.1 takayama 1152: def mulseries(V1,V2)
1153: {
1154: L = length(V1);
1155: if(size(V2) < L)
1156: L = size(V2);
1157: VV = newvect(L);
1158: for(J = 0; J < L; J++){
1159: for(K = R = 0; K <= J; K++)
1160: R = radd(R,rmul(V1[K],V2[J-K]));
1161: VV[J] = R;
1162: }
1163: return VV;
1164: }
1165:
1166: def pluspower(P,V,N,M)
1167: {
1168: RR = 1;
1169: for(K = R = 1; K < M-1; I++){
1170: R = R*(N-K+1)*P/K;
1171: RR = radd(RR,R);
1172: }
1173: VV = newvect(M);
1174: for(K = 0; K < M-1; K++)
1175: VV[K] = red(mycoef(RR,K,V));
1176: }
1177:
1178: def vtozv(V)
1179: {
1180: if(type(V)<4) V=newvect(1,[V]);
1181: S = length(V);
1182: VV = newvect(S);
1183: Lcm = 1;
1184: for(K = 0; K < S; K++){
1185: VV[K] = red(V[K]);
1186: Lcm = lcm(Lcm,dn(VV[K]));
1187: C = ptozp(nm(VV[K])|factor=0);
1188: if(K == 0){
1189: Dn = dn(C[1]);
1190: Nm = nm(C[1]);
1191: PNm = nm(C[0]);
1192: }else{
1193: Dn = ilcm(Dn,dn(C[1]));
1194: Nm = igcd(Nm,nm(C[1]));
1195: PNm = gcd(PNm,nm(C[0]));
1196: }
1197: }
1.4 ! takayama 1198: if(!(M=Nm*PNm)) return [VV,0];
! 1199: Mul = (Lcm*Dn)/M;
1.1 takayama 1200: for(K = 0; K < S; K++)
1201: VV[K] = rmul(VV[K],Mul);
1202: return [VV,Mul];
1203: }
1204:
1205: def dupmat(M)
1206: {
1207: if(type(M) == 6){
1208: Size = size(M);
1209: MM = newmat(Size[0],Size[1]);
1210: for(I = 0; I < Size[0]; I++){
1211: for(J = 0; J < Size[1]; J++)
1212: MM[I][J] = M[I][J];
1213: }
1214: return MM;
1215: }
1216: if(type(M) == 5)
1217: return ltov(vtol(M));
1218: return M;
1219: }
1220:
1221: def matrtop(M)
1222: {
1223: S = size(M);
1224: MM = dupmat(M);
1225: Lcm = newvect(S[0]);
1226: for(J = 0; J < S[0]; J++){
1227: U = vtozv(M[J]);
1228: for(K = -1, I = 0; I < S[1]; I++)
1229: MM[J][I] = U[0][I];
1230: Lcm[J] = U[1];
1231: }
1232: return [MM,Lcm];
1233: }
1234:
1.3 takayama 1235: def mytrace(M)
1236: {
1237: S=size(M);
1238: if(S[0]!=S[1]) return 0;
1239: for(I=V=0; I<S[0]; I++){
1240: V+=M[I][I];
1241: }
1242: return V;
1243: }
1244:
1.1 takayama 1245: def mydet(M)
1246: {
1247: MM = matrtop(M);
1248: if(type(MM[0]) == 6){
1249: S = size(M);
1250: for(Dn = 1, I = 0; I < S[0]; I++)
1251: Dn *= MM[1][I];
1.4 ! takayama 1252: return (!Dn)?0:red(det(MM[0])/Dn);
1.1 takayama 1253: }
1254: }
1255:
1256: def mperm(M,P,Q)
1257: {
1258: if(type(M) == 6){
1259: S = size(M);
1260: if(type(P) <= 1)
1261: P=(P==1)?Q:trpos(0,0,S[0]);
1262: if(type(P) > 3 && type(P[0]) >= 4)
1263: P = trpos(P[0][0],P[0][1],S[0]);
1264: else if(type(P) == 4){
1265: if(length(P)==2 && type(P[1])==4){
1266: P0=P[0];P1=car(P[1]);P=newvect(P1);
1267: for(I=0;I<P1;I++) P[I]=P0+I;
1268: }else P = ltov(P);
1269: }
1270: if(type(Q) <= 1)
1271: Q=(Q==1)?P:trpos(0,0,S[1]);
1272: if(type(Q) > 3 && type(Q[0]) >= 4)
1273: Q = trpos(Q[0][0],Q[0][1],S[1]);
1274: if(type(Q) == 4){
1275: if(length(Q)==2 && type(Q[1])==4){
1276: P0=Q[0];P1=car(Q[1]);Q=newvect(P1);
1277: for(I=0;I<P1;I++) Q[I]=P0+I;
1278: }else Q = ltov(Q);
1279: }
1280: MM = newmat(S0=length(P),S1=length(Q));
1281: for(I = 0; I < S0; I++){
1282: MMI = MM[I]; MPI = M[P[I]];
1283: for(J = 0; J < S1; J++)
1284: MMI[J] = MPI[Q[J]];
1285: }
1286: return MM;
1287: }
1288: if((type(M) == 5 || type(M) == 4) && type(P) >= 4){
1289: if(length(P) == 1 && type(car(P)) == 4)
1290: P = trpos(car(P)[0],car(P)[1],length(M));
1291: MM = newvect(S = length(P));
1292: for(I = 0; I < S; I++)
1293: MM[I] = M[P[I]];
1294: if(type(M) == 4)
1295: MM = vtol(MM);
1296: return MM;
1297: }
1298: return M;
1299: }
1300:
1301: def mtranspose(M)
1302: {
1303: if(type(M)==4){
1304: MV=ltov(M);
1305: II=length(MV);
1306: for(I=L=0; I<II; I++){
1307: if(type(MV[I])!=4) return M;
1308: MV[I]=ltov(MV[I]);
1309: }
1310: for(R=[],J=0; ;J++){
1311: for(T=[],I=F=0; I<II; I++){
1312: if(length(MV[I])>J){
1313: F=1;
1314: T=cons(MV[I][J],T);
1315: }
1316: }
1317: if(F==0) return reverse(R);
1318: if(F==1) R=cons(reverse(T),R);
1319: }
1320: }
1321: if(type(M) != 6)
1322: return M;
1323: S = size(M);
1324: MM = newmat(S[1],S[0]);
1325: for(I = 0; I < S[0]; I++){
1326: for(J = 0; J < S[1]; J++)
1327: MM[J][I] = M[I][J];
1328: }
1329: return MM;
1330: }
1331:
1332: def mtoupper(MM, F)
1333: {
1.3 takayama 1334: TeXs=["\\ -=\\ ","\\ +=\\ "];
1335: Lins=[" -= line"," += line"];
1336: Assume=["If","Assume"];
1337: if(type(St = getopt(step))!=1) St=0;
1.1 takayama 1338: Opt = getopt(opt);
1339: if(type(Opt)!=1) Opt=0;
1340: TeX=getopt(dviout);
1.3 takayama 1341: if(type(Tab=getopt(tab))!=1 && Tab!=0) Tab=2;
1.1 takayama 1342: Line="\\text{line}";
1.3 takayama 1343: if(type(TeX)!=1 || !St) TeX=0;
1.1 takayama 1344: Size = size(MM);
1.3 takayama 1345: if(F==-1){
1.1 takayama 1346: M = newmat(Size[0], Size[1]+1);
1347: for(I = 0; I < Size[0]; I++){
1348: for(J = 0; J < Size[1]; J++)
1349: M[I][J] = MM[I][J];
1350: M[I][Size[1]] = zz^I;
1351: }
1352: Size = size(M);
1353: F = 1;
1354: }else if(F<0){
1355: F=Size[0];
1356: M = newbmat(1,2,[[MM,mgen(F,0,[1],0)]]);
1357: Size=[Size[0],F+Size[1]];
1358: }else
1359: M = dupmat(MM);
1.3 takayama 1360: if(St){
1.1 takayama 1361: if(TeX) Lout=[[dupmat(M)]];
1362: else mycat0([M,"\n\n"],0);
1363: }
1364: Top="";
1365: if(Opt>3){
1366: for(I=Opt; I>4; I--)
1.3 takayama 1367: Top+=(TeX)?"\\ ":" ";
1.1 takayama 1368: }
1.3 takayama 1369: PC=IF=1;
1.1 takayama 1370: for(K = JJ = 0; K < Size[1] - F; K++){
1371: for(J = JJ; J < Size[0]; J++){
1.3 takayama 1372: if(M[J][K] != 0){ /* search simpler element */
1.1 takayama 1373: if(Opt>2 && (Mul=M[J][K])!=1){
1374: for(FF=0,JT=J; JT<Size[0]; JT++){
1.3 takayama 1375: if((Val=M[JT][K])==1){ /* 1 */
1376: Mul=1;J=JT; break;
1.1 takayama 1377: }
1378: if(Val==0 || type(Val)>type(Mul)) continue;
1379: if(type(Val)<type(Mul) || (Val==-1 && Mul!=-1)){
1.3 takayama 1380: Mul=Val; J=JT; /* smaller type */
1.1 takayama 1381: }
1.3 takayama 1382: else if(Opt>3){
1383: if(isint(Val)==1){ /* integer elememt */
1384: if(isint(Mul)!=1){
1385: Mul=Val; J=JT; /* integer */
1386: }
1387: if(FF<3||(FF==3&&Val>0)){
1388: for(JK=K+1;;){
1389: if(JK>=Size[1]-F){
1390: J=JT;
1391: FF=((Mul=Val)>0)?4:3;
1392: break; /* divisible int => 4: pos_int 3: neg_int */
1393: }
1394: if(isint(M[JT][JK++]/Val)!=1) break;
1395: }
1396: }
1397: }else if(!FF){
1398: for(JK=K+1; JK<Size[1]-F; JK++){
1399: if(isint(M[JT][JK]/Val)!=1) break;
1400: J=JT; FF=1; /* divisible => 1: non integer */
1.1 takayama 1401: }
1402: }
1403: }
1404: }
1.3 takayama 1405: if(FF==0 && Opt>3 && Mul!=1 && Mul!=-1){ /* FF > 0 => divisible */
1406: for(FF=0,J0=J; J0<Size[0]-1 && FF!=9; J0++){
1.1 takayama 1407: VV0=M[J0][K];
1408: if(VV0==0 || isint(VV0)==0) continue;
1.3 takayama 1409: for(J1=J0+1;J1<Size[0] && FF!=9; J1++){
1.1 takayama 1410: VV1=M[J1][K];
1411: if(VV1==0 || isint(VV1)==0) continue;
1.3 takayama 1412: for(C=FT=0,V0=VV0,V1=VV1; C<2 && FF!=10; C++,V1=V0,V0=VV1){
1.1 takayama 1413: for(CC=0,RC=ceil(V0/V1);CC<2;CC++,RC--){
1414: if((CD=V0-RC*V1)==0 && (RC==1 || RC==-1)){
1.3 takayama 1415: FT=1; FF=10; /* 10: vanish by +- */
1.1 takayama 1416: }else if(CD==1){
1.3 takayama 1417: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1418: if((RC==1 || RC==-1) && FF<8+FV){
1419: FT=1; FF=8+FV; /* 8/9: 1 by +- */
1420: }else if(FF<6+VF){
1421: FT=1; FF=6+FV; /* 6/7: 1 by times */
1.1 takayama 1422: }
1423: }else if(CD==-1){
1.3 takayama 1424: FV=(vars(M[J0])==[]&&vars(M[J1])==[])?1:0;
1425: if((RC==1 || RC==-1) && FF<4+FV){
1426: FT=1; FF=4+FV; /* 4/5: 1 by +- */
1427: }else if(FF<2+VF){
1428: FT=1; FF=2+FV; /* 2/3: 1 by times */
1.1 takayama 1429: }
1430: }
1431: if(FT==1){
1432: FT=0; KRC=RC;
1433: if(C==0){
1434: KJ0=J0; KJ1=J1;
1435: }else{
1436: KJ0=J1; KJ1=J0;
1437: }
1438: }
1439: }
1440: }
1441: }
1442: }
1443: if(FF>0){
1444: for(I=K;I<Size[1];I++)
1445: M[KJ0][I]=radd(M[KJ0][I],rmul(M[KJ1][I],-KRC));
1.3 takayama 1446: if(KRS<0){
1447: KRS=-KRS;Sgn=1;
1448: }else
1449: Sgn=0;
1450: if(St){
1.1 takayama 1451: if(TeX){
1452: if(KRC==1)
1.3 takayama 1453: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1.1 takayama 1454: Line,KJ1+1,"}",dupmat(M)],Lout);
1455: else
1.3 takayama 1456: Lout=cons([Top+"\\xrightarrow{", Line,KJ0+1,TeXs[Sgn],
1457: Line,KJ1+1,"\\times\\left(",KRC,"\\right)}",
1.1 takayama 1458: dupmat(M)],Lout);
1.3 takayama 1459:
1.1 takayama 1460: }else{
1461: if(KRC==1)
1.3 takayama 1462: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1,"\n",M,"\n"]); else
1463: mycat([Top+"line",KJ0+1,Lins[Sgn],KJ1+1," * (",KRC,")\n",M,"\n"]);
1.1 takayama 1464: }
1465: }
1466: Mul=M[KJ0][K]; J=KJ0;
1.3 takayama 1467: if(FF==10){
1.1 takayama 1468: J--; continue;
1469: }
1470: }
1471: }
1.3 takayama 1472: }
1473: /* a parameter Var */
1474: Var=0;
1475: if(St && Opt>4 && length(Var=vars(nm(M[J][K])))==1){
1476: J0=J;Jv=mydeg(nm(M[J0][K]),car(Var));
1477: for(I=JJ;I<Size[0]; I++){
1478: if((MIK=M[I][K])==0) continue;
1479: if((T=vars(MIK=nm(MIK)))==[]){ /* 1/poly */
1480: J=I;Var=[]; break;
1481: }
1482: if(length(T)>1) continue;
1483: if(mydeg(MIK,T[0])<Jv){
1484: J0=I;Jv=mydeg(MIK);Var=T; /* search minimal degree */
1485: }
1486: }
1487: if(length(Var)==1){
1488: Var=car(Var);
1489: Q=nm(M[J0][K]);
1490: for(I=JJ; I<Size[0]; I++){
1491: if(I==J0 || mydeg(nm(M[I][K]),Var)<0) continue;
1492: T=rpdiv(nm(M[I][K]),Q,Var);
1493: if(T[0]!=0 && (vars(T)==[] || vars(T)==[Var])) break; /* dec. deg */
1494: }
1495: }
1496: }
1497: if(type(Var)==2){ /* 1 variable */
1498: if(I==Size[0]){
1499: for(QF=0,Q0=1,QR=getroot(Q,Var|mult=1);QR!=[];QR=cdr(QR)){
1500: if(deg(T=QR[0][1],Var)>0){
1501: QF=1;Q0*=T; continue;
1502: }
1503: if(subst(PC,Var,T)==0) continue;
1504: Q0*=(Var-(T=QR[0][1]));
1505: if(type(T)<2){
1506: M0=subst(M,Var,T);
1507: if(TeX){
1508: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1509: Var,"=",T,","] ,Lout);
1510: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab),Lout);
1511: }else{
1512: mycat([str_times(" ",St-1)+"If",Var,"=",T,","]);
1513: mtoupper(M0,F|step=St+1,opt=Opt);
1.1 takayama 1514: }
1515: }
1516: }
1.3 takayama 1517: if(Q0!=1){
1518: if(TeX)
1519: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[QF]+" }",
1520: Q0/=fctr(Q0)[0][0],"\\ne0,"],Lout);
1521: else
1522: mycat([str_times(" ",St-1)+Assume[QF],Q0,"!=0,"]);
1523: PC*=Q0;
1.1 takayama 1524: }
1.3 takayama 1525: IF=0;St++;
1526: }else{
1527: KRC=-red((T[2]*dn(M[J0][K]))/(T[1]*dn(M[I][K])));
1528: for(II=K;II<Size[1];II++)
1529: M[I][II]=radd(M[I][II],rmul(M[J0][II],KRC));
1530: if(TeX)
1531: Lout=cons([Top+"\\xrightarrow{", Line,I+1,"\\ +=\\ ",Line,
1532: J0+1,"\\times\\left(",KRC,"\\right)}",dupmat(M)],Lout);
1533: else
1534: mycat([Top+"line",I+1,"+=",Line,J0+1," * (",KRC,")\n",M,"\n"]);
1535: J=JJ-1;
1536: continue;
1.1 takayama 1537: }
1538: }
1539: if(J != JJ){
1540: for(I = K; I < Size[1]; I++){
1541: Temp = M[JJ][I];
1542: M[JJ][I] = M[J][I];
1543: M[J][I] = (Opt>=2)?Temp:-Temp;
1544: }
1.3 takayama 1545: if(St){
1.1 takayama 1546: if(TeX)
1.3 takayama 1547: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,"\\ \\leftrightarrow\\ ",
1548: Line,J+1,"}",dupmat(M)],Lout);
1.1 takayama 1549: else
1550: mycat0([Top+"line",JJ+1," <-> line",J+1,"\n",M,"\n\n"],0);
1551: }
1552: }
1.3 takayama 1553: /* Assume PC != 0 */
1.1 takayama 1554: if(Opt>1){
1.3 takayama 1555: Mul = M[JJ][K];
1556: if(Opt > 5 && St && IF && (Var=vars(MIK=nm(Mul)))!=[]){
1557: TF=fctr(MIK);
1558: for(FF=0,Q0=1,TP=cdr(TF);TP!=[];TP=cdr(TP)){
1559: if(type(dn(red(PC/(TP0=car(car(TP))))))<2) continue; /* divisible */
1560: Q0*=TP0;
1561: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
1562: if(mydeg(TP0,X=car(Var))==1 && type(dn(red(PC/mycoef(TP0,1,X))))<2){
1563: /* TP0=A*X+B with non-vanishing A */
1564: T=red(-mycoef(TP0,0,X)/mycoef(TP0,1,X));
1565: M0=mysubst(M,[X,T]);
1566: if(TeX){
1567: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1568: X,"=",T,","] ,Lout);
1569: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab),
1570: Lout);
1571: }else{
1572: mycat([str_times(" ",St-1)+"If",X,"=",T,","]);
1573: mtoupper(M0,F|step=St+1,opt=Opt);
1574: }
1575: break;
1576: }
1577: }
1578: if(Var==[] && Opt>6){
1579: for(Var=vars(TP0);Var!=[];Var=cdr(Var)){
1580: if(mydeg(TP0,X=car(Var))==1){
1581: /* TP0=A*X+B, A is a poly of X0 with rational funct */
1582: T=nm(mycoef(TP0,1,X));
1583: for(Var0=vars(T);Var0!=[]; Var0=cdr(Var0)){
1584: X0=car(Var0);
1585: if(type(dn(red(PC/type(mycoef(T,mydeg(T,X0),X0)))))>1) continue;
1586: TR=getroot(T,X0|mult=1);
1587: if(findin(X0,vars(TR))<0) break;
1588: }
1589: if(Var0==[]) continue;
1590: for(;TR!=[0];TR=cdr(TR)){
1591: if(TR==[]){
1592: TR=[0,0];
1593: T0=-mycoef(TP0,0,X)/mycoef(TP0,1,X);
1594: X0=X;
1595: }else T0=car(TR)[1];
1596: M0=mysubst(M,[X0,T0]);
1597: if(TeX){
1598: Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{If }",
1599: X0,"=",T0,","] ,Lout);
1600: Lout=append(mtoupper(M0,F|step=St+1,opt=Opt,dviout=-2,tab=Tab),
1601: Lout);
1602: }else{
1603: mycat([str_times(" ",St-1)+"If",X0,"=",T0,","]);
1604: mtoupper(M0,F|step=St+1,opt=Opt);
1605: }
1606: }
1607:
1608: }
1609: break;
1610: }
1611: }
1612: if(Var==[]){
1613: /* mycat([PC,TF,TP0,vars(TP0)]); */
1614: FF=1;
1615: }
1616: }
1617: if(Q0!=1){
1618: if(FF) FF=1;
1619: if(TeX) Lout=cons(["\\hspace{",Tab*(St-3)-1,"mm}\\text{"+Assume[FF]+" }",Q0/=fctr(Q0)[0][0],"\\ne0,"],
1620: Lout);
1621: else mycat([str_times(" ",St-1)+Assume[FF],Q0,"!=0,"]);
1622: PC*=Q0;St++;
1623: }
1624: }
1625: IF=M[JJ][K]=1;
1.1 takayama 1626: if(Mul!=1){
1627: for(L=K+1; L<Size[1]; L++)
1628: M[JJ][L]=red(M[JJ][L]/Mul);
1.3 takayama 1629: if(St){
1.1 takayama 1630: if(TeX)
1.3 takayama 1631: Lout=cons([Top+"\\xrightarrow{",Line,JJ+1,
1632: "\\ \\times=\\ \\left(",red(1/Mul),"\\right)}",
1.1 takayama 1633: dupmat(M)],Lout);
1634: else
1.3 takayama 1635: mycat0([Top+"line",JJ+1, " *= (",red(1/Mul), ")\n",M,"\n\n"],0);
1.1 takayama 1636: }
1637: }
1.3 takayama 1638:
1.1 takayama 1639: }
1640: for(J = (Opt>0)?0:(JJ+1); J < Size[0]; J++){
1641: if(J == JJ)
1642: continue;
1643: Mul = -M[J][K];
1644: if(Mul!=0){
1645: if(Opt!=2) Mul=rmul(Mul,1/M[JJ][K]);
1646: for(I = K+1; I < Size[1]; I++)
1647: M[J][I] = radd(M[J][I],rmul(M[JJ][I],Mul));
1648: M[J][K] = 0;
1.3 takayama 1649: if(St){
1650: if(Mul<0){
1651: Mul=-Mul;Sgn=0;
1652: }else Sgn=1;
1.1 takayama 1653: if(TeX){
1654: if(Mul==1)
1.3 takayama 1655: Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
1.1 takayama 1656: "}",dupmat(M)],Lout);
1.3 takayama 1657: else Lout=cons([Top+"\\xrightarrow{", Line,J+1,TeXs[Sgn],Line,JJ+1,
1.1 takayama 1658: "\\times\\left(",Mul,"\\right)}",dupmat(M)],Lout);
1659: }else{
1660: if(Mul==1)
1.3 takayama 1661: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1,"\n",M,"\n\n"],0);
1.1 takayama 1662: else
1.3 takayama 1663: mycat0([Top+"line",J+1, Lins[Sgn],JJ+1," * (",Mul,")\n",M,"\n\n"],0);
1.1 takayama 1664: }
1665: }
1666: }
1667: }
1668: JJ++;
1669: }
1670: }
1671: }
1672: if(TeX){
1.3 takayama 1673: if(TeX==-2) return Lout;
1.1 takayama 1674: Lout=reverse(Lout);
1.3 takayama 1675: Br="\\allowdisplaybreaks";
1676: Cr="\\\\\n &";
1677: if(getopt(pages)==1) Cr=Br+Cr;
1678: if(type(S=getopt(cr))==7) Cr=S;
1.4 ! takayama 1679: if(type(Lim=getopt(lim))==1){
! 1680: if(Lim>0){
! 1681: if(Lim<30) Lim=TeXLim;
! 1682: Lim*=2;
! 1683: }
! 1684: }else Lim=0;
! 1685: Out = ltotex(Lout|opt=["cr","spts0"],str=1,cr=Cr,lim=Lim);
1.3 takayama 1686: if(TeX<0) return Out;
1687: dviout(Out|eq=(str_str(Cr,Br)>=0)?6:5,keep=(TeX==1)?0:1);
1.1 takayama 1688: }
1689: return M;
1690: }
1691:
1692: def mydet2(M)
1693: {
1694: S = size(M);
1695: Det = 1;
1696: MM = mtoupper(M,0);
1697: for(I = 0; I < S[0]; I++)
1698: Det = rmul(Det,MM[I][I]);
1699: return Det;
1700: }
1701:
1702: def myrank(MM)
1703: {
1704: S = size(MM);
1705: M = dupmat(MM);
1706: M = mtoupper(M,0);
1707: C = 0;
1708: for(I = K = 0; I < S[0]; I++){
1709: for(J = K; J < S[1]; J++){
1710: if(M[I][J] != 0){
1711: C++; K++;
1712: break;
1713: }
1714: }
1715: }
1716: return C;
1717: }
1718:
1719: def meigen(M)
1720: {
1721: F = getopt(mult);
1722: if(type(M)==4 || type(M)==5){
1723: II=length(M);
1724: for(R=[],I=II-1; I>=0; I--){
1725: if(F==1)
1726: R=cons(meigen(M[I]|mult=1),R);
1727: else
1728: R=cons(meigen(M[I]),R);
1729: }
1730: return R;
1731: }
1732: S = size(M)[0];
1733: P = mydet2(mgen(S,0,[zz],0)-M);
1734: return (F==1)?getroot(P,zz|mult=1):getroot(P,zz);
1735: }
1736:
1.3 takayama 1737: def transm(M)
1738: {
1.4 ! takayama 1739: if(type(M)!=6) M=s2m(M);
! 1740: if(type(M)!=6){
! 1741: errno(0);
! 1742: return 0;
! 1743: }
1.3 takayama 1744: L=[M];TeX="";
1745: Line=["\\text{line}","\\text{col}"];
1746: if((DVI=getopt(dviout)) !=1) DVI=0;
1747: else dviout(M);
1748: for(;;){
1749: print(L0=dupmat(car(L)));
1750: Sz=size(L0);
1751: S=keyin("? ");
1752: N=0;
1753: if(str_len(S)<=1){
1754: if(S=="q") return L;
1755: if(S=="t"){
1756: N=mtranspose(L0);
1757: TeX=["\\text{transpose}"];
1758: }
1759: else if(S=="f"){
1760: if(length(L)>1){
1761: if(LF!=0) TeX="";
1762: L=cdr(L);LF=L0;
1.4 ! takayama 1763: if(DVI){
! 1764: dviout0(-1);
! 1765: dviout(" ");
! 1766: }
1.3 takayama 1767: }
1768: }else if(S=="g"){
1769: if(LF!=0) N=LF;
1770: }else if(S=="0"){
1771: N=M;L=[];TeX=[];
1772: }else if(S=="a"||S=="A"){
1773: if(DVI&&S=="A") mtoupper(L0,0|step=1,opt=10,dviout=1);
1774: else mtoupper(L0,0|step=1,opt=10);
1775: }else{
1776: mycat0([
1777: "2,5 : line2 <-> line5",
1778: "2,5,-2 ; line2 += (-2)*line5",
1779: "2,2,-2 : line2 *= -2",
1780: "2,5,0 : line2 += (?)*line5 for reduction",
1781: "r,2,5 : raw2 <-> raw5 (r,2,5,-2 etc.)",
1782: "s,x,2 : subst(*,x,2)",
1783: "t : transpose",
1784: "0 : first matrix",
1785: "f : previous matrix",
1786: "g : next matrix (only after f)",
1787: "A : auto (a : without TeX)",
1788: "q : quit"
1789: ],1|delim="\n");
1790: }
1791: }else{
1792: FR=0;
1793: S=evals(S|del=",");
1794: if(S[0]==r){
1795: FR=1; S=cdr(S);
1796: }
1797: if((LL=length(S))>=2){
1798: S0=S[0]-1;S1=S[1]-1;
1799: if(S[0]==s){
1800: if(length(S)==3) N=subst(L0,S[1],S[2]);
1801: if(DVI) TeX=[S[1],"\\mapsto",S[2]];
1.4 ! takayama 1802: }else if(FR==0){
! 1803: if(S0<0 || S0>=Sz[0] || S1<0 || S1>=Sz[0]) continue;
1.3 takayama 1804: if(LL==2){
1805: N=rowx(L0,S0,S1);
1806: if(DVI) TeX=[Line[0],S[0],"\\ \\leftrightarrow\\ ",Line[0],S[1]];
1807: }else{
1808: S2=S[2];
1809: if(S0==S1){
1810: N=rowm(L0,S0,S2);
1811: if(DVI) TeX=[Line[0],S[0],"\\ \\times=\\ ",S2];
1812: }else{
1813: if(S2==0){
1814: for(J=0;J<Sz[1] && L0[S1][J]==0;J++);
1815: if(J<Sz[1]) S2=-L0[S0][J]/L0[S1][J];
1816: }
1817: if(S2!=0){
1818: N=rowa(L0,S0,S1,S2);
1819: if(DVI) TeX=[Line[0],S[0],"\\ +=\\ ",Line[0],
1820: S[1],"\\ \\times\\ (",S2,")"];
1821: }
1822: }
1823: }
1.4 ! takayama 1824: }else{
! 1825: if(S0<0 || S0>=Sz[1] || S1<0 && S1>=Sz[1]) continue;
1.3 takayama 1826: if(LL==2){
1827: N=colx(L0,S0,S1);
1828: if(DVI) TeX=[Line[1],S[0],"\\ \\leftrightarrow\\ ",Line[1],S[1]];
1829: }else{
1830: S2=S[2];
1831: if(S0==S1){
1832: N=colm(L0,S0,S2);
1833: if(DVI) TeX=[Line[1],S[0],"\\ \\times=\\ ",S[2]];
1834: }else{
1835: if(S2!=0){
1836: for(J=0; I1<Sz[0] && L0[I1][J]==0; J++);
1837: if(J<Sz[0]) S2=-L0[J][S0]/L0[J][S1];
1838: }if(S2!=0){
1839: N=cola(L0,S0,S1,S2);
1840: if(DVI) TeX=[Line[1],S[0],"\\ +=\\ ",Line[1],
1841: S[1],"\\ \\times\\ (",S2,")"];
1842: }
1843: }
1844: }
1845: }
1846: }
1847: }
1848: if(N!=0){
1849: LF=0;L=cons(N,L);
1850: if(DVI) dviout("\\xrightarrow{"+ltotex(TeX|opt="spts0",str=1)+"}"+mtotex(N)|eq=8);
1851: }
1852: }
1853: }
1854:
1.1 takayama 1855: def vgen(V,W,S)
1856: {
1857: IM=length(V);
1858: I=(getopt(opt)==0)?IM:0;
1859: for(SS=0; I<IM && (SS==0 || V[I]<=W[I]); I++)
1860: SS += W[I];
1861: if(I<IM){
1862: W[I]++;
1863: SS--;
1864: }else
1865: SS=S;
1866: for(J=0;J<I;J++){
1867: W[J] = (SS<=V[J])?SS:V[J];
1868: SS -= W[J];
1869: }
1870: if(SS>0)
1871: return -1;
1872: return(I==IM)?0:I;
1873: }
1874:
1875: def mmc(M,X)
1876: {
1877: L=length(M);
1878: if(getopt(mult)==1){
1879: for(SS=I=2; I<L; I+=(++SS));
1880: if(I!=L) return -1;
1881: }else SS=L;
1882: N=newvect(L);
1883: for(I=0;I<L;I++)
1884: N[I]=M[I];
1885: S=size(N[0])[0];
1886: if(type(X)==4){
1887: for(I=0;I<SS;I++){
1888: if(X[I] != 0)
1889: N[I] = radd(N[I],X[I]);
1890: }
1891: X=X[SS];
1892: }
1893: MZ = newmat(S,S);
1894: ME = mgen(S,0,[X],0);
1895: MM = newvect(L);
1896: for(J=0; J<SS; J++){
1897: for(R=[],I=SS-1; I>=0; I--){
1898: if(I==J){
1899: for(RR=[],K=SS-1; K>=0; K--)
1900: RR=cons((K==I)?N[K]+ME:N[K],RR);
1901: R=cons(RR,R);
1902: }else R=cons([MZ],R);
1903: }
1904: MM[J]=newbmat(SS,SS,R);
1905: }
1906: for( ;J<L; J++){
1907: for(R=[],I=SS-1; I>=0; I--){
1908: for(RR=[N[J]],K=0;K<I;K++)
1909: RR=cons(MZ,RR);
1910: R=cons(RR,R);
1911: }
1912: MM[J]=newbmat(SS,SS,R);
1913: }
1914: for(II=JJ=1,J=SS; J<L; J++){
1915: JI=(II==JJ)?0:II;
1916: IS=JI*S;JS=JJ*S;
1917: for(P=0; P<S; P++){
1918: for(Q=0; Q<S; Q++){
1919: MM[J][JS+P][JS+Q] += N[JI][P][Q];
1920: MM[J][JS+P][IS+Q] -= N[JI][P][Q];
1921: MM[J][IS+P][IS+Q] += N[JJ][P][Q];
1922: MM[J][IS+P][JS+Q] -= N[JJ][P][Q];
1923: }
1924: }
1925: if(++II>=SS) II=++JJ;
1926: }
1927: for(R=[],I=SS-1; I>=0; I--){
1928: for(RR=[N[I]],J=0; J<I; J++) RR=cons(MZ,RR);
1929: R=cons(RR,R);
1930: }
1931: M0 = newbmat(SS,SS,R);
1932: for(M1=MM[0], J=1; J<SS; J++) M1=radd(M1,MM[J]);
1933: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
1934: if(length(KE) == 0) return MM;
1935: KK = mtoupper(lv2m(KE),0);
1936: for(I=0;I<L;I++)
1937: MM[I] = mmod(MM[I],KK);
1938: return MM;
1939: }
1940:
1941: def lpgcd(L)
1942: {
1943: for(F=[]; L!=[]; L=cdr(L)){
1944: if((P=car(L))==0) continue;
1945: if(F==[]){
1946: F=fctr(P);
1947: S=length(F);
1948: S--;
1949: V=newvect(S);
1950: M=newvect(S);
1951: for(I=0; I<S; I++){
1952: M[I] = F[I+1][1];
1953: V[I] = F[I+1][0];
1954: }
1955: N=nm(ptozp(P|factor=1)[1]);
1956: continue;
1957: }
1958: N=igcd(ptozp(P|factor=1)[1],N);
1959: for(I=0; I<S; I++){
1960: for(Q=P,CT=0; CT<M[I]; CT++)
1961: if((Q=tdiv(Q,V[I])) == 0) break;
1962: if(CT<M[I]) M[I]=CT;
1963: }
1964: }
1965: if(F==[]) return 0;
1966: for(Q=N,I=0;I<S; I++){
1967: while(M[I]>0){
1968: Q *= V[I];
1969: M[I]--;
1970: }
1971: }
1972: return Q;
1973: }
1974:
1975: def mdivisor(M,X)
1976: {
1.3 takayama 1977: S=size(M=dupmat(M));
1978: XX=(type(X)==4||X==0)?X:[0,X];
1.1 takayama 1979: S0=S[0]; S1=S[1];
1.3 takayama 1980: if((Tr=getopt(trans))==1||Tr==2){
1981: Tr0=1;
1.1 takayama 1982: GR=mgen(S0,0,1,0); GC=mgen(S1,0,1,0);
1.3 takayama 1983: }else Tr=Tr0=0;
1984: /* 0,a,b : (a,b)->(1,1)
1985: 1 : (1,1) invertible
1986: 2,i,M : line 0,i by M
1987: 3,j,M : col 0,j by M
1988: 4,j : col 1 += col j
1989: 5,j,T : line j by T
1990: 6,j,T : col 1 += col j by T (non-com)
1991: 7,j : line 2<->j (non-com)
1992: */
1993: if(type(V=getopt(dviout))==1){
1994: if(type(XX)==4 && type(XX[0])>1) Var=[XX[1],"\\partial"];
1995: else Var=0;
1996: Tr=(abs(V)==3)?0:1;
1997: MM=dupmat(M);
1998: II=((S[0]>S[1])?S[1]:S[0])+1;
1999: if(abs(V)>1){
2000: Is1=Js1=S[0]+S[1];
2001: Is=Js=[0,[Is1]];
2002: }else{
2003: Is=[0,[Is1=S[0]]];Js=[0,[Js1=S[1]]];
2004: }
2005: VV=V;
2006: V=newvect(II);
2007: for(I=0;I<II;I++) V[I]=[];
2008: N=newbmat(2,2,[[M,mgen(S[0],0,[1],0)],[mgen(S[1],0,[1],0)]]);
2009: mdivisor(M,X|step=1,dviout=V);
2010: L=S[0]+S[1];
2011: if(Tr){
2012: NN=mperm(N,Is1,Js1);
2013: for(K=S[0];K<Is1;K++){
2014: for(L=S[1];L<Js1;L++)
2015: NN[K][L]=" ";
2016: }
2017: Out=[[mperm(NN,Is,Js)]];
2018: }
2019: for(I=1;I<II;I++){
2020: I0=I-1;
2021: if(V[I]==[]) continue;
2022: for(T=reverse(V[I]);T!=[];T=cdr(T)){
2023: St=[];
2024: C=car(R=car(T));
2025: if(C==0){
2026: N=mperm(N,(R[1]==0)?0:[[R[1]+I0,I0]],(R[2]==0)?0:[[R[2]+I0,I0]]);
2027:
2028: if(Tr){
2029: if(R[2]!=0) St=append(["C",I,"\\leftrightarrow C",R[2]+I],St);
2030: if(R[1]!=0){
2031: if(R[2]!=0) St=cons(",\\ ",St);
2032: St=append(["L",I,"\\leftrightarrow L",R[1]+I],St);
2033: }
2034: Out=cons(St,Out);
2035: }
2036: }else if(C==1){
2037: P=1/N[I0][I0];N[I0][I0]=1;
2038: if(P!=1){
2039: for(J=I;J<L;J++)
2040: N[I0][J]=muldo(P,N[I0][J],XX);
2041:
2042: if(Tr){
2043: St=append(["L",I,"\\leftarrow(",P,")","\\times L",I],St);
2044: Out=cons(St,Out);
2045: NN=mperm(N,Is1,Js1);
2046: for(K=S[0];K<Is1;K++){
2047: for(L=S[1];L<Js1;L++)
2048: NN[K][L]=" ";
2049: }
2050: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2051: }
2052: }
2053: for(F=0,J=I;J<S[0];J++){
2054: if((P=N[J][I0])==0) continue;
2055: F++;
2056: N[J][I0]=0;
2057: for(K=I;K<L;K++)
2058: N[J][K]=red(N[J][K]-muldo(P,N[I0][K],XX));
2059:
2060: }
2061: if(F){
2062: if(Tr){
2063: Out=cons(["Li\\ -\\!=\\ \\circ\\times L",I,"\\quad(i>",I,")"],Out);
2064: NN=mperm(N,Is1,Js1);
2065: for(K=S[0];K<Is1;K++){
2066: for(L=S[1];L<Js1;L++)
2067: NN[K][L]=" ";
2068: }
2069: Out=cons(["\\to",mperm(NN,Is,Js)],Out);
2070: }
2071: }
2072: for(F=0,J=I;J<S[1];J++){
2073: if((P=N[I0][J])==0) continue;
2074: F++;
2075: N[I0][J]=0;
2076: for(K=I;K<L;K++)
2077: N[K][J]=red(N[K][J]-muldo(N[K][I0],P,XX));
2078: }
2079: if(F&&Tr) Out=cons(["Cj\\ -\\!=\\ C",I,"\\times\\circ\\quad(j>",I,")"],Out);
2080: else continue;
2081: }else if(C==2){
2082: C=mat(N[I0],N[R[1]+I0]);C=muldo(R[2],C,XX);
2083: for(J=0;J<L;J++){
2084: N[I0][J]=C[0][J];N[R[1]+I0][J]=C[1][J];
2085: }
2086: if(Tr) Out=cons([dupmat(R[2]),"\\begin{pmatrix}L",I,"\\\\L",R[1]+I,
2087: "\\end{pmatrix}"],Out);
2088: }else if(C==3){
2089: C=newmat(L,2);
2090: for(J=0;J<L;J++){
2091: C[J][0]=N[J][I0];C[J][1]=N[J][R[1]+I0];
2092: }
2093: C=muldo(C,R[2],XX);
2094: for(J=0;J<L;J++){
2095: N[J][I0]=C[J][0];N[J][R[1]+I0]=C[J][1];
2096: }
2097: if(Tr) Out=cons(["\\begin{pmatrix}C",I,"&C",R[1]+I,"\\end{pmatrix}",
2098: dupmat(R[2])],Out);
2099: }else if(C==4){
2100: for(J=0;J<L;J++)
2101: N[J][I0]=red(N[J][I0]+N[J][R[1]+I0]);
2102: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",R[1]+I],Out);
2103: }else if(C==5){
2104: for(J=0;J<L;J++)
2105: N[I0+R[1]][J]=red(R[2]*N[I0+R[1]][J]);
2106: if(Tr) Out=cons(["L",I+R[1],"\\leftarrow(", R[2],")\\times L",I+R[1]],
2107: Out);
2108: }else if(C==6){
2109: for(J=0;J<L;J++)
2110: N[J][I0]=N[J][I0]+muldo(N[J][I0+R[1]],R[2],XX);
2111: if(Tr) Out=cons(["C",I,"\\ +\\!=\\ C",I+R[1],"\\times(", R[2],")"],
2112: Out);
2113: }else if(C==7){
2114: mycat(["line",I+1,"\\leftrightarrow",R[1]+I]);
2115: for(J=0;J<L;J++){
2116: C=N[I][J];N[I][J]=N[R[1]+I0][J];N[R[1]+I0][J]=C;
2117: }
2118: if(Tr) Out=cons(["L",I+1,"\\leftrightarrow L",R[1]+I],Out);
2119: }
2120: if(Tr){
2121: NN=mperm(N,Is,Js);
2122: for(K=S[0];K<Is1;K++){
2123: for(L=S[1];L<Js1;L++)
2124: NN[K][L]=" ";
2125: }
2126: Out=cons(["\\to",NN],Out);
2127: }
2128: }
2129: }
2130: if(!Tr){
2131: NN=mperm(N,Is,Js);
2132: Out=[];
2133: }
2134: if(S[0]+S[1]==Is1){
2135: N1=mperm(NN,[0,[S[0]]],[S[1],[S[0]]]);
2136: N2=mperm(NN,[S[0],[S[1]]],[0,[S[1]]]);
2137: N3=mperm(NN,[0,[S[0]]],[0,[S[1]]]);
2138: R1=mdivisor(N1,X|trans=1)[1];
2139: R2=mdivisor(N2,X|trans=1)[1];
2140: if(Tr){
2141: Out=cons(["\\text{As a result,}"],Out);
2142: Out=cons([N3,"=",N1,MM,N2],Out);
2143: if(S[0]==S[1] && N3==mgen(S[0],0,1,0)){
2144: Out=cons(["=",muldo(N2,N1,XX),MM,"."],Out);
2145: }else{
2146: Out=cons([N1,"^{-1}=",R1,","],Out);
2147: Out=cons([N2,"^{-1}=",R2,"."],Out);
2148: }
2149: }else{
2150: Out=cons([N3,"=P",MM,"Q,"],Out);
2151: Out=cons(["P=",N1,"=",R1,"^{-1},"],Out);
2152: Out=cons(["Q=",N2,"=",R2,"^{-1}."],Out);
2153: }
2154: }
2155: Out = ltotex(reverse(Out)|opt=["cr","spts0"],str=1,cr=15,var=Var);
2156: if(S[0]+S[1]==Is1)
2157: Out=str_subst(Out,"\\texttt{ }","");
2158: if(VV>0){
2159: dviout(Out|eq=6);
2160: return NN;
2161: }
2162: return Out;
2163: }else if(type(V)!=5) V=0;
2164:
1.1 takayama 2165: if(type(St=getopt(step))!=1) St=0;
2166: for(FF=": start";;){
1.3 takayama 2167: if(St && V==0){
1.1 takayama 2168: if(Tr){
2169: mycat0([St,FF,"\n"],0);
2170: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2171: }
2172: else mycat0([St,FF,"\n",M,"\n"],0);
2173: }
2174: /* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
1.3 takayama 2175: if(X==0||X==[0,0]){ /* search minimal non-zero element */
1.1 takayama 2176: for(K=F=I=0; I<S0; I++){
2177: for(J=0; J<S1; J++){
2178: if((P=abs(M[I][J]))!=0 && (K>P || K==0)){
2179: K=P; R=[I,J];
2180: }
2181: }
2182: }
2183: R=cons(K-1,[R]);
2184: }
2185: else R=mymindeg(M,XX[1]|opt=1);
2186: if(R[0]<0){ /*zero matrix */
1.3 takayama 2187: if(Tr) return [[],mgen(S0,0,1,0),mgen(S1,0,1,0)];
1.1 takayama 2188: return [];
2189: }
2190: R0=R[1][0];R1=R[1][1];
2191: if(R0!=0){
2192: M=rowx(M,0,R0);
1.3 takayama 2193: if(Tr) GR=rowx(GR,0,R0);
1.1 takayama 2194: }
2195: if(R1!=0){
2196: M=colx(M,0,R1);
1.3 takayama 2197: if(Tr) GC=colx(GC,0,R1);
1.1 takayama 2198: }
2199: if(St>0 && (R0!=0 || R1!=0))
1.3 takayama 2200: if(type(V)==5) V[St]=cons([0,R0,R1],V[St]);
2201: else if(Tr){
1.1 takayama 2202: mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n"],0);
2203: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2204: }else mycat0([St,": (",R0+1,",",R1+1,") -> (1,1)\n",M,"\n"],0);
2205: /* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
2206: if(R[0]==0){ /* (1,1) : invertible */
1.3 takayama 2207: if(type(V)==5) V[St]=cons([1],V[St]);
1.1 takayama 2208: P=M[0][0]; M[0][0]=1;
2209: for(J=0;J<S1;J++){ /* (1,1) -> 1 */
2210: if(J>0) M[0][J]= red(M[0][J]/P);
1.3 takayama 2211: if(Tr) GR[0][J]=red(GR[0][J]/P);
1.1 takayama 2212: }
2213: /* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
2214: if(S0>1 && S1>1) N=newmat(S0-1,S1-1);
2215: else N=0;
2216: for(I=1;I<S0;I++){
2217: P=M[I][0]; M[I][0]=0;
2218: for(J=1;J<S1;J++)
2219: N[I-1][J-1]=M[I][J]=red(M[I][J] - muldo(P,M[0][J],XX));
1.3 takayama 2220: if(Tr){
1.1 takayama 2221: for(J=0;J<S0;J++)
2222: GR[I][J] = red(GR[I][J] -muldo(P,GR[0][J],XX));
2223: }
2224: }
2225: /* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
1.3 takayama 2226: if(Tr){
1.1 takayama 2227: for(J=1;J<S1; J++){
1.3 takayama 2228: for(I=0;I<S1;I++) GC[I][J]=red(GC[I][J]-muldo(GC[I][0],M[0][J],XX));
1.1 takayama 2229: M[0][J]=0;
2230: }
2231: }
1.3 takayama 2232: if(St>0 && V==0){
2233: if(Tr){
1.1 takayama 2234: mycat0([St,": unit\n"],0);
2235: mycat([GR,"\n"]);mycat([M,"\n"]);mycat([GC,"\n"]);
2236: }
2237: else mycat0([St,": unit\n",M,"\n"],0);
2238: }
2239: /* if(Tr==1){ mycat(GR); mycat([GC,"\n\n"]);} */
2240: if(N==0){
1.3 takayama 2241: if(!Tr) return [1];
2242: if(Tr==2){
2243: GR0=mdivisor(GR,X|trans=1)[1];
2244: GC0=mdivisor(GC,X|trans=1)[1];
2245: return [[1],GR,GC,GR0,GC0];
2246: }
1.1 takayama 2247: return [[1],GR,GC];
2248: }
1.3 takayama 2249: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2250: if(!Tr) return cons(1,R);
1.1 takayama 2251: /* mycat(["Ret",R]); */
2252: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2253: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2254: if(S0==S1 && countin(1,1,R[0])==S0-1){
1.3 takayama 2255: /* mycat(GR);mycat(GC); */
2256: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2257: /* mycat(GR);mycat("#");*/
2258: }
2259: if(Tr==2){
2260: GR0=mdivisor(GR,X|trans=1)[1];
2261: GC0=mdivisor(GC,X|trans=1)[1];
2262: return [cons(1,R[0]),GR,GC,GR0,GC0];
1.1 takayama 2263: }
2264: return [cons(1,R[0]),GR,GC];
2265: }
2266: for(I=1;I<S0;I++){
2267: if(M[I][0]!=0){
1.3 takayama 2268: /* Error! when mygcd(A,B,0) with A<=0 or B<=0 */
1.1 takayama 2269: R=mygcd(M[I][0],M[0][0],XX); /* R[0]=R[1]*M[I][0]+R[2]*M[0][0] */
2270: M[0][0]=R[0]; M[I][0]=0; /* 0=R[3]*M[I][0]+R[4]*M[0][0] */
2271: for(J=1;J<S1;J++){
2272: T=red(muldo(R[1],M[I][J],XX)+muldo(R[2],M[0][J],XX));
2273: M[I][J]=red(muldo(R[3],M[I][J],XX)+muldo(R[4],M[0][J],XX));
2274: M[0][J]=T;
2275: }
1.3 takayama 2276: if(Tr){
1.1 takayama 2277: for(J=0;J<S0;J++){
2278: T=red(muldo(R[1],GR[I][J],XX)+muldo(R[2],GR[0][J],XX));
2279: GR[I][J]=red(muldo(R[3],GR[I][J],XX)+muldo(R[4],GR[0][J],XX));
2280: GR[0][J]=T;
2281: }
2282: }
1.3 takayama 2283: if(St && V==0){
1.1 takayama 2284: mycat([" [",R[2],R[1],"]*"]);
2285: mycat([" [",R[4],R[3],"]"]);
2286: }
1.3 takayama 2287: if(type(V)==5) V[St]=cons([2,I,mat([R[2],R[1]],[R[4],R[3]])],V[St]);
2288: FF=": line 1 & "+rtostr(I+1); I=S0;
1.1 takayama 2289: }
2290: }
2291: if(I>S0) continue;
2292: for(J=1;J<S1;J++){
2293: if(M[0][J]!=0){
2294: R=mygcd(M[0][J],M[0][0],XX|rev=1); /* R[0]=M[0][J]*R[1]+M[0][0]*R[2] */
2295: M[0][0]=R[0]; M[0][J]=0; /* 0=M[0][J]*R[3]+M[0][0]*R[4] */
2296: for(I=1;I<S0;I++){
2297: T=red(muldo(M[I][J],R[1],XX)+muldo(M[I][0],R[2],XX));
2298: M[I][J]=red(muldo(M[I][J],R[3],XX)+muldo(M[I][0],R[4],XX));
2299: M[I][0]=T;
2300: }
1.3 takayama 2301: if(Tr){
1.1 takayama 2302: for(I=0;I<S1;I++){
2303: T=red(muldo(GC[I][J],R[1],XX)+muldo(GC[I][0],R[2],XX));
2304: GC[I][J]=red(muldo(GC[I][J],R[3],XX)+muldo(GC[I][0],R[4],XX));
2305: GC[I][0]=T;
2306: }
2307: }
1.3 takayama 2308: if(type(V)==5) V[St]=cons([3,J,mat([R[2],R[4]],[R[1],R[3]])],V[St]);
1.1 takayama 2309: FF=": column 1 & "+rtostr(J+1);J=S1;
1.3 takayama 2310: if(St && V==0){
1.1 takayama 2311: mycat([" *[",R[2],R[4],"]"]);
2312: mycat([" [",R[1],R[3],"]"]);
2313: }
2314: }
2315: }
2316: if(J>S1) continue;
2317: if(S0==1 || S1==1){
2318: P=M[0][0];
2319: if(X==0){
1.3 takayama 2320: if(P<0){
2321: P=-P;
2322: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
2323: if(type(V)==5) V[St]=cons([5,0,-1],V[St]);
2324: }
1.1 takayama 2325: }else{
2326: P=nm(P);
1.3 takayama 2327: if((R=fctr(P)[0][0])!=1){
2328: P/=R;
2329: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=R;
2330: if(type(V)==5) V[St]=cons([5,0,1/R],V[St]);
2331: }
2332: }
2333: if(!Tr) return [P];
2334: if(Tr==2){
2335: GR0=mdivisor(GR,X|trans=1)[1];
2336: GC0=mdivisor(GC,X|trans=1)[1];
2337: return [[P],GR,GC,GR0,GC0];
1.1 takayama 2338: }
2339: return [[P],GR,GC];
2340: }
1.3 takayama 2341: if(XX==0 || (type(XX)==4 && XX[0]==0)){ /* commutative case */
1.1 takayama 2342: P=M[0][0];
2343: for(I=1; I<S0; I++){
2344: for(J=1; J<S1; J++)
2345: if(divdo(M[I][J],P,XX)[1]!=0) break;
2346: if(J<S1){
1.3 takayama 2347: if(type(V)==5) V[St]=cons([4,J],V[St]);
1.1 takayama 2348: FF=": column 1 += col"+rtostr(J+1);
2349: for(I=1;I<S0;I++) M[I][0]=M[I][J];
1.3 takayama 2350: if(Tr) for(I=0;I<S1;I++) GC[I][0]=red(GC[I][0]+GC[I][J]);
1.1 takayama 2351: break;
2352: }
2353: }
2354: if(J<S1) continue;
2355: N=newmat(S0-1,S1-1);
2356: for(I=1;I<S0;I++)
2357: for(J=1;J<S1;J++) N[I-1][J-1]=red(M[I][J]/P);
2358: if(X==0){
2359: if(P<0) P=-P;
1.3 takayama 2360: if(Tr) for(J=0;J<S0;J++) GR[0][J]=-GR[0][J];
1.1 takayama 2361: }else{
2362: P=M[0][0];
2363: P=nm(P);
2364: P/=fctr(P)[0][0];
1.3 takayama 2365: if(Tr) for(J=0;J<S0;J++) GR[0][J]/=fctr(P)[0][0];
1.1 takayama 2366: }
1.3 takayama 2367: R=mdivisor(N,XX|dviout=V,trans=Tr0,step=(St>0)?St+1:St);
2368: RT=(Tr)?R[0]:R;
1.1 takayama 2369: for(RR=[],L=reverse(RT);L!=[];L=cdr(L))
2370: RR=cons(red(P*car(L)),RR);
2371: RR=cons(P,RR);
1.3 takayama 2372: if(!Tr) return RR;
1.1 takayama 2373: GR=muldo(newbmat(2,2,[[1],[0,R[1]]]),GR,XX);
2374: GC=muldo(GC,newbmat(2,2,[[1],[0,R[2]]]),XX);
2375: if(S0==S1 && countin(1,1,RR)==S0){
1.3 takayama 2376: GR=muldo(GC,GR,XX); GC=mgen(S0,0,1,0);
2377: }
2378: if(Tr==2){
2379: GR0=mdivisor(GR,X|trans=1)[1];
2380: GC0=mdivisor(GC,X|trans=1)[1];
2381: return [RR,GR,GC,GR0,GC0];
1.1 takayama 2382: }
2383: return [RR,GR,GC];
2384: } /* End of commutative case */
2385: for(I=1; I<S0; I++){
2386: for(J=1; J<S1; J++){
2387: if(M[I][J] != 0){
2388: for(T=1;I<S0;T*=XX[0]){
2389: R=divdo(muldo(M[I][J],T,XX),M[0][0],XX);
2390: if(R[1]!=0){
1.3 takayama 2391: if(type(V)==5) V[St]=cons([6,J,T],V[St]);
1.1 takayama 2392: FF=": column 1 += col"+rtostr((J+1)*T);
2393: if(I>1){
2394: M=rowx(M,1,I);
1.3 takayama 2395: if(Tr) GR=rowx(GR,1,I);
2396: if(type(V)==5) V[St]=cons([7,I],V[St]);
1.1 takayama 2397: FF+=", line 2<->"+rtostr(I+1);
2398: }
2399: for(I=1;I<S0;I++) M[I][0]=muldo(M[I][J],T,XX);
1.3 takayama 2400: if(Tr)
1.1 takayama 2401: for(I=1;I<S1;I++) GC[I][0]=red(GC[I][0]+muldo(GC[I][J],T,XX));
2402: I=S0+1; J=S1;
2403: break;
2404: }
2405: }
2406: }
2407: }
2408: if(I>S0) break;
2409: }
2410: if(I==S0) return []; /* zero matrix : never happen */
2411: }
2412: }
2413:
2414: def mdsimplify(L)
2415: {
2416: T=getopt(type);
2417: SS=0;
2418: if(type(L)==6){
2419: L=[L]; SS=1;
2420: }
2421: if(type(L)==5){
2422: SS=2;
2423: L = vtol(L);
2424: }
2425: M=car(L);
2426: S=size(M)[0];
2427: DD=newvect(S);
2428: for(I=0; I<S; I++){
2429: LN=RN=[];
2430: LD=RD=1;
2431: for(LL=L; LL!=[]; LL=cdr(LL)){
2432: M = car(LL);
2433: for(J=0; J<S; J++){
2434: if(J==I) continue;
2435: if((MM=M[I][J]) != 0){
2436: LN = cons(nm(MM),LN);
2437: if(type(MM)==3 && tdiv(LD,P=dn(MM))==0)
2438: LD=tdiv(LD*P,gcd(LD,P));
2439: }
2440: if((MM=M[J][I]) != 0){
2441: RN = cons(nm(MM),RN);
2442: if(type(MM)==3 && tdiv(RD,P=dn(MM))==0)
2443: RD=tdiv(RD*P,gcd(RD,P));
2444: }
2445: }
2446: }
2447: if(T==1 || T==3) LQ=RD;
2448: else{
2449: P=lpgcd(LN);
2450: LQ=gcd(P,RD);
2451: if(P!=0) LQ *= nm(fctr(P)[0][0]);
2452: }
2453: if(T==1 || T==2) RQ=LD;
2454: else{
2455: P=lpgcd(RN);
2456: RQ=gcd(P,LD);
2457: if(P!=0) RQ *= nm(fctr(P)[0][0]);
2458: }
2459: if((P=gcdz(LQ,RQ))!=1){
2460: LQ = red(LQ/P); RQ=red(RQ/P);
2461: }
2462: DD[I]=red(LQ/RQ);
2463: if(LQ!=1 || RQ!=1){
2464: for(LA=[],LL=L; LL!=[]; LL=cdr(LL)){
2465: M = car(LL);
2466: for(J=0; J<S; J++){
2467: if(I!=J){
2468: if(LQ!=1){
2469: M[I][J] = red(M[I][J]/LQ);
2470: M[J][I] = red(M[J][I]*LQ);
2471: }
2472: if(RQ!=1){
2473: M[J][I] = red(M[J][I]/RQ);
2474: M[I][J] = red(M[I][J]*RQ);
2475: }
2476: }
2477: }
2478: }
2479: }
2480: }
2481: if(SS==2) L=ltov(L);
2482: if(SS==1) L=L[0];
2483: if(getopt(show)==1) L=[L,DD];
2484: return L;
2485: }
2486:
2487: def m2mc(M,X)
2488: {
2489: if(type(M)<2){
2490: mycat([
2491: "m2mc(m,t) or m2mc(m,[t,s])\t Calculation of Pfaff system of two variables\n",
2492: " m : list of 5 residue mat. or GRS/spc for rigid 4 singular points\n",
2493: " t : [a0,ay,a1,c], swap, GRS, GRSC, sp, irreducible, pair, pairs, Pfaff, All\n",
2494: " s : TeX, dviout, GRSC\n",
2495: " option : swap, small, simplify, operator, int\n",
2496: " Ex: m2mc(\"21,21,21,21\",\"All\")\n"
2497: ]);
2498: return 0;
2499: }
2500: if(type(M)==7) M=s2sp(M);
2501: if(type(X)==7)
2502: X=[X];
2503: Simp=getopt(simplify);
2504: if(Simp!=0 && type(Simp)!=1) Simp=2;
2505: Small=(getopt(small)==1)?1:0;
2506: if(type(M[0])==4){
2507: if(type(M[0][0])==1){ /* spectral type */
2508: XX=getopt(dep);
2509: if(type(XX)!=4 || type(XX[0])>1) XX=[1,length(M[0])];
2510: M=sp2grs(M,[d,a,b,c],[XX[0],XX[1],-2]|mat=1);
2511: if(XX[0]>1 && XX[1]<2) XX=[XX[0],2];
2512: if(getopt(int)!=0){
2513: T=M[XX[0]-1][XX[1]-1][1];
2514: for(V=vars(T);V!=[];V=cdr(V)){
2515: F=coef(T,1,car(V));
2516: if(type(F)==1 && dn(F)>1)
2517: M = subst(M,car(V),dn(F)*car(V));
2518: }
2519: }
2520: V=vars(M);
2521: if(findin(d1,V)>=0 && findin(d2,V)<0 && findin(d3,V)<0)
2522: M=subst(M,d1,d);
2523: }
2524: RC=chkspt(M|mat=1);
2525: if(RC[2] != 2 || RC[3] != 0){ /* rigidity idx and Fuchs cond */
2526: erno(0);return 0;
2527: }
2528: R=getbygrs(M,1|mat=1);
2529: Z=newmat(1,1,[[0]]);
2530: N=[Z,Z,Z,Z,Z];
2531: for(RR=R; RR!=[]; RR=cdr(RR)){
2532: RT=car(RR)[0];
2533: if(type(RT)==4){
2534: if(RT[0]!=0) N=m2mc(N,RT[0]|simplify=Simp);
2535: N=m2mc(N,[RT[1],RT[2],RT[3]]|simplify=Simp);
2536: }
2537: }
2538: if(type(X)==4 && type(X[0])==7)
2539: return m2mc(N,X|keep=Keep,small=Small);
2540: return N;
2541: }
2542: if(type(X)==4 && type(X[0])==7){
2543: Keep=(getopt(keep)==1)?1:0;
2544: if(X[0]=="All"){
2545: dviout("Riemann scheme"|keep=1);
2546: m2mc(M,[(findin("GRSC",X)>=0)?"GRSC":"GRS","dviout"]|keep=1);
2547: dviout("Spectral types : "|keep=1);
2548: m2mc(M,["sp","dviout"]|keep=1);
2549: dviout("\\\\\nBy the decompositions"|keep=1);
2550: R=m2mc(M,["pairs","dviout"]|keep=1);
2551: for(R0=R1=[],I=1; R!=[]; I++, R=cdr(R)){
2552: for(S=0,RR=car(R)[1][0];RR!=[]; RR=cdr(RR)) S+=RR[0];
2553: if(S==0) R0=cons(I,R0);
2554: else if(S<0) R1=cons(I,R1);
2555: }
2556: S="irreducibility\\ $"+((length(R0)==0)?"\\Leftrightarrow":"\\Leftarrow")
2557: +"\\ \\emptyset=\\mathbb Z\\cap$";
2558: dviout(S|keep=1);
2559: m2mc(M,["irreducible","dviout"]|keep=1);
2560: if(R0!=[])
2561: dviout(ltotex(reverse(R0))|eq=0,keep=1,
2562: title="The following conditions may not be necessary for the irreducibility.");
2563: if(R1!=[])
2564: dviout(ltotex(reverse(R1))|eq=0,keep=1,title="The following conditions can be omitted.");
2565: if(getopt(operator)!=0){
2566: dviout("The equation in a Pfaff form is"|keep=1);
2567: m2mc(M,["Pfaff","dviout"]|keep=Keep,small=Small);
2568: }
2569: else if(Keep!=1) dviout(" ");
2570: return M;
2571: }
2572: Show=0;
2573: if(length(X)>1){
2574: if(X[1]=="dviout") Show=2;
2575: if(X[1]=="TeX") Show=1;
2576: }
2577: if(X[0]=="GRS"||X[0]=="GRSC"||X[0]=="sp"){
2578: Y=radd(-M[0],-M[1]-M[2]);
2579: if(X[0]!="GRSC"){
2580: 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);
2581: if(X[0]=="sp"){
2582: L=chkspt(L|opt="sp");
2583: V=[L[1],L[0],L[2],L[5]]; W=[L[1],L[3],L[4],L[6]];
2584: if(Show==2) dviout(s2sp(V)+" : "+s2sp(W)|keep=Keep);
2585: return [V,W];
2586: }
2587: S="x=0&x=y&x=1&y=0&y=1&x=\\infty&y=\\infty&x=y=\\infty\\\\\n";
2588: }else{
2589: 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]),
2590: radd(M[0],M[1]+M[3]),radd(M[1],M[2]+M[4])]|mult=1);
2591: 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";
2592: }
2593: T=ltotex(L|opt="GRS",pre=S,small=Small);
2594: if(Show==2) dviout(T|eq=0,keep=Keep);
2595: if(Show==1) L=T;
2596: return L;
2597: }
2598: if(X[0]=="Pfaff"){
2599: S=ltotex(M|opt=["Pfaff",u,x,x-y,x-1,y,y-1],small=Small);
2600: if(Show==2) dviout(S|eq=0,keep=Keep);
2601: return S;
2602: }
2603: if(X[0]=="irreducible"){
2604: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
2605: S=getbygrs(L,10|mat=1);
2606: if(Show==2) dviout(ltotex(S)|eq=0,keep=Keep);
2607: return S;
2608: }
2609: if(X[0]=="pairs"||X[0]=="pair"){
2610: L=meigen([M[0],M[1],M[2],radd(-M[0],-M[1]-M[2])]|mult=1);
2611: S=chkspt(L|opt=0);
2612: V=(Show==2)?1:0;
2613: S=sproot(L,X[0]|dviout=V,keep=Keep);
2614: return S;
2615: }
2616: if(X[0]=="swap"){
2617: Swap=getopt(swap);
2618: if(type(Swap)<1 || Swap==1)
2619: return newvect(5,[M[3],M[1],M[4],M[0],M[2]]);
2620: if(Swap==2)
2621: return newvect(5,[radd(M[0],M[1]+M[3]),M[4],M[2],radd(-M[1],-M[3]-M[4]),M[1]]);
2622: if(type(Swap)==4 && length(Swap)==3){
2623: MX=radd(-M[0],-M[1]-M[2]); MY=radd(-M[3],-M[1]-M[4]);
2624: if(Swap[0]==1){
2625: MX0=M[2];MY0=M[4];
2626: }
2627: else if(Swap[0]==2){
2628: MX0=MX;MY0=MY;
2629: }else{
2630: MX0=M[0];MY0=M[3];
2631: }
2632: if(Swap[1]==1){
2633: MX1=M[2];MY1=M[4];
2634: }
2635: else if(Swap[1]==2){
2636: MX1=MX;MY1=MY;
2637: }else{
2638: MX1=M[0];MY1=M[3];
2639: }
2640: return newvect(5,MX0,M[1],MX1,MY0,MY1);
2641: }
2642: }
2643: return 0;
2644: }
2645: if(getopt(swap)==1)
2646: return m2mc(m2mc(m2mc(M,"swap"),X),"swap");
2647: N=newvect(5);
2648: for(I=0;I<5;I++)
2649: N[I]=M[I];
2650: S=size(N[0])[0];
2651: if(type(X)==4){
2652: for(I=0;I<3;I++){
2653: if(X[I] != 0)
2654: N[I] = radd(N[I],X[I]);
2655: }
2656: if(length(X)==3) return N;
2657: X=X[3];
2658: }
2659: MZ = newmat(S,S);
2660: ME = mgen(S,0,[X],0);
2661: MM = newvect(5);
2662: MM[0] = newbmat(3,3, [[N[0]+ME,N[1],N[2]], [MZ], [MZ]]);
2663: MM[1] = newbmat(3,3, [[MZ], [N[0],N[1]+ME,N[2]], [MZ]]);
2664: MM[2] = newbmat(3,3, [[MZ], [MZ], [N[0],N[1],N[2]+ME]]);
2665: MM[3] = newbmat(3,3, [[N[3]+N[1],-N[1]], [-N[0],radd(N[0],N[3])], [MZ,MZ,N[3]]]);
2666: MM[4] = newbmat(3,3, [[N[4]], [MZ,N[4]+N[2],-N[2]], [MZ,-N[1],radd(N[4],N[1])]]);
2667: M0 = newbmat(3,3, [[N[0]], [MZ,N[1]], [MZ,MZ,N[2]]]);
2668: M1 = radd(MM[0],MM[1]+MM[2]);
2669: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
2670: if(length(KE) == 0) return MM;
2671: KK = mtoupper(lv2m(KE),0);
2672: for(I=0;I<5;I++)
2673: MM[I] = mmod(MM[I],KK);
2674: if(Simp!=0) MM = mdsimplify(MM|type=Simp);
2675: return MM;
2676: }
2677:
2678: /*
2679: def mmc(M,X)
2680: {
2681: if(type(M)==4)
2682: M=ltov(M);
2683: L = length(M);
2684: S = size(M[0])[0];
2685: SS = L*S;
2686: MM = newvect(L);
2687: M0 = newmat(SS,SS);
2688: if(type(X)<4){
2689: Y = newvect(L+1);
2690: Y[L]=X;
2691: }else Y = X;
2692: for(KI = 0; KI < L; KI++){
2693: MM[KI] = newmat(SS,SS);
2694: II=KI*S;
2695: for(I=0; I<S; I++){
2696: for(KJ=0; KJ<L; KJ++){
2697: JJ=KJ*S;
2698: for(J=0; J<S; J++){
2699: MM[KI][II+I][JJ+J]=M[KJ][I][J]+((I==J)?Y[KJ]:0);
2700: if(KI==KJ){
2701: M0[II+I][JJ+J]=M[KJ][I][J]+((I==J)?Y[KJ]:0);
2702: if(I==J)
2703: MM[KI][II+I][JJ+J]+=Y[L];
2704: }
2705: }
2706: }
2707: }
2708: }
2709: M1 = newmat(SS,SS);
2710: for(I=0; I<L; I++)
2711: M1 += MM[I];
2712: KE = append(mykernel(M0|opt=1),mykernel(M1|opt=1));
2713: if(length(KE)==0) return MM;
2714: KK = toupper(lv2m(KE,0));
2715: for(KI = 0; KI < L; KI++)
2716: MM[KI] = mmod(MM[KI],KK);
2717: return MM;
2718: }
2719: */
2720:
2721: def easierpol(P,X)
2722: {
2723: if(type(X) == 4){
2724: for( Y = [] ; X != []; X = cdr(X) )
2725: Y = cons([0,car(X)], Y);
2726: }else
2727: Y = [0,X];
2728: return rede(P,Y);
2729: }
2730:
2731: def mykernel(M)
2732: {
2733: if(getopt(opt) == 1)
2734: M = mtranspose(M);
2735: S = size(M);
2736: R = [];
2737: MM = mtoupper(M,-1);
2738: for(I = S[0]-1; I >= 0; I--){
2739: for(J = S[1]-1; J >= 0; J--){
2740: if(MM[I][J] != 0)
2741: return R;
2742: }
2743: P = easierpol(MM[I][S[1]],zz);
2744: RR = newvect(S[0]);
2745: for(J = 0; J < S[0]; J++)
2746: RR[J] = mycoef(P,J,zz);
2747: R = cons(RR,R);
2748: }
2749: return R;
2750: }
2751:
2752: def myimage(M)
2753: {
2754: if(getopt(opt) == 1)
2755: M = mtranspose(M);
2756: S = size(M);
2757: V = [];
2758: M0 = newvect(S[1]);
2759: M = mtoupper(M,0|opt=1);
2760: for(I = S[0]-1; I >= 0; I--)
2761: if(M0 != M[I])
2762: V = cons(vtozv(M[I])[0], V);
2763: return V;
2764: }
2765:
2766: def mymod(V,L)
2767: {
2768: Opt = getopt(opt);
2769: S = length(V);
2770: VP = newvect(S);
2771: if(type(L)==6)
2772: L=m2lv(L);
2773: CT = length(L);
2774: for(LT = L; LT != []; LT = cdr(LT)){
2775: for(VT = car(LT), I = 0; I < S; I++)
2776: if(VT[I] != 0) break;
2777: if(I >= S){
2778: CT--;
2779: continue;
2780: }
2781: VP[I] = 1;
2782: MI = -red(V[I]/VT[I]);
2783: if(MI != 0)
2784: V = radd(V,rmul(MI,VT));
2785: }
2786: if(Opt==1){
2787: for(I = 0; I < S; I++)
2788: if(V[I] != 0)
2789: return 1;
2790: return 0;
2791: }
2792: if(Opt==2){
2793: W=newvect(S-CT);
2794: for(CC = I = 0; I < S; I++){
2795: if(VP[I]==0) W[CC++] =V[I];
2796: }
2797: return W;
2798: }
2799: return V;
2800: }
2801:
2802: def mmod(M,L)
2803: {
2804: S=size(M)[1];
2805: MM=mtranspose(M);
2806: VP = newvect(S);
2807: if(type(L)==6)
2808: L=m2lv(L);
2809: for(CT = 0, LT = L; LT != []; LT = cdr(LT)){
2810: for(VT = car(LT), I = 0; I < S; I++){
2811: if(VT[I] != 0){
2812: VP[I] = 1;
2813: break;
2814: }
2815: }
2816: }
2817: if(getopt(opt)==1)
2818: NE=1;
2819: for(D=I=0; I<S; I++){
2820: if(NE != 1 && VP[I] == 1) continue;
2821: T = mymod(MM[I],L|opt=2);
2822: if(D==0){
2823: K=length(T);
2824: MN=newmat((NE==1)?S:K,K);
2825: }
2826: for(J=0;J<K;J++)
2827: MN[J][D]=T[J];
2828: D++;
2829: }
2830: return MN;
2831: }
2832:
1.3 takayama 2833: def llsize(V)
2834: {
2835: for(I=J=0;V!=[];V=cdr(V),I++)
2836: if(length(car(V))>J) J=length(car(V));
2837: return [I,J];
2838: }
2839:
1.1 takayama 2840: def llbase(VV,L)
2841: {
2842: S = length(VV);
2843: V = dupmat(VV);
2844: if(type(V) == 4)
2845: V = ltov(V);
2846: T = length(L);
2847: for(I = 0; I < S; I++)
2848: V[I] = nm(red(V[I]));
2849: LV = 0;
2850: for(J = 0; J < T; J++){
2851: X = var(L[J]); N = deg(L[J],X);
2852: for(I = LV; I < S; I++){
2853: if((C2=coef(V[I],N,X)) != 0){
2854: if(I > LV){
2855: Temp = V[I];
2856: V[I] = V[LV];
2857: V[LV] = Temp;
2858: }
2859: for(I = 0; I < S; I++){
2860: if(I == LV || (C1 = coef(V[I],N,X)) == 0)
2861: continue;
2862: Gcd = gcd(C1,C2);
2863: V[I] = V[I]*tdiv(C2,Gcd)-V[LV]*tdiv(C1,Gcd);
2864: }
2865: LV++;
2866: }
2867: }
2868: }
1.4 ! takayama 2869: return V;
! 2870: /* return map(ptozp,V); */
1.1 takayama 2871: }
2872:
2873: def lsort(L1,L2,T)
2874: {
2875: if(type(T)==7)
2876: T = findin(T,["cup","setminus","cap","reduce"]);
2877: if(L2 == []){
2878: if(T == 2) return L2;
2879: if(T == 3) return [L1,L2];
2880: L1 = ltov(L1); qsort(L1);
2881: if(T != 1)
2882: return vtol(L1);
2883: L3 = [];
2884: for(I = length(L1)-1; I >= 0; I--){
2885: if(I > 0 && L1[I] == L1[I-1])
2886: continue;
2887: L3 = cons(L1[I], L3);
2888: }
2889: return L3;
2890: }
2891: if(T == 1 || T == 2){
2892: L1 = lsort(L1,[],1);
2893: L2 = lsort(L2,[],1);
2894: L3 = [];
2895: if(T == 1){
2896: while(L1 != []){
2897: if(L2 == [] || car(L1) < car(L2)){
2898: L3 = cons(car(L1), L3);
2899: L1 = cdr(L1);
2900: continue;
2901: }
2902: if(car(L1) > car(L2)){
2903: L2 = cdr(L2);
2904: continue;
2905: }
2906: L1 = cdr(L1); L2 = cdr(L2);
2907: }
2908: return reverse(L3);
2909: }
2910: if(T==2){
2911: while(L1 != [] && L2 != []){
2912: if(car(L1) != car(L2)){
2913: if(car(L1) <= car(L2))
2914: L1 = cdr(L1);
2915: else L2 = cdr(L2);
2916: continue;
2917: }
2918: while(car(L1) == car(L2))
2919: L1 = cdr(L1);
2920: L3 = cons(car(L2), L3);
2921: }
2922: return reverse(L3);
2923: }
2924: }
2925: if(T==3){
2926: L1 = qsort(L1); L2 = qsort(L2);
2927: L3 = L4 = [];
2928: while(L1 != [] && L2 != []){
2929: if(car(L1) == car(L2)){
2930: L1 = cdr(L1); L2 = cdr(L2);
2931: }else if(car(L1) < car(L2)){
2932: L3 = cons(car(L1),L3);
2933: L1 = cdr(L1);
2934: }else{
2935: L4 = cons(car(L2), L4);
2936: L2 = cdr(L2);
2937: }
2938: }
2939: L4 = append(reverse(L4),L2);
2940: L3 = append(reverse(L3),L1);
2941: return [L3,L4];
2942: }
2943: L1 = append(L1,L2);
2944: return lsort(L1,[],1);
2945: }
2946:
1.3 takayama 2947: def lmax(L)
2948: {
2949: if(type(L)==4){
2950: V=car(L);
2951: while((L=cdr(L))!=[])
2952: if(V < car(L)) V=car(L);
2953: return V;
2954: }else if(type(L)==5||type(L)==6)
2955: return lmax(m2l(L));
2956: return [];
2957: }
2958:
2959: def lmin(L)
2960: {
2961: if(type(L)==4){
2962: V=car(L);
2963: while((L=cdr(L))!=[])
2964: if(V > car(L)) V=car(L);
2965: return V;
2966: }else if(type(L)==5||type(L)==6)
2967: return lmin(m2l(L));
2968: return [];
2969: }
2970:
1.4 ! takayama 2971: def lgcd(L)
! 2972: {
! 2973: if(type(L)==4){
! 2974: F=getopt(poly);
! 2975: V=car(L);
! 2976: while((L=cdr(L))!=[]&&V!=1){
! 2977: if(V!=0){
! 2978: V=(F==1)?V=gcd(V,car(L)):igcd(V,car(L));
! 2979: }
! 2980: }
! 2981: return V;
! 2982: }else if(type(L)==5||type(L)==6)
! 2983: return lgcd(m2l(L)|option_list=getopt());
! 2984: return [];
! 2985: }
! 2986:
! 2987:
! 2988: def ldev(L,S)
! 2989: {
! 2990: M=abs(lmax(L));N=abs(lmin(L));
! 2991: if(M<N) M=N;
! 2992: for(C=0,LT=L;;C++){
! 2993: LT=ladd(LT,S,1);
! 2994: MT=abs(lmax(LT));NT=abs(lmin(LT));
! 2995: if(MT<NT) MT=NT;
! 2996: if(MT>=M) break;
! 2997: M=MT;
! 2998: }
! 2999: if(!C){
! 3000: for(C=0,LT=L;;C--){
! 3001: LT=ladd(LT,S,-1);
! 3002: MT=abs(lmax(LT));NT=abs(lmin(LT));
! 3003: if(MT<NT) MT=NT;
! 3004: if(MT>=M) break;
! 3005: M=MT;
! 3006: }
! 3007: }
! 3008: return [C,ladd(L,S,C)];
! 3009: }
! 3010:
1.1 takayama 3011: def lchange(L,P,V)
3012: {
1.4 ! takayama 3013: if(getopt(flat)==1&&type(P)==4){
! 3014: for(L=ltov(L);P!=[];P=cdr(P),V=cdr(V))
! 3015: L[car(P)]=car(V);
! 3016: return vtol(L);
! 3017: }
1.1 takayama 3018: if(type(P)==4){
3019: IP=car(P); P=cdr(P);
3020: }else{
3021: IP=P; P=[];
3022: }
3023: for(I=0, LL=[], LT=L; LT!=[]; I++,LT=cdr(LT)){
3024: if(I==IP){
3025: LL=cons((P==[])?V:lchange(car(LT),P,V),LL);
3026: }else
3027: LL=cons(car(LT),LL);
3028: }
3029: return reverse(LL);
3030: }
3031:
3032: def lsol(VV,L)
3033: {
3034: if(type(VV)<4 && type(L)==2)
3035: return red(L-VV/mycoef(VV,1,L));
3036: S = length(VV);
3037: T = length(L);
3038: V = llbase(VV,L);
3039: for(J = K = 0; J < T; J++){
3040: X = var(L[J]); N = deg(L[J],X);
3041: for(I = K; I < S; I++){
3042: if((C=mycoef(V[I], N, X)) != 0){
3043: V[I] = [L[J],red(X^N-V[I]/C)];
3044: K++;
3045: break;
3046: }
3047: }
3048: }
3049: return V;
3050: }
3051:
3052: def lnsol(VV,L)
3053: {
3054: LL=lsort(vars(VV),L,1);
3055: VV=ptol(VV,LL|opt=0);
3056: return lsol(VV,L);
3057: }
3058:
3059:
1.4 ! takayama 3060: def ladd(X,Y,M)
1.3 takayama 3061: {
3062: if(type(X)==4) X=ltov(X);
3063: if(type(Y)==4) Y=ltov(Y);
1.4 ! takayama 3064: return vtol(X+M*Y);
1.3 takayama 3065: }
3066:
3067: def mrot(X)
3068: {
3069: if(getopt(deg)==1) X=@pi*X/180;
3070: X=deval(X);
3071: return mat([dcos(X),dsin(X)],[-dsin(X),dcos(X)]);
3072: }
3073:
1.1 takayama 3074: def m2v(M)
3075: {
3076: S = size(M);
3077: V = newvect(S[0]*S[1]);
3078: for(I = C = 0; I < S[0]; I++){
3079: MI = M[I];
3080: for(J = 0; J < S[1]; J++)
3081: V[C++] = MI[J];
3082: }
3083: return V;
3084: }
3085:
3086: def lv2m(L)
3087: {
3088: if(type(L)==5) L=vtol(L);
3089: II=length(L);
3090: for(J=1,T=L; T!=[]; T=cdr(T))
1.3 takayama 3091: if(length(car(T))>JJ) JJ=length(car(T));
1.1 takayama 3092: M = newmat(II,JJ);
1.3 takayama 3093: N = getopt(null);
1.1 takayama 3094: if(type(N)<0) N=0;
3095: for(I=0; I<II; I++){
3096: V=car(L); L=cdr(L);
1.3 takayama 3097: for(J=length(V);--J>=0;)
1.1 takayama 3098: M[I][J] = V[J];
3099: if(N!=0){
3100: for(J=length(V); J<JJ; J++)
3101: M[I][J]=N;
3102: }
3103: }
3104: return M;
3105: }
3106:
3107: def m2lv(M)
3108: {
3109: I=size(M)[0];
3110: for(N=[],I=size(M)[0];I-->0;)
3111: N=cons(M[I],N);
3112: return N;
3113: }
3114:
3115: def s2m(S)
3116: {
1.4 ! takayama 3117: if(type(S)==6) return S;
1.1 takayama 3118: if(type(S)==7){
3119: if(str_chr(S,0,"[")!=0) S=s2sp(S);
3120: else if(str_chr(S,0,",")>=0) return eval_str(S);
3121: else{
3122: for(L=LL=[],I=0; ; ){
3123: II=str_chr(S,I+2,"]");
3124: if(II<0) return 0;
3125: J=str_chr(S,I+2," ");
3126: while(str_chr(S,J+1," ")==J+1) J++;
3127: if(J>II-2 || J<0) J=II;
3128: V=eval_str(sub_str(S,I+1,J-1));
3129: L=cons(V,L);
3130: I=J;
3131: if(J==II){
3132: LL=cons(ltov(reverse(L)),LL);
3133: L=[];
3134: if((I=str_chr(S,II+1,"["))<0)
3135: return lv2m(reverse(LL));
3136: }
3137: }
3138: }
3139: }
3140: if(type(S)==5) S=vtol(S);
3141: if(type(S[0])==5) return lv2m(S);
3142: I=length(S);
3143: for(J=1,T=S; T!=[]; T=cdr(T))
3144: if(length(car(T))>J) J=length(car(T));
3145: return newmat(I,J,S);
3146: }
3147:
1.3 takayama 3148: def c2m(L,V)
3149: {
3150: if(type(Pow=getopt(pow))!=1){
3151: if(isvar(V)==1){
3152: for(Pow=0,LT=L;LT!=[];LT=cdr(LT)){
3153: if(mydeg(car(LT),V)>JJ) Pow=mydeg(car(LT),V);
3154: }
3155: JJ=Pow+1;
3156: }else{
3157: Pow=-1;
3158: JJ=length(V);
3159: }
3160: }else JJ=Pow+1;
3161: M=newmat(length(L),JJ);
3162: for(I=0;L!=[];L=cdr(L),I++){
3163: for(J=0;J<JJ;J++){
3164: LT=car(L);
3165: M[I][J]=(Pow>=0)?mycoef(LT,J,V):mycoef(LT,1,V[J]);
3166: }
3167: }
3168: return M;
3169: }
3170:
1.1 takayama 3171: #if 0
3172: def m2diag(M,N)
3173: {
3174: S = size(M);
3175: MM = mtoupper(M,N);
3176: for(I = S[0]-1; I >= 0; I--){
3177: for(J = 0; I < S[1]-N; I++){
3178: if(MM[I][J] != 0){
3179: P = MM[I][J];
3180: for(K = 0; K < I; K++){
3181: Q = -rmul(MM[K][J],1/P);
3182: MM[K][J] = 0;
3183: if(Q != 0){
3184: for(L = J+1; L < S[1]; L++){
3185: if(MM[I][L] != 0)
3186: MM[K][L] = radd(MM[K][L], rmul(MM[I][L],Q));
3187: }
3188: }
3189: }
3190: }
3191: }
3192: }
3193: return MM;
3194: }
3195: #endif
3196:
3197: def myinv(M)
3198: {
3199: S = size(M);
3200: if((T=S[0]) != S[1])
3201: return 0;
3202: MM = mtoupper(M,-T|opt=2);
3203: if(MM[T-1][T-1] != 1) return 0;
3204: return mperm(MM,0,[T,[T]]);
3205: }
3206:
3207: def madj(G,M)
3208: {
3209: H=myinv(G);
3210: if(type(M)==6)
3211: return rmul(rmul(G,M),H);
3212: if(type(M)==4||type(M)==5){
3213: L=length(M);
3214: N=newvect(L);
3215: for(I=0;I<L;I++){
3216: N[I]=rmul(rmul(G,M[I]),H);
3217: }
3218: if(type(N)==4) N=vtol(N);
3219: return N;
3220: }
3221: return -1;
3222: }
3223:
3224: def mpower(M,N)
3225: {
3226: if(type(M)<=3) return (red(M))^N;
3227: S = size(M);
3228: if(S[0] != S[1])
3229: return 0;
3230: if(N == 0) return mgen(S[0],0,[1],0);
3231: if(N < 0)
3232: return(mpower(myinv(M), -N));
3233: R = dupmat(M);
3234: V=1;
3235: for(V=1;;){
3236: if(iand(N,1)){
3237: V=map(red,R*V);
3238: N--;
3239: }
3240: if((N/=2)==0) break;
3241: R=map(red,R*R);
3242: }
3243: return V;
3244: }
3245:
3246: def texlen(S)
3247: {
3248: if(type(S)!=7) return 0;
3249: LF=I=J=0;
3250: LM=str_len(S);
3251: while((I=str_str(S,"\\frac{"|top=J))>=0){
3252: if(I>J) LF+=texlen(str_cut(S,J,I-1));
3253: I+=6;
3254: for(F=L=0,J=I;F<2 && J<LM-1;F++){
3255: for(C=1;C>0 && J<LM;){
3256: if((K0=str_char(S,J,"}"))<0) K0=LM;
3257: if((K1=str_char(S,J,"{"))<0) K1=LM;
3258: if(K0<0 && K1<0){
3259: J = str_len(S)-1;
3260: break;
3261: }
3262: if(K0<K1){
3263: J=K0+1; C--;
3264: }else{
3265: J=K1+1; C++;
3266: }
3267: }
3268: T=str_cut(S,I,J-1);
3269: if(F==0){
3270: I=J=K1+1;C=1;
3271: }else J=K0+1;
3272: if(type(T)==7 && (LL=texlen(T))>L) L=LL;
3273: }
3274: LF+=L;
3275: }
3276: if(J>0) S=str_cut(S,J,str_len(S)-1);
3277: if(S==0) return LF;
3278: S=ltov(strtoascii(S));
3279: L=LL=length(S);
3280: for(I=F=0; I<L; I++){
3281: if(S[I]==92) F=1;
3282: else if(F==1){
3283: if((S[I]>96 && S[I]<123)||(S[I]>64 && S[I]<91)) LL--;
3284: else F=0;
3285: }
3286: if(S[I]<=32||S[I]==123||S[I]==125||S[I]==94||S[I]==38) LL--; /* {}^& */
3287: else if(S[I]==95){
3288: LL--;
3289: if(I+2<L && S[I+2]==94) LL--; /* x_2^3 */
3290: else if(I+6<L && S[I+1]==123 && S[I+4]==125){ /* x_{11}^2 */
3291: if(S[I+5]==94 || (S[I+5]==125 && S[I+6]==94)) LL-- ; /* x_{11}}^2 */
3292: }
3293: }
3294: }
3295: return LL+LF;
3296: }
3297:
3298: def isdif(P)
3299: {
3300: if(type(P)<1 || type(P)>3) return 0;
3301: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
3302: V0=rtostr(car(R));
3303: if(V0>"d" && V0<"e"){
3304: V=sub_str(V0,1,str_len(V0)-1);
3305: if(V>="a" && V<"{") Var=cons([strtov(V),strtov(V0)],Var);
3306: }
3307: }
3308: if(Var==[]) return 0;
3309: for(V=Var; V!=[]; V=cdr(V))
3310: if(ptype(P,car(V)[1])==3) return 0;
3311: return Var;
3312: }
3313:
1.4 ! takayama 3314: def texsp(P)
! 3315: {
! 3316: Q=strtoascii(P);
! 3317: if((J=str_char(Q,0,92))<0 || (C=Q[L=str_len(P)-1])==32||C==41||C==125)
! 3318: return P;
! 3319: for(;;){
! 3320: if((I=str_char(Q,J+1,92))<0) break;
! 3321: J=I;
! 3322: };
! 3323: for(I=J+1;I<L&&isalpha(Q[I]);I++);
! 3324: return(I==L)?P+" ":P;
! 3325: }
! 3326:
1.1 takayama 3327: def fctrtos(P)
3328: {
3329: /* extern TeXLim; */
3330:
3331: if(!chkfun("write_to_tb", "names.rr"))
3332: return 0;
3333:
3334: TeX = getopt(TeX);
3335: if(TeX != 1 && TeX != 2 && TeX != 3)
3336: TeX = 0;
3337: if((Dvi=getopt(dviout)==1) && TeX<2) TeX=3;
3338: if(TeX>0){
3339: Lim=getopt(lim);
3340: if(Lim!=0 && TeX>1 && (type(Lim)!=1||Lim<30)) Lim=TeXLim;
3341: else if(type(Lim)!=1) Lim=0;
3342: CR=(TeX==2)?"\\\\\n":"\\\\\n&";
1.3 takayama 3343: if(TeX==1 || Lim==0) CR="";
1.1 takayama 3344: else if((Pages=getopt(pages))==1) CR="\\allowdisplaybreaks"+CR;
3345: if(!chkfun("print_tex_form", "names.rr"))
3346: return 0;
3347: Small=getopt(small);
3348: }
3349: Dif=getopt(dif);
3350: Var=getopt(var);
3351: if(Lim>0 && type(Var)<2 && TeX!=1) Var=[strtov("0"),""];
3352: Dif=0;
3353: if(Var=="dif"){
3354: Dif=DV=1;
3355: }else if (Var=="dif0") Dif=1;
3356: else if(Var=="dif1") Dif=2;
3357: else if(Var=="dif2") Dif=3;
3358: if(Dif>0){
3359: for(Var=[],R=vars(P);R!=[];R=cdr(R)){
3360: V=rtostr(car(R));
3361: if(V>"d" && V<"e"){
3362: V=sub_str(V,1,str_len(V)-1);
3363: if(V>="a" && V<"{"){
3364: if(TeX>0){
3365: V=my_tex_form(strtov(V));
3366: if(Dif>=1){
3367: if(Dif==1){
3368: if(str_len(V)==1) V="\\partial_"+V;
3369: else V="\\partial_{"+V+"}";
3370: }
3371: Var=cons([car(R),V],Var);
3372: }
3373: else Var=cons([car(R)],Var);
3374: }else Var=cons([car(R)],Var);
3375: }
3376: }
3377: }
3378: if(TeX>0){
3379: if(length(Var)==1){
3380: if(DV==1 && str_len(Var[0][1])==10) Var=[[Var[0][0],"\\partial"]];
3381: }else if(DV==1){
3382: for(V=Var;V!=[];V=cdr(V)){
3383: VV=rtostr(car(V)[0]);
3384: if(VV<"dx0" || VV>= "dx:" || str_len(VV)>4) break;
3385: }
3386: if(V==[]){
3387: for(VT=[],V=Var;V!=[];V=cdr(V)){
3388: VV=str_cut(rtostr(car(V)[0]),2,3);
3389: if(str_len(VV)==1) VT=cons([car(V)[0],"\\partial_"+VV],VT);
3390: else VT=cons([car(V)[0],"\\partial_{"+VV+"}"],VT);
3391: }
3392: Var=reverse(VT);
3393: }
3394: }else
3395: if(Dif==2 && length(Var)>1) Dif=3;
3396: }
3397: if(Dif>0) Dif--;
3398: }
3399: if(type(Var)>1 && Var!=[]){ /* as a polynomial of Var */
3400: Add=getopt(add);
3401: if(type(Add)>0){
3402: if(type(Add)!=7){
3403: Add=my_tex_form(Add);
3404: if(str_char(Add,0,"-")>=0 || str_char(Add,0,"+")>=0) Add="("+Add+")";
3405: }
3406: if(str_char(Add,0,"(")!=0) Add = " "+Add;
3407: }else Add=0;
3408: if(type(Var)!=4) Var=[Var];
3409: if(length(Var)==2 && type(Var[1]) == 7)
3410: Var = [Var];
3411: for(VV=VD=[]; Var!=[];Var=cdr(Var)){
3412: VT=(type(car(Var))==4)?car(Var):[car(Var)];
3413: VT0=var(car(VT));
3414: VV=cons(VT0,VV);
3415: if(length(VT)==1){
3416: VD=cons((TeX>=1)?my_tex_form(VT0):rtostr(VT0),VD);
3417: }else VD=cons(VT[1],VD);
3418: }
3419: VV=reverse(VV);VD=reverse(VD);
3420: Rev=(getopt(rev)==1)?1:0;
3421: Dic=(getopt(dic)==1)?1:0;
3422: TT=terms(P,VV|rev=Rev,dic=Dic);
3423: if(TeX==0){
3424: Pre="("; Post=")";
1.3 takayama 3425: }else{
1.1 takayama 3426: Pre="{"; Post="}";
3427: }
3428: Out = string_to_tb("");
3429: for(L=C=0,Tm=TT;Tm!=[];C++,Tm=cdr(Tm)){
3430: for(I=0,PC=P,T=cdr(car(Tm)),PW="";T!=[];T=cdr(T),I++){
3431: PC=mycoef(PC,D=car(T),VV[I]);
3432: if(PC==0) continue;
3433: PT="";
3434: if(D!=0 && VD[I]!=""){
3435: if(TeX==0 && PW!="") PW+="*";
3436: if(D>1){
3437: if(D>9) PT="^"+Pre+rtostr(D)+Post;
3438: else PT="^"+rtostr(D);
3439: }
3440: if(Dif>0) PW+=(Dif==1)?"d":"\\partial ";
3441: PW+=VD[I]+PT;
3442: }
3443: }
3444: D=car(Tm)[0];
3445: if(Dif>0 && D>0){
3446: Op=(Dif==1)?"\\frac{d":"\\frac{\\partial";
3447: if(D>1) Op+="^"+((D>9)?(Pre+rtostr(D)+Post):rtostr(D));
3448: PW=Op+Add+"}{"+PW+"}";
3449: }else if(Add!=0) PW=PW+Add;
1.3 takayama 3450: if(TeX>=1){
3451: if(type(PC)==1 && ntype(PC)==0 && PC<0)
3452: OC="-"+my_tex_form(-PC);
3453: else OC=fctrtos(PC|TeX=1,br=1);
3454: }else OC=fctrtos(PC|br=1);
1.1 takayama 3455: if(PW!=""){
3456: if(OC == "1") OC = "";
3457: else if(OC == "-1") OC = "-";
3458: }
3459: if(TeX==0 && D!=0 && OC!="" && OC!="-") PW= "*"+PW;
3460: if((TOC=type(OC)) == 4){ /* rational coef. */
3461: if(Lim>0 && (texlen(OC[0])>Lim || texlen(OC[0])>Lim)){
3462: OC = (Small==1)?"("+OC[0]+")/("+OC[1]+")"
3463: :"\\Bigl("+OC[0]+"\\Bigr)\\Bigm/\\Bigl("+OC[1]+"\\Bigr)";
3464: TOC = 7;
3465: }else{
3466: if(str_char(OC[0],0,"-")==0){
1.3 takayama 3467: OC = fctrtos(-PC|TeX=1,br=1);
3468: OC = "-\\frac{"+OC[0]+"}{"+OC[1]+"}";
1.1 takayama 3469: }
3470: else
3471: OC = "\\frac{"+OC[0]+"}{"+OC[1]+"}";
3472: }
3473: }
3474: if(Lim>0){
3475: LL=texlen(OC)+texlen(PW);
3476: if(LL+L>=Lim){
3477: if(L>0) str_tb(CR,Out);
3478: if(LL>Lim){
3479: if(TOC==7) OC=texlim(OC,Lim|cut=CR);
3480: PW+=CR; L=0;
3481: }else L=LL;
3482: }else L+=LL;
3483: }else if(length(Tm)!=1) PW += CR; /* not final term */
1.4 ! takayama 3484: if(TeX) OC=texsp(OC);
1.1 takayama 3485: if(str_chr(OC,0,"-") == 0 || C==0) str_tb([OC,PW], Out);
3486: else{
3487: str_tb(["+",OC,PW],Out);
3488: if(LL<=Lim) L++;
3489: }
3490: }
3491: S=str_tb(0,Out);
1.3 takayama 3492: if(S=="") S="0";
1.1 takayama 3493: }else{ /* Var is not specified */
3494: if((TP=type(P)) == 3){ /* rational function */
3495: P = red(P); Nm=nm(P); Dn=dn(P);
3496: Q=dn(ptozp(Nm|factor=1)[1]);
3497: if(Q>1){
3498: Nm*=Q;Dn*=Q;
3499: }
3500: if(TeX>0){
3501: return (TeX==2)?
3502: "\\frac\{"+fctrtos(Nm|TeX=1)+"\}\{"+fctrtos(Dn|TeX=1)+"\}"
3503: :[fctrtos(Nm|TeX=1),fctrtos(Dn|TeX=1)];
3504: }
1.4 ! takayama 3505: else{
! 3506: S=fctrtos(Nm);
! 3507: if(nmono(Nm)>1) S="("+S+")";
! 3508: return S+"/("+fctrtos(Dn)+")";
! 3509: }
1.1 takayama 3510: }
1.4 ! takayama 3511: if(imag(P)==0) P = fctr(P); /* usual polynomial */
! 3512: else P=[[P,1]];
1.1 takayama 3513: S = str_tb(0,0);
3514: for(J = N = 0; J < length(P); J++){
3515: if(type(P[J][0]) <= 1){
3516: if(P[J][0] == -1){
3517: write_to_tb("-",S);
3518: if(length(P) == 1)
3519: str_tb("1", S);
3520: }else if(P[J][0] != 1){
3521: str_tb((TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]), S);
3522: N++;
3523: }else if(length(P) == 1)
3524: str_tb("1", S);
3525: else if(getopt(br)!=1 && length(P) == 2 && P[1][1] == 1){
3526: str_tb((TeX>=1)?my_tex_form(P[1][0]):rtostr(P[1][0]), S);
3527: J++;
3528: }
3529: continue;
3530: }
3531: if(N > 0 && TeX != 1 && TeX != 2 && TeX != 3)
3532: write_to_tb("*", S);
1.4 ! takayama 3533: SS=(TeX>=1)?my_tex_form(P[J][0]):rtostr(P[J][0]);
1.1 takayama 3534: N++;
1.4 ! takayama 3535: if(P[J][1] != 1){ /* (log(x))^2 */
! 3536: if(nmono(P[J][0])>1||
! 3537: (!isvar(P[J][0])||vtype(P[J][0]))&&str_len(SS)>1) SS="("+SS+")";
! 3538: write_to_tb(SS,S);
! 3539: str_tb(["^", (TeX>1)?rtotex(P[J][1]):monotos(P[J][1])],S);
! 3540: }else{
! 3541: if(nmono(P[J][0])>1) SS="("+SS+")";
! 3542: write_to_tb(SS,S);
! 3543: }
1.1 takayama 3544: }
3545: S = str_tb(0,S);
3546: if((Lim>0 || TP!=2) && CR!="") S=texlim(S,Lim|cut=CR);
3547: }
3548: if(TeX>0){
3549: if(Small==1) S=str_subst(S,"\\frac{","\\tfrac{");
3550: if(Dvi==1){
1.4 ! takayama 3551: dviout(strip(S,"(",")")|eq=(Pages==1)?6:0); S=1;
1.1 takayama 3552: }
3553: }
3554: return S;
3555: }
3556:
1.4 ! takayama 3557: def strip(S,S0,S1)
! 3558: {
! 3559: SS=strtoascii(S);
! 3560: if(length(SS)>1){
! 3561: if(SS[0]==40&&SS[length(SS)-1]==41&&str_pair(SS,1,S0,S1)==length(SS)-1)
! 3562: S=str_cut(SS,1,length(SS)-2);
! 3563: }
! 3564: return S;
! 3565: }
! 3566:
1.1 takayama 3567: def texlim(S,Lim)
3568: {
3569: /* extern TeXLim; */
3570: if(S==1 && Lim>10){
3571: TeXLim=Lim;
3572: mycat(["Set TeXLim =",Lim]);
3573: return 1;
3574: }
3575: if(type(Out=getopt(cut))!=7) Out="\\\\\n&";
3576: if(type(Del=getopt(del))!=7) Del=Out;
3577: if(Lim<30) Lim=TeXLim;
3578: S=ltov(strtoascii(S));
3579: for(L=[0],I=F=0;F==0; ){
3580: II=str_str(S,Del|top=I)+2;
3581: if(II<2){
3582: F++;II=/* str_len(S) */ length(S)-1;
3583: }
3584: for(J=JJ=I+1;;JJ=K+1){
3585: K=str_char(S,JJ,43); /* + */
3586: if((K1=str_char(S,JJ,45))>2 && K1<K){ /* - */
3587: if(S[K1-1]!=123 && S[K1-1]!=40) K=K1; /* {, ( */
3588: }
3589: if((K1=str_char(S,JJ,40))>0 && K1-JJ>6 && K1<K && S[K1-1]!=43 && S[K1-1]!=45){ /* ( */
3590: T=str_char(S,K1-6,"\\"); /* \Big*(, \big*( */
3591: if((T==K1-6 || T==K1-5)
3592: && (str_str(S,"big"|top=T+1,end=T+1)>0 || str_str(S,"Big"|top=T+1,end=T+1)>0))
3593: K=T;
3594: else if(K1>0 && K1<K) K=K1;
3595: }
3596: if(K<0 || K>II) break;
3597: if(K-J>Lim && texlen(str_cut(S,J,K-1))>=Lim){
3598: J=K+1; L=cons(JJ-1,L); SL=0;
3599: }
3600: }
3601: I=II;
3602: }
3603: SS=str_tb(0,0);
3604: L=cons(length(S),L);
3605: L=reverse(L);
3606: for(I=0; L!=[]; I=J,L=cdr(L)){
3607: str_tb((I==0)?"":Out,SS);
3608: J=car(L);
3609: str_tb(str_cut(S,I,J-1),SS);
3610: }
3611: return str_tb(0,SS);
3612: }
3613:
3614: def fmult(FN,M,L,N)
3615: {
1.3 takayama 3616: Opt=getopt();
1.1 takayama 3617: for(I = 0; I < length(M); I++)
1.3 takayama 3618: M = call(FN, cons(M,cons(L[I],N))|option_list=Opt);
1.1 takayama 3619: return M;
3620: }
3621:
3622: def radd(P,Q)
3623: {
3624: if(type(P) <= 3 || type(Q) <= 3){
3625: if(type(P) >= 5)
3626: return radd(Q,P);
3627: if(type(Q) >= 5){
3628: R = dupmat(Q);
3629: if(P == 0)
3630: return R;
3631: if(type(Q) == 6){
3632: S = size(Q);
3633: if(S[0] != S[1])
3634: return 0;
3635: for(I = 0; I < S[0]; I++)
3636: R[I][I] = radd(R[I][I], P);
3637: }else{
3638: for(I = length(R)-1; I >= 0; I--)
3639: R[I] = radd(R[I],P);
3640: }
3641: return R;
3642: }
3643: /* P=red(P);Q=red(Q); */
3644: if((P1=dn(P)) == (Q1=dn(Q))){
3645: if(P1==1) return P+Q;
3646: return red((nm(P)+nm(Q))/P1);
3647: }
3648: R=gcd(P1,Q1);S=tdiv(P1,R);
3649: return red((nm(P)*tdiv(Q1,R)+nm(Q)*S)/(S*Q1));
3650: }
3651: if(type(P) == 5){
3652: S = length(P);
3653: R = newvect(S);
3654: for(I = 0; I < S; I++)
3655: R[I] = radd(P[I],Q[I]);
3656: return R;
3657: }
3658: if(type(P) == 6){
3659: S = size(P);
3660: R = newmat(S[0],S[1]);
3661: for(I = 0; I < S[0]; I++){
3662: for(J = 0; J < S[1]; J++)
3663: R[I][J] = radd(P[I][J],Q[I][J]);
3664: }
3665: return R;
3666: }
3667: erno(0);
3668: }
3669:
3670: def getel(M,I)
3671: {
3672: if(type(M) >= 4 && type(M) <= 6 && type(I) <= 1)
3673: return M[I];
3674: if(type(M) == 6 && type(I) == 5)
3675: return M[I][J];
3676: return M;
3677: }
3678:
3679: def ptol(P,X)
3680: {
3681: F=(getopt(opt)==0)?0:1;
3682: if(type(P) <= 3)
3683: P = [P];
3684: if(type(X) == 4){
3685: for( ; X != []; X = cdr(X))
3686: P=ptol(P,car(X)|opt=F);
3687: return P;
3688: }
3689: P = reverse(P);
3690: for(R=[]; P != []; P = cdr(P)){
3691: Q = car(P);
3692: for(I = mydeg(Q,X); I >= 0; I--){
3693: S=mycoef(Q,I,X);
3694: if(F==1 || S!=0) R = cons(S,R);
3695: }
3696: }
3697: return R;
3698: }
3699:
3700: def rmul(P,Q)
3701: {
3702: if(type(P) <= 3 && type(Q) <= 3){
3703: P=red(P);Q=red(Q);
3704: P1=dn(P);P2=nm(P);Q1=dn(Q);Q2=nm(Q);
3705: if(P1==1 && Q1==1)
3706: return P*Q;
3707: if((R=gcd(P1,Q2)) != 1){
3708: P1=tdiv(P1,R);Q2=tdiv(Q2,R);
3709: }
3710: if((R=gcd(Q1,P2)) != 1){
3711: Q1=tdiv(Q1,R);P2=tdiv(P2,R);
3712: }
3713: return P2*Q2/(P1*Q1);
3714: }
1.3 takayama 3715: #ifdef USEMODULE
3716: return mmulbys(os_md.rmul,P,Q,[]);
3717: #else
1.1 takayama 3718: return mmulbys(rmul,P,Q,[]);
1.3 takayama 3719: #endif
1.1 takayama 3720: }
3721:
3722: def mtransbys(FN,F,LL)
3723: {
1.3 takayama 3724: Opt=getopt();
1.1 takayama 3725: if(type(F) == 4){
3726: F = ltov(F);
3727: S = length(F);
3728: R = newvect(S);
3729: for(I = 0; I < S; I++)
1.3 takayama 3730: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
1.1 takayama 3731: return vtol(R);
3732: }
3733: if(type(F) == 5){
3734: S = length(F);
3735: R = newvect(S);
3736: for(I = 0; I < S; I++)
1.3 takayama 3737: R[I] = mtransbys(FN,F[I],LL|option_list=Opt);
1.1 takayama 3738: return R;
3739: }
3740: if(type(F) == 6){
3741: S = size(F);
3742: R = newmat(S[0],S[1]);
3743: for(I = 0; I < S[0]; I++){
3744: for(J = 0; J < S[1]; J++)
1.3 takayama 3745: R[I][J] = mtransbys(FN,F[I][J],LL|option_list=Opt);
1.1 takayama 3746: }
3747: return R;
3748: }
1.4 ! takayama 3749: if(type(F) == 7) return F;
1.3 takayama 3750: return call(FN, cons(F,LL)|option_list=Opt);
3751: }
3752:
3753: def drawopt(S,T)
3754: {
3755: if(type(S)!=7) return -1;
3756: if(T==0||T==1){
3757: for(I=0,R=LCOPT;I<7;I++,R=cdr(R))
3758: if(str_str(S,car(R))>=0) return(T==0)?COLOPT[I]:car(R);
3759: return -1;
3760: }
3761: if(T==2){
3762: V0=V1=0;
3763: for(I=0,R=LPOPT;R!=[];I++,R=cdr(R)){
3764: if(str_str(S,car(R))>=0){
3765: if(I==0) V1++;
3766: else if(I==1) V1--;
3767: else if(I==2) V0--;
3768: else V0++;
3769: }
3770: }
3771: if(V0==0&&V1==0) return -1;
3772: return [V0,V1];
3773: }
3774: if(T==3){
3775: V=0;
3776: for(I=1,R=LFOPT;R!=[];R=cdr(R),I*=2){
3777: if(str_str(S,car(R))>=0) V+=I;
3778: }
3779: return (V==0)?-1:V;
3780: }
3781: return -1;
3782: }
3783:
3784: def execdraw(L,P)
3785: {
3786: if((Proc=getopt(proc))!=1) Proc=0;
3787: if(type(P)<2) P=[P];
3788: if(L!=[]&&type(L[0])!=4) L=[L];
3789: /* special command */
3790: if(P[0]<0){
3791: if(length(P)==1&&(P[0]==-1||P[0]==-2||P[0]==-3)){ /* Bounding Box */
1.4 ! takayama 3792: W=WS=N=LS=0;
! 3793: for(LL=L;LL!=[];LL=cdr(LL)){
1.3 takayama 3794: T=car(LL);
3795: if(P[0]!=-3 && T[0]==0){
3796: if(length(T)>3) S=" by "+rtostr(T[3])+" cm";
3797: else S="";
3798: if(P[0]==-1){
3799: mycat(["Windows : ",T[1][0],"< x <",T[1][1],", ",
3800: T[2][0],"< y <",T[2][1],S]);
3801: if(length(T)>4 && type(T[4])==4) mycat(["ext :",T[4]]);
3802: if(length(T)>5) mycat(["shift :",T[5]]);
3803: }
3804: return cdr(T);
3805: }
3806: if(type(T[0])==1){
3807: if(T[0]==1){
1.4 ! takayama 3808: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
! 3809: D=car(TT);
! 3810: if(type(D[0][0])==4){
! 3811: for(DT=D;DT!=[];DT=cdr(DT)){
! 3812: if(N++==0) W=ptbbox(car(DT));
! 3813: else W=ptbbox(car(DT)|box=W);
! 3814: }
! 3815: }else{
! 3816: if(N++==0) W=ptbbox(D);
! 3817: else W=ptbbox(D|box=W);
1.3 takayama 3818: }
3819: }
3820: }else if(T[0]==2){
3821: V=T[2];
1.4 ! takayama 3822: if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
1.3 takayama 3823: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
3824: Sc=car(Sc)[1];
3825: if(type(Sc)==1) V=[Sc*V[0],Sc*V[1]];
3826: else V=[Sc[0]*V[0],Sc[1]*V[1]];
3827: }
3828: if(LS==0) WS=ptbbox([V]);
3829: else WS=ptbbox([V]|box=WS);
3830: if(length(T)>4) S=T[4];
1.4 ! takayama 3831: else if(type(S=T[3])==4){
! 3832: S=S[0];
! 3833: if(type(S)==4) S=S[length(S)-1];
! 3834: S=rtostr(S);
! 3835: }
1.3 takayama 3836: if(str_len(S)>LS) LS=str_len(S);
3837: }else if(T[0]==3||T[0]==4){
3838: if(N++==0) W=ptbbox(cdr(cdr(T)));
3839: else W=ptbbox(cdr(cdr(T))|box=W);
1.4 ! takayama 3840: }
1.3 takayama 3841: }
3842: }
1.4 ! takayama 3843: if(W!=0&&WS!=0) W=ptbbox([W,WS]|box=1);
1.3 takayama 3844: return (P[0]==-3)?[W,LS,WS]:W;
3845: }else if(length(P)>1&&P[0]==-1){ /* set Bounding Box */
3846: P=cons(0,cdr(P));
3847: Ex=Sft=[0,0];
3848: if(type(X=getopt(ext))==4) Ex=X;
3849: if(type(X=getopt(shift))==4) Sft=X;
3850: if(Ex!=Sft||Ex!=[0,0]){
3851: if(Sft==[0,0]) Sft=[Ex];
3852: else Sft=[Ex,Sft];
3853: if(length(P)==3) Sft=cons(1,Sft);
3854: if(length(P)==3||length(P)==4) P=append(P,Sft);
3855: }
3856: return cons(P,delopt(L,0));
3857: }
3858: if(P[0]==-4){
3859: for(N=0,LT=L;LT!=[];LT=cdr(LT)){ /* count coord. */
3860: T=car(LT);
3861: if(T[0]==1){
3862: for(T=cdr(cdr(T));T!=[];T=cdr(T)){
3863: if(type((S=car(T))[0][0])==4) N+=length(S);
3864: else for(;S!=[];S=cdr(S)) if(type(car(S))==4) N++;
3865: }
3866: }else if(T[0]==2) N++;
3867: else if(T[0]==3||T[0]==4) N+=2;
3868: }
3869: return N;
3870: }
3871: if(P[0]==-5){ /* functions */
3872: for(N=0,R=[],LT=L;LT!=[];LT=cdr(LT)){
3873: T=car(LT);
3874: if(T[0]==0) N=ior(N,1);
3875: else if(type(T[0])==1){
3876: if(T[0]>0) N=ior(N,2^T[0]);
3877: }
3878: else if(Type(T[0])==2){
3879: if(findin(T[0],R)<0) R=cons(T[0],R);
3880: }
3881: }
3882: for(I=5;I>=0;I--) if(iand(N,2^I)) R=cons(I,R);
3883: return R;
3884: }
3885: return 0;
3886: }
3887:
3888: if(length(P)>1){
3889: if(type(P[1])==6||(type(P[1])<2&&P[1]>0)) M=P[1];
3890: else if(type(P[1])==4&&length(P[1])==2) M=diagm(2,P[1]);
3891: }
3892: if(length(P)>2&&type(P[2])==4){
3893: Org=[["shift",P[2]]];
3894: if(M==0) M=1;
3895: }else Org=[];
3896: if(P[0]==0||(type(P[0])==4&&P[0][0]==0)){ /* Risa/Asir */
3897: PP=car(P);PPP=0;
3898: if(type(PP)!=4) PP=[PP];
3899: if(length(PP)<3){
3900: if(length(PP)==1 || type(PP[1])==4){
3901: if(ID_PLOT<0) ID_PLOT=ox_launch_nox(0,"ox_plot");
3902: Id=ID_PLOT;
1.4 ! takayama 3903: if(length(PP)==1&&type(Canvas)==4&&length(Canvas)==2)
! 3904: PP=cons(PP[0],[Canvas]);
1.3 takayama 3905: if(length(PP)>1){
3906: PPP=PP[1][0];
3907: PPQ=(length(PP[1])==2)?PP[1][1]:PPP;
3908: open_canvas(Id,[PPP,PPQ]);
3909: }else open_canvas(Id);
3910: Ind=ox_pop_cmo(Id);
1.4 ! takayama 3911: }else{
! 3912: Ind=PP[1];
! 3913: if(getopt(cl)==1) clear_canvas(Id,Ind);
! 3914: }
1.3 takayama 3915: }else{
3916: Id=PP[1];Ind=PP[2];
3917: if(length(PP)>3 && type(PP[3])==1) PPP=PP[3];
3918: if(length(PP)>4 && type(PP[4])==1) PPQ=PP[4];
3919: if(getopt(cl)==1) clear_canvas(Id,Ind);
3920: }
3921: if(L==[]) return (PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
3922: Ex0=Ex0;Sft=[0,0];
3923: if(length(P)>1&&P[1]==0&&length(P)<4){
3924: R=execdraw(L,-3);
3925: Ex0=Ex1=Ex2=10;
3926: if((U=R[1])>0){ /* string */
3927: if(U>20) U=16; /* adj 16,8,2,7,15 */
1.4 ! takayama 3928: if(R[0][0][0]>R[2][0][0]-(R[0][0][1]-R[0][0][0])/256) Ex0+=8*U; /* adj 256 */
1.3 takayama 3929: else Ex0+=2*U;
1.4 ! takayama 3930: if(R[0][0][1]<R[2][0][1]+(R[0][0][1]-R[0][0][0])/256) Ex1+=7*U;
1.3 takayama 3931: else Ex1+=2*U;
1.4 ! takayama 3932: if(R[0][1][1]<R[2][1][1]+(R[0][1][1]-R[0][1][0])/256) Ex2+=15;
1.3 takayama 3933: }
3934: R=[R[0][0],R[0][1],0,[Ex0,Ex1],[0,-Ex2]];
3935: if(length(P)>2 && P[2]==1)
3936: mycat0(["Box:",[R[0],R[1]], ", ext=",R[3],", shift=",R[4]],1);
3937: }else R=execdraw((length(P)>3)?P[3]:L,-2); /* Windows */
3938: XW=R[0];YW=R[1];
3939: if(length(R)>3){
3940: if(R[3]!=0 && R[3]!=[0,0]) Ex=R[3];
3941: if(length(R)>4) Sft=R[4];
3942: }
3943: if(type(X=getopt(ext))==4)
3944: Ex=(Ex0)?[X[0]+Ex[0],X[1]+Ex[1]]:X;
3945: if(type(M)<2){
3946: if(length(P)>1&&type(P[1])==1) M=P[1];
1.4 ! takayama 3947: else if((length(P)==1||P[1]==0||P[1]==1)&& PPP>0) M=PPP;
! 3948: if(M<2) M=400;
1.3 takayama 3949: if(Ex!=0 && type(Ex)==4){
3950: M-=Ex[0]+Ex[1];
3951: }
3952: M=(M/(XW[1]-XW[0]))*diagm(2,[1,-1]);
3953: }
3954: if(type(X=getopt(shift))==4) Sft=(Ex0)?[Sft[0]+X[0],Sft[1]+X[1]]:X;
3955: if(type(Sft)==4) Sft=[Sft[0],-Sft[1]];
3956: if(Ex!=0) Sft=[Sft[0]+Ex[0],Sft[1]];
3957: Org=[["shift",ptaffine(M,[-XW[0],-YW[1]]|shift=Sft)]];
3958: for(CT=0;CT<2;CT++){
3959: for(LT=L;LT!=[];LT=cdr(LT)){
3960: T=car(LT);
3961: if(!CT && T[0]!=2) continue;
3962: if(CT && T[0]==2) continue;
3963: if(T[0]==1){
3964: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
3965: D=car(TT);
3966: if(type(D[0][0])==4){
3967: for(DT=D;DT!=[];DT=cdr(DT)){
3968: V=car(DT);
3969: if(M) V=ptaffine(M,V|option_list=Org);
3970: draw_bezier(Id,Ind,V|option_list=T[1]);
3971: }
3972: }else{
3973: if(M) D=ptaffine(M,D|option_list=Org);
3974: draw_bezier(Id,Ind,D|option_list=T[1]);
3975: }
3976: }
1.4 ! takayama 3977: }else if(T[0]==2){ /* put */
! 3978: if(length(T)<4) continue;
! 3979: V=T[2];
! 3980: if(type(VLB)==4&&V[0]=="_") V=VLB;
! 3981: else if(type(V[0])>1||type(V[1])>1) continue; /* not supported */
! 3982: if(length(T)>3&&type(T[3])==4&&length(T[3])>1&&T[3][1]==1) VLB=V;
! 3983: F++;MM=M;
1.3 takayama 3984: if((Sc=delopt(T[1],"scale"|inv=1))!=[]){
3985: if(!MM) MM=1;
3986: Sc=car(Sc)[1];
3987: if(type(Sc)==1) MM=MM*Sc;
3988: else if(type(Sc)==6) MM=MM*diagm(2,Sc);
3989: }
3990: if(MM) V=ptaffine(MM,V|option_list=Org);
3991: if(type(S=S0=T[3])==4) S=S0[0];
3992: if(length(T)>4) S=T[4]; /* subst. string */
3993: if(type(S0)==4&&type(S0[0])==4){
3994: if((Col=drawopt(S0[0][0],0))<0) Col=0; /* attrib. */
1.4 ! takayama 3995: if(type(S)!=7) S=rtostr(S0[0][1]);
! 3996: S=str_subst(S,[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
1.3 takayama 3997: if(type(Pos=drawopt(S0[0][0],2))==4)
3998: V=[V[0]+4*str_len(S)*Pos[0],V[1]-10*Pos[1]]; /* adjustable */
1.4 ! takayama 3999: }else S=str_subst(rtostr(S),[["$\\bullet$","*"],["$\\times$","x"],["$",""]],0);
1.3 takayama 4000: V=[V[0]-str_len(S)*4,V[1]-8]; /* adjustable */
4001: draw_string(Id,Ind,V,S,Col);
4002: }else if(T[0]==3){ /* arrow */
4003: F++;
4004: T1=T[2];T2=T[3];
4005: if(M){
4006: T1=ptaffine(M,T1|option_list=Org);
4007: T2=ptaffine(M,T2|option_list=Org);
4008: }
4009: draw_bezier(Id,Ind,[T1,T2]|option_list=T[1]);
4010: }else if(T[0]==4){ /* line */
4011: F++;
4012: T1=T[2];T2=T[3];
4013: if(M){
4014: T1=ptaffine(M,T1|option_list=Org);
4015: T2=ptaffine(M,T2|option_list=Org);
4016: }
4017: V=delopt(T1=T[1],"opt"|inv=1);
4018: if(V!=[]&&str_str(V[1],".")>=0)
4019: T1=cons(["opt",cons("dotted,",V[1])],delopt(T1,"opt"));
4020: draw_bezier(Id,Ind,[T1,T2]|option_list=T1);
4021: }else if(T[0]==5){ /* TeX */
4022: mycat(rtostr(T[2]));
1.4 ! takayama 4023: if(F){
1.3 takayama 4024: S=str_tb(0,Out);
4025: Out=str_tb(0,0);
4026: F=0;
4027: if(S!=""){
4028: if(P[0]==2) dviout(xyproc(S)|keep=1);
4029: else LOut=cons(xyproc(S),LOut);
4030: }
4031: if(P[0]==2) dviout(T[2]|option_list=T[1]);
4032: else{
4033: LOut=cons(T[2],Out);
4034: }
4035: }
4036: }else if(Proc==1&&type(T[0])==2){
4037: if(length(T)<3) call(T[0],T[1]);
4038: else call(T[0],T[1]|option_list=T[2]);
4039: }
4040: }
4041: }
4042: S=(PPP>0)? [0,Id,Ind,PPP,PPQ]:[0,Id,Ind];
1.4 ! takayama 4043: if(Ex==0&&Sft!=[0,0]) Ex=[0,0];
! 4044: return (Ex!=0&&length(P)>2&&P[2]==-1)?
1.3 takayama 4045: [S,0,0,[0,R[0],R[1],0,Ex,[Sft[0]-Ex[0],-Sft[1]]]]:S;
4046: }
4047: if(P[0]==1||P[0]==2){ /* TeX */
4048: Out=str_tb(0,0);LOut=[];F=0;
4049: if(getopt(cl)==1) dviout0(0);
4050: for(;L!=[];L=cdr(L)){
4051: T=car(L);Opt=T[1];
4052: if(type(T[0])>=2) continue;
4053: if(T[0]==0){
4054: XW=T[1];YW=T[2];
4055: if(length(P)>1&&type(P[1])==1&&P[1]<0)
4056: M=-P[1]/(XW[0]-XW[1]);
4057: }else if(T[0]==1){
4058: F++;
4059: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
4060: D=car(TT);
4061: if(type(D[0][0])==4){
4062: for(DT=D;DT!=[];DT=cdr(DT)){
4063: V=car(DT);
4064: if(M) V=ptaffine(M,V|option_list=Org);
4065: str_tb(xybezier(V|option_list=Opt),Out);
4066: }
4067: }else{
4068: if(M) D=ptaffine(M,D|option_list=Org);
4069: str_tb(xybezier(D|option_list=Opt),Out);
4070: }
4071: }
4072: }else if(T[0]==2){
4073: F++;V=T[2];
4074: Opt=delopt(Opt,"scale"|inv=1);
1.4 ! takayama 4075: MM=M;
1.3 takayama 4076: if(Opt!=[]){
4077: Opt=car(Opt)[1];
4078: if(type(Opt)==1) Opt=[Opt,Opt];
1.4 ! takayama 4079: if(Opt!=[1,1]){
! 4080: if(!MM) MM=1;
! 4081: MM=MM*diagm(2,[Opt[0],Opt[1]]);
! 4082: }
1.3 takayama 4083: }
1.4 ! takayama 4084: if(MM) V=ptaffine(MM,V|option_list=Org);
1.3 takayama 4085: if(length(T)>3) V=append(V,T[3]);
4086: str_tb(xyput(V),Out);
4087: }else if(T[0]==3){
4088: F++;
4089: T1=T[2];T2=T[3];
4090: if(M){
4091: T1=ptaffine(M,T1|option_list=Org);
4092: T2=ptaffine(M,T2|option_list=Org);
4093: }
1.4 ! takayama 4094: str_tb(xyarrow(T1,T2|option_list=Opt),Out);
1.3 takayama 4095: }else if(T[0]==4){
4096: F++;
4097: T1=T[2];T2=T[3];
4098: if(M){
4099: T1=ptaffine(M,T1|option_list=Org);
4100: T2=ptaffine(M,T2|option_list=Org);
4101: }
1.4 ! takayama 4102: str_tb(xyline(T1,T2|option_list=Opt),Out);
1.3 takayama 4103: }else if(T[0]==5){
4104: if(F){
4105: S=str_tb(0,Out);
4106: Out=str_tb(0,0);
4107: F=0;
4108: if(S!=""){
4109: if(P[0]==2) dviout(xyproc(S)|keep=1);
4110: else LOut=cons(xyproc(S),LOut);
4111: }
4112: if(P[0]==2) dviout(T[2]|option_list=T[1]);
4113: else LOut=cons(T[2],Out);
4114: }
4115: }else if(T[0]==-2)
4116: str_tb(["%",T[1],"\n"],Out);
4117: else if(Proc==1&&type(T[0])==2){
4118: if(length(T)<3) call(T[0],T[1]);
4119: else call(T[0],T[1]|option_list=T[2]);
4120: }
4121: }
4122: S=str_tb(0,Out);
4123: if(P[0]==1){
4124: if(F) LOut=cons(xyproc(S),LOut);
4125: Out=str_tb(0,0);
4126: for(L=reverse(LOut);L!=[];L=cdr(L))
4127: str_tb(car(L),Out);
4128: return str_tb(0,Out);
4129: }
4130: if(F) dviout(xyproc(S));
4131: else dviout(" ");
4132: }
4133: }
4134:
4135: def execproc(L)
4136: {
4137: if(type(N=getopt(var))!=1&&N!=0) N=2;
4138: for(R=[];L!=[];L=cdr(L)){
4139: P=car(L);
4140: if(type(P[0])==2&&vtype(P[0])==3){
4141: if((VS=vars(cdr(P)))!=[]){
4142: for(I=0;I<N;I++){
4143: V=makev(["v",I+1]);
1.4 ! takayama 4144: if(findin(V,VS)>=0) P=mysubst(P,[V,R[I]]);
1.3 takayama 4145: }
4146: }
4147: if(length(P)<3) R=cons(call(P[0],P[1]),R);
4148: else R=cons(call(P[0],P[1]|option_list=P[2]),R);
4149: }
4150: }
4151: return (getopt(all)==1)?R:car(R);
1.1 takayama 4152: }
4153:
4154: def mysubst(P,L)
4155: {
4156: if(P==0) return 0;
1.4 ! takayama 4157: Inv=getopt(inv);
1.1 takayama 4158: if(type(L[0]) == 4){
4159: while((L0 = car(L))!=[]){
1.4 ! takayama 4160: P = mysubst(P,(Inv==1)?[L0[1],L0[0]]:L0);
1.1 takayama 4161: L = cdr(L);
4162: }
4163: return P;
4164: }
1.4 ! takayama 4165: if(Inv==1) L=[L[1],L[0]];
1.1 takayama 4166: if(type(P) > 3){
1.4 ! takayama 4167: if(type(P)==7) return P;
! 4168: if(type(P)>7)
1.1 takayama 4169: return subst(P,L[0],L[1]);
1.3 takayama 4170: #ifdef USEMODULE
4171: return mtransbys(os_md.mysubst,P,[L]);
4172: #else
1.1 takayama 4173: return mtransbys(mysubst,P,[L]);
1.3 takayama 4174: #endif
1.1 takayama 4175: }
4176: P = red(P);
4177: if(type(P) == 3){
4178: A=mysubst(nm(P),L);B=mysubst(dn(P),L);
4179: return red(nm(A)/nm(B))*red(dn(B)/dn(A));
4180: }
1.4 ! takayama 4181: L1=(type(L[1])==3)?red(L[1]):L[1];X=L[0];
! 4182: if(ptype(L1,X)==3){
1.1 takayama 4183: LN=nm(L1);LD=dn(L1);
1.4 ! takayama 4184: Deg=mydeg(P,X);
1.1 takayama 4185: if(Deg <= 0) return P;
4186: V = newvect(Deg+1);
4187: for(V[I=Deg]=1;I >= 1;I--)
4188: V[I-1]=V[I]*LD;
4189: for(R = 0, I = Deg; I >= 0; I--)
1.4 ! takayama 4190: R = R*LN + mycoef(P,I,X)*V[I];
1.1 takayama 4191: return red(R/V[0]);
4192: }
4193: return subst(P,X,L1);
4194: }
4195:
4196: def mmulbys(FN,P,F,L)
4197: {
1.3 takayama 4198: Opt=getopt();
1.1 takayama 4199: if(type(F) <= 3){
4200: if(type(P) <= 3)
1.3 takayama 4201: return call(FN, cons(P,cons(F,L))|option_list=Opt);
1.1 takayama 4202: if(type(P) == 5){
4203: S = length(P);
4204: R = newvect(S);
4205: for(I = 0; I < S; I++)
1.3 takayama 4206: R[I] = call(FN, cons(P[I],cons(F,L))|option_list=Opt);
1.1 takayama 4207: return R;
4208: }else if(type(P) == 6){
4209: S = size(P);
4210: R = newmat(S[0],S[1]);
4211: for(I = 0; I < S[0]; I++){
4212: for(J = 0; J < S[1]; J++)
1.3 takayama 4213: R[I][J] = call(FN, cons(P[I][J],cons(F,L))|option_list=Opt);
1.1 takayama 4214: }
4215: return R;
4216: }
4217: }
4218: if(type(F) == 5){
4219: S = length(F);
4220: if(type(P) <= 3){
4221: R = newvect(S);
4222: for(I = 0; I < S; I++)
1.3 takayama 4223: R[I] = call(FN, cons(P,cons(F[I],L))|option_list=Opt);
1.1 takayama 4224: return R;
4225: }
4226: if(type(P) == 5){
4227: for(J=R=0; J<S; J++)
1.3 takayama 4228: R = radd(R, call(FN, cons(P[J],cons(F[J],L)))|option_list=Opt);
1.1 takayama 4229: return R;
4230: }
4231: T = size(P);
4232: R = newvect(T[0]);
4233: for(I = 0; I < T[0]; I++){
4234: for(J = 0; J < S; J++)
1.3 takayama 4235: R[I] = radd(R[I], call(FN, cons(P[I][J],cons(F[J],L))|option_list=Opt));
1.1 takayama 4236: }
4237: return R;
4238: }
4239: if(type(F) == 6){
4240: S = size(F);
4241: if(type(P) <= 3){
4242: R = newmat(S[0],S[1]);
4243: for(I = 0; I < S[0]; I++){
4244: for(J = 0; J < S[1]; J++)
1.3 takayama 4245: R[I][J] = call(FN, cons(P,cons(F[I][J],L))|option_list=Opt);
1.1 takayama 4246: }
4247: return R;
4248: }
4249: if(type(P) == 5){
4250: R = newvect(S[1]);
4251: for(J = 0; J < S[1]; J++){
4252: for(K = U = 0; K < S[0]; K++)
1.3 takayama 4253: U = radd(U, call(FN, cons(P[K],cons(F[K][J],L))|option_list=Opt));
1.1 takayama 4254: R[J] = U;
4255: }
4256: return R;
4257: }
4258: T = size(P);
4259: R = newmat(T[0],S[1]);
4260: for(I = 0; I < T[0]; I++){
4261: for(J = 0; J < S[1]; J++){
4262: for(K = U = 0; K < S[0]; K++)
1.3 takayama 4263: U = radd(U, call(FN, cons(P[I][K],cons(F[K][J],L)|option_list=Opt)));
1.1 takayama 4264: R[I][J] = U;
4265: }
4266: }
4267: return R;
4268: }
4269: erno(0);
4270: return 0;
4271: }
4272:
4273: def appldo(P,F,L)
4274: {
4275: if(type(F) <= 3){
4276: if(type(L) == 4 && type(L[0]) == 4)
4277: return applpdo(P,F,L);
4278: L = vweyl(L);
4279: X = L[0]; DX = L[1];
4280: J = mydeg(P,DX);
4281: for(I = R = 0; I <= J; I++){
4282: if(I > 0)
4283: F = mydiff(F,X);
4284: R = radd(R,mycoef(P,I,DX)*F);
4285: }
4286: return R;
4287: }
1.3 takayama 4288: #ifdef USEMODULE
4289: return mmulbys(os_md.appldo,P,F,[L]);
4290: #else
1.1 takayama 4291: return mmulbys(appldo,P,F,[L]);
1.3 takayama 4292: #endif
1.1 takayama 4293: }
4294:
4295: def appledo(P,F,L)
4296: {
4297: if(type(F) <= 3){
4298: L = vweyl(L);
4299: X = L[0]; DX = L[1];
4300: J = mydeg(P,DX);
4301: for(I = R = 0; I <= J; I++){
4302: if(I > 0)
4303: F = myediff(F,X);
4304: R = radd(R,mycoef(P,I,DX)*F);
4305: }
4306: return R;
4307: }
1.3 takayama 4308: #ifdef USEMODULE
4309: mmulbys(os_md.appledo,P,F,[L]);
4310: #else
1.1 takayama 4311: mmulbys(appledo,P,F,[L]);
1.3 takayama 4312: #endif
1.1 takayama 4313: }
4314:
4315: def muldo(P,Q,L)
4316: {
4317: if(type(Lim=getopt(lim))!=1) Lim=100;
4318: if(type(Q) <= 3){
4319: if(type(L) == 4 && type(L[0]) == 4)
4320: return mulpdo(P,Q,L|lim=Lim); /* several variables */
4321: R = rmul(P,Q);
4322: L = vweyl(L);
4323: X = L[0]; DX = L[1];
4324: if(X != 0){
4325: for(I = F = 1; ; I++){
4326: P = mydiff(P,DX);
4327: if(I>Lim){
4328: mycat(["Over", Lim,"derivations!"]);
4329: break;
4330: }
4331: if(P == 0)
4332: break;
4333: Q = mydiff(Q,X);
4334: if(Q == 0)
4335: break;
4336: F *= I;
4337: R = radd(R,P*Q/F);
4338: }
4339: }
4340: return R;
4341: }
1.3 takayama 4342: #ifdef USEMODULE
4343: return mmulbys(os_md.muldo,P,Q,[L]);
4344: #else
1.1 takayama 4345: return mmulbys(muldo,P,Q,[L]);
1.3 takayama 4346: #endif
1.1 takayama 4347: }
4348:
4349: def adj(P,L)
4350: {
4351: if(type(P) == 4)
1.3 takayama 4352: #ifdef USEMODULE
4353: return map(os_md.adj,mtranspose(P),L);
4354: #else
1.1 takayama 4355: return map(adj,mtranspose(P),L);
1.3 takayama 4356: #endif
1.1 takayama 4357: if(type(L) == 4 && type(L[0]) == 4)
1.3 takayama 4358: #ifdef USEMODULE
4359: return fmult(os_md.adj,P,L,[]);
4360: #else
1.1 takayama 4361: return fmult(adj,P,L,[]);
1.3 takayama 4362: #endif
1.1 takayama 4363: L = vweyl(L);
4364: X = L[0]; DX = L[1];
4365: P = R = subst(P, DX, -DX);
4366: for(I = 1; (R = mydiff(mydiff(R, X), DX)/I) != 0 && I < 100; I++)
4367: P = radd(P,R);
4368: return P;
4369: }
4370:
4371: def laplace1(P,L)
4372: {
4373: if(type(L) == 4 && type(L[0]) == 4)
1.3 takayama 4374: #ifdef USEMODULE
4375: return fmult(os_md.laplace,P,L,[]);
4376: #else
1.1 takayama 4377: return fmult(laplace,P,L,[]);
1.3 takayama 4378: #endif
1.1 takayama 4379: L = vweyl(L);
4380: X = L[0]; DX = L[1];
4381: P = adj(P, L);
4382: return subst(P,X,o_1,DX,X,o_1,DX);
4383: }
4384:
4385: def laplace(P,L)
4386: {
4387: if(type(L) == 4 && type(L[0]) == 4)
1.3 takayama 4388: #ifdef USEMODULE
4389: return fmult(os_md.laplace1,P,L,[]);
4390: #else
1.1 takayama 4391: return fmult(laplace1,P,L,[]);
1.3 takayama 4392: #endif
1.1 takayama 4393: L = vweyl(L);
4394: X = L[0]; DX = L[1];
4395: P = adj(P, L);
4396: return subst(P,X,o_1,DX,-X,o_1,-DX);
4397: }
4398:
4399: def mce(P,L,V,R)
4400: {
4401: L = vweyl(L);
4402: X = L[0]; DX = L[1];
4403: P = sftexp(laplace1(P,L),L,V,R);
4404: return laplace(P,L);
4405: }
4406:
4407: def mc(P,L,R)
4408: {
4409: return mce(P,L,0,R);
4410: }
4411:
4412: def rede(P,L)
4413: {
4414: Q = ltov(fctr(nm(red(P))));
4415: P = 1;
4416: if(type(L) < 4)
4417: L = [L];
4418: if(type(L[0]) < 4)
4419: L = [L];
4420: for( ; L != []; L = cdr(L)){
4421: DX = vweyl(car(L))[1];
4422: for(I = 1; I < length(Q); I++){
4423: if(mydeg(Q[I][0],DX) > 0){
4424: P *= (Q[I][0])^(Q[I][1]);
4425: Q[I]=[1,0];
4426: }
4427: }
4428: }
4429: return P;
4430: }
4431:
4432: def ad(P,L,R)
4433: {
4434: L = vweyl(L);
4435: DX = L[1];
4436: K = mydeg(P,DX);
4437: S = mycoef(P,0,DX);
4438: Q = 1;
4439: for(I=1; I <= K;I++){
4440: Q = muldo(Q,DX-R,L);
4441: S = radd(S,mycoef(P,I,DX)*Q);
4442: }
4443: return S;
4444: }
4445:
4446: def add(P,L,R)
4447: {
4448: return rede(ad(P,L,R),L);
4449: }
4450:
4451:
4452: def vadd(P,L,R)
4453: {
4454: L = vweyl(L);
4455: if(type(R) != 4)
4456: return 0;
4457: N = length(R);
4458: DN = 1; Ad = PW = 0;
4459: for( ; R != []; R = cdr(R), PW++){
4460: DN *= (T=1-car(R)[0]*L[0]);
4461: Ad = Ad*T-car(R)[1]*x^PW;
4462: }
4463: Ad /= DN;
4464: return add(P,L,Ad);
4465: }
4466:
4467: def addl(P,L,R)
4468: {
4469: return laplace1(add(laplace(P,L),L,R),L);
4470: }
4471:
4472: def cotr(P,L,R)
4473: {
4474: L = vweyl(L);
4475: X = L[0]; DX = L[1];
4476: T = 1/mydiff(P,DX);
4477: K = mydeg(P,DX);
4478: S = mysubst(mycoef(P,0,DX), [X, R]);
4479: Q = 1;
4480: for(I = 1; I <= K; I++){
4481: Q = muldo(Q, K*DX, L);
4482: S = radd(S,mysubst(mycoef(P,I,DX), [X, R])*Q);
4483: }
4484: }
4485:
4486: def rcotr(P,L,R)
4487: {
4488: return rede(cotr(P,L,R), L);
4489: }
4490:
4491: def muledo(P,Q,L)
4492: {
4493: if(type(Q)>3)
1.3 takayama 4494: #ifdef USEMODULE
4495: return mmulbys(os_md.muledo,P,Q,[L]);
4496: #else
1.1 takayama 4497: return mmulbys(muledo,P,Q,[L]);
1.3 takayama 4498: #endif
1.1 takayama 4499: R = P*Q;
4500: L = vweyl(L);
4501: X = L[0]; DX = L[1];
4502: for(I = F = 1; I < 100; I++){
4503: P = mydiff(P,DX);
4504: if(P == 0)
4505: break;
4506: Q = myediff(Q,X);
4507: if(Q == 0)
4508: break;
4509: F = rmul(F,I);
4510: R = radd(R,P*Q/F);
4511: }
4512: return R;
4513: }
4514:
4515:
4516: #if 1
4517: def mulpdo(P,Q,L)
4518: {
4519: if(type(Q)>3)
1.3 takayama 4520: #ifdef USEMODULE
4521: return mmulbys(os_md.mulpdo,P,Q,[L]);
4522: #else
1.1 takayama 4523: return mmulbys(mulpdo,P,Q,[L]);
1.3 takayama 4524: #endif
1.1 takayama 4525: if(type(Lim=getopt(lim))!=1) Lim=100;
4526: M = vweyl(car(L)); X= M[0]; DX = M[1];
4527: L = cdr(L);
4528: R = 0;
4529: for(I = 0; Q != 0 && I <= Lim; I++){
4530: if(I>Lim){
4531: mycat(["Over", Lim,"derivations!"]);
4532: break;
4533: }
4534: if(I > 0)
4535: P /= I;
4536: if(length(L)==0)
4537: R = radd(R,P*Q);
4538: else
4539: R = radd(R,mulpdo(P,Q,L));
4540: if(X==0) break;
4541: P = mydiff(P,DX);
4542: if(P == 0)
4543: break;
4544: Q = mydiff(Q,X);
4545: }
4546: if(I>Lim) mycat(["Over", Lim,"derivations!"]);
4547: return R;
4548: }
4549:
4550: #else
4551: def mulpdo(P,Q,L);
4552: {
4553: if(type(Q)>3)
1.3 takayama 4554: #ifdef USEMODULE
4555: return mmulbys(os_md.mulpdo,P,Q,[L]);
4556: #else
1.1 takayama 4557: return mmulbys(mulpdo,P,Q,[L]);
1.3 takayama 4558: #endif
1.1 takayama 4559: if(type(Lim=getopt(lim))!=1) Lim=100;
4560: N = length(L);
4561: VO = newvect(2*N);
4562: VN = newvect(2*N);
4563: for(I = J = 0; I < N; J += 2, I++){
4564: M = vweyl(L[I]);
4565: P = subst(P, VO[J]=M[0], VN[J]=strtov("o_"+rtostr(V[J])),
4566: VO[J+1]=M[1], VN[J+1] = strtov("o_"+rtostr(V[J+1])));
4567: }
4568: for(PQ = P*Q, I = 0; I < 2*N; I += 2){
4569: for(R = PQ, J = 1; J < Lim; J++){
4570: R = mydiff(R, VN[I+1])/J;
4571: if(R == 0)
4572: break;
4573: R = mydiff(R, VO[I]);
4574: if(R == 0)
4575: break;
4576: PQ = radd(PQ,R);
4577: }
4578: if(I==Lim) mycat(["Over", Lim,"derivations!"]);
4579: PQ = red(subst(PQ,VN[I],VO[I],VN[I+1],VO[I+1]));
4580: }
4581: }
4582: #endif
4583:
4584: def transpdosub(P,LL,K)
4585: {
4586: Len = length(K)-1;
4587: if(Len < 0 || P == 0)
4588: return P;
4589: KK=K[Len];
4590: if(type(KK)==4){
4591: KK0=KK[0]; KK1=KK[1];
4592: }else{
4593: L = vweyl(LL[Len]);
4594: KK0=L[1]; KK1=K[Len];
4595: }
4596: Deg = mydeg(P,KK0);
4597: K1 = reverse(cdr(reverse(K)));
4598: R = transpdosub(mycoef(P,0,KK0),LL,K1);
4599: for(I = M = 1; I <= Deg ; I++){
4600: M = mulpdo(M,KK1,LL);
4601: S = mycoef(P,I,KK0);
4602: if(Len > 0)
4603: S = transpdosub(S,LL,K1);
4604: R = radd(R,mulpdo(S,M,LL));
4605: }
4606: return R;
4607: }
4608:
4609: def transpdo(P,LL,K)
4610: {
4611: if(type(K[0]) < 4)
4612: K = [K];
4613: Len = length(K)-1;
4614: K1=K2=[];
4615: if(type(LL)!=4) LL=[LL];
4616: if(type(LL[0])!=4) LL=[LL];
4617: if(getopt(ex)==1){
4618: for(LT=LL, KT=K; KT!=[]; LT=cdr(LT), KT=cdr(KT)){
4619: L = vweyl(LL[J]);
4620: K1=cons([L[0],car(KT)[0]],K1);
4621: K2=cons([L[1],car(KT)[1]],K2);
4622: }
4623: K2=append(K1,K2);
4624: }else{
4625: for(J = length(K)-1; J >= 0; J--){
4626: L = vweyl(LL[J]);
4627: if(L[0] != K[J][0])
4628: K1 = cons([L[0],K[J][0]],K1);
4629: K2 = cons(K[J][1],K2);
4630: }
4631: P = mulsubst(P, K1);
4632: }
4633: return transpdosub(P,LL,K2);
4634: }
4635:
4636: def translpdo(P,LL,M)
4637: {
4638: S=length(LL);
4639: L0=newvect(S);L1=newvect(S);
4640: K=newvect(S);
4641: for(J=0;J<S;J++){
4642: L = vweyl(LL[J]);
4643: L0[J]=L[0];
4644: L1[J]=L[1];
4645: }
4646: K=rmul(M,L0);
4647: for(T=[],J=0;J<S;J++)
4648: T=cons([L0[J],K[J]],T);
4649: P=mulsubst(P,T);
4650: K=rmul(myinv(M),L1);
4651: for(T=[],J=0;J<S;J++)
4652: T=cons([L1[J],K[J]],T);
4653: return mulsubst(P,T);
4654: }
4655:
4656: /*
4657: return [R, M, S] : R = M*P - S*Q
4658: deg(R,X) < deg(Q,X)
4659: */
4660: def rpdiv(P,Q,X)
4661: {
4662: if(P == 0)
4663: return [0,1,0];
4664: DQ = mydeg(Q,X);
4665: CO = mycoef(Q,DQ,X);
4666: S = 0;
4667: while((DP = mydeg(P,X)) >= DQ){
4668: R = mycoef(P,DP,X)/CO;
4669: S = radd(S,R*X^(DP-DQ));
4670: P = radd(P, -R*Q*X^(DP-DQ));
4671: }
4672: Lcm = lcm(dn(S),dn(P));
4673: Gcd = gcd(nm(S),nm(P));
4674: return [red(P*Lcm/Gcd), red(Lcm/Gcd),red(S*Lcm/Gcd)];
4675: }
4676:
1.3 takayama 4677: def texbegin(T,S)
4678: {
4679: if(type(Opt=getopt(opt))==7) Opt="["+Opt+"]\n";
4680: else Opt="\n";
4681: return "\\begin{"+T+"}"+Opt+S+"%\n\\end{"+T+"}\n";
4682: }
4683:
1.1 takayama 4684: def mygcd(P,Q,L)
4685: {
1.3 takayama 4686: if((Dvi=getopt(dviout))==3 || Dvi==-3){ /* dviout=3 */
4687: if((Rev=getopt(rev))!=1) Rev=0;
4688: R=mygcd(P,Q,L|rev=Rev);
4689: if(type(L)<2) Var=0;
4690: else if(type(L)==2){
4691: Val=L;L=[0,L];
4692: }else if(type(L)==4){
4693: L=vweyl(L);
4694: Var=[[L[1],"\\partial"]];
4695: }
4696: S=mat([P],[Q]);T=mat([R[0]],[0]);
4697: M=mat([R[1],R[2]],[R[3],R[4]]);
4698: if(type(Val)==4)
4699: N=mdivisor(M,L|trans=1)[1];
4700: else N=myinv(M);
4701: Tb=str_tb(mtotex(S|var=Var),0);
4702: str_tb("&="+mtotex(N|var=Var)+mtotex(T|var=Var)+",\\\\\n",Tb);
4703: str_tb(mtotex(T|var=Var),Tb);
4704: str_tb("&="+mtotex(M|var=Var)+mtotex(S|var=Var)+".",Tb);
4705: Out=str_tb(0,Tb);
4706: if(Dvi<0) return Out;
4707: dviout(Out|eq="align*");
4708: return 1;
4709: }
4710: if((type(Dvi)==1||Dvi==0) && getopt(rev)!=1) V=[[P,Q]];
4711: else V=0;
4712: if(L==0){ /* integer case */
4713: if(type(P) > 1 || type(Q) > 1 || Q==0 /* P <= 0 || Q <= 0 */
1.1 takayama 4714: || dn(P) > 1 || dn(Q) > 1)
4715: return 0;
4716: CPP = CQQ = 1; CQP = CPQ = 0;
4717: P1 = P; Q1 = Q;
4718: /* P1 = CPP*P + CPQ*Q
1.3 takayama 4719: Q1 = CQP*P + CQQ*Q */
4720: while(Q1 != 0){
1.1 takayama 4721: Div1 = idiv(P1,Q1); Div2 = irem(P1,Q1);
1.3 takayama 4722: if(type(V)==4) V=cons([Div1,Div2],V);
1.1 takayama 4723: P1 = Q1 ; Q1 = Div2;
4724: TP = CQP; TQ = CQQ;
4725: CQP = CPP-Div1*CQP;
4726: CQQ = CPQ-Div1*CQQ;
4727: CPP = TP; CPQ = TQ;
4728: }
1.3 takayama 4729: if(V!=0){
4730: V=reverse(V);
4731: if((DVI=abs(Dvi))==0) return V;
4732: PT=P;QT=Q;
4733: if(DVI==1 || DVI==2){
4734: Tb=str_tb(0,0);
4735: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
4736: T=car(V);
4737: if(C++) str_tb("\\allowdisplaybreaks\\\\\n",Tb);
4738: if(DVI==1){
4739: Qs=rtostr(QT);
4740: if(QT<0) Qs="("+Qs+")";
4741: if(T[1]>0) Qs=Qs+"+";
4742: if(T[1]!=0) Qs=Qs+rtostr(T[1]);
4743: str_tb(rtostr(PT)+"&="
4744: +rtostr(T[0])+"\\times"+Qs,Tb);
4745: }else{
4746: N=mat([T[0],1],[1,0]);
4747: if(C==1){
4748: str_tb(S0=mtotex(mat([PT],[QT])),Tb);
4749: M=N;
4750: }
4751: str_tb("&=",Tb);
4752: if(C>1) str_tb(mtotex(M),Tb);
4753: str_tb(mtotex(N),Tb);
4754: str_tb(S=mtotex(mat([QT],[T[1]])),Tb);
4755: if(C>1){
4756: str_tb("=",Tb);
4757: str_tb(mtotex(M=M*N),Tb);
4758: str_tb(S,Tb);
4759: }
4760: }
4761: PT=QT;QT=T[1];
4762: }
4763: if(DVI==2){
4764: str_tb(",\\allowdisplaybreaks\\\\\n"+S+"&=",Tb);
4765: str_tb(mtotex(myinv(M)),Tb);
4766: str_tb(S0,Tb);
4767: }
4768: Out=str_tb(0,Tb);
4769: if(Dvi>0){
4770: dviout(Out|eq="align*");
4771: return 1;
4772: }
4773: return Out;
4774: }
4775: }
4776: if(P1<0) return [-P1,-CPP,-CPQ,CQP,CQQ];
1.1 takayama 4777: return [P1, CPP, CPQ, CQP, CQQ];
4778: }
1.3 takayama 4779: if(type(L) == 2) /* polynomical case */
1.1 takayama 4780: L = [0,L];
4781: if(getopt(rev)==1 && L[0]!=0){
4782: R=mygcd(adj(P,L),adj(Q,L),L);
4783: return [adj(R[0],L),adj(R[1],L),adj(R[2],L),adj(R[3],L),adj(R[4],L)];
4784: }
4785: if(type(P) == 3)
4786: P = red(P);
4787: if(type(Q) == 3)
4788: Q = red(Q);
1.3 takayama 4789: CP=newvect(2,[1/dn(P),0]); CQ=newvect(2,[0,1/dn(Q)]);
4790: P=PT=nm(P); Q =QT=nm(Q);
1.1 takayama 4791: L = vweyl(L);
4792: while(Q != 0){
4793: R = divdo(P,Q,L);
1.3 takayama 4794: if(type(V)==4) V=cons(R,V);
4795: /* R[1] = R[2]*P - R[0]*Q
4796: = R[2]*(CP[0]*P0+CP[1]*Q0) - R[0]*(CQ[0]*P0+CQ[1]*Q0) */
4797: /*
4798: P(n) |0 1 | P(n-1)
4799: = | |
4800: R[1] |R[2] -R[0]| P(n)
4801: P(n+1) = R[1], P(n) = P, P(n-1) = Q
4802: */
1.1 takayama 4803: P = Q;
4804: Q = R[1];
4805: {
4806: CT = dupmat(CQ);
4807: CQ = [R[2]*CP[0]-muldo(R[0],CQ[0],L),
1.3 takayama 4808: R[2]*CP[1]-muldo(R[0],CQ[1],L)];
1.1 takayama 4809: CP = CT;
4810: }
4811: }
1.3 takayama 4812: if(V!=0){
4813: V=reverse(V);
4814: if((DVI=abs(Dvi))==0) return V;
4815: if(type(L[0])<1) Var=L[1];
4816: else Var=[L[1],"\\partial"];
4817: if(DVI==1 || DVI==2){
4818: Tb=str_tb(0,0);
4819: PT=car(V)[0];QT=car(V)[1];
4820: for(C=0,V=cdr(V);V!=[];V=cdr(V)){
4821: T=car(V);
4822: if(C++) str_tb("\\allowdisplaybreaks\\\\\n",Tb);
4823: if(DVI==1){
4824: if(T[2]!=1){
4825: str_tb(monototex(T[2]),Tb);
4826: str_tb("(",Tb);
4827: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
4828: str_tb(")&=",Tb);
4829: }else{
4830: str_tb(fctrtos(PT|var=Var,TeX=2),Tb);
4831: str_tb("&=",Tb);
4832: }
4833: str_tb("(",Tb);
4834: str_tb(fctrtos(T[0]|var=Var,TeX=2),Tb);
4835: str_tb(")(",Tb);
4836: str_tb(fctrtos(QT|var=Var,TeX=2),Tb);
4837: if(T[1]!=0){
4838: str_tb(")+(",Tb);
4839: str_tb(fctrtos(T[1]|var=Var,TeX=2),Tb);
4840: }
4841: str_tb(")",Tb);
4842: }else{
4843: N=mat([red(T[0]/T[2]),1],[1,0]);
4844: if(C==1){
4845: str_tb(S0=mtotex(mat([PT],[QT])|var=Var),Tb);
4846: M=N;
4847: }
4848: str_tb("&=",Tb);
4849: if(C>1) str_tb(mtotex(M),Tb);
4850: str_tb(mtotex(N|var=Var),Tb);
4851: str_tb(S=mtotex(mat([QT],[T[1]])|var=Var),Tb);
4852: if(C>1){
4853: str_tb("=",Tb);
4854: str_tb(mtotex(M=muldo(M,N,L)|var=Var),Tb);
4855: str_tb(S,Tb);
4856: }
4857: }
4858: PT=QT;QT=T[1];
4859: }
4860: if(DVI==2){
4861: FT=fctr(PT);
4862: for(R=1;FT!=[];FT=cdr(FT)){
4863: if(mydeg(car(FT)[0],L[1])<1)
4864: for(J=car(FT)[1];J>0;J--) R*=car(FT)[0];
4865: }
4866: if(R!=1){
4867: str_tb("\\allowdisplaybreaks\\\\\n&=",Tb);
4868: M=muldo(M,mat([R,0],[0,1]),L);
4869: str_tb(mtotex(M|var=Var),Tb);
4870: str_tb(S=mtotex(mat([PT/R],[QT])|var=Var),Tb);
4871: }
4872: str_tb(",\\allowdisplaybreaks\\\\\n"+S+"&=",Tb);
4873: if(type(Var)==4){
4874: N=mdivisor(M,L|trans=1);
4875: N=N[1];
4876: }else
4877: N=myinv(M);
4878: str_tb(mtotex(N|var=Var),Tb);
4879: str_tb(S0,Tb);
4880: }
4881: Out=str_tb(0,Tb);
4882: if(Dvi>0){
4883: dviout(Out|eq="align*");
4884: return 1;
4885: }
4886: return Out;
4887: }
4888: }
4889: Q = rede(P,L);
1.1 takayama 4890: R = red(P/Q);
4891: return [Q,red(CP[0]/R),red(CP[1]/R),red(CQ[0]/R),red(CQ[1]/R)];
4892: }
4893:
4894: def mylcm(P,Q,L)
4895: {
4896: Rev=(getopt(rev)==1)?1:0;
4897: if(Rev==1){
4898: P=adj(P); Q=adj(Q);
4899: }
4900: R = mygcd(P,Q,L);
4901: S=(type(L)<=2)?R[3]*P:muldo(R[3],P,L);
4902: S = nm(S);
4903: if(type(S) <= 1 && type(L) <= 1){
4904: if(S<0) S = -S;
4905: return S;
4906: }
4907: if(type(L) == 2)
4908: return easierpol(S,L);
4909: S=rede(easierpol(S,L[1]),L);
4910: return (Rev==1)?adj(S):S;
4911: }
4912:
4913: def sftpexp(P,LL,F,Q)
4914: {
4915: if(type(LL[0]) < 4)
4916: LL = [LL];
1.4 ! takayama 4917: for(L0=L1=[],LT=LL;LT!=[];LT=cdr(LT)){
! 4918: W=vweyl(car(LT));
! 4919: L0=cons(W,L0);
! 4920: D=mydiff(F,W[0]);
! 4921: if(D!=0) L1=cons(W[1]+Q*D/F,L1);
! 4922: else L1=cons(W[1],L1);
1.1 takayama 4923: }
1.4 ! takayama 4924: return rede(transpdosub(P,L0,L1),L0);
1.1 takayama 4925: }
4926:
4927: def applpdo(P,F,LL)
4928: {
4929: if(type(F)>3)
1.3 takayama 4930: #ifdef USEMODULE
4931: return mmulbys(os_md.applpdo,P,F,[LL]);
4932: #else
1.1 takayama 4933: return mmulbys(applpdo,P,F,[LL]);
1.3 takayama 4934: #endif
1.1 takayama 4935: L = vweyl(LL[0]);
4936: LL = cdr(LL);
4937: Deg = deg(P,L[1]);
4938: S = F;
4939: for(I = R = 0; I <= Deg ; I++){
4940: if(I > 0)
4941: S = mydiff(S,L[0]);
4942: if(LL == [])
4943: R = radd(R,mycoef(P,I,L[1])*S);
4944: else
4945: R = radd(R,applpdo(mycoef(P,I,L[1]), S, LL));
4946: }
4947: return R;
4948: }
4949:
4950: def tranlpdo(P,L,M)
4951: {
4952: N = length(L);
4953: R = size(M);
4954: if(R[0] != N || R[1] != N){
4955: print("Strange size");
4956: return;
4957: }
4958: InvM = M;
4959: if(InvM[1] == 0){
4960: print("Not invertible");
4961: return;
4962: }
4963: XL = newvector(N);
4964: DL = newvector(N);
4965: for(I = 0; I < 0; I++){
4966: R = vweyl(L[I]);
4967: XL[I] = R[0];
4968: DL[I] = R[1];
4969: }
4970: for(I = 0; I < N; I++){
4971: for(J = XX = D0 = 0; J < N; J++){
4972: XX = radd(XX,M[I][J]*XL[J]);
4973: DD = radd(DD, red(InvM[0][I][J]/InvM[1])*DL[J]);
4974: P = mysubst(P,[[XL[I],XX],[DL[I],DD]]);
4975: }
4976: }
4977: return P;
4978: }
4979:
4980: def divdo(P,Q,L)
4981: {
1.3 takayama 4982: if(L==0){
4983: R=P-(P%Q)*Q;
4984: if(R<0){
4985: if(Q>0) R+=Q;
4986: else R-=Q;
4987: }
4988: return [(P-R)/Q,R,1];
4989: }
4990: L = vweyl(L);
4991: if(getopt(rev)==1){
4992: R=divdo(adj(P,L),adj(Q,L),L);
4993: return [adj(R[0],L),adj(R[1],L),R[2]];
4994: }
4995: X = L[0]; DX = L[1];
4996: S = 0;
4997: M = 1;
4998: I = mydeg(Q,DX);
4999: CQ = mycoef(Q,I,DX);
5000: while((J=mydeg(P,DX)) >= I){
5001: C = mycoef(P,J,DX);
5002: SR = red(C/CQ);
1.1 takayama 5003: if(dn(SR) != 1){
1.3 takayama 5004: M *= dn(SR);
5005: P *= dn(SR);
5006: S *= dn(SR);
5007: SR = nm(SR);
5008: }
5009: P -= muldo(SR*(DX)^(J-I),Q,L);
5010: S += SR*(DX)^(J-I);
5011: }
5012: return [S,P,M];
1.1 takayama 5013: }
5014:
5015: def qdo(P,Q,L)
5016: {
5017: L = vweyl(L); DX = L[1]; OD = deg(P,DX);
5018: V = newvect(OD+1);
5019: for(I = 0; I <= OD; I++){
1.3 takayama 5020: if(I)
5021: Q = muldo(DX,Q,L);
5022: S = divdo(Q,P,L);
5023: V[I] = S[1]*DX-S[2]*zz^I;
1.1 takayama 5024: }
5025: for(K = [], I = OD; I >= 0; I--)
5026: K = cons(DX^(I+1), K);
5027: R = lsol(V,K);
5028: S = length(R);
5029: for(I = P1 = 0; I < S; I++){
5030: if(type(R[I]) < 4 && mydeg(R[I],DX) == 0 && R[I] != 0
5031: && (mydeg(R[I],zz) <= mydeg(P,DX)))
5032: P1 = R[I];
5033: else if(type(R[I]) == 4 && R[I][0] == DX)
5034: P2 = R[I][1];
5035: }
5036: T=fctr(P1);
5037: for(I=0, S=length(T), P1=1; I<S; I++){
5038: if(mydeg(T[I][0],zz) > 0)
5039: P1 *= T[I][0]^(T[I][1]);
5040: }
5041: return subst([P1,P2],zz,DX);
5042: }
5043:
5044: def sqrtdo(P,L)
5045: {
5046: L = vweyl(L);
5047: P = toeul(P,L,0);
5048: V = -1;
5049: for(R = 0, Ord = mydeg(P,L[1]); Ord >= 0; Ord--){
5050: Q = coef(P,Ord,L[1]);
5051: M = mydeg(Q,L[0]);
5052: N = mymindeg(Q,L[0]);
5053: if(V < 0)
5054: V = M+N;
5055: else if(V != M+N){
5056: print("Cannot be transformed!");
5057: return;
5058: }
5059: Q = tohomog(red(Q/L[0]^N), [L[0]], z_z);
5060: if(irem(Ord,2))
5061: B = x-z_z;
5062: else
5063: B = x+z_z;
5064: Q = substblock(Q,x,B,z_zz);
5065: if(mydeg(Q,x) > 0){
5066: print("Cannot be transformed!");
5067: return;
5068: }
5069: R += mysubst(Q,[z_zz,x])*L[1]^Ord;
5070: }
5071: return fromeul(R,L,0);
5072: }
5073:
5074: def ghg(A,B)
5075: {
5076: R = dx;
5077: while(length(B)>0){
5078: R = muldo(x*dx+car(B),R,[x,dx]);
5079: B = cdr(B);
5080: }
5081: T = 1;
5082: while(length(A)>0){
5083: T = muldo(x*dx+car(A),T,[x,dx]);
5084: A = cdr(A);
5085: }
5086: return R-T;
5087: }
5088:
5089: def ev4s(A,B,C,S,T)
5090: {
5091: R4 = x^2*(x-1)^2;
5092: R3 = x*(x-1)*((2*A-2*B-8)*x-2*A+5);
5093: R2 = (-3/2*(A^2+B^2)+3*A*B+9*A-9*B-29/2+1/4*(S^2+T^2))*x^2
5094: +(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
5095: - (2*A+2*C-5)*(2*A-2*C-3)/4;
5096: 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
5097: +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
5098: #if 1
5099: + A^2*B
5100: #endif
5101: - B*C^2 - A^3/2+(2*A-3)*(S^2+T^2)/8;
5102: /* OK? for the above term added */
5103: R0 = -(A-B-1-S)*(A-B-1+S)*(A-B-1-T)*(A-B-1+T)/16;
5104: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
5105: }
5106:
5107: def b2e(A,B,C,S,T)
5108: {
5109: R4 = x^2*(x-1)^2;
5110: R3 = x*(x-1)*(2*x-1)*(2*c-5);
5111: R2 = (-6*C^2+24*C-25+1/2*S^2+1/2*T^2)*x^2
5112: +(6*C^2-24*C+25-1/2*S^2-1/2*T^2-A^2+B^2+A-B)*x
5113: +A^2-C^2-A+4*C-15/4;
5114: R1 = (2*C-3)*(2*C^2-6*C+5-1/2*S^2-1/2*T^2)*x
5115: +(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);
5116: R0 = -(2-2*C+S+T)*(2-2*C-S-T)*(2-2*C+S-T)*(2-2*C-S+T)/16;
5117: return (R4*dx^4-R3*dx^3-R2*dx^2-R1*dx-R0);
5118: }
5119:
5120:
5121: /*
5122: T^m = T(T-1)....(T-m+1)
5123: f(t) -> g(t)
5124:
5125: f(t) = a_mt^m + ... + a_1t+a_0
5126: g(x*dx) = a_m*x^m*dx^m + ... + a_1*x*dx+a_0
5127:
5128: ret: x(x-1)...(x-i+1)
5129: */
5130: def sftpow(X,I)
5131: {
5132: R = 1;
5133: for(J=0; J<I;J++)
5134: R *= X-J;
5135: return(R);
5136: }
5137:
5138: /*
5139: ret: x(x+K)(x+2*k)...(x+(i-1)*k)
5140: */
5141: def sftpowext(X,I,K)
5142: {
5143: R = 1;
5144: for(J=0; J<I;J++)
5145: R *= X+K*J;
5146: return(R);
5147: }
5148:
5149: def polinsft(F,A)
5150: {
5151: R = 0;
5152: while(F != 0){
5153: D = mydeg(F,A);
5154: C = mycoef(F,D,A);
5155: R += C*A^D;
5156: F -= C*sftpow(A,D);
5157: }
5158: return R;
5159: }
5160:
5161: def pol2sft(F,A)
5162: {
5163: S=getopt(sft);
5164: if(type(S)<0 || type(S)>2) S=1;
5165: R = 0;
5166: for(I = mydeg(F,A); I >= 0; I--)
5167: R = R*(A-I*S) + mycoef(F,I,A);
5168: return R;
5169: }
5170:
5171: def binom(P,N)
5172: {
5173: if(type(N)!=1 || N<0) return 1;
5174: for(S=1;N>0;N--,P-=1) S*=P/N;
5175: return red(S);
5176: }
5177:
5178: def expower(P,R,N)
5179: {
5180: if(type(N)!=1 || N<0) return 0;
5181: for(S=S0=K=1;K<=N;K++,R-=1){
5182: S0*=P*R/K;S+=S0;
5183: }
5184: return red(S);
5185: }
5186:
5187: def seriesHG(A,B,X,N)
5188: {
5189: if(type(N)!=1 || N<0) return 0;
5190: for(K=0,S=S0=1;K<N;K++){
5191: for(T=A; T!=[]; T=cdr(T)) S0*=car(T)+K;
5192: for(T=B; T!=[]; T=cdr(T)) S0/=car(T)+K;
5193: S0=red(S0*X/(K+1));
5194: DN=dn(S0);
5195: S=red((red(S*DN)+nm(S0))/DN);
5196: }
5197: }
5198:
1.3 takayama 5199: def evalred(F)
5200: {
5201: Opt=getopt(opt);
5202: if(type(Opt)!=4){
5203: Opt=[];
5204: }else if(length(Opt)==2 && type(Opt[0])!=4) Opt=[Opt];
5205: for(;;){
1.4 ! takayama 5206: G=mysubst(F,[[sin(0),0],[tan(0),0],[asin(0),0],[atan(0),0],[sinh(0),0],[tanh(0),0],
! 5207: [log(1),0],[cos(0),1],[cosh(0),1],[exp(0),1]]);
1.3 takayama 5208: for(Rep=Opt; Rep!=[]; Rep=cdr(Rep))
5209: G=subst(G,car(Rep)[0],car(Rep)[1]);
5210: Var=vars(G);
5211: for(V=Var; V!=[]; V=cdr(V)){
5212: if(functor(car(V))!=pow || (P=args(car(V))[0])!=1) continue;
5213: G=subst(G,car(V),1);
5214: }
5215: if(G==F) return F;
5216: F=G;
5217: }
5218: }
5219:
5220: def seriesMc(F,N,V)
5221: {
5222: if(type(V)<4) V=[V];
5223: V=reverse(V);
5224: L=length(V);
5225: if(type(Opt=getopt(evalopt))!=4) Opt=[];
5226: P=newvect(L);
5227: G=newvect(L+1);
5228: G[0]=F;
5229: for(I=0;I<L;I++)
5230: G[I+1]=eval(evalred(subst(G[I],V[I],0)|opt=Opt));
5231: R=G[L];
5232: for(;;){
5233: for(M=0,I=0;I<L;I++){
5234: M+=P[I];
5235: if(M==N) break;
5236: }
5237: if(M<N){
5238: P[L-1]++;
5239: G[L-1]=mydiff(G[L-1],V[L-1]);
1.4 ! takayama 5240: G[L]=eval(evalred(mysubst(G[L-1],[V[L-1],0])|opt=Opt));
1.3 takayama 5241: }else{
5242: if(I--==0) break;
5243: P[I]++;
5244: G[I]=mydiff(G[I],V[I]);
5245: while(I++<L){
1.4 ! takayama 5246: G[I]=eval(evalred(mysubst(G[I-1],[V[I-1],0])|opt=Opt));
1.3 takayama 5247: if(I<L) P[I]=0;
5248: }
5249: }
5250: K=1;
5251: for(I=0;I<L;I++) K*=V[I]^P[I]/fac(P[I]);
5252: R+=G[L]*K;
5253: }
5254: return R;
5255: }
5256:
5257: def seriesTaylor(F,N,V)
5258: {
5259: G=F;
5260: if(isvar(V)) V=[V];
5261: if(length(V)==2 && type(car(V))!=4 && !isvar(V[1])) V=[V];
5262: for(V0=V1=[];V!=[];V=cdr(V)){
5263: if(type(T=car(V))!=4) T=[T];
5264: V0=cons(X=car(T),V0);
5265: if(length(T)==1 || T[1]==0){
5266: V1=cons(X,V1);continue;
5267: }
5268: S=my_tex_form(-T[1]);
5269: if(str_char(S,0,"-")!=0) S="+"+S;
5270: S="("+my_tex_form(X)+S+")";
5271: V1=cons([X,S],V1);
5272: F=red(subst(F,T[0],T[0]+T[1]));
5273: }
5274: V0=reverse(V0);V1=reverse(V1);
5275: F=seriesMc(F,N,V0|option_list=getopt());
5276: if(getopt(frac)==0) F=frac2n(F);
5277: T=getopt(dviout);
5278: if(type(T)!=1) T=0;
5279: F=fctrtos(F|var=V1,rev=1,TeX=(T==0||T==2)?2:3);
5280: if(getopt(small)==1) F=str_subst(F,"\\frac{","\\tfrac{");
5281: if(T<0 || T==1) F="\\begin{align}\\begin{split}\n"+
5282: my_tex_form(G)+"&="+F+"+\\cdots\n\\end{split}\\end{align}\n";
5283: if(T==1) dviout(F);
5284: else if(T==1) dviout(F|eq=4);
5285: return F;
5286: }
5287:
1.1 takayama 5288: def toeul(F,L,V)
5289: {
5290: L = vweyl(L);
5291: X = L[0]; DX = L[1];
5292: I = mydeg(F,DX);
5293: if(V == "infty"){
5294: for(II=I; II>=0; II--){
5295: J = mydeg(P=mycoef(F,I,DX),X);
5296: if(II==I) S=II-J;
5297: else if(P!=0 && II-J>S) S=II-J;
5298: }
5299: F *= X^S;
5300: R = 0;
5301: for( ; I >= 0; I--)
5302: R += red((mysubst(mycoef(F,I,DX),[X,1/X])*(x*DX)^I));
5303: return(subst(pol2sft(R,DX),DX,-DX));
5304: }
5305: F = subst(F,X,X+V);
5306: for(II=I; II>=0; II--){
5307: J = mymindeg(P=mycoef(F,II,DX),X);
5308: if(II==I) S=II-J;
5309: else if(P!=0 && II-J>S) S=II-J;
5310: }
5311: F *= X^S;
5312: R = 0;
5313: for( ; I >= 0; I--)
5314: R += (red(mycoef(F,I,DX)/X^I))*DX^I;
5315: return pol2sft(R,DX);
5316: }
5317:
5318: /*
5319: def topoldif(P,F,L)
5320: {
5321: L = vweyl(L);
5322: P = nm(red(P));
5323: while(deg(P,L[1]) > 0){
5324: R = coef(P,0,L[0]);
5325: Q = red((P-R)/(F*L[0]);
5326: P = nm(Q)*zz+F*R*dn(Q);
5327: }
5328: }
5329: */
5330:
5331: def fromeul(P,L,V)
5332: {
5333: if(P == 0)
5334: return 0;
5335: L = vweyl(L);
5336: X = L[0]; DX = L[1];
5337: I = mydeg(P,DX);
5338: if(V == "infty"){
5339: P = subst(P,DX,-DX);
5340: J = mydeg(P,X);
5341: P = red(mysubst(P,[X,1/X])*X^J);
5342: }
5343: R = mycoef(P,0,DX);
5344: S = 1;
5345: for(S = J = 1; J <= I; J++){
5346: S = DX*(S*X + mydiff(S,DX));
5347: R += mycoef(P,J,DX)*S;
5348: }
5349: while(mycoef(R,0,X) == 0)
5350: R = tdiv(R,X);
5351: if(V != "infty" && V != 0)
5352: R = mysubst(R,[X,X-V]);
5353: return R;
5354: }
5355:
5356: def sftexp(P,L,V,N)
5357: {
5358: L = vweyl(L); DX = L[1];
5359: P = mysubst(toeul(P,L,V),[DX,DX+N]);
5360: return fromeul(P,L,V);
5361: }
5362:
5363:
5364: def fractrans(P,L,N0,N1,N2)
5365: {
5366: L = vweyl(L);
5367: if(N2 != "infty"){
5368: if(N0 == "infty")
5369: N0 = 0;
5370: else
5371: N0 = red(1/(N0-N2));
5372: if(N1 == "infty")
5373: N1 = 0;
5374: else
5375: N1 = red(1/(N1-N2));
5376: P = mysubst(P,[L[0],L[0]+N2]);
5377: P = fromeul(toeul(P,L,"infty"),L,0);
5378: }
5379: if(N0 != 0){
5380: P = mysubst(P,[L[0],L[0]+N0]);
5381: N1 -= N0;
5382: }
5383: if(N1 != 1)
5384: P = mysubst(P,[[L[0],L[0]/N1],[L[1],L[1]*N1]]);
5385: return P;
5386: }
5387:
5388: def soldif(P,L,V,Q,N)
5389: {
5390: L = vweyl(L); X = L[0]; DX = L[1];
5391: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
5392: DEG = mydeg(P,X);
5393: P0 = newvect(DEG+1);
5394: for(I = 0; I <= DEG; I++)
5395: P0[I] = coef(P,I,X);
5396: if(P0[0] == 0)
5397: return 0;
5398: if(subst(P0[0],DX,0) != 0){
5399: mycat([Q,"is not the exponent at", V])$
5400: return 0;
5401: }
5402: R = newvect(N+1);
5403: R[0] = 1;
5404: for(I = 1; I <= N; I++){
5405: for(S = 0, K = 1; K <= DEG && K <= I; K++)
5406: S += mysubst(P0[K],[DX,I-K])*R[I-K];
5407: S = red(S);
5408: M = mysubst(P0[0],[DX,I]);
5409: if(M != 0){
5410: R[I] = -red(S/M);
5411: if(R1 != 0){
5412: for(S = 0, K = 1; K <= DEG && K <= I; K++)
5413: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
5414: mysubst(P1[K],[DX,I-K])*R[I-K];
5415: R1[I] = -red(S/M);
5416: }
5417: }else{
5418: if(S == 0){
5419: if(R1 != 0){
5420: for(S = 0, K = 1; K <= DEG && K <= I; K++)
5421: S += mysubst(P0[K],[DX,I-K])*R1[I-K] +
5422: mysubst(P1[K],[DX,I-K])*R[I-K];
5423: }
5424: if(S == 0)
5425: continue;
5426: }
5427: R1 = newvect(N+1);
5428: for(K = 0; K < I; K++){
5429: R1[K] = R[K];
5430: R[K] = 0;
5431: }
5432: R1[I] = 0;
5433: P1 = newvect(DEG);
5434: for(K = 0; K <= DEG; K++)
5435: P1[K] = mydiff(P0[K], DX);
5436: M = mysubst(P1[0],[DX,I]);
5437: if(M == 0){
5438: cat(["multiple log at ", I])$
5439: return 0;
5440: }
5441: R[I] = -red(S/M);
5442: }
5443: }
5444: if(R1 != 0)
5445: return [R1, R];
5446: else
5447: return R;
5448: }
5449:
5450: def chkexp(P,L,V,Q,N)
5451: {
5452: L = vweyl(L); X = L[0]; DX = L[1];
5453: P = mysubst(toeul(P,L,V),[DX,DX+Q]);
5454: P = fromeul(P,L,0);
5455: D = mydeg(P,DX);
5456: Z = mindeg(mycoef(P,D,DX), X) - (D-N);
5457: R = [];
5458: for(I = 0; I < Z; I++){
5459: S = mycoef(P,I,X);
5460: if(S != 0){
5461: for(J = mydeg(S,DX); J >= 0; J--){
5462: T = mycoef(S,J,DX);
5463: if(T != 0)
5464: R = cons(T,R);
5465: }
5466: }
5467: }
5468: return R;
5469: }
5470:
1.4 ! takayama 5471:
! 5472: def sqrtrat(P)
! 5473: {
! 5474: if(P==0) return 0;
! 5475: if(type(P)==3||type(P)==2){
! 5476: P=red(P);
! 5477: if(imag(dn(P))!=0||imag(nm(P))!=0){
! 5478: if(imag(dn(P))==0&&real(P)!=0){
! 5479: F=red(imag(P)/real(P));
! 5480: if(F==3^(1/2)||F==-3^(1/2)){
! 5481: if(eval(real(P))<0)
! 5482: return -real(P)+imag(P)*@i;
! 5483: else{
! 5484: if(eval(imag(P))>0) return imag(P)+real(P)*@i;
! 5485: else return -imag(P)-real(P)*@i;
! 5486: }
! 5487: }
! 5488: }
! 5489: return [];
! 5490: }
! 5491: F=fctr(dn(P));
! 5492: R=sqrtrat(car(F)[0]);
! 5493: for(F=cdr(F);F!=[];F=cdr(F)){
! 5494: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
! 5495: else return [];
! 5496: }
! 5497: F=fctr(nm(P));
! 5498: R=sqrtrat(car(F)[0])/R;
! 5499: for(F=cdr(F);F!=[];F=cdr(F)){
! 5500: if(!iand(car(F)[1],1)) R*=car(F)[0]^(car(F)[1]/2);
! 5501: else return [];
! 5502: }
! 5503: return R;
! 5504: }
! 5505: if(ntype(P)==4){
! 5506: P0=real(P);P1=imag(P)/2;
! 5507: X=makenewv(P);
! 5508: for(R=fctr(X^4-P0*X^2-P1^2);R!=[];R=cdr(R)){
! 5509: RT=car(R)[0];
! 5510: if(deg(RT,X)==1){
! 5511: X=-mycoef(RT,0,X)/mycoef(RT,1,X);
! 5512: return X+P1/X*@i;
! 5513: }
! 5514: if(deg(RT,X)==2){
! 5515: if((D=mycoef(RT,1,X)^2-4*mycoef(RT,2,X)*mycoef(RT,0,X))<0) continue;
! 5516: X=(-mycoef(RT,1,X)+sqrtrat(D))/(2*mycoef(RT,2,X));
! 5517: return X+P1*sqrt2rat(1/X)*@i;
! 5518: }
! 5519: }
! 5520: D=P0^2+4*P1^2;
! 5521: if(P1>0) return ((sqrtrat(D)+P0)/2)^(1/2)+((sqrtrat(D)-P0)/2)^(1/2)*@i;
! 5522: return ((sqrtrat(D)+P0)/2)^(1/2)-((sqrtrat(D)-P0)/2)^(1/2)*@i;
! 5523: }else if(ntype(P)!=0) return [];
! 5524: if(P==1) return P;
! 5525: Dn=dn(P);Nm=nm(P);C=R=1;
! 5526: N=pari(factor,Dn);
! 5527: if(N){
! 5528: for(II=car(size(N))-1;II>=0;II--){
! 5529: if(iand(K=N[II][1],1)){
! 5530: R*=N[II][0];
! 5531: K++;
! 5532: }
! 5533: C/=N[II][0]^(K/2);
! 5534: }
! 5535: }
! 5536: N=pari(factor,Nm);
! 5537: if(N){
! 5538: for(II=car(size(N))-1;II>=0;II--){
! 5539: if(N[II][0]==-1){
! 5540: C*=@i;
! 5541: continue;
! 5542: }
! 5543: K=N[II][1];
! 5544: if(iand(K,1)){
! 5545: R*=N[II][0];
! 5546: K--;
! 5547: }
! 5548: if(K!=0) C*=N[II][0]^(K/2);
! 5549: }
! 5550: }
! 5551: if(R!=1) C*=R^(1/2);
! 5552: return C;
! 5553: }
! 5554:
! 5555: def fctri(F)
! 5556: {
! 5557: R=(iscoef(F,os_md.israt))?fctr(F):[[1,1],[F,1]];
! 5558: if(!iscoef(F,os_md.iscrat)||chkfun("af_noalg",0)==0) return R;
! 5559: X=makenewv(vars(F));
! 5560: for(S=[];R!=[];R=cdr(R)){
! 5561: if(length(Var=vars(R0=car(R)[0])) == 1 && (D=mydeg(R0,Var=car(Var))) > 0){
! 5562: if(imag(T=mycoef(R0,D,Var))!=0) R0/=T;
! 5563: T=af_noalg(real(R0)+imag(R0)*X,[[X,X^2+1]]);
! 5564: if(length(T)>1||T[0][1]>1){
! 5565: T=subst(T,X,@i);
! 5566: for(; T!=[];T=cdr(T)){
! 5567: if(vars(T[0])!=[])
! 5568: S=cons([car(T)[0],car(T)[1]*car(R)[1]],S);
! 5569: }
! 5570: continue;
! 5571: }
! 5572: }
! 5573: S=cons(R[0],S);
! 5574: }
! 5575: return reverse(S);
! 5576: }
! 5577:
1.1 takayama 5578: def getroot(F,X)
5579: {
5580: S=[];
1.4 ! takayama 5581: if(type(Cpx=getopt(cpx))!=1) Cpx=0;
1.1 takayama 5582: M=getopt(mult);
5583: if(type(F) == 3)
5584: F = nm(red(F));
1.4 ! takayama 5585: for(R=fctri(F); length(R)>0; R = cdr(R)){
1.1 takayama 5586: T=car(R);
5587: P=car(T);
5588: I=car(cdr(T));
5589: if(mydeg(P,X)>0){
5590: if(mydeg(P,X)==1){
5591: C = mycoef(P,1,X);
5592: P = X - red(P/C);
1.4 ! takayama 5593: }else if(mydeg(P,X)==2 && Cpx>0){
! 5594: C2=mycoef(P,2,X);C1=mycoef(P,1,X);C0=mycoef(P,0,X);
! 5595: C=sqrt2rat(C1^2-4*C0*C2);
! 5596: C0=[];
! 5597: if(type(C)==0&&ntype(C)==0&&pari(issquare,-C)) C0=sqrt(C);
! 5598: else if(Cpx>1) C0=sqrtrat(C);
! 5599: if(C0==[]&&Cpx>2) C0=C^(1/2);
! 5600: if(C0!=[]){
! 5601: if(M==1)
! 5602: S=cons([I,sqrt2rat((-C1+C0)/(2*C2))],S);
! 5603: else{
! 5604: for(II=I; II>0; II--)
! 5605: S=cons(sqrt2rat((-C1+C0)/(2*C2)),S);
! 5606: }
! 5607: P=sqrt2rat((-C1-C0)/(2*C2));
! 5608: }
! 5609: }else if(mydeg(P,X)==3 && Cpx>1){
! 5610: Omg=(-1+3^(1/2)*@i)/2;
! 5611: PP=P/mycoef(P,3,X);
! 5612: C2=mycoef(PP,2,X)/3;
! 5613: PP=subst(PP,X,X-C2);
! 5614: if((C1=mycoef(PP,1,X))==0){
! 5615: C0=mycoef(PP,0,X);
! 5616: if(real(C0)==0||imag(C0)==0){
! 5617: if(real(C0)==0){
! 5618: PP=getroot(X^3+imag(C0),X);
! 5619: if(length(PP)==3){
! 5620: for(;PP!=[];PP=cdr(PP)){
! 5621: if(imag(PP[0])==0){
! 5622: C0=PP[0]*@i;
! 5623: break;
! 5624: }
! 5625: }
! 5626: if(PP==[]) C0=0;
! 5627: }
! 5628: }else{
! 5629: if(C0>0) C0=C0^(1/3);
! 5630: else C0=-(-C0)^(1/3);
! 5631: }
! 5632: if(C0!=0){
! 5633: if(M==1){
! 5634: S=cons([I,C0-C2],S);
! 5635: S=cons([I,C0*Omg-C2],S);
! 5636: S=cons([I,C0*(-1-Omg)-C2],S);
! 5637: }else{
! 5638: for(II=I; II>0; II--){
! 5639: S=cons(C0-C2,S);
! 5640: S=cons(C0*Omg-C2,S);
! 5641: S=cons(C0*(-1-Omg)-C2,S);
! 5642: }
! 5643: }
! 5644: continue;
! 5645: }
! 5646: }
! 5647: }
! 5648: if(Cpx>2){
! 5649: Q=X^2+(mycoef(PP,1,X)/3)*X+mycoef(PP,0,X)^3;
! 5650: SQ=getroot(Q,X|cpx=2);
! 5651: SQ=SQ[0]^(1/3);SQ2=mycoef(PP,0,X)/SQ;
! 5652: if(M==1){
! 5653: S=cons([I,SQ+SQ2-C2],S);
! 5654: S=cons([I,SQ*Omg+SQ2*(-1-Omg)-C2],S);
! 5655: S=cons([I,SQ*(-1-Omg)+SQ2*Omg-C2],S);
! 5656: }else{
! 5657: for(II=I; II>0; II--){
! 5658: S=cons(SQ+SQ2-C2,S);
! 5659: S=cons(SQ*Omg+SQ2*(-1-Omg)-C2,S);
! 5660: S=cons(SQ*(-1-Omg)+SQ2*Omg-C2,S);
! 5661: }
! 5662: }
! 5663: continue;
! 5664: }
! 5665: }else if(mydeg(P,X)==4 && Cpx>0){
! 5666: C2=mycoef(P,3,X)/(4*mycoef(P,4,X));
! 5667: PP=subst(P,X,X-C2);
! 5668: if(mycoef(PP,1,X)==0){
! 5669: PP=mycoef(PP,4,X)*X^2+mycoef(PP,2,X)*X+(SQ2=mycoef(PP,0,X));
! 5670: SQ=getroot(PP,X|cpx=2);
! 5671: if(length(SQ)==2){
! 5672: if((C0=sqrtrat(SQ[0]))==[]){
! 5673: if(mycoef(PP,1,X)==0){
! 5674: if(SQ2<0) C0=(-SQ2)^(1/4);
! 5675: else C0=SQ2^(1/4)*(1+@i)/2;
! 5676: }
! 5677: else if(Cpx>2) C0=SQ[0]^(1/2);
! 5678: else C0=0;
! 5679: }
! 5680: if((C1=sqrtrat(SQ[1]))==[]){
! 5681: if(mycoef(PP,1,X)==0) C1=-C0;
! 5682: else C1=SQ[1]^(1/2);
! 5683: }
! 5684: if(C0!=0){
! 5685: if(M==1)
! 5686: S=append([[I,C0-C2],[I,-C0-C2],[I,C1-C2],[I,-C1-C2]],S);
! 5687: else{
! 5688: for(II=I; II>0; II--)
! 5689: S=append([C0-C2,-C0-C2,C1-C2,-C1-C2],S);
! 5690: }
! 5691: continue;
! 5692: }
! 5693: }
! 5694: }else{
! 5695: PP/=mycoef(PP,4,X);
! 5696: CC=mycoef(PP,2,X);C1=mycoef(PP,1,X);C0=mycoef(PP,0,X);
! 5697: SQ=getroot(X*(CC+X)^2-4*C0*X-C1^2,X|cpx=Cpx);
! 5698: if(length(SQ)>1){
! 5699: SQ=sqrt2rat(SQ[0]);
! 5700: SQ2=getroot(X^2-SQ,X|cpx=Cpx);
! 5701: if(length(SQ2)>1){
! 5702: C1=SQ2[0]*X-C1/SQ2[0]/2;
! 5703: C0=getroot(X^2+CC/2+SQ/2+C1,X|cpx=Cpx);
! 5704: C1=getroot(X^2+CC/2+SQ/2-C1,X|cpx=Cpx);
! 5705: if(length(C0)>1&&length(C1)>1){
! 5706: C0=[sqrt2rat(C0[0]-C2),sqrt2rat(C0[1]-C2),
! 5707: sqrt2rat(C1[0]-C2),sqrt2rat(C1[1]-C2)];
! 5708: if(M==1) for(II=0;II<4;II++) S=cons([I,C0[II]],S);
! 5709: else for(II=I; II>0; II--) S=append(C0,S);
! 5710: continue;
! 5711: }
! 5712: }
! 5713: }
! 5714: }
1.1 takayama 5715: }
1.4 ! takayama 5716: if(M==1)
1.1 takayama 5717: S=cons([I,P],S);
1.4 ! takayama 5718: else for( ; I>0; I--) S=cons(P,S);
1.1 takayama 5719: }
5720: }
1.4 ! takayama 5721: S=qsort(S);
! 5722: if(M==1) S=reverse(S);
1.1 takayama 5723: return S;
5724: }
5725:
5726: def expat(F,L,V)
5727: {
5728: L = vweyl(L);
5729: if(V == "?"){
5730: Ans = [];
5731:
5732: F = nm(red(F));
5733: S = fromeul(toeul(F,L,"infty"),L,0);
5734: S = mycoef(S,mydeg(S,L[1]),L[1]);
5735: if(mydeg(S,L[0]) > 0)
5736: Ans = cons(["infty", expat(F,L,"infty")],Ans);
5737:
5738: S = mycoef(F,mydeg(F,L[1]), L[1]);
5739: R = getroot(S,L[0]);
5740: for(I = 0; I < length(R); I++){
5741: if(I > 0 && R[I-1] == R[I])
5742: continue;
5743: if(mydeg(R[I], L[0]) <= 0)
5744: Ans = cons([R[I], expat(F,L,R[I])], Ans);
5745: else
5746: Ans = cons([R[I]], Ans);
5747: }
5748: return Ans;
5749: }
5750: return getroot(subst(toeul(F,L,V),L[0],0),L[1]);
5751: }
5752:
5753: def polbyroot(P,X)
5754: {
5755: R = 1;
5756: while(length(P)){
5757: R *= X-car(P);
5758: if(type(R)>2) R = red(R);
5759: P = cdr(P);
5760: }
5761: return R;
5762: }
5763:
5764: def polbyvalue(P,X)
5765: {
5766: R = 1; S = 0;
5767: while(length(P)){
5768: T = car(P);
5769: V0 = T[1] - mysubst(S,[X,T[0]]);
5770: if(V0 != 0){
5771: if(type(R) > 2) R = red(R);
5772: V1 = mysubst(R,[X,T[0]]);
5773: if(V1 == 0){
5774: erno(0);
5775: return 0;
5776: }
5777: S += (V0/V1)*R;
5778: if(type(S) > 2) S = red(S);
5779: }
5780: R *= X - T[0];
5781: P = cdr(P);
5782: }
5783: return S;
5784: }
5785:
5786:
5787: def pcoef(P,L,Q)
5788: {
5789: if(L==0)
5790: return 1;
5791: Coef=TP=0;
5792: if(type(Q)>=4){
5793: TP=1;
5794: V=Q[0];
5795: if(type(V)==4)
5796: V=ltov(V);
5797: else V=dupmat(V);
5798: N=length(V);
5799: if(type(Q[1])==5) MR=dupmat(Q[1]);
5800: else{
5801: MR=newvect(N);
5802: for(K=Q[1], I=0; I< N; I++){
5803: MR[I] = car(K);
5804: K = cdr(K);
5805: }
5806: }
5807: }else{
5808: V=ltov(vars(P));
5809: N=length(V);
5810: MR=newvect(N);
5811: for(I=0;I<N;I++){
5812: MR[I]=mydeg(Q,V[I]);
5813: Q=mycoef(Q,MR[I],V[I]);
5814: }
5815: if(type(Q)>1) return 0;
5816: }
5817: /* mycat([V,MR]); */
5818: if(L==1){
5819: for(I=0;I<N;I++)
5820: P=mycoef(P,MR[I],V[I]);
5821: return P;
5822: }
5823: for(I=1;I<N;I++){ /* sorted by required degrees */
5824: for(K1=MR[I],K2=V[I],J=I-1; J>=0 && MR[J]<K1; J--);
5825: for(II=I-1;II>J;II--){
5826: MR[II+1]=MR[II];V[II+1]=V[II];
5827: }
5828: MR[II+1]=K1;V[II+1]=K2;
5829: }
5830: for(NN=N; N>0 && MR[N-1]==0; N--);
5831: Mon=[];Coe=[];Q=P;
5832: while(Q!=0){
5833: M=newvect(N);
5834: for(R=Q,F=I=0,MT=1;I<NN;I++){
5835: K=mydeg(R,V[I]);
5836: R=mycoef(R,K,V[I]);
5837: if(I<N) M[I]=K;
5838: if(K>0) MT*=V[I]^K;
5839: if(K>MR[I]) F=1;
5840: }
5841: Q -= R*MT;
5842: if(F==0){
5843: Mon=cons(M,Mon);
5844: Coe=cons(R,Coe);
5845: }
5846: }
5847: Mon=ltov(reverse(Mon));
5848: Coe=ltov(reverse(Coe));
5849: Len=length(Mon);
5850: S=newvect(Len);
5851: for(JL=0; JL<Len;JL++){
5852: if(L*Mon[JL][0]<MR[0]) break;
5853: }
5854: S[0]=L;
5855:
5856: K0=Mon[0][0];
5857: K=L*K0-MR[0];
5858: for(I=II=0;II<Len && K>=0;II++){
5859: if((K1=K0-Mon[0][II])>0){
5860: while(K>K1 && S[I]>0){
5861: S[I]--;S[II]++;
5862: K-=K1;
5863: I=II;
5864: K0=Mon[0][II];
5865: }
5866: }else break;
5867: }
5868:
5869: I=0;
5870: while(1){
5871: for(T=T0=J=JP=0; J<Len; J++){
5872: if(S[J]!=0){
5873: if(T0==0 && J>=JL) return Coef;
5874: JP=J;T0=1;
5875: T+=S[J]*Mon[J][I];
5876: }
5877: }
5878: if(T==MR[I]){
5879: if(++I<N) continue;
5880: for(TT=1,J=1; J<=L; J++) /* find a solution */
5881: TT*=J;
5882: for(J=0;J<Len;J++){
5883: if(S[J]!=0){
5884: TT*=Coe[J]^S[J];
5885: for(II=S[J]; II>1; II--)
5886: TT/=II;
5887: }
5888: }
5889: Coef+=TT;
5890: if(TP==1 && type(Coef)==3) Coef=red(Coef);
5891: if(JP<Len-2 && S[JP]>1){
5892: S[JP]-=2;S[JP+1]++;S[JP+2]++;
5893: }else{
5894: for(JT=JP-1;JT>=0&&S[JT]==0;JT--);
5895: if(JT<0) break;
5896: if(JT==JP-1){
5897: S[JT]--;
5898: if(JP<Len-1)
5899: S[JP+1]++;
5900: else
5901: S[JP]++;
5902: }else{
5903: S[JT]--;
5904: S[JT+1]+=S[JP]+1;
5905: S[JP]=0;
5906: }
5907: }
5908: I=0;
5909: continue;
5910: }
5911: if(JP<Len-1){
5912: for(JP1=JP+1;JP1<Len-1;JP1++){
5913: if(Mon[JP1][I]!=Mon[JP][I]) break;
5914: }
5915:
5916: if(I>0 && Mon[JP1][0] < Mon[JP][0]){
5917: S[JP]--;S[Len-1]++;JP=JP-1;
5918: }else{
5919:
5920: S[JP]--;
5921: if(JP1<Len){
5922: S[JP1]++;
5923: }else{
5924: S[JP1-1]++;
5925: }
5926: }
5927: }
5928: if(JP==Len-1){
5929: for(JT=JP-1;JT>=0 && S[JT]==0;JT--);
5930: if(JT<0) break;
5931: S[JT]--;
5932: if(JT==JP-1){
5933: S[JP]++;
5934: }else{
5935: S[JT+1]+=S[JP]+1;
5936: S[JP]=0;
5937: }
5938: }
5939: I=0;
5940: }
5941: return Coef;
5942: }
5943:
5944: def prehombf(P,Q)
5945: {
5946: if((Mem=getopt(mem))!=1 && Mem!=-1)
5947: return prehombfold(P,Q);
5948: /* CT=0; */
5949: if(Q==0) Q=P;
5950: V=ltov(vars(P));
5951: N=length(V);
5952: for(I=1;I<N;I++){ /* sorted by required degrees */
5953: for(K=mydeg(P,V[I]),K1=V[I],J=I-1; J>=0 && mydeg(P,V[J])<K; J--);
5954: for(II=I-1;II>J;II--) V[II+1]=V[II];
5955: V[II+1]=K1;
5956: }
5957: S=newvect(N);T=newvect(N);U=newvect(N);
5958: for(R=P,M=1,Deg=I=0;I<N;I++){ /* extreme vector */
5959: Deg+=(S[I]=mydeg(R,V[I]));
5960: R=mycoef(R,S[I],V[I]);
5961: }
5962: DR=[[-1,0]];
5963: if((R1=N/Deg)!=1){
5964: DR=cons([-R1,0],DR);
5965: Sft=1;
5966: }else Sft=0;
5967: if(Deg%2==0) Sg=1;
5968: else Sg=-1;
5969: for(I=0,R=R2=1,QQ=Q; 2*I+Sft < Deg; I++){
5970: if(Mem==-1){
5971: print(I+1,0);print("/",0);print(idiv(Deg-Sft+1,2),0);print(" ",2);
5972: }
5973: Coef=0;
5974: Q=QQ;
5975: while(Q!=0){
5976: for(R=Q,J=0,RR=1;J<N;J++){
5977: T[J]=mydeg(R,V[J]);
5978: R=mycoef(R,T[J],V[J]);
5979: if(T[J]>0) RR*=V[J]^T[J];
5980: }
5981: Q-=R*RR;
5982: for(J=0,CC=R;J<N;J++){
5983: U[J]=I*S[J]+T[J];
5984: for(II=0; II<T[J]; II++)
5985: CC*=(U[J]-II);
5986: }
5987: /* mycat([I+1,U,CC]); */
5988: CC*=pcoef(P,I+1,[V,U]);
5989: if(Mem==-1) print("*",2);
5990: /* mycat([++CT]); */
5991: Coef+=CC;
5992: }
5993: DR=cons([I,Coef],DR);
5994: DR=cons([-R1-1-I,Sg*Coef],DR);
5995: if(Mem==-1) print("");
5996: }
5997: /* mycat([DR]); */
5998: P = polbyvalue(DR,s);
5999: return fctr(P);
6000: }
6001:
6002: def prehombfold(P,Q)
6003: {
6004: V = vars(P);
6005: if(Q==0) Q=P;
6006: for(Deg=0, R=P, V1=V, DD=[]; V1!=[]; V1=cdr(V1)){
6007: VT = car(V1);
6008: D = mydeg(R,VT);
6009: R = mycoef(R,D,VT);
6010: Deg += D;
6011: X = makev(["d",VT]);
6012: Q = subst(Q,VT,X);
6013: DD=cons([VT,X],DD);
6014: }
6015: DR=[[-1,0]];
6016: NV=length(V);
6017: if((R1=NV/Deg)!=1){
6018: DR=cons([-R1,0],DR);
6019: Sft=1;
6020: }else
6021: Sft=0;
6022: if(Deg%2==0)
6023: Sg=1;
6024: else Sg=-1;
6025: for(I = 0, R=R2=1; 2*I+Sft < Deg; I++){
6026: R = R2;
6027: R2 = R*P;
6028: S = appldo(Q,R2,DD);
6029: QQ = sdiv(S,R);
6030: DR=cons([I,QQ],DR);
6031: DR=cons([-R1-1-I,Sg*QQ],DR);
6032: }
6033: /* mycat([DR]); */
6034: P = polbyvalue(DR,s);
6035: return fctr(P);
6036: }
6037:
6038: def sub3e(P0,P1,P2,N0,N1,N)
6039: {
6040: R = x^N0*(x-1)^N1*dx^N;
6041: for(V = I = 1, J = 1; I <= N; I++){
6042: S = 0;
6043: M = N-I;
6044: if(I <= N0){
6045: T = mycoef(P0,N0-I,x);
6046: S += T;
6047: R += T*x^(N0-I)*(x-1)^N1*dx^M;
6048: K1 = N0-I+1;
6049: }else
6050: K1 = 0;
6051: if(I <= N1){
6052: T = mycoef(P1,N1-I,x);
6053: S += T;
6054: R += T*x^N0*(x-1)^(N1-I)*dx^M;
6055: K2 = N0-1;
6056: }else
6057: K2 = N-I;
6058: for(K = K1; K <= K2; K++){
6059: if(K == K2){
6060: R += (mycoef(P2,N-I,x)-S)*x^K*(x-1)^(M-K)*dx^M;
6061: continue;
6062: }
6063: R += strtov("r"+rtostr(V))*x^K*(x-1)^(M-K)*dx^M;
6064: S += strtov("r"+rtostr(V++));
6065: }
6066: }
6067: if(V > 1)
6068: mycat([V-1, "accessory parameters: r1,r2,..."]);
6069: return R;
6070: }
6071:
6072: def fuchs3e(P,Q,R)
6073: {
1.3 takayama 6074: return getbygrs([R,P,Q],3);
1.1 takayama 6075: }
6076:
6077: def okubo3e(P,Q,R)
6078: {
1.3 takayama 6079: if(getopt(opt)==1){
6080: N=length(R);
6081: M1=N-length(P);M2=N-length(Q);
6082: V=(M1-1)*(M2-1);
6083: if(V>0) mycat([V, "accessory parameters"]);
6084: return getbygrs([R,cons([M1,0],P),cons([M2,0],Q)],3);
6085: }
1.1 takayama 6086: S = 0;
6087: V = -1;
6088: L = newvect(3,[[],[],[]]);
6089: N = newvect(3,[0,0,0]);
6090: if(type(R) < 4){
6091: I = -1;
6092: V = 3;
6093: }else{
6094: I = 2;
6095: V = -1;
6096: }
6097: for( ; I >= 0; I--){
6098: if(I == 2)
6099: U = R;
6100: else if(I == 1)
6101: U = Q;
6102: else
6103: U = P;
6104: for( ; length(U); U = cdr(U)){
6105: T = car(U);
6106: if( T == "?"){
6107: if(V < 0)
6108: V = I;
6109: else
6110: return 0;
6111: }else{
6112: if(I == 2)
6113: L[I] = cons(-T, L[I]);
6114: else
6115: L[I] = cons(T, L[I]);
6116: S += T;
6117: }
6118: N[I]++;
6119: }
6120: }
6121: if(V == 3){
6122: N[2] = N[0] + N[1];
6123: P2 = x^N;
6124: for(I = 1; I <= N; I++)
6125: P2 += makev([R,I])*x^(N-I);
6126: }else{
6127: if(N[0]+N[1] != N[2]){
6128: print("Number of exponents are wrong",0);
6129: return -1;
6130: }
6131: S -= N[0]*N[1];
6132: if(V < 0){
6133: if(S != 0){
6134: mycat(["Viorate Fuchs relation ->",S]);
6135: return -2;
6136: }
6137: }else{
6138: if(V != 2)
6139: S = -S;
6140: L[V] = cons(S, L[V]);
6141: }
6142: P2 = polinsft(polbyroot(L[2],x),x);
6143: }
6144: P0 = polinsft(mysubst(polbyroot(L[0],x),[x,x+N[1]]),x);
6145: P1 = polinsft(mysubst(polbyroot(L[1],x),[x,x+N[0]]),x);
6146: return sub3e(P0,P1,P2,N[0],N[1],N[2]);
6147: }
6148:
6149: /* N = 2*M (N-M = M) or 2*M+1 (N-M = M+1)
6150: 0 : 0 1 ..... M-1 B B+1 ... B+N-M-2 A
6151: 1 : C C+1 ... C+M-1 0 1 .... N-M-2 N-M-1
6152: */
6153: def eosub(A,B,C,N)
6154: {
6155: M = N%2;
6156: P = [];
6157: Q = [];
6158: P = cons(A,P);
6159: for(I = 0; I < N-M-1; I++)
6160: P = cons(B+I,P);
6161: for(I = 0; I < M; I++)
6162: Q = cons(C+I,Q);
6163: P = okubo3e(P,Q,s);
6164:
6165: C = newvect(2);
6166: L = newvect(2);
6167: C[1] = chkexp(P,[x,dx],0,b,N-M-1);
6168: C[0] = chkexp(P,[x,dx],1,c,M);
6169: for(LL = K = 0; K < 2; K++){
6170: L[K] = length(C[K]);
6171: C[K] = ltov(C[K]);
6172: if(L[K] > LL)
6173: LL = L[K];
6174: }
6175: JJ = 0;
6176:
6177: for(I = 1; Do; I++){
6178: Do = 0;
6179: S = makev(["r",I]);
6180: for(J = JJ; J < LL; J++){
6181: JJ = LL;
6182: for(K = 0; K < 2; K++){
6183: if(J >= L[K] || C[K][J] == 0)
6184: continue;
6185: if(J < JJ)
6186: JJ = J;
6187: if(Do == 1){
6188: CC = C[K];
6189: CC[J] = mysubst(CC[J], [S, Var]);
6190: continue;
6191: }
6192: if(mydeg(C[K][J]) >= 1){
6193: if(mydeg(C[K][J]) > 1){
6194: print("Internal error");
6195: return;
6196: }
6197: Var = getroot(C[K][J],S);
6198: Var = Var[0];
6199: CC = C[K];
6200: CC[J] = 0;
6201: P = mysubst(P, [S, Var]);
6202: Do = 1;
6203: J = JJ - 1;
6204: K++;
6205: }
6206: }
6207: }
6208: }
6209: if(JJ != L){
6210: print("Internal error (non Rigid)");
6211: return;
6212: }
6213: return P;
6214: }
6215:
6216: def even4e(X,Y){
6217: if(length(X) != 4 || length(Y) != 2){
6218: print("Usage: even4e([a,b,c,d],[e,f])");
6219: print("0: 0 1 e f");
6220: print("1; 0 1 * *+1");
6221: print("infty: a b c d");
6222: return;
6223: }
6224: S = -3;
6225: for(I = 0; I < 4; I++){
6226: S += X[I];
6227: if(I < 2)
6228: S += Y[I];
6229: }
6230: S = -S/2;
6231: P = okubo3e(Y,[S,"?"],X);
6232: T = chkexp(P,x,1,S,2);
6233: T = getroot(T[0],r1);
6234: return mysubst(P,[r1,T[0]]);
6235: }
6236:
6237: def odd5e(X,Y)
6238: {
6239: if(length(X) != 5 || length(Y) != 2){
6240: print("Usage: spec6e([a,b,c,d,e],[f,g])");
6241: print("0: 0 1 f g g+1");
6242: print("1: 0 1 2 * *+1");
6243: print("infty: a b c d e");
6244: return;
6245: }
6246: S = -4;
6247: for(I = 0; I < 5; I++){
6248: S += X[I];
6249: if(I < 2)
6250: S += Y[I];
6251: }
6252: S = -(S + Y[1])/2;
6253: P = okubo3e([Y[0],Y[1],Y[1]+1],[S,"?"],X);
6254: T = chkexp(P,x,1,S,2);
6255: T = getroot(T[0],r1);
6256: P = mysubst(P,[r1,T[0]]);
6257: T = chkexp(P,x,0,Y[1],2);
6258: T = getroot(T[0],r2);
6259: return mysubst(P,[r2,T[0]]);
6260: }
6261:
6262: def extra6e(X,Y)
6263: {
6264: if(length(X) != 6 || length(Y) != 2){
6265: print("Usage: extra6e([a,b,c,d,e,f],[g,h])");
6266: print("0: 0 1 g g+1 h h+1");
6267: print("1: 0 1 2 3 * *+1");
6268: print("infty: a b c d e f");
6269: return;
6270: }
6271: S = -5;
6272: for(I = 0; I < 6; I++){
6273: S += X[I];
6274: if(I < 2)
6275: S += 2*Y[I];
6276: }
6277: S = -S/2;
6278: P = okubo3e([Y[0],Y[0]+1,Y[1],Y[1]+1],[S,"?"],X);
6279: T = chkexp(P,x,1,S,2);
6280: T = getroot(T[0],r1);
6281: P = mysubst(P,[r1,T[0]]);
6282: T = chkexp(P,x,0,Y[0],2);
6283: T = getroot(T[0],r3);
6284: P = mysubst(P,[r3,T[0]]);
6285: T = chkexp(P,x,0,Y[1],2);
6286: T = getroot(T[0],r2);
6287: return mysubst(P,[r2,T[0]]);
6288: }
6289:
6290: def rigid211(X,Y,Z)
6291: {
6292: if(length(X) != 2 || length(Y) != 2 || length(Z) != 2){
6293: print("Usage: rigid211([a,b],[c,d],[e,f])");
6294: print("0: 0 1 a b");
6295: print("1: 0 1 c d");
6296: print("infty: e e+1 f *");
6297: return;
6298: }
6299: P = okubo3e(X,Y,[Z[0],Z[0]+1,Z[1],"?"]);
6300: T = chkexp(P,x,"infty",Z[0],2);
6301: T = getroot(T[0],r1);
6302: return mysubst(P,[r1,T[0]]);
6303: }
6304:
6305: def solpokuboe(P,L,N)
6306: {
6307: if(type(N) > 1 || ntype(N) != 0 || dn(N) != 1){
6308: mycat(["Irrigal argument :", N]);
6309: return 0;
6310: }
6311: L = vweyl(L);
6312: DD=N+1;
6313: for(U = S = L[0]^N; U != 0; ){
6314: D = mydeg(U,L[0]);
6315: if(D>=DD){
6316: mycat(["Internal Error",D,DD]);
6317: return -1;
6318: }
6319: DD=D;
6320: UU = L[0]^D;
6321: R = appldo(P,UU,L);
6322: if(mydeg(R,L[0]) > D){
6323: printf("Bad operator\n");
6324: return 0;
6325: }
6326: CC = mycoef(R,D,L[0]);
6327: if(D == N){
6328: P -= (E = CC);
6329: U = R-E*U;
6330: continue;
6331: }
6332: if(CC == 0){
6333: printf("No polynomial\n");
6334: return 0;
6335: }
6336: CC= mycoef(U,D,L[0])/CC;
6337: S = red(S - UU*CC);
6338: U = red(U - R*CC);
6339: }
6340: return [nm(S),E];
6341: }
6342:
6343: def stoe(M,L,N)
6344: {
6345: L = vweyl(L);
6346: Size = size(M);
6347: S = Size[0];
6348: NN = 0;
6349: if(type(N) == 4){
6350: NN=N[0]; N=N[1];
6351: }else if(N < 0){
6352: NN=-N; N=0;
6353: }
6354: if(S != Size[1] || N >= S || NN >= S)
6355: return;
6356: D = newmat(S+1,S+1);
6357: MN = dupmat(M);
6358: MD = newmat(S,S);
6359: DD = D[0];
6360: DD[N] = 1; DD[S] = 1;
6361: for(Lcm = I = 1; ; ){
6362: DD = D[I];
6363: MM = MN[N];
6364: for(J = 0; J < S; J++){
6365: DD[J] = MM[J];
6366: Lcm = lcm(dn(DD[J]),Lcm);
6367: }
6368: DD[S] = L[1]^I;
6369: for(J = 0; J <= S; J++)
6370: DD[J] = red(DD[J]*Lcm);
6371: if(I++ >= S)
6372: break;
6373: if(I==S && NN>0){
6374: DD = D[I];
6375: DD[0]=-z_zz; DD[NN]=1;
6376: break;
6377: }
6378: Mm = dupmat(MN*M);
6379: for(J = 0; J < S; J++){
6380: for(K = 0; K < S; K++)
6381: MN[J][K] = red(diff(MN[J][K],L[0])+Mm[J][K]);
6382: }
6383: }
6384: #if 0
6385: P = fctr(mydet2(D));
6386: #else
6387: P = fctr(det(D));
6388: #endif
6389: for(I = R = 1; I < length(P); I++){
6390: if(mydeg(P[I][0],L[1]) > 0)
6391: R *= P[I][0]^P[I][1];
6392: }
6393: if(NN > 0)
6394: R = -red(coef(R,0,z_zz)/coef(R,1,z_zz));
6395: return R;
6396: }
6397:
6398: def dform(L,X)
6399: {
6400: if(type(X)==2) X=[X];
6401: if(type(L[0])!=4) L=[L];
6402: if(type(X)==4) X=ltov(X);
6403: M=length(X);
6404: if(length(car(L))==2){
6405: R=newvect(M);
6406: for(LL=L; LL!=[]; LL=cdr(LL)){
6407: for(I=0; I<M; I++){
6408: RT=rmul(car(LL)[0],mydiff(car(LL)[1],X[I]));
6409: R[I] = (R[I]==0)?RT:radd(R[I],RT);
6410: }
6411: }
6412: Dif=getopt(dif);
6413: for(RR=[], I=M-1; I>=0; I--){
6414: if(Dif==1) RR=cons([1,R[I],X[I]],RR);
6415: else RR=cons([R[I],X[I]],RR);
6416: }
6417: if(Dif==1) RR=dform(RR,X);
6418: return RR;
6419: }else if(length(car(L))!=3) return L;
6420: N=M*(M-1)/2;
6421: R=newvect(N);
6422: S=newvect(N);
6423: for(LL=L; LL!=[]; LL=cdr(LL)){
6424: for(I=K=0; I<M; I++){
6425: for(J=I+1; J<M; J++, K++){
6426: if(LL==L) S[K]=[X[I],X[J]];
6427: LT=car(LL);
6428: R1=mydiff(LT[2],X[J]);
6429: R2=mydiff(-LT[2],X[I]);
6430: if(R2==0){
6431: if(R1==0) continue;
6432: R1=rmul(mydiff(LT[1],X[I]),R1);
6433: }else if(R1==0){
6434: R1=rmul(mydiff(LT[1],X[J]),R2);
6435: }else
6436: R1=rmul(mydiff(LT[1],X[I]),R1)+rmul(mydiff(LT[1],X[J]),R2);
6437: R1=rmul(LT[0],R1);
6438: R[K] = (R[K]==0)?R1:radd(R[K],R1);
6439: }
6440: }
6441: }
6442: for(RR=[],I=N-1; I>=0; I--)
6443: RR=cons([R[I],S[I][0],S[I][1]],RR);
6444: return RR;
6445: }
6446:
6447: def polinvsym(P,Q,Sym)
6448: {
6449: N = length(Q);
6450: T = polbyroot(Q,zz);
6451: for(I = 1; I <= N; I++){
6452: P = mysubst(P,[makev([Sym,I]), (-1)^I*coef(T,N-I,zz)]);
6453: }
6454: return P;
6455: }
6456:
6457: def polinsym(P,Q,Sym)
6458: {
6459: if(type(P) == 3){
6460: P = red(P);
6461: if(type(P) == 3){
6462: D = polinsym(dn(P),Q,Sym);
6463: if(D == 0)
6464: return 0;
6465: return polinsym(nm(P),Q,Sym)/D;
6466: }
6467: }
6468: N = length(Q);
6469: V = newvect(N+1);
6470: S = newvect(N+1);
6471: E = newvect(N+1);
6472: E0 = newvect(N+1);
6473: T = polbyroot(Q,zzz);
6474: for(J = 1; J <= N; J++){
6475: K = coef(T,N-J,zzz);
6476: if(J % 2)
6477: K = -K;
6478: S[J] = K;
6479: V[J] = makev([Sym,J]);
6480: }
6481: K = deg(P,Q[0]);
6482: for(J = 0; J <= N; J++)
6483: E0[J] = K+1;
6484: E[0] = K+1;
6485: while(deg(P,Q[0]) > 0){
6486: for(P0 = P, J = 1; J <= N; J++){
6487: E[J] = deg(P0,Q[J-1]);
6488: P0 = coef(P0,E[J],Q[J-1]);
6489: }
6490: /* P0*Q[0]^E[1]*Q[1]^E[2]*... E[1] >= E[2} >= ... */
6491: for(J = 1; J <= N; J++){
6492: if(E[J] < E0[J])
6493: break;
6494: if(E[J-1] < E[J])
6495: J = N;
6496: }
6497: if(J > N){
6498: print("Not symmetric");
6499: return 0;
6500: }
6501: for(J = 1; J <= N; J++)
6502: E0[J] = E[J];
6503: for(J = N; J > 1; J--){
6504: if(E[J] != 0)
6505: for(K = 1; K < J; K++)
6506: E[K] -= E[J];
6507: }
6508: for(R0 = P0, K = 1; K <= N; K++){
6509: if(E[K] > 0)
6510: P0 *= S[K]^E[K];
6511: R0 *= V[K]^E[K];
6512: }
6513: P += R0 - P0;
6514: }
6515: return P;
6516: }
6517:
6518: def tohomog(P,L,V)
6519: {
6520: while(length(L)>0){
6521: P = mysubst(P,[car(L),car(L)/V]);
6522: L = cdr(L);
6523: }
6524: P = red(P);
6525: N = mindeg(dn(P),V);
6526: if(N > 0)
6527: P = red(P*V^N);
6528: N = mindeg(dn(P),V);
6529: if(N > 0)
6530: P = red(P/(V^N));
6531: return P;
6532: }
6533:
6534: def substblock(P,X,Q,Y)
6535: {
6536: P = red(P);
6537: if(deg(dn(P),X) > 0)
6538: return substblock(nm(P),X,Q,Y)/substblock(dn(P),X,Q,Y);
6539: N = mydeg(Q,X);
6540: if(N < 1)
6541: return P;
6542: R = mycoef(Q,N,X);
6543: while(M = mydeg(P,X), M >= N)
6544: P = red(P - mycoef(P,M,X)*(Q-Y)*X^(M-N)/R);
6545: return P;
6546: }
6547:
6548: def okuboetos(P,L)
6549: {
6550: L = vweyl(L); X = L[0]; DX = L[1];
6551: N = mydeg(P,DX);
6552: C = mycoef(P,N,DX);
6553: K = mydeg(C,X);
6554: if(K > N){
6555: print("Irregular singularity at infinity")$
6556: return 0;
6557: }
6558: if(N > K)
6559: P *= x^(N-K);
6560:
6561: L = getroot(mycoef(P,N,DX),x);
6562: L = ltov(reverse(L));
6563: if(length(L) != N || N == 0){
6564: print("Cannot get exponents")$
6565: return 0;
6566: }
6567: if( type(LL = getopt(diag)) == 4 ){
6568: LL = ltov(LL);
6569: if(length(LL) != N){
6570: mycat(["Length of the option should be", N]);
6571: return 0;
6572: }
6573: Tmp = newvect(N);
6574: for(I = N-1; I >= 0; I--){
6575: for(LLT = LL[I], J = N-1; J >=0 ; J--){
6576: if(LLT == L[J] && Tmp[J] == 0){
6577: Tmp[J] = 1;
6578: break;
6579: }
6580: }
6581: if(J < 0){
6582: print("option is wrong");
6583: return 0;
6584: }
6585: }
6586: L = LL;
6587: }
6588: P /= mycoef(C,N,X);
6589: A = newmat(N,N);
6590: AT = newmat(N+1,N+1);
6591: Phi= newvect(N+1);
6592: Phi[0] = 1;
6593: for(J = 0; J < N; J++)
6594: Phi[J+1] = Phi[J]*(X-L[J]);
6595: for(ATT = AT[N], J = 0; J < N; J++)
6596: ATT[J] = mycoef(P,J,DX);
6597:
6598: for(K = 1; K <= N; K++){
6599: for(J = N; J >= K; J--){
6600: Aj = A[J-1];
6601: SIG = AT[J][J-K];
6602: for(I = 0; I <= K-2; I++)
6603: SIG += Aj[J-I-1]*AT[J-I-1][J-K];
6604: if(K == 1)
6605: DAT = mydiff(Phi[J-1],X);
6606: else
6607: DAT = mydiff(AT[J-1][J-K],X);
6608: Aj[J-K] = -SIG+(X-L[J-1])*DAT;
6609: Aj[J-K] /= Phi[J-K];
6610: Aj[J-K] = mysubst(Aj[J-K],[X,L[J-1]]);
6611: if(J < K+1) continue;
6612: ATj = AT[J-1];
6613: ATj[J-K-1] = SIG+Aj[J-K]*Phi[J-K];
6614: ATj[J-K-1] /= (X - L[J-1]);
6615: ATj[J-K-1] = red(ATj[J-K-1]-DAT);
6616: }
6617: }
6618:
6619: ATT = newmat(N,N);
6620: for(J = 0; J < N; J++){
6621: for(K = 0; K < N; K++){
6622: ATj = ATT[J];
6623: ATj[K] = AT[J][K];
6624: }
6625: ATj[J] = Phi[J];
6626: if(J < N-1){
6627: ATj = A[J];
6628: ATj[J+1] = 1;
6629: }
6630: }
6631: return [L,A,ATT];
6632: }
6633:
6634: def heun(X,P,R)
6635: {
6636: if(type(X) != 4 || length(X) != 5){
6637: print("Usage: huen([a,b,c,d,e],p,r)");
6638: print("0: 0 c");
6639: print("1: 0 d");
6640: print("p: 0 e");
6641: print("infty: a b");
6642: print("Fuchs relation: a+b+1 = c+d+e");
6643: return;
6644: }
6645: S = 1;
6646: V = -1;
6647: X = ltov(X);
6648: for(I = 0; I < 5; I++){
6649: if(X[I] == "?"){
6650: if(V >= 0)
6651: return;
6652: V = I;
6653: }else if(I < 2){
6654: S += X[I];
6655: }else
6656: S -= X[I];
6657: }
6658: if(V >= 0){
6659: if(V < 2)
6660: X[V] = -S;
6661: else
6662: X[V] = S;
6663: }else if(S != 0){
6664: mycat(["Fuch relation:", S,"should be zero!"]);
6665: return;
6666: }
6667: return
6668: x*(x-1)*(x-P)*dx^2
6669: + (X[2]*(x-1)*(x-P)+X[3]*x*(x-P)+X[4]*x*(x-1))*dx
6670: + X[0]*X[1]*(x-R);
6671: }
6672:
6673: def fspt(M,T)
6674: {
6675: if(type(M)==7) M=s2sp(M);
6676: if(T == 3) /* 3: cut 0 */
6677: return cutgrs(M);
6678: if(T == 4 || T== 5){ /* 4: short 5: long */
6679: for(MN = [] ; M != []; M = cdr(M)){
6680: MT = car(M);
6681: for(MNT = []; MT != []; MT = cdr(MT)){
6682: if(type(car(MT)) <= 3){
6683: if(T == 4) MNT = cons(car(MT),MNT);
6684: else MNT = cons([1,car(MT)],MNT);
6685: }else{
6686: if(T == 5 || car(MT)[0] > 1) MNT = cons(car(MT),MNT);
6687: else if(car(MT)[0] == 1) MNT = cons(car(MT)[1],MNT);
6688: }
6689: }
6690: MN = cons(reverse(MNT), MN);
6691: }
6692: return reverse(MN);
6693: }
6694: if(type(M[0][0]) == 4){
6695: for(MN = [] ; M != []; M = cdr(M)){
6696: MT = car(M);
6697: for(MNT = []; MT != []; MT = cdr(MT))
6698: MNT = cons(car(MT)[0], MNT);
6699: MN = cons(reverse(MNT), MN);
6700: }
6701: return fspt(reverse(MN),T);
6702: }
6703: if(T == 0) /* 0: sp */
6704: return M;
6705: for(MN = [] ; M != []; M = cdr(M)){
6706: MT = qsort(ltov(car(M)));
6707: L = length(MT);
6708: for(MNT = [], I = 0; I < L; I++)
6709: MNT = cons(MT[I], MNT);
6710: MN = cons(MNT, MN);
6711: }
6712: MN = reverse(MN);
6713: if(T==6) return MN; /* 7: sort */
6714: L = length(MN);
6715: for(M = MN; M != []; M = cdr(M)){
6716: for(I = 0, MT = car(M); MT != []; MT = cdr(MT))
6717: I += car(MT);
6718: if(OD == 0)
6719: OD = I;
6720: else if(OD != I || OD == 0)
6721: return 0;
6722: }
6723: ALL = [MN];
6724: RD=[];
6725: while(OD > 0){
6726: for(S = 0, MT = MN; MT != []; MT = cdr(MT))
6727: S += car(MT)[0];
6728: S -= (L-2)*OD;
6729: if(S <= 0){
6730: if(T==7) return [ALL[0],ALL[length(ALL)-1],RD];
6731: return (T==1)?MN:ALL;
6732: }
6733: RD=cons([S,0,0],RD);
6734: for(NP=0, M = [], MT = MN; MT != []; NP++, MT = cdr(MT)){
6735: MTT = car(MT);
6736: I = MTT[0] - S;
6737: if(I < 0){
6738: if(I+OD!=0) return 0;
6739: if(T==7) return [ALL[0],ALL[length(ALL)-1],cdr(RD)];
6740: return (T==1)?MN:ALL;
6741: }
6742: MTT = cdr(MTT);
6743: NC=1; DO=0;
6744: for(MNT = []; MTT != []; MTT = cdr(MTT)){
6745: if(MTT[0] > I){
6746: if(DO==0) RD=cons([MTT[0]-I,NP,NC++],RD);
6747: MNT = cons(MTT[0], MNT);
6748: }
6749: else if(MTT[0] <= I && I != 0){
6750: DO=1;
6751: MNT = cons(I, MNT);
6752: I = 0;
6753: if(MTT[0] > 0)
6754: MNT = cons(MTT[0], MNT);
6755: }
6756: }
6757: if(I > 0)
6758: MNT = cons(I,MNT);
6759: M = cons(reverse(MNT), M);
6760: }
6761: MN = reverse(M);
6762: ALL = cons(MN,ALL);
6763: OD -= S;
6764: }
6765: }
6766:
6767: def abs(X)
6768: {
1.4 ! takayama 6769: if(vars(X)!=[]) return todf(os_md.abs,[X]);
! 6770: if(type(X)==4){
! 6771: P=X[1];X=X[0];
! 6772: }else P=0;
1.3 takayama 6773: if(type(X)==1){
6774: if((T=ntype(X))<2 || T==3){
6775: if(X<0) X=-X;
1.4 ! takayama 6776: }else if(T==4) X=P?pari(abs,X,P):pari(abs,X);
1.3 takayama 6777: }
1.1 takayama 6778: return X;
6779: }
6780:
6781: def calc(X,L)
6782: {
6783: if(type(X)<4){
6784: if(type(L)==4){
6785: V=L[1];
6786: if((L0=L[0])=="+") X+=V;
6787: else if(L0=="-") X-=V;
6788: else if(L0=="*") X*=V;
6789: else if(L0=="/") X/=V;
6790: else if(L0=="^") X^=V;
6791: else if(L0==">") X=(X>V);
6792: else if(L0=="<") X=(X<V);
6793: else if(L0=="=") X=(X==V);
6794: else if(L0==">=") X=(X>=V);
6795: else if(L0=="<=") X=(X<=V);
6796: else if(L0=="!=") X=(X!=V);
6797: }else if(type(L)==7){
6798: if(L=="neg") X=-X;
6799: else if(L=="abs") X=abs(X);
6800: else if(L=="neg") X=-X;
6801: else if(L=="sqr") X*=X;
6802: else if(L=="inv") X=1/X;
6803: else if(L=="sgn"){
6804: if(X>0)X=1;
6805: else if(X<0) X=-1;
6806: }
6807: }
6808: }
6809: return X;
6810: }
6811:
6812: def isint(X)
6813: {
6814: if(X==0||(type(X)==1 && ntype(X)==0 && dn(X)==1)) return 1;
6815: return 0;
6816: }
6817:
1.3 takayama 6818: def israt(X)
6819: {
6820: if(X==0||(type(X)==1 && ntype(X)==0)) return 1;
6821: return 0;
6822: }
6823:
1.4 ! takayama 6824: def iscrat(X)
! 6825: {
! 6826: if(X==0 || (type(X)==1 && israt(real(X)) && israt(imag(X)))) return 1;
! 6827: return 0;
! 6828: }
! 6829:
1.1 takayama 6830: def isalpha(X)
6831: {
6832: return ((X>64&&X<91)||(X>96&&X<123))?1:0;
6833: }
6834:
6835: def isnum(X)
6836: {
6837: return (X>47&&X<58)?1:0;
6838: }
6839:
6840: def isalphanum(X)
6841: {
6842: return (isalpha(X)||isnum(X))?1:0;
6843: }
6844:
6845: def isvar(X)
6846: {
1.3 takayama 6847: return ([X]==vars(X)&&vtype(X)<3)?1:0;
1.1 takayama 6848: }
6849:
6850: def isyes(F)
6851: {
6852: if((CC=getopt(set))==1){
6853: IsYes=(type(F[0])==4)?F:[F];
6854: return 1;
6855: }else if(CC==0) return(IsYes);
6856: if(type(CC)!=7)
6857: CC=IsYes;
6858: for(;CC!=[]; CC=cdr(CC)){
6859: C=car(CC);
6860: V=call(C[0],cons(F,C[1]));
6861: if(type(C[2])!=4){
6862: if(V!=C[2]) break;
6863: }else{
6864: if(C[2][0]!="" && V<C[2][0]) break;
6865: if(C[2][1]!="" && V>C[2][1]) break;
6866: }
6867: }
6868: return (CC==[])?1:0;
6869: }
6870:
6871: def isall(FN,M)
6872: {
6873: if(type(M)<4 || type(M)>6) return ((*FN)(M)==0)?0:1;
6874: if(type(M)==4){
6875: for(;M!=[];M=cdr(M))
6876: if((*FN)(car(M))==0) return 0;
6877: }else if(type(M)==5){
6878: K=length(M);
6879: for(I=0;I<K;I++)
6880: if((*FN)(M[I])==0) return 0;
6881: }else if(type(M)==6){
6882: K=size(M)[0];
6883: for(I=0;I<K;I++)
6884: if (isall(FN,M[I])==0) return 0;
6885: }
6886: return 1;
6887: }
6888:
6889: def sproot(MP,T)
6890: {
6891: if((I=str_chr(T,0,","))>0){
6892: if(type(MP)==7) M=s2sp(MP);
6893: else M=chkspt(MP|opt=0);
6894: if(I==length(M[0])){
6895: N=s2sp(T);S=SM=SN=K=0;
6896: for(MM=M,NN=N;MM!=[];MM=cdr(MM),NN=cdr(NN),K++){
6897: for(MT=car(MM),NT=car(NN);MT!=[];MT=cdr(MT),NT=cdr(NT)){
6898: S+=car(MT)*car(NT);
6899: if(K==0){
6900: SM+=car(MT);SN+=car(NT);
6901: }
6902: }
6903: }
6904: return S-(length(M)-2)*SM*SN;
6905: }
6906: }
6907: MM=chkspt(MP|opt=7);
6908: if(T=="base") return MM;
6909: Keep=(getopt(keep)==1)?1:0;
6910: Null=getopt(null);
6911: Only=getopt(only);
6912: if(type(Only)!=1) Only=7;
6913: M0=MM[0];
6914: M1=MM[1];
6915: M=MM[2];
6916: if(T=="length") return length(M);
6917: if(T=="height"){
6918: for(J=2,S=M1[0][0],M2=M1; M2!=[]; M2=cdr(M2)){
6919: for(MT=cdr(car(M2)); MT!=[]; J++, MT=cdr(MT)){
6920: S+= J*car(MT);
6921: }
6922: J=1;
6923: }
6924: return S;
6925: }
6926: for(OD=0, MT=M1[0]; MT!=[]; MT=cdr(MT)) OD+=car(MT);
6927: if(T=="type"){
6928: R=newvect(OD+1);
6929: for(MT=M; MT!=[]; MT=cdr(MT)) R[MT[0][0]]++;
6930: for(RR=[],I=OD; I>0; I--)
6931: if(R[I]>0) RR=cons([R[I],I],RR);
6932: return RR;
6933: }
6934: if(T=="part"||T=="pair"||T=="pairs"){
6935: NP=length(M1);
6936: LM=newvect(NP);
6937: R=newvect(length(M));
6938: for(K=0; K<NP; K++) LM[K]=length(M1[K]);
6939: for(I=0,TM=M; TM!=[]; I++, TM=cdr(TM)){
6940: V=newvect(NP);
6941: for(K=0; K<NP; K++) V[K]=newvect(LM[K]);
6942: TP=car(TM);
6943: if(TP[2]==0){
6944: for(K=0;K<NP;K++) V[K][0]=1;
6945: for(J=0; J<I; J++){
6946: VJ=R[J][1];
6947: for(S=K=0;K<NP;K++) S+=VJ[K][0];
6948: for(OD=0,K=0;K<LM[0];K++) OD+=VJ[0][K];
6949: S-=(NP-2)*OD;
6950: for(K=0;K<NP;K++) VJ[K][0]-=S;
6951: }
6952: }else{
6953: K=TP[1]; P=TP[2];
6954: V[K][P-1]=-1; V[K][P]=1;
6955: for(J=0; J<I; J++){
6956: VJ=R[J][1];
6957: S=VJ[K][P]; VJ[K][P]=VJ[K][P-1]; VJ[K][P-1]=S;
6958: }
6959: }
6960: R[I]=[TP[0],V];
6961: }
6962: if(T=="pair"||T=="pairs"){
6963: MV=ltov(M1);
6964: for(K=0; K<NP; K++) MV[K] = ltov(MV[K]);
6965: for(RR=UU=SS=[],I=0; I<length(M); I++){
6966: V=newvect(NP); W=newvect(NP); U=newvect(NP);
6967: for(K=0; K<NP; K++){
6968: U[K]=newvect(LM[K]); V[K]=newvect(LM[K]); W[K]=newvect(LM[K]);
6969: }
6970: S=R[I][0];
6971: for(K=0; K<NP; K++){
6972: for(Q=J=0; J<LM[K]; J++){
6973: V[K][J] = S*(U[K][J] = R[I][1][K][J]);
6974: Q+=(W[K][J] = MV[K][J] - V[K][J]);
6975: }
6976: }
6977: if(Q>0 && iand(Only,1)==0) continue;
6978: if(Q==0 && iand(Only,2)==0) continue;
6979: if(Q<0 && iand(Only,4)==0) continue;
6980: for(K=0; K<NP; K++){
6981: V[K] = vtol(V[K]); W[K] = vtol(W[K]); U[K]=vtol(U[K]);
6982: }
6983: V=vtol(V); W=vtol(W);U=vtol(U);
6984: if(Q<0) S=-S;
6985: RR = cons([V,W], RR); UU = cons(U,UU); SS=cons(S,SS);
6986: }
6987: RR = reverse(RR); UU=reverse(UU); SS=reverse(SS);
6988: if(getopt(dviout)==1 && (Null!=1 || RR!=[])){
6989: Out=string_to_tb("\\begin{align}\\begin{split}"+s2sp(M1)+"&=");
6990: for(I=0,R=RR, U=UU; R!=[]; I++, R=cdr(R), U=cdr(U)){
6991: if(I>0) str_tb("\\\\\n &=",Out);
6992: if(T=="pairs"){
6993: if((S=SS[I])<0) S=-S;
6994: if(S>1) str_tb([my_tex_form(S),"("],Out);
6995: str_tb(s2sp(car(U)),Out);
6996: if(S>1) str_tb(")",Out);
6997: str_tb(" \\oplus ",Out);
6998: if(SS[I]<0){
1.3 takayama 6999: #ifdef USEMODULE
7000: str_tb(["-(",s2sp(mtransbys(os_md.abs,car(R)[1],[])),")"],Out);
7001: #else
1.1 takayama 7002: str_tb(["-(",s2sp(mtransbys(abs,car(R)[1],[])),")"],Out);
1.3 takayama 7003: #endif
1.1 takayama 7004: }else
7005: str_tb(s2sp(car(R)[1]),Out);
7006: }else
7007: str_tb([s2sp(car(R)[0])," \\oplus ",s2sp(car(R)[1])],Out);
7008: }
7009: str_tb("\n\\end{split}\\end{align}",Out);
7010: dviout(str_tb(0,Out)|keep=Keep);
7011: }
7012: return RR;
7013: }
7014: for(I=0; I<length(M); I++){
7015: for(K=0; K<NP; K++) R[I][1][K] = vtol(R[I][1][K]);
7016: R[I] = [R[I][0],vtol(R[I][1])];
7017: }
7018: R = vtol(R);
7019: return [M0,M1,R];
7020: }
7021: }
7022:
7023: def spgen(MO)
7024: {
7025: Eq=(getopt(eq)==1)?1:0;
7026: Sp=getopt(sp);
7027: if(type(Sp)==7) Sp=s2sp(Sp);
7028: St=getopt(str);
7029: LP=getopt(pt);
7030: if(type(LP)==4){
7031: L0=LP[0]; L1=LP[1];
7032: }else{
7033: L0=0; L1=MO+1;
7034: }
7035: if(MO<=0){
7036: MO=-MO;
7037: if(iand(MO,1)==1) return [];
7038: if(MO>1){
7039: if(isMs()==0) return [];
7040: Cmd="okubo "+rtostr(-MO);
7041: MO/=2;
7042: if(L1>0) Cmd=Cmd+"+"+rtostr(L0)+"-"+rtostr(L1);
7043: else L1=MO+4;
7044: Cmd=Cmd+" B";
7045: Id=getbyshell(Cmd);
7046: if(Id<0) return [];
7047: B=[];
7048: while((S=get_line(Id)) !=0){
7049: P0=str_chr(S,1,":")+1;
7050: if(P0>1){
7051: P1=str_chr(S,P,"\n");
7052: if(P1<0) P1=str_len(S);
7053: B=cons(sub_str(S,P0,P1-1),B);
7054: }
7055: }
7056: }else{
7057: MO/=2;
7058: if(L1<=1) L1=MO+4;
7059: BB=[
7060: ["11,11,11,11","111,111,111","1^4,1^4,22","1^6,222,33"],
7061: ["11,11,11,11,11","1^4,1^4,211","211,22,22,22","1^6,2211,33",
7062: "2211,222,222","22211,2^4,44","2^511,444,66","1^4,22,22,31",
7063: "2^5,3331,55","1^5,1^5,32","1^8,332,44","111,111,21,21","1^5,221,221"],
7064: ["11,11,11,11,11,11","1^4,1^4,1^4","1^4,22,22,22","111,111,111,21",
7065: "1^6,21^4,33","21^4,222,222","221^4,2^4,44","2^41^4,444,66",
7066: "1^5,1^5,311","1^8,3311,44","1^6,222,321","321,33,33,33",
7067: "3321,333,333","33321,3^4,66","3^721,666,99","2^5,3322,55",
7068: "1^6,1^6,42","222,33,33,42","1^a,442,55","1^6,33,33,51",
7069: "222,222,33,51","1^9,333,54","2^7,554,77","1^5,2111,221",
7070: "2^41,333,441","1^7,2221,43","211,211,22,22","2211,2211,222",
7071: "22211,22211,44","1^4,211,22,31","2^411,3331,55","1^4,1^4,31,31",
7072: "22,22,22,31,31","1^7,331,331","2221,2221,331","111,21,21,21,21"],
7073: ["11,11,11,11,11,11,11","111,111,111,111","1^6,1^6,33",
7074: "1^6,222,222","222,33,33,33","1^5,1^5,221",
7075: "1^4,211,22,22","1^4,1^4,22,31","22,22,22,22,31",
7076: "111,111,21,21,21","21^6,2^4,44","2221^6,444,66",
7077: "1^6,222,3111","3111,33,33,33","33111,333,333",
7078: "333111,3^4,66","3^5111,666,99","2^5,33211,55",
7079: "1^8,3221,44","3222,333,333","33222,3^4,66",
7080: "3^4222,666,99","1^6,1^6,411","222,33,33,411",
7081: "1^a,4411,55","2^4,2^4,431","431,44,44,44",
7082: "2^6,4431,66","4431,444,444","44431,4^4,88",
7083: "4^531,888,cc","1^a,433,55","1^7,1^7,52",
7084: "1^c,552,66","3^4,444,552","1^8,2^4,53",
7085: "1^8,44,44,71","3^5,555,771","21^4,2211,222",
7086: "221^4,22211,44","2221^4,3331,55","1^6,2211,321",
7087: "2^411,3322,55","1^7,322,331","2211,33,33,42",
7088: "3^42,4442,77","2211,222,33,51","3^51,5551,88",
7089: "2^611,554,77","2221,2221,322","2^41,2^41,54",
7090: "1^5,2111,2111","222111,333,441","1^7,22111,43",
7091: "1^5,1^5,41,41","1^9,441,441","22111,2221,331",
7092: "1^5,221,32,41","221,221,221,41","211,211,211,22",
7093: "2211,2211,2211","1^4,211,211,31","211,22,22,31,31",
7094: "1^4,22,31,31,31","1^5,32,32,32","221,221,32,32","21,21,21,21,21,21"],
7095: ["11,11,11,11,11,11,11,11","1^4,1^4,22,22","1^8,2^4,44",
7096: "1^6,2211,222","2211,33,33,33","111,111,111,21,21",
7097: "1^5,1^5,2111","1^4,211,211,22","1^4,1^4,211,31",
7098: "211,22,22,22,31","1^4,22,22,31,31","111,21,21,21,21,21",
7099: "221^8,444,66","2^5,331^4,55","1^8,32111,44",
7100: "32211,333,333","332211,3^4,66","3^42211,666,99",
7101: "2^5,32221,55","1^7,1^7,511","1^c,5511,66",
7102: "3^4,444,5511","541,55,55,55","5541,555,555",
7103: "55541,5^4,aa","5^541,aaa,ff","1^8,1^8,62",
7104: "1^a1^4,662,77","1^a,55,55,91","2^71,555,87",
7105: "21^6,22211,44","221^6,3331,55","1^6,2211,3111",
7106: "2^411,33211,55","1^7,3211,331","2211,33,33,411",
7107: "3^42,44411,77","22211,2^4,431","2^511,4431,66",
7108: "1^8,332,431","3^42,4433,77","1^8,22211,53",
7109: "2221,2221,3211","221^5,333,441","1^7,21^5,43",
7110: "1^b,443,65","21^5,2221,331","2^51,3332,65",
7111: "21^4,21^4,222","221^4,221^4,44","1^6,21^4,321",
7112: "2221^4,3322,55","21^4,33,33,42","21^4,222,33,51",
7113: "2^51^4,554,77","2^4,3311,3311","3^411,4442,77",
7114: "321,321,33,33","3321,3321,333","33321,33321,66",
7115: "222,321,33,42","1^6,321,33,51","222,222,321,51",
7116: "1^9,3321,54","1^7,322,322","3^422,5551,88",
7117: "1^6,33,42,42","1^6,222,42,51","33,33,33,42,51",
7118: "1^6,1^6,51,51","222,33,33,51,51","1^b,551,551",
7119: "1^5,221,311,41","2^41,3321,441","22111,2221,322",
7120: "2^51,443,551","222111,2^41,54","21^4,2211,2211",
7121: "1^5,311,32,32","3331,3331,442","2211,2211,33,51",
7122: "221,221,311,32","22111,22111,331","1^5,2111,32,41",
7123: "2111,221,221,41","2111,221,32,32","211,211,211,211",
7124: "211,211,22,31,31","1^4,211,31,31,31","22,22,31,31,31,31"],
7125: ["11,11,11,11,11,11,11,11,11","1^5,1^5,1^5","2^5,2^5,55",
7126: "111,111,111,111,21","2^41,333,333","1^4,1^4,211,22",
7127: "211,22,22,22,22","1^8,22211,44","1^4,1^4,1^4,31",
7128: "1^4,22,22,22,31","1^7,1^7,43","1^7,2221,331",
7129: "2221,2221,2221","1^6,21^4,222","21^4,33,33,33",
7130: "1^6,1^6,321","222,321,33,33","1^6,33,33,42",
7131: "222,222,33,42","1^6,222,33,51","222,222,222,51",
7132: "33,33,33,33,51","1^6,2211,2211","111,111,21,21,21,21",
7133: "1^5,1^5,32,41","1^5,221,221,41","1^5,221,32,32",
7134: "221,221,221,32","1^4,211,211,211","211,211,22,22,31",
7135: "1^4,211,22,31,31","1^4,1^4,31,31,31","22,22,22,31,31,31",
7136: "21,21,21,21,21,21,21","21^a,444,66","1^8,31^5,44",
7137: "321^4,333,333","3321^4,3^4,66","3^421^4,666,99",
7138: "2^5,322111,55","32^41,3^4,66","3332^41,666,99",
7139: "1^8,1^8,611","2^4,44,44,611","1^d,6611,77",
7140: "4^5,66611,aa","2^6,444,651","3^4,3^4,651",
7141: "651,66,66,66","3^6,6651,99","6651,666,666",
7142: "66651,6^4,cc","6^551,ccc,ii","2^8,655,88",
7143: "1^9,1^9,72","1^g,772,88","1^c,444,75",
7144: "2^6,3^4,75","1^c,66,66,b1","3^4,444,66,b1",
7145: "3^7,777,ba","1^7,2221,4111","2^41,333,4311",
7146: "1^9,2^41,63","21^8,3331,55","2^411,331^4,55",
7147: "1^7,31^4,331","2^411,32221,55","22211,2^4,422",
7148: "2^511,4422,66","1^8,332,422","2^5,3331,541",
7149: "22211,44,44,62","2^411,2^5,64","2^711,664,88",
7150: "1^a,3331,64","2221,2221,31^4","21^7,333,441",
7151: "333,333,441,81","2^6111,555,87","21^6,221^4,44",
7152: "221^6,3322,55","2^41^6,554,77","1^6,21^4,3111",
7153: "3111,321,33,33","33111,3321,333","333111,33321,66",
7154: "222,3111,33,42","1^6,3111,33,51","222,222,3111,51",
7155: "1^9,33111,54","2221^4,33211,55","1^7,3211,322",
7156: "3^4211,5551,88","2^4,3221,3311","333221,4442,77",
7157: "3222,3321,333","33222,33321,66","1^9,3222,54",
7158: "21^4,33,33,411","3^411,44411,77","222,321,33,411",
7159: "1^6,33,411,42","1^6,222,411,51","33,33,33,411,51",
7160: "221^4,2^4,431","2^41^4,4431,66","1^8,3311,431",
7161: "3^411,4433,77","33321,444,552","1^8,221^4,53",
7162: "3311,44,44,53","4^42,5553,99","2^4,3311,44,71",
7163: "3^421,555,771","4^52,7771,bb","3^611,776,aa",
7164: "2^41,33111,441","22111,2221,3211","2^41,3222,441",
7165: "2^61,4441,76","3331,3331,4411","22211,22211,431",
7166: "3331,3331,433","3^41,3^41,76","1^7,1^7,61,61",
7167: "1^d,661,661","21^5,2221,322","221^5,2^41,54",
7168: "2^51,33311,65","21^5,22111,331","3^41,4441,661",
7169: "1^7,331,43,61","2221,2221,43,61","2221,331,331,61",
7170: "21^4,21^4,2211","21^4,2211,33,51","22211,3311,3311",
7171: "1^5,311,311,32","2211,321,33,42","2211,222,321,51",
7172: "3322,3331,442","2211,222,42,42","2^411,442,442",
7173: "1^6,2211,42,51","2211,33,33,51,51","221,221,311,311",
7174: "1^5,2111,311,41","222111,3321,441","22111,22111,322",
7175: "222111,222111,54","2111,221,311,32","2111,2111,221,41",
7176: "1^5,221,41,41,41","2221,43,43,43","1^5,32,32,41,41",
7177: "331,331,43,43","221,221,32,41,41","221,32,32,32,41",
7178: "211,211,211,31,31","211,22,31,31,31,31","1^4,31,31,31,31,31"]];
7179: B=BB[MO];
7180: }
7181: if(St!=1){
7182: for(R=[]; B!=[]; B=cdr(B)){
7183: RT=s2sp(car(B));
7184: if(length(RT)<L0 || length(RT)>L1) continue;
7185: R=cons(RT,R);
7186: }
7187: return reverse(R);
7188: }else{
7189: if(L0<=3 && L1>=MO+4) return B;
7190: for(R=[]; B!=[]; B=cdr(B)){
7191: RT=s2sp(car(B));
7192: if(length(RT)<L0 || length(RT)>L1) continue;
7193: R=cons(car(B),R);
7194: }
7195: return reverse(R);
7196: }
7197: /*
7198: MM = 3*MO+5;
7199: if(L1<=1) L1=MM/2+1;
7200: R = newvect(MM+2);
7201: for(RR=[], I=MO/2+2; I>0; I--)
7202: RR=cons([1,1],RR);
7203: R[2]=[RR];
7204: if(MO==0){
7205: R[6] = [[[3,3],[2,2,2],[1,1,1,1,1,1]]];
7206: R[4] = [[[2,2],[1,1,1,1],[1,1,1,1,]]];
7207: R[3] = [[[1,1,1],[1,1,1],[1,1,1]]];
7208: }else{
7209: I=MO/2+1;
7210: R[MM+1]=[[[3*I,3*I],[2*I,2*I,2*I],[I,I,I,I,I,I-1,1]]];
7211: }
7212: */
7213: }
7214: MP=(L1<MO+1)?L1:MO+1;
7215: LL=newvect(MO+1);
7216: R=newvect(MP+2);
7217: R0=newvect(MP+2);
7218: for(I=1; I<=MO; I++) LL[I]=[];
7219: if(type(Sp)==4){
7220: if(getopt(basic)==1) Sp=chkspt(Sp[6]);
7221: R=chkspt(Sp);
7222: if(R[1]>MO) return 0;
7223: LL[R[1]]=R;
7224: K=R[1];
7225: }
7226: if(K==1||type(Sp)!=4){
7227: LL[1]=[[[1]]];
7228: for(I=2; I<=MO && I<MP;I++){
7229: for(T=[], J=0; J<I+1; J++)
7230: T=cons([I-1,1],T);
7231: LL[I]=cons(T,LL[I]);
7232: }
7233: K=2;
7234: }
7235: /* mycat(LL); */
7236: for(OD=K; OD<MO; OD++){
7237: for(LT=LL[OD]; LT!=[]; LT=cdr(LT)){
7238: for(II=0,L=car(LT); L!=[]; II++, L=cdr(L)){
7239: R0[II]=R[II]=car(L);
7240: }
7241: /* mycat([R0,R]); */
7242: for(; ;){
7243: for(S=-2*OD, I=0; I<II; I++){
7244: S += OD;
7245: if(R[I]!=[]) S-=car(R[I]);
7246: }
7247: --I;
7248: for(;S+OD<=MO && I<=MP;S+=OD,I++){
7249: /* mycat(["C",I]); */
7250: if(S<=0) continue;
7251: /* mycat(["+",S,I,II,R,R0]); */
7252: for(J=0;J<=I;J++){
7253: /* mycat([S+((R[J]==[])?0:car(R[J])),car(R0[J])]); */
7254: if(J>=II){
7255: if(S<OD) break;
7256: }else
7257: if(S+((R[J]==[])?0:car(R[J]))<car(R0[J])) break;
7258: }
7259: if(--J>=I){
7260: V=newvect(I);
7261: RRR=[];
7262: for(;J>=0;J--){
7263: if(J>=II) RR=[OD,S];
7264: else{
7265: K=length(R[J]);
7266: RR=[S+((K==0)?0:car(R[J]))];
7267: K=length(R0[J])-K;
7268: for(RT=R0[J]; RT!=[]; K--,RT=cdr(RT)){
7269: if(K!=0) RR=cons(car(RT),RR);
7270: }
7271: }
7272: RRR=cons(reverse(RR),RRR);
7273: }
7274: /* mycat(["Get",s2sp(RRR)]); */
7275: RRR=qsort(reverse(RRR));
7276: if(findin(RRR,LL[S+OD])<0)
7277: LL[S+OD]=cons(RRR,LL[S+OD]);
7278: }
7279: }
7280: /* mycat(["*",I,R]); */
7281: for(K=0; K<II; K++){
7282: if(R[K]!=[]){
7283: S=car(R[K]);
7284: while((R[K]=cdr(R[K]))!=[] && car(R[K])==S);
7285: break;
7286: }else R[K]=R0[K];
7287: }
7288: /* mycat([R,R0]); */
7289: if(K>=II) break;
7290: }
7291: }
7292: }
7293: if(L0>0 || L1<MO+1 || St==1){
7294: for(J=1; J<=MO; J++){
7295: for(RT=[],R=LL[J]; R!=[];R=cdr(R)){
7296: L=length(car(R));
7297: if(L<L0 || L>L1) continue;
7298: RT=cons((St==1)?s2sp(car(R)):car(R),RT);
7299: }
7300: LL[J] = reverse(RT);
7301: }
7302: }
7303: if(Eq==1) return LL[MO];
7304: return LL;
7305: }
7306:
1.4 ! takayama 7307: def spType2(L)
! 7308: {
! 7309: C=0;R=[];
! 7310: for(LT=L;LT!=[];LT=cdr(LT)){
! 7311: D=-1;LP=car(LT);
! 7312: for(LPT=LP;LPT!=[];LPT=cdr(LPT)){
! 7313: if(D==-1) D=car(LPT);
! 7314: else D=igcd(D,car(LPT));
! 7315: if(D==1){
! 7316: C++;break;
! 7317: }
! 7318: }
! 7319: if(C==2) return 0;
! 7320: R=cons(D,R);
! 7321: }
! 7322: if(C==0) return L;
! 7323: if(C==1){
! 7324: for(K=length(R)-1;R[K]!=1;K--);
! 7325: D=-1;
! 7326: for(I=length(R)-1;I>=0;I--){
! 7327: if(I==K) continue;
! 7328: if(D==-1) D=R[I];
! 7329: else D=igcd(D,R[I]);
! 7330: if(D==1) return 0;
! 7331: }
! 7332: }
! 7333: return L;
! 7334: }
! 7335:
1.1 takayama 7336:
7337: /* ret [#points, order, idx, Fuchs, reduction order, reduction exponents, fund] */
7338: def chkspt(M)
7339: {
7340: Opt= getopt(opt);
7341: Mat= getopt(mat);
7342: if(type(M)==7) M=s2sp(M);
7343: if(type(Opt) >= 0){
7344: if(type(Opt) == 7)
7345: Opt = findin(Opt, ["sp","basic","construct","strip","short","long","sort","root"]);
7346: if(Opt < 0){
7347: erno(2);
7348: return 0;
7349: }
7350: return fspt(M,Opt);
7351: }
7352: MR = fspt(M,1);
7353: P = length(M);
7354: OD = -1;
7355: XM = newvect(P);
7356: Fu = 0;
7357: for( I = SM = SSM = 0; I < P; I++ ){
7358: LJ = length(M[I]);
7359: JM = JMV = 0;
7360: for(J = SM = 0; J < LJ; J++){
7361: MV = M[I][J];
7362: if(type(MV) == 4){
7363: Fu += MV[0]*MV[1];
7364: MV = MV[0];
7365: }
7366: if(MV > JMV){
7367: JM = J; JMV = MV;
7368: }
7369: SM += MV;
7370: SSM += MV^2;
7371: }
7372: if(OD < 0)
7373: OD = SM;
7374: else if(OD != SM){
7375: print("irregal partitions");
7376: return 0;
7377: }
7378: XM[I] = JM;
7379: }
7380: SSM -= (P-2)*OD^2;
7381: for(I = SM = JM = 0; I < P; I++){
7382: MV = M[I][XM[I]];
7383: if(type(MV) == 4){
7384: MV = MV[0]; JM = 1;
7385: }
7386: if(I == 0)
7387: SMM = MV;
7388: else if(SMM > MV)
7389: SMM = MV;
7390: SM += MV;
7391: }
7392: SM -= (P-2)*OD;
7393: if(SM > SMM && SM != 2*OD){
7394: print("not realizable");
7395: return -1;
7396: }
7397: if(JM==1 && Mat!=1)
7398: Fu -= OD - SSM/2;
7399: return [P, OD, SSM, Fu, SM, XM, MR];
7400: }
7401:
7402: def cterm(P)
7403: {
7404: V = getopt(var);
7405: if(type(V) != 4)
7406: V=vars(P);
7407: for(; V !=[]; V = cdr(V))
7408: P = mycoef(P,0,car(V));
7409: return P;
7410: }
7411:
7412: def terms(P,L)
7413: {
7414: Lv=getopt(level);
7415: if(type(Lv)!=1) Lv=0;
7416: V=car(L);L=cdr(L);
7417: for(R=[],D=mydeg(P,V);D>=0; D--){
7418: if((Q=mycoef(P,D,V))==0) continue;
7419: if(L!=[]){
7420: R0=terms(Q,L|level=Lv+1);
7421: for(;R0!=[];R0=cdr(R0)) R=cons(cons(D,car(R0)),R);
7422: }else R=cons([D],R);
7423: }
7424: if(Lv>0) return R;
7425: R=qsort(R);
7426: Rev = getopt(rev); Dic=getopt(dic);
7427: if(Dic==1 && Rev==1) R=reverse(R);
7428: for(R0=[];R!=[];R=cdr(R)){
7429: for(RT=car(R),S=0;RT!=[];RT=cdr(RT)) S+=car(RT);
7430: R0=cons(cons(S,car(R)),R0);
7431: }
7432: if(Dic==1) return R0;
1.3 takayama 7433: if(Rev==1){
7434: for(R=[];R0!=[];R0=cdr(R0)){
7435: T=car(R0);
7436: R=cons(cons(-car(T),cdr(T)),R);
7437: }
7438: R0=R;
7439: }
1.1 takayama 7440: R0=qsort(R0);
1.3 takayama 7441: if(Rev==1){
7442: for(R=[];R0!=[];R0=cdr(R0)){
7443: T=car(R0);
7444: R=cons(cons(-car(T),cdr(T)),R);
7445: }
7446: R0=R;
7447: }
1.1 takayama 7448: return (Rev==1)?R0:reverse(R0);
7449: }
7450:
7451: def polcut(P,N,L)
7452: {
7453: if(type(L)==2) L=[L];
7454: M=getopt(top);
7455: if(type(M)!=1) M=0;
7456: T=terms(P,L);
7457: for(S=0;T!=[];T=cdr(T)){
7458: LT=car(T);
7459: if(LT[0]<M || LT[0]>N) continue;
7460: for(PW=1,LT=cdr(LT),V=L,Q=P;LT!=[];LT=cdr(LT),V=cdr(V)){
7461: Q=mycoef(Q,car(LT),car(V));PW*=car(V)^car(LT);
7462: }
7463: S+=Q*PW;
7464: }
7465: return S;
7466: }
7467:
7468: def redgrs(M)
7469: {
7470: Mat = getopt(mat);
7471: if(Mat!=1) Mat=0;
7472: R = chkspt(M|mat=Mat);
7473: if(type(R) < 4)
7474: return -1;
7475: if(R[4] <= 0)
7476: return 1-R[4];
7477: if(R[4] == 2*R[1])
7478: return 0;
7479: V = newvect(R[0]);
7480: Type = type(M[0][0]);
7481: if(Type > 3){
7482: Mu = Mat-1;
7483: for(I = 0; I < R[0]; I++)
7484: Mu += M[I][R[5][I]][1];
7485: }
7486: for(I = 0; I < R[0]; I++){
7487: IR = R[5][I]; L = []; MI = M[I]; MIE=MI[IR];
7488: for(J = length(MI)-1; J >= 0; J--){
7489: if(Type <= 3){
7490: VM = MI[J];
7491: if(J == IR){
7492: VM -= R[4];
7493: if(VM < 0)
7494: return -1;
7495: }
7496: L = cons(VM, L);
7497: }else{
7498: VM = MI[J][0];
7499: if(J == IR){
7500: VM -= R[4];
7501: if(VM < 0)
7502: return -1;
7503: if(I == 0)
7504: EV = 1-Mat-Mu;
7505: else
7506: EV = 0;
7507: }else{
7508: if(I == 0)
7509: EV = MI[J][1] - M[0][R[5][0]][1] + 1-Mat; /* + MX - Mu; */
7510: else
7511: EV = MI[J][1] - MIE[1] + Mu;
7512: }
7513: L = cons([VM,EV], L);
7514: /*
7515: if(R[2] >= 2){ */ /* digid */
7516: /* P = dx^(R[1]);
7517: } */
7518: }
7519: }
7520: V[I] = L;
7521: }
7522: return [R[5], vtol(V)];
7523: }
7524:
7525: def cutgrs(A)
7526: {
7527: for(AL=[] ; A!=[]; A=cdr(A)){ /* AT: level 2 */
7528: for(ALT=[], AT=car(A); AT!=[]; AT=cdr(AT)){
7529: M = (type(car(AT)) < 4)?car(AT):car(AT)[0];
7530: if(M > 0)
7531: ALT = cons(car(AT), ALT); /* ALT: level 2 */
7532: }
7533: AL = cons(reverse(ALT), AL); /* AL: level 3 */
7534: }
7535: return reverse(AL);
7536: }
7537:
7538: def mcgrs(G, R)
7539: {
7540: NP = length(G);
7541: Mat = (getopt(mat)==1)?0:1;
7542: for(R = reverse(R) ; R != []; R = cdr(R)){
7543: GN = [];
7544: L = length(G)-1;
7545: RT = car(R);
7546: if(type(RT) == 4){
7547: RT = reverse(RT); S = 0;
7548: for(G = reverse(G); G != []; G = cdr(G), L--){
7549: AD = car(RT); RT = cdr(RT);
7550: if(L > 0)
7551: S += AD;
7552: else
7553: AD = -S;
7554: for(GTN = [], GT = reverse(car(G)); GT != []; GT = cdr(GT))
7555: GTN = cons([car(GT)[0],car(GT)[1]+AD], GTN);
7556: GN = cons(GTN, GN);
7557: }
7558: G = GN;
7559: continue;
7560: }
7561: VP = newvec(L+1); GV = ltov(G);
7562: for(I = S = OD = 0; I <= L; I++){
7563: RTT = (I==0)?(Mat-RT):0;
7564: VP[I] = -1;
7565: for(J = M = 0, GT = GV[I]; GT != []; GT = cdr(GT), J++){
7566: if(I == 0)
7567: OD += car(GT)[0];
7568: if(car(GT)[1] == RTT && car(GT)[0] > M){
7569: S += car(GT)[0]-M;
7570: VP[I] = J;
7571: }
7572: }
7573: S -= (L-1)*OD;
7574: for(GN = [] ; L >= 0; L--){
7575: GT = GV[L];
7576: RTT = (L==0)?(-RT):RT;
7577: FTN = (VP[L] >= 0 || S == 0)?[]:[-S,(L==0)?(Mat-RT):0];
7578: for(J = 0; GT != []; GT = cdr(GT), J++){
7579: if(J != VP[L]){
7580: GTN = cons([car(GT)[0],car(GT)[1]+RTT], GTN);
7581: continue;
7582: }
7583: K = car(GT)[0] - S;
7584: if(K < 0){
7585: print("Not realizable");
7586: return;
7587: }
7588: GTN = cons([K,(L==0)?(Mat-RT):0], GTN);
7589: }
7590: GN = cons(reverse(GTN), GN);
7591: }
7592: }
7593: G = cutgrs(GN);
7594: }
7595: return G;
7596: }
7597:
1.4 ! takayama 7598: def add2grs(R,T,K)
! 7599: {
! 7600: F=0;T1=[T[0],4];T2=[T[1],4];
! 7601: if(I[0]>I[1]) I=[I[1],I[0]];
! 7602: if(R[0][0]==T) F=1;
! 7603: else if(R[0][1]==T) F=2;
! 7604: if(getopt(Ad)==1){
! 7605: K=-K;
! 7606: if(R[0][0]==T1||car(PG)[0][0]==T2){
! 7607: F=1;break;
! 7608: }
! 7609: if(car(PG)[0][1]==T1||car(PG)[0][0]==T2){
! 7610: F=2;break;
! 7611: }
! 7612: }
! 7613: if(!F) return R;
! 7614: G=reverse(cdr(R));
! 7615: for(L=[];G!=[];G=cdr(G)){
! 7616: if(F==1) L=cons([car(G)[0],car(G)[1]+K,car(G)[2]],TL);
! 7617: else L=cons([car(G)[0],car(G)[1]+K,car(G)[2]],L);
! 7618: }
! 7619: return cons(car(R),L);
! 7620: }
! 7621:
! 7622:
! 7623: def sub2grs(R,I,K)
! 7624: {
! 7625: if(length(R[0])==1){
! 7626: if(R[0]!=I[0]){
! 7627: errno(0);
! 7628: return R;
! 7629: }
! 7630: VL=ltov(L);L=len(VL);
! 7631: for(I=cdr(I);I!=[];I=cdr(I)){
! 7632: V=car(I)[1];
! 7633: for(K=0;K<L;K++)
! 7634: if(I[K][1]==V) VL[K]=[car(I)[0]-I[K][0],V];
! 7635: }
! 7636: for(L=[],K=L-1;K>=0;K--) if(VL[K][1]) L=cons(VL[K],L);
! 7637: return cons(car(L),L);
! 7638: }
! 7639: F=0;
! 7640: if(I[0]>I[1]) I=[I[1],I[0]];
! 7641: if(R[0][0]==I) F=1;
! 7642: else if(R[0][1]==I) F==2;
! 7643: if(!F) return R;
! 7644: Eq=getopt(eq);
! 7645: for(L=[],G=reverse(cdr(R));G!=[];G=cdr(T))
! 7646: if((Eq!=1&&car(G)[F]!=K)||(Eq==1&&car(G)[F]==K)) L=cons(car(G),L);
! 7647: return cons(car(R),G);
! 7648: }
! 7649:
! 7650: def join2grs(R,J,K)
! 7651: {
! 7652: if(J[0]>J[1]) J=[J[1],J[0]];
! 7653: G=reverse(cdr(R));L=[];
! 7654: I=car(R);
! 7655: if(I[0]<J[0]){
! 7656: for(;G!=[];G=cdr(G)) L=cons([car(G)[0],car(G)[1],K],L);
! 7657: return cons([I,J],L);
! 7658: }
! 7659: for(;G!=[];G=cdr(G)) L=cons([car(G)[0],K,car(G)[1]],L);
! 7660: return cons([J,I],L);
! 7661: }
! 7662:
! 7663: /*
! 7664: G=0 get trivial common spct
! 7665: P=["get"] all spct
! 7666: P=["get",L]
! 7667: L=n for variable x_n
! 7668: L=[m,n] for residue [m,n]
! 7669: L=[[m,n],[m',n']] for common spct
! 7670: P=["swap",[m,n]] for symmetry
! 7671: P=["perm",[...]] for symmetry
! 7672: P=["homog"]
! 7673: P=[[[m,n],c],...] for addition
! 7674: P=[m,c] or [[m,c],...] for middle convolution
! 7675: */
! 7676: def mc2grs(G,P)
! 7677: {
! 7678: if(G==0){
! 7679: G=[];
! 7680: for(I=4;I>=0;I--){
! 7681: V=lsort([0,1,2,3,4],[I],1);
! 7682: for(J=1;J<4;J++){
! 7683: for(T=[],K=3;K>0;K--)
! 7684: if(K!=J) T=cons(V[K],T);
! 7685: G=cons([[[V[0],V[J]],T],[1,0,0]],G);
! 7686: }
! 7687: }
! 7688: return reverse(G);
! 7689: }
! 7690: F=0;
! 7691: if(type(P)==4&&type(F=car(P))==7){
! 7692: if(F=="get"){
! 7693: if(length(P)==1){
! 7694: for(L=[],I=3;I>=0;I--){
! 7695: for(J=4;J>I;J--)
! 7696: L=cons([[I,J],mc2grs(G,["get",[I,J]])],L);
! 7697: }
! 7698: return L; /* get spct */
! 7699: }
! 7700: if(type(T=P[1])==4){
! 7701: if(type(car(T))==4){
! 7702: if(T[0][0]>T[0][1]) T=[[T[0][1],T[0][0]],T[1]];
! 7703: if(T[1][0]>T[1][1]) T=[T[0],[T[1][1],T[1][0]]];
! 7704: if(T[0][0]>T[1][0]) T=[T[1],T[0]];
! 7705: for(PG=G;PG!=[];PG=cdr(PG)){
! 7706: if(car(PG)[0]==T) return car(PG);
! 7707: }
! 7708: return []; /* get common spct */
! 7709: }
! 7710: if(T[0]>T[1]) T=[T[1],T[0]];
! 7711: for(F=0,PG=G;PG!=[];PG=cdr(PG)){
! 7712: if(car(PG)[0][0]==T){
! 7713: F=1;break;
! 7714: }
! 7715: if(car(PG)[0][1]==T){
! 7716: F=2;break;
! 7717: }
! 7718: }
! 7719: if(!F) return [];
! 7720: VT=newvect(length(PG));MT=newvect(length(PG));
! 7721: for(T=cdr(car(PG));T!=[];T=cdr(T)){
! 7722: V=car(T)[F];
! 7723: for(I=0;;I++){
! 7724: if(V==VT[I]){
! 7725: MT[I]+=car(T)[0];
! 7726: break;
! 7727: }
! 7728: if(!MT[I]){
! 7729: VT[I]==V;
! 7730: MT[I]==car(T)[0];
! 7731: break;
! 7732: }
! 7733: }
! 7734: }
! 7735: for(L=[],I=0;MT[I];I++){
! 7736: L=cons([MT[I],VT[I]],L);
! 7737: }
! 7738: return reverse(L); /* get exp */
! 7739: }
! 7740: if(type(I=P[1])<2&&I>=0&&I<=4){
! 7741: for(L=[],J=4;J>=0;J--){
! 7742: if(I==J) continue;
! 7743: T=(I<J)?[I,J]:[J,I];
! 7744: L=cons(cdr(mc2grs(G,["get",T])),L);
! 7745: }
! 7746: return L; /* get spct1 */
! 7747: }
! 7748: return [];
! 7749: }
! 7750: if(F=="swap"||F=="perm"){
! 7751: if(F=="perm") TR=P[1];
! 7752: else{
! 7753: TR=newvect(5,[0,1,2,3,4]);
! 7754: K=P[1][0];L=P[1][1];
! 7755: TR[K]=L;TR[L]=K;
! 7756: }
! 7757: V=newvect(2);
! 7758: for(L=[],T=G;T!=[];T=cdr(T)){
! 7759: TP=car(T)[0];
! 7760: for(TQ=[],I=1;I>=0;I--){
! 7761: V=[TR[TP[I][0]],TR[TP[I][1]]];
! 7762: if(V[0]>V[1]) V=[V[1],V[0]];
! 7763: TQ=cons(V,TQ);
! 7764: }
! 7765: if(TQ[0][0]<TQ[1][0]){
! 7766: L=cons(cons(TT,cdr(TP)),L);
! 7767: continue;
! 7768: }
! 7769: TQ=[TQ[1],TQ[0]];
! 7770: for(TP=cdr(TP);TP!=[];TP=cdr(TP))
! 7771: TQ=cons([car(TP)[0],car(TP)[2],car(TP)[1]],TQ);
! 7772: L=conse(reverse(TQ),L);
! 7773: }
! 7774: return qsort(L);
! 7775: }
! 7776: if(F=="homog"){
! 7777: V=mc2grs(G,"nonhomog");
! 7778: return mc2grs(G,[[2,3],V/2]|unique=1);
! 7779: }else if(F=="nonhomog"){
! 7780: R=mc2grs(G,4);
! 7781: for(V=0;R!=[];R++){
! 7782: for(TR=cdr(R);TR!=[];TR=cdr(TR))
! 7783: V+=car(TR)[0]*car(TR)[1];
! 7784: }
! 7785: return -V;
! 7786: }
! 7787: }
! 7788: if(F==4){
! 7789: if(type(P[0])!=4) P=[P];
! 7790: for(;P!=[];P=cdr(P)){
! 7791: if(type(P[0][0])==4){ /* addition */
! 7792: Un=(type(getopt(unique))==1)?1:0;
! 7793: T=P[0][0];T1=[T[0],4];T2=[T[1],4];
! 7794: for(L=[],PG=reverse(G);PG!=[];PG=cdr(PG)){
! 7795: F=0;K=P[0][1];
! 7796: if(car(PG)[0][0]==T) F=1;
! 7797: else if(car(PG)[0][1]==T) F=2;
! 7798: if(!F&&!Un){
! 7799: K=-K;
! 7800: if(car(PG)[0][0]==T1||car(PG)[0][0]==T2) F=1;
! 7801: else if(car(PG)[0][1]==T1||car(PG)[0][0]==T2) F=2;
! 7802: }
! 7803: }
! 7804: if(!F) L=cons(car(PG),L);
! 7805: else{
! 7806: TG=reverse(cdr(PG));
! 7807: for(TL=[];TG!=[];TG=cdr(TG)){
! 7808: if(F==1) TL=cons([car(TG)[0],car(TG)[1]+K,car(TG)[2]],TL);
! 7809: else TL=cons([car(TG)[0],car(TG)[1]+K,car(TG)[2]],TL);
! 7810: }
! 7811: TL=cons(car(PG)[0],TL);
! 7812: L=cons(TL,L);
! 7813: }
! 7814: G=L;
! 7815: }else{ /* mc 4:cases */
! 7816: # if 0
! 7817: K=mc2grs(G,"nonhomog");
! 7818: U=P[0][1];
! 7819: GG=[];
! 7820: /* [[0,1],[2,3]] */
! 7821: for(I=1;I<4;I++){
! 7822: J=lsort([1,2,3,4],[I],1);
! 7823: }
! 7824: I=[0,I];
! 7825: G0=mc2grs(G,["get",[I,J]]);
! 7826: G0=sub2grs(G0,I,0);
! 7827: G0=add2grs(G0,I,U);
! 7828: G1=mc2grs(G,["get",[[0,4],J]]);
! 7829: G1=sub2grs(G1,[0,4],U);
! 7830: G1=mc2grs(G1,["get",J]);
! 7831: G1=join2grs(G1,I,0);
! 7832: G3=mc2grs(G,["get",[[I[0],4],[]]
! 7833: #endif
! 7834: }
! 7835: }
! 7836: return G;
! 7837: }
! 7838: }
! 7839:
1.3 takayama 7840: def delopt(L,S)
7841: {
7842: if((Inv=getopt(inv))!=1) Inv=0;
7843: for(R=[];L!=[];L=cdr(L)){
1.4 ! takayama 7844: if(type(car(L))!=4) F=0;
! 7845: else if(type(S)==4) F=(findin(car(L)[0],S)<0)?0:1;
! 7846: else F=(car(L)[0]==S)?1:0;
1.3 takayama 7847: if(F==Inv) R=cons(car(L),R);
7848: }
7849: return reverse(R);
7850: }
7851:
1.1 takayama 7852: def str_char(S,N,L)
7853: {
7854: if(type(S)==7){
7855: if(type(L)==1) L=asciitostr([L]);
7856: return str_chr(S,N,L);
7857: }
7858: if(type(L)==7) L=strtoascii(L)[0];
7859: if(type(S)==4){
7860: M=N;
7861: while(M-->0) S=cdr(S);
7862: M=findin(L,S);
7863: return (M>=0)?findin(L,S)+N:-1;
7864: }else if(type(S)==5){
7865: K=length(S);
7866: for(I=N;I<K;I++)
7867: if(S[I]==L) return I;
7868: }
7869: return -1;
7870: }
7871:
7872: def str_pair(S,N,I,J)
7873: {
7874: if(type(I)==7) I=(II=strtoascii(I))[0];
7875: if(type(J)==7) J=(JJ=strtoascii(J))[0];
7876: if(type(S)==7) S=strtoascii(S);
1.4 ! takayama 7877: if(getopt(inv)==1){
! 7878: if(II!=0){
! 7879: I=asciitostr(reverse(II));
! 7880: IL=length(II);
! 7881: }else IL=1;
! 7882: if(JJ!=0) J=asciitostr(reverse(JJ));
! 7883: R=str_pair(reverse(S),length(S)-N-1,J,I);
! 7884: if(R>=0) R=length(S)-IL-R;
! 7885: return R;
! 7886: }
1.3 takayama 7887: if((SJIS=getopt(sjis))!=1) SJIS=0;
1.1 takayama 7888: if((II!=0&&length(II)>1)||(JJ!=0&&length(JJ)>1)){
7889: for(;;){
1.3 takayama 7890: MJ=str_str(S,N|top=JJ,sjis=SJIS);
1.1 takayama 7891: if(MJ>=0){
1.3 takayama 7892: MI=str_str(S,II|top=N,sjis=SJIS);
1.1 takayama 7893: if(MI<0 || MI>MJ){
7894: if(C==0) return MJ;
7895: C--; N=MJ+length(II);
7896: }else if(MI>=0){
7897: C++; N=MI+length(JJ);
7898: }
7899: }
7900: return -1;
7901: }
7902: }
7903: if(type(S)==4){
7904: M=N;
7905: while(M-->0) S=cdr(S);
7906: while(S!=[]){
7907: if(car(S)==I) C++;
7908: else if(car(S)==J){
7909: if(C==0) return N;
7910: C--;
7911: }
7912: S=cdr(S);N++;
7913: }
7914: }else if(type(S)==5){
7915: K=length(S);
7916: for(T=N;T<K && C>=0; T++){
7917: if(S[T]==I) C++;
7918: else if(S[T]==J){
7919: if(C==0) return T;
7920: C--;
7921: }
7922: }
7923: }
7924: return -1;
7925: }
7926:
7927:
7928: def str_cut(S,I,J)
7929: {
7930: if(type(S)==7) return sub_str(S,I,J);
7931: if((JJ=length(S))<=J) J=JJ-1;
7932: if(type(S)==5){
7933: for(L=[],K=J; K>=I; K--) L=cons(S[K],L);
7934: }else if(type(S)==4){
7935: J-=I;
7936: while(I-->0) S=cdr(S);
7937: for(L=[];J-->=0;S=cdr(S)) L=cons(car(S),L);
7938: L=reverse(L);
7939: }
7940: return asciitostr(L);
7941: }
7942:
7943: def str_str(S,T)
7944: {
7945: if(S==0) return -1;
7946: if(type(S) == 7)
7947: S = strtoascii(S);
7948: if(type(J=getopt(top))!=1 || J<0) J=0;
7949: LS=length(S);
7950: if(LS-J<1) return -1;
7951: if(type(S)==4){
7952: LS-=(J0=J);
7953: for( ; J>0 && S!=[]; S=cdr(S),J--);
7954: }
7955: if(type(JJ=getopt(end))!=1 && JJ!=0) JJ=LS;
7956: else JJ-=J0;
7957: if((SJIS=getopt(sjis))!=1) SJIS=0;
7958: if(JJ-J<0) return -1;
7959: /* search from J-th to JJ-th */
7960: if(type(T)==1) T=[T];
7961: else if(type(T)==7) T = strtoascii(T);
7962: else if(type(T)==4 && type(T[0])>3){
7963: for(K=(KF=-1)-J0; T!=[]; F++,T=cdr(T)){
7964: JK=str_str(S,car(T)|top=J,end=JJ,sjis=SJIS);
7965: if(JK>=0){
7966: JJ=(K=JK)-1; KF=F;
7967: if(J>JJ) break;
7968: }
7969: }
7970: return [KF,J0+K];
7971: }
7972: if(type(T)==4) T=ltov(T);
7973: LT = length(T);
7974: if(LT>0){
7975: LE = LS-LT;
7976: LP = T[0];
7977: if(JJ==0 ||(type(JJ)==1 && JJ<LE)) LE=JJ;
7978: if(type(S)==5){
7979: for(; J <= LE; J++){
7980: if(S[J] != LP){
7981: if(SJIS && (V=S[J])>128){
7982: if(V<160 || (V>223 && V<240)) J++;
7983: }
7984: continue;
7985: }
7986: for(I = 1; I < LT && S[I+J] == T[I]; I++);
7987: if(I >= LT) return J;
7988: }
7989: }else if(type(S)==4){
7990: for(; J<=LE; S=cdr(S),J++){
7991: if(car(S) != LP){
7992: if(SJIS && (V=S[J])>128){
7993: if(V<160 || (V>223 && V<240)) J++;
7994: }
7995: continue;
7996: }
7997: for(ST=cdr(S), I = 1; I < LT && car(ST) == T[I]; I++, ST=cdr(ST));
7998: if(I >= LT) return J0+J;
7999: }
8000: }
8001: }
8002: return -1;
8003: }
8004:
1.3 takayama 8005: def str_times(S,N)
8006: {
8007: if(!isint(N)) return "";
8008: if(type(S)==7){
8009: for(Tb=str_tb(0,0);N-->0;)
8010: str_tb(S,Tb);
8011: return str_tb(0,Tb);
8012: }
8013: if(type(S)==4){
8014: for(LT=[],I=0;I<N;I++){
8015: if(type(car(S))==7){
8016: LT=cons(car(S),LT);
8017: S=cdr(S);
8018: if(S==[]) S=[[""]];
8019: }else if(type(car(S))==4){
8020: ST=car(S);
8021: for(J=0;I<N;I++){
8022: if(J==length(ST)) J=0;
8023: LT=cons(ST[J++],LT);
8024: }
8025: }
8026: }
8027: return reverse(LT);
8028: }
8029: return S;
8030: }
8031:
1.1 takayama 8032: def ssubgrs(M,L)
8033: {
8034: if(type(L)==7) L=s2sp(L);
8035: for(S=0, L=L, M=M; L!=[]; L=cdr(L), M=cdr(M)){
8036: for(LT=car(L), MT=car(M); LT!=[]; LT=cdr(LT), MT=cdr(MT)){
8037: S += car(LT)*car(MT)[1];
8038: }
8039: }
8040: return S;
8041: }
8042:
1.3 takayama 8043: def s2os(S)
8044: {
8045: return str_subst(S,[["\\","\\\\"],["\"","\\\""]],0);
8046: }
8047:
8048: def l2os(S)
8049: {
8050: if(type(S)==6)
8051: S=m2ll(S);
8052: else if(type(S)==5)
8053: S=vtol(S);
8054: else if(type(S)==7) return "\""+s2os(S)+"\"";
8055: else if(type(S)<4) return rtostr(S);
8056: if(type(S)==4){
8057: for(F=0,Tb=str_tb("[",0);S!=[];S=cdr(S)){
8058: if(F++) str_tb(", ",Tb);
8059: str_tb(l2os(car(S)),Tb);
8060: }
8061: str_tb("]",Tb);
8062: return str_tb(0,Tb);
8063: }
8064: return 0;
8065: }
8066:
8067: def r2os(S)
8068: {
8069: if(type(S)==6){
8070: for(T="",S=m2ll(S);S!=[];S=cdr(S)){
8071: if(T!="") T=T+","+r2os(car(S));
8072: else T=r2os(car(S));
8073: }
8074: return "mat("+T+")\n";
8075: }else if(type(S)==5){
8076: for(T="",S=v2l(S);S!=[];S=cdr(S)){
8077: if(T!="") T=T+","+r2os(car(S));
8078: else T=r2os(car(S));
8079: }
8080: return "vect("+T+")\n";
8081: }else if(type(S)<4) return rtostr(S);
8082: else if(type(S)==4){
8083: for(T="";S!=[];S=cdr(S)){
8084: if(T!="") T=T+","+r2os(car(S));
8085: else T=r2os(car(S));
8086: }
8087: return "["+T+"]";
8088: }else if(type(S)==7) return "\""+s2os(S)+"\"";
8089: return "";
8090: }
8091:
8092: def s2euc(S)
8093: {
8094: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
8095: if((C=car(L)) == 0x1b && length(L)>1) {
8096: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
8097: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
8098: Mode = 1;
8099: } else return 0;
8100: }else if(C == 0x28 && length(L)>1) { /* ( */
8101: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
8102: Mode = 0;
8103: }else if(C == 0x49) { /* I */
8104: Mode = 2;
8105: }else{
8106: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
8107: }
8108: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
8109: L=cdr(L);
8110: }else{
8111: R=cons(0x1b,R);R=cons(C,R);
8112: }
8113: }else if(C == 0x0e) {
8114: Mode = 2;
8115: }else if(C == 0x0f) {
8116: Mode = 0;
8117: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
8118: D=car(L=cdr(L));
8119: if(D>0x20 && D<0x7f) {
8120: R=cons(ior(C,0x80),R);R=cons(ior(D,0x80),R);
8121: } else return 0;
8122: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
8123: R=cons(0x8e,R); R=cons(ior(C,0x80),R);
8124: }else if(((C>0x80 && C<0xa0) || (C>0xdf && C<0xf0)) && length(L)>1) { /* ShiftJIS */
8125: D=car(L=cdr(L));
8126: if(D>0x3f && D<0xfd && D!=0x7f) {
8127: T=sjis2jis([C,D]);
8128: R=cons(ior(T[0],0x80),R); R=cons(ior(T[1],0x80),R);
8129: }else return 0;
8130: }else if(C>0x9f && C<0xe0) { /* HanKana */
8131: R=cons(0x8e,R); R=cons(C,R);
8132: }else if(C == 0x0a){
8133: CR++;
8134: }else if(C == 0x0d){
8135: R=cons(0x0d,R);
8136: CR=0;
8137: }else{
8138: while(CR-->0) R=cons(0x0d,R);
8139: R=cons(C,R);
8140: }
8141: }
8142: while(CR-->0) R=cons(0x0d,R);
8143: return asciitostr(reverse(R));
8144: }
8145:
8146: def s2sjis(S)
8147: {
8148: for(R=[],CR=0,L=strtoascii(S);L!=[];L=cdr(L)){
8149: if((C=car(L)) == 0x1b && length(L)>1) {
8150: if((C=car(L=cdr(L)))==0x24 && length(L)>1){ /* $ */
8151: if((C = car(L=cdr(L))) == 0x40 || C == 0x42) { /* @, B */
8152: Mode = 1;
8153: } else return 0;
8154: }else if(C == 0x28 && length(L)>1) { /* ( */
8155: if((C = car(L=cdr(L)))== 0x42 || C == 0x4a) { /* B, J */
8156: Mode = 0;
8157: }else if(C == 0x49) { /* I */
8158: Mode = 2;
8159: }else{
8160: R=cons(0x1b,R);R=cons(0x28,R);R=cons(C,R);
8161: }
8162: }else if (C == 0x26 && length(L)>1 && car(cdr(L))==0x1b) { /* & ESC */
8163: L=cdr(L);
8164: }else{
8165: R=cons(0x1b,R);R=cons(C,R);
8166: }
8167: }else if(C == 0x0e) {
8168: Mode = 2;
8169: }else if(C == 0x0f) {
8170: Mode = 0;
8171: }else if(Mode == 1 && C>0x20 && C<0x7f && length(L)>1) { /* JIS KANJI */
8172: D=car(L=cdr(L));
8173: if(D>0x20 && D<0x7f) {
8174: T=jis2sjis([C,D]);
8175: R=cons(T[0],R);R=cons(T[1],R);
8176: } else return 0;
8177: }else if(Mode == 2 && C > 0x1f && C < 0x60) { /* JIS KANA */
8178: R=cons(ior(C,0x80),R);
8179: }else if(C>0xa0 && C<0xff && length(L)>1) { /* EUC */
8180: D=car(L=cdr(L));
8181: if(D>0xa0 && D<0xff) {
8182: T=jis2sjis([iand(C,0x7f),iand(D,0x7f)]);
8183: R=cons(T[0],R);R=cons(T[1],R);
8184: }else return 0;
8185: }else if(C == 0x0a){
8186: CR++;
8187: }else if(C == 0x0d){
8188: R=cons(0x0a,R);R=cons(0x0d,R);
8189: CR=0;
8190: }else{
8191: while(CR-->0){
8192: R=cons(0x0a,R);R=cons(0x0d,R);
8193: }
8194: R=cons(C,R);
8195: }
8196: }
8197: while(CR-->0){
8198: R=cons(0x0a,R);R=cons(0x0d,R);
8199: }
8200: return asciitostr(reverse(R));
8201: }
8202:
8203: def r2ma(S)
8204: {
8205: return evalma(S|inv=1);
8206: }
8207:
8208: def evalma(S)
8209: {
8210: L0=["\n","\d","{","}","[","]","Log","Exp","Sinh","Cosh","Tanh","Sin","Cos","Tan",
8211: "ArcSin","ArcCos","ArcTan"];
8212: L1=["", "" ,"[","]","(",")","log","exp","sinh","cosh","tanh","sin","cos","tan",
8213: "asin", "acos", "atan"];
8214: if(getopt(inv)==1){
8215: if(type(S)==6) S=m2ll(S);
8216: else if(type(S)==5) S=vtol(S);
8217: if(type(S)==4){
8218: for(L=[];S!=[];S=cdr(S)){
8219: if(type(car(S))==6) L=cons(m2ll(car(S)),L);
8220: else if(type(car(S))==5) L=cons(vtol(car(S)),L);
8221: else L=cons(car(S),L);
8222: }
8223: S=reverse(L);
8224: }else return 0;
8225: return str_subst(rtostr(S),cdr(cdr(L1)),cdr(cdr(L0)));
8226: }
8227: if(S==0){
8228: print("Mathematica text (terminated by ;) ?");
8229: purge_stdin();
8230: Tb=str_tb(0,0);
8231: for(;;){
8232: S=get_line();
8233: str_tb(S,Tb);
8234: if(str_char(S,0,";")>=0) break;
8235: }
8236: S=str_tb(0,Tb);
8237: }
8238: /*
8239: while((P=str_chr(S,0,";"))>=0){
8240: V0=evalma(str_cut(S,0,P+1));
8241: S=str_cut(S,P+1,length(S));
8242: }
8243: if((P=str_char(S,0,"="))>=0){
8244: X=strtoascii(str_cut(S,0,P));
8245: L=length(X);
8246: for(P0=P1=-1,I=0;I<L;I++){
8247: if(L(I)<=32) continue;
8248: if(isalphanum(L[I])){
8249: if(P0<0){
8250: if(isnum(L[I])) break;
8251: P0=I;
8252: }
8253: else if(P1!=I+1) break;
8254: P1=I;
8255: }
8256: }
8257: if(I==L && P0>=0){
8258: for(I==P0;I-->0;) X=cdr(X);
8259: if((X0=car(X))>96) X0-=32;
8260: Y=[X0];X=cdr(X);
8261: for(I=P1-P0;I-->0;X=cdr(X))
8262: Y=cons(car(X),Y);
8263: Y=cons(61,Y);
8264: Var=asciitostr(reverse(Y));
8265: S=str_cut(S,P,length(S));
8266: }
8267: }
8268: */
8269: S=eval_str(str_subst(S,L0,L1));
8270: if(type(S)==4){
8271: for(L=-1,T=S;T!=[];T=cdr(T)){
8272: if(type(T0=car(T))>4) break;
8273: if(type(T0)<4){
8274: if(L>=0) break;
8275: L=-2;continue;
8276: }
8277: if(L<-2) break;
8278: if(L==-1) L=length(T0);
8279: else if(L!=length(T0)) break;
8280: }
8281: if(T==[]){
8282: if(L>0) S=s2m(S);
8283: else S=ltov(S);
8284: }
8285: }
8286: /*
8287: if(S==0 && V0!=0) return V0;
8288: if(type(Var)==7){
8289: T=rtostr(S);
8290: if(type(S)==7) T="\""+T+"\"";
8291: S=eval_str(Var+T);
8292: mycat(["Define",Var]);
8293: }
8294: */
8295: return S;
8296: }
8297:
8298: def i2hex(N)
8299: {
8300: Opt=getopt();
8301: if(type(N)==4 && isint(car(N))){
8302: #ifdef USEMODULE
8303: L=mtransbys(os_md.i2hex,N,[]|option_list=Opt);
8304: #else
8305: L=mtransbys(i2hex,N,[]|option_list=Opt);
8306: #endif
8307: return rtostr(L);
8308: }
8309: if(!isint(N) || N<0) return 0;
8310: if(!N) L=[];
8311: else{
8312: Cap=(getopt(cap)==1)?32:0;
8313: for(L=[];N!=0;N=ishift(N,4)){
8314: J=iand(N,15);
8315: L=cons(((J>9)?(87-Cap):48)+J,L);
8316: }
8317: }
8318: if(!isint(Min=getopt(min))) Min=2;
8319: for(Min-=length(L);Min-->0;)
8320: L=cons(48,L);
8321: if(getopt(num)==1){
8322: L=cons(120,L);L=cons(48,L);
8323: }
8324: return asciitostr(L);
8325: }
8326:
8327: def sjis2jis(L)
8328: {
8329: L1=L[1];
8330: if((L0=L[0])<=0x9f){
8331: if(L1<0x9f) L0=L0*2-0xe1;
8332: else L0=(L0*2)-0xe0;
8333: }else{
8334: if(L1<0x9f) L0=L0*2-0x161;
8335: else L0=L0*2-0x160;
8336: }
8337: if(L1<0x7f) return [L0,L1-0x1f];
8338: else if(L1<0x9f) return [L0,L1-0x20];
8339: return [L0,L1-0x7e];
8340: }
8341:
8342: def jis2sjis(L)
8343: {
8344: L1=L[1];
8345: if(iand(L0=L[0],1)){
8346: if(L1<0x60) L=[L1+0x1f];
8347: else L=[L1+0x20];
8348: }else L=[L1+0x7e];
8349: if(L0<0x5f) return cons(ishift(L0+0xe1,1),L);
8350: return cons(ishift(L0+0x161,1),L);
8351: }
8352:
1.1 takayama 8353: def verb_tex_form(P)
8354: {
8355: L = reverse(strtoascii(rtostr(P)));
8356: for(SS = []; L != []; L = cdr(L)){
8357: Ch = car(L); /* ^~\{} */
8358: if(Ch == 92 || Ch == 94 || Ch == 123 || Ch == 125 || Ch == 126){
8359: SS = append([92,Ch,123,125],SS); /* \Ch{} */
8360: if(Ch != 94 && Ch != 126) /* \char` */
8361: SS = append([92,99,104,97,114,96],SS);
8362: continue;
8363: }
8364: SS = cons(Ch, SS);
8365: if((Ch >= 35 && Ch <= 38) || Ch == 95) /* #$%&_ */
8366: SS = cons(92, SS); /* \Ch */
8367: }
8368: return asciitostr(SS);
8369: }
8370:
1.4 ! takayama 8371: def tex_cuteq(S,P)
! 8372: {
! 8373: if(P==0) return 0;
! 8374: if(S[P]==125){ /* } */
! 8375: if((Q=str_pair(S,P-1,"{","}"|inv=1))<0) return -1;
! 8376: if(Q<2||S[Q-1]!=95) return Q;
! 8377: return tex_cuteq(S,Q-2);
! 8378: }
! 8379: if(!isalphanum(S[Q=P--])) return -1;
! 8380: while(P>0&&isalphanum(S[P])) P--;
! 8381: if(S[P]==92){ /* \ */
! 8382: if(P==0) return P;
! 8383: else P--;
! 8384: }
! 8385: if(S[P]!=95||P==0) return Q; /* _ */
! 8386: return tex_cuteq(S,P-1);
! 8387: }
! 8388:
! 8389:
! 8390: def texket(S)
! 8391: {
! 8392: if(!isint(F=getopt(all))) F=0;
! 8393: if(type(S)==7){
! 8394: L=str_len(S);
! 8395: SS=strtoascii(S);
! 8396: }else{
! 8397: L=length(S);
! 8398: SS=S;
! 8399: }
! 8400: for(T="",I=I0=0;I<L-1;){
! 8401: J=str_char(SS,I,"(");
! 8402: if(J<0) break;
! 8403: if(J<L-1 && J>4 && str_str(SS,"\\left"|top=J-5,end=J-1)>=0){
! 8404: I=J+1;continue;
! 8405: }
! 8406: if((K=str_pair(SS,J+1,"(",")"))>=0){
! 8407: KK=str_char(SS,J+2,"(");
! 8408: if(KK>K||KK<0){
! 8409: if(F!=1){
! 8410: if(!F){
! 8411: for(N=J+1;N<K;N++) /* + - _ { } */
! 8412: if(!isalphanum(P=SS[N])&&findin(P,[32,43,45,95,123,125])<0) break;
! 8413: }else N=K;
! 8414: if(N==K){
! 8415: I=K+1;continue;
! 8416: }
! 8417: }
! 8418: T=T+str_cut(SS,I0,J-1)+"\\left"+str_cut(SS,J,K-1)+"\\right)";
! 8419: I0=I=K+1;
! 8420: }else{
! 8421: T=T+str_cut(SS,I0,J-1)+"\\left("+texket(str_cut(SS,J+1,K-1)|all=F) +"\\right)";
! 8422: I0=I=K+1;
! 8423: }
! 8424: }else break;
! 8425: }
! 8426: return T+str_cut(SS,I0,L);
! 8427: }
! 8428:
! 8429:
1.1 takayama 8430: def my_tex_form(S)
8431: {
8432: if(getopt(skip) != 1){
1.3 takayama 8433: if(type(S)==1 && S<0) return "-"+print_tex_form(-S);
1.4 ! takayama 8434: if(type(S)==6) return mtotex(S);
1.1 takayama 8435: S = print_tex_form(S);
8436: for(F=Top=0;(L=str_str(S,"\\verb`"|top=Top))>=0;Top=LV+1){
8437: F++;
8438: if(Top==0) Tb = string_to_tb("");
8439: LV = str_chr(S, L+6, "`");
8440: if(LV<0) LV=str_len(S);
8441: str_tb([my_tex_form(sub_str(S, Top, L-1)|skip=1), "\\texttt{"], Tb);
8442: str_tb([verb_tex_form(sub_str(S,L+6, LV-1)),"}"], Tb);
8443: Top=LV+1;
8444: }
1.3 takayama 8445: if(F>0){
8446: str_tb(my_tex_form(sub_str(S, Top,str_len(S)-1)|skip=1), Tb);
8447: return tb_to_string(Tb);
8448: }
1.1 takayama 8449: }
8450: if(S==0) return "";
8451: S = ltov(strtoascii(S));
8452: L = length(S)-1;
8453: while(L >= 1 && S[L] == 10)
8454: L--;
1.3 takayama 8455: if((Fr=getopt(frac))!=0 && Fr!=1) Fr=2;
8456: for(I = L+1, T = K = 0, SS = []; --I >= 0; ){
8457: if(S[I] == 32 && I!=L){
8458: if(I==L) continue;
1.1 takayama 8459: if(findin(S[I+1], [32,40,41,43,45,123,125]) >= 0 /* " ()+-{}" */
8460: || (S[I+1] >= 49 && S[I+1] <= 57)) /* 1 - 9 */
1.3 takayama 8461: if(I == 0 || S[I-1] >= 32) continue;
8462: }
8463: if(Fr && S[I]>=48 && S[I]<=57){ /* 2/3 -> \tfrac{2}{3} */
8464: for(K=0,II=I; II>=0; II--){
8465: if(S[II]>=48 && S[II]<=57) continue;
8466: if(S[II]==47){ /* / */
8467: if(K>0) break;
8468: K=II;
8469: }else break;
8470: }
8471: if(K>II+1){
8472: SS=cons(125,SS);
8473: for(J=I; J>K; J--) SS=cons(S[J],SS);
8474: if(AMSTeX){
8475: SS=cons(123,SS);SS=cons(125,SS);
8476: }else{
8477: for(J=[114,101,118,111,92];J!=[];J=cdr(J)) /* \over */
8478: SS=cons(car(J),SS);
8479: }
8480: for(J=K-1;J>II;J--) SS=cons(S[J],SS);
8481: SS=cons(123,SS);
8482: if(AMSTeX){
8483: J=(Fr==2)?[99,97,114,102,116,92]:[99,97,114,102,92];
8484: for(;J!=[];J=cdr(J)) /* \tfrac */
8485: SS=cons(car(J),SS);
8486: }
8487: I=II+1;
8488: }else{
8489: for(;I>II;I--) SS = cons(S[I], SS);
8490: I++;
8491: }
8492: continue;
1.1 takayama 8493: }
8494: SS = cons(S[I], SS);
8495: }
1.4 ! takayama 8496: SS=str_subst(SS,"\\\\\n\\end{pmatrix}","\n\\end{pmatrix}"|raw=1);
1.1 takayama 8497: Subst=getopt(subst);
1.4 ! takayama 8498: Sub0=["{asin}","{acos}","{atan}"];
! 8499: Sub1=["\\arcsin ","\\arccos","\\arctan "];
! 8500: if(type(Subst) == 4){
! 8501: Sub0=append(Sub0,Subst[0]);Sub1=append(Sub1,Subst[1]);
! 8502: }
! 8503: SS = str_subst(SS,Sub0,Sub1|raw=1);
1.1 takayama 8504: S = ltov(SS);
8505: L = length(S);
8506: SS = [];
8507: while(--L >= 0){
8508: if(S[I=L] == 125){
8509: while(--I >= 0 && S[I] == 125);
8510: J = 2*I - L;
8511: if(J >= 0 && S[I] != 123){
8512: for(K = J; K < I && S[K] == 123; K++);
8513: if(K == I){
8514: if(J-- <= 0 || S[J] < 65 || S[J] > 122 || (S[J] > 90 && S[J] < 97)){
1.3 takayama 8515: SS = cons(S[I],SS);
1.1 takayama 8516: L = J+1;
8517: continue;
8518: }
8519: }
8520: }
8521: }
1.3 takayama 8522: SS = cons(S[L],SS);
8523: }
1.4 ! takayama 8524: RT=getopt(root);
! 8525: for(Top=0;;Top++){ /* ((x+1))^{y} , 1/y=2,3,...,9 */
! 8526: #if 1
! 8527: P=str_str(SS,["))^","^{\\tfrac{1}"]|top=Top);
! 8528: if(P[0]<0) break;
! 8529: Sq=0;
! 8530: if(P[0]==0){
! 8531: P=P[1];
! 8532: if((Q=str_pair(SS,P,"(",")"|inv=1))<0||SS[Q+1]!=40) continue;
! 8533: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
! 8534: && SS[P+14]==125){
! 8535: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
! 8536: }
! 8537: F=2;
! 8538: }else{
! 8539: P=P[1];
! 8540: if(SS[P+12]!=125||(Sq=(SS[P+11]-48))<2||Sq>9) break;
! 8541: if(SS[P-1]==125){
! 8542: if((Q=str_pair(SS,P-2,"{","}"|inv=1))<0) break;
! 8543: if(Q>1&&SS[Q-1]==95){
! 8544: if((Q=tex_cuteq(SS,Q-2))<0) break;
! 8545: F=0;
! 8546: }else F=1;
! 8547: }else{
! 8548: if(!isalphanum(SS[Q=P-1]) || (Q=tex_cuteq(SS,Q))<0) break;
! 8549: F=0;
! 8550: }
! 8551: if(RT!=2&&P-Q>32) break;
! 8552: }
! 8553: #else
! 8554: if((P=str_str(SS,"))^"|top=Top))<0 || (Q=str_pair(SS,P,"(",")"|inv=1))<0) break;
! 8555: else F=2;
! 8556: Sq=0;
! 8557: if((RT==2||(RT!=0 && P-Q<33)) && str_str(SS,"{\\tfrac{1}"|top=P+3,end=P+3)==P+3
! 8558: && SS[P+14]==125){
! 8559: if((Sq=SS[P+13]-48)<2||Sq>9) Sq=0;
! 8560: }
! 8561: #endif
1.3 takayama 8562: for(I=0,S=[];SS!=[];SS=cdr(SS),I++){
1.4 ! takayama 8563: if(I==Q){
! 8564: if(Sq){
! 8565: S=append([116,114,113,115,92],S);
! 8566: if(Sq>2) S=append([93,Sq+48,91],S);
! 8567: S=cons(123,S);
! 8568: if(F==2) SS=cdr(SS);
! 8569: else if(F==0) S=cons(car(SS),S);
! 8570: }else if(F==2&&P-Q==3){ /* (2)^x -> 2^x*/
! 8571: SS=cdr(SS);SS=cdr(SS);
! 8572: S=cons(123,S);S=cons(car(SS),S);S=cons(125,S);
! 8573: SS=cdr(SS);SS=cdr(SS);
! 8574: I+=3;
! 8575: }
! 8576: continue;
! 8577: }else if(I==P){
! 8578: if(Sq){
! 8579: if(F>0) S=cdr(S);
! 8580: S=cons(125,S);
! 8581: if(F==2) SS=cdr(SS);
! 8582: for(J=0;J<12;J++) SS=cdr(SS);
! 8583: }
! 8584: continue;
! 8585: }
1.3 takayama 8586: S=cons(car(SS),S);
8587: }
8588: SS=reverse(S);
8589: Top=P;
1.1 takayama 8590: }
1.4 ! takayama 8591: S=asciitostr(SS);
! 8592: if((K=getopt(ket))==1) S=texket(S);
! 8593: else if(K==2) S=texket(S|all=1);
! 8594: return S;
1.1 takayama 8595: }
8596:
8597: def smallmattex(S)
8598: {
8599: return str_subst(S,[["\\begin{pmatrix}","\\left(\\begin{smallmatrix}"],
8600: ["\\end{pmatrix}","\\end{smallmatrix}\\right)"],
8601: ["\\begin{Bmatrix}","\\left\\{\\begin{smallmatrix}"],
8602: ["\\end{Bmatrix}","\\end{smallmatrix}\\right\\}"],
8603: ["\\begin{bmatrix}","\\left[{\\begin{smallmatrix}"],
8604: ["\\end{bmatrix}","\\end{smallmatrix}\\right]"],
8605: ["\\begin{vmatrix}","\\left|\\begin{smallmatrix}"],
8606: ["\\end{vmatrix}","\\end{smallmatrix}\\right|"],
8607: ["\\begin{Vmatrix}","\\left\\|\\begin{smallmatrix}"],
8608: ["\\end{Vmatrix}","\\end{smallmatrix}\\right\\|"],
8609: ["\\begin{matrix}","\\begin{smallmatrix}"],
8610: ["\\end{matrix}","\\end{smallmatrix}"]],0);
8611: }
8612:
8613: def str_subst(S, L0, L1)
8614: {
8615: if(type(S) == 7)
8616: S = strtoascii(S);
8617: if(type(S) == 4)
8618: S = ltov(S);
8619: SE = length(S);
8620: if(L1 == 0){
8621: for(L1 = L = [], L0 = reverse(L0); L0 != []; L0 = cdr(L0)){
8622: L = cons(car(L0)[0], L);
8623: L1 = cons(car(L0)[1], L1);
8624: }
8625: L0 = L;
8626: }
8627: if(type(L0)==7) L0 = [strtoascii(L0)];
8628: else{
8629: for(LT = []; L0 != []; L0 = cdr(L0))
8630: LT = cons(strtoascii(car(L0)), LT);
8631: L0 = ltov(LT);
8632: }
8633: E0 = length(L0);
8634: if(type(L1)==7) L1 = [strtoascii(L1)];
8635: else{
8636: for(LT = []; L1 != []; L1 = cdr(L1))
8637: LT = cons(strtoascii(car(L1)), LT);
8638: L1 = ltov(LT);
8639: }
1.3 takayama 8640: if(getopt(inv)==1){
8641: L2=L0;L0=L1;L0=L2;
8642: }
1.1 takayama 8643: if((SJIS=getopt(sjis))!=1) SJIS=0;
8644: for(J = JJ = 0, ST = []; J < SE; J++){
8645: SP = S[J];
8646: for(I = E0-1; I >= 0; I--){
8647: if(SP != L0[I][0] || J + (K = length(L0[I])) > SE)
8648: continue;
8649: while(--K >= 1)
8650: if(L0[I][K] != S[J+K]) break;
8651: if(K > 0) continue;
8652: for(KE = length(L1[I]), K = 0 ;K < KE; K++)
8653: ST = cons(L1[I][K],ST);
8654: J += length(L0[I])-1;
8655: break;
8656: }
8657: if(I < 0){
8658: ST = cons(S[J],ST);
8659: if(SJIS && (V=S[J])>128){
8660: if(V<160 || (V>223 && V<240)) ST = cons(S[J++],ST);
8661: }
8662: }
8663: }
1.4 ! takayama 8664: if(getopt(raw)==1) return reverse(ST);
1.1 takayama 8665: return asciitostr(reverse(ST));
8666: }
8667:
8668: def dviout0(L)
8669: {
1.4 ! takayama 8670: Cmd=["TikZ","TeXLim","TeXEq","DVIOUT","XYPrec","XYcm","XYLim","Canvas"];
1.3 takayama 8671: if(type(Opt=getopt(opt))==7){
8672: if((F=findin(Opt,Cmd)) < 0) return -1;
8673: if(L==-1){
8674: if(F<=3){
8675: if(F==0) V=TikZ;
8676: else if(F==1) V=TeXLim;
8677: else if(F==2) V=TeXEq;
8678: else V=iand(DVIOUTF,1);
8679: }else{
8680: if(F==4) V=XYPrec;
8681: else if(F==5) V=XYcm;
1.4 ! takayama 8682: else if(F==6) V=XYLim;
! 8683: else V=Canvas;
1.3 takayama 8684: }
8685: return V;
8686: }
8687: if(F==0) TikZ=L;
8688: else if(F==2) TeXEq=L;
8689: else if(F==3){
8690: if(iand(DVIOUTF,1)==L)
8691: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
8692: else dviout0(4);
8693: return 1;
1.4 ! takayama 8694: }else if(F==7&&type(L)==4)
! 8695: Canvas=L;
! 8696: else if(L>0){
1.3 takayama 8697: if(F==1) TeXLim=L;
8698: else if(F==4) XYPrec=L;
8699: else if(F==5) XYcm=L;
8700: else if(F==6) XYLim=L;
8701: }
8702: mycat0([Cmd[F],"=",L],1);
8703: return 1;
8704: }
1.1 takayama 8705: if(type(L) == 4){
1.3 takayama 8706: for( ; L != []; L = cdr(L)) dviout0(car(L));
1.1 takayama 8707: return 1;
8708: }
8709: if(type(L) == 7){
1.3 takayama 8710: if(L=="") dviout(" \n"|keep=1);
8711: else if(L=="cls") dviout0(0);
8712: else if(L=="show") dviout(" ");
1.4 ! takayama 8713: else if(L=="?") dviout0(3);
1.3 takayama 8714: else dviout("\\"+L+"\n"|keep=1);
1.1 takayama 8715: return 1;
8716: }
8717: if(L == 0)
8718: dviout(" "|keep=1,clear=1);
8719: else if(L == 1)
8720: dviout(" ");
8721: else if(L == 2)
8722: dviout(" "|clear=1);
8723: else if(L>10)
8724: dviout("\\setcounter{MaxMatrixCols}{"+rtostr(L)+"}%"|keep=1);
8725: else if(L < 0)
8726: dviout(" "|delete=-L,keep=1);
8727: else if(L == 3){
1.3 takayama 8728: mycat0(["DIROUT =\"", DIROUT,"\""],1);
8729: mycat0(["DVIOUTH=\"", DVIOUTH,"\""],1);
8730: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
8731: mycat0(["DVIOUTB=\"", DVIOUTB,"\""],1);
8732: mycat0(["DVIOUTL=\"", DVIOUTL,"\""],1);
1.4 ! takayama 8733: mycat(["Canvas =", Canvas]);
1.1 takayama 8734: mycat(["TeXLim =", TeXLim]);
8735: mycat(["TeXEq =", TeXEq]);
8736: mycat(["AMSTeX =", AMSTeX]);
1.3 takayama 8737: mycat(["TikZ =", TikZ]);
8738: mycat(["XYPrec =", XYPrec]);
8739: mycat(["XYcm =", XYcm]);
8740: mycat(["XYLim =", XYLim]);
8741: }else if(L==4){
8742: Tmp=DVIOUTA; DVIOUTA=DVIOUTB; DVIOUTB=Tmp;
8743: mycat0(["DVIOUTA=\"", DVIOUTA,"\""],1);
8744: DVIOUTF++;
8745: }else if(L==5){
8746: if(!iand(DVIOUTF,1)) dviout0(4);
8747: }else if(L==6){
8748: TikZ=1;mycat("TikZ=1");
8749: }else if(L==7){
8750: TikZ=0;mycat("TikZ=0");
1.1 takayama 8751: }
8752: return 1;
8753: }
8754:
8755: def myhelp(T)
8756: {
8757: /* extern DVIOUT; */
8758: /* extern HDVI; */
8759: /* extern DVIOUTH; */
8760:
8761: if(type(T)==2){
8762: if(T==getbygrs){
8763: getbygrs(0,0);
8764: return 0;
8765: }
8766: else if(T==m2mc){
8767: m2mc(0,0);
8768: return 0;
8769: }
8770: else if(T==mgen){
8771: mgen(0,0,0,0);
8772: return 0;
8773: }
8774: else T=rtostr(T);
8775: }
8776: if(type(T)==4 && typeT[0]==7){
8777: if(length(T)==2 && type(T[1])==1){
8778: DVIOUTH="start "+T[0]+" -"+rtostr(T[1])+"-hyper:0x90 \"%ASIRROOT%\\help\\os_muldif.dvi\" #r:%LABEL%";
8779: }else if(str_len(T[0])>2) DVIOUTH=T[0];
8780: mycat(["DVIOUTH="+DVIOUTH,"\nmyhelp(fn) is set!"]);
8781: return 0;
8782: }
8783: if(T==0){
8784: mycat([
8785: "myhelp(t) : show help\n",
8786: #ifdef USEMODULE
8787: " t : -1 (dvi), 1 (pdf) or os_md.getbygrs, os_md.m2mc, os_md.mgen\n",
8788: #else
8789: " t : -1 (dvi), 1 (pdf) or getbygrs, m2mc, mgen\n",
8790: #endif
8791: " \"fn\" : Help of the function fn\n",
8792: " [path,n] : path of dviout, n = # dviout\n",
8793: " [DVIOUTH] : Way to jump to the help of a function\n",
8794: " default: start dviout -2 \"%ASIRTOOT%\\help\\os_muldif.dvi\" #r:%LABEL%"
8795: ]);
8796: return 0;
8797: }
8798: if(type(T)==7){
8799: if(str_str(T,"os_md.")==0) T=str_cut(T,6,str_len(T)-1);
8800: Dr=str_subst(DVIOUTH,["%ASIRROOT%","%LABEL%"],[get_rootdir(),"r:"+str_subst(T,"_","")]);
8801: shell(Dr);
8802: return 0;
8803: }
8804: Dr=get_rootdir();
8805: if(T==-1) Dr+="\\help\\os_muldif.dvi";
8806: else Dr+="\\help\\os_muldif.pdf";
8807: if(!isMs()) Dr=str_subst(Dr,"\\","/");
8808: shell(Dr);
8809: return 0;
8810: }
8811:
8812: def isMs()
8813: {
8814: if(type(Tmp=getenv("TEMP"))!=7) {
8815: if (type(Tmp=getenv("TMP")) != 7) Tmp=getenv("HOME");
8816: }
8817: if(type(Tmp)==7 && str_chr(Tmp,0,"\\")==2) return 1;
8818: else return 0;
8819: }
8820:
1.3 takayama 8821: def tocsv(L)
8822: {
8823: if(type(L)==6) L=m2ll(L);
8824: else if(type(L)==5) L=vtol(L);
8825: Null=getopt(null);
8826: Tb=str_tb(0,0);
8827: for(LL=L; LL!=[]; LL=cdr(LL)){
8828: LT=car(LL);
8829: if(type(LT)==5) LT=vtol(LT);
8830: if(type(LT)<4) LT=[LT];
8831: for(N=0; LT!=[]; LT=cdr(LT),N++){
8832: if(N) str_tb(", ",Tb);
8833: if((T=car(LT))==Null) continue;
8834: if(type(T)==7){
8835: K=str_len(T);
8836: T=str_subst(T,["\""],["\"\""]);
8837: if(str_len(T)>K||str_char(T,0,",")>=0) T="\""+T+"\"";
8838: str_tb(T,Tb);
8839: }else str_tb(rtostr(T),Tb);
8840: }
8841: str_tb("\n",Tb);
8842: }
8843: return str_tb(0,Tb);
8844: }
8845:
8846: def readcsv(F)
8847: {
8848: if((ID=open_file(F))<0) return -1;
8849: SJIS=isMs();
8850: L=[];
8851: if(type(V=getopt(eval))!=4){
8852: if(V=="all") V=1;
8853: else if(type(V)==1) V=[V];
8854: else V=[];
8855: }
8856: Sp=getopt(sp);
8857: if(type(T=getopt(col))!=1) T=0;
8858: Null=getopt(null);
8859: while((S=get_line(ID))!=0){
8860: S=strtoascii(S);
8861: N=length(S);
8862: for(I=J=F=0,LL=LT=[];I<N;I++){
8863: C=S[I];
8864: if(F==0){
8865: if(C<=32) continue;
8866: if(C==34){F=2;continue;}
8867: F=1;
8868: }
8869: if(F==2 && C==34){
8870: if(I<N-1&& S[I+1]==34){
8871: LT=cons(34,LT);I++;continue;
8872: }
8873: F=-2;
8874: }
8875: if(F==1){
8876: if((C==44&&Sp!=1)||(C<=32&&Sp==1)) F=-1;
8877: else if(C<32 && C!=9) continue;
8878: }
8879: if(SJIS && I<N-1 && ((C>128 && C<160)||(C>223 && C<240))){
8880: LT=cons(C,LT);LT=cons(S[++I],LT);continue;
8881: }
8882: if(F>0){
8883: LT=cons(C,LT);continue;
8884: }
8885: LS=asciitostr(reverse(LT));
8886: if(V==1||findin(++J,V)>=0) LS=(type(Null)>=0 && LS=="")?Null:eval_str(LS);
8887: if(!T || T==J) LL=cons(LS,LL);
8888: if(F==-2) while(++I<N && Sp!=1 && S[I]!=44);
8889: F=0;LT=[];
8890: }
8891: if(I<=N && (Sp!=1 || length(LT)>0)){ /* lastline */
8892: LS=asciitostr(reverse(LT));
8893: if(findin(++J,V)>=0) LS=(type(Null)>=0 && LS=="")?Null:eval_str(LS);
8894: if(!T || T==J) LL=cons(LS,LL);
8895: }
8896: L=cons(reverse(LL),L);
8897: }
8898: close_file(ID);
8899: if(T) L=m2l(L|flat=1);
8900: return reverse(L);
8901: }
1.1 takayama 8902:
8903: def showbyshell(S)
8904: {
8905: Id = getbyshell(S);
8906: if(Id<0) return Id;
8907: while((S=get_line(Id))!=0) print(S,2);
8908: return close_file(Id);
8909: }
8910:
1.3 takayama 8911:
1.1 takayama 8912: def getbyshell(S)
8913: {
8914: /* extern DIROUT; */
8915:
8916: Home=getenv("HOME");
8917: if(type(Home)!=7) Home="";
8918: if(type(Tmp=getenv("TEMP"))!=7 && type(Tmp=getenv("TMP")) != 7)
8919: Tmp=str_subst(DIROUT,["%HOME%","%ASIRROOT%"],[Home,get_rootdir()]);
8920: Sep=isMs()?"\\":"/";
8921: F=Tmp+Sep+"muldif.tmp";
8922: if(type(S)<=1 && S>=0) close_file(Id);
8923: remove_file(F);
8924: if(type(S)<=1) return -1;
8925: shell(S+" > \""+F+"\"");
8926: return open_file(F);
8927: }
8928:
8929: def show(P)
8930: {
8931: T=type(P);
8932: S=P;
8933: Var=getopt(opt);
8934: if(Var=="verb"){
8935: dviout("{\\tt"+verb_tex_form(T)+"}\n\n");
8936: return;
8937: }
1.3 takayama 8938: if(type(Var)<0) Var=getopt(var);
1.1 takayama 8939: if(T==6){
8940: if((Sp=getopt(sp))==1 || Sp==2)
8941: S=mtotex(P|lim=1,small=2,sp=Sp,null=1,mat="B");
1.3 takayama 8942: else if(type(Var)==4 || type(Var)==7)
1.1 takayama 8943: S=mtotex(P|lim=1,small=2,var=Var);
8944: else
8945: S=mtotex(P|lim=1,small=2);
8946: Size=size(P);
8947: Size=(Size[0]>Size[1])?Size[0]:Size[1];
8948: if(Size>10) dviout0(Size);
8949: }else if(T<=3){
1.4 ! takayama 8950: X=0;
! 8951: if(Var=="pfrac") X=var(P);
! 8952: else X=getopt(pfrac);
! 8953: if(isvar(X)){
! 8954: pfrac(P,X|dviout=1);
! 8955: return;
! 8956: }
! 8957: Opt=cons(["dviout",1],getopt());
! 8958: if(type(Var)==2||type(Var)==4||type(Var)==7) fctrtos(P|option_list=Opt);
! 8959: else{
! 8960: if(isdif(P)!=0) Opt=cons(["var","dif"],Opt);
! 8961: else Opt=cons(["br",1],Opt);
! 8962: fctrtos(P|option_list=Opt);
! 8963: }
1.1 takayama 8964: return;
8965: }else if(T==4){
8966: if(type(Var)==4 || type(Var)==7){
1.4 ! takayama 8967: S=ltotex(P|option_list=getopt());
1.1 takayama 8968: if(Var=="text"){
8969: dviout(S);
8970: return;
8971: }
8972: }else{
8973: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
8974: LL=car(L);
8975: if(type(LL)==4){
8976: if(F==0){
8977: T=type(LL[0]);
8978: if(T==4) F=2; /* [[[? */
8979: else if(T==1 || T==0) F=1; /* [[num,.. */
8980: }
8981: if(F==1){
8982: if(length(LL)!=2 || !isint(LL[0]) || LL[0]<0 || type(LL[1])>3)
8983: F=-1; /* [[num,rat],[num,rat],...] */
8984: }else if(F==2){
8985: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
8986: LLL=car(LLT); /* [[[num,rat],[num,rat],...],[[..],..]],....] */
8987: if(length(LLL)!=2 || !isint(LLL[0]) || LLL[0]<0 || type(LLL[1])>3)
8988: F=-1;
8989: }
8990: }
8991: }else if((F==0 || F==7) && type(LL)==7){
8992: F=7;
8993: }else F=-1;
8994: }
8995: if(F==1) S=ltotex(P|opt="spt");
8996: else if(F==2){
8997: M=mtranspose(lv2m(S));
8998: show(M|sp=1); /* GRS */
8999: return;
9000: }else if(F==7) S=ltotex(P|opt="spts");
9001: else{
9002: for(F=0,L=P;L!=[] && F!=-1;L=cdr(L)){
9003: LL=car(L);
9004: if(type(LL)!=4){
9005: F=-1; break;
9006: }
9007: for(LLT=LL; LLT!=[] && F!=-1; LLT=cdr(LLT)){
9008: T=type(LLL=car(LLT));
9009: if(T<7 && T!=4) F0++;
9010: else if(T==7){
9011: if(str_char(LLL,0,"\\")<0) F1++;
9012: else F2++;
9013: }else F=-1;
9014: }
9015: }
9016: }
9017: if(F==0 && F0>0 && (F1+F2)>0){ /* list of list of eq and str */
9018: if(F2>0) S=ltotex(P|opt=["cr","spts0"],str=1);
9019: else S=ltotex(P|opt=["cr","spts"]);
1.4 ! takayama 9020: }else{
! 9021: for(S="[";;){
! 9022: S+=my_tex_form(car(P));
! 9023: if((P=cdr(P))==[]){
! 9024: S+="]";break;
! 9025: }
! 9026: S+=",";
! 9027: }
1.1 takayama 9028: }
9029: }
9030: }else if(T==7){
9031: if(Var=="raw" ||
9032: (Var !="eq" && str_chr(P,0,"\\")<0 && str_char(P,0,"^")<0 && str_char(P,0,"_")<0
9033: && str_char(P,0,"&")<0)){
9034: dviout(P+"\n\n");
9035: return;
9036: }
9037: }
9038: dviout(S|eq=5);
9039: }
9040:
9041:
9042: /* options : eq = 1 - 8, clear=1, keep=1, delete=1, title=s,
1.3 takayama 9043: fctr=1, begin=s */
1.1 takayama 9044: def dviout(L)
9045: {
1.3 takayama 9046: /* extern AMSTeX, TeXEq, DIROUT, DVIOUTA, DVIOUTB, DVIOUTL; */
1.1 takayama 9047:
9048: MyEq = [
9049: ["\\[\n ","\\]"],
9050: ["\\begin{align}\n","\\end{align}"],
9051: ["\\begin{gather}\n ","\\end{gather}"],
9052: ["\\begin{multline}\n ","\\\\[-15pt]\\end{multline}"],
9053: ["\\begin{align}\\begin{split}\n &","\\end{split}\\end{align}"],
9054: ["\\begin{align*}\n &","\\end{align*}"],
9055: ["\\begin{gather*}\n ","\\end{gather*}"],
9056: ["\\begin{equation}\n ","\\end{equation}"]
9057: ];
9058: if(!chkfun("print_tex_form", "names.rr"))
9059: return 0;
9060: Home=getenv("HOME");
9061: if(type(Home)!=7) Home="";
1.4 ! takayama 9062: Dir=str_subst(DIROUT,["%HOME%","%ASIRROOT%","\\"],[Home,get_rootdir(),"/"]);
1.1 takayama 9063: Dirout=Dir+(AMSTeX?"/out.tex":"/out0.tex");
9064: Risaout=(AMSTeX)?"risaout":"risaout0";
9065: Dirisa=Dir+"/"+Risaout+".tex";
9066: Viewer="dviout";
9067: SV=["c:/w32tex/dviout","c:/dviout"];
9068: Risatex=str_subst(AMSTeX?DVIOUTA:DVIOUTL,
1.3 takayama 9069: ["%HOME%","%ASIRROOT%","%TikZ%"],[Home,get_rootdir(),rtostr(TikZ)]);
1.1 takayama 9070: if(isMs() && !access(Risatex)){
9071: for(TV=SV; TV!=[]; TV=cdr(TV)){
9072: VV=car(TV)+"/dviout.exe";
9073: if(access(VV)){
9074: Viewer=str_subst(VV,"/","\\");
9075: break;
9076: }
9077: }
9078: output(Risatex);
9079: print("cd \""+str_subst(Dir,"/","\\")+"\"");
9080: print("latex -src=cr,display,hbox,math,par "+Risaout);
9081: print("start "+Viewer+" -1 \""+Dr+"\\tex\\"+Risaout+"\" 1000");
9082: output();
9083: }
9084: if(access(Dirisa) == 0){
9085: D0="\""+(isMs()?str_subst(Dir,"/","\\")+"\"":Dir);
9086: shell("mkdir "+D0);
9087: output(Dirisa);
9088: if(AMSTeX){
9089: print("\\documentclass[a4paper]{amsart}");
9090: print("\\usepackage{amsmath,amssymb,amsfonts}");
9091: }else
9092: print("\\documentclass[a4paper]{article}");
9093: print("\\pagestyle{empty}\n\\begin{document}\n\\thispagestyle{empty}");
9094: print(AMSTeX?"\\input{out}\n\\end{document}":"\\input{out0}\n\\end{document}");
9095: output();
9096: }
9097: if((K = getopt(delete)) >= 1){ /* delete */
9098: LC = 0;
9099: if(type(K) == 1 && K > 10) K = 10;
9100: if(type(K) == 4){
9101: K = qsort(K);
9102: LC = 1; /* specific lines */
9103: }
9104: Done = 1;
9105: Id = open_file(Dirout);
9106: if(Id >= 0){
9107: Buf = Buf0 = Buf1 = Key = "";
9108: PE = 0;
9109: if(type(K) == 1)
9110: BufE = newvect(K--);
9111: Dout = Dirout+"0";
9112: remove_file(Dout);
9113: output(Dout);
9114: while((S = get_line(Id)) != 0){
9115: if(LC){
9116: while(K != [] && car(K) < LC)
9117: K = cdr(K);
9118: if(K == [] || car(K) > LC)
9119: output(S);
9120: }
9121: if(Key == ""){
9122: if((P0 = str_str(S,"\\begin{")) == 0){
9123: Key = sub_str(S,7,str_str(S,"}")-1);
1.3 takayama 9124: if(findin(Key,["align", "gather","multline", "equation","align*"]) < 0)
1.1 takayama 9125: Key = "";
9126: else{
9127: Key = "\\end{"+Key+"}";
9128: if(!LC){
9129: if(Buf != ""){
9130: if(PE < K)
9131: BufE[PE++] = Buf1+Buf;
9132: else{
9133: if(K > 0){
9134: print(BufE[0]);
9135: for(I = 1; I < K; I++)
9136: BufE[I-1]=BufE[I];
9137: BufE[K-1] = Buf1+Buf;
9138: }else
9139: print(Buf1+Buf);
9140: Done = 0;
9141: }
9142: Buf1 = Buf0;
9143: Buf = Buf0 ="";
9144: }
9145: }
9146: }
9147: }
9148: if(Key == "" && !LC) Buf0 += S;
9149: }
9150: if(Key != ""){
9151: if(!LC) Buf += S;
9152: if(str_str(S,Key) >= 0){
9153: Key = "";
9154: if(LC) LC++;
9155: }
9156: }
9157: }
9158: output();
9159: close_file(Id);
9160: }
9161: if(Done==0){
9162: Id = open_file(Dout);
9163: if(Id >= 0){
9164: remove_file(Dirout);
9165: output(Dirout);
9166: while((S = get_line(Id)) != 0)
9167: print(S,0);
9168: output();
9169: close_file(Id);
9170: }
9171: remove_file(Dout);
9172: }else L=" ";
9173: }
9174: if(getopt(clear) == 1 || Done == 1){ /* clear */
9175: remove_file(Dirout);
9176: if(L == "" || L == " "){
9177: output(Dirout);
9178: print("\\centerline{Risa/Asir}");
9179: output();
9180: }
9181: }
9182: if(L != " "){
1.3 takayama 9183: Eq=1;
1.1 takayama 9184: Eqo = getopt(eq);
9185: Fc = getopt(fctr);
9186: if(Fc == 1 && (type(L) == 2 || type(L) == 3)){
9187: L = fctrtos(L|TeX=1);
9188: if(type(L) == 4)
9189: L = "\\fact{"+L[0]+"}{"+L[1]+"}";
1.3 takayama 9190: if(type(Eqo) != 0 && type(Eqo) !=7){
1.1 takayama 9191: Eqo=0;
1.3 takayama 9192: }
1.1 takayama 9193: }
9194: if(type(L) != 4 || getopt(mult) != 1)
9195: L = [L];
1.3 takayama 9196: if(type(Eqo)!=7 && (Eqo<1 || Eqo>8))
1.1 takayama 9197: Eqo = (AMSTeX==1)?TeXEq:1;
9198: Title = getopt(title);
9199: if(type(Title) == 7){
9200: output(Dirout);
9201: print(Title);
9202: output();
9203: }
9204: Sb = getopt(subst);
9205: for( ; L != []; L = cdr(L)){
9206: Eq = 1;
9207: if(type(LT=car(L)) != 7 && type(LT) != 21)
9208: LT = my_tex_form(LT);
9209: else if(type(getopt(eq)) < 0)
9210: Eq = 0;
9211: if(type(Sb) == 4)
9212: LT = str_subst(LT,Sb[0],Sb[1]);
9213: output(Dirout);
1.3 takayama 9214: if(Eq == 1){
9215: if(type(Eqo)==7)
9216: print(texbegin(Eqo,LT));
9217: else if(Eqo >= 1 && Eqo <= 8){
9218: mycat0([MyEq[Eqo-1][0],LT,"%"],1);
9219: print(MyEq[Eqo-1][1]);
9220: }else print(LT);
9221: }else print(LT);
1.1 takayama 9222: output();
9223: }
9224: }
1.3 takayama 9225: if(str_char(Risatex,0," ")>=0 && str_char(DVIOUTA,0," ")<0 && str_char(DVIOUTB,0," ")<0
9226: && str_char(DVIOUTL,0," ")<0)
1.1 takayama 9227: Risatex="\""+Risatex+"\"";
9228: if(getopt(keep) != 1) shell(Risatex);
9229: return 1;
9230: }
9231:
9232: def rtotex(P)
9233: {
9234: S = my_tex_form(P);
9235: return (str_len(S) == 1)?S:"{"+S+"}";
9236: }
9237:
9238: def mtotex(M)
9239: {
9240: /* extern TexLim; */
9241:
9242: MB=mat(["(",")","p"],["\\{","\\}","B"],["[","]","b"],["|","|","v"],
9243: ["\\|","\\|","V"], [".",".",""]);
9244: if(type(MT=getopt(mat))==7){
9245: MT=findin(MT,["p","B","b","v","V",""]);
9246: if(MT<0) MT=0;
9247: }
9248: else MT=0;
9249: MT=MB[MT];
9250: if((F=getopt(small))!=1 && F!=2) F=0;
9251: Lim=getopt(lim);
9252: if(type(Lim)==1){
9253: if(Lim<30 && Lim!=0) Lim = TexLim;
9254: }else Lim=0;
9255: FL=getopt(len);
9256: Rw=getopt(raw);
9257: Sp=getopt(sp);
9258: Idx=getopt(idx);
9259: if(type(Idx)==4) Idx=ltov(Idx);
9260: if(type(Idx)==6 && length(Idx)==0) Idx=-1;
9261: Var=getopt(var);
9262: if(Lim>0) FL=1;
9263: Null=getopt(null);
9264: if(Null!=1 && Null!=2) Null=0;
1.4 ! takayama 9265: if(type(M)==5) M=lv2m([V]);
! 9266: else if(type(M)!=6) return monototex(M);
1.1 takayama 9267: S=size(M);
9268: if(FL==1){
9269: L=newmat(S[0],S[1]); LL=newvect(S[1]);
9270: }
9271: SS=newmat(S[0],S[1]);
9272: for(I=0; I<S[0]; I++){
9273: for(J=0; J<S[1]; J++){
9274: if(type(P=M[I][J])<=3){
9275: if(P!=0 || Null == 0 || (Null==2 && I==J)){
9276: SS[I][J]=(type(Var)>1)?fctrtos(P|TeX=2,lim=0,var=Var):fctrtos(P|TeX=2,lim=0);
1.4 ! takayama 9277: if(type(P)==1 && str_str(SS[I][J],"\\frac{-"|end=0)==0)
1.3 takayama 9278: SS[I][J]="-\\frac{"+str_cut(SS[I][J],7,100000);
1.1 takayama 9279: }
9280: }else if(type(P)==6){
9281: ST= mtotex(P|small=1,len=1);
9282: SS[I][J]=ST[0];
9283: L[I][J]=ST[1];
9284: }else if(type(P)==7){
9285: if(Rw==1) SS[I][J]=P;
9286: else SS[I][J]="\\text{"+P+"\}";
9287: }else if(type(P)==4 && length(P)==2 && P[0]>0 && (Sp==1 || Sp==2)){
9288: if(P[0]==1){
9289: SS[I][J]=fctrtos(P[1]|TeX=2,lim=0);
9290: }else{
9291: ST=my_tex_form(P[0]);
9292: if(Sp==2) ST="("+ST+")";
9293: SS[I][J]="["+fctrtos(P[1]|TeX=2,lim=0)+"]_";
9294: if(str_len(ST)<2) SS[I][J]+=ST;
9295: else SS[I][J]+="{"+ST+"}";
9296: }
9297: }else
9298: SS[I][J]=my_tex_form(P);
9299: if(FL==1) L[I][J]=texlen(SS[I][J]);
9300: }
9301: }
9302: if(Lim>0 || FL==1){
9303: for(LLL=J=0; J<S[1];J++){
9304: for(I=K=0; I<S[0];I++){
9305: if(K<L[I][J]) K=L[I][J];
9306: }
9307: LLL+=(LL[J]=K);
9308: }
9309: }
9310: if(Lim>0){
9311: if(F==2 && LLL>Lim-2*S[1]-2) F=1;
9312: if(F==1)
9313: Lim=idiv(Lim*6,5);
9314: if(LLL<=Lim-(2-F)*S[I]-2) Lim=0;
9315: }
9316: Mat=(F==1)?"smallmatrix}":"matrix}";
9317: if(F==1) Out=str_tb("\\left"+MT[0]+"\\begin{",0);
9318: else Out=str_tb((Lim==0)?"\\begin{"+MT[2]:"\\left"+MT[0]+"\\begin{",0);
9319: Out = str_tb(Mat,Out);
9320: for(I=II=LT=0; II<=S[0]; II++){
9321: if(Lim==0) II=S[0];
9322: if(II<S[0]){
9323: K=LL[II]+(2-F);
9324: if(I==II){
9325: LT+=K;
9326: continue;
9327: }
9328: if(LT+K<Lim-2) continue;
9329: LT=K;
9330: }
9331: for(I0=I; I<II; I++){
9332: if(I==I0){
9333: str_tb((I==0)?
9334: "\n ":
9335: "\\right.\\\\\n \\allowdisplaybreaks\\\\\n &\\ \\left.\\begin{"+Mat+"\n ", Out);
9336: if(Idx==1||Idx==0||type(Idx)==5){
9337: for(J=I; J<II; J++){
9338: if(type(Idx)!=4)
9339: str_tb("("+rtostr(J+Idx)+")",Out);
9340: else{
9341: JJ=length(Idx)-1;
9342: if(J<JJ) JJ=J;
9343: str_tb(my_tex_form(Idx[JJ]),Out);
9344: }
9345: if(J<II) str_tb(" & ",Out);
9346: }
9347: str_tb("\\\\\n ",Out);
9348: }
9349: }
9350: else str_tb("\\\\\n ",Out);
9351: for(J=0; J<S[1]; J++){
9352: if(J!=0) str_tb(" & ",Out);
9353: if(type(SS[I][J])==7) str_tb(SS[I][J],Out);
9354: }
9355: }
9356: Out=str_tb("\n\\end{", Out);
9357: if(II==S[0]) Out=str_tb((Lim==0&&F!=1)?MT[2]+Mat:Mat+"\\right"+MT[1],Out);
9358: else Out=str_tb(Mat+"\\right.",Out);
9359: }
9360: SS = str_tb(0,Out);
9361: if(FL!=1) return SS;
9362: if(F==1) LLL=idiv((LLL+S[1])*5+13,6);
9363: else LLL+=2*(1+S[1]);
9364: return [SS,LLL];
9365: }
9366:
9367: def sint(N,P)
9368: {
1.3 takayama 9369: if( type(N)==1 ) {
9370: NT=ntype(N);
1.4 ! takayama 9371: if((type(Opt=getopt(str))==1 || Opt==0) && Opt>=0 && P>=0){
! 9372: if(Opt==2 || Opt==4 || Opt==0){
1.3 takayama 9373: if(N==0) return "0";
9374: Pw=0;
9375: if(NT==4){
9376: NN=abs(real(N));N1=abs(imag(N));
9377: if(NN<N1) NN=N1;
9378: }else NN=abs(N);
9379: while(NN<1 && NN>-1){
9380: Pw--;
9381: N*=10;NN*=10;
9382: }
9383: while(N>=10 || N<=-10){
9384: Pw++;
9385: N/=10;NN/=10;
9386: }
1.4 ! takayama 9387: if(Opt==0) return sint(N*10^Pw,P-Pw-1);
1.3 takayama 9388: S=(getopt(sqrt)==1)?sint(N,P|str=(Opt==4)?3:1,sqrt=1):sint(N,P|str=(Opt==4)?3:1);
9389: if(Pw==0) return S;
9390: if(NT==4)
9391: S="("+S+")";
9392: if(Pw==1){
9393: if(Opt==2)
9394: return S+"*10";
9395: else
9396: return S+"\\times10";
9397: }
9398: if(Opt==2)
9399: return S+"*10^("+rtostr(Pw)+")";
9400: else
9401: return S+"\\times10^{"+rtostr(Pw)+"}";
9402: }
9403: if(NT==4){
9404: NN=real(N);
1.4 ! takayama 9405: if(NN!=0){
! 9406: S=sint(NN,P|str=1);
! 9407: if(imag(N)>0) S=S+"+";
! 9408: }
1.3 takayama 9409: else S="";
9410: S=S+sint(imag(N),P|str=1)+((Opt==3)?((getopt(sqrt)==1)?"\\sqrt{-1}":"i"):"@i");
9411: return S;
9412: }
9413: if(N<0){
9414: N=-N;
9415: Neg="-";
9416: }else Neg="";
9417: NN=floor(N);
9418: NS=rtostr(NN);
9419: if(P<=0) return Neg+NS;
9420: if(NN==0 && getopt(zero)==0) NS="";
9421: return Neg+NS+"."+str_cut(rtostr(rint((N-NN+1)*10^P)),1,P);
9422: }
9423: if(NT==4)
9424: return sint(real(N),P)+sint(imag(N),P)*@i;
9425: X = rint( N*10^P );
9426: return ((X+1.0)-1.0)/10^P;
9427: }
9428: if( (type(N)==2) || (type(N)==3) ){
9429: NN = eval(N);
9430: if( type(NN)==1 )
9431: return sint(NN,P|option_list=getopt());
9432: else return N;
9433: }
9434: if( type(N)>3 )
9435: #ifdef USEMODULE
9436: return mtransbys(os_md.sint,N,[P]|option_list=getopt());
9437: #else
9438: return mtransbys(sint,N,[P]|option_list=getopt()));
9439: #endif
9440: }
9441:
9442: def frac2n(N)
9443: {
9444: if((T=type(N))<0) return N;
1.4 ! takayama 9445: E=(getopt(big)==1)?eval(@e):0.1;
1.3 takayama 9446: if(T==1){
1.4 ! takayama 9447: if(ntype(N)==0) return (E+N)-E;
! 9448: else if(ntype(N)!=4) return N;
! 9449: else return (E*(1+@i)+N)-E*(1+@i);
1.3 takayama 9450: }
1.4 ! takayama 9451: if(T==3||T==2){
1.3 takayama 9452: N=red(N);
1.4 ! takayama 9453: Nm=nm(N);Var=vars(Nm);V=car(Var);K=length(Var);
! 9454: for(S=0,I=mydeg(Nm,V);I>=0;I--) S+=frac2n(mycoef(Nm,I,V))*V^I;
! 9455: return S/dn(N);
1.3 takayama 9456: }
1.4 ! takayama 9457: if(T<4) return (N+E)-E;
1.3 takayama 9458: #ifdef USEMODULE
1.4 ! takayama 9459: return mtransbys(os_md.frac2n,N,[]|option_list=getopt());
1.3 takayama 9460: #else
1.4 ! takayama 9461: return mtransbys(frac2n,N,[]|option_list=getopt());
1.3 takayama 9462: #endif
1.1 takayama 9463: }
9464:
9465: def xyproc(F)
9466: {
1.3 takayama 9467: if(type(Opt=getopt(opt))!=7) Opt="";
9468: if(type(Env=getopt(env))!=7)
9469: Env=(!TikZ)?"xy":"tikzpicture";
9470: if(F==1)
9471: return(Opt=="")?"\\begin{"+Env+"}\n":"\\begin{"+Env+"}["+Opt+"]\n";
9472: if(F==0) return "\\end{"+Env+"}\n";
1.1 takayama 9473: if(type(F)==7){
1.3 takayama 9474: F=xyproc(1|opt=Opt,env=Env)+F+xyproc(0|env=Env);
1.1 takayama 9475: if(getopt(dviout)==1) dviout(F);
9476: else return F;
9477: }
9478: }
9479:
9480: def xypos(P)
9481: {
1.3 takayama 9482: if(type(P[0])==7){
9483: if(P[0]=="") S="";
9484: else S=(!TikZ)?"\""+P[0]+"\"":"("+P[0]+")";
9485: }
1.1 takayama 9486: else{
1.3 takayama 9487: if(TikZ==0 && XYcm==1){
9488: X=sint(P[0]*10,XYPrec); Y=sint(P[1]*10,XYPrec);
9489: }else{
9490: X=sint(P[0],XYPrec); Y=sint(P[1],XYPrec);
9491: }
1.1 takayama 9492: S="("+rtostr(X)+","+rtostr(Y)+")";
9493: }
1.3 takayama 9494: if(!TikZ){
9495: if(length(P)>2 && (PP=P[2])!=""){
9496: S=S+" *";
9497: if(type(PP)==4 && length(PP)==2 && type(PP[0])==7){
9498: S=S+PP[0];
9499: PP=PP[1];
9500: }
9501: if(type(PP)==7){
9502: L=str_len(PP);
9503: if(str_chr(PP,0,"$")==0 && str_chr(PP,L-1,"$")==L-1){
9504: PP=str_cut(PP,1,L-2);
9505: }else S+="\\txt";
9506: }
9507: else PP=my_tex_form(PP);
9508: S=S+"{"+PP+"}";
9509: }
9510: if(length(P)>3){
9511: if(type(P[3])==7 && P[3]!="") S=S+"=\""+P[3]+"\"";
9512: if(length(P)>4 && type(P[4])==7) S=S+P[4];
9513: }
9514: }else{
9515: T="";
9516: if(length(P)>2 && (PP=P[2])!=""){
9517: F=1;
9518: if(type(PP)==4){
9519: if(length(PP)==2 && type(PP[0])==7){
9520: T="["+PP[0]+"]";
9521: PP=PP[1];
9522: }
9523: }
9524: if(type(PP)!=7) PP="$"+my_tex_form(PP)+"$";
9525: S=S+"{"+PP+"}";
9526: }else F=0;
9527: if(length(P)>3){
9528: if(type(P[3])==7 && P[3]!="") T=T+"("+P[3]+")";
9529: else if(P[3]==1) T=T+"(_)";
9530: if(length(P)>4 && type(P[4])==7) S=S+P[4];
9531: }
9532: if(length(P)>2){
9533: if(F) S="node"+T+" at"+S;
9534: else S="coordinate"+T+" at"+S;
9535: }
1.1 takayama 9536: }
9537: return S;
9538: }
9539:
9540: def xyput(P)
9541: {
9542: if((type(Sc=getopt(scale))==1 && Sc!=1) || type(Sc)==4){
9543: if(type(Sc)==1) Sc=[Sc,Sc];
9544: Sx=Sc[0];Sy=Sc[1];
1.3 takayama 9545: if(length(P)>2)
9546: P1=cons(Sy*P[1],cdr(cdr(P)));
9547: else P1=[Sy*P[1]];
9548: P=cons((type(P[0])==7)?P[0]:(Sx*P[0]),P1);
1.1 takayama 9549: }
1.3 takayama 9550: if(!TikZ) return "{"+xypos(P)+"};\n";
9551: return "\\"+xypos(P)+";\n";
1.1 takayama 9552: }
9553:
9554: def xyline(P,Q)
9555: {
1.3 takayama 9556: if(!TikZ) return "{"+xypos(P)+" \\ar@{-} "+xypos(Q)+"};\n";
9557: if(type(T=getopt(opt))!=7) T="";
9558: else T="["+T+"]";
9559: if(length(P)<3 && length(Q)<3)
9560: return "\\draw"+T+xypos(P)+"--"+xypos(Q)+";\n";
9561: if(length(P)==2) P=[P[0],P[1],"","_0"];
9562: else if(length(P)==3 || (length(P)==4 && P[3]==""))
9563: P=[P[0],P[1],P[2],"_0"];
9564: else if(length(P)>4 && P[3]=="")
9565: P=[P[0],P[1],P[2],"_0",P[4]];
9566: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
9567: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
9568: Q=[Q[0],Q[1],Q[2],"_1"];
9569: else if(length(Q)>4 && Q[3]=="")
9570: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
9571: return "\\draw "+T+xypos(P)+" "+xypos(Q)+"("+P[3]+")--("+Q[3]+");\n";
1.1 takayama 9572: }
9573:
9574: def xylines(P)
9575: {
1.3 takayama 9576: /* mycat([P,getopt()]); */
1.1 takayama 9577: Lf=getopt(curve);
9578: if(type(Lf)!=1) Lf=0;
9579: SS=getopt(opt);
1.3 takayama 9580: SF=(SS==0)?1:0;
9581: if((Proc=getopt(proc))==1||Proc==2||Proc==3){
9582: OL=cons(["opt",0],delopt(getopt(),["opt","proc"]));
9583: R=xylines(P|option_list=OL);
9584: OP=(type(SS)<0)?[]:((type(SS)==4)?[["opt",SS[0]],["cmd",SS[1]]]:[["opt",SS]]);
9585: return [1,OP,R];
9586: }
9587: if(type(SS)!=7 && type(SS)!=4){
9588: if(Lf==0 && !TikZ) SS="@{-}";
1.1 takayama 9589: else SS="";
9590: }
9591: if(type(Sc=getopt(scale))==1 || type(Sc)==4){
9592: if(type(Sc)==1) Sc=[Sc,Sc];
9593: Sx=Sc[0];Sy=Sc[1];
9594: if(Sx!=1 || Sy!=1){
9595: for(PP=[], P0=P; P0!=[]; P0=cdr(P0)){
9596: PT=car(P0);
1.3 takayama 9597: if((type(PT)!=4 && type(PT)!=5) || (type(PT[0])!=1 && PT[0]!=0))
9598: PP=cons(PT,PP);
1.1 takayama 9599: else{
1.3 takayama 9600: if(length(PT)>2 && type(PT)==4)
9601: P1=cons(Sy*PT[1],cdr(cdr(PT)));
9602: else P1=[Sy*PT[1]];
1.1 takayama 9603: PP=cons(cons(Sx*PT[0],P1),PP);
9604: }
9605: }
9606: P=reverse(PP);
9607: }
9608: }
1.3 takayama 9609: if(type(Cl=CL0=getopt(close))!=1) Cl=0;
9610: if((Vb=getopt(verb))!=1&&type(Vb)!=4) Vb=0;
1.1 takayama 9611: if(type(Lf)!=1 || Lf==0){ /* lines */
1.3 takayama 9612: if(TikZ||SF){
9613: for(L=[],F=0,PT=P;PT!=[];PT=cdr(PT)){
9614: if(type(car(PT))<4){
9615: L=cons(car(PT),L);
9616: F=0;
9617: }else{
9618: if(F++>1) L=cons(1,L);
9619: L=cons(car(PT),L);
9620: }
9621: }
9622: if(Cl==1){
9623: L=cons(1,L);L=cons(-1,L);
9624: }
9625: if(L) L=reverse(L);
9626: if(SF) return L;
9627: if(type(SS)!=4) S=xybezier(L|opt=SS);
9628: else S=xybezier(L|opt=SS[0],cmd=SS[1]);
9629:
9630: }else{
9631: Out = str_tb(0,0);
9632: for(PT=P; PT!=[]; ){
9633: PS1=car(PT);
9634: PT=cdr(PT);
9635: if(PT==[]){
9636: if(Cl==1) PS2=car(P);
9637: else PS2=0;
9638: }else PS2=car(PT);
9639: str_tb(xyarrow(PS1,PS2|opt=SS),Out);
9640: }
9641: S=str_tb(0,Out);
1.1 takayama 9642: }
9643: }else if(Lf==2){ /* B-spline */
1.3 takayama 9644: if(SF) return P;
9645: if(!TikZ){
9646: Out = str_tb("{\\curve{",0);
9647: for(PT=P;PT!=[];PT=cdr(PT)){
9648: if(car(PT)==0){
9649: str_tb("}};\n{\\curve{",Out);
9650: continue;
9651: }
9652: if(PT!=P) str_tb("&",Out);
9653: str_tb(xypos([car(PT)[0],car(PT)[1]]),Out);
1.1 takayama 9654: }
1.3 takayama 9655: str_tb("}};\n",Out);
9656: S=str_tb(0,Out);
9657: }else Out=str_tb(xybezier(P|opt=SS),0);
1.1 takayama 9658: for(I=0;I<2;I++){
9659: Q=car(P);
9660: if(length(Q)>2)
9661: str_tb(xyput(Q),Out);
9662: P=reverse(P);
9663: }
1.3 takayama 9664: S=str_tb(0,Out);
1.1 takayama 9665: }else{ /* extended Bezier */
9666: RTo=getopt(ratio);
1.4 ! takayama 9667: if(type(Acc=getopt(Acc))!=1) Acc=0;
1.1 takayama 9668: if(type(RTo)!=1 || RTo>1.5 || RTo<0.001) RTo=0;
9669: if(Cl==1){
9670: PR=reverse(P);
9671: PT=car(PR);
9672: PR=cons(P[0],PR);
9673: PR=cons(P[1],PR);
9674: P=cons(PT,reverse(PR));
9675: }else if(Cl==-1) Cl=1;
1.3 takayama 9676: for(L=P2=P3=0,PT=P;;){
1.1 takayama 9677: P1=P2;P2=P3;P3=P4;
9678: P4=(PT==[])?0:car(PT);
9679: if(PT==[] && (Cl==1 || P3==0)) break;
9680: PT=cdr(PT);
9681: if(P3==0) str_tb("%\n", Out);
9682: if(P2==0 || P3==0 || (Cl==1 && P1==0)) continue;
1.3 takayama 9683: if(L!=0){
9684: if(car(L)==P2)
9685: L=cons(1,L);
9686: else{
9687: L=cons(0,L); L=cons(P2,L);
9688: }
9689: }else L=[P2];
1.1 takayama 9690: X=P3[0]-P2[0];Y=P3[1]-P2[1];
1.4 ! takayama 9691: DL1=DL2=0;DL=Acc?sqrt(X^2+Y^2):dsqrt(X^2+Y^2);
1.1 takayama 9692: if(P4!=0){
1.4 ! takayama 9693: XD1=P4[0]-P2[0];YD1=P4[1]-P2[1];DL1=Acc?sqrt(XD1^2+YD1^2):dsqrt(XD1^2+YD1^2);
1.1 takayama 9694: }
9695: if(P1!=0){
1.4 ! takayama 9696: XD2=P3[0]-P1[0];YD2=P3[1]-P1[1];DL2=Acc?sqrt(XD2^2+YD2^2):dsqrt(XD2^2+YD2^2);
1.3 takayama 9697: }
9698: if(RTo!=0)
9699: R=RTo;
9700: else if(DL1>0 && DL2>0){
9701: Cos=(XD1*XD2+YD1*YD2)/(DL1*DL2);
1.4 ! takayama 9702: RT=4/(3*(Acc?sqrt((1+Cos)/2):dsqrt((1+Cos)/2))+3);
1.3 takayama 9703: R=DL*RT/(DL1+DL2);
9704: }else if(DL1!=0)
9705: R=DL/(2*DL1);
9706: else if(DL2!=0)
9707: R=DL/(2*DL2);
9708: if(DL2!=0) L=cons([P2[0]+R*XD2,P2[1]+R*YD2],L);
9709: if(DL1!=0) L=cons([P3[0]-R*XD1,P3[1]-R*YD1],L);
9710: L=cons([P3[0],P3[1]],L);
9711: }
9712: if(CL0==1) L=cons(-1,cdr(L));
9713: if(L!=0) L=reverse(L);
9714: if(SF) return L;
9715: if(type(SS)==4)
9716: S=xybezier(L|opt=SS[0],cmd=SS[1],verb=Vb);
9717: else
9718: S=xybezier(L|opt=SS,verb=Vb);
1.1 takayama 9719: }
9720: if(getopt(dviout)!=1) return S;
9721: xyproc(S|dviout=1);
9722: }
9723:
1.3 takayama 9724: def saveproc(S,Out)
9725: {
9726: if(type(Out)==4){
9727: Out=cons(S,Out);
9728: return Out;
9729: }else{
9730: str_tb(S,Out);
9731: return Out;
9732: }
9733: }
9734:
1.1 takayama 9735: def xy2graph(F0,N,Lx,Ly,Lz,A,B)
9736: {
9737: /* (x,y,z) -> ( -x sin A + y cos A, z cos B - x cos A sin B - y sin A sin B) */
1.3 takayama 9738: if((Proc=getopt(proc))==1||Proc==2){
9739: OPT0=[["proc",3]];
9740: }else{
9741: Proc=0;OPT0=[];
9742: }
9743: if(type(DV=getopt(dviout))==4){
1.4 ! takayama 9744: S=["ext","shift","cl","dviout"];
1.3 takayama 9745: OL=delopt(getopt(),S);
9746: OL=cons(["proc",1],OL);
1.4 ! takayama 9747: R=xy2graph(F0,N,Lx,Ly,Lz,A,B|option_list=OL);
1.3 takayama 9748: OL=delopt(getopt(),S|inv=1);
9749: return execdraw(R,DV|optilon_list=OL);
9750: }
1.1 takayama 9751: if(N==0 || N>100 || N<-100) N=-16;
9752: if(N<0){
9753: N=-N;N1=-1;N2=NN+1;
9754: }else{
9755: N1=0;N2=NN=N;
9756: }
1.3 takayama 9757:
9758: Ratio=Ratio2=1;
9759: if(type(Sc=Sc0=getopt(scale))!=1 && type(Sc)!=4) Sc=1;
9760: if(type(Sc)==4){
9761: Ratio=Sc[1]/Sc[0];
9762: if(length(Sc)>2) Ratio2=Sc[2]/Sc[0];
9763: Sc=Sc[0];
9764: }
1.1 takayama 9765: if(type(Vw=getopt(view))!=1) Vw=0;
9766: if(type(Raw=getopt(raw))!=1) Raw=0;
9767: if(type(M1=getopt(dev))==1) M2=M1;
9768: else if(type(M1)==4){
9769: M2=M1[1];M1=M1[0];
9770: }else M1=0;
1.3 takayama 9771: if(type(M3=getopt(acc))!=1 || (M3<0.5 && M3>100)) M3=1;
1.1 takayama 9772: if(M1<=0) M1=16;
9773: if(M2<=0) M2=16;
1.3 takayama 9774: OL=[["para",1],["scale",Sc]];
1.1 takayama 9775: if(Raw==1) OL=cons(["raw",1],OL);
1.3 takayama 9776: if(type(Prec=getopt(prec))>=0) OL=cons(["prec",Prec],OL);
1.1 takayama 9777: L=newvect(4,[[Lx[1],Ly[0]],[Lx[1],Ly[1]],[Lx[0],Ly[1]],[Lx[0],Ly[0]]]);
1.3 takayama 9778: Lx=[deval(Lx[0]),deval(Lx[1])];
9779: Ly=[deval(Ly[0]),deval(Ly[1])];
9780: Lz=[deval(Lz[0]),deval(Lz[1])];
9781: A=(A0=A)%360;
9782: F00=F0;
9783: if(type(F0)<4){
9784: FC=f2df(F0);
9785: if(findin(z,Vars=vars(FC))>=0 && findin(x,Vars)<0 && findin(y,Vars)<0)
9786: F0=[w,[z,0,x+y*@i],[w,os_md.abs,FC]];
9787: }
9788: if(type(Org=getopt(org))==4){ /* shift origin */
9789: Lx=[Lx[0]-Org[0],Lx[1]-Org[0]];
9790: Ly=[Ly[0]-Org[1],Ly[1]-Org[1]];
9791: Lz=[Lz[0]-Org[2],Lz[1]-Org[2]];
1.4 ! takayama 9792: F0=mysubst(F0,[[x,x+Org[0]],[y,y+Org[1]]]);
1.3 takayama 9793: if(type(F0)==4){
9794: F0=cons(F0[0]-Org[2],cdr(F0));
9795: }
9796: else F0-=Org[2];
9797: }else Org=[0,0,0];
9798: Cpx=getopt(cpx);
9799: if(type(Cpx)<0){
9800: if(str_str(rtostr(F0),"@i")>=0) Cpx=1;
9801: else Cpx=0;
9802: }
9803: if(A<0) A+=360;
9804: if(A<90){
9805: Sh=1;F1=F0;Cx=x-Org[0];Cy=y-Org[1];
9806: }else if(A<180){ /* x -> y, y -> -x */
9807: Sh=2;A-=90; F1=mulsubst(F0,[[x,-y],[y,x]]);
9808: LL=Ly;Ly=[-Lx[1],-Lx[0]];Lx=LL;Cx=y-Org[1];Cy=-x+Org[0];
9809: }else if(A<270){
1.4 ! takayama 9810: Sh=3;A-=180; F1=subst(F0,[[x,-x],[y,-y]]);
1.3 takayama 9811: Lx=[-Lx[1],-Lx[0]];Ly=[-Ly[1],-Ly[0]];Cx=-x+Org[0];Cy=-y+Org[1];
9812: }else{
9813: Sh=4;A-=270;F1=mulsubst(F0,[[x,y],[y,-x]]);
9814: LL=Lx;Lx=[-Ly[1],-Ly[0]];Ly=LL;Cx=-y+Org[1];Cy=x-Org[0];
1.1 takayama 9815: }
1.3 takayama 9816: A=@pi*A/180; B=@pi*B/180;
1.1 takayama 9817: if(A==0) A=@pi/3;
1.3 takayama 9818: if(B==0) B=@pi/12;
9819: NN=N*M2;
9820: Ac=dcos(deval(A)); As=dsin(deval(A));
1.1 takayama 9821: if(Ac<=0.087 || As<=0.087){
9822: mycat(["Unsuitable angle",A0,"(6-th argument)!"]);
9823: return -1;
9824: }
1.3 takayama 9825: Bc=Ratio*dcos(deval(B)); Bs=dsin(deval(B));
1.1 takayama 9826: if(Bc<0){
9827: mycat("Unsuitable angle (7-th argument)!");
9828: return -1;
9829: }
1.3 takayama 9830: /*
9831: z = f(x,y) => X=-As*x+Ac*y, Y= Bc*f(x,y)-Bsc*x-Bss*y
9832: Out X-coord is in [X0,X1], dvided by Dev segments
9833: J-th segment of Y-coord : ZF[J]==1 => [Z0[0],Z1[J]]
9834: */
1.1 takayama 9835: Bsc=Bs*Ac;Bss=Bs*As;
1.3 takayama 9836: if(Ratio2!=1){
9837: if(Sh%2==1){
9838: Ac*=Ratio2;Bss*=Ratio2;
9839: }else{
9840: As*=Ratio2;Bsc*=Ratio2;
9841: }
9842: }
9843: CX=-As*Cx+Ac*Cy;CY=Bc*(z-Org[2])-Bsc*Cx-Bss*Cy;
9844: if(type(Dvi=getopt(dviout))!=1 && getopt(trans)==1) return [CX*Sc,CY*Sc];
9845: if(type(N1=getopt(inf))==1){
9846: if(Proc) Dvi=N1;
9847: else if(Dvi<=0) Dvi=-N1;
9848: }
9849: X0=-As*Lx[1]+Ac*Ly[0];X1=-As*Lx[0]+Ac*Ly[1];
1.4 ! takayama 9850: F1=mysubst(F1,[@pi,deval(@pi)]);
1.3 takayama 9851: Tf=type(F1=f2df(F1|opt=0));
9852: if(Tf!=4) F=Bc*F1-Bsc*x-Bss*y;
9853: else F=append([Bc*F1[0]-Bsc*x-Bss*y],cdr(F1));
1.1 takayama 9854: Dx=(Lx[1]-Lx[0])/NN; Dy=(Ly[1]-Ly[0])/NN;
9855: if(type(Err=getopt(err))==1)
1.4 ! takayama 9856: F=mysubst(F,[[x,x+Err*Dx/1011.23],[y,y+Err*Dy/1101.34]]);
1.3 takayama 9857: Out=(Proc)?[]:str_tb(0,0);
9858: Dev=N*M1;
9859: XD=(X1-X0)/Dev;
9860: OLV=newvect(2,[OL,OL]);
9861: if(type(Ura=getopt(opt))==4 || type(Ura)==7){
9862: if(type(Ura)==7) Ura=[Ura,Ura];
9863: else{
9864: OLV[0]=cons(["opt",Ura[0]],OL);
9865: OLV[1]=cons(["opt",Ura[1]],OL);
9866: }
9867: }
9868: for(KC=0; KC<=1; KC++){ /* draw curves */
1.1 takayama 9869: Z0=newvect(Dev+1); Z1=newvect(Dev+1); ZF=newvect(Dev+1);
9870: for(I=0; I<=NN; I++){
9871: FV=I%M2;
9872: if(KC==0){
1.4 ! takayama 9873: X=x; Y=Ly[1]-I*Dy; LX=Lx; DD=Dx; G=mysubst(F,[y,Y]);
1.3 takayama 9874: if(!FV){
9875: if(!Proc) str_tb(["%y=",rtostr(Y),"\n"],Out);
9876: else Out=cons([-2,"y="+rtostr(Y)],Out);
9877: }
1.1 takayama 9878: }else{
1.4 ! takayama 9879: X=Lx[1]-I*Dx; Y=x; LX=Ly; DD=Dy; G=mysubst(F,[[x,X],[y,Y]]);
1.3 takayama 9880: if(!FV){
9881: if(!Proc) str_tb(["%x=",rtostr(X),"\n"],Out);
9882: else Out=cons([-2,"x="+rtostr(X)],Out);
9883: }
1.1 takayama 9884: }
9885: XX=-As*X+Ac*Y; A1=coef(XX,1,x); A0=coef(XX,0,x); /* XX = A1*x + A0, x = (XX-A0)/A1 */
9886: if(!FV && Vw==1){
1.3 takayama 9887: if(Proc) Out=cons(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1,proc=3),Out);
9888: else str_tb(xygraph([XX,G],N,LX,[X0,X1],Lz|scale=Sc,para=1),Out);
1.1 takayama 9889: continue;
9890: }
9891: V=VT=LX[1];
9892: J0=(subst(XX,x,LX[0])-X0)/XD; J1=(subst(XX,x,LX[1])-X0)/XD;
9893: if(J0<J1){
1.3 takayama 9894: J0=ceil(J0); J1=floor(J1); JD=1; /* fixed x: y: dec => (x,z):(dec,inc) */
1.1 takayama 9895: }else{
1.3 takayama 9896: J0=floor(J0); J1=ceil(J1); JD=-1; /* fixed y: x: dec => (x,z):(inc,inc) */
1.1 takayama 9897: }
9898: for(FF=1,J=J1;;J-=JD){
1.3 takayama 9899: V1=VT;
1.4 ! takayama 9900: VT=(X0+J*XD-A0)/A1;GG=mysubst(G,[x,VT]);
1.3 takayama 9901: if(Cpx>=1) VV=myeval(GG);
9902: else VV=(Tf==4)? mydeval(GG):deval(GG); /* J -> V */
9903: if(ZF[J]==0 || VV<=Z0[J] || VV>=Z1[J]){ /* visible */
1.1 takayama 9904: if(FF==0){
9905: V0=(VT+V1)/2;
1.3 takayama 9906: if(!FV && Vw==-1 && Raw!=1){ /* draw doted line */
9907: K=ceil(M3*(V-V0)/(M2*DD));
9908: if(N1<0) K=-K;
9909: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"],["scale",Sc],["para",1]]);
9910: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|
9911: option_list=OPT),Out);
9912: }
1.1 takayama 9913: V=V0;
9914: }
9915: if(ZF[J]==0){
9916: ZF[J]=1; Z0[J]=Z1[J]=VV;
9917: }else if(VV<=Z0[J]) Z0[J]=VV;
9918: else Z1[J]=VV;
1.3 takayama 9919:
9920: if(VV>=Z1[J]) FF=1;
9921: else if(VV<=Z0[J]) FF=-1;
1.1 takayama 9922: }else{
1.3 takayama 9923: if(FF!=0){
1.1 takayama 9924: V0=(VT+V1)/2;
9925: K=ceil(M3*(V-V0)/(M2*DD));
9926: if(N1<0) K=-K;
1.3 takayama 9927: if(!FV){
9928: OPT=append(OPT0,OLV[(1-FF)/2]);
9929: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
9930: }
1.1 takayama 9931: V=V0;
9932: }
9933: FF=0;
9934: }
9935: if(J==J0) break;
9936: }
9937: if(FV) continue;
1.3 takayama 9938: V0=LX[0];K=ceil(M3*(V-V0)/(M2*DD));
1.1 takayama 9939: if(N1<0) K=-K;
1.3 takayama 9940: if(FF!=0){
9941: if(Raw!=1){
9942: OPT=append(OPT0,OLV[(1-FF)/2]);
9943: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
9944: }else if(Vw==-1 && Raw!=1){
9945: OPT=append(OPT0,[["opt",(TikZ)?"dotted":"~*=<3pt>{.}"]]);
9946: Out=saveproc(xygraph([XX,G],K,[V0,V],[X0-1,X1+1],Lz|option_list=OPT),Out);
9947: }
9948: }
9949: }
9950: }
1.4 ! takayama 9951: OptSc=(Sc==1)?[]:[["scale",Sc]];
1.3 takayama 9952: if(type(LZ=getopt(ax))==4){ /* draw box */
9953: FC=0;
9954: if(length(LZ)==3) FC=LZ[2];
9955: P0=newvect(2,[-As*Lx[1]+Ac*Ly[1],Bc*(LZ[0]-Org[0])-Bsc*Lx[1]-Bss*Ly[1]]);
9956: Vx=newvect(2,[As*(Lx[1]-Lx[0]),Bsc*(Lx[1]-Lx[0])]);
9957: Vy=newvect(2,[Ac*(Ly[0]-Ly[1]),Bss*(Ly[1]-Ly[0])]);
9958: Vz=newvect(2,[0,Bc*(LZ[1]-LZ[0])]);
1.4 ! takayama 9959: OL=OL0=append(OPT0,OL);
! 9960: if(TikZ && type(Ura)==4 && length(Ura)>2) OL0=cons(["opt",Ura[2]],OL);
! 9961: Out=saveproc(xylines([P0,P0+Vx]|option_list=OL0),Out);
! 9962: Out=saveproc(xylines([P0+Vz,P0+Vx+Vz]|option_list=OL0),Out);
1.3 takayama 9963: if(Bs>0){
1.4 ! takayama 9964: Out=saveproc(xylines([P0+Vy+Vz,Pz=P0+Vx+Vy+Vz]|option_list=OL0),Out);
! 9965: Out=saveproc(xylines([P0+Vx+Vz,Pz]|option_list=OL0),Out);
1.3 takayama 9966: PP=Pz-Vz;
9967: }else{
1.4 ! takayama 9968: Out=saveproc(xylines([P0+Vy,Pz=P0+Vx+Vy]|option_list=OL0),Out);
! 9969: Out=saveproc(xylines([P0+Vx,Pz]|option_list=OL0),Out);
1.3 takayama 9970: PP=Pz+Vz;
9971: }
9972: J=ceil((PP[0]-X0)/XD+0.5);
1.4 ! takayama 9973: Out=saveproc(xylines([P0,P0+Vy]|option_list=OL0),Out);
! 9974: Out=saveproc(xylines([P0+Vz,P0+Vy+Vz]|option_list=OL0),Out);
! 9975: Out=saveproc(xylines([P0,P0+Vz]|option_list=OL0),Out);
! 9976: Out=saveproc(xylines([P0+Vx,P0+Vx+Vz]|option_list=OL0),Out);
! 9977: Out=saveproc(xylines([P0+Vy,P0+Vy+Vz]|option_list=OL0),Out);
! 9978: Out=saveproc(xylines([P0+Vy,P0+Vy+Vz]|option_list=OL0),Out);
1.3 takayama 9979: if(Dev>4) Dev2=ceil(Dev/2);
9980: if(FC<0 && Raw!=1){
1.4 ! takayama 9981: if(TikZ){
! 9982: if(type(Ura)==4 && length(Ura)>2)
! 9983: OL1=cons(["opt",Ura[2]+",dotted"],OL);
! 9984: else OL1=cons(["opt","dotted"],OL);
! 9985: }else OL1=cons(["opt","@{.}"],OL);
1.3 takayama 9986: if(FC==-8) FC=0;
9987: }
9988: for(I=0;I<3;I++){ /* box with hidden part */
9989: if(I==1) Pz=PP-Vx;
9990: else if(I==2) Pz=PP-Vy;
9991: LP=Pz-PP;
9992: for(FV=-1,K=0;K<=Dev2; K++){
9993: PPx=PP[0]+(K/Dev2)*LP[0]; PPy=PP[1]+(K/Dev2)*LP[1];
9994: J=ceil((PPx-X0)/XD);
9995: if(K!=Dev2 && (J<0||J>Dev)) continue;
9996: if(K!=Dev2 && (ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){ /* visible */
9997: if(FV!=1){
9998: FV=1;
9999: PPP=[PPx,PPy];
10000: }
10001: }else{
10002: if(FV!=0){
10003: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
10004: FV=0;
10005: }
10006: }
10007: }
10008: }
10009: if(FC!=0 && Raw!=1){ /* show coordinate*/
10010: if(iand(FC,4)){
10011: Sub=1;
10012: if(TikZ){
10013: S0="\\scriptsize";S1="";
10014: }else{
10015: S0="{}_{"; S1="}";
10016: }
10017: }else Sub=0;
10018: if(iand(FC,2))
10019: LLL=[[1,0,P0+Vx,(TikZ)?"right":"+!L"],[3,0,P0+Vy,(TikZ)?"left":"+!R"]];
10020: else LL=[];
10021: if(Bs>0){
10022: LLL=cons([0,0,P0,(TikZ)?"below":"+!U"],LLL);
10023: LLL=cons([2,1,P0+Vx+Vy+Vz,(TikZ)?"above":"+!D"],LLL);
10024: }else{
10025: LLL=cons([2,0,P0+Vx+Vy,(TikZ)?"below":"+!U"],LLL);
10026: LLL=cons([0,1,P0+Vz,(TikZ)?"above":"+!D"],LLL);
10027: }
10028: for(TLL=LLL;TLL!=[];TLL=cdr(TLL)){
10029: TL=car(TLL);LL=L[(Sh+TL[0])%4];
1.4 ! takayama 10030: if(Cpx==0 || Cpx==3){
1.3 takayama 10031: S=ltotex([LL[0],LL[1],LZ[TL[1]]]|opt="coord");
1.4 ! takayama 10032: SS="("+rtostr(LL[0]) +","+rtostr(LL[1])+","+rtostr(LZ[TL[1]])+")";
! 10033: }else{
1.3 takayama 10034: S=ltotex([LL[0]+LL[1]*@i,LZ[TL[1]]]|opt="coord",cpx=Cpx);
1.4 ! takayama 10035: SS="("+rtostr(LL[0])+"+"+rtostr(LL[1])+"i,"+ rtostr(LZ[TL[1]])+")";
! 10036: }
1.3 takayama 10037: if(TikZ) S="$"+S+"$";
10038: if(Sub) S=S0+S+S1;
10039: if(!TikZ) S="$"+S+"$";
1.4 ! takayama 10040: if(Proc) Out=cons([2,OptSc,[TL[2][0],TL[2][1]],[[TL[3],S]],SS],Out);
! 10041: else str_tb(xyput([TL[2][0],TL[2][1],[TL[3],S]]|option_list=OptSc),Out);
1.3 takayama 10042: }
10043: }
10044: }
10045: if(type(Pt=getopt(pt))==4){ /* option pt=[] */
10046: if(type(Pt[0])<4 || (length(Pt[0])==3 && type(Pt[0][0])<2 && type(Pt[0][2])<2))
10047: Pt=[Pt];
10048: for(PT=Pt;PT!=[];PT=cdr(PT)){
10049: PP=car(PT);
10050: /* if(type(PP[0])!=4) PP=[PP]; */
10051: P=car(PP);
10052: if(type(P)==7) Q=[P,0];
10053: else if(P==1) Q=["_",0];
1.4 ! takayama 10054: else Q=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
1.3 takayama 10055: if(length(PP)>1 && type(PP[1])==4 && length(PP[1])==3){ /* draw line */
10056: PP=cdr(PP);P=car(PP);
10057: if(type(P)==7) Q1=P;
10058: else if(P==1) Q="_";
1.4 ! takayama 10059: else Q1=mysubst([CX,CY],[[x,deval(P[0])],[y,deval(P[1])],[z,deval(P[2])]]);
1.3 takayama 10060: if(length(PP)<2 || PP[1]==0 || iand(PP[1],1)) OL2=="";
10061: else OL2=(TikZ)?"dotted":"@{.}";
10062: if(length(PP)>2 && type(PP[2])==7){
10063: if(OL2=="") OL2=PP[2];
10064: else{
10065: if(TikZ) OL2=OL2+",";
10066: OL2=OL2+PP[2];
10067: }
10068: }
10069: OL1=OL;
10070: if(OL2!="") OL1=cons(["opt",OL2],OL1);
10071: if(length(PP)<2 || PP[1]>=0)
10072: Out=saveproc(xylines([Q,Q1]|option_list=OL1),Out);
10073: else{
10074: LP0=Q1[0]-Q[0];LP1=Q1[1]-Q[1];
10075: for(FV=-1,K=0;K<=Dev2; K++){
10076: PPx=Q[0]+(K/Dev2)*LP0; PPy=Q[1]+(K/Dev2)*LP1;
10077: J=ceil((PPx-X0)/XD);
10078: if(K!=Dev2 && (J<0 || J>Dev || ZF[J]==0 || PPy<Z0[J] || PPy>Z1[J])){
10079: /* visible */
10080: if(FV!=1){
10081: FV=1;
10082: PPP=[PPx,PPy];
10083: }
10084: }else{
10085: if(FV!=0){
10086: if(FV==1) Out=saveproc(xylines([PPP,[PPx,PPy]]|option_list=OL1),Out);
10087: FV=0;
10088: }
10089: }
10090: }
10091: }
10092: continue;
10093: }
10094: if(length(PP)==1) S="$\\bullet$";
10095: else if(type(PP[1])==7) S=PP[1];
10096: else if(type(PP[1])==4){
10097: if(length(PP[1])>1 && type(PP[1][1])!=7)
10098: S=cons(car(PP),cons("$\\bullet$",cdr(cdr(PP))));
10099: else S=PP[1];
10100: }else S="$\\bullet$";
10101: if(length(PP)<=2){
1.4 ! takayama 10102: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S]],Out);
! 10103: else str_tb(xyput([Q[0],Q[1],S]|optilon_list=OptSc),Out);
1.3 takayama 10104: }else if(!TikZ){
1.4 ! takayama 10105: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],[S,"",PP[2]]],Out);
! 10106: else str_tb(xyput([Q[0],Q[1],S,"",PP[2]]|optilon_list=OptSc),Out);
1.3 takayama 10107: }else{
1.4 ! takayama 10108: if(Proc) Out=cons([2,OptSc,[Q[0],Q[1]],cons(S,cdr(cdr(PP)))],Out);
! 10109: else str_tb(xyput(append([Q[0],Q[1],S],cdr(cdr(PP)))|optilon_list=OptSc),Out);
1.3 takayama 10110: }
10111: }
10112: }
10113: if(Proc){
10114: S=reverse(Out);
10115: if(Proc==1||Proc==3){
10116: for(W=[],I=0;I<2;I++) for(J=0;J<2;J++) for(K=0;K<2;K++)
1.4 ! takayama 10117: W=cons(mysubst([CX*Sc,CY*Sc],[[x,Lx[I]],[y,Ly[J]],[z,Lz[K]]]),W);
1.3 takayama 10118: W=ptbbox(W);
10119: S=cons([0,W[0],W[1],(TikZ)?1:1/10],S);
10120: }
10121: }else S=str_tb(0,Out);
10122: if(type(Dvi)!=1||(Proc&&abs(Dvi)<2)) return S;
10123: Lout=[];
10124: if(abs(Dvi)>=2){
10125: /* show title */
10126: L0=[];
10127: Title=getopt(title);
10128: if(type(Title)!=7)
10129: Title=(type(F00)==4)?("\\texttt{"+verb_tex_form(F00)+"}"):my_tex_form(F00);
10130: if(type(Title)==7){
10131: T=my_tex_form(L[3][0])+"\\le x\\le "+my_tex_form(L[1][0])+",\\,"+
10132: my_tex_form(L[3][1])+"\\le y\\le "+my_tex_form(L[1][1])+")";
10133: if(Proc){
10134: if(Cpx>=1) L0=[[5,[["eq",1]],"|"+Title+"|\\quad(z=x+yi,\\ "+T]];
10135: else L0=[[5,[["eq",1]],"z="+Title+"\\ \\ ("+T]];
10136: }else{
10137: if(Cpx>=1) dviout("|"+Title+"|\\quad(z=x+yi,\\ "+T|eq=1,keep=1);
10138: else dviout("z="+Title+"\\ \\ ("+T|eq=1,keep=1);
10139: }
10140: }
10141: A=rint(deval(180*A/@pi))+90*(Sh-1);
10142: if(A>=180) A-=180;
10143: B=rint(deval(180*B/@pi));
10144: if(abs(Dvi)>=3){
10145: T="\\text{angle } ("+my_tex_form(A)+"^\\circ,"+my_tex_form(B)+"^\\circ)";
10146: if(Ratio!=1 || Ratio2!=1) T=T+"\\quad\\text{ratio }1:"
10147: +my_tex_form(sint(Ratio2,2))+":"+my_tex_form(sint(Ratio,2));
10148: if(Proc) L0=cons([5,[["eq",1]],T],L0);
10149: else dviout(T|eq=1,keep=1);
10150: }
10151: SS="% range "+rtostr([L[3][0],L[1][0]])+"x"+rtostr([L[3][1],L[1][1]])+
10152: " angle ("+ rtostr(A) +","+ rtostr(B)+") dev=";
10153: if(M1==M2) SS=SS+rtostr(M1);
10154: else SS=SS+rtostr([M1,M2]);
10155: if(M3!=1) SS=SS+" acc="+rtostr(M3);
10156: if(type(Sc0)>=0) SS=SS+" scale="+rtostr(Sc0);
10157: if(Proc){
10158: S=cons([5,[],SS],S);
10159: for(;L0!=[];L0=cdr(L0)) S=cons(car(L0),S);
10160: return S;
10161: }
10162: if(Dvi>0){
10163: dviout(SS|keep=1);
10164: dviout(xyproc(S)|eq=8);
10165: }else Lout=[SS,S];
10166: }else{
10167: if(Dvi>0) dviout(xyproc(S));
10168: else Lout=[S];
10169: }
10170: if(getopt(trans)==1) return cons([CX*Sc,CY*Sc],Lout);
10171: if(Dvi<0) return Lout;
10172: }
10173:
1.4 ! takayama 10174: def fouriers(A,B,X)
1.3 takayama 10175: {
1.4 ! takayama 10176: if(A!=[]&&type(car(A))>1){
! 10177: for(C=[],I=A[1];I>=0;I--) C=cons(myfeval(car(A),I),C);
! 10178: A=C;
! 10179: }
! 10180: if(B!=[]&&type(car(B))>1){
! 10181: for(C=[],I=B[1];I>0;I--) C=cons(myfeval(car(B),I),C);
! 10182: B=C;
! 10183: }
! 10184: R=0;
! 10185: if(getopt(cpx)==1){
! 10186: if(type(X=eval(X))>1) return todf([os_md.fouriers,[["cpx",1]]],[[A],[B],[X]]);
! 10187: V=dexp(@i*X);
! 10188: for(C=A,P=1,I=0;C!=[];C=cdr(C),I++){
! 10189: R+=car(C)*P;
! 10190: P*=V;
! 10191: }
! 10192: V=dexp(-@i*X);
! 10193: for(C=B,P=1,I=0;C!=[];C=cdr(C),I++){
! 10194: P*=V;
! 10195: R+=car(C)*P;
! 10196: }
! 10197: return R;
! 10198: }
! 10199: if(type(X=eval(X))>1) return todf(os_md.fouriers,[[A],[B],[X]]);
! 10200: for(C=A,I=0;C!=[];C=cdr(C),I++)
! 10201: R+=car(C)*mycos(I*X);
! 10202: for(C=B,I=1;C!=[];C=cdr(C),I++)
! 10203: R+=car(C)*mysin(I*X);
! 10204: return R;
! 10205: }
! 10206:
! 10207:
! 10208: def myexp(Z)
! 10209: {
! 10210: if(type(Z=eval(Z))>1) return todf(os_md.myexp,[Z]);
1.3 takayama 10211: if((Im=imag(Z))==0) return dexp(Z);
10212: return dexp(real(Z))*(dcos(Im)+@i*dsin(Im));
10213: }
10214:
10215: def mycos(Z)
10216: {
1.4 ! takayama 10217: if(type(Z=eval(Z))>1) return todf(os_md.mycos,[Z]);
1.3 takayama 10218: if((Im=imag(Z))==0) return dcos(Z);
10219: V=myexp(Z*@i);
10220: return (V+1/V)/2;
10221: }
10222:
10223: def mysin(Z)
10224: {
1.4 ! takayama 10225: if(type(Z=eval(Z))>1) return todf(os_md.mysin,[Z]);
1.3 takayama 10226: if((Im=imag(Z))==0) return dsin(Z);
10227: V=myexp(Z*@i);
10228: return (1/V-V)*@i/2;
10229: }
10230:
10231: def mytan(Z)
10232: {
1.4 ! takayama 10233: if(type(Z=eval(Z))>1) return todf(os_md.mytan,[Z]);
1.3 takayama 10234: if((Im=imag(Z))==0) return dsin(Z);
10235: V=myexp(2*Z*@i);
10236: return @i*(1-V)/(1+V);
10237: }
10238:
10239: def mylog(Z)
10240: {
1.4 ! takayama 10241: if(type(Z=eval(Z))>1) return todf(os_md.mylog,[Z]);
1.3 takayama 10242: if((Im=imag(Z))==0) return dlog(Z);
10243: return dlog(dabs(Z))+@i*myarg(Z);
10244: }
10245:
1.4 ! takayama 10246: def mypow(Z,R)
! 10247: {
! 10248: if(type(Z=eval(Z))>1||type(R=eval(R))>1) return todf(os_md.mypow,[Z,R]);
! 10249: if(Z==0) return 0;
! 10250: if(isint(2*R)){
! 10251: if(R==0) return 1;
! 10252: if(isint(R)) return Z^R;
! 10253: V=dsqrt(Z);
! 10254: if(R==1/2) return V;
! 10255: return Z^(R-1/2)*V;
! 10256: }
! 10257: return myexp(R*mylog(Z));
! 10258: }
! 10259:
1.3 takayama 10260: def myarg(Z)
10261: {
1.4 ! takayama 10262: if(type(Z=map(eval,Z))==4){
! 10263: if(length(Z)!=2) return todf(os_md.myarg,[Z]);
1.3 takayama 10264: Re=Z[0];Im=Z[1];
1.4 ! takayama 10265: }else if(type(Z)>1){
! 10266: return todf(os_md.myarg,[Z]);
! 10267: }else {
1.3 takayama 10268: Im=imag(Z);Re=real(Z);
10269: }
10270: if(Re==0) return (Im<0)?-deval(@pi)/2:deval(@pi)/2;
10271: V=datan(Im/Re);
10272: if(Re>0) return V;
10273: return (V>0)?(V-deval(@pi)):(V+deval(@pi));
10274: }
10275:
10276: def myatan(Z)
10277: {
1.4 ! takayama 10278: if(type(Z=eval(Z))>1) return todf(os_md.myatan,[Z]);
1.3 takayama 10279: if((Im=imag(Z))==0) return datan(Z);
10280: mylog((1-Z*@i)/(1+Z*@i))*@i/2;
10281: }
10282:
10283: def myasin(Z)
10284: {
1.4 ! takayama 10285: if(type(Z=eval(Z))>1) return todf(os_md.myasin,[Z]);
1.3 takayama 10286: return deval(@pi/2)-myacos(Z);
10287: }
10288:
1.4 ! takayama 10289: def frac(X)
! 10290: {
! 10291: if(type(X=eval(X))>1) return todf(os_md.frac,[X]);
! 10292: return (ntype(X)==3)? pari(frac,X):(X-floor(X));
! 10293: }
! 10294:
1.3 takayama 10295: def myacos(Z)
10296: {
1.4 ! takayama 10297: if(type(Z=eval(Z))>1) return todf(os_md.myacos,[Z]);
1.3 takayama 10298: if(imag(Z)==0 && Z<=1 && Z>=-1) return dacos(Z);
10299: return mylog(Z-dsqrt(Z^2-1))*@i;
10300: }
10301:
1.4 ! takayama 10302: def arg(Z)
! 10303: {
! 10304: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.arg,[Z]);
! 10305: return (type(Z)==4)?pari(arg,Z[0],Z[1]):arg(sqrt,Z);
! 10306: }
! 10307:
! 10308: def sqrt(Z){
! 10309: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.sqrt,[Z]);
! 10310: R=(type(Z)==4)?Z[1]:Z;
! 10311: if(ntype(R)==0){
! 10312: if(R==0) return 0;
! 10313: if(R>0){
! 10314: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R));
! 10315: }else{
! 10316: R=-R;
! 10317: if(pari(issquare,R)) return pari(isqrt,nm(R))/pari(isqrt,dn(R))*@i;
! 10318: }
! 10319: }
! 10320: return (type(Z)==4)?pari(sqrt,Z[0],Z[1]):pari(sqrt,Z);
! 10321: }
! 10322:
1.3 takayama 10323: def gamma(Z)
10324: {
1.4 ! takayama 10325: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.gamma,[Z]);
! 10326: return (type(Z)==4)?pari(gamma,Z[0],Z[1]):pari(gamma,Z);
1.3 takayama 10327: }
10328:
10329: def lngamma(Z)
10330: {
1.4 ! takayama 10331: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.lngamma,[Z]);
! 10332: return (type(Z)==4)?pari(lngamma,Z[0],Z[1]):pari(lngamma,Z);
1.3 takayama 10333: }
10334:
10335: def digamma(Z)
10336: {
1.4 ! takayama 10337: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.digamma,[Z]);
! 10338: return (type(Z)==4)?pari(digamma,Z[0],Z[1]):pari(digamma,Z);
1.3 takayama 10339: }
10340:
10341: def dilog(Z)
10342: {
1.4 ! takayama 10343: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.dilog,[Z]);
! 10344: return (type(Z)==4)?pari(dilog,Z[0],Z[1]):pari(dilog,Z);
1.3 takayama 10345: }
10346:
10347: def erfc(Z)
10348: {
1.4 ! takayama 10349: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.erfc,[Z]);
! 10350: return (type(Z)==4)?pari(erfc,Z[0],Z[1]):pari(erfc,Z);
1.3 takayama 10351: }
10352:
10353: def zeta(Z)
10354: {
1.4 ! takayama 10355: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.zeta,[Z]);
! 10356: return (type(Z)==4)?pari(zeta,Z[0],Z[1]):pari(zeta,Z);
1.3 takayama 10357: }
10358:
10359: def eta(Z)
10360: {
1.4 ! takayama 10361: if(vars(Z=map(eval,Z))!=[]) return todf(os_md.eta,[Z]);
! 10362: return (type(Z)==4)?pari(eta,Z[0],Z[1]):pari(eta,Z);
1.3 takayama 10363: }
10364:
10365: def jell(Z)
10366: {
1.4 ! takayama 10367: if(vars(Z=map(eval,V))>1) return todf(os_md.jell,[Z]);
! 10368: return (type(Z)==4)?pari(jell,Z[0],Z[1]):jell(jell,Z);
1.3 takayama 10369: }
10370:
10371: def evals(F)
10372: {
10373: if(type(F)==7){
10374: if(type(Del=getopt(del))!= 7) return eval_str(F);
10375: S=strtoascii(Del);K=length(S);
10376: if(K==0) return [eval_str(F)];
10377: Raw=getopt(raw);
10378: F=strtoascii(F);L=[];T1=0;
10379: do{
10380: T2=str_str(F,S|top=T1);
10381: if(T2<0) T2=10000;
10382: FT=str_cut(F,T1,T2-1);
10383: L=cons((Raw==1)?FT:evals(FT),L);
10384: T1=T2+K;
10385: }while(T2!=10000);
10386: return reverse(L);
10387: }
10388: if(type(F)==4){
10389: if(type(S=car(F))==7){
10390: S+="(";
10391: for(I=0,FT=cdr(F); FT!=[]; I++,FT=cdr(FT)){
10392: if(type(ST=car(FT))!=7) ST=rtostr(ST);
10393: if(I>0) S=S+","+ST;
10394: else S=S+ST;
10395: }
10396: S=S+")";
10397: return eval_str(S);
10398: }else return call(S,cdr(F));
10399: }
10400: return F;
10401: }
10402:
1.4 ! takayama 10403: def myval(F)
! 10404: {
! 10405: if(type(F)!=4){
! 10406: F=f2df(sqrt2rat(F));
! 10407: if(type(F)!=4) return F;
! 10408: };
! 10409: if(length(F)==1) V=car(F);
! 10410: else for(V=car(F),F=cdr(F); F!=[];){
! 10411: FT=car(F);
! 10412: if(type(G=FT[1])==2){
! 10413: if(length(FT)>2){
! 10414: FT2=myval(FT[2]);
! 10415: if(length(FT)>3) FT3=myval(FT[3]);
! 10416: };
! 10417: X=red(FT2/@pi);Vi=-red(FT2*@i/@pi);W=red(FT2/@e);
! 10418: if(G==os_md.mypow && FT3==1/2){
! 10419: G=os_md.sqrt;
! 10420: FT=[FT[0],G,FT[2]];
! 10421: }
! 10422: if((T=findin(G,
! 10423: [sin,os_md.mysin,cos,os_md.mycos,tan,os_md.mytan]))>=0
! 10424: &&(isint(6*X)||isint(4*X))){
! 10425: if(T==2||T==3){
! 10426: T=0;X=1/2-X;
! 10427: }
! 10428: X=X-floor(X/2)*2;
! 10429: if(T==0||T==1){
! 10430: if(X>1){
! 10431: S=-1;X-=1;
! 10432: }else S=1;
! 10433: if(X>1/2) X=1-X;
! 10434: if(X==0) R=0;
! 10435: else if(X==1/6) R=1/2;
! 10436: else if(X==1/4) R=2^(1/2)/2;
! 10437: else if(X==1/3) R=3^(1/2)/2;
! 10438: else R=1;
! 10439: R*=S;
! 10440: }else{
! 10441: if(X>1) X-=1;
! 10442: if(X>1/2){
! 10443: S=-1;V=1-X;
! 10444: }else S=1;
! 10445: if(X==0) R=0;
! 10446: else if(X==1/6) R=3^(1/2)/3;
! 10447: else if(X==1/4) R=1;
! 10448: else if(X==1/3) R=3^(1/2);
! 10449: else R=2^512;
! 10450: R*=S;
! 10451: }
! 10452: }else if((G==exp||G==os_md.myexp)&&(isint(FT2)||isint(6*Vi)||isint(4*Vi))){
! 10453: if(isint(FT2)) R=@e^FT2;
! 10454: else R=myval([z+w*@i,[z,cos,Vi*@pi],[w,sin,Vi*@pi]]);
! 10455: }else if((G==pow||G==os_md.mypow) && (isint(FT3)||FT2==1||FT2==0)){
! 10456: if(FT2==0) R=0;
! 10457: else if(FT2==1) R=1;
! 10458: else R=FT2^FT3;
! 10459: }else if(G==os_md.abs&&ntype(P=eval(FT2))<4){
! 10460: R=FT2;
! 10461: if(P<0) R=-R;
! 10462: }else if((G==os_md.sqrt||G==dsqrt)&&type(FT2)<2&&ntype(FT2)==0)
! 10463: R=sqrtrat(FT2);
! 10464: else if((G==os_md.mylog||G==dlog)&&(FT2==@e||FT2==1))
! 10465: R=(FT2==1)?0:1;
! 10466: else if(length(FT)==3) R=eval((*G)(myeval(FT2)));
! 10467: #ifdef USEMODULE
! 10468: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
! 10469: #else
! 10470: else R=call(G,map(myeval,cdr(cdr(FT))));
! 10471: #endif
! 10472: }
! 10473: else if(G==0) R=FT[2];
! 10474: #ifdef USEMODULE
! 10475: else R=eval(call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]));
! 10476: #else
! 10477: else R=eval(call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]));
! 10478: #endif
! 10479: V=mysubst(V,[FT[0],R]);
! 10480: F=mysubst(cdr(F),[FT[0],R]);
! 10481: }
! 10482: if(type(V)<4 && !iscoef(V,os_md.iscrat)) V=eval(V);
! 10483: #if 0
! 10484: return (type(V)<4)?myeval(V):mtransbys(os_md.myeval,V,[]);
! 10485: #else
! 10486: return V;
! 10487: #endif
! 10488: }
! 10489:
! 10490: /* -1:空 0:整数 1:有理数 2:Gauss整数 3:Gauss有理数 4:それ以外の複素数 */
! 10491: /* def vntype(F)
! 10492: {
! 10493: if((T=type(F))<2){
! 10494: if(T<0) return -1;
! 10495: if((Tn=ntype(F))==0){
! 10496: return (isint(F))?0:1;
! 10497: }
! 10498: if(Tn==4){
! 10499: if(ntype(real(F))==0&&ntype(real(F))==0)
! 10500: return (isint(F)&&isint(F))?2:3;
! 10501: return 4;
! 10502: }
! 10503: }
! 10504: if(T==2){
! 10505: V=vars(F);
! 10506: if((VV=lsort(V,[@e,@pi],1))==[]){
! 10507: FT=mycoef(
! 10508: }else{
! 10509: if(length(VV)==1){
! 10510: }else
! 10511: }
! 10512: }else if(T==3){
! 10513:
! 10514: }
! 10515: }
! 10516: */
! 10517:
! 10518:
1.3 takayama 10519: def myeval(F)
10520: {
10521: if(type(F)!=4) V=F;
1.4 ! takayama 10522: else if(length(F)==1) V=car(F);
1.3 takayama 10523: else for(V=car(F),F=cdr(F); F!=[];){
10524: FT=car(F);
10525: if(type(G=FT[1])==2){
10526: if(length(FT)==3) R=(*G)(myeval(FT[2]));
10527: #ifdef USEMODULE
10528: else R=call(G,map(os_md.myeval,cdr(cdr(FT))));
10529: #else
10530: else R=call(G,map(myeval,cdr(cdr(FT))));
10531: #endif
10532: }
10533: else if(G==0) R=myeval(FT[2]);
10534: #ifdef USEMODULE
10535: else R=call(G[0],map(os_md.myeval,cdr(cdr(FT)))|option_list=G[1]);
10536: #else
10537: else R=call(G[0],map(myeval,cdr(cdr(FT)))|option_list=G[1]);
10538: #endif
1.4 ! takayama 10539: V=mysubst(V,[FT[0],R]);
! 10540: F=mysubst(cdr(F),[FT[0],R]);
1.3 takayama 10541: }
1.4 ! takayama 10542: return (type(V)<4)?eval(V):mtransbys(eval,V,[]);
1.3 takayama 10543: }
10544:
10545: def mydeval(F)
10546: {
10547: if(type(F)!=4) V=F;
1.4 ! takayama 10548: else if(length(F)==1) V=car(F);
1.3 takayama 10549: else for(V=car(F),F=cdr(F); F!=[]; ){
10550: FT=car(F);
10551: if(type(G=FT[1])==2){
10552: if(length(FT)==3) R=(*G)(myeval(FT[2]));
10553: #ifdef USEMODULE
10554: else R=call(G,map(os_md.mydeval,cdr(cdr(FT))));
10555: #else
10556: else R=call(G,map(mydeval,cdr(cdr(FT))));
10557: #endif
10558: }
10559: else if(G==0) R=mydeval(FT[2]);
10560: #ifdef USEMODULE
10561: else R=call(G[0],map(os_md.mydeval,cdr(cdr(FT)))|option_list=G[1]);
10562: #else
10563: else R=call(G[0],map(mydeval,cdr(cdr(FT)))|option_list=G[1]);
10564: #endif
1.4 ! takayama 10565: V=mysubst(V,[FT[0],R]);
! 10566: F=mysubst(cdr(F),[FT[0],R]);
1.3 takayama 10567: }
1.4 ! takayama 10568: return (type(V)<4)?deval(V):mtransbys(deval,V,[]);
1.3 takayama 10569: }
10570:
10571: def myfeval(F,X)
10572: {
1.4 ! takayama 10573: if(type(X)==4){
! 10574: if(isvar(X[0])&&length(X)==2)
! 10575: return mydeval(mysubst(F,[X[0],X[1]]));
! 10576: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
! 10577: for(Y=X;Y!=[];Y=cdr(Y))
! 10578: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
! 10579: return myeval(F);
! 10580: }
! 10581: }
! 10582: return myeval(mysubst(F,[x,X]));
1.3 takayama 10583: }
10584:
10585: def myf2eval(F,X,Y)
10586: {
1.4 ! takayama 10587: return myeval(mysubst(F,[[x,X],[y,Y]]));
1.3 takayama 10588: }
10589:
10590: def myf3eval(F,X,Y,Z)
10591: {
1.4 ! takayama 10592: return myeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
1.3 takayama 10593: }
10594:
10595: def myfdeval(F,X)
10596: {
1.4 ! takayama 10597: if(type(X)==4){
! 10598: if(isvar(X[0])&&length(X)==2)
! 10599: return mydeval(mysubst(F,[X[0],X[1]]));
! 10600: if(type(X[0])==4&&isvar(X[0][0])&&length(X[0])==2){
! 10601: for(Y=X;Y!=[];Y=cdr(Y))
! 10602: F=mysubst(F,[car(Y)[0],car(Y)[1]]);
! 10603: return mydeval(F);
! 10604: }
! 10605: }
! 10606: return mydeval(mysubst(F,[x,X]));
1.3 takayama 10607: }
10608:
10609: def myf2deval(F,X,Y)
10610: {
1.4 ! takayama 10611: return mydeval(mysubst(F,[[x,X],[y,Y]]));
1.3 takayama 10612: }
10613:
10614: def myf3deval(F,X,Y,Z)
10615: {
1.4 ! takayama 10616: return mydeval(mysubst(F,[[x,X],[y,Y],[z,Z]]));
! 10617: }
! 10618:
! 10619: def df2big(F)
! 10620: {
! 10621: AG=[[os_md.mysin,sin],[os_md.mycos,cos],[os_md.mytan,tan],[os_md.myasin,asin],
! 10622: [os_md.acos,acos],[os_md,atan,atan],[os_md.myexp,exp],[os_md.mylog,log],[os_md.mypow,pow]];
! 10623: if(getopt(inv)!=1) return mysubst(F,AG);
! 10624: else return mysubst(F,AG|inv=1);
! 10625:
1.3 takayama 10626: }
10627:
10628: def f2df(F)
10629: {
10630: if(type(Opt=getopt(opt))!=1) Opt=0;
10631: if(iand(Opt,1)){
10632: if(Opt>0) F=map(eval,F);
10633: else F=map(deval,F);
10634: }
10635: Cpx=getopt(cpx);
10636: if(type(F)==4 && iand(Opt,2)==0) return F;
10637: K=getopt(level);
10638: if(type(K)!=1) K=0;
10639: AG=[sin,cos,tan,asin,acos,atan,exp,sinh,cosh,tanh,log,pow];
1.4 ! takayama 10640: AGd=[os_md.mysin,os_md.mycos,os_md.mytan,os_md.myasin,os_md.myacos,
1.3 takayama 10641: os_md.myatan,os_md.myexp,os_md.myexp,os_md.myexp,os_md.myexp,
1.4 ! takayama 10642: os_md.mylog,os_md.sqrt,os_md.myexp];
1.3 takayama 10643: for(R=[],I=0,Arg=vars(F);Arg!=[];Arg=cdr(Arg)){
10644: Fn=functor(car(Arg));
10645: if(vtype(Fn)!=3) continue;
10646: V=args(car(Arg));
10647: for(PAG=AG,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd)){
10648: if(Fn==car(PAG)){
10649: if(K==0) L="z__";
10650: else L="z"+rtostr(K)+"__";
10651: if(I==0) VC=makev([L]);
10652: else VC=makev([L,I]);
10653: I++;
10654: VC0=VC;
10655: if(Fn==sinh || Fn==cosh || Fn==tanh){
10656: VC=makev([L,I++]);
10657: if(Fn==sinh)
10658: R=cons([VC0,0,(VC^2-1)/(2*VC)],R);
10659: else if(Fn==cosh)
10660: R=cons([VC0,0,(VC^2+1)/(2*VC)],R);
10661: else
10662: R=cons([VC0,0,(VC^2-1)/(VC^2+1)],R);
10663: }
10664: if(Fn==pow && (V[1]!=1/2||Cpx==1)){
1.4 ! takayama 10665: #if 0
1.3 takayama 10666: R0=f2df(V[1]*((type(V[0])==1)?dlog(V[0]):log(V[0]))|level=K+1);
10667: PAGd=cdr(PAGd);
1.4 ! takayama 10668: #else
! 10669: R=cons([VC,os_md.mypow,V[0],V[1]],R);
! 10670: F=mysubst(F,[car(Arg),VC0]);
! 10671: Arg=cons(0,vars(F));
! 10672: break;
! 10673: #endif
1.3 takayama 10674: }else R0=f2df(V[0]|level=K+1);
10675: R=cons([VC,car(PAGd),R0],R);
1.4 ! takayama 10676: F=mysubst(F,[car(Arg),VC0]);
1.3 takayama 10677: Arg=cons(0,vars(F));
10678: break;
10679: }
10680: }
10681: }
10682: if(R==[]) return F;
10683: if(Cpx==1){
10684: for(PAG=P,PAGd=AGd;PAG!=[];PAG=cdr(PAG),PAGd=cdr(PAGd))
1.4 ! takayama 10685: R=mysubst(R,[car(PADd),car(PAG)]);
1.3 takayama 10686: }
10687: return cons(F,reverse(R));
10688: }
10689:
1.4 ! takayama 10690: def todf(F,V)
! 10691: {
! 10692: if(type(V)!=4) V=[V];
! 10693: for(R=[];V!=[];V=cdr(V)){
! 10694: R=cons(f2df(car(V)),R);
! 10695: }
! 10696: V=reverse(R);
! 10697: Z=makenewv([F,V]);
! 10698: return [Z,cons(Z,cons(F,V))];
! 10699: }
! 10700:
1.3 takayama 10701: def compdf(F,V,G)
10702: {
10703: FL=["abs","floor","rint","zeta","gamma","arg","real","imag","conj"];
10704: FS=[os_md.abs,floor,rint,os_md.zeta,os_md.gamma,os_md.myarg,real,imag,conj];
10705: if(type(V)==4){
10706: for(;V!=[];V=cdr(V),G=cdr(G)) F=compdf(F,car(V),car(G));
10707: return F;
10708: }
10709: if(type(F)==7){
10710: if(str_str(F,"|")==0){
10711: F="abs("+str_cut(F,1,str_len(F)-2)+")";
10712: }else if(str_str(F,"[")==0){
10713: F="floor("+str_cut(F,1,str_len(F)-2)+")";
10714: }
10715: I=str_str(F,"(");
10716: Var=x;
10717: if(I>0){
10718: J=str_pair(F,I+1,"(",")");
10719: if(J<0) return 0;
10720: Var=eval_str(str_cut(F,I+1,J-1));
10721: Var=f2df(Var);
10722: F0=str_cut(F,0,I-1);
10723: }
10724: if((I=findin(F0,FL))<0&&(I=findin(F,FL))<0) F=f2df(eval_str(F));
10725: else F=[z__,[z__,FS[I],Var]];
10726: }
10727: if(type(F)!=4) F=f2df(F);
10728: if(type(G)!=4) G=f2df(G);
10729: VF=vars(F);VG=vars(G);
10730: for(E=I=0;I<30;I++){
10731: for(J=0;J<30;J++){
10732: X=makev(["z__",I,J]);
10733: if(findin(X,VF)<0 && findin(X,VG)<0){
10734: E=1;break;
10735: }
10736: }
10737: if(E) break;
10738: }
10739: if(!E) return 0;
10740: if(V==G) return F; /* subst(F(V),V,G) */
1.4 ! takayama 10741: if(type(G)<4) return mysubst(F,[V,G]);
1.3 takayama 10742: if(type(F)<4) F=[F]; /* return compdf([X,[X,0,F]],V,G); */
1.4 ! takayama 10743: F=mysubst(F,[V,X]);
! 10744: if(isvar(G[0])){
! 10745: G=mysubst(G,[G[0],X]);
! 10746: if(length(G)==2&&type(G[1])==4&&G[1][0]==X) G=G[1];
! 10747: G=cons(G,cdr(F));
! 10748: }
! 10749: else G=cons([X,0,G],cdr(F));
1.3 takayama 10750: return cons(car(F),G);
10751: }
10752:
10753: def fzero(F,LX)
10754: {
1.4 ! takayama 10755: if(length(LX)==3){
! 10756: V=LX[0];LX=cdr(LX);
! 10757: }else V=x;
! 10758: LX1=eval(LX[0]);LX2=eval(LX[1]);
1.3 takayama 10759: if(getopt(zero)==1){
10760: if(getopt(cont)==1) CT=1;
10761: else CT=0;
10762: if(getopt(trans)!=1 && type(F)<4) F=f2df(F);
1.4 ! takayama 10763: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
1.3 takayama 10764: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
1.4 ! takayama 10765: V1=myeval(mysubst(F,[V,X1=LX1]));
! 10766: V2=myeval(mysubst(F,[V,X2=LX2]));
1.3 takayama 10767: if(V1>0){
10768: V0=V1;V1=V2;V2=V0;
10769: X0=X1;X1=X2;X2=X0;
10770: }
10771: if(V1<0 && V2>0){
10772: D=(V2-V1)*1024;
10773: for(I=0; I<Dev; I++){
10774: /* mycat([D,X1,V1,X2,V2]) ; */
10775: if(iand(I,1)) X0=(X1+X2)/2;
10776: else X0=(V2*X1-V1*X2)/(V2-V1);
1.4 ! takayama 10777: V0=myeval(mysubst(F,[V,X0]));
1.3 takayama 10778: if(V0==0||V0==V1||V0==V2) return [X0,V0];
10779: if(V0<0){
10780: if(!CT && V0+D<0) return [];
10781: V1=V0;X1=X0;
10782: }else{
10783: if(!CT && V0>D) return [];
10784: V2=V0;X2=X0;
10785: }
10786: }
10787: X0=(V2*X1-V1*X2)/(V2-V1);
1.4 ! takayama 10788: return [X0,myeval(mysubst(F,[V,X0]))];
1.3 takayama 10789: }
10790: if(V0==0) return [X0,V0];
10791: if(V1==0) return [X1,V1];
10792: return [];
10793: }
10794: if(type(F)<4) F=f2df(F);
1.4 ! takayama 10795: F=mysubst(F,[[@pi,deval(@pi)],[@e,deval(@e)]]);
1.3 takayama 10796: L=[];
10797: if(type(F)<4){
10798: if(type(F)==3) F=nm(red(F));
1.4 ! takayama 10799: if((Deg=deg(F,V))<=2){
1.3 takayama 10800: if(Deg==2){
1.4 ! takayama 10801: D=(C1=coef(F,1,V))^2-4*(C2=coef(F,2,V))*coef(F,0,V);
1.3 takayama 10802: if(D>=0){
10803: R=dsqrt(D);
1.4 ! takayama 10804: if((S=(-C1+R)/(2*C2))>=LX1&&S<=LX2) L=[[S,mysubst(F,[V,S])]];
! 10805: if(D!=0 && (S=(-C1-R)/(2*C2))>=LX1&&S<=LX2) L=cons([S,mysubst(F,[V,S])],L);
1.3 takayama 10806: }
1.4 ! takayama 10807: L=qsort(L);
! 10808: }else if(Deg==1&&(S=-coef(F,0,V)/coef(F,1,V))>=LX1&&S<=LX2)
! 10809: L=[[S,mysubst(F,[V,S])]];
1.3 takayama 10810: return L;
10811: }
10812: for(L=[];S!=[];S=cdr(S))
1.4 ! takayama 10813: if(car(S)>=LX1&&car(S)<=LX2) L=cons([car(S),mysubst(F,[V,car(S)])],L);
1.3 takayama 10814: return qsort(L);
10815: }
10816: if(type(Div=getopt(mesh))!=1 || Div<=0)
10817: Div = 2^(10);
10818: W=(LX2-LX1)/Div;
10819: for(I=V2=0;I<=Div;I++){
10820: X1=X2;X2=LX1+I*W;V1=V2;
1.4 ! takayama 10821: if((V2=myeval(mysubst(F,[V,X2])))==0)
1.3 takayama 10822: L=cons([X2,V2],L);
10823: if(V1*V2<0){
1.4 ! takayama 10824: L0=fzero(F,[V,X1,X2]|zero=1,trans=1);
1.3 takayama 10825: if(L0!=[]) L=cons(L0,L);
10826: }
10827: }
10828: return reverse(L);
10829: }
10830:
10831: def fmmx(F,LX)
10832: {
1.4 ! takayama 10833: if(length(LX)==3){
! 10834: V=LX[0];LX=cdr(LX);
! 10835: }else V=x;
! 10836: LX1=eval(LX[0]);LX2=eval(LX[1]);
! 10837: FT=F;
! 10838: if(getopt(trans)!=1 && type(F)<4) FT=f2df(FT);
! 10839: FT=mysubst(FT,[[@pi,eval(@pi)],[@e,eval(@e)]]);
1.3 takayama 10840: if(type(G=getopt(dif))>=1){
1.4 ! takayama 10841: if(G==1) G=os_md.mydiff(F,V);
! 10842: L=fzero(G,[V,LX1,LX2]|option_list=getopt());
! 10843: R=[[LX1,myeval(mysubst(FT,[V,LX1]))]];
1.3 takayama 10844: for(I=0;L!=[];L=cdr(L),I++){
10845: X=car(L)[0];
10846: if(X==LX1) continue;
1.4 ! takayama 10847: R=cons([X,myeval(mysubst(FT,[V,X]))],R);
! 10848: }
! 10849: if(X!=LX2) R=cons([LX2,myeval(mysubst(FT,[V,LX2]))],R);
! 10850: if(getopt(mmx)!=1) return reverse(R);
! 10851: for(Mi=Ma=car(R);R!=[];R=cdr(R)){
! 10852: if(car(R)[1]>Ma[1]) Ma=car(R);
! 10853: else if(car(R)[1]<Mi[1]) Mi=car(R);
1.3 takayama 10854: }
1.4 ! takayama 10855: return [Mi,Ma];
1.3 takayama 10856: }
10857: if(type(Div=getopt(mesh))!=1 || Div<=0)
10858: Div = 2^(10);
10859: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
10860: W=(LX2-LX1)/Div;
10861: for(I=V2=V3=0;I<=Div;I++){
10862: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
1.4 ! takayama 10863: V3=myeval(mysubst(FT,[V,X3]));
1.3 takayama 10864: if(I==0) L=[[X3,V3]];
10865: if(I<2) continue;
10866: /* mycat([X1,X2,X3,V1,V2,V3]); */
10867: if((V1-V2)*(V2-V3)<0){
10868: X02=X2;V02=V2;X03=X3;V03=V3;
10869: for(J=0; J<Dev && X1!=X3; J++){
10870: /* mycat([J,X1,X2,X3,V1,V2,V3,V1-V2,V2-V3]); */
1.4 ! takayama 10871: X12=(X1+X2)/2;V12=myeval(mysubst(FT,[V,X12]));
1.3 takayama 10872: if((V1-V12)*(V12-V2)<=0){
10873: X3=X2;V3=V2;X2=X12;V2=V12;continue;
10874: }
1.4 ! takayama 10875: X23=(X2+X3)/2;V23=myeval(mysubst(FT,[V,X23]));
1.3 takayama 10876: if((V12-V2)*(V2-V23)<=0){
10877: X1=X12;V1=V12;X3=X23;V3=V23;continue;
10878: }
10879: if((V2-V23)*(V23-V3)<=0){
10880: X1=X2;V1=V2;X2=X23;V2=V23;continue;
10881: }
10882: }
10883: L=cons([X2,V2],L);
10884: X2=X02;V2=V02;X3=X03;V3=V03;
10885: }
10886: }
1.4 ! takayama 10887: L=cons([LX2,myeval(mysubst(FT,[V,LX2]))],L);
! 10888: if(getopt(mmx)!=1) return L;
! 10889: for(Mi=Ma=car(L);L!=[];L=cdr(L)){
! 10890: if(car(L)[1]>Ma[1]) Ma=car(L);
! 10891: else if(car(L)[1]<Mi[1]) Mi=car(L);
! 10892: }
! 10893: return [Mi,Ma];
! 10894: }
! 10895:
! 10896: def flim(F,L)
! 10897: {
! 10898: FD=f2df(F);
! 10899: Lim0=4;Lim=12;FS=1;
! 10900: if(type(Pc=getopt(prec))==1){
! 10901: if((Pc>1&&Pc<31)||Pc>-5) Lim+=Pc;
! 10902: }
! 10903: if(type(Pc=getopt(init))==1 && Pc>0) FS*=Pc;
! 10904: if(type(L)==7) L=[L];
! 10905: else if(type(L)<2){
! 10906: K=flim(F,["+",L]|option_list=getopt());
! 10907: if(K=="") return K;
! 10908: K1=flim(F,["-",L]|option_list=getopt());
! 10909: if(K1=="") return K1;
! 10910: if(type(K)==7||type(K1)==7){
! 10911: if(K!=K1) return "";
! 10912: return K;
! 10913: }
! 10914: if(abs(K)<10^(-5)){
! 10915: if(abs(K1)<10^(-5)) return (K1+K)/2;
! 10916: else return "";
! 10917: }
! 10918: if(abs((K1-K)/K)<10^(-4)) return (K1+K)/2;
! 10919: return "";
! 10920: }
! 10921: if(type(L)!=4||type(L[0])!=7) return "";
! 10922: if(L[0]=="-"){
! 10923: FS=-FS;
! 10924: }else if(L[0]!="+") return "";
! 10925: FI=(length(L)==1)?1:0;
! 10926: for(Inf=0,I=Lim0;I<Lim;I++){
! 10927: D1=FS*8^I;D2=8*D1;
! 10928: if(FI==0){
! 10929: D1=1/D1;D2=1/D2;
! 10930: }
! 10931: if(D1>D2){
! 10932: D=D1;D1=D2;D1=D;
! 10933: X1=D1;X2=D2;
! 10934: }
! 10935: if(FI==0){
! 10936: D1+=L[1];D2+=L[1];
! 10937: }
! 10938: K=fmmx(FD,[D1,D2]|mmx=1,mesh=16,dev=4);
! 10939: /* mycat([FD,DF,K,Inf]); */
! 10940: if(I>Lim0){
! 10941: if(DF<K[1][1]-K[0][1]){
! 10942: if(I>Lim0+1){
! 10943: if(Inf==0) return "";
! 10944: }else Inf=1;
! 10945: }else if(Inf==1) return "";
! 10946: }
! 10947: DF=K[1][1]-K[0][1];
! 10948: }
! 10949: if(Inf==1){
! 10950: if(K[0][1]>10^8) return "+";
! 10951: else if(K[1][1]<-10^8) return "-";
! 10952: return "";
! 10953: }
! 10954: V=(myfeval(FD,D1)+1.0)-1.0;
! 10955: if(V!=0 && abs(V)<10^(-9)) return 0;
! 10956: return V;
1.3 takayama 10957: }
10958:
10959: def fcont(F,LX)
10960: {
1.4 ! takayama 10961: if(length(LX)==3){
! 10962: V=LX[0];LX=cdr(LX);
! 10963: }else V=x;
! 10964: LX1=eval(LX[0]);LX2=eval(LX[1]);
1.3 takayama 10965: if(getopt(trans)!=1 && type(F)<4) FT=f2df(F);
10966: if(type(Div=getopt(mesh))!=1 || Div<=0)
10967: Div = 2^(10);
10968: if(type(Dev=getopt(dev))!=1 || Dev<2) Dev=16;
10969: W=(LX2-LX1)/Div;
10970: if((Df=getopt(dif))!=1){
10971: Df=0;
10972: }else{
10973: if(Dev==16) Dev=6;
10974: WD=W/2^(Dev+1);
10975: }
10976: F=FT;
10977: C=2;
10978: for(I=V2=V3=0;I<=Div;I++){
10979: X1=X2;X2=X3;X3=LX1+I*W;V1=V2;V2=V3;
1.4 ! takayama 10980: V3=myeval(mysubst(F,[V,X3]));
1.3 takayama 10981: if(Df){
10982: if(I==Div) break;
1.4 ! takayama 10983: V3=(myeval(mysubst(F,[V,X3+WD]))-V3)/WD;
1.3 takayama 10984: }
10985: if(I==0) L=[[X3,V3]];
10986: if(I<2) continue;
10987: /* mycat([X1,X2,X3,V1,V2,V3]); */
10988: if(C*dabs(2*V2-V1-V3) > dabs(V1-V3)){
10989: X01=X1;V01=V1;X02=X2;V02=V2;X03=X3;V03=V3;
10990: for(J=0; X01!=X03; J++){
10991: /* mycat([J,X01,X02,X03,V01,V02,V03,V01-V02,V02-V03]); */
10992: if(dabs(V01-V02)>dabs(V02-V03)){
10993: X03=X02;V03=V02;
10994: }else{
10995: X01=X02;V01=V02;
10996: }
10997: if(J==Dev) break;
10998: X02=(X01+X02)/2;
1.4 ! takayama 10999: V02=myeval(mysubst(F,[V,X02]));
! 11000: if(Df) V02=(myeval(mysubst(F,[V,WD]))-V02)/WD;
1.3 takayama 11001: if(C*dabs(2*V02-V01-V03) < dabs(V01-V03)) break;
11002: }
11003: if(J==Dev||X01==X03) L=cons([X01,X03,V03-V01],L);
11004: }
11005: }
11006: return reverse(L);
11007: }
11008:
11009: def xygraph(F,N,LT,LX,LY)
11010: {
11011: if((Proc=getopt(proc))!=1&&Proc!=2&&Proc!=3) Proc=0;
11012: if(type(DV=getopt(dviout))==4){
11013: OL=delopt(getopt(),["dviout","shift","ext","cl"]);
11014: OL=cons(["proc",1],OL);
11015: R=xygraph(F,N,LT,LX,LY|option_list=OL);
11016: OL=delopt(getopt(),["shift","ext","cl"]|inv=1);
11017: return execdraw(R,DV|optilon_list=OL);
11018: }
11019: if(N==0) N=32;
11020: if(N<0){
11021: N=-N;
11022: N1=-1; N2=N+1;
11023: }else{
11024: N1=0; N2=N;
11025: }
11026: if(length(LT)==3 && isvar(LT[0])==1){
11027: TT=LT[0]; LT=cdr(LT);
1.4 ! takayama 11028: F=mysubst(F,[TT,x]);
! 11029: }
! 11030: if(LX==0) LX=LT;
! 11031: if((Acc=getopt(Acc))!=1) Acc=0;
! 11032: if(Acc){
! 11033: LX=[eval(LX[0]),eval(LX[1])];
! 11034: LY=[eval(LY[0]),eval(LY[1])];
! 11035: LT=[eval(LT[0]),eval(LT[1])];
! 11036: }else{
! 11037: LX=[deval(LX[0]),deval(LX[1])];
! 11038: LY=[deval(LY[0]),deval(LY[1])];
! 11039: LT=[deval(LT[0]),deval(LT[1])];
1.3 takayama 11040: }
11041: TD=(LT[1]-LT[0])/N;
11042: if(type(Mul=getopt(scale))!=1){
11043: if(type(Mul)==4){
11044: MulX=Mul[0]; MulY=Mul[1];
11045: }else MulX=MulY=1;
11046: }else MulX=MulY=Mul;
11047: if(type(Org=getopt(org))==4){
11048: Orgx=Org[0];Orgy=Org[1];
11049: }else Orgx=Orgy=0;
11050: if(type(F)!=4 || (getopt(para)!=1 && length(F)>1 && type(F[0])<4 && type(F[1])==4)) {
11051: if(getopt(rev)!=1){
11052: F1=x; /* LX[0]+(LX[1]-LX[0])*(x-LT[0])/(TD*N); */
11053: F2=F;
11054: }else{
11055: F1=F;
11056: F2=x; /* LY[0]+(LY[1]-LY[0])*(x-LT[0])/(TD*N); */
11057: }
11058: }else{
11059: F1=F[0]; F2=F[1];
11060: }
11061: if(F1==0 || F2==0) LT=[];
11062: if(length(LT)==2){
1.4 ! takayama 11063: if(Acc){
! 11064: for(LTT=[],I=N2;I>=N1;I--)
! 11065: LTT=cons(eval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
! 11066: }else{
! 11067: for(LTT=[],I=N2;I>=N1;I--)
! 11068: LTT=cons(deval(LT[0]+I*(LT[1]-LT[0])/N),LTT);
! 11069: }
1.3 takayama 11070: LT=LTT;
11071: }
11072: Cpx=getopt(cpx);
11073: if(Cpx!=1 && (str_str(rtostr(F1),"@i")>=0 || str_str(rtostr(F2),"@i")>=0))
11074: Cpx=1;
11075: if(type(Cpx)<0) Cpx=0;
1.4 ! takayama 11076: if(!Acc){
! 11077: if(type(F1)<4) F1=f2df(F1);
! 11078: if(type(F2)<4) F2=f2df(F2);
! 11079: }
1.3 takayama 11080: if(type(Err=getopt(err))==1){
1.4 ! takayama 11081: F1=mysubst(F1,[x,x+Err*TD/1001.23]);
! 11082: F2=mysubst(F2,[x,x+Err*TD/1001.23]);
1.3 takayama 11083: }
11084: if(type(F1)==4 || type(F2)==4){
11085: Dn=1;
11086: }else Dn=dn(F1)*dn(F2);
11087: for(V=[],PT=LT;PT!=[]; PT=cdr(PT)){
11088: T=car(PT);
11089: if(myfeval(Dn,T)==0){
11090: V=cons(0,V); continue;
11091: }
1.4 ! takayama 11092: if(Cpx>0||Acc){
1.3 takayama 11093: X=myfeval(F1,T);Y=myfeval(F2,T);
11094: }else{
11095: X=myfdeval(F1,T);Y=myfdeval(F2,T);
11096: }
11097: if((N1==0||(PT!=LT&&length(PT)!=1)) && (X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1]))
11098: V=cons(0,V);
11099: else
11100: V=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],V);
11101: }
11102: V=reverse(V);
11103: Gap0=Gap=Arg=0;
11104: if(type(Prec=getopt(prec))<0)
11105: Level=0;
11106: else if(Prec==0) Level=4;
11107: else if(type(Prec)==1){
11108: Level=Prec;
11109: if(Level<0){
11110: Level=-Level;
11111: Gap0=1;
11112: }
11113: }else if(type(Prec)==4){
11114: Level=Prec[0];
11115: if(length(Prec)>1) Arg=Prec[1];
11116: if(length(Prec)>2) Gap0=Prec[2];
11117: }
11118: if(Level>0){
11119: if(Level>16) Level=16;
11120: if(Arg<=0) Arg=30;
11121: else if(Arg>120) Arg=120;
1.4 ! takayama 11122: Arg=Acc?eval(@pi*Arg/180):deval(@pi*Arg/180);
1.3 takayama 11123: SL=dcos(Arg);
11124: }
11125: if(Gap0>0){
11126: if(Gap0<2) Gap0=16;
11127: else if(Gap0>512) Gap0=512;
11128: Gap=((MulX*(LX[1]-LX[0]))^2+(MulY*(LY[1]-LY[0]))^2)/(Gap0^2);
11129: }
11130: for(I=0;I<Level;I++){
11131: for(F=K=G=0,NV=NLT=[],PLT=LT,PV=V;PLT!=[];K++,PLT=cdr(PLT),PV=cdr(PV)){
11132: TG=0;D0=D1;CLT0=CLT;CV0=CV;CV=car(PV);CLT=car(PLT);
11133: if(length(PV)>1){
11134: if((CV1=car(cdr(PV)))!=0 && CV!=0)
11135: D1=[CV[0]-CV1[0],CV[1]-CV1[1]];
11136: else D1=0;
11137: }else K=-1; /* ? */
11138: if(K>0 &&(((D1==0||D0==0)&&(CV0!=0||CV!=0||CV1!=0)) || dvangle(D0,D1)<SL ||
1.4 ! takayama 11139: (Gap>0 && type(D0)==4 && (TG=(D0[0]^2+D0[1]^2-Gap)>0)))){
1.3 takayama 11140: G++;T1=(CLT0+CLT)/2;
11141: if(F==0 && (CV0!=0 || CV!=0)){
11142: if(myfdeval(Dn,T1)==0){
11143: NV=cons(0,NV); NLT=cons(T1,NLT);
11144: }
1.4 ! takayama 11145: if(Cpx>0||Acc){
1.3 takayama 11146: X=myfeval(F1,T1);Y=myfeval(F2,T1);
11147: }else{
11148: X=myfdeval(F1,T1);Y=myfdeval(F2,T1);
11149: }
11150: if(K==1 && N1<0){
11151: NV=[];NLT=[];
11152: }
11153: if((K>1||N1==0)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
11154: NV=cons(0,NV);NLT=cons(T1,NLT);F=0;
11155: }else{
11156: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T1,NLT);
11157: }
11158: }
11159: NV=cons(CV,NV);NLT=cons(CLT,NLT);
11160: if(!TG&&(CV0!=0||CV1!=0)){
11161: T2=(car(cdr(PLT))+CLT)/2;
11162: if(myfdeval(Dn,T2)==0){
11163: NV=cons(0,NV); NLT=cons(CLT,NLT);
11164: }
1.4 ! takayama 11165: if(Cpx>0||Acc){
1.3 takayama 11166: X=myfeval(F1,T2);Y=myfeval(F2,T2);
11167: }else{
11168: X=myfdeval(F1,T2);Y=myfdeval(F2,T2);
11169: }
11170: if((N1==0||length(PV)!=2)&&(X<LX[0]||X>LX[1]||Y<LY[0]||Y>LY[1])){
11171: NV=cons(0,NV);NLT=cons(T1,NLT);
11172: }else{
11173: NV=cons([MulX*(X-Orgx),MulY*(Y-Orgy)],NV);NLT=cons(T2,NLT);
11174: }
11175: }
11176: if(length(PV)==2 && N1==-1) break;
11177: F=1;
11178: }else{
11179: F=0;NV=cons(CV,NV);NLT=cons(CLT,NLT);
11180: }
11181: }
11182: V=reverse(NV);LT=reverse(NLT);
11183: if(G==0) break;
11184: }
11185: if(Gap>0){
11186: for(NV=[],PV=V;PV!=[];PV=cdr(PV)){
11187: NV=cons(P0=car(PV),NV);
11188: if(length(PV)>1 && P0!=0 && PV[1]!=0
11189: && (P0[0]-PV[1][0])^2+(P0[1]-PV[1][1])^2>Gap) NV=cons(0,NV);
11190: }
11191: V=reverse(NV);
11192: }
11193: if(getopt(raw)==1) return V;
11194: OL=[["curve",1]];OLP=[];
11195: if(type(C=getopt(ratio))==1){
11196: OL=cons(["ratio",C],OL);OLP=cons(["ratio",C],OLP);
11197: }
1.4 ! takayama 11198: if(Acc==1) OL=cons(["Acc",1],OL);
1.3 takayama 11199: if(N1<0) OL=cons(["close",-1],OL);
11200: if(type(Opt=getopt(opt))!=7 && type(Opt)!=4){
1.4 ! takayama 11201: if(Opt==0) return xylines(V|option_list=cons(["opt",0],OL));
1.3 takayama 11202: }
11203: OL=cons(["opt",(Proc)?0:Opt],OL);
11204: if(type(Opt)>=0) OLP=cons(["opt",Opt],OLP);
11205: if(type(Vb=getopt(verb))==1||type(Vb)==4){
11206: OL=cons(["verb",Vb],OL);OLP=cons(["verb",Vb],OL);
11207: }
11208: if(Proc){
11209: S=(Proc==1)?
11210: [[0,[MulX*(LX[0]-Orgx),MulX*(LX[1]-Orgx)],[MulY*(LY[0]-Orgy),MulY*(LY[1]-Orgy)],
11211: (TikZ)?1:1/10]]:[];
11212: S=cons([1,OLP,xylines(V|option_list=OL)],S);
11213: if(Proc==3) return car(S);
11214: }else S=xylines(V|option_list=OL);
11215: if(type(Pt=getopt(pt))==4){
11216: if(type(Pt[0])!=4) Pt=[Pt];
11217: if(length(Pt)>1 && type(Pt[1])!=4) Pt=[Pt];
11218: for(PT=Pt;PT!=[];PT=cdr(PT)){
11219: PP=car(PT);
11220: if(type(PP[0])!=4) PP=[PP];
11221: P=car(PP);PP=cdr(PP);
11222: Qx=MulX*(P[0]-Orgx);Qy=MulY*(P[1]-Orgy);
11223: if(length(PP)>0 && type(PP[0])==4){ /* draw line */
11224: P=car(PP);
11225: Q1x=MulX*(P[0]-Orgx);Q1y=MulY*(P[1]-Orgy);
11226: if(length(PP)<1 || car(PP)==0 || iand(car(PP),1))
11227: OL=["opt",(TikZ)?"-":"@{-}"];
11228: else OL=["opt",(TikZ)?".":"@{.}"];
11229: if(Proc) S=cons([1,OL,[[Qx,Qy],[Q1x,Q1y]]],S);
11230: else S=S+xylines([[Qx,Qy],[Q1x,Q1y]]|optilon_list=OL);
11231: continue;
11232: }
11233: if(length(PP)==0 || type(car(PP))!=7) SS="$\\bullet$";
11234: else SS=car(PP);
11235: if(length(PP)<=1){
1.4 ! takayama 11236: if(Proc) S=cons([2,[],[Qx,Qy],[SS]],S);
1.3 takayama 11237: else S=S+xyput([Qx,Qy,SS]);
11238: }else{
1.4 ! takayama 11239: if(Proc) S=cons([2,[],[Qx,Qy],[[SS],"",PP[1]]],S);
1.3 takayama 11240: S=S+xyput([Qx,Qy,SS,"",PP[1]]);
11241: }
11242: }
11243: }
11244: if(type(Ax=getopt(ax))==4){ /* draw axis */
11245: Adx0=Ady0=0; Adx1=Ady1=0.1;
11246: if(!TikZ){
11247: if(!XYcm) Adx1=Ady1=1;
11248: LOp="@{-}"; LxOp="+!U"; LyOp="+!R";
11249: }else{
11250: LOp="-"; LxOp="below"; LyOp="left";
11251: }
11252: LOp0=LOp1=LOp;
11253: LxOO=(Ax[1]==LY[0])?LxOp:(TikZ)?"below left":"+!UR";
11254: if(type(AxOp=getopt(axopt))>0){
11255: if(type(AxOp)==1){
11256: if(AxOp>0) Adx1=Ady1=AxOp;
11257: else if(AxOp<0){
11258: Adx1=Ady1=0; Adx0=Ady0=AxOp;
11259: }
11260: }else if(type(AxOp)==4){
11261: if(type(T=car(AxOp))==4 && length(AxOp)>1){
11262: if(type(T)==7){
11263: LxOp=T; LyOp=AxOp[1];
11264: }else if(type(T)==4){
11265: Ay0=T[0]; Ay1=T[1]; Ax0=AxOp[1][0]; Ax1=AxOp[1][1];
11266: if(length(T)>2) LxOp=T[2];
11267: if(length(AxOp[1])>2) LyOp=AxOp[1][2];
11268: }
11269: }
11270: if(length(AxOp)>2 && type(AxOp[2])==7) LxOO=AxOp[2];
11271: if(length(AxOp)>3 && type(AxOp[3])==7) LOp0=AxOp[3];
11272: if(length(AxOp)>4 && type(AxOp[4])==7) LOp1=AxOp[4];
11273: }
11274: if(type(AxOp)==7) LOp0=AxOp;
11275: }
11276: if(Ax[0]>=LX[0] && Ax[0]<=LX[1]){ /* draw marks on x-axis */
11277: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp0]]:[],
11278: [MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],[MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]],S);
11279: else S=S+xyarrow([MulX*(Ax[0]-Orgx),MulY*(LY[0]-Orgy)],
11280: [MulX*(Ax[0]-Orgx),MulY*(LY[1]-Orgy)]|opt=LOp0);
11281: if(length(Ax)>2){
11282: D=Ax[2];
11283: if(type(D)==1 && D>0){
11284: I0=ceil((LX[0]-Ax[0])/D); I1=floor((LX[1]-Ax[0])/D);
11285: for(DD=[],I=I0; I<=I1; I++){
11286: if(length(Ax)<5) DD=cons(I*D,DD);
11287: else if(Ax[4]==0) DD=cons([I*D,I*D+Ax[0]],DD);
11288: else if(Ax[4]==1) DD=cons([I*D,I*D],DD);
11289: else if(Ax[4]==2) DD=cons([I*D,I],DD);
11290: }
11291: D=DD;
11292: }
11293: if(type(D)==4){
11294: for(;D!=[]; D=cdr(D)){
11295: T=car(D);
11296: if(type(T)==4) T=car(T);
11297: X=MulX*(T+Ax[0]-Orgx); Y=MulY*(Ax[1]-Orgy);
11298: if(T!=0){
11299: if(Proc) S=cons([3,(type(LOp1)>=0)?[["opt",LOp1]]:[],[X,Y+Ady0],[X,Y+Ady1]],S);
11300: else S=S+xyarrow([X,Y+Ady0],[X,Y+Ady1]|opt=LOp1);
11301: }
11302: if(type(car(D))==4){
11303: Arg=[(T==0)?LxOO:LxOp,D[0][1]];
1.4 ! takayama 11304: if(Proc) S=cons([2,[],[X,Y+Ady0],[Arg]],S);
1.3 takayama 11305: else S=S+xyput([X,Y+Ady0,Arg]);
11306: }
11307: }
11308: }
11309: }
11310: }
11311: if(Ax[1]>=LY[0] && Ax[1]<=LY[1]){ /* draw marks on y-axis */
11312: if(Proc) S=cons([3,[["opt",LOp0]],
11313: [MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
11314: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]],S);
11315: else S=S+xyarrow([MulX*(LX[0]-Orgx),MulY*(Ax[1]-Orgy)],
11316: [MulX*(LX[1]-Orgx),MulY*(Ax[1]-Orgy)]|opt=LOp0);
11317: if(length(Ax)>3){
11318: D=Ax[3];
11319: if(type(D)==1 && D>0){
11320: I0=ceil((LY[0]-Ax[1])/D); I1=floor((LY[1]-Ax[0])/D);
11321: for(DD=[],I=I0; I<=I1; I++){
11322: if(length(Ax)<5) DD=cons(I*D,DD);
11323: else if(I!=0){
11324: if(Ax[4]==0) DD=cons([I*D,I*D+Ax[1]],DD);
11325: if(Ax[4]==1) DD=cons([I*D,I*D],DD);
11326: if(Ax[4]==2) DD=cons([I*D,I],DD);
11327: }
11328: }
11329: D=DD;
11330: }
11331: if(type(D)==4){
11332: for(;type(D)==4&&D!=[]; D=cdr(D)){
11333: T=car(D);
11334: if(type(T)==4) T=car(T);
11335: X=MulX*(Ax[0]-Orgx); Y=MulY*(T+Ax[1]-Orgy);
11336: if(T!=0){
11337: if(Proc) S=cons([3,(type(LOp0)>=0)?[["opt",LOp1]]:[],
11338: [X+Adx0,Y],[X+Adx1,Y]],S);
11339: else S=S+xyarrow([X+Adx0,Y],[X+Adx1,Y]|opt=LOp1);
11340: }
11341: if(type(car(D))==4){
11342: if(Proc) S=cons([2,[],[X,Y+Ady0],[[LyOp,D[0][1]]]],S);
11343: else S=S+xyput([X,Y+Ady0,[LyOp,D[0][1]]]);
11344: }
11345: }
11346: }
11347: }
11348: }
11349: }
11350: if(Proc) return reverse(S);
11351: if(getopt(dviout)!=1) return S;
11352: xyproc(S|dviout=1);
11353: }
11354:
11355: def xyarrow(P,Q)
11356: {
11357: Cmd = ["fill","filldaw","shade","shadedraw","clip ","pattern","path ","node","coordinate"];
11358: if(type(P)<4) return "%\n";
11359: SS=getopt(opt);
11360: if(!TikZ){
11361: if(type(Q)<4) return "";
11362: S="{"+xypos(P)+" \\ar";
11363: if(type(SS)==7) S=S+SS;
11364: return S+" "+xypos(Q)+"};\n";
11365: }
11366: if(type(SS)==4 && length(SS)>1){
11367: if(length(SS)>2) SU=SS[2];
11368: ST=SS[1];
11369: SS=SS[0];
11370: }
11371: if(type(SS)!=7) SS="->";
11372: if(type(ST)!=7) ST=" -- ";
11373: if(type(SU)!=7) SU="";
11374: if(type(S=getopt(cmd))==7) S="\\"+S;
11375: else S="\\draw";
11376: if(type(Q)!=4){
11377: if(Q>0 && Q<=length(Cmd)) S="\\"+Cmd[Q-1]+"";
11378: if(SS!="-") S=S+"["+SS+"]";
11379: if(SU!="") SU="["+SU+"]";
11380: return S+xypos(P)+ST+SU+";\n";
11381: }
11382: if(SS!="-") S=S+"["+SS+"]";
11383: if(length(P)<3 && length(Q)<3)
11384: return S+xypos(P)+ST+xypos(Q)+SU+";\n";
11385: if(length(P)==2) P=[P[0],P[1],"","_0"];
11386: else if(length(P)==3 || (length(P)==4 && P[3]==""))
11387: P=[P[0],P[1],P[2],"_0"];
11388: else if(P[3]=="")
11389: P=[P[0],P[1],P[2],"_0",P[4]];
11390: if(length(Q)==2) Q=[Q[0],Q[1],"","_1"];
11391: else if(length(Q)==3 || (length(Q)==4 && Q[3]==""))
11392: Q=[Q[0],Q[1],Q[2],"_1"];
11393: else if(Q[3]=="")
11394: Q=[Q[0],Q[1],Q[2],"_1",Q[4]];
11395: return S+xypos(P)+" "+xypos(Q)+"("+P[3]+")"+ST+"("+Q[3]+")"+SU+";\n";
11396: }
11397:
11398: def polroots(L,V)
11399: {
11400: INIT=1;
11401: if(type(CF=getopt(comp))!=1) CF=0;
11402: OL=getopt();
11403: if(CF>32){
11404: CF-=64;
11405: INIT=0;
11406: }else OL=cons(["comp",CF+64],delopt(OL,"comp"));
11407: if(type(V)==4&&length(V)==1){
11408: L=L[0];V=V[0];
11409: }
11410: Lim=Lim2=[];
11411: if(type(L)<4){
11412: if(type(Lim=getopt(lim))==4){
11413: if(type(Lim[0])!=4) Lim=[Lim];
11414: Lim=delopt(Lim,V|inv=1);
11415: if(Lim!=[]){
11416: Lim=Lim[0];
11417: if(length(Lim)==3) Lim2=Lim[2];
11418: Lim=Lim[1];
11419: }
11420: }else{
11421: Lim=Lim2=[];
11422: }
1.4 ! takayama 11423: /* mycat([V,Lim,Lim2]); */
! 11424: if((CF==-2||CF==-1||CF==2)&&iscoef(L,os_md.israt)){ /* Rat+Comp, Rat+Real or Rat */
! 11425: S=(CF==-1)?getroot(L,V|cpx=1):getroot(L,V);
1.3 takayama 11426: for(RR=[],F=x;S!=[];S=cdr(S)){
11427: if(findin(V,vars(C=car(S)))<0){ /* Rational solution */
11428: if(type(C)<2){
11429: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
11430: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
11431: }
11432: if(F!=C) RR=cons(F=C,RR);
11433: }else if(CF<0){ /* Irrational solution */
1.4 ! takayama 11434: if((R=pari(roots,mysubst(C,[V,x])))!=0){
1.3 takayama 11435: for(R=vtol(R);R!=[];R=cdr(R))
1.4 ! takayama 11436: if((C=car(R))!=F && ntype(C)<CF+6){
1.3 takayama 11437: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
11438: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
11439: RR=cons(F=C,RR);
11440: }
11441: }
11442: }
11443: }
11444: return qsort(RR);
11445: }
11446: R=pari(roots,subst(L,V,x));
1.4 ! takayama 11447: if(R==0){
! 11448: R=[0];
! 11449: if(CF==1){
! 11450: for(R=[0],I=mydeg(L,V);I>1; I--)
! 11451: R=cons(0,R);
! 11452: }
! 11453: return R;
! 11454: }
1.3 takayama 11455: if(CF==1){ /* Complex */
11456: if(Lim==[]&&Lim2==[]) return vtol(R);
11457: for(L=[],I=length(R)-1;I>=0;I--){
11458: C=R[I];
11459: if(Lim!=[]&&(real(C)<Lim[0]||real(C)>Lim[1])) continue;
11460: if(Lim2!=[]&&(imag(C)<Lim2[0]||imag(C)>Lim2[1])) continue;
11461: L=cons(C,L);
11462: }
11463: return L;
11464: }
11465: for(L=[],F=x,I=length(R)-1;I>=0;I--){ /* Real */
11466: if(ntype(R[I])<4 && F!=R[I]){
11467: if(Lim!=[] && (R[I]<Lim[0]||R[I]>Lim[1])) continue;
11468: L=cons(F=R[I],L);
11469: }
11470: }
11471: return qsort(L);
11472: }
11473: if(SS==0&&INIT==1){
11474: SS=polroots(L,V|option_list=OL);
11475: if(SS!=0) return SS;
11476: for(C=0;SS==0&&C<4;C++){
11477: I=(C==0)?1:(iand(random(),0xff)-0x80);
11478: for(LL=[],K=length(L)-1;K>=0;K--){
11479: for(Q=0,J=length(L)-1;J>=0;J--)
11480: Q+=L[J]*(I+K)^J;
11481: LL=cons(Q,LL);
11482: }
11483: SS=polroots(LL,V|option_list=OL);
11484: if(SS!=0) return SS;
11485: }
11486: return SS;
11487: }
11488: C=2^(-32);
11489: if(type(getopt(err))==1) C=err;
11490: if((N=length(V))!=length(L)) return [];
11491: if(N==1) return polroots(L[0],V[0]|option_list=OL);
11492: for(L1=[],I=1;I<N;I++){
11493: Res=res(V[0],L[I-1],L[I]);
11494: if(type(Res)<2) return Res;
11495: L1=cons(res(V[0],L[I-1],L[I]),L1);
11496: }
11497: R=polroots(L1,V1=cdr(V)|option_list=OL);
11498: if(type(R)<2) return R;
11499: for(SS=[];R!=[];R=cdr(R)){
11500: RS=(N==2)?[car(R)]:car(R);
1.4 ! takayama 11501: for(I=0,L0=L[0];I<N-1;I++) L0=mysubst(L0,[V1[I],RS[I]]);
1.3 takayama 11502: S0=polroots(L0,V[0]|option_list=OL);
11503: if(type(S0)<2) return S0;
11504: for(S=S0;S!=[];S=cdr(S)){
11505: S0=cons(car(S),RS);
11506: for(LT=cdr(L);LT!=[];LT=cdr(LT)){
1.4 ! takayama 11507: for(I=0,TV=car(LT);I<N;I++) TV=mysubst(TV,[V[I],S0[I]]);
1.3 takayama 11508: if(abs(TV)>C) break;
11509: }
11510: if(LT==[]) SS=cons(S0,SS);
11511: }
11512: }
11513: return reverse(SS);
11514: }
11515:
11516: def ptcommon(X,Y)
11517: {
11518: if(length(X)!=2 || length(Y)!=2) return 0;
11519: if(type(X[1])==4){ /* X is a line */
11520: if((In=getopt(in))==-1||In==-2||In==-3){
11521: X0=(X[0][0]+X[1][0])/2;X1=(X[0][1]+X[1][1])/2;
11522: X=[[X0,X1],[X0+X[1][1]-X[0][1],X1-X[1][0]+X[0][0]]];
11523: if(In==-1&&type(Y[1])==4) return ptcommon(Y,X|in=-2);
11524: /* for the second line */
11525: if(In==-3) In=1;
11526: else In=0;
11527: }else if(In==2||In==3){
11528: X=(X[1][0]-X[0][0])+(X[1][1]-X[0][1])*@i;
11529: if(X==0) return 0;
11530: Y=(Y[1][0]-Y[0][0])+(Y[1][1]-Y[0][1])*@i;
11531: X=myarg(Y/X);
11532: return (In==2)?X:(X*180/deval(@pi));
11533: }else if(In!=1) In=0;
1.4 ! takayama 11534: if(type(Y[0])<=3){
1.3 takayama 11535: if(In==1){
11536: return [(Y[1]*X[0][0]+Y[0]*X[1][0])/(Y[0]+Y[1]),
11537: (Y[1]*X[0][1]+Y[0]*X[1][1])/(Y[0]+Y[1])];
11538: }
11539: XX=X[1][0]-X[0][0];YY=X[1][1]-X[0][1];
11540: Arg=(length(Y)<2)?0:Y[1];
11541: Arg=deval(Arg);
11542: if(Arg!=0){
11543: S=dcos(Arg)*XX-dsin(Arg)*YY;
11544: YY=dsin(Arg)*XX+dcos(Arg)*YY;
11545: XX=S;
11546: }
11547: S=dnorm([XX,YY]);
11548: if(S!=0){
11549: XX*=Y[0]/S;YY*=Y[0]/S;
11550: }
11551: return [X[1][0]+XX,X[1][1]+YY];
11552: }
11553: S=[X[0][0]+(X[1][0]-X[0][0])*x_,X[0][1]+(X[1][1]-X[0][1])*x_];
11554: if(type(Y[1])==4){ /* Y is a line */
11555: T=[Y[0][0]+(Y[1][0]-Y[0][0])*y_-S[0],
11556: Y[0][1]+(Y[1][1]-Y[0][1])*y_-S[1]];
11557: R=lsol(T,[x_,y_]);
11558: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
11559: if(!In || (R[0][1]>=0&&R[0][1]<=1&&R[1][1]>=0&&R[1][1]<=1) )
11560: return subst(S,x_,R[0][1],y_,R[1][1]);
11561: }
11562: if((type(R[0])>0&&type(R[0])<4)||(type(R[1])>0&&type(R[1])<4)) return 0;
11563: if(!In) return 1;
11564: I=(X[0][0]==X[1][0]&&Y[0][0]==Y[1][0]&&X[0][0]==Y[0][0])?1:0;
11565: if(X[0][I]<=X[1][I]){
11566: X0=X[0][I];X1=X[1][I];
11567: }else{
11568: X1=X[0][I];X0=X[1][I];
11569: }
11570: return ((Y[0][I]<X0 && Y[1][I]<X0)||(Y[0][I]>X1&&Y[1][I]>X1))?0:1;
11571: }else if(Y[1]==0){ /* orth */
11572: T=[Y[0][0]+(X[1][1]-X[0][1])*y_-S[0],
11573: Y[0][1]-(X[1][0]-X[0][0])*y_-S[1]];
11574: R=lsol(T,[x_,y_]);
11575: if(type(R[0])==4&&type(R[1])==4&&R[0][0]==x_&&R[1][0]==y_){
11576: if(!In||(R[0][1]>=0&&R[0][1]<=1))
11577: return subst(S,x_,R[0][1],y_,R[1][1]);
11578: }
11579: return (X[0]==X[1])?0:1;
11580: }else if(type(Y[1])==1 && Y[1]>0){ /* circle */
11581: T=(S[0]-Y[0][0])^2+(S[1]-Y[0][1])^2-Y[1]^2;
11582: D=mycoef(T,1,x_)^2-4*mycoef(T,0,x_)*mycoef(T,2,x_);
11583: if(D==0){
11584: V=mycoef(T,1,x_)/(2*mycoef(T,2,x_));
11585: if(!in||(V>=0&&V<=1)) return [subst(S,x_,V)];
11586: }
11587: else if((type(D)==1&&D>0)){
11588: D=dsqrt(D);
11589: V=-(mycoef(T,1,x_)+D)/(2*mycoef(T,2,x_));
11590: if(!In||(V>=0&&V<=1)) L=[subst(S,x_,V)];
11591: else L=[];
11592: V=(D-mycoef(T,1,x_))/(2*mycoef(T,2,x_));
11593: if(!In||(V>=0&&V<=1)) L=cons(subst(S,x_,V),L);
11594: if(length(L)>0) return L;
11595: }
11596: }
11597: return 0;
11598: }
11599: if(type(Y[1])==4 || X[1]==0) return ptcommon(Y,X);
11600: /* X is a circle */
11601: if(Y[1]==0){ /* tangent line */
11602: if(Y[0][0]==X[0][0]+X[1] || Y[0][0]==X[0][0]-X[1]) L=[[Y[0][0],X[0][1]]];
11603: else L=[];
11604: P=(Y[0][0]+x_-X[0][0])^2+(Y[0][1]+x_*y_-X[0][1])^2-X[1]^2;
11605: Q=mycoef(P,1,x_)^2-4*mycoef(P,2,x_)*mycoef(P,0,x_);
11606: for(R=polroots(Q,y_);R!=[];R=cdr(R)){
11607: X0=-subst(mycoef(P,1,x_)/(2*mycoef(P,2,x_)),y_,car(R));
11608: L=cons([Y[0][0]+X0,Y[0][1]+car(R)*X0],L);
11609: }
11610: }else{ /* Y is a circle */
11611: P=(x_-X[0][0])^2+(y_-X[0][1])^2-X[1]^2;
11612: Q=(x_-Y[0][0])^2+(y_-Y[0][1])^2-Y[1]^2;
11613: V=(X[0][0]!=Y[0][0])?[x_,y_]:[y_,x_];
11614: R=subst(P,V[0],T=lsol(P-Q,V[0]));
11615: if(type(T[0])<4) return (T[0]==0)?1:0;
11616: S=polroots(R,V[1]);
11617: for(L=[];S!=[];S=cdr(S)){
11618: R=subst(T,V[1],car(S));
11619: if(V[0]==x_) L=cons([R,car(S)],L);
11620: else L=cons([S,R],L);
11621: }
11622: }
11623: if(length(L)!=0) return L;
11624: return 0;
11625: }
11626:
11627: def tobezier(L)
11628: {
11629: if((Div=getopt(div))==1||Div==2){
11630: if(length(L)!=4) return [tobezier(L|inv=[0,1/2]),tobezier(L|inv=[1/2,1])];
11631: if(type(L)==4) L=ltov(L);
11632: if(type(L[0])==4)
11633: L=[ltov(L[0]),ltov(L[1]),ltov(L[2]),ltov(L[3])];
11634: S=[(L[0]+3*L[1]+3*L[2]+L[3])/8];
11635: T=[L[3]];
11636: S=cons((L[0]+2*L[1]+L[2])/4,S);
11637: T=cons((L[2]+L[3])/2,T);
11638: S=cons((L[0]+L[1])/2,S);
11639: T=cons((L[1]+2*L[2]+L[3])/4,T);
11640: S=cons(L[0],S);
11641: T=cons((L[0]+3*L[1]+3*L[2]+L[3])/8,T);
11642: return [S,T];
11643: }
11644: if(Div>2&&Div<257){
11645: L=tobezier(L);
11646: for(R=[],I=Div-1;I>=0;I--)
11647: R=cons(tobezier(L|inv=[I/Div,(I+1)/Div]),R);
11648: return R;
11649: }
11650: if((V=getopt(inv))==1 || type(V)>3){
11651: if(type(L[0])>3 && type(V)>3) L=tobezier(L);
11652: if(type(V)>3 && length(V)>2) V2=V[2];
11653: if(type(V2)!=2) V2=t;
11654: if(type(V)>3) L=subst(L,V2,(V[1]-V[0])*V2+V[0]);
11655: N=mydeg(L,V2);
11656: for(R=[],I=0;I<=N;I++){
11657: RT=mycoef(L,I,V2);
11658: R=cons(RT/binom(N,I),R);
11659: L-=RT*V2^I*(1-V2)^(N-I);
11660: }
11661: return reverse(R);
11662: };
11663: N=length(L)-1;
11664: V=newvect(2);
11665: for(I=0;I<=N;I++,L=cdr(L)){
11666: if(type(X=car(L))==4) X=ltov(X);
11667: V+=X*binom(N,I)*t^I*(1-t)^(N-I);
11668: }
11669: return V;
11670: }
11671:
1.4 ! takayama 11672: def cutf(F,X,VV)
! 11673: {
! 11674: if(type(car(V=VV))==2){
! 11675: Y=[car(V),X];
! 11676: V=cdr(V);
! 11677: }else Y=X;
! 11678: if(type(X)>1){
! 11679: Y=(type(Y)==4)?Y[0]:x;
! 11680: V1=makenewv(F);
! 11681: if(X==Y||Y==x){
! 11682: V2=makenewv([F,V1]);
! 11683: F=mysubst(F,[Y,V2]);
! 11684: V=cons(V2,V);
! 11685: }
! 11686: return [V1,[V1,os_md.cutf,[F],X,[V]]];
! 11687: }
! 11688: if(car(V)!=[] && X<car(V)[0]) return myfeval(car(V)[1],Y);
! 11689: for(V=cdr(V); ;V=R){
! 11690: if((R=cdr(V))==[]){
! 11691: if(car(V)!=[] && car(V)[0]<X) return myfeval(car(V)[1],Y);
! 11692: return myfeval(F,Y);
! 11693: }
! 11694: if(X>car(V)[0]) continue;
! 11695: if(X==car(V)[0]) return car(V)[1];
! 11696: return myfeval(F,Y);
! 11697: }
! 11698: }
! 11699:
! 11700: def fsum(F,L,X)
! 11701: {
! 11702: if(type(L[0])==2){
! 11703: X=L[0];
! 11704: L=cdr(L);
! 11705: }else X=0;
! 11706: V=(length(L)>2)?L[2]:1;
! 11707: for(R=0,I=L[0];;I+=V){
! 11708: if(V==0||(I-L[1])*V>0) return R;
! 11709: R+=os_md.myfeval(F,X?[X,I]:I);
! 11710: }
! 11711: }
! 11712:
! 11713: def periodicf(F,L,X)
! 11714: {
! 11715: if(type(L)==4) L=[eval(L[0]),eval(L[1])];
! 11716: else L=eval(L);
! 11717: if(isvar(X)){
! 11718: Y=makenewv([X,V]);
! 11719: if(type(F)==5) return [Y,[Y,os_md.periodicf,[F],L,X]];
! 11720: Z=makenewv([X,Y,V]);
! 11721: return [Z,[Z,os_md.periodicf,[mysubst(F,[x,Y])],[L],[[Y,X]]]];
! 11722: }
! 11723: X=eval(X);
! 11724: if(type(F)==5)
! 11725: return myfeval(F[floor(X/L)%length(F)],X-floor(X/L)*L);
! 11726: if(type(L)==4){
! 11727: if(type(X)==4){
! 11728: V=X[0];
! 11729: X=X[1];
! 11730: }else V=x;
! 11731: X-=floor((X-L[0])/(L[1]-L[0]))*(L[1]-L[0]);
! 11732: return myfeval(F,[V,X]);
! 11733: }
! 11734: }
! 11735:
! 11736: def cmpf(X)
! 11737: {
! 11738: if(type(X)>3){
! 11739: if(type(L)==7) return [S_Fc,Dx,S_Ic,S_Ec,S_EC,S_Lc];
! 11740: S_Lc=0;
! 11741: if(type(S_Fc=X[0])!=4) S_Fc=f2df(S_Fc);
! 11742: S_Ic=X[1];
! 11743: if(length(S_Ic)>2){
! 11744: S_Fc=mysubst(S_Fc,[S_Ic[0],x]);
! 11745: S_Ic=cdr(S_Ic);
! 11746: }
! 11747: S_Dc=(type(S_Ic[0])==7)?1:0;
! 11748: if(type(S_Ic[1])==7) S_Dc=ior(S_Dc,2);
! 11749: if(type(S_Ec=getopt(exp))!=1) S_Ec=0;
! 11750: if(S_Ec<=0){
! 11751: S_EC=-S_Ec;
! 11752: if(S_EC==0) S_EC=1;
! 11753: if(S_Dc==3) S_EC*=2;
! 11754: else S_EC/=4;
! 11755: if(type(F=X[0])==3&&vars(F)==[x]&&(D=deg(nm(F),x))==deg(dn(F),x)-2){
! 11756: S_Lc=S_EC*coef(nm(F),D,x)/coef(dn(F),D+2,x);
! 11757: }
! 11758: }else{
! 11759: S_EC=S_Ec;
! 11760: if(S_Dc==3) S_EC*=12;
! 11761: else S_EC/=6;
! 11762: }
! 11763: if(type(S_Fc)==3) S_Fc=red(S_Fc);
! 11764: S_EC=1/S_EC;
! 11765: return [z_,[z_,os_md.cmpf,x]];
! 11766: }
! 11767: if(X<=0 && iand(S_Dc,1)) return S_Lc;
! 11768: if(X>=1 && iand(S_Dc,2)) return S_Lc;
! 11769: if(S_Dc==3){
! 11770: if(S_Ec>0){
! 11771: Y0=dexp(1/X)*S_EC;
! 11772: Y1=dexp(1/(1-X))*S_EC;
! 11773: return myfeval(S_Fc,Y1-Y0)*(Y0/X^2+Y1/(1-X)^2);
! 11774: }
! 11775: return myfeval(S_Fc,S_EC/(1-X)-S_EC/X)*(S_EC/(1-X)^2+S_EC/X^2);
! 11776: }
! 11777: if(S_Dc==1){
! 11778: if(S_Ec>0){
! 11779: Y=dexp(1-1/X);
! 11780: R=myfeval(S_Fc,S_EC*(Y-1)+I[1])*Y;
! 11781: }
! 11782: else R=myfeval(S_Fc,I[1]+(1-1/X)*S_EC);
! 11783: return R*S_EC/X^2;
! 11784: }
! 11785: if(S_Dc==2){
! 11786: if(S_Ec>0){
! 11787: Y=dexp(X/(1-X));
! 11788: R=myfeval(S_Fc,S_EC*(Y-1)+S_Ic[0])*Y;
! 11789: }else R=myfeval(S_Fc,S_EC*X/(1-X)+S_Ic[0]);
! 11790: return R*S_EC/(1-X)^2;
! 11791: }
! 11792: X=S_Ic[0]+(S_Ic[1]-S_Ic[0])*X;
! 11793: return myfeval(S_Fc,X)/(S_Ic[1]-Ic[0]);
! 11794: }
! 11795:
! 11796: def fresidue(P,Q)
! 11797: {
! 11798: if(iscoef(Q,os_md.israt)) S=fctr(Q);
! 11799: else S=[[Q,1]];
! 11800: for(R=[];S!=[];S=cdr(S)){
! 11801: T=car(S);
! 11802: if((D=mydeg(T[0],z))==0) continue;
! 11803: L=[];
! 11804: if(iscoef(T[0],os_md.iscrat)) L=getroot(T[0],z|cpx=2);
! 11805: if(findin(z,vars(L))>=0) L=[];
! 11806: if(L==[]) L=polroots(T[0],z|comp=-1);
! 11807: for(;L!=[];L=cdr(L)){
! 11808: QQ=Q;
! 11809: for(I=T[1]; I>1;I--) QQ=mydiff(QQ,z);
! 11810: for(U=0,W=I=T[1];I>0;I--,W++){
! 11811: QQ=diff(QQ,z);
! 11812: U+=subst(QQ,z,L[0])*(z-L[0])^(W-T[1])/fac(W);
! 11813: }
! 11814: UD=mydiff(U,z);
! 11815: for(I=T[1],K=1,PP=P; I>1;I--,K++)
! 11816: PP=diff(PP,z)*U-K*PP*UD;
! 11817: QQ=subst(PP,z,L[0])/subst(U,z,L[0])^K;
! 11818: /* if(D==2) QQ=sqrt2rat(QQ); */
! 11819: R=cons([L[0],sqrt2rat(QQ)],R);
! 11820: }
! 11821: }
! 11822: if(type(L=getopt(cond))==4){
! 11823: for(S=[];R!=[];R=cdr(R)){
! 11824: Z=car(R);
! 11825: for(LL=L;LL!=[];LL=cdr(LL)){
! 11826: X=real(car(Z));Y=imag(car(Z));
! 11827: if(myf3eval(car(LL),X,Y,car(Z))<=0) break;
! 11828: }
! 11829: if(LL==[]) S=cons(Z,S);
! 11830: }
! 11831: R=reverse(S);
! 11832: }
! 11833: if((Sum=getopt(sum))==1||Sum==2){
! 11834: for(S=0;R!=[];R=cdr(R)) S+=car(R)[1];
! 11835: if(Sum==2) S*=2*@pi*@i;
! 11836: return sqrt2rat(S);
! 11837: }
! 11838: return R;
! 11839: }
! 11840:
! 11841: def fint(F,D,V)
! 11842: {
! 11843: if(((L=length(V))==2 || (L==3&&isvar(V[0])<3))
! 11844: && (type(V[L-1])==7||(type(V[L-1])<3&&type(eval(V[L-1]))<2)))
! 11845: /* real integral */
! 11846: return areabezier([F,D,V]|option_list=getopt());
! 11847: /* complex integral */
! 11848: if(L>1&&type(V[1])==4&&type(V[1][1])<4){
! 11849: if(type(V[0])==4&&type(V[0][0])<2){
! 11850: for(R=[],VT=car(V),VV=cdr(V);VV!=[];VV=cdr(VV),VT=VU){
! 11851: if((VU=car(VV))==-1) VU=car(V);
! 11852: R=cons([ptcommon([VT,VU],[t,1-t]|in=1),[0,1]],R);
! 11853: }
! 11854: V=reverse(R);
! 11855: }
! 11856: else if(L==2) V=[V];
! 11857: }
! 11858: Opt=cons(["cpx",1],getopt());
! 11859: for(R=0;V!=[];V=cdr(V)){
! 11860: VT=car(V);
! 11861: X=car(VT)[0];XD=red(diff(X,t));
! 11862: Y=car(VT)[1];YD=red(diff(Y,t));
! 11863: F=mysubst(F,[[x,X],[y,Y],[z,X+@i*Y]]);
! 11864: if(type(F)==4)
! 11865: FF=cons(F[0]*(XD+@i*YD),cdr(F));
! 11866: else FF=red(F*(XD+@i*YD));
! 11867: R+=areabezier([FF,D,cons(t,VT[1])]|option_list=Opt);
! 11868: }
! 11869: return R;
! 11870: }
! 11871:
! 11872: def areabezier(V)
! 11873: {
! 11874: if(getopt(cpx)==1){
! 11875: Opt=delopt(getopt(),"cpx");
! 11876: F=V[0];
! 11877: if(!isvar(Var=V[2][0])) Var=x;
! 11878: if(type(F)==3 && vars(F)==[Var] && imag(dn(F))!=0){
! 11879: F=(nm(F)*conj(dn(F)))/(dn(F)*conj(dn(F)));
! 11880: V0=red(real(nm(F))/dn(F));
! 11881: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
! 11882: V0=red(imag(nm(F))/dn(F));
! 11883: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
! 11884: }
! 11885: if(getopt(Acc)!=1) F=f2df(F);
! 11886: V0=compdf([o,[o,real,o_]],o_,F);
! 11887: R=areabezier([V0,V[1],V[2]]|option_list=Opt);
! 11888: V0=compdf([o,[o,imag,o_]],o_,F);
! 11889: return R+@i*areabezier([V0,V[1],V[2]]|option_list=Opt);
! 11890: }
! 11891: if(type(V[0])!=4 || vars(V[0][0])!=0){
! 11892: Mx=[-2.0^(512),2.0^(512)];
! 11893: I=length(V[2]);
! 11894: if(type(V[2][I-1])==7||type(V[2][I-2])==7){ /* infinite interval */
! 11895: if(type(Ec=getopt(exp))==1) R=cmpf([V[0],V[2]]|exp=Ec);
! 11896: else R=cmpf([V[0],V[2]]);
! 11897: V=[R,V[1],[0,1]];
! 11898: }
! 11899: if(type((Int=getopt(int)))==1 && type(V[0])<4 && (V1=V[1])>=0){
! 11900: if(Int==2&&iand(V1,1)) V1++;
! 11901: if(!V1) V1=32;
! 11902: Opt=cons(["raw",1],getopt());
! 11903: W=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
! 11904: SS=W[0][1];
! 11905: for(S0=S1=0,I=0,L=W;L!=[] && I<=V1;I++, L=cdr(L)){
! 11906: if(iand(I,1)) S1+=car(L)[1];
! 11907: else S0+=car(L)[1];
! 11908: if (I==V1) SS+=car(L)[1];
! 11909: }
! 11910: VV=deval(V[2][1]-V[2][0]);
! 11911: if(Int==2)
! 11912: return (2*S0+4*S1-SS)*VV/(3*V1);
! 11913: else
! 11914: return (2*S0+2*S1-SS)*VV/(2*V1);
! 11915: }
! 11916: Opt=cons(["opt",0],getopt());
! 11917: V=xygraph(V[0],V[1],V[2],Mx,Mx|option_list=Opt);
! 11918: }
! 11919: if(type(V[0][0])!=4) V=os_md.lbezier(V);
! 11920: for(S=0; V!=[]; V=cdr(V)){
! 11921: B=tobezier(car(V));
! 11922: P=intpoly(B[1]*diff(B[0],t),t);
! 11923: S+=mysubst(P,[t,1]);
! 11924: }
! 11925: return S;
! 11926: }
! 11927:
1.3 takayama 11928: def velbezier(V,L)
11929: {
11930: if(L==0) L=[t,0,1];
11931: else L=[(length(L)==3)?L[2]:t,L[0],L[1]];
11932: for(R=[],II=length(V)-1;II>=0;II--){
11933: S=fmmx(diff(V[II],L[0]|dif=1),L|dif=1);
11934: for(U=0;S!=[];S=cdr(S)) if((T=abs(car(S)[1]))>U) U=T;
11935: R=cons(U,R);
11936: }
11937: return R;
11938: }
11939:
1.4 ! takayama 11940: def ptbezier(V,L)
! 11941: {
! 11942: if(type(V[0])==4&&type(V[0][0])!=4) V=lbezier(V);
! 11943: K=length(V);
! 11944: if(type(L)<2){
! 11945: if(L<0) return K;
! 11946: if(L>=K-1) L=[K-1,1];
! 11947: else{
! 11948: L0=floor(L);
! 11949: if(L0>=K-1) L0=K-1;
! 11950: L=[L0,L-L0];
! 11951: }
! 11952: }
! 11953: if(L[0]>=0) B=V[L[0]];
! 11954: else B=V[K+L[0]];
! 11955: B=tobezier(B);
! 11956: BB=[diff(B[0],t),diff(B[1],t)];
! 11957: return [subst(B,t,L[1]),subst(BB,t,L[1])];
! 11958: }
! 11959:
1.3 takayama 11960: def ptcombezier(P,Q,T)
11961: {
11962: if(type(T)<2){
11963: if(T<2) T=20; /* default */
11964: return ptcombezier(P,Q,[0,0,1,T]);
11965: }
11966: V=T[2]/2;;
11967: /* mycat(["IN",P,Q,T]); */
11968: PB=tobezier(P|div=1);
11969: PP=[ptbbox(PB[0]),ptbbox(PB[1])];
11970: QB=tobezier(Q|div=1);
11971: QQ=[ptbbox(QB[0]),ptbbox(QB[1])];
11972: for(L=[],I=0;I<2;I++){
11973: for(J=0;J<2;J++){
11974: /* mycat([I,J,PP[I],QQ[J]]); */
11975: if(!iscombox(PP[I],QQ[J])) continue;
11976: if(T[3]<=1) return
11977: [[T[0]+(I+0.5)*V,T[1]+(J+0.5)*V,
11978: [(PP[I][0][0]+PP[I][0][1])/2,(PP[I][1][0]+PP[I][1][1])/2]]];
11979: else{
11980: #if 0
11981: U=PB[I][0];V=PB[I][length(PB[I])-1];
11982: if(abs(A=(U[0]-V[0]))>abs(B=(U[1]-V[I])))
11983: M=mat([1,0],[-B/A,1]);
11984: else if(U!=V)
11985: M=mat([1,-A/B],[0,1]);
11986: else continue;
11987: if(!iscombox(ptbox(ptaffine(M,PB[I])),ptbox(ptaffine(M,QB[J])))) continue;
11988: #endif
11989:
11990: LN=ptcombezier(PB[I],QB[J],[T[0]+I*V,T[1]+J*V,V,T[3]-1]);
11991: #if 0
11992: L=append(LN,L);
11993: #else
11994: if(LN!=[]){
11995: if(L==[]) L=LN;
11996: else for(VV=3*V/2^T[3];LN!=[];LN=cdr(LN)){
11997: for(LT=L;LT!=[];LT=cdr(LT)){
11998: if(abs(car(LN)[0]-car(LT)[0])<VV&&abs(car(LN)[1]-car(LT)[1])<VV) break;
11999: }
12000: }
12001: }
12002: if(length(L)>32){ /* Too many points */
12003: I=J=2;
12004: }
12005: #endif
12006: }
12007: }
12008: }
12009: return L;
12010: }
12011:
12012:
12013: def ptcombz(P,Q,T)
12014: {
12015: if(P==Q) Q=0;
12016: if(type(P[0][0])!=4) P=P0=lbezier(P);
12017: if(Q==0){
12018: Q=P;F=1;
12019: }
12020: else if(type(Q[0][0])!=4) Q=lbezier(Q);
12021: for(R=[],I=0,Q0=Q;P!=[];P=cdr(P),I++){
12022: for(J=0,Q=Q0;Q!=[];Q=cdr(Q),J++){
12023: if(F==1&&I<J+2) break;
12024: if((RT=ptcombezier(car(P),car(Q),T))!=[]){
12025: RT=cons([I,J],RT);
12026: R=cons(RT,R);
12027: }
1.1 takayama 12028: }
12029: }
1.3 takayama 12030: if((Red=getopt(red))==1||Red==2){
12031: if(type(M=getopt(prec))!=1) M=12;
12032: for(F=0,T=P0;T!=[];T=cdr(T)){
12033: for(S=car(T);S!=[];S=cdr(S)){
12034: if(type(ST=car(S))==4 && type(ST[0])<2){
12035: if(F++==0){
12036: X0=X1=ST[0];Y0=Y1=ST[1];
12037: }else{
12038: if(ST[0]<X0) X0=ST[0];
12039: if(ST[0]>X1) X1=ST[0];
12040: if(ST[1]<Y0) Y0=ST[1];
12041: if(ST[1]>Y1) Y1=ST[1];
12042: }
12043: }
12044: }
1.1 takayama 12045: }
1.3 takayama 12046: V0=(X1-X0)/2^M;V1=(Y1-Y2)/2^M;
12047: for(RR=[],RT=R;RT!=[];RT=cdr(RT))
12048: for(S=cdr(car(RT));S!=[];S=cdr(S)) RR=cons(car(S)[2],RR);
12049: RR=ltov(RR);L=length(RR);
12050: for(I=0;I<L;I++)
12051: for(K=1,J=I+1;K!=0&&J<L;J++)
12052: if(abs(RR[I][0]-RR[J][0])<V0 && abs(RR[I][1]-RR[J][1])<V1) RR[I]=K=0;
12053: R0=[];
12054: I=L-1;
12055: if(Red==2){
12056: for(;I>=0;I--) if(RR[I]!=0) R0=cons(RR[I],R0);
1.1 takayama 12057: }else{
1.3 takayama 12058: for(RT=R;RT!=[];RT=cdr(RT)){
12059: R00=[car(RT)[0]];
12060: for(S=cdr(car(RT));S!=[];S=cdr(S),I--)
12061: if(RR[L-I-1]!=0) R00=cons(car(S),R00);
12062: if(length(R00)>1) R0=cons(reverse(R00),R0);
1.1 takayama 12063: }
12064: }
1.3 takayama 12065: return R0;
1.1 takayama 12066: }
1.3 takayama 12067: return reverse(R);
1.1 takayama 12068: }
12069:
1.3 takayama 12070: def draw_bezier(ID,IDX,B)
1.1 takayama 12071: {
1.3 takayama 12072: if(getopt(init)==1){
1.4 ! takayama 12073: S_FDot=0;
1.3 takayama 12074: return;
1.1 takayama 12075: }
1.3 takayama 12076: if(type(Col=getopt(col))!=1&&Col!=0) Col=0;
12077: Dot=0;
12078: if(type(Opt=getopt(opt))==7){
12079: if(!Col){
12080: Col=drawopt(Opt,0);
12081: if(Col==-1) Col=0;
12082: }
12083: T=drawopt(Opt,3);
12084: if(iand(T,2)){
12085: M=iand(T,1)?1/8:1/4;
12086: for(C=Col,Col=I=0;I<20;I+=8)
12087: Col+=ishift(0xff-(floor((0xff-iand(0xff,ishift(C,I)))*M)),-I);
12088: }
12089: if(iand(T,4)) Dot=2; /* 2 or 3 or 4 or 6 */
12090: else if(iand(T,8)) Dot=4;
12091: }
1.4 ! takayama 12092: if(type(B)==4 && (type(B[0])==4||type(B[0])==5) && type(B[0][0])<2) B=lbezier(B);
! 12093: else if(type(B)==5) B=[vtol(B)];
1.3 takayama 12094: for(;B!=[];B=cdr(B)){
12095: if(vars(F=car(B))==[]){
1.4 ! takayama 12096: #if 1
1.3 takayama 12097: if(length(F)<3&&!Dot){ /* line or point */
12098: if(length(F)>0){
12099: G=[rint(F[0][0]),rint(F[0][1])];
12100: if(length(F)==1) draw_obj(ID,IDX,G,Col);
12101: else{
12102: G=[G[0],G[1],rint(F[1][0]),rint(F[1][1])];
12103: draw_obj(ID,IDX,G,Col);
12104: }
12105: }
12106: continue;
12107: }
1.4 ! takayama 12108: #endif
! 12109: if(length(F)<2) continue;
1.3 takayama 12110: F=tobezier(F);
12111: }
12112: N=velbezier(F,0);
12113: N=(N[0]>N[1])?N[0]:N[1];
1.4 ! takayama 12114: if(!N) N=1;
! 12115: for(I=0;I<=N;I++,S_FDot++){
! 12116: if(Dot!=iand(S_FDot,Dot)) continue;
1.3 takayama 12117: G=subst(F,t,I/N);
12118: G=[rint(G[0]),rint(G[1])];
12119: if(G!=G0){
12120: draw_obj(ID,IDX,G,Col);
12121: G0=G;
12122: }
1.1 takayama 12123: }
12124: }
1.4 ! takayama 12125: if(S_FDot-->=2^32) S_FDot=0;
1.3 takayama 12126: return 0;
12127: }
12128:
12129: def lbezier(L)
12130: {
12131: if((In=getopt(inv))==1||In==2||In==3){
12132: for(F=0,R=[];L!=[];L=cdr(L)){
12133: LT=car(L);
12134: if(F==car(LT)) R=cons(1,R);
12135: else{
12136: if(R!=[]&&F!=0) R=cons(0,R);
12137: R=cons(G=car(LT),R);
12138: if(In==3) In==2;
12139: }
12140: for(LT=cdr(LT);LT!=[];LT=cdr(LT))
12141: R=cons(car(LT),R);
12142: if((F=car(R))==G&&In==1){
12143: R=cons(-1,cdr(R));
12144: F=0;
12145: }
1.1 takayama 12146: }
1.3 takayama 12147: if(In==3 && car(R)==G) R=cons(-1,cdr(R));
12148: return reverse(R);
1.1 takayama 12149: }
1.3 takayama 12150: for(F=0,RT=R=[];L!=[];L=cdr(L)){
1.4 ! takayama 12151: if(type(T=car(L))==4||type(T)==5){
1.3 takayama 12152: if(F==0){
12153: FT=T;F=1;
1.1 takayama 12154: }
1.3 takayama 12155: RT=cons(T,RT);
12156: }else if(T==0){
12157: if(RT==[]) R=cons(reverse(RT),R);
12158: RT=[];F=0;
12159: }else if(T==1){
12160: if(RT!=[]){
12161: R=cons(reverse(RT),R);
12162: RT=[car(RT)];
12163: }else{
12164: RT=[];F=0;
1.1 takayama 12165: }
1.3 takayama 12166: }else if(T==-1){
12167: RT=cons(FT,RT);
12168: R=cons(reverse(RT),R);
12169: RT=[];F=0;
1.1 takayama 12170: }
12171: }
1.3 takayama 12172: if(RT!=[]) R=cons(reverse(RT),R);
12173: return reverse(R);
12174: }
12175:
12176:
12177: def xybezier(L)
12178: {
12179: if(L==0 || (LS=length(L))==0) return "";
12180: Out=str_tb(0,0);
12181: if(type(VF=getopt(verb))==4){
12182: if(type(car(VF))>3){
12183: VFS=VF;VF=1;
12184: }else{
12185: VFS=cdr(VF);VF=car(VF);
12186: }
12187: }else VFS=["$\\bullet$","$\\times$"];
12188: if(VF!=1 && VF!=2) VF=0;
12189: if(!TikZ){
12190: if(VF) Ob=str_tb(0,0);
12191: T="\n**\\crv{";
12192: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+Opt;
12193: L00=Q=L[I0=0];S=S1="";
12194: for(F=0,I=1;I<=LS;I++){
12195: P=Q;Q=(I==LS)?0:L[I];
12196: if(type(Q)==4){
12197: if(F==0){
12198: S1="";L0=P;F=1;
12199: continue;
12200: }else if(F==1)
12201: F=2;
12202: else if(F==2){
12203: S1=S1+"&";
1.1 takayama 12204: }
1.3 takayama 12205: S1=S1+xypos(P);
12206: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
12207: }else{
12208: if(Q==0){
12209: if(F>0){
12210: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
12211: if(VF){
12212: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
12213: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
12214: }
12215: F=0;
1.1 takayama 12216: }
1.3 takayama 12217: }else if(Q==1){
12218: str_tb("{"+xypos(L0)+";"+xypos(P)+T+S1+"}};\n",Out);
12219: if(VF){
12220: str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
12221: if(VF==1) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
1.1 takayama 12222: }
1.3 takayama 12223: F=1;
12224: }else if(Q==-1){
12225: if(F==2)
12226: S1=S1+"&";
12227: str_tb("{"+xypos(L0)+";"+xypos(L00)+T+S1+xypos(P)+"}};\n",Out);
12228: if(VF) str_tb(xyput([L[0][0],L[0][1],VFS[0]]),Ob);
12229: F=0;
12230: }
12231: if(F==1){
12232: if(I<LS-1 && type(L[I+1])<2){
12233: if(L[I+1]==-1){
12234: str_tb("{"+xypos(P)+";"+xypos(L00)+T+"}};\n",Out);
12235: }
12236: if(VF) str_tb(xyput([P[0][0],P[0][1],VFS[0]]),Ob);
12237: F=0;
1.1 takayama 12238: }
12239: }
1.3 takayama 12240: while(++I<LS && type(L[I])<2);
12241: if(I>=LS) break;
12242: if(F==1){
12243: Q=P;I--;F=0;
12244: }else L00=Q=L[I];
1.1 takayama 12245: }
12246: }
1.3 takayama 12247: }else{
12248: if(type(T=getopt(cmd))==7){
12249: if(T!="") T="\\"+T;
12250: }else T="\\draw";
12251: if((Rel=getopt(relative))==1) VF=0;
12252: if(VF) Ob=str_tb(0,0);
12253: if(type(Opt=getopt(opt))==7 && Opt!="") T=T+"["+Opt+"]";
12254: Out=str_tb(T,0);
12255: Q=L[0];
12256: for(F=M=0,I=1;I<=LS;I++){
12257: P=Q; Q=(I==LS)?0:L[I];
12258: if(++M>XYLim){
12259: str_tb("\n",Out);M=1;
12260: }
12261: if(type(Q)==4 || type(Q)==5 || type(Q)==7){
12262: if(F==0){
12263: str_tb(" ",Out);
12264: F=1;
12265: }else if(F==1){
12266: str_tb(" .. controls ",Out);
12267: F=2;
12268: }else if(F==2){
12269: str_tb(" and ",Out);
12270: F=2;
12271: }
12272: PP=xypos(P);
12273: if(Rel==1 && F==2) PP="+"+PP;
12274: str_tb(PP,Out);
12275: if(VF&&((F<2)||length(VFS)>1))
12276: str_tb(xyput([P[0],P[1],(F<2)?VFS[0]:VFS[1]]),Ob);
12277: }else{
12278: /* if(I<LS-1) VF=0; */
12279: if(Q==0||Q==1){
12280: PP=xypos(P);
12281: if(Rel==1) PP="+"+PP;
12282: str_tb(((F==0)?" ":((F==1)?" -- ":" .. "))+PP,Out);
12283: if(VF) str_tb(xyput([P[0],P[1],VFS[0]]),Ob);
12284: F=Q;
12285: }else if(Q==-1){
12286: PP=xypos(P);
12287: if(Rel==1) PP="+"+PP;
12288: if(F==1)
12289: str_tb("..controls "+PP+" .. cycle",Out);
12290: else if(F==2)
12291: str_tb(" and "+PP+" .. cycle",Out);
12292: if(VF&&length(VFS)>1) str_tb(xyput([P[0],P[1],VFS[1]]),Ob);
12293: F=0;
12294: }
12295: if(F==1){
12296: if(I<LS-1){
12297: if(L[I+1]==-1){
12298: str_tb(" -- cycle",Out);
12299: I=I+1;
12300: F=0;
12301: }
12302: else if(type(L[I+1])<2) F=0;
1.1 takayama 12303: }
12304: }
1.3 takayama 12305: while(++I<LS && type(L[I])<2);
12306: if(I>=LS) break;
12307: Q=L[I];
1.1 takayama 12308: }
12309: }
1.3 takayama 12310: str_tb(";\n",Out);
1.1 takayama 12311: }
1.3 takayama 12312: if(VF) str_tb(str_tb(0,Ob),Out);
12313: return str_tb(0,Out);
1.1 takayama 12314: }
12315:
12316: def xybox(L)
12317: {
12318: K=length(L);
12319: P=L[0];Q=L[1];
12320: if(K==2)
12321: LL=[ P, [P[0],Q[1]], Q, [Q[0],P[1]] ];
12322: else{
12323: R=L[2];
12324: LL=[ P, R, Q, [P[0]+Q[0]-R[0],P[1]+Q[1]-R[1]] ];
12325: }
1.4 ! takayama 12326: Opt=getopt();
1.1 takayama 12327: SS=getopt(opt);
1.4 ! takayama 12328: if(type(SS)!=7&&!TikZ) Opt=cons(["opt","@{-}"],Opt);
! 12329: Opt=cons(["close",1],Opt);
! 12330: return xylines(LL|option_list=Opt);
1.1 takayama 12331: }
12332:
1.3 takayama 12333: def xyang(S,P,Q,R)
12334: {
12335: Opt=getopt();
12336: if(type(Prec=getopt(prec))!=1) Prec=0;
12337: if(type(Q)>2){
12338: if(R==1||R==-1){ /* 直角 */
12339: P1=ptcommon([Q,P],[-S,0]);
12340: S*=R;
12341: P2=ptcommon([P,P1],[S,@pi/2]);
12342: P3=ptcommon([P1,P2],[S,@pi/2]);
12343: return xylines([P1,P2,P3]|option_list=Opt);
12344: }else if((AR=abs(R))==0||AR==2||AR==3||AR==4){ /* 矢印 */
12345: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
12346: if(R<0) Ang+=3.14159;
12347: ANG=[0.7854,0.5236,1.0472];
12348: X=(AR==0)?1.5708:ANG[AR-2];
12349: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
12350: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)]; /* 矢先 */
12351: V=(X==0)?[U,V]:[U,P,V];
12352: if(getopt(ar)==1) V=append([Q,P,0],V); /* 心棒 */
12353: return xylines(V|option_list=Opt);
1.4 ! takayama 12354: }else if(AR>4&&AR<9){
! 12355: Ang=myarg([Q[0]-P[0],Q[1]-P[1]]);
! 12356: ANG=[0.7854,0.5236,0.3927,0.2618];
! 12357: X=ANG[AR-5];
! 12358: U=[P[0]+S*dcos(Ang+X),P[1]+S*dsin(Ang+X)];
! 12359: V=[P[0]+S*dcos(Ang-X),P[1]+S*dsin(Ang-X)];
! 12360: W=ptcommon([P,U],[P,Q]|in=-2);
! 12361: W1=[(U[0]+P[0]+W[0])/3,(U[1]+P[1]+W[1])/3];
! 12362: W2=[(V[0]+P[0]+W[0])/3,(V[1]+P[1]+W[1])/3];
! 12363: L=[U,W1,P,1,W2,V];
! 12364: if(getopt(ar)==1) L=append([Q,P,0],L);
! 12365: if(type(Sc=getopt(scale))>0){
! 12366: if(type(Sc)==1) Sc=[Sc,Sc];
! 12367: L=ptaffine(diagm(2,Sc),L);
! 12368: }
! 12369: Opt=getopt(opt);
! 12370: if(type(Opt)>0) OL=[["opt",Opt]];
! 12371: else OL=[];
! 12372: if(getopt(proc)==1) return append([2,OL],L);
! 12373: S=xybezier(L|optilon_list=OL);
! 12374: if(getopt(dviout)!=1) return S;
! 12375: dviout(S);
! 12376: return 1;
1.3 takayama 12377: }
12378: }
12379: if(type(Q)<3){
12380: X=deval(Q); Y=deval(R);
12381: }else{
12382: X=myarg([Q[0]-P[0],Q[1]-P[1]]);
12383: Y=myarg([R[0]-P[0],R[1]-P[1]]);
12384: }
12385: if(Prec>2) N=8;
12386: else if(Prec==2) N=6;
12387: else if(Prec==1) N=4;
12388: else N=3;
12389: U=deval(@pi)*2/N;
12390: if(X==Y||Y-X>6.28318){
12391: for(L=[],I=N-1;I>=0;I--) L=cons([P[0]+S*dcos(I*U),P[1]+S*dsin(I*U)],L);
12392: return xylines(L|option_list=append([["curve",1],["close",1]],Opt));
12393: }
12394: for(M=1;(Y-X)/M>U;M++);
12395: for(L=[],I=M+1;I>-2;I--){
12396: Ang=X+(Y-X)*I/M;
12397: L=cons([P[0]+S*dcos(Ang),P[1]+S*dsin(Ang)],L);
12398: }
12399: if(getopt(ar)!=1) return xylines(L|option_list=append([["curve",1],["close",-1]],Opt));
12400: OL=delopt(Opt,["dviout","opt","proc"]);
12401: S=xylines(L|option_list=append([["curve",1],["close",-1],["opt",0]],OL));
12402: T=xylines([P,L[1]]|option_list=cons(["opt",0],OL));
12403: S=ptaffine("close",[S,T]); /* connect curves */
12404: if(getopt(opt)==0) return S;
12405: OL=(type(SS=getopt(opt))>1)?[["opt",SS]]:[];
12406: if(type(T=getopt(proc))==1 && T>=1 && T<=3) return [1,OL,S];
12407: if(OL==[]) S=xybezier(S);
12408: else S=(type(SS)==7)? xybezier(S|opt=SS):xybezier(S|opt=SS[0],cmd=SS[1]);
12409: if(getopt(dviout)==1) return xyproc(S|dviout=1);
12410: return S;
12411: }
12412:
12413: def xyoval(P,L,R)
12414: {
12415: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
12416: if(length(Arg)>2)
12417: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180,@pi*Arg[2]/180];
12418: else
12419: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
12420: }
12421: if(type(Arg)==4){
12422: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
12423: if(length(Arg)>2) Arg2=deval(Arg[2]);
12424: if(Arg1<Arg0 || Arg0<-7) return 0;
12425: }
12426: if(type(Prec=getopt(prec))!=0) Prec=0;
12427: if((Ar=getopt(ar))!=1) Ar=0;
12428: L=xyang(L,[0,0],Arg0,Arg1|prec=Prec,opt=0,ar=Ar);
12429: Sc=getopt(scale);
12430: if(type(Sc=getopt(scale))<1) Sc=[1,1];
12431: else if(type(Sc)==1) Sc=[Sc,Sc];
12432: M=mat([1,0],[0,R]);
12433: L=ptaffine(M,L|shift=P);
12434: M=mat([Sc[0],0],[0,Sc[1]]);
12435: L=ptaffine(M,L|arg=Arg2);
12436: if((Opt=getopt(opt))==0) return L;
1.4 ! takayama 12437: Opt=(type(Opt)>1)? [["opt2",Opt]]:[];
1.3 takayama 12438: if(getopt(proc)==1) return [1,Opt,L];
12439: S=xybezier(L|option_list=getopt());
12440: if(getopt(dviout)==1){
12441: xyproc(S|dviout=1);
12442: return 1;
12443: }
12444: return S;
12445: }
12446:
1.1 takayama 12447: def xycirc(P,R)
12448: {
12449: ST=getopt(opt);
1.3 takayama 12450: if(type(ST)<0) ST="";
1.1 takayama 12451: if(type(Arg=getopt(arg))!=4 && type(Arg=getopt(deg))==4){
12452: Arg=[@pi*Arg[0]/180,@pi*Arg[1]/180];
12453: }
1.3 takayama 12454: /* Is it OK?
12455: if(TikZ==0 && XYcm==1){
12456: R*=10; P=[P[0]*10,P[1]*10];
12457: }
12458: */
12459: if(type(Arg)==4){
1.1 takayama 12460: Arg0=deval(Arg[0]); Arg1=deval(Arg[1]);
12461: if(Arg1<=Arg0 || Arg0<-7 || Arg1-Arg0>7) return 0;
12462: if(type(ST)==7)
1.3 takayama 12463: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
1.1 takayama 12464: [P[1]-R-1,P[1]+R+1]|opt=ST);
12465: else
12466: S=xygraph([R*cos(x)+P[0],R*sin(x)+P[1]],-4,[Arg0,Arg1],[P[0]-R-1,P[0]+R+1],
12467: [P[1]-R-1,P[1]+R+1]);
12468: if(getopt(close)==1){
12469: S=S+xyline([0,0],
12470: [deval(subst(R*cos(x)+P[0],x,Arg0)),deval(subst(R*sin(x)+P[0],x,Arg0))]);
12471: S=S+xyline([0,0],
12472: [deval(subst(R*cos(x)+P[0],x,Arg1)),deval(subst(R*sin(x)+P[0],x,Arg1))]);
12473: }
12474: return S;
12475: }
1.3 takayama 12476: if(TikZ){
12477: SP="";
12478: if(length(P)>2) SP=P[2];
12479: if(type(SP)!=7) SP="$"+my_tex_form(SP)+"$";
12480: if(R==0){
12481: if(ST!="") ST=ST+",";
12482: return "\\node ["+ST+"circle,draw]"+xypos([P[0],P[1]])+ "{"+SP+"};\n";
12483: }
12484: if(type(R)!=7) R=rtostr((R+0.1)-0.1);
12485: if(ST!="") ST="["+ST+"]";
12486: S="\\draw "+ST+xypos([P[0],P[1]])+" circle [radius="+R+"]";
12487: if(SP!="") S=S+" node at"+xypos([P[0],P[1]])+" {"+SP+"}";
12488: return S+";\n";
12489: }
1.1 takayama 12490: S="{"+xypos([P[0],P[1]]);
12491: if(length(P)>2){
12492: SP=P[2];
12493: if(type(P)!=7) SP=my_tex_form(SP);
12494: S=S+" *+{"+SP+"}";
12495: }
12496: S =S+" *\\cir";
12497: if(R!=0){
12498: R=(R+0.1)-0.1;
1.3 takayama 12499: S=S+"<"+rtostr(R)+((XYcm)?"cm>":"mm>");
1.1 takayama 12500: }
12501: S = S+"{";
12502: if(type(ST)==7) S=S+ST;
12503: return S+"}};\n";
12504: }
12505:
12506: def ptaffine(M,L)
12507: {
1.4 ! takayama 12508: if(type(L)!=4&&type(L)!=5){
1.3 takayama 12509: erno(0);return L;
12510: }
1.4 ! takayama 12511: if(type(M)==7){ /* connect lists */
1.3 takayama 12512: if(M=="reverse"){
12513: for(LO=LR=[],F=0,LT=L; LT!=[]; LT=cdr(LT)){
12514: if(type(P=car(LT))==4 || type(P)==7){
12515: LR=cons(P,LR);
12516: continue;
12517: }else{
12518: if(P==-1){
12519: LL=reverse(LR);
12520: LO=append(reverse(cons(-1,cdr(LL))),LO);
12521: LO=cons(car(LL),LO);
12522: LR=[];
12523: }else if(P==1){
12524: LR=cons(car(LR),cons(1,cdr(LR)));
12525: }else if(P==0 || length(LT)==1){
12526: if(LO!=[] && car(LO)!=0 && (type(car(LO))==4 || car(LO)==1))
12527: LO=cons(0,LO);
12528: LO=append(LR,LO);
12529: if(length(LT)>1&&length(LO)>0&&car(LO)!=0) LO=cons(0,LO);
12530: LR=[];
12531: }
12532: }
12533: }
12534: return append(LR,LO);
12535: }
12536: if(type(L[0][0])!=4) L=[L];
12537: LO=[];
12538: if(M=="connect" || M=="close" || M=="loop"){
12539: Top=car(car(L));
12540: for(K=1,LL=L; LL!=[]; LL=cdr(LL)){
12541: for(F=0,LT=car(LL); LT!=[]; LT=cdr(LT),F++){
12542: if((LTT=car(LT))==0) LTT=1;
12543: if(F==0 && LO!=[]){
12544: LO0=car(LO);
12545: if(car(LO)!=1&&length(LO)>1) LO=cons(1,LO);
12546: if(LTT==LO0) continue;
12547: else LO=cons(1,cons(LTT, LO));
12548: }else LO=cons(LTT, LO);
12549: }
12550: }
12551: if(M!="connect"){
12552: if(Top==car(LO) || car(LO)==1 || M=="loop")
12553: LO=cons(-1,cdr(LO));
12554: else
12555: LO=cons(-1,cons(1,LO));
12556: }
12557: return reverse(LO);
12558: }
12559: if(M=="union"){
12560: for(LL=reverse(L); LL!=[]; LL=cdr(LL)){
12561: if(LO!=[]) LO=cons(0,LO);
12562: LO=append(car(LL),LO);
12563: }
12564: L=LO;
12565: }
12566: return L;
12567: }
1.1 takayama 12568: if(type(Arg=getopt(deg))==1)
12569: Arg=@pi*Arg/180;
12570: else Arg=getopt(arg);
12571: if(type(Arg)==2) Arg=deval(Arg);
12572: if(type(Arg)==1)
12573: M=M*mat([dcos(Arg),-dsin(Arg)],[dsin(Arg),dcos(Arg)]);
12574: if(type(Sft=getopt(org))==4){
12575: Sft=ltov(Sft);
12576: Sft-=M*Sft;
1.3 takayama 12577: }else Sft=ltov([0,0]);
1.1 takayama 12578: if(type(V=getopt(shift))==4)
12579: Sft+=ltov(V);
1.3 takayama 12580: if(getopt(proc)==1){
12581: if(Sft!=0&<ov(Sft)!=[0,0]) Sft=[["shift",vtol(Sft)]];
12582: else Sft=[];
12583: for(LO=[],LT=L;LT!=[];LT=cdr(LT)){
12584: if(type(car(T=car(LT)))<2){
1.4 ! takayama 12585: if((P=car(T))==0){ /* exedraw 0 */
1.3 takayama 12586: 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]]];
12587: V=ptbbox(ptaffine(M,V|option_list=Sft));
12588: L1=cdr(cdr(cdr(T)));
12589: LO=cons(append([0,V[0],V[1]],L1),LO);
12590: continue;
1.4 ! takayama 12591: }else if(P==1){ /* exedraw 1 */
1.3 takayama 12592: L1=[];
12593: for(TT=cdr(cdr(T));TT!=[];TT=cdr(TT)){
12594: D=car(TT);
12595: if(type(D[0][0])==4){
12596: for(L2=[],DT=D;DT!=[];DT=cdr(DT))
12597: L2=cons(ptaffine(M,car(DT)|option_list=Sft),L2);
12598: L1=cons(reverse(L2),L1);
12599: }else L1=cons(ptaffine(M,D|option_list=Sft),L1);
12600: }
12601: LO=cons(append([1,T[1]],reverse(L1)),LO);
12602: continue;
12603: }else if(P>=2 && P<=5){
12604: L1=ptaffine(M,cdr(cdr(T))|optilon_list=Sft);
12605: LO=cons(append([P,T[1]],L1),LO);
12606: continue;
12607: }
12608: }
12609: LO=cons(T,LO);
12610: }
12611: return reverse(LO);
12612: }
1.4 ! takayama 12613: F=0;
! 12614: if(type(L)==4){
! 12615: for(LT=L; LT!=[]; LT=cdr(LT)){
! 12616: if((T=type(car(LT)))==4||T==5){
! 12617: F=1; break;
! 12618: }
1.1 takayama 12619: }
12620: }
12621: if(F==0) return (Sft==0)?ptaffine(M,[L])[0]:ptaffine(M,[L]|shift=vtol(Sft))[0];
12622: for(LO=[],LT=L; LT!=[]; LT=cdr(LT)){
1.3 takayama 12623: if(((T=type(P=car(LT)))!=4 && T!=5)||type(P[0])>3) LO=cons(P,LO);
12624: else{
12625: if(T==4) P=ltov(P);
12626: V=M*P;
1.1 takayama 12627: if(Sft!=0) V+=Sft;
1.3 takayama 12628: if(T==4) V=vtol(V);
12629: LO=cons(V,LO);
1.1 takayama 12630: }
12631: }
12632: return reverse(LO);
12633: }
12634:
12635: def ptlattice(M,N,X,Y)
12636: {
12637: if(type(S=getopt(scale))!=1) S=1;
12638: if(type(Cond=getopt(cond))!=4) Cond=[];
12639: Line=getopt(line);
12640: if(Line==1 || Line==2) F=newmat(M,N);
12641: else Line=0;
12642: if(type(Org=getopt(org))==4) Org=ltov(Org);
12643: else Org=newvect(length(X));
12644: X=ltov(X); Y=ltov(Y);
12645: for(L=[],I=M-1;I>=0;I--){
12646: for(P0=P1=0,J=N-1;J>=0;J--){
12647: P=Org+I*X+J*Y;
12648: for(C=Cond; C!=[]; C=cdr(C))
1.4 ! takayama 12649: if(subst(car(C),x,P[0],y,P[1])<0) break;
! 12650: if(C!=[]) continue;
1.1 takayama 12651: if(Line) F[I][J]=1;
12652: else L=cons(vtol(S*P),L);
12653: }
12654: }
12655: if(Line==0) return L;
12656: for(I=M-1;I>=0;I--){
12657: for(T0=0,T1=J=N-1;J>=0;J--){
12658: if((K=F[I][J])!=0){
12659: if(T0==0) T0=J;
12660: else T1=J;
12661: }
12662: if(K==0 || T1==0){
12663: if(T1<T0){
12664: L=cons(vtol(S*(Org+I*X+T0*Y)), L);
12665: L=cons(vtol(S*(Org+I*X+T1*Y)), L);
12666: L=cons(0,L);
12667: }
12668: T0=0; T1=N-1;
12669: }
12670: }
12671: }
12672: for(J=N-1;J>=0;J--){
12673: for(T0=0,T1=I=M-1;I>=0;I--){
12674: if((K=F[I][J])!=0){
12675: if(T0==0) T0=I;
12676: else T1=I;
12677: }
12678: if(K==0 || T1==0){
12679: if(T1<T0){
12680: L=cons(vtol(S*(Org+T0*X+J*Y)), L);
12681: L=cons(vtol(S*(Org+T1*X+J*Y)), L);
12682: L=cons(0,L);
12683: }
12684: T0=0; T1=M-1;
12685: }
12686: }
12687: }
12688: return cdr(L);
12689: }
12690:
12691: def ptpolygon(N,R)
12692: {
12693: if(type(S=getopt(scale))!=1) S=1;
12694: if(type(Org=getopt(org))!=4) Org=[0,0];
1.3 takayama 12695: Pi=deval(@pi);
1.1 takayama 12696: if(type(Arg=getopt(deg))==1)
1.3 takayama 12697: Arg=Pi*Arg/180;
1.1 takayama 12698: else Arg=getopt(arg);
12699: if(type(Arg)==2) Arg=deval(Arg);
12700: if(type(Arg)!=1) Arg=0;
12701: Arg -= Pi*(1/2+1/N);
12702: D=Pi*2/N;
12703: for(L=[],I=N-1; I>=0; I--)
12704: L=cons([S*(Org[0]+R*dcos(Arg+I*D)),S*(Org[1]+R*dsin(Arg+I*D))],L);
12705: return L;
12706: }
12707:
12708: def ptwindow(L,X,Y)
12709: {
12710: if(type(S=getopt(scale))==1){
12711: X=[S*X[0],S*X[1]]; Y=[S*Y[0],S*Y[1]];
12712: }
12713: for(R=[],LT=L;LT!=[];LT=cdr(LT)){
12714: P=car(LT);
12715: if(P[0]<X[0] || P[0]>X[1] || P[1]<Y[0] || P[1]>Y[1])
12716: R=cons(0,R);
12717: else R=cons(P,R);
12718: }
12719: return reverse(R);
12720: }
12721:
1.3 takayama 12722: def lninbox(L,W)
12723: {
12724: if(L[0]==L[1]) return 0;
12725: R=newvect(2);C=newvect(2);
12726: for(J=0;J<2;J++){
12727: C[J]=L[1][J]-L[0][J];
12728: if(C[J]!=0){
12729: R[J]=[(W[J][0]-L[0][J])/C[J],(W[J][1]-L[0][J])/C[J]];
12730: if(R[J][0]>R[J][1]) R[J]=[R[J][1],R[J][0]];
12731: }
12732: }
12733: if(R[0]==0) R[0]=R[1];
12734: if(R[1]==0) R[1]=R[0];
12735: S0=(R[0][0]<R[1][0])?R[1][0]:R[0][0];
12736: S1=(R[0][1]<R[1][1])?R[0][1]:R[1][1];
12737: if(getopt(in)==1){
12738: if(S0<0) S0=0;
12739: if(S1>1) S1=1;
12740: }
12741: if(S0>S1) return 0;
12742: 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]];
12743: }
12744:
12745: def ptbbox(L)
12746: {
12747: J=length(L[0]);
12748: if((Box=getopt(box))==1){
12749: for(R=[],I=0;I<J;I++){
12750: P=car(LT=L)[I][0];Q=car(LT)[I][1];
12751: for(;LT!=[];LT=cdr(LT)){
1.4 ! takayama 12752: if((type(T=car(LT))==4 || type(T)==5) && length(T)==J){
1.3 takayama 12753: if(T[I][0]<P) P=T[I][0];
12754: if(T[I][1]>Q) Q=T[I][1];
12755: }
12756: }
12757: R=cons([P,Q],R);
12758: }
12759: }else if(type(Box)==4) return ptbbox([ptbbox(L),Box]|box=1);
12760: else{
12761: for(R=[],I=0;I<J;I++){
12762: P=Q=car(LT=L)[I];LT=cdr(LT);
12763: for(;LT!=[];LT=cdr(LT)){
1.4 ! takayama 12764: if((type(T=car(LT))==4||type(T)==5) && type(T[0])<2 && length(T)==J){
1.3 takayama 12765: if((V=T[I])<P) P=V;
12766: else if(V>Q) Q=V;
12767: }
12768: }
12769: R=cons([P,Q],R);
12770: }
12771: }
12772: return reverse(R);
12773: }
12774:
12775: def iscombox(S,T)
12776: {
12777: for(;S!=[];S=cdr(S),T=cdr(T))
12778: if(car(S)[0]>car(T)[1] || car(S)[1]<car(T)[0]) return 0;
12779: return 1;
12780: }
1.1 takayama 12781:
12782: def ptcopy(L,V)
12783: {
12784: if(type(V[0])!=4) V=[V];
12785: for(F=0,LL=[]; V!=[]; V=cdr(V)){
12786: if(F) LL=append(LL,[0]);
12787: F++;
12788: LL=append(LL,ptaffine(1,L|shift=car(V)));
12789: }
12790: }
12791:
12792: def average(L)
12793: {
12794: L=os_md.m2l(L|flat=1);
12795: M0=M1=car(L);
12796: for(I=SS=0, LT=L; LT!=[]; LT=cdr(LT), I++){
12797: S+=(V=car(LT));
12798: SS+=V^2;
12799: if(V<M0) M0=V;
12800: else if(V>M1) M1=V;
12801: }
12802: SS=dsqrt(SS/I-S^2/I^2);
12803: S=((S+0.1)-0.1)/I;
12804: return [S,SS,I,M0,M1];
12805: }
12806:
12807: def m2ll(M)
12808: {
12809: for(R=[],I=size(M)[0]-1; I>=0; I--)
12810: R=cons(vtol(M[I]),R);
12811: return R;
12812: }
12813:
12814: def madjust(M,W)
12815: {
12816: if(type(Null=getopt(null))<0) Null=0;
12817: if(type(M)==4 && type(M[0])==4){
12818: M=lv2m(M|null=Null);
12819: return m2ll(madjust(M,W|null=Null));
12820: }
12821: S=size(M);
12822: if(W<0){
12823: W=-W;
12824: T0=ceil(S[0]/W);
12825: T1=S[1]*W;
12826: N=newmat(T0,T1);
12827: for(I=0; I<T0; I++){
12828: for(K=0; K<W; K++){
12829: II=K*T0+I;
12830: for(J=0; J<S[1]; J++)
12831: N[I][S[1]*K+J]=(II<S[0])?M[II][J]:Null;
12832: }
12833: }
12834: }else{
12835: T1=W;
12836: T0=S[0]*(D=ceil(S[1]/T1));
12837: N=newmat(T0,T1);
12838: for(K=0; K<D; K++){
12839: for(J=0; J<W;J++){
12840: JJ=W*K+J;
12841: for(I=0; I<S[0]; I++)
12842: N[S[0]*K+I][J]=(JJ<S[1])?M[I][JJ]:Null;
12843: }
12844: }
12845: }
12846: return N;
12847: }
12848:
1.3 takayama 12849: def texcr(N)
12850: {
12851: if(!isint(N) || N<0 || N>31) return N;
12852: S=(iand(N,8))? "\\allowdisplaybreaks":"";
12853: if(iand(N,2)) S=S+"\\\\";
12854: if(iand(N,16)) S=S+"\\pause";
12855: if(iand(N,1)) S=S+"\n";
12856: if(iand(N,4)) S=S+"& ";
12857: else if(!iand(N,1)) S=S+" ";
12858: return S;
12859: }
12860:
1.1 takayama 12861: def ltotex(L)
12862: {
12863: /* extern TeXLim; */
12864:
12865: if(type(L)==5)
12866: L = vtol(L);
12867: if(type(L) != 4)
12868: return my_tex_form(L);
12869: Opt=getopt(opt);
12870: Pre=getopt(pre);
1.3 takayama 12871: if(type(Var=getopt(var))<1) Var=0;
12872: Cr2="\n";
12873: if(type(Cr=getopt(cr))==4){
12874: Cr2=Cr[1];Cr=Cr[0];
12875: }
12876: if(isint(Cr)) Cr=texcr(Cr);
12877: if(type(Cr)!=7) Cr="\\\\\n & "; /* Cr=7 */
12878: if(type(Opt)==7) Opt=[Opt];
1.1 takayama 12879: if(type(Opt)!=4)
12880: Op = -1;
12881: else{
12882: Op=findin(Opt[0],["spt","GRS","Pfaff","Fuchs","vect","cr","text","spts","spts0",
1.3 takayama 12883: "dform","tab", "graph","coord"]);
1.1 takayama 12884: Opt=cdr(Opt);
12885: }
12886: if(Op==0){ /* spt */
12887: Out = str_tb("\\left\\{\n ",0);
12888: for(CC=0; L!=[]; L=cdr(L), CC++){
12889: if(CC>0) str_tb(",\\, ",Out);
12890: TP=car(L);
12891: if(Op!=0)
12892: str_tb(my_tex_form(TP),Out);
12893: else if(TP[0]==1)
12894: str_tb(my_tex_form(TP[1]),Out);
12895: else
12896: str_tb(["[", my_tex_form(TP[1]), "]_", rtotex(TP[0])],Out);
12897: }
12898: str_tb("%\n\\right\\}\n",Out);
12899: }else if(Op==1){ /* GRS */
12900: Out = string_to_tb("\\begin{Bmatrix}\n");
12901: if(type(Pre)==7) str_tb(Pre,Out);
12902: MC=length(M=ltov(L));
12903: for(ML=0, I=length(M); --I>=0; ){
12904: if(length(M[I]) > ML) ML=length(M[I]);
12905: }
12906: for(I=0; I<ML; I++){
12907: for(CC=J=0; J<MC; J++, CC++){
12908: if(length(M[J]) <= I){
12909: if(CC > 0) str_tb(" & ",Out);
12910: }else if(M[J][I][0] <= 1){
12911: if(M[J][I][0] == 0) str_tb(" & ",Out);
12912: else
12913: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
12914: }else
12915: str_tb([((!CC)?" [":" & ["), my_tex_form(M[J][I][1]), "]_",
12916: rtotex(M[J][I][0])], Out);
12917: }
12918: str_tb((I<ML-1)?"\\\\\n":"\n", Out);
12919: }
12920: str_tb("\\end{Bmatrix}",Out);
12921: }else if(Op==2){ /* Pfaff */
12922: V=monototex(Opt[0]);
12923: Out = string_to_tb("d"+V+"= \\Biggl(");
12924: Opt=cdr(Opt);
12925: II=length(Opt);
12926: for(I=0; I<II; I++){
12927: str_tb([(I>0)?" + ":" ",mtotex(L[I]),"\\frac{d",monototex(Opt[I]),"}{",
12928: my_tex_form(Opt[I]),(I==II-1)?"}\n":"}\n\\\\&\n"],Out);
12929: }
12930: str_tb(["\\Biggr)",V,"\n"],Out);
12931: }else if(Op==3){ /* Fuchs */
12932: Out = string_to_tb("\\frac{d");
12933: V=my_tex_form(Opt[0]);
12934: str_tb([V,"}{d",my_tex_form(Opt[1]),"}="] ,Out);
12935: Opt=cdr(Opt); Opt=cdr(Opt);
12936: II=length(Opt);
12937: for(I=0; I<II; I++){
12938: str_tb([(I>0)?" +":"\\Biggl(", " \\frac{",
12939: my_tex_form(L[I]),"}{", my_tex_form(Opt[I]),"}\n"],Out);
12940: }
12941: str_tb(["\\Biggr)",V,"\n"],Out);
12942: }else if(Op==4){ /* vect */
1.3 takayama 12943: Out=str_tb(mtotex(matc(L)|lim=0,var=Var),0);
1.1 takayama 12944: }else if(Op==5 || Op==6){ /* cr or text */
12945: Out = str_tb(0,0);
1.4 ! takayama 12946: if(type(Lim=getopt(lim))!=1) Lim=0;
! 12947: else if(Lim<30&&Lim>0) Lim=TeXLim;
1.1 takayama 12948: Str=getopt(str);
12949: if(length(Opt)==1 && (car(Opt)=="spts" || car(Opt)=="spts0") && type(Str)!=1)
12950: Str=2;
1.4 ! takayama 12951: for(K=I=0; L!=[]; I++, L=cdr(L)){
1.1 takayama 12952: LT=car(L);
1.4 ! takayama 12953: if((!Lim||Op==6)&&I>0) str_tb((Op==5)?Cr:"\n",Out);
1.1 takayama 12954: if(Op==6){
1.3 takayama 12955: if(type(LT)==7){
1.1 takayama 12956: str_tb([LT," "],Out);
12957: I=-1;
12958: continue;
12959: }
12960: str_tb("$",Out);
12961: }
1.4 ! takayama 12962: KK=0;
! 12963: if(Str>0 && type(LT)==4 && Opt!=[])
! 12964: S=ltotex(LT|opt=car(Opt),lim=0,str=Str,cr=Cr2,var=Var);
! 12965: else if(type(LT)==6){
! 12966: if(Lim>0){
! 12967: S=mtotex(LT|var=Var,lim=0,len=1);
! 12968: KK=S[1];
! 12969: S=S[0];
! 12970: }else S=mtotex(LT|var=Var,lim=0);
! 12971: }else if(type(LT)==3 || type(LT)==2)
! 12972: S=fctrtos(LT|TeX=2,lim=0,var=Var);
! 12973: else S=my_tex_form(LT);
! 12974: if(Op!=6&&I>0&&Lim){
! 12975: if(Lim<0){
! 12976: if(I%(-Lim)==0)
! 12977: str_tb((Op==5)?Cr:"\n",Out);
! 12978: }else if((K+=(KK=(KK)?KK:texlen(S)))>Lim){
! 12979: str_tb((Op==5)?Cr:"\n",Out);
! 12980: K=KK;
! 12981: }
! 12982: }
! 12983: str_tb(S,Out);
! 12984: if(Op==6) str_tb("$",Out);
1.1 takayama 12985: }
12986: }else if(Op==7||Op==8){ /* spts, spts0 */
12987: if(type(Lim=getopt(lim))!=1 || (Lim<30 && Lim!=0))
12988: Lim=TeXLim;
12989: Str=getopt(str);
12990: Out = str_tb(0,0);
12991: for(K=0; L!=[]; L=cdr(L)){
12992: LT=car(L);
1.4 ! takayama 12993: KK=0;
1.3 takayama 12994: if(type(LT)==7 && Str==1) S=LT;
12995: else if(type(LT)==3 || type(LT)==2)
12996: S=fctrtos(LT|TeX=2,lim=0,var=Var);
1.4 ! takayama 12997: else if(type(LT)==6){
! 12998: if(Lim){
! 12999: S=mtotex(LT|var=Var,lim=0,len=1);
! 13000: KK=S[1];
! 13001: S=S[0];
! 13002: }else S=mtotex(LT|var=Var,lim=0);
! 13003: }else
1.3 takayama 13004: S=my_tex_form(LT);
1.4 ! takayama 13005: if(Lim!=0){
! 13006: if(!KK) KK=texlen(S);
1.1 takayama 13007: if(K>0 && K+KK>Lim){
13008: str_tb(Cr,Out);
13009: K=0;
13010: }
13011: }
13012: if(K>0){
1.3 takayama 13013: str_tb((Op==7)?"\\ ":" ",Out);
1.1 takayama 13014: if(type(LT)>3 && type(LT)<7) str_tb("%\n",Out);
13015: }
13016: str_tb(S,Out);
13017: K+=KK;
13018: if(OP==7) K++;
13019: }
13020: }else if(Op==9){ /* dform */
13021: Out=str_tb(0,0);
13022: for(I=0;L!=[];L=cdr(L),I++){
13023: for(J=0,LT=car(L); LT!=[]; LT=cdr(LT),J++){
13024: if(J==0){
13025: if((V=car(LT))==0) continue;
13026: if(I>0){
13027: if(type(V)==1){
13028: if(V<0){
13029: str_tb("-",Out);
13030: V=-V;
13031: }
13032: else str_tb("+",Out);
13033: if(V==1 && length(LT)>1) continue;
13034: str_tb(monototex(V),Out);
13035: continue;
13036: }
13037: else str_tb("+",Out);
13038: }
13039: }else if(J>0) str_tb((J>1)?"\\wedge d":"\\,d",Out);
13040: V=monototex(car(LT));
13041: if(V<"-" || V>=".") str_tb(V,Out);
13042: else str_tb(["(",V,")"],Out);
13043: }
13044: }
1.3 takayama 13045: }else if(Op==10 && type(L)==4 && type(car(L))==4){ /* tab */
1.1 takayama 13046: if(type(Null=getopt(null))<0) Null="";
13047: if(getopt(vert)==1){
1.3 takayama 13048: M=lv2m(L|null=Null);
1.1 takayama 13049: L=m2ll(mtranspose(M));
13050: }
1.3 takayama 13051: if(type(W=getopt(width))==1)
13052: L=madjust(L,W|null=Null);
1.1 takayama 13053: LV=ltov(L);
13054: S=length(LV);
13055: for(I=CS=0; I<S; I++)
13056: if(length(LV[I])>CS) CS=length(LV[I]);
13057: if(type(Title=getopt(title))!=7) Title="";
13058: if(type(Vline=getopt(vline))!=4) Vline=[0,CS];
1.3 takayama 13059: else Vline=subst(Vline,z,CS);
13060: for(VV=[],VT=Vline;VT!=[];VT=cdr(VT)){
13061: if(type(T=car(VT))==4 && T[1]>0){
13062: for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV);
13063: }else VV=cons(T,VV);
13064: }
13065: Vline=qsort(VV);
1.1 takayama 13066: Out=str_tb("\\begin{tabular}{",0);
1.3 takayama 13067: if(type(Al=getopt(align))==7 && str_len(Al)>1){
1.1 takayama 13068: str_tb(Al,Out);
13069: }else{
1.3 takayama 13070: if(type(Al)!=7 || str_len(Al)<1) Al="r";
1.1 takayama 13071: for(I=0;I<=CS;I++){
13072: if(I!=0) str_tb(Al,Out);
13073: while(Vline!=[] && car(Vline)==I){
13074: str_tb("|",Out);
13075: Vline=cdr(Vline);
13076: }
13077: }
13078: }
13079: str_tb("}",Out);
13080: if(Title!="")
13081: str_tb("\n\\multicolumn{"+rtostr(CS)+"}{c}{"+Title+"}\\\\",Out);
13082: if(type(Hline=getopt(hline))!=4) Hline=[0,S];
1.3 takayama 13083: else Hline=subst(Hline,z,S);
13084: for(VV=[],VT=Hline;VT!=[];VT=cdr(VT)){
13085: if(type(T=car(VT))==4 && T[1]>0){
13086: for(I=T[0];I<=CS;I+=T[1]) VV=cons(I,VV);
13087: }else VV=cons(T,VV);
13088: }
13089: Hline=qsort(VV);
1.1 takayama 13090: while(Hline!=[] && car(Hline)==0){
13091: str_tb(" \\hline\n",Out);
13092: Hline=cdr(Hline);
13093: }
1.3 takayama 13094: if(type(getopt(left))==4) CS++;
13095: if(type(getopt(right))==4) CS++;
13096: if(type(T=getopt(top))==4){
13097: LV=cons(str_times(T,CS),vtol(LV));
13098: S++;
13099: }
13100: if(type(T=getopt(last))==4){
13101: LV=append(vtol(LV),[str_times(T,CS)]);
13102: S++;
13103: }
13104: if(type(T=getopt(left))==4){
13105: T=str_times(T,S);
13106: for(L=[],I=0;I<S;I++){
13107: L=cons(cons(car(T),LV[I]),L);
13108: T=cdr(T);
13109: }
13110: LV=reverse(L);
13111: }
13112: if(type(T=getopt(right))==4){
13113: T=str_times(T,S);
13114: for(L=[],I=0;I<S;I++){
13115: L=cons(append(LV[I],[car(T)]),L);
13116: T=cdr(T);
13117: }
13118: LV=reverse(L);
13119: }
1.1 takayama 13120: for(I=0; I<S; I++){
13121: for(C=0,LT=LV[I];C<CS; C++){
13122: if(LT!=[]){
13123: P=car(LT);
13124: if(type(P)!=7) P="$"+my_tex_form(P)+"$";
13125: if(P!="") str_tb(P,Out);
13126: LT=cdr(LT);
13127: }
13128: if(C<CS-1) str_tb("& ",Out);
13129: }
13130: str_tb("\\\\",Out);
13131: while(Hline!=[] && car(Hline)==I+1){
13132: str_tb(" \\hline",Out);
13133: Hline=cdr(Hline);
13134: }
13135: str_tb("\n",Out);
13136: }
13137: str_tb("\\end{tabular}\n",Out);
13138: }else if(Op==11){ /* graph */
1.3 takayama 13139: Width=8; Hight=3; WRet=1/2; HMerg=0.2;
13140: if(!TikZ){
13141: Width*=10; Height*=10; HMerg*=10;
13142: }
1.1 takayama 13143: if(type(V=getopt(size))==4){
13144: Width=V[0];Hight=V[1];
13145: if(length(V)>2) WRet=V[2];
13146: if(length(V)>3) HMerg=V[3];
13147: }
13148: Val=getopt(value);
13149: if(!isint(Val)) Val=-1;
13150: if(type(Shift=getopt(shift))!=1)
13151: Shift=0;
13152: if(type(Line=getopt(line))!=1){
13153: if(type(Line)==4 && type(Line[0])==1 && (type(Line[1])==7 || type(Line[1])==1)){
13154: Opt=Line[1]; Line=Line[0];
13155: }else Line=0;
13156: }else Opt="@{-}";
13157: if(type(car(L))==4){
13158: LL=L[1]; L=L[0];
13159: }else LL=[];
13160: if(Line==-1){
13161: for(Sum=0, LT=L; LT!=[]; LT=cdr(LT)){
13162: if((S=car(LT))<=0) return 0;
13163: Sum+=S;
13164: }
13165: for(R=[],LT=L;LT!=[];LT=cdr(LT))
13166: R=cons(car(LT)/Sum,R);
13167: R=reverse(R);
13168: Opt0=Opt*2/3;
13169: Out=str_tb(xyproc(1),0);
13170: str_tb(xylines(ptpolygon(6,Opt)|close=1,curve=1),Out);
13171: for(S=0,RT=R,LT=LL;RT!=[];RT=cdr(RT)){
13172: str_tb(xyline([0,0],[Opt*dsin(S*6.2832),Opt*dcos(S*6.2832)]),Out);
13173: T=S+RT[0]/2;
13174: S+=RT[0];
13175: if(LT!=[]){
13176: str_tb(xyput([Opt0*dsin(T*6.2832),Opt0*dcos(T*6.2832),SS]),Out);
13177: LT=cdr(LT);
13178: }
13179: }
13180: str_tb(xyproc(0),Out);
13181: return str_tb(0,Out);
13182: }
13183: if(type(MX=getopt(max))!=1)
13184: MX=0;
13185: if(MX==0){
13186: for(MX=0,LT=L; LT!=[]; LT=cdr(LT))
13187: if(car(LT)>MX) MX=car(LT);
13188: }
13189: MX-=Shift;
13190: S=length(L);
13191: WStep=Width/S;
13192: WWStep=WStep*WRet;
13193: HStep=Hight/MX;
13194: Out=str_tb(xyproc(1),0);
13195: str_tb(xyline([0,0],[Width-WStep+WWStep,0]),Out);
13196: for(I=0,LT=L;LT!=[]; LT=cdr(LT),I++){
13197: XP=WStep*I; XPM=XP+WWStep/2; YP=(car(LT)-Shift)*HStep;
13198: if(Line!=0){
13199: if(I>0)
13200: str_tb(xyarrow([XPM-WStep,YPP],[XPM,YP]|opt=Opt),Out);
13201: if(Val!=0)
13202: str_tb(xyput([XPM,YP+HMerg,car(LT)]),Out);
13203: if(Line==2)
1.3 takayama 13204: str_tb(xyput([XPM,YP,"$\\bullet$"]),Out);
1.1 takayama 13205: YPP=YP;
13206: }else if(YP!=0 || Val==1){
13207: str_tb(xybox([[XP,0],[XP+WWStep,YP]]),Out);
13208: if(Val!=0){
13209: str_tb(xyput([XPM,(YP<0)?(YP-HMerg):(YP+HMerg),car(LT)]),Out);
13210: }
13211: }
1.3 takayama 13212: if(LL!=[]) str_tb(xyput([XPM,-HMerg,LL[I]]),Out);
13213: }
13214: str_tb(xyproc(0),Out);
13215: }else if(Op==12){ /* coord */
13216: Out=str_tb("(",0);
13217: for(LT=L;;){
13218: X=car(LT);
13219: if(type(X)>3 || imag(X)==0) str_tb(my_tex_form(X),Out);
13220: else{
13221: XR=real(X);XI=imag(X);
13222: S=monototex(imag(X));
13223: if(S=="1") S="";
13224: else if(S=="- 1") S="-";
13225: if(getopt(cpx)==2) S=S+"\\sqrt{-1}";
13226: else S=S+"i";
13227: if(XR!=0){
13228: if(str_char(S,0,"-")==0) S=monototex(XR)+S;
13229: else S=monototex(XR)+"+"+S;
13230: }
13231: str_tb(S,Out);
1.1 takayama 13232: }
1.3 takayama 13233: if((LT=cdr(LT))==[]) break;
13234: else str_tb(",",Out);
1.1 takayama 13235: }
1.3 takayama 13236: str_tb(")",Out);
1.1 takayama 13237: }
13238: else return my_tex_form(L);
13239: S = str_tb(0,Out);
13240: return (getopt(small)==1)?smallmattex(S):S;
13241: }
13242:
13243:
13244: def str_tb(L,TB)
13245: {
13246: if(type(TB) == 0) TB = "";
13247: if(L == 0)
13248: return (type(TB) == 7)?string_to_tb(TB):tb_to_string(TB);
13249: if(type(L) == 7)
13250: L = [L];
13251: else if(type(L) != 4){
13252: erno(0);
13253: return 0;
13254: }
13255: if(type(TB) <= 7)
13256: TB = string_to_tb((type(TB)==7)?TB:"");
13257: for(; L != []; L = cdr(L))
13258: write_to_tb(car(L), TB);
13259: return TB;
13260: }
13261:
13262: /*
13263: def redgrs(M,T)
13264: {
13265: L = [zzz];
13266: for(I=S=0,Eq=[],MT=M; MT!=[]; I++, MT=cdr(MT)){
13267: for(J=LS=0, N=car(MT); N!=[]; N=cdr(N)){
13268: X = makev([z,I,z,J]);
13269: L=cons(X,L);
13270: LS += X;
13271: S += car(N)[1]*X;
13272: }
13273: Eq = cons(LS-zzz,Eq);
13274: }
13275: Eq = cons(S-T,Eq);
13276: Sol= lnsol(Eq,L);
13277: for(LS=[],S=Sol; S!=[]; S=cdr(S)){
13278: T=car(S);
13279: if(type(S)!=4) return 0;
13280: LS=cons(car(S)[0],LS);
13281: }
13282: }
13283: */
13284:
13285: /* T=0 : all reduction
13286: =1 : construction procedure
13287: =2 : connection coefficient
13288: =3 : operator
13289: =4 : series expansion
13290: =5 : expression by TeX
13291: =6 : Fuchs relation
13292: =7 : All
13293: =8 : basic
13294: =9 : ""
13295: =10: irreducible
13296: =11: recurrence */
13297: def getbygrs(M, TT)
13298: {
13299: /* extern TeXEq; */
13300:
13301: if(type(M)==7) M=s2sp(M);
13302: if(type(M) != 4 || TT =="help"){
13303: mycat(
13304: ["getbygrs(m,t) or getbygrs(m,[t,s_1,s_2,...]|perm=?,var=?,pt=?,mat=?)\n",
13305: " m: generalized Riemann scheme or spectral type\n",
13306: " t: reduction, construct, connection, series, operator, TeX, Fuchs, irreducible, basic, recurrence,\n",
13307: " All\n",
13308: " s: TeX dviout simplify short general operator irreducible top0 x1 x2 sft\n",
13309: "Ex: getbygrs(\"111,21,111\", [\"All\",\"dviout\",\"operator\",\"top0\"])\n"]);
13310: return 0;
13311: }
13312: if(type(TT) == 4){
13313: T = TT[0];
13314: T1 = cdr(TT);
13315: }else{
13316: T = TT;
13317: T1 = [];
13318: }
13319: if(type(T) == 7)
13320: T = findin(T,["reduction","construct","connection", "operator", "series",
13321: "TeX", "Fuchs", "All", "basic", "", "irreducible", "recurrence"]);
13322: TeX = findin("TeX", T1);
13323: Simp = findin("simplify", T1);
13324: Short = findin("short", T1);
13325: Dviout= findin("dviout", T1);
13326: General=findin("general", T1);
13327: Op =findin("operator", T1);
13328: Irr =findin("irreducible", T1);
13329: Top0 =findin("top0",T1);
13330: X1 =findin("x1",T1);
13331: X2 =findin("x2",T1);
13332: Sft =findin("sft",T1);
13333: Title = getopt(title);
13334: Mat = getopt(mat);
1.3 takayama 13335: if(Mat!=1 || T<0 ||(T!=0&&T!=1&&T!=5&&T!=6&&T!=8&&T!=10&&T!=9)) Mat = 0;
1.1 takayama 13336: if(findin("keep",T1) >= 0)
13337: Keep = Dviout = 1;
13338: else Keep = 0;
13339: if(Dviout >= 0 || T == 5) TeX = 1;
13340: for(J = 0, MM = M; J == 0 && MM != []; MM = cdr(MM)){
13341: for(MI = car(MM); MI != []; MI = cdr(MI)){
13342: if(type(car(MI)) != 1 || car(MI) <= 0){
13343: J = 1; break;
13344: }
13345: }
13346: }
13347:
13348: /* spectral type -> GRS */
13349: if(J == 0){
13350: for(R = [], S = J = 0, MM = M; MM != []; MM = cdr(MM), J++){
13351: MT = qsort(car(MM));
13352: R = cons(reverse(MT), R);
13353: if(J == 1){
13354: S = length(MT)-1;
13355: if(MT[S] > MT[0]) S = 0;
13356: }
13357: }
13358: M = reverse(R);
13359: R = getopt(var);
13360: if(type(R)<1){
13361: for(R = [], I = J-1; I >= 0; I--)
13362: R = cons(asciitostr([97+I]), R);
13363: }
13364: Sft=(Sft>=0)?1:0;
13365: if(General < 0)
13366: Sft=-Sft-1;
13367: M = sp2grs(M,R,Sft|mat=Mat);
13368: }
1.3 takayama 13369: for(M0=[],MM=M;MM!=[];MM=cdr(MM)){ /* change "?" -> z_z */
13370: for(M1=[],Mm=car(MM);Mm!=[];Mm=cdr(Mm)){
13371: Mt=car(Mm);
13372: if(type(Mt)==4 && Mt[1]=="?"){
13373: M1=cons([Mt[0],z_z],M1);
13374: continue;
13375: }else if(type(Mt)==7 && Mt=="?"){
13376: M1=cons(z_z,M1);
13377: continue;
13378: }
13379: M1=cons(Mt,M1);
13380: }
13381: M0=cons(reverse(M1),M0);
13382: }
13383: M = fspt(reverse(M0),5); /* short -> long */
13384: if(findin(z_z,vars(M))>=0)
13385: M=subst(M,z_z,lsol(chkspt(M|mat=Mat)[3],z_z)); /* Fuchs relation */
1.1 takayama 13386: NP = length(M);
13387: Perm = getopt(perm);
13388: if(type(Perm) == 4)
13389: M = mperm(M,Perm,0);
13390: if(T == 9){ /* "" */
13391: if(Short >= 0)
13392: M = chkspt(M|opt=4,mat=Mat);
13393: return M;
13394: }
13395: R = [0,M];
13396: ALL = [R];
13397:
13398: while(type(R = redgrs(R[1]|mat=Mat)) == 4)
13399: ALL = cons(R, ALL);
13400: if(R < 0)
13401: return 0;
13402:
13403: /* TeX */
13404: if(TeX >= 0 && !chkfun("print_tex_form", "names.rr"))
13405: return 0;
13406: if(Dviout >= 0 && type(Title) == 7)
13407: dviout(Title|keep=1);
13408: if(T == 7 && Dviout >= 0){
13409: S=["keep","simplify"];
13410: if(Top0 >= 0)
13411: S = cons("top0",S);
13412: getbygrs(M,cons(5,S)|title="\\noindent Riemann Scheme",mat=Mat);
13413: Same = 0;
13414: if(R > 0){
13415: MM = getbygrs(M,8|mat=Mat); /* basic GRS */
13416: MS = chkspt(MM|opt=0,mat=Mat); /* spectral type */
13417: if(M != MM)
13418: getbygrs(MM,cons(5,S)|title="Basic Riemann Scheme",mat=Mat);
13419: else{
13420: dviout("This is a basic Riemann Scheme.\n\n\\noindent"|keep=1);
13421: Same = 1;
13422: }
13423: dviout(MS|keep=1);
13424: }
13425: if(chkspt(ALL[0][1]|mat=Mat)[3] != 0)
13426: getbygrs(M,cons(6,S)|title="Fuchs condition",mat=Mat);
13427: if(Same == 0){
13428: M1 = M[1];
13429: if(M1[length(M1)-1][0]==1 && Mat!=1){
13430: M1=M[2];
13431: if(M1[length(M1)-1][0] == 1){
13432: getbygrs(M,cons(2,S)|title="Connection formula");
13433: if(M1[length(M[0][0])-1][0] == 1 && R==0)
13434: getbygrs(M,cons(11,S)|title="Recurrence relation shifting the last exponents at $\\infty$, 0, 1");
13435: }
13436: getbygrs(M,cons(1,S)|title="Integral representation");
13437: getbygrs(M,cons(4,S)|title="Series expansion");
13438: }
13439: if(Irr < 0){
13440: TI="Irreduciblity $\\Leftrightarrow$ any value of the following linear forms $\\notin\\mathbb Z$";
13441: if(R > 0)
13442: TI += " + fundamental irreducibility";
13443: getbygrs(M,cons(10,S)|title=TI,mat=Mat);
13444: dviout("which coorespond to the decompositions"|keep=1);
13445: sproot(chkspt(M|opt=0),"pairs"|dviout=1,keep=1);
13446: }
13447: }
13448: if(Op >= 0 && Mat!=1) getbygrs(M,cons(3,S)|title="Operator");
13449: dviout(" ");
13450: return 1;
13451: }
13452: if(T == 0 && TeX >= 0){
13453: T = 1; TeX = 16;
13454: }
13455: /* Fuchs */
13456: Fuc = chkspt(ALL[0][1]|Mat=mat)[3];
13457: if(Fuc == 0) Simp = -1;
13458: if(type(Fuc) == 1){
13459: print("Violate Fuchs condition");
13460: return 0;
13461: }
13462: if(T == 6){
13463: if(Dviout >= 0) dviout(Fuc|eq=0,keep=Keep);
13464: return (TeX >= 0)?my_tex_form(Fuc):Fuc;
13465: }
13466: Fuc = [Fuc];
13467: /* Generelized Riemann scheme */
13468: if(T == 5){
13469: M = ltov(M);
13470: for(ML=0, I=0; I<NP; I++){
13471: L = length(M[I]);
13472: if(L > ML) ML = L;
13473: }
13474: Out = string_to_tb("P\\begin{Bmatrix}\nx=");
13475: if(Top0 < 0)
13476: write_to_tb("\\infty & ",Out);
13477: Pt = getopt(pt);
13478: if(type(Pt) == 4){
13479: for(J = 3; J < NP; J++){
13480: str_tb(["& ",rtotex(car(Pt))],Out);
13481: Pt = cdr(Pt);
13482: }
13483: }
13484: else if(X2>=0)
13485: str_tb("0 & x_2",Out);
13486: else
13487: str_tb((X1>=0)?"x_1 & x_2":"0 & 1",Out);
13488: for(J = 3; J < NP; J++)
13489: str_tb(["& x_",rtotex(J)],Out);
13490: if(Top0 >= 0)
13491: write_to_tb("& \\infty",Out);
13492: write_to_tb("\\\\\n",Out);
13493: for(I = 0; I < ML; I++){
13494: for(CC = 0, J = (Top0 >= 0)?1:0; ; J++, CC++){
13495: if(J == NP){
13496: if(Top0 < 0) break;
13497: J = 0;
13498: }
13499: if(length(M[J]) <= I){
13500: if(CC > 0) write_to_tb(" & ",Out);
13501: }else if(M[J][I][0] <= 1){
13502: if(M[J][I][0] == 0) str_tb(" & ",Out);
13503: else
13504: str_tb([(!CC)?" ":" & ", my_tex_form(M[J][I][1])], Out);
13505: }else{
13506: str_tb([((!CC)?"[":" & ["), my_tex_form(M[J][I][1]),
13507: (Mat==1)?"]_{":"]_{("],Out);
13508: str_tb([my_tex_form(M[J][I][0]),(Mat==1)?"}":")}"],Out);
13509: }
13510: if(Top0 >= 0 && J == 0)
13511: break;
13512: }
13513: if(I == 0)
13514: str_tb("&\\!\\!;x",Out);
13515: str_tb("\\\\\n",Out);
13516: }
13517: str_tb("\\end{Bmatrix}",Out);
13518: Out = str_tb(0,Out);
13519: if(Dviout >= 0)
13520: dviout(Out|eq=0,keep=Keep);
13521: return Out;
13522: }
13523:
13524: /* Reduction */
13525: if(T == 0){
13526: if(Simp >= 0)
13527: ALL = simplify(ALL,Fuc,4);
13528: return reverse(ALL);
13529: }
13530: LA = length(ALL) - 1;
13531: NP = length(ALL[0][1]);
13532:
13533: /* irreducible */
13534: if(T == 10){
13535: for(IR=[], I = 0; I < LA; I++){
13536: AI = ALL[I]; AIT = AI[1];
13537: K = AI[0][0];
13538: P = -AIT[0][K][1];
13539: P -= cterm(P);
13540: IR = cons(P, IR);
13541: for(J = 0; J < NP; J++){
13542: K = AI[0][J];
13543: for(L = length(AIT[J]) - 1; L >= 0 ; L--){
13544: if(L == K || AIT[J][L][0] <= AIT[J][K][0])
13545: continue;
13546: P = AIT[J][L][1] - AIT[J][K][1];
13547: Q = cterm(P);
13548: if(dn(Q)==1)
13549: P -= Q;
13550: IR = cons(P,IR);
13551: }
13552: }
13553: }
13554: P=Fuc[0];
13555: Q=cterm(P);
13556: if(type(Q)==1 && dn(Q)==1){
13557: for(F=0,V=vars(P);V!=[];V=cdr(V)){
13558: R=mycoef(P,1,car(V));
13559: if(type(R)!=1 || Q%R!=0){
13560: F=1; break;
13561: }
13562: }
13563: if(F==0){
13564: P-=Q;
13565: Simp=0;
13566: }
13567: }
13568: if(Simp >= 0){
13569: IR=simplify(IR,[P],4);
13570: for(R=[]; IR!=[]; IR=cdr(IR)){
13571: P=car(IR);
13572: Q=cterm(P);
13573: if(dn(Q)==1) P-=Q;
13574: R=cons(P,R);
13575: }
13576: IR=R;
13577: }
13578: for(R=[]; IR!=[]; IR=cdr(IR)){
13579: P=car(IR);
13580: if(str_len(rtostr(P)) > str_len(rtostr(-P)))
13581: P = -P;
13582: R = cons(P,R);
13583: }
13584: R = ltov(R);
1.3 takayama 13585: #ifdef USEMODULE
1.2 ohara 13586: R = qsort(R,os_md.cmpsimple);
13587: #else
1.4 ! takayama 13588: R = qsort(R,cmpsimple);
1.2 ohara 13589: #endif
1.1 takayama 13590: R = vtol(R);
13591: if(TeX >= 0){
13592: Out = string_to_tb("");
13593: for(I=L=K=0; R!=[]; R=cdr(R),I++){
13594: K1 = K;
13595: RS = my_tex_form(car(R));
13596: /* K = str_len(RS);
13597: L += K+4; */
13598: K = nmono(car(R));
13599: L += K;
13600: if(I){
13601: if(K1 == K && L < 30)
13602: str_tb("\\quad ",Out);
13603: else{
13604: L = K;
13605: str_tb((TeXEq==5)?["\\\\%\n &"]:["\\\\%\n "],Out);
13606: }
13607: }
13608: str_tb(RS,Out);
13609: }
13610: R = Out;
13611: if(Dviout>=0){
13612: dviout(R|eq=0,keep=Keep);
13613: return 1;
13614: }
13615: }
13616: return R;
13617: }
13618:
13619: AL = []; SS = 0;
13620: for(I = 0; I <= LA; I++){
13621: AI = ALL[I]; AIT = AI[1]; /* AIT: GRS */
13622: if(I > 0){
13623: for(S = J = 0; J < NP; J++){
13624: GE = AIT[J][AI0[J]][1];
13625: S += GE;
13626: if(J == 0)
13627: SS = [];
13628: else
13629: SS = cons(GE,SS);
13630: }
13631: SS = cons(1-Mat-S, reverse(SS));
13632: }
13633: AI0 = AI[0];
13634: AL = cons([SS, cutgrs(AIT)], AL);
13635: }
13636: AL = reverse(AL);
13637: AD = newvect(NP);
13638: ALT = AL[0][1];
13639: for(J = 1; J < NP; J++){
13640: /* AD[J] = ALT[J][0][1]; [J][?][1] <- [J][?][0]: max */
13641: for(MMX=0, K = KM = length(ALT[J])-1; K >= 0; K--){
13642: if(MMX <= ALT[J][K][0]){
13643: if(J == 1 && MMX == ALT[J][K][0])
13644: continue;
13645: KM = K;
13646: MMX = ALT[J][K][0];
13647: }
13648: }
13649: AD[J] = ALT[J][KM][1];
13650: }
13651: AL = cdr(AL);
13652: AL = cons([vtol(AD), ALT], AL);
13653: AL = cons([0, mcgrs(ALT, [vtol(-AD)]|mat=Mat)], AL);
13654: if(Simp >= 0 && T != 3)
13655: AL = simplify(AL,Fuc,4);
13656: /* Basic */
13657: if(T == 8){
13658: ALT = AL[0][1];
13659: if(TeX >= 0){
13660: if(Dviout >= 0){
13661: return getbygrs(ALT,["TeX","dviout","keep"]);
13662: }
13663: return getbygrs(ALT,"TeX");
13664: }
13665: if(Short >= 0)
13666: ALT = chkspt(ALT|opt=4);
13667: return ALT;
13668: }
13669:
13670: /* Construct */
13671: if(T == 1){
13672: if(TeX >= 0){
13673: L = length(AL);
13674: I = Done = 0; Out0=Out1=""; NM = DN = [];
13675: if(TeX != 16){
13676: AL11=AL[L-1][1][1];
13677: AT = AL11[length(AL11)-1];
13678: if(type(AT) == 4){
13679: PW = (AT[0] > 1)?"":AT[1];
13680: }else PW = AT;
13681: }
13682: Out = string_to_tb("");
13683: while(--L >= 0){
13684: if(TeX == 16){
13685: if(Done)
13686: write_to_tb(":\\ ", Out);
13687: write_to_tb(getbygrs(AL[L][1],(Top0>=0)?["TeX", "top0"]:"TeX"|mat=Mat), Out);
13688: Done = 1;
13689: if(L != 0) write_to_tb((TeXEq==5)?
13690: "\\\\%\n&\\leftarrow ":"\\\\%\n\\leftarrow ", Out);
13691: }
13692: ALT = AL[L][0];
13693: if(TeX != 16){
13694: V1 = (I==0)?"x":V2;
13695: V2 = /* (I==0 && L<=2)?"s": */
13696: "s_"+rtotex(I);
13697: }else V1=V2="x";
13698: JJ = (type(ALT) == 4)?length(ALT):0;
13699: if(I > 0 && L > 0)
13700: write_to_tb("\n ", Out);
13701: for(Outt = "", J = 1; J < JJ; J++){
13702: if(ALT[J] == 0) continue;
13703: if(J == 1) Outt += V1;
13704: else if(J == 2) Outt += "(1-"+V1+")";
13705: else Outt += "(x_"+rtotex(J)+"-"+V1+")";
13706: Outt += "^"+ rtotex(ALT[J]);
13707: }
13708: if(TeX != 16) write_to_tb(Outt, Out);
13709: else if(Outt != "")
13710: str_tb(["\\mathrm{Ad}\\Bigl(",Outt,"\\Bigr)"], Out);
13711: if(JJ == 0){
13712: if(I != 0)
13713: Out1 = "ds_"+rtotex(I-1)+Out1;
13714: continue;
13715: }
13716: if(ALT[0] == 0) continue;
13717: Out0 += "\\int_p^{"+V1+"}";
13718: if(TeX == 16)
13719: str_tb(["mc_",rtotex(ALT[0])], Out);
13720: else{
13721: str_tb(["(",V1,"-",V2,")^",rtotex(-1+ALT[0])], Out);
13722: AL11=AL[L-1][1][1];
13723: AT = AL11[length(AL11)-1];
13724: if(type(AT) == 4) AT = AT[1];
13725: DN = cons(ALT[0]+AT+1,DN);
13726: NM = cons(AT+1,cons(ALT[0],NM));
13727: }
13728: if(L != 2) Out1 += "d"+V2;
13729: I++;
13730: }
13731: if(R){
13732: if(I == 0) Ov = "x";
13733: else Ov = "s_"+rtotex(I-1);
13734: Out1 = "u_B("+Ov+")"+Out1;
13735: }
13736: if(TeX != 16){
13737: Out0 = string_to_tb(Out0);
13738: str_tb([Out, Out1], Out0);
13739: Out = Out0;
13740: NM = simplify(NM, Fuc, 4);
13741: DN = simplify(DN, Fuc, 4);
13742: DNT = lsort(NM,DN,"reduce");
13743: NMT = DNT[0]; DNT = DNT[1];
13744: if(NMT != [] && PW != ""){
13745: write_to_tb((TeXEq==5)?"\\\\\n &\\sim\\frac{\n"
13746: :"\\\\\n \\sim\\frac{\n", Out);
13747: for(PT = NMT; PT != []; PT = cdr(PT))
13748: str_tb([" \\Gamma(",my_tex_form(car(PT)), ")\n"], Out);
13749: write_to_tb(" }{\n", Out);
13750: for(PT = DNT; PT != []; PT = cdr(PT))
13751: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
13752: write_to_tb(" }", Out);
13753: if(R > 0) write_to_tb("C_0", Out);
13754: write_to_tb("x^"+rtotex(PW) +"\\ \\ (p=0,\\ x\\to0)", Out);
13755: }
13756: }else
13757: Out = str_tb(0, Out);
13758: if(Dviout >= 0){
13759: dviout(Out|eq=0,keep=Keep);
13760: return 1;
13761: }
13762: return O;
13763: }
13764: if(Short >= 0){
13765: for(ALL = [] ; AL != []; AL = cdr(AL)){
13766: AT = car(AL);
13767: ALL = cons([AT[0], chkspt(AT[1]|opt=4)], ALL);
13768: }
13769: AL = reverse(ALL);
13770: }
13771: return AL; /* AL[0][1] : reduced GRS, R==0 -> rigid */
13772: }
13773:
13774: if(T == 2 || T == 4 || T == 11){
13775: for(I = (T==2)?2:1; I >= (T==11)?0:1; I--){
13776: ALT = M[I];
13777: if(ALT[length(ALT)-1][0] != 1){
13778: mycat(["multiplicity for",I,":",ALT[length(ALT)-1][1],
13779: "should be 1"]);
13780: return;
13781: }
13782: }
13783: }
13784: LA++;
13785: NM = DN = [];
13786:
13787: /* Three term relation */
13788: if(T == 11){
13789: if(R > 0){
13790: print("This is not rigid\n");
13791: return 0;
13792: }
13793: for(I = 0; I <= LA; I++){
13794: if(I > 0){
13795: AI = AL[I][0]; /* operation */
13796: if(AI[0] != 0){
13797: DN = cons(simplify(AI1+1,Fuc,4),DN);
13798: NM = cons(simplify(AI1+AI[0]+1,Fuc,4),NM);
13799: }
13800: }
13801: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
13802: }
13803: DNT = lsort(NM,DN,"reduce");
13804: if(TeX < 0) return DNT;
13805: NMT = DNT[0]; DNT = DNT[1];
13806: Out = str_tb("u_{0,0,0}-u_{+1,0,-1}=\\frac{","");
13807: for(PT = NMT; PT != []; PT = cdr(PT))
13808: str_tb(["(",my_tex_form(car(PT)),")"], Out);
13809: str_tb(["}\n{"],Out);
13810: for(PT = DNT; PT != []; PT = cdr(PT))
13811: str_tb(["(",my_tex_form(car(PT)),")"], Out);
13812: write_to_tb("}u_{0,+1,-1}",Out);
13813: if(Dviout >= 0){
13814: dviout(Out|eq=0,keep=Keep);
13815: return 1;
13816: }
13817: return Out;
13818: }
13819:
13820: AD=newvect(NP);
13821: for(I = 0; I <= LA; I++){
13822: if(I > 0){
13823: AI = AL[I][0]; /* operation */
13824: if(T == 2 && AI[0] != 0){
13825: DN = cons(simplify(-AI2,Fuc,4), cons(simplify(AI1+1,Fuc,4),DN));
13826: NM = cons(simplify(-AI2-AI[0],Fuc,4), cons(simplify(AI1+AI[0]+1,Fuc,4),
13827: NM));
13828: }
13829: for(J = 1; J < NP; J++)
13830: AD[J] += simplify(AI[J],Fuc,4);
13831: }
13832: if(T == 2){
13833: ALT = AL[I][1][1]; AI1 = ALT[length(ALT)-1][1];
13834: ALT = AL[I][1][2]; AI2 = ALT[length(ALT)-1][1];
13835: if(I == 0){
13836: C3 = AI1; C4 = AI2;
13837: }
13838: }
13839: }
13840:
13841: /* Connection */
13842: if(T == 2){
13843: DNT = lsort(NM,DN,"reduce");
13844: NMT = DNT[0]; DNT = DNT[1];
13845: if(TeX < 0) return [NMT,DNT,AD];
13846: C0 = M[1][length(M[1])-1][1];
13847: C1 = M[2][length(M[2])-1][1];
13848: M = AL[0][1];
13849: C3 = M[1][length(M[1])-1][1];
13850: C4 = M[2][length(M[2])-1][1];
13851: Out = str_tb(["c(0\\!:\\!", my_tex_form(C0),
13852: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C1),")"], "");
13853: if(R > 0 && AMSTeX == 1 && (TeXEq == 4 || TeXEq == 5)){
13854: write_to_tb("\\\\\n", Out);
13855: if(TeXEq == 5) write_to_tb(" &", Out);
13856: }
13857: write_to_tb("=\\frac{\n",Out);
13858: for(PT = NMT; PT != []; PT = cdr(PT))
13859: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n", Out);
13860: write_to_tb(" }{\n",Out);
13861: for(PT = DNT; PT != []; PT = cdr(PT))
13862: write_to_tb(" \\Gamma("+my_tex_form(car(PT))+")\n",Out);
13863: write_to_tb(" }", Out);
13864: for(J = 3; J < length(AD); J++){
13865: if(AD[J] == 0) continue;
13866: str_tb(["\n (1-x_", rtotex(J), "^{-1})^", rtotex(AD[J])], Out);
13867: }
13868: if(R != 0)
13869: str_tb(["\n c_B(0\\!:\\!", my_tex_form(C3),
13870: " \\rightsquigarrow 1\\!:\\!", my_tex_form(C4), ")"], Out);
13871: Out = tb_to_string(Out);
13872: if(Dviout >= 0){
13873: dviout(Out|eq=0,keep=Keep);
13874: return 1;
13875: }
13876: return Out;
13877: }
13878:
13879: /* Series */
13880: if(T == 4){
13881: AL11 = AL[0][1][1];
13882: V = AL11[length(AL11)-1][1];
13883: S00 = -V; S01 = (R==0)?[]:[[0,0]];
13884: S1 = S2 = [];
13885: for(Ix = 1, ALL = cdr(AL); ALL != []; ){
13886: ALT = ALL[0][0];
13887: if(ALT[0] != 0){ /* mc */
13888: for(Sum = [], ST = S01; ST != []; ST = cdr(ST))
13889: Sum = cons(car(ST)[0], Sum);
13890: S1 = cons(cons(S00+1,Sum), S1);
13891: S2 = cons(cons(S00+1+ALT[0],Sum),S2);
13892: S00 += ALT[0];
13893: }
13894: ALL = cdr(ALL);
13895: for(I = 1; I < length(ALT); I++){ /* addition */
13896: if(I == 1){
13897: S00 += ALT[1];
13898: if(ALL == [])
13899: S00 = [S00];
13900: }else{
13901: if(ALT[I] == 0)
13902: continue;
13903: if(ALL != []){
13904: S1 = cons([-ALT[I],Ix],S1);
13905: S2 = cons([1,Ix],S2);
13906: S01= cons([Ix,I],S01);
13907: Ix++;
13908: }else
13909: S00 = cons([ALT[I],I],S00);
13910: }
13911: }
13912: }
13913: S00 = reverse(S00);
13914: S01 = qsort(S01); S1 = qsort(S1); S2 = qsort(S2);
13915: if(Simp >= 0){
13916: S00 = simplify(S00,Fuc,4);
13917: S01 = simplify(S01,Fuc,4);
13918: S1 = simplify(S1,Fuc,4);
13919: S2 = simplify(S2,Fuc,4);
13920: SS = lsort(S1,S2,"reduce");
13921: S1 = SS[0]; S2 = SS[1];
13922: }
13923:
13924: if(TeX >= 0){
13925: /* Top linear power */
13926: TOP = Ps = Sm = "";
13927: for(TOP = Ps = Sm = "", ST = cdr(S00); ST != []; ST = cdr(ST)){
13928: SP = car(ST);
13929: if(SP[0] != 0){
13930: if(SP[1] == 2)
13931: TOP += "(1-x)^"+rtotex(SP[0]);
13932: else
13933: TOP += "(1-x/x_"+rtotex(SP[1])+")^"+rtotex(SP[0]);
13934: }
13935: }
13936: /* Top power */
13937: PW = my_tex_form(car(S00));
13938: if(PW == "0")
13939: PW = "";
13940: NP = length(AL[0][1]);
13941: PWS = newvect(NP);
13942: for(I = 0; I < NP; I++)
13943: PWS[I] = "";
13944: for(S = S01, I = 0; S != []; S = cdr(S), I++){
13945: SI = rtotex(car(S)[0]);
13946: if(I > 0) Sm += ",\\ ";
13947: Sm += "n_"+SI+"\\ge0";
13948: if(PW != "")
13949: PW += "+";
13950: PW += "n_"+SI;
13951: if(car(S)[1] > 2)
13952: PWS[car(S)[1]] += "-n_"+rtotex(car(S)[0]);
13953: else if(car(S)[1] == 0)
13954: Ps = "C_{n_0}"+Ps;
13955: }
13956: for(I = 3; I < NP; I++){
13957: if(PWS[I] != "")
13958: Ps += "x_"+rtotex(I)+"^{"+PWS[I]+"}";
13959: }
13960: Out = str_tb([TOP, Ps, "x^{", PW, "}"], "");
13961: /* Gamma factor */
13962: for(I = 0, SS = S1; I <= 1; I++, SS = S2){
13963: PW = string_to_tb("");
13964: for(PW1=""; SS != [] ; SS = cdr(SS)){
13965: for(J = 0, SST = car(SS); SST != []; SST = cdr(SST), J++){
13966: if(J == 0){
13967: JJ = (car(SST) == 1)?((length(SST)==2)?(-1):0):1;
13968: if(JJ > 0)
13969: str_tb(["(", my_tex_form(car(SST)), ")_{"], PW);
13970: else if(JJ == 0)
13971: PW1 = "(";
13972: }else{
13973: if(JJ > 0){
13974: if(J > 1) write_to_tb("+", PW);
13975: str_tb(["n_", rtotex(car(SST))], PW);
13976: }else{
13977: if(J > 1) PW1 += "+";
13978: PW1 += "n_"+rtotex(car(SST));
13979: }
13980: }
13981: }
13982: if(JJ > 0) write_to_tb("}", PW);
13983: else PW1 += (JJ == 0)?")!":"!";
13984: }
13985: if(I == 0)
13986: Out0 = "\\frac";
13987: Out0 += "{"+tb_to_string(PW)+PW1+"}";
13988: PW = string_to_tb(""); PW1 = "";
13989: }
13990: if(Out0 == "\\frac{}{}")
13991: Out0 = "";
13992: Out = "\\sum_{"+Sm+"}"+Out0 + Top + tb_to_string(Out);
13993: if(length(S01) == 1){
13994: Out = str_subst(Out, "{n_"+SI+"}", "n");
13995: Out = str_subst(Out, "n_"+SI, "n");
13996: }
13997: if(Dviout >= 0)
13998: dviout(Out|eq=0,keep=Keep);
13999: return Out;
14000: }
14001: return [cons(S00, S01), S1, S2];
14002: }
14003:
14004: /* Operator */
14005: if(T==3){
14006: Fuc0 = car(Fuc);
14007: if(Fuc0 != 0){ /* Kill Fuchs relation */
14008: for(V = vars(Fuc0); V != []; V = cdr(V)){
14009: VT = car(V);
14010: if(deg(Fuc0,VT) == 1){
14011: AL = mysubst(AL, [VT, -red(coef(Fuc0,0,VT)/coef(Fuc0,1,VT))]);
14012: break;
14013: }
14014: }
14015: if(V == []){
14016: print("Fuchs condition has no variable with degree 1");
14017: return 0;
14018: }
14019: }
14020: L = newvect(NP);
14021: Pt = getopt(pt);
14022: for(I = NP-1; I >= 1; I--){
14023: if(type(Pt) == 4)
14024: L[I] = Pt[I-1];
14025: else if(I >= 3 || X1 >= 0 || (X2 >= 0 && I >= 2))
14026: L[I] = makev(["x_", I]);
14027: else L[I] = I-1;
14028: }
14029: if(R){ /* non-rigid basic */
14030: MM = AL[0][1]; /* Riemann scheme */
14031: for(OD = 0, MT = car(MM); MT != []; MT = cdr(MT))
14032: OD += car(MT)[0];
14033: for(V = DN = [], M = MM; M != []; M = cdr(M)){
14034: MT = car(M); /* exponents */
14035: for(K = KM = 0, NT = []; ; K++){
14036: for(J = 0, P = 1, MTT = MT; MTT != []; MTT = cdr(MTT)){
14037: if(J == 0 && car(MTT)[1] == 0)
14038: KM = car(MTT)[0];
14039: for(KK = car(MTT)[0] - K -1; KK >= 0; KK--)
14040: P *= (dx-car(MTT)[1]-KK);
14041: }
14042: if(P == 1) break;
14043: NT = cons(P,NT);
14044: }
14045: V = cons(reverse(NT), V);
14046: DN = cons(KM, DN);
14047: }
14048: V = ltov(reverse(V)); /* conditions for GRS */
14049: DN = ltov(reverse(DN)); /* dims of local hol. sol. */
14050: for(J = OD; J >= 0; J--){
14051: for(I = Q = 1; I < NP; I++){
14052: if(J > DN[I])
14053: Q *= (x-L[I])^(J-DN[I]);
14054: }
14055: K = mydeg(Q,x);
14056: if(J == OD){
14057: P = Q*dx^J;
14058: DM = K;
14059: }else{
14060: for(I = DM-OD+J-K; I >= 0; I--){
14061: X = makev(["r",J,"_",I]);
14062: P += Q*x^I*X*dx^J;
14063: }
14064: }
14065: }
14066: for(R = [], I = 0; I < NP; I++){
14067: Q = toeul(P, [x,dx], (I==0)?"infty":L[I]); /* Euler at I-th pt */
14068: for(VT = V[I], J=0; VT != [] ; VT = cdr(VT), J++){
14069: if(car(VT) != 0)
14070: R = cons(rpdiv(coef(Q,J,x), car(VT), dx)[0], R); /* equations */
14071: }
14072: }
14073: for(RR = RRR = [], I = OD-1; I>=0; I--){
14074: RR = [];
14075: for(RT = R; RT != [] ; RT = cdr(RT)){
14076: if( (VT = mycoef(car(RT), I, dx)) != 0)
14077: RR = cons(VT, RR); /* real linear eqs */
14078: }
14079: J = mydeg(mycoef(P,I,dx),x);
14080: for(S = 0, VVV = []; J >= 0; J--){
14081: X = makev(["r",I,"_",J]);
14082: VVV = cons(X, VVV); /* unknowns */
14083: }
14084: RR = lsol(RR,VVV);
14085: LN = length(RR);
14086: for(K=0; K<LN; K++){
14087: RRT = RR[K];
14088: if(type(RRT) != 4) continue;
14089: R = mysubst(R,RRT);
14090: P = mysubst(P,RRT);
14091: }
14092: }
14093: }else /* Rigid case */
14094: P = dx^(AL[0][1][0][0][0]);
14095: /* additions and middle convolutions */
14096: for(ALT = AL; ALT != []; ALT = cdr(ALT)){
14097: AI = car(ALT)[0];
14098: if(type(AI) != 4) continue;
14099: V = ltov(AI);
14100: if(V[0] != 0) P = mc(P,x,V[0]);
14101: for(I = 1; I < NP; I++){
14102: if(V[I] != 0)
14103: P = sftexp(P,x,L[I],-V[I]);
14104: }
14105: }
14106: P = (Simp>=0)? simplify(P,Fuc,4|var=[dx]):simplify(P,Fuc,4);
14107: if(TeX >= 0){
14108: Val = 1;
14109: if(mydeg(P,dx) > 2 && AMSTeX == 1 && TeXEq > 3)
14110: Val = (TeXEq==5)?3:2;
14111: Out = fctrtos(P|var=[dx,"\\partial"],TeX=Val);
14112: if(Dviout < 0) return Out;
14113: dviout(Out|eq=0,keep=Keep);
14114: return 1;
14115: }
14116: return P;
14117: }
14118: return 0;
14119: }
14120:
1.4 ! takayama 14121: def mcop(P,M,S)
! 14122: {
! 14123: for(V=[],ST=S;ST!=[];ST=cdr(ST))
! 14124: if(isvar(VT=car(ST))) V=cons(vweyl(VT),V);
! 14125: V=reverse(V);
! 14126: N=length(V);
! 14127: for(MT=M;MT!=[];MT=cdr(MT)){
! 14128: T=car(MT);
! 14129: if(T[0]!=0)
! 14130: P=mc(P,V[0],T[0]);
! 14131: for(TT=cdr(T),ST=cdr(S);ST!=[];TT=cdr(TT),ST=cdr(ST))
! 14132: if(car(TT)!=0) P=sftpexp(P,V,S[0]-ST[0],-car(TT));
! 14133: }
! 14134: return P;
! 14135: }
! 14136:
1.1 takayama 14137: /* option: zero, all, raw */
14138: def shiftop(M,S)
14139: {
14140: if(type(M)==7) M=s2sp(M);
14141: if(type(S)==7) S=s2sp(S);
14142: Zero=getopt(zero);
14143: NP=length(M);
14144: for(V=L=[],I=NP-1; I>=0; I--){
14145: V=cons(strtov(asciitostr([97+I])),V);
14146: if(I>2) L=cons(makev(["y_", I-1]),L);
14147: else L=cons(I-1,L);
14148: }
14149: if(type(M[0][0])==4){
14150: F=1;RS=M;SS=S;
14151: R=chkspt(M);
14152: if(R[2]!=2 || R[3]!=0){
14153: mycat("GRS is not valid!");return 0;
14154: }
14155: for(; S!=[]; S=cdr(S)){
14156: if(nmono(S[0][0])!=1) break;
14157: if(isint(S[0][1]-S[0][0])==0) break;
14158: }
14159: if(S!=[]){
14160: mycat("Error in shift!"); return 0;
14161: }
14162: }else{
14163: F=0;
14164: RS=sp2grs(M,V,[1,length(M[0]),1]);
14165: for(SS=S0=[],I=0; I<NP; I++){
14166: for(J=F=0; J<length(M[I]); J++){
14167: if(I==0 && J==length(M[0])-1) break;
14168: if((U=S[I][J])!=0){
14169: if(isint(U)!=1){
14170: mycat("Error in shift!"); return 0;
14171: }
14172: VT=RS[I][J][1];
14173: SS=cons([VT,VT+U],SS);
14174: }else if(I>0 && Zero==1 && F==0){
14175: RS=mysubst(RS,[RS[I][J][1],0]);
14176: F=J+1;
14177: }
14178: }
14179: if((F>0 && J==2) || (I==0 && J==1)){
14180: J=(I==0)?0:2-F; VT=RS[I][J][1];
14181: S0=cons([VT,strtov(asciitostr([strtoascii(rtostr(VT))[0]]))],S0);
14182: }
14183: }
14184: }
14185: RS1=mysubst(RS,SS);
14186: if(F==1){
14187: R=chkspt(RS1);
14188: if(R[2]!=2 || R[3]!=0){
14189: mycat("Error in shift!");
14190: return 0;
14191: }
14192: }
14193: R=getbygrs(RS,1); R1=getbygrs(RS1,1);
14194: RT=R[0][1][0];
14195: if(length(RT)!=1 || RT[0][0]!=1){
14196: mycat("Not rigid!");
14197: return 0;
14198: }
14199: P=dx;Q=Q1=1;
14200: for(RT = R, RT1=R1; RT != []; RT = cdr(RT), RT1=cdr(RT1)){
14201: V=car(RT)[0]; V1=car(RT1)[0];
14202: if(type(V) != 4) continue;
14203:
14204: if(V[0] != 0){
14205: P = mc(P,x,V[0]); /* middle convolution */
14206: QT = mc(Q,x,V[0]);
14207: }else QT=Q;
14208: D0=mydeg(Q,dx);D0T=mydeg(QT,dx);
14209: C0=red(mycoef(Q,D0,dx)/mycoef(QT,D0T,dx));
14210: if(C0!=1) QT=red(C0*QT);
14211:
14212: if(V1[0] != 0) Q1T = mc(Q1,x,V1[0]);
14213: else Q1T=Q1;
14214: D1=mydeg(Q1,dx);D1T=mydeg(Q1T,dx);
14215: C1=red(mycoef(Q1,D1,dx)/mycoef(Q1T,D1T,dx));
14216: if(C1!=1) Q1T=red(C1*Q1T);
14217: DD=(V[0]-V1[0])+(D0-D0T)-(D1-D1T);
14218: if(DD>0){
14219: QT=muldo(dx^DD,QT,[x,dx]);
14220: D0T+=DD;
14221: }else if(DD<0){
14222: Q1T=muldo(dx^(-DD),Q1T,[x,dx]);
14223: D1T-=DD;
14224: }
14225: C=mylcm(dn(QT),dn(Q1T),x);
14226: if(C!=1){
14227: QT=red(C*QT); Q1T=red(C*Q1T);
14228: }
14229: Q=QT;Q1=Q1T;
14230: for(I = 1; I < NP; I++){
14231: if(V[I]!=0){
14232: P = sftexp(P,x,L[I],-V[I]); /* addition u -> (x-L[I])^V[I]u */
14233: QT = sftexp(QT,x,L[I],-V[I]);
14234: }
14235: if(V1[I]!=0)
14236: Q1T = sftexp(Q1T,x,L[I],-V1[I]);
14237: }
14238: C=red(mycoef(QT,D0T,dx)*mycoef(Q1,D1T,dx)/(mycoef(Q,D0T,dx)*mycoef(Q1T,D1T,dx)));
14239: Q=red(dn(C)*QT);Q1=red(nm(C)*Q1T);
14240: for(I = 1; I < NP; I++){
14241: if((J=V[I]-V1[I])!=0){
14242: if(J>0) Q1*=(x-L[I])^J;
14243: else Q*=(x-L[I])^(-J);
14244: }
14245: while((QT=tdiv(Q,x-L[I]))!=0){
14246: if((Q1T=tdiv(Q1,x-L[I]))!=0){
14247: Q=QT;Q1=Q1T;
14248: }else break;
14249: }
14250: }
14251: }
14252: P1=mysubst(P,SS);
14253: if(type(S0)==4 && S0!=[]){
14254: P=mysubst(P,S0); Q=mysubst(Q,S0);
14255: P1=mysubst(P1,S0); Q1=mysubst(Q1,S0);
14256: RS=mysubst(RS,S0); RS1=mysubst(RS1,S0);
14257: }
14258: R=mygcd(Q1,P1,[x,dx]);
14259: if(findin(dx,vars(R[0]))>=0){
14260: mycat("Some error!");
14261: return 0;
14262: }
14263: Q=muldo(R[1]/R[0],Q,[x,dx]);
14264: R=divdo(Q,P,[x,dx]);
14265: Q=red(R[1]/R[2]);
14266: R=fctr(nm(Q));
14267: QQ=Q/R[0][0];
14268: R1=fctr(dn(QQ));
14269: for(RR=cdr(R1); RR!=[]; RR=cdr(RR)){
14270: VT=vars(car(RR)[0]);
14271: if(findin(x,VT)<0 && findin(dx,VT)<0){
14272: for(I=car(RR)[1];I>0;I--) QQ=red(QQ*car(RR)[0]);
14273: }
14274: }
14275: Raw=getopt(raw);
14276: Dviout=getopt(dviout);
14277: if(Dviout==1) Raw=4;
14278: if(Raw!=1){
14279: for(RR=cdr(R); RR!=[]; RR=cdr(RR)){
14280: VT=vars(car(RR)[0]);
14281: if(findin(x,VT)<0 && findin(dx,VT)<0){
14282: for(I=car(RR)[1];I>0;I--) QQ=red(QQ/car(RR)[0]);
14283: }
14284: }
14285: }
14286: if(Raw==2||Raw==3||Raw==4){
14287: R=mygcd(QQ,P,[x,dx]); /* R[0]=R[1]*QQ + R[2]*P */
14288: Q1=red(R[0]/R[2]);
14289: for(Q=1,RR=cdr(fctr(nm(Q1))); RR!=[]; RR=cdr(RR)){
14290: VT=vars(car(RR)[0]);
14291: if(findin(x,VT)<0){
14292: for(I=car(RR)[1];I>0;I--) Q*=car(RR)[0];
14293: }
14294: }
14295: if(Raw==3) QQ=[QQ,Q];
14296: else if(Raw==4) /* Q=Q*R[1]/R[0]*QQ+Q/R[0]*P */
14297: QQ=[QQ,Q,red(R[1]*Q/R[0])];
14298: else QQ=Q;
14299: }
14300: F=getopt(all);
14301: if(Dviout==1){
14302: Pre = " x=\\infty & 0 & 1";
14303: for(I=3; I<NP; I++) Pre = Pre+"& "+rtostr(L[I]);
14304: Pre = Pre+"\\\\\n";
14305: PW=str_tb(ltotex(RS|opt="GRS",pre=Pre),0);
14306: str_tb(
14307: "=\\{u\\mid Pu=0\\}\\\\\n&\\underset{Q_2}{\\overset{Q_1}{\\rightleftarrows}}\n",PW);
14308: str_tb([ltotex(RS1|opt="GRS",pre=Pre),"\\\\\n"],PW);
14309: R=fctrtos(QQ[0]|TeX=3,var=[dx,"\\partial"]);
14310: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
14311: str_tb(["Q_1&=",R,"\\\\\n"],PW);
14312: R=fctrtos(QQ[2]|TeX=3,var=[dx,"\\partial"]);
14313: if(type(R)==4) R="\\frac1{"+R[1]+"}"+R[0];
14314: str_tb(["Q_2&=",R,"\\\\\n"],PW);
14315: str_tb(["Q_2Q_1&\\equiv ",fctrtos(QQ[1]|TeX=3),"\\mod W(x)P"],PW);
14316: if(F==1)
14317: str_tb(["\\\\\nP&=",fctrtos(P|TeX=3,var=[dx,"\\partial"])],PW);
14318: dviout(str_tb(0,PW)|eq=0,title="Shift Operator");
14319: }
14320: if(F==1) return [QQ,P,RS,P1,RS1];
14321: else if(F==0) return QQ;
14322: return [QQ,P,RS];
14323: }
14324:
14325: def conf1sp(M)
14326: {
14327: if(type(M)==7) M=s2sp(M);
14328: L0 = length(M);
14329: L1 = length(M[L0-1]);
14330: X2 = getopt(x2);
14331: Conf= getopt(conf);
14332: if(Conf != 0)
14333: Conf = -1;
14334: if((X2==1 || X2==-1) && Conf != 0){
14335: X1 = 0;
14336: X = x_1;
14337: }else{
14338: X1 = 1;
14339: X = x_2;
14340: }
14341: G = sp2grs(M,a,[L0,L1]);
14342: for(I = 0; I < L0-1; I++){
14343: V = makev([a,I-Conf,0]);
14344: G = subst(G,V,0);
14345: }
14346: L2 = length(M[1]);
14347: for(I=J=S0=S1=0; I < L2; I++){
14348: S1 += G[1][I][0];
14349: while(S0 < S1){
14350: S0 += G[0][J][0];
14351: if((V=G[0][J][1]) != 0)
14352: G = mysubst(G,[V,V-G[1][I][1]]);
14353: J++;
14354: }
14355: if(S0 > S1){
14356: print("Error in data!");
14357: return 0;
14358: }
14359: }
14360: if(Conf==0){
14361: for(L=[], I=L0-2; I>=0; I--)
14362: L=cons(I,L);
14363: L=cons(L0-1,L);
14364: P = getbygrs(G,["operator","x2"]|perm=L);
14365: }else if(X1)
14366: P = getbygrs(mperm(G,[[1,2]],[]), ["operator","x2"]);
14367: else
14368: P = getbygrs(G,["operator","x1"]);
14369: if(Conf==0)
14370: P=nm(mysubst(P,[X,c]));
14371: else{
14372: P = nm(mysubst(P,[X,1/c]));
14373: if(X2==-1){
14374: for(I=2; I<L0; I++){
14375: V=makev(["x_",I]); VC=makev([c,I]);
14376: P = nm(mysubst(P,[V,1/VC]));
14377: }
14378: }
14379: }
14380: for(I = 1; I < L2; I++){
14381: X = G[1][I][1];
14382: P = nm(mysubst(P,[X,X/c]));
14383: }
14384: VS = vars(P);
14385: while(VS!=[]){
14386: V = car(VS);
14387: if(str_chr(rtostr(V),0,"r")==0){
14388: CV = mycoef(P,1,V);
14389: D = mymindeg(CV,c);
14390: if(D > 0) P = mysubst(P,[V,V/c^D]);
14391: CV = mycoef(P,1,V);
14392: DD = mydeg(CV,dx);
14393: CVV = mycoef(CV,DD,dx);
14394: CD1 = mydeg(CVV,x);
14395: CD = (X==x1)?0:CD1;
14396: while(CD>=0 && CD<=CD1){
14397: CC = mycoef(CVV,CD,x);
14398: if(type(CC)==1){
14399: VT = mycoef(mycoef(mycoef(P,DD,dx),CD,x),0,V)/CC;
14400: if(VT != 0) P = mysubst(P,[V,V-VT]);
14401: break;
14402: }
14403: if(X==x1) CD++;
14404: else CD--;
14405: }
14406: while(subst(P,c,0,V,0) == 0)
14407: P = red(mysubst(P,[V,c*V])/c);
14408: }
14409: VS =cdr(VS);
14410: }
14411: return P;
14412: }
14413:
14414: def pgen(L,VV)
14415: {
14416: if(type(L[0])<4) L=[L];
14417: if(type(L)==4) L=ltov(L);
14418: K=length(L);
14419: V=newvect(K);
14420: if(type(Sum=getopt(sum))!=1) Sum=0;
14421: if((Num=getopt(num))!=1) Num=0;
14422: if((Sep=getopt(sep))!=1) Sep=0;
14423: if(type(Shift=getopt(shift))!=1) Shift=0;
14424: for(;;){
14425: for(PP=1,R=[],II=K-1; II>=0; II--){
14426: R=cons(V[II]+Shift,R);
14427: if(II>0 && Sep==1) R=cons("_",R);
14428: PP*=L[II][0]^V[II];
14429: }
14430: P+=makev(cons(VV,R)|num=Num)*PP;
14431: for(I=0;I<K;){
14432: if(++V[I]<=L[I][1]){
14433: if(Sum>0){
14434: for(S=II=0;II<K;) S+=V[II++];
14435: if(S>Sum){
14436: V[I++]=0;
14437: continue;
14438: }
14439: }
14440: }else{
14441: V[I++]=0;
14442: continue;
14443: }
14444: break;
14445: }
14446: if(I>=K) return P;
14447: }
14448: }
14449:
1.3 takayama 14450: def diagm(M,A)
14451: {
1.4 ! takayama 14452: return mgen(M,0,A,1);
1.3 takayama 14453: }
14454:
1.1 takayama 14455: def mgen(M,N,A,S)
14456: {
14457: if(M==0 && N==0){
14458: mycat([
14459: "mgen(m,n,a,s|sep=1) : generate a matrix of size m x n\n",
1.4 ! takayama 14460: " n : a number or \"diagonal\", \"highdiag\", \"lowdiag\",\"skew\",\"symmetric\",\"perm\" = 0,-1,-2,..\n",
1.1 takayama 14461: " a : a symbol or list (ex. a, [a], [a,b,c], [1,2,3])\n",
14462: " s : 0 or 1 (shift of suffix)\n"
14463: ]);
14464: return 0;
14465: }
1.4 ! takayama 14466: if(type(N)==7) N=-findin(N,["diag","highdiag","lowdiag","skew","symmetric","perm"]);
1.1 takayama 14467: Sep=(getopt(sep)==1)?1:0;
14468: if(S < 0 || S > 2)
14469: S = 0;
14470: if(M+S > 30 || N+S > 30){
14471: erno(1);
14472: return;
14473: }
1.4 ! takayama 14474: if(N==-5){
! 14475: NM=newmat(M,M);
! 14476: for(I=0;I<M;I++,A=cdr(A)) NM[I][car(A)-S]=1;
! 14477: return NM;
! 14478: }
1.1 takayama 14479: if(type(A) == 4)
14480: L = length(A)-1;
14481: else
14482: L = -1;
14483: if(N <= 0 && N >= -2){
14484: MM = newmat(M,M);
14485: J = K = 0;
14486: if(N == -1){
14487: K = 1; M--;
14488: }else if(N == -2){
14489: J = 1; M--;
14490: }
14491: for(I = 0; I < M; I++){
14492: if(L >= 0)
14493: MM[I+J][I+K] = A[(I > L)?L:I];
14494: else if(type(A)==7 || isvar(A))
14495: MM[I+J][I+K] = makev([A,S+I]|sep=Sep);
14496: else
14497: MM[I+J][I+K] = A;
14498: }
14499: return MM;
14500: }
14501: K = N;
14502: if(K < 0) N = M;
14503: MM = newmat(M,N);
14504: for(I = 0; I < M; I++){
14505: if(L >= 0)
14506: AA = rtostr(A[(I > L)?L:I]);
14507: else
14508: AA = rtostr(A)+rtostr(I+S);
14509: if(AA>="0" && AA<=":"){
14510: erno(0); return;
14511: }
14512: for(J = 0; J < N; J++){
14513: if(K < 0){
14514: if(I > J) continue;
14515: if(K == -3 && I == J) continue;
14516: }
14517: MM[I][J] = makev([AA,J+S]|sep=Sep);
14518: }
14519: }
14520: if(K < 0){
14521: for(I = 0; I < M; I++){
14522: for(J = 0; J < I; J++)
14523: MM[I][J] = (K == -4)?MM[J][I]:-MM[J][I];
14524: }
14525: }
14526: return MM;
14527: }
14528:
14529: def newbmat(M,N,R)
14530: {
14531: S = newvect(M);
14532: T = newvect(N);
14533: IM = length(R);
14534: for(I = 0; I < IM; I++){
14535: RI = R[I];
14536: JM = length(RI);
14537: for(J = 0; J < JM; J++){
14538: RIJ = RI[J];
14539: if(type(RIJ) == 6){
14540: S[I] = size(RIJ)[0];
14541: T[J] = size(RIJ)[1];
14542: }
14543: }
14544: }
14545: for(I = K = 0; I < M; I++){
14546: if(S[I] == 0)
14547: S[I] = 1;
14548: K += S[I];
14549: }
14550: for(J = L = 0; J < N; J++){
14551: if(T[J] == 0)
14552: T[J] = 1;
14553: L += T[J];
14554: }
14555: M = newmat(K,L);
1.3 takayama 14556: if(type(Null=getopt(null))>0){
14557: for(I=0;I<K;I++){
14558: for(J=0;J<L;J++) M[I][J]=Null;
14559: }
14560: }
1.1 takayama 14561: for(I0 = II = 0; II < IM; I0 += S[II++]){
14562: RI = R[II];
14563: JM = length(RI);
14564: for(J0 = JJ = 0; JJ < JM; J0 += T[JJ++]){
14565: if((RIJ = RI[JJ]) == 0)
14566: continue;
14567: Type = type(RIJ);
14568: for(I = 0; I < S[II]; I++){
14569: for(J = 0; J < T[JJ]; J++){
14570: if(Type == 6)
14571: M[I0+I][J0+J] = RIJ[I][J];
14572: else if(Type == 4 || Type == 5)
14573: M[I0+I][J0+J] = (I>0)?RIJ[I]:RIJ[J];
14574: else
14575: M[I0+I][J0+J] = RIJ;
14576: }
14577: }
14578: }
14579: }
14580: return M;
14581: }
14582:
1.4 ! takayama 14583: def unim(S)
! 14584: {
! 14585: if(!Rand++) random(currenttime());
! 14586: if(!isint(Wt=getopt(wt))||Wt<0||Wt>10) Wt=2;
! 14587: if(!isint(Xa=getopt(abs)) || Xa<1)
! 14588: Xa=9;
! 14589: if((Xaa=Xa)>10) Xaa=10;
! 14590: if(Xaa%2) Xaa++;
! 14591: Xh=Xaa/2;
! 14592: if(type(S0=SS=S)==4){
! 14593: Int=(getopt(int)==1)?1:0;
! 14594: U=[1,1,1,1,1,1,1,1,1,1,1,1,2,2,3,4];
! 14595: M=newmat(S[0],S[1]);
! 14596: SS=cdr(S);SS=cdr(SS);
! 14597: if(Rk=length(SS)) L=SS;
! 14598: else{
! 14599: L=[0];
! 14600: I=(S[0]>S[1])?S[1]:S[0];
! 14601: if(I<=2) return 0;
! 14602: if(!isint(Rk=getopt(rank))||Rk<1||Rk>S[0]||Rk>S[1])
! 14603: Rk=random()%(I-1)+2;
! 14604: for(I=1;I<Rk;){
! 14605: P=random()%(S[1]+Wt)-Wt;
! 14606: if(P<=0) P=1;
! 14607: if(findin(P,L)!=0){
! 14608: L=cons(P,L);
! 14609: I++;
! 14610: }
! 14611: }
! 14612: }
! 14613: L=ltov(qsort(L));
! 14614: M[0][L[0]]=1;
! 14615: for(I=1;I<Rk;I++){
! 14616: P=Int?1:U[random()%length(U)];
! 14617: if(P>Xa) P=Xa;
! 14618: M[I][L[I]]=(random()%2)?P:(-P);
! 14619: }
! 14620: for(I=0;I<Rk;I++){
! 14621: if(I!=0&&abs(M[I][L[I]])>1) M[K=random()%I][KK=L[I]]=1;
! 14622: I0=(I==0)?1:L[I]+1;
! 14623: I1=(I==Rk-1)?S[1]:L[I+1];
! 14624: for(J=I0;J<I1;J++){
! 14625: for(K=1;K<=Xa;K++){
! 14626: P=random()%(I+1);
! 14627: if((random()%2)==1) M[P][J]++;
! 14628: else M[P][J]--;
! 14629: }
! 14630: }
! 14631: }
! 14632: S=M;
! 14633: Res=(getopt(res)==1)?dupmat(S):0;
! 14634: }
! 14635: Conj=0;
! 14636: if(type(S)<2){
! 14637: if(S<2||S>20) return 0;
! 14638: if(getopt(conj)==1){
! 14639: M=S+Wt;
! 14640: if(M>15) M=10;
! 14641: M0=floor((M-1)/2);
! 14642: for(R=[],I=0;I<S;I++) R=cons(random()%M-M0,R);
! 14643: R=qsort(R);
! 14644: M=diagm(S,R);
! 14645: if(getopt(diag)!=1){
! 14646: for(I=1;I<S;I++)
! 14647: if(M[I-1][I-1]==M[I][I] && random()%2) M[I-1][I]=1;
! 14648: }
! 14649: if(M[0][0]==M[S-1][S-1]){
! 14650: for(I=1;I<S;I++) if(M[I-1][I]==1) break;
! 14651: if(I==S){
! 14652: if(M[0][0]>0) M[0][0]--;
! 14653: else M[S-1][S-1]++;
! 14654: }
! 14655: }
! 14656: if(getopt(res)==1) RR=diagm(S,[1]);
! 14657: S1=S;
! 14658: Res=dupmat(S=M);
! 14659: if(isint(I=getopt(int))&&I>1&&random()%I==0){
! 14660: K=S[0][0];L=K+1;
! 14661: for(I=1;I<S1;I++){
! 14662: if(S[I][I]>L && S[I-1][I]==0 && (I==S1-1||S[I][I+1]==0)){
! 14663: L=S[I][I];
! 14664: if(RR){
! 14665: RR[I][I]=L-K;RR[0][I]=1;
! 14666: /* S=RR*S*myinv(RR); */
! 14667: }
! 14668: S[0][I]=1;
! 14669: if(!(random()%3)) break;
! 14670: }
! 14671: }
! 14672: if(random()%3==0){
! 14673: for(I=0;I<S1-1;I++){
! 14674: if(iand(S[I][I],1)&&S[I][I+1]==1){
! 14675: for(J=I+2;J<S1&&S[I][J]==0;J++);
! 14676: if(J<S1) continue;
! 14677: for(J=I-1;J>=0&&S[J][I]==0;J--);
! 14678: if(J>=0) continue;
! 14679: S[I][I+1]=2;
! 14680: for(J=0;J<S1;J++) RR[I][J]*=2;
! 14681: break;
! 14682: }
! 14683: }
! 14684: }
! 14685: }
! 14686: }else{
! 14687: M=diagm(S,[1]);
! 14688: S1=S;
! 14689: }
! 14690: }
! 14691: if(type(S)==6){
! 14692: M=dupmat(S);
! 14693: S=size(S);
! 14694: S1=S[1];S=S[0];
! 14695: Nt=1;
! 14696: if(getopt(conj)==1&&S==S1) Conj=1;
! 14697: }
! 14698: if(!isint(Ct=getopt(time)))
! 14699: Ct=(S>3||S1>3)?100:200;
! 14700: if(getopt(both)==1){
! 14701: OL=delopt(getopt(),"both");
! 14702: M=unim(mtranspose(M)|option_list=OL);
! 14703: M=mtranspose(M);
! 14704: }
! 14705: Mx=20;
! 14706: for(I=K=LL=0;I<Ct+Mx;I++){
! 14707: P=random()%S;Q=random()%S;
! 14708: if(3*K>Ct) T=random()%Xaa-Xh;
! 14709: else if(5*K<Ct) T=random()%2-1;
! 14710: else T=random()%4-2;
! 14711: if(T>=0) T++;
! 14712: if(P==Q) continue;
! 14713: for(G=0,J=S1-1;J>=0;J--){
! 14714: if((H=abs(M[Q][J]+M[P][J]*T))>Xa&&(!Conj||J!=P)) break;
! 14715: if(K<Mx&&!Conj) G=igcd(G,H);
! 14716: }
! 14717: if(K<Mx && G>1) J=1;
! 14718: if(J>0) continue;
! 14719: if(J<0&&Conj==1){
! 14720: for(J=S1-1;J>=0;J--)
! 14721: if(J!=Q&&abs(M[J][P]-M[J][Q]*T)>Xa) break;
! 14722: if(J<0&&abs(M[Q][P]-M[Q][Q]*T+M[P][P]*T-M[P][Q]*T^2)>Xa) J=1;
! 14723: if(J<0&&M[P][P]==M[Q][Q]){
! 14724: LF=0;
! 14725: for(L=S1-1;J>=0;J--) if(L!=Q&&M[J][Q]!=0) LF++;
! 14726: for(L=S1-1;J>=0;J--) if(L!=P&&M[P][J]!=0) LF++;
! 14727: if(!LF) J=1;
! 14728: }
! 14729: }
! 14730: if(J<0){
! 14731: for(J=S1-1;J>=0;J--)
! 14732: M[Q][J]+=M[P][J]*T;
! 14733: if(Conj==1)
! 14734: for(J=S1-1;J>=0;J--) M[J][P]-=M[J][Q]*T;
! 14735: if(RR) for(J=S1-1;J>=0;J--) RR[Q][J]+=RR[P][J]*T;
! 14736: K++;
! 14737: }
! 14738: if(!Nt&&K%5==0) M=mtranspose(M);
! 14739: if(I>Ct){
! 14740: for(L=S-1;L>=0;L--){
! 14741: for(F=0,J=S1-1;J>=0;J--)
! 14742: if(M[L][J]!=0) F++;
! 14743: if(F<2){
! 14744: F=-1;break;
! 14745: }
! 14746: else F=0;
! 14747: }
! 14748: if(F<0 && LL++<5){
! 14749: I=(CT-CT%2)/2;K=1;
! 14750: }
! 14751: if(I>Ct) break;
! 14752: }
! 14753: }
! 14754: if(RR){
! 14755: for(I=F=0;I<S1;I++){
! 14756: V=Res[I][I];
! 14757: for(J=I+1;J<S1;J++){
! 14758: if(Res[J][J]!=V) break;
! 14759: for(LP=0;LP<2;LP++){
! 14760: if(J==S1-1||Res[J][J+1]==0){
! 14761: if(I==0||Res[I-1][I]==0){
! 14762: for(VL=VS=[],K=0;K<S1;K++){
! 14763: VL=cons(RR[K][J],VL);VS=cons(RR[K][I],VS);
! 14764: }
! 14765: VR=ldev(VL,VS);
! 14766: if(VR[0]){
! 14767: for(K=S1-1,VN=VR[1];K>=0;K--,VN=cdr(VN))
! 14768: RR[K][J]=car(VN);
! 14769: F=1;
! 14770: }
! 14771: }
! 14772: }
! 14773: K=I;I=J;J=K;
! 14774: }
! 14775: }
! 14776: if(F&&I==S1-1){
! 14777: F=0;I=-1;
! 14778: }
! 14779: }
! 14780: if(getopt(int)==1){
! 14781: N=mtranspose(M);
! 14782: for(F=I=0;I<S1;I++) if(lgcd(M[I])>1||lgcd(N[I])>1) F++;
! 14783: if(F){
! 14784: for(F=I=0;I<S1;I++){
! 14785: if(Res[I][I]==-1) F=ior(F,1);
! 14786: else if(Res[I][I]==1) F=ior(F,2);
! 14787: }
! 14788: C=0;
! 14789: if(!iand(F,1)) C=1;
! 14790: else if(!iand(F,2)) C=-1;
! 14791: if(C){
! 14792: for(I=0;I<S1;I++){
! 14793: M[I][I]+=C;Res[I][I]+=C;
! 14794: }
! 14795: }
! 14796: }
! 14797: }
! 14798: if(getopt(rep)!=1){
! 14799: for(Lp=0;Lp<5;Lp++){
! 14800: F=(M==Res||abs(lmax(RR))>Xa*10||abs(lmin(RR))>Xa*10)?1:0;
! 14801: for(I=0;!F&&I<S1&&Lp<4;I++){
! 14802: for(K=L=J=0;J<S1;J++){
! 14803: if(M[I][J]) K++;
! 14804: if(M[J][I]) L++;
! 14805: }
! 14806: if(K<2||L<2) F=1;
! 14807: }
! 14808: if(!F) break;
! 14809: R=unim(S0|option_list=cons(["rep",1],getopt()));
! 14810: M=R[0];Res=R[1];RR=R[3];
! 14811: }
! 14812: }
! 14813: }
! 14814: /* if(RR && M*RR!=RR*Res) mycat("Error"); */
! 14815: if(Res==0) return M;
! 14816: if(getopt(rep)!=1){
! 14817: if((F=getopt(dviout))==1){
! 14818: if(getopt(conj)==1){
! 14819: if(RR) show([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
! 14820: }else{
! 14821: if(type(Lim=getopt(lim))==1)
! 14822: mtoupper(M,0|step=1,opt=7,dviout=1,pages=1,lim=Lim);
! 14823: else mtoupper(M,0|step=1,opt=7,dviout=1,pages=1);
! 14824: }
! 14825: }else if(F==-1){
! 14826: if(getopt(conj)==1){
! 14827: if(RR) return ltotex([Res,"=",myinv(RR),M,RR]|opt="spts0",str=1,lim=200);
! 14828: }else{
! 14829: if(type(Lim=getopt(lim))==1)
! 14830: return mtoupper(M,0|step=1,opt=7,pages=1,lim=Lim,dviout=-1);
! 14831: else return mtoupper(M,0|step=1,opt=7,pages=1,dviout=-1);
! 14832: }
! 14833: }
! 14834: }
! 14835: return (RR==0)?[M,Res]:[M,Res,myinv(RR),RR];
! 14836: }
! 14837:
1.1 takayama 14838: def pfrac(F,X)
14839: {
14840: F = red(F);
14841: FN = nm(F);
14842: FD = dn(F);
14843: if(mydeg(FD,X) == 0)
14844: return [[F,1,1]];
14845: R = rpdiv(FN,FD,X);
14846: FN = R[0]/R[1];
14847: R0 = R[2]/R[1];
14848: FC = fctr(FD);
1.4 ! takayama 14849: RT=[];
! 14850: if(getopt(root)==2){
! 14851: for(FE=[],FT=FC;FT!=[];FT=cdr(FT)){
! 14852: if(mydeg(P=car(FT)[0],X)==4 && vars(P)==[X] && pari(issquare,C=mycoef(P,4,X))){
! 14853: if((S=mycoef(P,3,X)/4/C)!=0) P=subst(P,X,X-S);
! 14854: if(mycoef(P,1,X)==0 && pari(issquare,C0=mycoef(P,0,X))){
! 14855: C=sqrtrat(C);C0=sqrtrat(C0);C1=2*C*C0-mycoef(P,2,X);
! 14856: if(C1>0){
! 14857: FE=cons([C*(X+S)^2-C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
! 14858: FE=cons([C*(X+S)^2+C1^(1/2)*(X+S)+C0,car(FT)[1]],FE);
! 14859: RT=cons(C1,RT);
! 14860: continue;
! 14861: }
! 14862: }
! 14863: }
! 14864: FE=cons(car(FT),FE);
! 14865: }
! 14866: FC=reverse(FE);
! 14867: }
1.1 takayama 14868: N = Q = 0;
14869: L = [];
14870: for(I = length(FC)-1; I >= 0; I--){
14871: if((D = mydeg(FC[I][0],X)) == 0) continue;
14872: for(K=1; K<=FC[I][1]; K++){
14873: for(J=P=0; J < D; J++){
14874: V = makev(["zz_",++N]);
14875: P = P*X + V;
14876: L = cons(V,L);
14877: }
14878: Q += P/(FC[I][0]^K);
14879: Q = red(Q);
14880: }
14881: }
14882: L=reverse(L);
14883: Q = nm(red(red(Q*FD)-FN));
14884: Q = ptol(Q,X);
14885: S = lsol(Q,L);
14886: R = (R0==0)?[]:[[R0,1,1]];
14887: for(N=0,I=length(FC)-1; I >= 0; I--){
14888: if((D = mydeg(FC[I][0],X)) == 0) continue;
14889: for(K=1; K<=FC[I][1]; K++){
14890: for(P=J=0; J < D; N++,J++)
14891: P = P*X + S[N][1];
1.4 ! takayama 14892: if(P!=0) R = cons([P,FC[I][0],K],R);
1.1 takayama 14893: }
14894: }
1.4 ! takayama 14895: for(;RT!=[];RT=cdr(RT)){
! 14896: RTT=car(RT);
! 14897: R=mtransbys(os_md.substblock,R,[RTT^(1/2),(RTT^(1/2))^2,RTT]);
! 14898: }
1.1 takayama 14899: TeX=getopt(TeX);
14900: if((Dvi=getopt(dviout))==1||TeX==1){
14901: V=strtov("0");
14902: for(S=L=0,RR=R;RR!=[];RR=cdr(RR),L++){
14903: RT=car(RR);
14904: S+=(RT[0]/RT[1]^RT[2])*V^L;
14905: }
14906: if(TeX!=1) fctrtos(S|var=[V,""],dviout=1);
14907: else return fctrtos(S|var=[V,""],TeX=3);
14908: }
14909: return reverse(R);
14910: }
14911:
14912: def cfrac(X,N)
14913: {
14914: F=[floor(X)];
14915: if(N<0){
14916: Max=N=-N;
14917: }
14918: X-=F[0];
14919: if(Max!=1)
14920: M=mat([F[0],1],[1,0]);
14921: for(;N>0 && X!=0;N--){
14922: X=1/X;
14923: F=cons(Y=floor(X),F);
14924: X-=Y;
14925: if(Max){
14926: M0=M[0][0];M1=M[1][0];
14927: M=M*mat([Y,1],[1,0]);
14928: if(M[0][0]>Max) return M0/M1;
14929: }
14930: }
14931: return (Max==0)?reverse(F):M[0][0]/M[1][0];
14932: }
14933:
1.4 ! takayama 14934: def sqrt2rat(X)
! 14935: {
! 14936: if(type(X)>3) return X;
! 14937: X=red(X);
! 14938: if(getopt(mult)==1){
! 14939: for(V=vars(X);V!=[];V=cdr(V)){
! 14940: T=funargs(F=car(V));
! 14941: if(type(T)==4&&length(T)>1){
! 14942: Y=T[1];
! 14943: Z=sqrt2rat(Y);
! 14944: if(Y!=Z){
! 14945: if(length(T)==2){
! 14946: T0=T[0];
! 14947: X=subst(X,F,T0(Z));
! 14948: }else if(T[0]==pow)
! 14949: X=subst(X,F,Y^T[2]);
! 14950: }
! 14951: }
! 14952: }
! 14953: }
! 14954: for(V=vars(X);V!=[];V=cdr(V)){ /* r(x)^(1/2+n) -> r(x)^n*r(x)^(1/2) */
! 14955: T=args(Y=car(V));
! 14956: if(functor(Y)==pow&&T[1]!=1/2&&isint(T2=2*T[1])){
! 14957: if(iand(T2,1)){
! 14958: R=(T[0])^(1/2);T2--;
! 14959: }else R=1;
! 14960: R*=T[0]^(T2/2);
! 14961: X=red(subst(X,Y,R));
! 14962: }
! 14963: }
! 14964: D=dn(X);N=nm(X);
! 14965: if(imag(D)!=0){
! 14966: N*=conj(D);
! 14967: D*=conj(D);
! 14968: return sqrt2rat(N/D);
! 14969: }
! 14970: for(V=vars(N);V!=[];V=cdr(V)){ /* (r(x)^(n/m))^k */
! 14971: T=args(Y=car(V));
! 14972: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
! 14973: Dn=dn(T[1]);Nm=nm(T[1]);
! 14974: N=substblock(N,Y,Y^Dn,T[0]^Nm);
! 14975: }
! 14976: }
! 14977: for(V=vars(D);V!=[];V=cdr(V)){
! 14978: T=args(Y=car(V));
! 14979: if(functor(Y)==pow&&(T[1]==0||(type(T[1])==1&&ntype(T[1])==0))){
! 14980: Dn=dn(T[1]);Nm=nm(T[1]);
! 14981: D=substblock(D,Y,Y^Dn,T[0]^Nm);
! 14982: }
! 14983: }
! 14984: for(V=vars(D);V!=[];V=cdr(V)){
! 14985: T=args(Y=car(V));
! 14986: if(functor(Y)==pow&&T[1]==1/2&&mydeg(D,Y)==1){
! 14987: N*=mycoef(D,0,Y)-mycoef(D,1,Y)*Y;
! 14988: N=mycoef(N,0,Y)+mycoef(N,1,Y)*Y+mycoef(N,2,Y)*T[0];
! 14989: D=mycoef(D,0,Y)^2-mycoef(D,1,Y)^2*T[0];
! 14990: X=red(N/D);
! 14991: D=dn(X);N=nm(X);
! 14992: break;
! 14993: }
! 14994: }
! 14995: X=red(N/D);
! 14996: D=dn(X);N=nm(X);
! 14997: for(V=vars(D);V!=[];V=cdr(V)){
! 14998: T=args(Y=car(V));
! 14999: if(functor(Y)==pow&&T[1]==1/2)
! 15000: D=substblock(D,T[0]^T[1],(T[0]^T[1])^2,T[0]);
! 15001: }
! 15002: for(V=vars(N);V!=[];V=cdr(V)){
! 15003: T=args(Y=car(V));
! 15004: if(functor(Y)==pow&&T[1]==1/2)
! 15005: N=substblock(N,T[0]^T[1],(T[0]^T[1])^2,T[0]);
! 15006: }
! 15007: for(V=vars(N);V!=[];V=cdr(V)){
! 15008: T=args(Y=car(V));
! 15009: if(functor(Y)==pow&&T[1]==1/2){
! 15010: Ag=T[0];
! 15011: R=S=1;
! 15012: An=fctr(nm(Ag));
! 15013: CA=An[0][0];
! 15014: if(CA<0){
! 15015: CA=-CA;R=-1;
! 15016: }
! 15017: if(type(I=sqrtrat(CA))<2) S=I;
! 15018: else R*=CA;
! 15019: for(An=cdr(An);An!=[];An=cdr(An)){
! 15020: Pw=car(An)[1];I=iand(Pw,1);
! 15021: if(I) R*=car(An)[0];
! 15022: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
! 15023: }
! 15024: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
! 15025: Pw=car(An)[1];I=iand(Pw,1);
! 15026: if(I) R/=car(An)[0]^I;
! 15027: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
! 15028: }
! 15029: if(S!=1) N=subst(N,Y,R^(1/2)*S);
! 15030: }
! 15031: }
! 15032: for(V=vars(N);V!=[];V=cdr(V)){
! 15033: T=args(Y=car(V));
! 15034: if(functor(Y)==pow&&T[1]==1/2){
! 15035: C=mycoef(N,1,Y);
! 15036: for(VC=vars(C);VC!=[];VC=cdr(VC)){
! 15037: TC=args(YC=car(VC));
! 15038: if(functor(YC)==pow&&TC[1]==1/2){
! 15039: Ag=red(T[0]*TC[0]);
! 15040: R=S=1;
! 15041: An=fctr(nm(Ag));
! 15042: CA=An[0][0];
! 15043: if(CA<0){
! 15044: CA=-CA;R=-1;
! 15045: }
! 15046: if(type(I=sqrtrat(CA))<2) S=I;
! 15047: else R*=CA;
! 15048: for(An=cdr(An);An!=[];An=cdr(An)){
! 15049: Pw=car(An)[1];I=iand(Pw,1);
! 15050: if(I) R*=car(An)[0];
! 15051: if((Q=(Pw-I)/2)>0) S*=car(An)[0]^Q;
! 15052: }
! 15053: for(An=fctr(dn(Ag));An!=[];An=cdr(An)){
! 15054: Pw=car(An)[1];I=iand(Pw,1);
! 15055: if(I) R/=car(An)[0]^I;
! 15056: if((Q=(Pw-I)/2)>0) S/=car(An)[0]^Q;
! 15057: }
! 15058: CC=mycoef(C,1,YC);
! 15059: N=N-CC*YC*Y+CC*R^(1/2)*S;
! 15060: }
! 15061: }
! 15062: }
! 15063: }
! 15064: return red(N/D);
! 15065: }
! 15066:
1.1 takayama 15067: def cfrac2n(X)
15068: {
1.4 ! takayama 15069: if(type(L=getopt(loop))==1&&L>0)
! 15070: C=x;
! 15071: else{
! 15072: C=0;L=0;
! 15073: }
! 15074: if(L>1){
! 15075: for(Y=[];L>1;L--){
! 15076: Y=cons(car(X),Y);
! 15077: X=cdr(X);
! 15078: }
! 15079: if(X!=[]){
! 15080: P=cfrac2n(X|loop=1);
! 15081: for(V=P,Y=reverse(Y);Y!=[];Y=cdr(Y))
! 15082: V=sqrt2rat(car(Y)+1/V);
! 15083: return V;
! 15084: }else{
! 15085: C=0;X=reverse(Y);
! 15086: }
! 15087: }
! 15088: for(V=C,X=reverse(X);X!=[];X=cdr(X)){
1.1 takayama 15089: if(V!=0) V=1/V;
15090: V+=car(X);
15091: }
1.4 ! takayama 15092: if(C!=0){
! 15093: V=red(V);P=dn(V)*x-nm(V);
! 15094: S=getroot(P,x|cpx=2);
! 15095: T=map(eval,S);
! 15096: V=(T[0]>0)?S[0]:S[1];
! 15097: }
1.1 takayama 15098: return V;
15099: }
15100:
15101: def s2sp(S)
15102: {
15103: if(type(S)==7){
15104: S = strtoascii(S);
15105: if(type(S) == 5) S = vtol(S);
15106: for(N=0,R=TR=[]; S!=[]; S=cdr(S)){
15107: if(car(S)==45) /* - */
15108: N=1;
15109: else if(car(S)==47) /* / */
15110: N=2;
15111: if(N>0){
15112: while(car(S)<48&&car(S)!=40) S=cdr(S);
15113: }
15114: if((T=car(S))>=48 && T<=57) TR=cons(T-48,TR);
15115: else if(T>=97) TR=cons(T-87,TR);
15116: else if(T>=65 && T<=90) TR=cons(T-29,TR); /* A-Z */
15117: else if(T==44){
15118: R=cons(reverse(TR),R);
15119: TR=[];
15120: }else if(T==94){ /* ^ */
15121: S=cdr(S);
15122: if(car(S)==40){ /* ( */
15123: S=cdr(S);
15124: for(T=0; car(S)!=41 && S!=[]; S=cdr(S)){
15125: V=car(S)-48;
15126: if(V>=10) V-=39;
15127: T=10*T+V;
15128: }
15129: }else{
15130: while(car(S)<48) S=cdr(S);
15131: T=car(S)-48;
15132: if(T>=10) T-=39;
15133: }
15134: while(--T>=1) TR=cons(car(TR),TR);
15135: }else if(T==40){ /* ( */
15136: S=cdr(S);
15137: if(N==1){
15138: N=0; NN=1;
15139: }else NN=0;
15140: if(car(S)==45){ /* - */
15141: S=cdr(S);
15142: NN=1-NN;
15143: }
15144: for(I=0; I<2; I++){
15145: for(V=0; (SS=car(S))!=41 && SS!=47 && S!=[]; S=cdr(S)){
15146: T=SS-48;
15147: if(T>=10) T-=39;
15148: V=10*V+T;
15149: }
15150: if(NN==1){
15151: V=-V; NN=0;
15152: }
15153: TR=cons(V,TR);
15154: if(SS!=47) break;
15155: else{
15156: N=2; S=cdr(S);
15157: }
15158: }
1.4 ! takayama 15159: }else if(T==60){
! 15160: for(V=[],S=cdr(S);S!=[]&&car(S)!=62;S=cdr(S))
! 15161: V=cons(car(S),V);
! 15162: if(car(S)!=62) continue;
! 15163: TR=cons(eval_str(asciitostr(reverse(V))),TR);
1.1 takayama 15164: }else if(T<48) continue;
15165: if(N==1){
15166: T = car(TR);
15167: TR=cons(-T,cdr(TR));
15168: N=0;
15169: }else if(N==2){
15170: T=car(TR); TR=cdr(TR);
15171: TR=cons(car(TR)/T,cdr(TR));
15172: N=0;
15173: }
15174: }
15175: return reverse(cons(reverse(TR),R));
15176: }else if(type(S)==4){
15177: Num=getopt(num);
15178: for(R=[]; ; ){
1.4 ! takayama 15179: if(type(TS=car(S))!=4) return;
! 15180: for(; TS!=[]; TS=cdr(TS)){
1.1 takayama 15181: V=car(TS);
1.4 ! takayama 15182: if(type(V)>1||(type(V)==1&&ntype(V)>0)){
! 15183: V="<"+rtostr(V)+">";
! 15184: R=append(reverse(strtoascii(V)),R);
! 15185: continue;
! 15186: }
1.1 takayama 15187: if(dn(V)>1){
15188: P=reverse(strtoascii(rtostr(V)));
15189: R=append(P,cons(40,R));
15190: R=cons(41,R);
15191: continue;
15192: }
15193: if(V<0 && V>-10){
15194: V=-V;
15195: R=cons(45,R);
15196: }
15197: if(V<0 || V>35 || (V>9 && Num==1)){
15198: P=reverse(strtoascii(rtostr(V)));
15199: R=append(P,cons(40,R));
15200: V=41;
15201: }else if(V<10) V+=48;
15202: else V+=87;
15203: R=cons(V,R);
15204: }
15205: if((S=cdr(S))==[]) break;
15206: R=cons(44,R);
15207: }
15208: return asciitostr(reverse(R));
15209: }
15210: return 0;
15211: }
15212:
15213: def sp2grs(M,A,L)
15214: {
15215: MM = [];
15216: T0 = 0;
15217: Mat=getopt(mat);
15218: if(Mat!=1) Mat=0;
15219: if(type(M)==7) M=s2sp(M);
15220: if((LM = length(M)) > 10 && type(A) < 4)
15221: CK = 1;
15222: Sft = (type(L)==1)?L:0;
15223: if(type(L)==4 && length(L)>=3)
15224: Sft = L[2];
15225: if(Sft < 0){
15226: T0 = 1;
15227: Sft = -Sft-1;
15228: }
15229: for(I = LM-1; I >= 0; I--){
15230: MI = M[I]; MN = [];
15231: if(CK == 1 && length(MI) > 10){
15232: erno(1);
15233: return;
15234: }
15235: if(type(A) == 4)
15236: AA = rtostr(A[I]);
15237: else
15238: AA = rtostr(A)+rtostr(I);
15239: for(J = LM = length(MI)-1; J >= 0; J--){
15240: V = MI[J];
15241: if(type(V) > 3)
15242: V = V[0];
15243: if(T0 == 0 || I == 0)
15244: MN = cons([V, makev([AA,J+Sft])], MN);
15245: else{
15246: if(LM == 1)
15247: MN = cons([V, (J==0)?0:makev([AA])], MN);
15248: else if(I == 1 && Mat == 0)
15249: MN = cons([V, (J==length(MI)-1)?0:makev([AA,J+Sft])], MN);
15250: else
15251: MN = cons([V, (J==0)?0:makev([AA,J])], MN);
15252: }
15253: }
15254: MM = cons(MN, MM);
15255: }
15256: if(type(L) == 4 && length(L) >= 2){
15257: R = chkspt(MM|mat=Mat); /* R[3]: Fuchs */
15258: AA = var(MM[L[0]-1][L[1]-1][1]);
15259: if(AA==0) AA=var(R[3]);
15260: if(AA!=0 && (P = mycoef(R[3],1,AA))!=0){
15261: P = -mycoef(R[3], 0, AA)/P;
15262: MM = mysubst(MM,[AA,P]);
15263: }
15264: }
15265: return MM;
15266: }
15267:
15268: def intpoly(F,X)
15269: {
1.4 ! takayama 15270: if((T=ptype(F,X))<4){
! 15271: if(T<3){ /* polynomial */
! 15272: if(type(C=getopt(cos))>0){
! 15273: V=vars(F);
! 15274: Z=makenewv(V);
! 15275: W=makenewv(cons(Z,V));
! 15276: Q=intpoly(F,X|exp=Z);
! 15277: Q=(subst(Q,Z,@i*C)*(Z+@i*W)+subst(Q,Z,-@i*C)*(Z-@i*W))/2;
! 15278: return [mycoef(Q,1,Z),mycoef(Q,1,W)];
! 15279: }
! 15280: if(type(C=getopt(sin))>0){
! 15281: Q=intpoly(F,X|cos=C);
! 15282: return [-Q[1],Q[0]];
! 15283: }
! 15284: if(type(C=getopt(log))>0){
! 15285: Q=intpoly(F,X);
! 15286: if(C[0]==0) return [Q,0];
! 15287: if(length(C)<3) C=[C[0],C[1],1];
! 15288: Q-=subst(Q,X,-C[1]/C[0]);
! 15289: if(iscoef(Q,os_md.israt)) Q=red(Q);
! 15290: if(C[2]==0) return [Q];
! 15291: S=subst(-Q*C[0]*C[2],X,X-C[1]/C[0]);
! 15292: for(R=0,D=mydeg(S,X);D>0;D--) R+=mycoef(S,D,X)*X^(D-1);
! 15293: R=subst(R,X,X+C[1]/C[0]);
! 15294: return cons(Q,intpoly(R,X|log=[C[0],C[1],C[2]-1]));
! 15295: }
! 15296: if(type(C=getopt(exp))>0){
! 15297: D = mydeg(F,X);
! 15298: for(P=Q=F/C;D>=0;D--){
! 15299: Q=-mydiff(Q,X)/C;
! 15300: P+=Q;
! 15301: }
! 15302: return P;
! 15303: }
! 15304: for(P=0,I=mydeg(F,X);I >= 0;I--)
! 15305: P += mycoef(F,I,X)*X^(I+1)/(I+1);
! 15306: return P;
! 15307: }
! 15308: R=pfrac(F,X|root=2); /* rational */
! 15309: for(P=0;R!=[];R=cdr(R)){
! 15310: if(type(V=getopt(dumb))==5){
! 15311: for(PF=[],RR=R;RR!=[];RR=cdr(RR))
! 15312: PF=cons(RR[0][0]/RR[0][1]^RR[0][2],PF);
! 15313: PF=[cons(X,reverse(PF))];
! 15314: if(P) PF=cons([1,P],PF);
! 15315: V[0]=cons(PF,V[0]);
! 15316: }
! 15317: RT=car(R);
! 15318: if(mydeg(RT[1],X)==0) P+=intpoly(RT[0]*RT[2],X);
! 15319: else if((Deg=mydeg(RT[1],X))==1){
! 15320: if(RT[2]>1) P+=RT[0]*RT[1]^(1-RT[2])/(1-RT[2])/mycoef(RT[1],1,X);
! 15321: else P+=RT[0]*log(RT[1])/mycoef(RT[1],1,X);
! 15322: P=red(P);
! 15323: }else if(Deg==2){
! 15324: D1=diff(RT[1],X);C1=mycoef(D1,1,X);
! 15325: B=2*C1*mycoef(RT[1],0,X)-mycoef(RT[1],1,X)^2; /* ax^2+bx+c => B=4ac-b^2 */
! 15326: B=sqrt2rat(B);
! 15327: N=RT[0];
! 15328: for(I=RT[2];I>0&&N!=0;I--){
! 15329: C0=mycoef(N,1,X)/C1;N-=C0*D1;
! 15330: if(C0){
! 15331: if(I>1) P-=C0/RT[1]^(I-1)/(I-1);
! 15332: else P+=C0*log(RT[1]);
! 15333: }
! 15334: if(I>1){
! 15335: BB=B/C1;
! 15336: P+=N*X/RT[1]^(I-1)/(I-1)/BB;
! 15337: N*=(2*I-3)/(I-1)/BB;
! 15338: }else{
! 15339: if(type(BR=sqrtrat(B))>3){
! 15340: mycat(["Cannot obtain sqare root of ",B]);
! 15341: return [];
! 15342: }
! 15343: if(real(nm(BR))!=0){
! 15344: P+=(2*N/BR)*atan(sqrt2rat(D1/BR|mult=1));
! 15345: }else{
! 15346: BR*=@i;BRI=sqrt2rat(1/BR);
! 15347: R1=(-mycoef(RT[1],1,X)+BR)/C1;
! 15348: R2=(-mycoef(RT[1],1,X)-BR)/C1;
! 15349: P+=N*BRI*log( /* sqrt2rat */((x-R1)/(x-R2)));
! 15350: }
! 15351: }
! 15352: P=red(P);
! 15353: }
! 15354: P=sqrt2rat(P);
! 15355: }else{
! 15356: mycat(["Cannot get an indefinite integral of ",F]);
! 15357: return [];
! 15358: }
! 15359: }
! 15360: Q=simplog(P,X);
! 15361: if(type(V)==5&&nmono(P)!=nmono(Q)) V[0]=cons([[1,red(P)]],V[0]);
! 15362: return red(Q);
! 15363: }
! 15364: return [];
! 15365: }
! 15366:
! 15367: def fshorter(P,X)
! 15368: {
! 15369: Q=sqrt2rat(P);
! 15370: R=trig2exp(Q,X|inv=1);
! 15371: if(str_len(fctrtos(R))<str_len(fctrtos(Q))) Q=R;
! 15372: Var=pfargs(Q,X|level=1);
! 15373: for(C=F=0,R=1,V=Var;V!=[];V=cdr(V)){
! 15374: if(findin(car(V)[1],[cos,sin,tan])>=0){
! 15375: if(!C){
! 15376: F=car(V)[2];
! 15377: }else{
! 15378: R=red(car(V)[2]/F);
! 15379: if(type(R)!=1) break;
! 15380: F/=dn(R);
! 15381: }
! 15382: C++;
! 15383: }
! 15384: }
! 15385: if(getopt(period)==1) return F;
! 15386: if(!isint(Log=getopt(log))) Log=0;
! 15387: if(V==[]&&F!=0){
! 15388: if(iand(Log,1)){
! 15389: H=append(cdr(fctr(nm(Q))),cdr(fctr(dn(Q))));
! 15390: for(L=0;H!=[];H=cdr(H))
! 15391: L+=str_len(rtostr(car(H)[0]));
! 15392: }else L=str_len(fctrtos(Q));
! 15393: S=trig2exp(P,X);
! 15394: for(T=[sin(F),tan(F),cos(F),sin(F/2),cos(F/2),tan(F/2)];T!=[];T=cdr(T)){
! 15395: R=trig2exp(S,X|inv=car(T));
! 15396: if(iand(Log,1)){
! 15397: H=append(cdr(fctr(nm(R))),cdr(fctr(dn(R))));
! 15398: for(K=0;H!=[];H=cdr(H))
! 15399: K+=str_len(rtostr(car(H)[0]));
! 15400: }else K=str_len(fctrtos(R));
! 15401: if(K<L){
! 15402: Q=R;L=K;
! 15403: }
! 15404: }
! 15405: }
! 15406: return Q;
! 15407: }
! 15408:
! 15409: def isshortneg(P)
! 15410: {
! 15411: return(str_len(rtostr(P))>str_len(rtostr(-P)))?1:0;
! 15412: }
! 15413:
! 15414: def simplog(R,X)
! 15415: {
! 15416: for(V=[],Var=pfargs(R,X);Var!=[];Var=cdr(Var)){
! 15417: VT=car(Var);
! 15418: if(VT[1]==log && ptype(R,VT[0])==2 && mydeg(R,VT[0])==1)
! 15419: V=cons([VT[0],VT[2],mycoef(R,1,VT[0])],V);
! 15420: }
! 15421: for(;V!=[];V=cdr(V)){
! 15422: VT=car(V);
! 15423: for(V2=cdr(V);V2!=[];V2=cdr(V2)){
! 15424: Dn=1;
! 15425: if((C=red(car(V2)[2]/VT[2]))!=1&&C!=-1){
! 15426: if(getopt(mult)==1&&type(C)==1&&ntype(C)==0){
! 15427: Dn=dn(C);C*=Dn;
! 15428: }else continue;
! 15429: }
! 15430: Log=red(VT[1]^Dn*car(V2)[1]^(Dn*C));
! 15431: L=str_len(rtostr(dn(Log)))-str_len(rtostr(nm(Log)));
! 15432: if(L>0 || (L==0&&isshortneg(VT[2])) ){
! 15433: Dn=-Dn;Log=1/Log;
! 15434: }
! 15435: R=mycoef(R,0,VT[0]);R=mycoef(R,0,car(V2)[0]);
! 15436: return(R+VT[2]*log(Log)/Dn);
! 15437: }
! 15438: }
! 15439: return R;
! 15440: }
! 15441:
! 15442: def integrate(P,X)
! 15443: {
! 15444: if(isint(Dvi=getopt(dviout))==1){
! 15445: if(Dvi==2||getopt(dumb)==-1){
! 15446: V=newvect(1);V[0]=[];
! 15447: }else V=0;
! 15448: if((RR=integrate(P,X|dumb=V))==[]) return R;
! 15449: S=fshorter(RR,X);
! 15450: VV=[X];
! 15451: if(V!=0){
! 15452: R=cons([[1,RR]],V[0]);
! 15453: if(S!=RR) R=cons([[1,RR=S]],R);
! 15454: for(V=FR=[];R!=[];R=cdr(R))
! 15455: if(car(R)!=FR) V=cons(FR=car(R),V);
! 15456: Var=varargs(V|all=1)[1];
! 15457: for(S0=[x0,x1,x2,x3],S=[t,s,u,v,w];S0!=[]&&S!=[];){
! 15458: if(findin(car(S0),Var)<0){
! 15459: S0=cdr(S0); continue;
! 15460: }
! 15461: if(findin(car(S),Var)>=0){
! 15462: S=cdr(S); continue;
! 15463: }
! 15464: V=subst(V,[car(S0),car(S)]);S0=cdr(S0);S=cdr(S);
! 15465: }
! 15466: if(Dvi==-2) return V;
! 15467: S1="\\,dx&";
! 15468: }else{
! 15469: V=[[],[[1,RR=S]]];
! 15470: S1="\\,dx";
! 15471: }
! 15472: if(type(P)>2){
! 15473: if(type(nm(P))<2){
! 15474: P=P*dx;S1=V?"&":"";
! 15475: }
! 15476: S=fctrtos(P|TeX=2,lim=0);SV0=my_tex_form(P);
! 15477: if(str_len(SV0)<str_len(S)) S=SV0;
! 15478: }else S=monototex(P);
! 15479: if(Dvi!=-2) S="\\int "+S+S1;
! 15480: else S="";
! 15481: for(L=[],V=cdr(V);V!=[];V=cdr(V)){
! 15482: CL=car(V);S0=["="]; /* a line */
! 15483: for(FL=0;CL!=[];CL=cdr(CL),FL++){
! 15484: CT=car(CL); /* a term */
! 15485: if((Y=CT[0])==0){ /* a variable */
! 15486: CT=cdr(CT);
! 15487: if(length(CT)>2) CT=cdr(CT);
! 15488: S0=["\\qquad(",CT[0],"=",CT[1],")"];
! 15489: break;
! 15490: }else{
! 15491: for(FT=0,S2=[],CT=cdr(CT);CT!=[];CT=cdr(CT),FT++){
! 15492: SV=fctrtos(car(CT)|TeX=2,lim=0);SV0=my_tex_form(car(CT));
! 15493: if(str_len(SV0)<str_len(SV)) SV=SV0;
! 15494: if(FL||FT||(F&&type(Y)<2)) SV=minustos(SV);
! 15495: S2=append(["+",SV],S2);
! 15496: }
! 15497: S2=reverse(cdr(S2));
! 15498: if(type(Y)>1){
! 15499: if(length(S2)>1){
! 15500: S1="\\int\\left(";S3="\\right)\\,d";
! 15501: }else{
! 15502: S1="\\int";S3="\\,d";
! 15503: }
! 15504: S2=cons(S1,append(S2,[S3,Y]));
! 15505: if(findin(Y,VV)<0) VV=cons(Y,VV);
! 15506: }
! 15507: if(FL) S0=append(S0,cons("+",S2));
! 15508: else S0=append(S0,S2);
! 15509: }
! 15510: }
! 15511: L=append([S0],L);
! 15512: };
! 15513: V=pfargs(RR,X|level=1);
! 15514: for(Var=[];V!=[];V=cdr(V)) Var=cons(car(V)[0],Var);
! 15515: Var=reverse(Var);
! 15516: if(!isint(J=getopt(frac))) J=0;;
! 15517: if(!iand(J,4)&&(!iand(J,2)||length(Var)==1)&&(iand(J,8)==8||ptype(RR,Var)==2)){
! 15518: F=1;
! 15519: if(iand(J,1)){
! 15520: K=str_len(fctrtos(RR));
! 15521: I=str_len(fctrtos(RR|var=Var));
! 15522: if(I>=K) F=0;
! 15523: }
! 15524: if(F){
! 15525: V=[fctrtos(RR|var=Var,TeX=2)];
! 15526: if(Dvi!=-2) V=cons("=",V);
! 15527: if(length(L)>0) L=cdr(L);
! 15528: L=append([V],L);
! 15529: }
! 15530: }else if(ptype(RR,X)==2){
! 15531: L=cdr(L);
! 15532: V=[fctrtos(RR|var=X,TeX=2)];
! 15533: if(Dvi!=-2) V=cons("=",V);
! 15534: L=append([V],L);
! 15535: }
! 15536: S=texket(S+ltotex(reverse(L)|opt=["cr","spts0"],str=1));
! 15537: if(getopt(log)!=1){
! 15538: for(V=[];VV!=[];VV=cdr(VV))
! 15539: V=cons(strtoascii(my_tex_form(car(VV))),V);
! 15540: S0=strtoascii(S); /* log(x) -> log|x| */
! 15541: L=length(S0);
! 15542: S1=strtoascii("\\log");
! 15543: S2=str_tb(0,0);
! 15544: for(I=0;;){
! 15545: if(I>=L||(J=str_str(S0,S1|top=I))<0
! 15546: ||(K=str_str(S0,40|top=J+4))<0
! 15547: ||(K!=J+4&&K!=J+9)||(N=str_pair(S0,K+1,40,41))<0){
! 15548: S=str_tb(0,S2)+str_cut(S0,I,100000);
! 15549: break;
! 15550: }
! 15551: if(str_str(S0,V|top=K+1,end=N-1)[0]<0) S2=str_tb(str_cut(S0,I,N),S2);
! 15552: /* log(a) -> log(a) */
! 15553: else{
! 15554: if(N<L-1&&S0[N+1]==94){ /* log(x)^2 -> (log|x|)^2 */
! 15555: S2=str_tb([str_cut(S0,I,J-1),"\\left(",str_cut(S0,J,K-1),
! 15556: "|",str_cut(S0,K+1,N-1),"|\\right)"],S2);
! 15557: }
! 15558: else S2=str_tb([str_cut(S0,I,K-1),"|",str_cut(S0,K+1,N-1),"|"],S2);
! 15559: }
! 15560: I=N+1;
! 15561: }
! 15562: }
! 15563: if(Dvi>0){
! 15564: dviout(texbegin("align*",S));
! 15565: return 1;
! 15566: }
! 15567: return S;
! 15568: } /* endof dviout */
! 15569: SM=["Cannot integrate",P,"at present"];
! 15570: P=sqrt2rat(P|mult=1);
! 15571: Dumb2=1;Dumb3=0;W=newvect(1);W[0]=[];
! 15572: if(type(Dumb=getopt(dumb))==5){
! 15573: Dumb2=Dumb3=Dumb;D2=W;
! 15574: }else if(!isint(Dumb)) Dumb=0;
! 15575: if(Dumb==-1){
! 15576: Dumb2=Dumb3=-1;
! 15577: }
! 15578: if(type(Dumb)!=5) D2=Dumb2;
! 15579: if(!isint(Mul=getopt(mult))) Mul=0;
! 15580: else Mul++;
! 15581: if(type(VAR=getopt(var))!=4) VAR=[];
! 15582: if(type(P)>4) return [];
! 15583: if(iand(T=ptype(P=red(P),X),63)>3||Mul>4){
! 15584: if(Dumb!=1) mycat(SM);
! 15585: return [];
! 15586: }
! 15587: if(Dumb==-1) mycat(["integrate", P]);
! 15588: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
! 15589: if(T<4 && (T<3||iscoef(P,os_md.israt))){
! 15590: if(Dumb==-1) mycat(["rational function",P]);
! 15591: else if(type(Dumb)==5) Dumb[0]=cons([[X,P]],Dumb[0]);
! 15592: return intpoly(P,X|dumb=Dumb); /* rational function */
! 15593: }
! 15594: Var=pfargs(P,X);
! 15595: for(F=0,VV=Var;VV!=[];VV=cdr(VV)){
! 15596: /* p(x)*log(x^2-1), @e^x, a^x, f(x)^(m/n) etc.->simplify */
! 15597: V=car(VV);
! 15598: if(V[1]==log && (T=ptype(V[2],X))>1 && T<4){
! 15599: if(mydeg(dn(V[2]),X)>0||mydeg(nm(V[2]),X)>1){
! 15600: FC=pfctr(V[2],X);RV=1;
! 15601: if(length(FC)>2){
! 15602: RR=0;RV=1;
! 15603: if((F0=car(FC)[0])!=1){
! 15604: if(type(F0)!=1 && F0<0){
! 15605: for(FT=cdr(FT);FT!=[];FT=cdr(FT)){
! 15606: if(iand(car(FT)[1],1)){
! 15607: RV=-1;F0=-F0;break;
! 15608: }
! 15609: }
! 15610: }
! 15611: }
! 15612: if(F0!=1) RR=log(F0);
! 15613: for(FC=cdr(FC);FC!=[];FC=cdr(FC)){
! 15614: if(RV==-1&&iand(car(FC)[1],1)==1){
! 15615: RR+=car(FC)[1]*log(-car(FC)[0]);
! 15616: RV=1;
! 15617: }else
! 15618: RR+=car(FC)[1]*log(car(FC)[0]);
! 15619: }
! 15620: P=subst(P,V[0],RR);
! 15621: F=1;
! 15622: }
! 15623: }
! 15624: F=1;
! 15625: }else if(V[1]==pow){
! 15626: if(ptype(V[2],X)==1){
! 15627: F=1;
! 15628: if(V[2]==@e){ /* @e^(f(x)) */
! 15629: P=subst(P,V[0],exp(V[3]));
! 15630: }else P=subst(P,V[0],exp(log(V[2])*V[3]));
! 15631: }else if(type(V[3])<=1 && ntype(V[3])==0){ /* r(x)^(m/n) */
! 15632: if((Pw=floor(V[3]))!=0){
! 15633: R=V[2]^Pw;
! 15634: if((PF=V[3]-Pw)!=0) R*=V[2]^PF;
! 15635: P=subst(P,V[0],R);
! 15636: F=1;
! 15637: V=[V[2]^PF,V[1],V[2],PF];
! 15638: }
! 15639: if(ptype(nm(V[2]),X)<2&&V[3]>0){ /* (1/p(x))^(m/n) */
! 15640: P=subst(P,V[0],V[2]*red(1/V[2])^(1-V[3]));
! 15641: F=0;VV=cons(0,Var=pfargs(P,X));continue;
! 15642: }
! 15643: if(ptype(V[2],X)<4&&(K=dn(V[3]))>1){
! 15644: V2=red(V[2]);
! 15645: DN=mydeg(nm(V2),X);DD=mydeg(dn(V2),X);
! 15646: if(DN+DD>1){
! 15647: VF=pfctr(V2,X);
! 15648: R=car(VF)[0]^(car(VF)[1]);RR=0;
! 15649: for(VF=cdr(VF);VF!=[];VF=cdr(VF)){
! 15650: TV=car(VF);TM=TV[1];
! 15651: while(abs(TM)>=K){
! 15652: RR=1;
! 15653: if(TM>0){
! 15654: TM-=K;
! 15655: RR*=TV[0]^nm(V[3]);
! 15656: }else{
! 15657: TM+=K;
! 15658: RR/=TV[0]^nm(V[3]);
! 15659: }
! 15660: }
! 15661: if(TM!=0) R*=TV[0]^TM;
! 15662: }
! 15663: if(RR){
! 15664: P=subst(P,V[0],RR*red(R)^(V[3]));F=1;
! 15665: F=0;VV=cons(0,Var=pfargs(P,X));continue;
! 15666: }
! 15667: }
! 15668: }
! 15669: }
! 15670: }
! 15671: }
! 15672: if(F){
! 15673: P=sqrt2rat(P|mult=1);
! 15674: Var=pfargs(P=red(P),X);T=ptype(P,X);
! 15675: if(T<4 && (T<3||iscoef(P,os_md.israt))){
! 15676: if(Dumb==-1) mycat(["rational function",P]);
! 15677: else if(type(Dumb)==5){
! 15678: Dumb[0]=cons([[X,P]],Dumb[0]);
! 15679: return intpoly(P,X|dumb=Dumb3);
! 15680: }
! 15681: return intpoly(P,X); /* rational function */
! 15682: }
! 15683: }
! 15684: #if 1
! 15685: for(P0=P,V=pfargs(P,X|level=1);V!=[];V=cdr(V)) /* P:tan(x) -> P0:sin(x)/cos(x) */
! 15686: if(car(V)[1]==tan) P0=red(subst(P0,car(V)[0],sin(car(V)[2])/cos(car(V)[2])));
! 15687: if(iand(ptype(P0,X),128)){ /* (log f)'=f'/f */
! 15688: for(Df=cdr(fctr(dn(P0)));Df!=[];Df=cdr(Df)){
! 15689: if(!iand(ptype(car(Df)[0],X),64)) continue;
! 15690: Q=car(Df)[0]^(car(Df)[1]);QQ=red(dn(P0)/Q);
! 15691: DQ=red(diff(Q,X)*QQ);
! 15692: if(C!=0&&type(C=DQ/nm(P0))<2){
! 15693: PP=0;DN=[1];
! 15694: }else for(DN=cdr(fctr(DQ));DN!=[];DN=cdr(DN)){
! 15695: Y=car(DN)[0];
! 15696: if(!iand(ptype(Y,X),64)||(I=mydeg(nm(P0),Y))!=mydeg(DQ,Y)
! 15697: || ptype((C=red(mycoef(nm(P0),I,Y)/mycoef(DQ,I,Y))),X)>1||C==0) continue;
! 15698: PP=red(P0-C*diff(Q,X)/Q);
! 15699: if(nmono(P0)>nmono(PP)) break;
! 15700: }
! 15701: if(DN!=[]){
! 15702: R=C*log(Q);
! 15703: if(PP==0) return R;
! 15704: W[0]=[];
! 15705: S=integrate(PP,X|dumb=D2);
! 15706: if(S!=[]){
! 15707: if(type(Dumb)==5){
! 15708: Dumb[0]=cons([[X,red(P0-PP),PP]],Dumb[0]);
! 15709: TD=W[0];
! 15710: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
! 15711: if(car(TD)[0][0]){
! 15712: WL=cons([1,R],car(TD));
! 15713: Dumb[0]=cons(WL,Dumb[0]);
! 15714: }
! 15715: else Dumb[0]=cons(car(TD),Dumb[0]);
! 15716: }
! 15717: }
! 15718: return red(R+S);
! 15719: }
! 15720: }
! 15721: }
! 15722: }
! 15723: #endif
! 15724: if((length(Var)==1||getopt(exe)==1) && /* p(x)*atan(q(x))^m+r(x), etc */
! 15725: findin((VT=car(Var))[1],[atan,asin,acos,log])>=0 && ptype(P,VT[0])==2 &&
! 15726: (VT[1]!=log||(T!=65&&T!=66)||mydeg(VT[2],X)!=1)){ /* exclude x*log(x+1)^2 */
! 15727: for(R=0,D=mydeg(P,VT[0]);D>=0;D--){
! 15728: Q=S=mycoef(P,D,VT[0]);
! 15729: if(S){
! 15730: if(D>0){
! 15731: if((Q=integrate(S,X|mult=Mul))==[]) return Q;
! 15732: }else{
! 15733: W[0]=[];
! 15734: if((Q=integrate(S,X|dumb=D2,var=VAR,mult=Mul))==[]) return Q;
! 15735: if(type(Dumb)==5){
! 15736: TD=W[0];
! 15737: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
! 15738: if(car(TD)[0][0]){
! 15739: WL=cons([1,R],car(TD));
! 15740: Dumb[0]=cons(WL,Dumb[0]);
! 15741: }
! 15742: else Dumb[0]=cons(car(TD),Dumb[0]);
! 15743: }
! 15744: if(car(Dumb[0])!=[[1,R],[1,Q]])
! 15745: Dumb[0]=cons([[1,R,Q]],Dumb[0]);
! 15746: }
! 15747: return red(R+Q);
! 15748: }
! 15749: }else if(D>0) continue;
! 15750: if(D==0){
! 15751: if(Q!=0&&type(Dumb)==5) Dumb[0]=cons([[1,R,Q]],Dumb[0]);
! 15752: return red(Q+R);
! 15753: }
! 15754: R0=Q*VT[0]^D;
! 15755: P=(P0=P)-S*VT[0]^D-Q*diff(VT[0]^D,X);
! 15756: if(mydeg(P,VT[0])>=D){ /* (x+1)*log(x)/x^2 */
! 15757: if(mydeg(P,VT[0])==D &&
! 15758: ptype(C=red(mycoef(P,D,VT[0])/diff(VT[0],X)),VT[0])<2){
! 15759: P=P0-(S*VT[0]^D+Q*diff(VT[0]^D,X)+C*diff(VT[0]^(D+1),X)/(D+1));
! 15760: R0+=C*VT[0]^(D+1)/(D+1);
! 15761: }else{
! 15762: P=P0;
! 15763: if(Dumb!=1) mycat(SM);
! 15764: return [];
! 15765: }
! 15766: }
! 15767: if(type(Dumb)==5){
! 15768: if(P) Dumb[0]=cons([R?[1,R,R0]:[1,R0],[X,P]],Dumb[0]);
! 15769: else if(R!=0) Dumb[0]=cons([[1,R,R0]],Dumb[0]);
! 15770: }
! 15771: R+=R0;
! 15772: }
! 15773: }
! 15774: if(length(Var)==1 && (VT=car(Var))[1]==pow && mydeg(P,VT[0])==1 && (PT=ptype(VT[2],X))<4){
! 15775: PR=mycoef(P,0,VT[0]);
! 15776: if(RR!=0){
! 15777: RR=integrate(RR,X|dumb=Dumb3,var=Var);
! 15778: if(RR==[]) return RR;
! 15779: }
! 15780: PW=VT[3];
! 15781: if((D=mydeg(nm(V2=VT[2]),X))==2&&PT==2){ /* f(x)*(ax^2+bx+c)^(m/2)+r(x) */
! 15782: if(isint(2*PW)){
! 15783: C2=mycoef(V20=V2,2,X);F=1;
! 15784: if((C21=sqrtrat(C2))==[]) return [];
! 15785: if(imag(C21)!=0){
! 15786: if(real(C21)!=0) return [];
! 15787: C21=C21/@i;F=-1;
! 15788: }
! 15789: if(type(C21)>3) return [];
! 15790: P=subst(P,X,X/C21);VT=mysubst(VT,[X,X/C21]);V2=VT[2];
! 15791: C1=mycoef(V2,1,X)/F/2;
! 15792: if(C1!=0){
! 15793: P=subst(P,X,X-C1);VT=mysubst(VT,[X,X-C1]);V2=VT[2];
! 15794: }
! 15795: C0=mycoef(V2,0,X);
! 15796: if((C01=sqrtrat(C0))==[]) return [];
! 15797: if(imag(nm(C01))!=0){
! 15798: if(real(nm(C01))!=0) return [];
! 15799: C01=C01/@i;G=-1;
! 15800: }else G=1;
! 15801: if(type(C01)>3||(F==-1&&G==-1)) return [];
! 15802: Y=makenewv([P,VAR]|var=x);
! 15803: if(F==-1){ /* (c^2-x^2)^(1/2) */
! 15804: Q=subst(P,VT[0],(C01*cos(Y))^(2*PW),X,YX=C01*sin(Y))
! 15805: *C01*cos(Y)/C21;
! 15806: SY=C21*(X+C1);CY=V20;YY=asin(sqrt2rat(C21*(X+C1)/C01|mult=1));
! 15807: }else if(G==-1){ /* (x^2-c^2)^(1/2) */
! 15808: Q=subst(P,VT[0],(C01*sin(Y)/cos(Y))^(2*PW),X,YX=C01/cos(Y))
! 15809: *C01*sin(Y)/cos(Y)^2/C21;
! 15810: SY=V20;CY=1/(C21*(X+C1));YY=acos(sqrt2rat(C01/C21/(X+C1)|mult=1));
! 15811: }else{ /* (x^2+c^2)^(1/2) */
! 15812: Q=subst(P,VT[0],(C01/cos(Y))^(2*PW),X,YX=C01*sin(Y)/cos(Y))
! 15813: *C01/cos(Y)^2/C21;
! 15814: CY=V20; YY=atan(sqrt2rat(C21*(X+C1)/C01|mult=1));
! 15815: }
! 15816: if(Dumb==-1) mycat([C21*X+C1,"=",YX]);
! 15817: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,C21*X+C1,YX]],Dumb[0]);
! 15818: if((Q=integrate(red(Q),Y|dumb=Dumb2,var=cons(X,Var)))==[]) return [];
! 15819: Q=trig2exp(Q,Y|inv=cos(Y));
! 15820: for(V=vars(Q);V!=[];V=cdr(V)){
! 15821: FA=funargs(car(V));
! 15822: if(type(FA)==4&&FA[0]==log){
! 15823: QQ=trig2exp(FA[1],Y|inv=cos(Y));
! 15824: Q=mycoef(Q,0,car(V))+mycoef(Q,1,car(V))*log(QQ);
! 15825: }
! 15826: }
! 15827: if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
! 15828: if(F==-1) Q=subst(Q,sin(Y),SY/C01,cos(Y),CY^(1/2)/C01,Y,YY);
! 15829: else if(G==-1){
! 15830: Q=red(subst(Q,sin(Y),SY^(1/2)*cos(Y)/C01));
! 15831: Q=red(subst(Q,cos(Y),C01*CY,Y,YY));
! 15832: }else{
! 15833: Q=red(subst(Q,sin(Y),C21*(X+C1)*cos(Y)/C01));
! 15834: Nm=substblock(nm(Q),cos(Y),C01^2/CY,cos(Y)^2);
! 15835: Nm=subst(Nm,cos(Y),C01/CY^(1/2));
! 15836: Dn=substblock(dn(Q),cos(Y),C01^2/CY,cos(Y)^2);
! 15837: Dn=subst(Dn,cos(Y),C01/CY^(1/2));
! 15838: Q=red(subst(Nm/Dn,Y,YY));
! 15839: }
! 15840: if(findin(Y,vars(Q))>=0) return [];
! 15841: for(R=[],Var=vars(Q);Var!=[];Var=cdr(Var)){
! 15842: VT=funargs(V=car(Var));
! 15843: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60&&mydeg(Q,V)==1)
! 15844: R=cons([mycoef(Q,1,V),V],R);
! 15845: }
! 15846: if(length(R)==2 && (R[0][0]==R[1][0]||R[0][0]+R[1][0]==0)){
! 15847: R0=args(R[0][1])[0];R1=args(R[1][1])[0];
! 15848: if(R[0][0]==R[1][0]) S=R0*R1;
! 15849: else S=R1/R0;
! 15850: Q=mycoef(Q,0,R[0][1]);Q=mycoef(Q,0,R[1][1]);
! 15851: Q+=R[1][0]*log(red(S));
! 15852: }
! 15853: for(Var=vars(Q);Var!=[];Var=cdr(Var)){
! 15854: VT=funargs(car(Var));
! 15855: if(type(VT)==4&&VT[0]==log&&ptype(VT[1],X)>60){
! 15856: S=trig2exp(VT[1],X|inv=cos(X),arc=1);
! 15857: if(ptype(dn(S),X)<2 && mydeg(Q,car(Var))==1
! 15858: && ptype(mycoef(Q,1,car(Var)),X)<2){
! 15859: S=nm(S);
! 15860: SF=fctr(S);
! 15861: S/=SF[0][0];
! 15862: }
! 15863: if(cmpsimple(S,-S)>0) S=-S;
! 15864: Q=subst(Q,car(Var),log(S));
! 15865: }
! 15866: } /* x/(1-x^2)^(1/2) */
! 15867: if(type(Q=red(Q+RR))==2&&type(Dumb)!=5) Q-=cterm(Q);
! 15868: if(Dumb==-1) mycat(["->",Q]);
! 15869: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
! 15870: return Q;
! 15871: }
! 15872: }else if(D==1 && mydeg(Dn=dn(V2),X)<2 && type(PW)==1 && ntype(PW)==0 &&
! 15873: (V2!=X||ptype(mycoef(P,1,VT[0]),X)>2)){ /* p(x)((ax+b)/(cx+d))^(m/n) */
! 15874: PN=nm(PW);PD=dn(PW);
! 15875: Y=makenewv([P,VAR]|var=x);Q=Y^PD*Dn-nm(V2);F=-mycoef(Q,0,X)/mycoef(Q,1,X);
! 15876: Q=red(subst(P,VT[0],Y^PN,X,F)*diff(F,Y));
! 15877: if(Dumb==-1) mycat([Y,"=",V2^(1/PD)]);
! 15878: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,V2^(1/PD)]],Dumb[0]);
! 15879: if((Q=integrate(Q,Y|dumb=Dumb3,var=cons(X,Var)))==[]) return [];
! 15880: Q=red(Q);
! 15881: QN=subst(substblock(nm(Q),Y,Y^PD,V2),Y,V2^(1/PD));
! 15882: QD=subst(substblock(dn(Q),Y,Y^PD,V2),Y,V2^(1/PD));
! 15883: Q=red(QN/QD+RR);
! 15884: if(Dumb==-1) mycat(["->",Q]);
! 15885: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
! 15886: return Q;
! 15887: }
! 15888: }else if(length(Var)==2 && /* r(x,(ax+b)^(1/2),(cx+d)^(1/2)) */
! 15889: (VT=car(Var))[1]==pow && ptype(VT[2],X)==1 && mydeg(VT[2],X)==1 && VT[3]==1/2 &&
! 15890: (VS=car(car(Var)))[1]==pow && ptype(VS[2],X)==1 && mydeg(VS[2],X)==1 && VS[3]==1/2){
! 15891: Y=makenewv([P,VAR]|var=x);R=(Y^2-myceof(VS[0],0,X))/(C=mycoef(VS[0],1,X));
! 15892: if(Dumb==-1) mycat([Y,"=",VS[0]]);
! 15893: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,VD[0]]],Dumb[0]);
! 15894: R=integrate(subst(P,VS[0],Y,X,R)*2*Y/C,Y|dumb=Dumb3,var=cons(X,Var));
! 15895: if(R!=[]){
! 15896: R=subst(substblock(R,Y,VS[0],Y^2),Y,VS[0]);
! 15897: if(Dumb==-1) mycat(["->",R]);
! 15898: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
! 15899: }
! 15900: return R;
! 15901: }
! 15902: if(T==65||T==66){ /* polynomial including sin, exp etc */
! 15903: for(F=0,VT=Var;VT!=[];VT=cdr(VT)){
! 15904: VTT=car(VT);
! 15905: if(ptype(VTT[2],X)>2||mydeg(VTT[2],X)>1) F=ior(F,256); /* compos. or rat. or nonlin. */
! 15906: K=findin(VTT[1],[cos,sin,tan,exp,log,pow]);
! 15907: F=ior(F,2^(K+1)); /* 1:other,2:cos,4:sin,8:tan,16:exp,32:log,64:pow */
! 15908: if((Deg=mydeg(P,VTT[0]))>1&&K!=4) F=ior(F,1024); /* nonlinear */
! 15909: if(K==5 && (ptype(VTT[3],X)!=0 || VTT[2]!=x||Deg>1)) F=ior(F,8192); /* pow */
! 15910: for(;Deg>0;Deg--){ /* coef */
! 15911: if(ptype(mycoef(P,Deg,VTT[0]),X)>2){
! 15912: if(K==4||K==5) F=ior(F,2048); /* exp, log */
! 15913: else F=ior(F,4096);
! 15914: }
! 15915: }
! 15916: }
! 15917: if(!iand(F,1+8+64+256+512+2048+8192)){ /* cos,sin,exp,log^n,x^c */
! 15918: if(iand(F,1024+4096)&&!iand(F,32+64)){ /* cos,sin,exp */
! 15919: if(type(Dumb)==5){
! 15920: S=trig2exp(P,X|inv=1);
! 15921: if(P!=S) Dumb[0]=cons([[X,S]],Dumb[0]);
! 15922: }
! 15923: R=integrate(trig2exp(P,X),X);
! 15924: if(R!=[]) S=trig2exp(R,X|inv=1);
! 15925: R=fshorter(S,X);
! 15926: if(type(Dumb)==5&&R!=S){
! 15927: Dumb[0]=cons([[1,S]],Dumb[0]);
! 15928: }
! 15929: return R;
! 15930: }
! 15931: for(R=0,VT=Var;VT!=[];VT=cdr(VT)){
! 15932: CV=car(VT);
! 15933: C0=mycoef(CV[2],0,X);C1=mycoef(CV[2],1,X);
! 15934: Q=mycoef(P,1,CV[0]);
! 15935: if(CV[1]==sin||CV[1]==cos){
! 15936: TR=(CV[1]==sin)?intpoly(Q,X|sin=C1):intpoly(Q,X|cos=C1);
! 15937: R+=TR[0]*cos(CV[2])+TR[1]*sin(CV[2]);
! 15938: }else if(CV[1]==exp){
! 15939: QT=exp(CV[2]);
! 15940: for(V2=vars(C1);V2!=[];V2=cdr(V2)){ /* exp(2*log(a)*x) => a^(2*x) */
! 15941: if(vtype(VA=car(V2))==2&&functor(VA)==log){
! 15942: if(ptype(C1,VA)!=2||mydeg(C1,VA)==1&&mycoef(C1,0,VA)==0){
! 15943: QT=args(VA)[0]^(red(C1/VA)*X);
! 15944: if(C0!=0) QT*=exp(C0);
! 15945: break;
! 15946: }
! 15947: }
! 15948: }
! 15949: R+=intpoly(Q,X|exp=C1)*QT;
! 15950: }else if(CV[1]==pow)
! 15951: R+=intpoly(Q,X|pow=CV[2])*x^CV[2];
! 15952: else if(CV[1]==log){
! 15953: for(Deg=mydeg(P,CV[0]);Deg>0; Deg--){
! 15954: Q=mycoef(P,Deg,CV[0]);
! 15955: TR=intpoly(Q,X|log=[C1,C0,Deg]);
! 15956: for(I=0;TR!=[];I++,TR=cdr(TR)){
! 15957: if(I==Deg) R+=car(TR)-subst(car(TR),X,0);
! 15958: else R+=car(TR)*CV[0]^(Deg-I);
! 15959: }
! 15960: }
! 15961: }
! 15962: P=mycoef(P,0,CV[0]);
! 15963: }
! 15964: R+=intpoly(P,X);
! 15965: return R;
! 15966: }
! 15967: }
! 15968: for(K=0,VX=[],VT=Var;VT!=[];VT=cdr(VT)){ /* contain only both pow and trig */
! 15969: VTT=car(VT);
! 15970: if(findin(VTT[1],[cos,sin,tan])>=0){
! 15971: if(ptype(VTT[2],X)!=2||mydeg(VTT[2],X)!=1) break;
! 15972: VX=cons(VTT,VX);
! 15973: }else if(VTT[1]==pow) K=1;
! 15974: else break;
! 15975: }
! 15976: if(VT==[]&&K==1&&VX!=[]){
! 15977: D=VX[0][2];
! 15978: if(VX[0][1]==tan) D*=2;
! 15979: for(VT=cdr(VX);VT!=[];VT=cdr(VT)){
! 15980: K=VT[0][2]/D;
! 15981: if(VT[0][1]==tan) K*=2;
! 15982: if(type(K)!=1||ntype(K)!=0) break;
! 15983: D/=dn(K);
! 15984: }
! 15985: if(VT==[]){
! 15986: Y=makenewv([P,VAR]|var=x);
! 15987: for(Q=P,VT=VX;VT!=[];VT=cdr(VT)){
! 15988: VTT=car(VT);
! 15989: if(VTT[1]==cos||VTT[1]==sin){
! 15990: VV=trig2exp(VTT[0],X|inv=cos(D));
! 15991: VV=subst(VV,cos(D),(1-Y^2)/(1+Y^2),sin(D),2*Y/(Y^2+1));
! 15992: }else if(VTT[1]==tan){
! 15993: VV=trig2exp(VTT[0],X|inv=tan(D/2));
! 15994: VV=subst(VV,tan(D),Y);
! 15995: }
! 15996: Q=subst(Q,VTT[0],VV);
! 15997: }
! 15998: Q*=2/(Y^2+1);
! 15999: if(diff(Q,X)==0){
! 16000: if(Dumb==-1) mycat([Y,"=",tan(D/2)]);
! 16001: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y,tan(D/2)]],Dumb[0]);
! 16002: R=integrate(Q,Y|dumb=Dumb2,var=cons(X,Var));
! 16003: if(R!=[]){
! 16004: if(Dumb==-1) mycat(["->",R]);
! 16005: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
! 16006: return sqrt2rat(subst(R,Y,tan(D/2))|mult=1);
! 16007: }
! 16008: }
! 16009: }
! 16010: }
! 16011: if(T>65||iand(F,8)){ /* rational for functions or tan */
! 16012: if(findin(X,vars(P))<0){
! 16013: for(XV=XE=0,VT=Var;VT!=[];VT=cdr(VT)){
! 16014: VTT=car(VT);
! 16015: if(mydeg(VTT[2],X)!=1) break;
! 16016: if(VTT[1]==cos||VTT[1]==sin||VTT[1]==tan){
! 16017: K=red(VTT[2]/X);
! 16018: if(type(K)>1||ntype(K)>0) break;
! 16019: if(XV==0) XV=K;
! 16020: else XV/=dn(K/XV);
! 16021: if(VTT[1]==tan) P=red(subst(P,VTT[0],sin(VTT[2])/cos(VTT[2])));
! 16022: }else if(VTT[1]==exp){
! 16023: K=red(VTT[2]/X);
! 16024: if(type(K)>1||ntype(K)>0) break;
! 16025: if(XE==0) XE=K;
! 16026: else XE/=dn(K/XE);
! 16027: }else break;
! 16028: }
! 16029: if(VT==[]&&XE*XV==0){
! 16030: if(XE){
! 16031: if(XE<0) XE=-XE;
! 16032: Y=makenewv([P,VAR]|var=x);
! 16033: for(F=0,VT=Var;VT!=[];VT=cdr(VT),F++){
! 16034: VTT=car(VT);C=red(VTT[2]/X/XE);
! 16035: P=subst(P,VTT[0],Y^C);
! 16036: if(!F){
! 16037: if(Dumb==-1) mycat([Y^C,"=",VTT[0]]);
! 16038: else if(type(Dumb)==5) Dumb[0]=cons([[0,Y^C,VTT[0]]],Dumb[0]);
! 16039: }
! 16040: }
! 16041: P/=XE*Y;
! 16042: Q=integrate(P,Y|dumb=Dumb3,var=cons(X,VAR));
! 16043: if(Q==[]) return [];
! 16044: Q=subst(Q,Y,exp(XE*X));
! 16045: Q=trig2exp(Q,X);
! 16046: if(Dumb==-1) mycat(["->",Q]);
! 16047: else if(type(Dumb)==5) Dumb[0]=cons([[1,Q]],Dumb[0]);
! 16048: return Q;
! 16049: }
! 16050: P=trig2exp(nm(P),X|inv=cos(XV*X))/trig2exp(dn(P),X|inv=cos(XV*X));
! 16051: Y=makenewv([P,VAR]|var=x);
! 16052: Q=red(subst(P,sin(XV*X),Y*cos(XV*X)));
! 16053: Q=substblock(nm(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))/
! 16054: (substblock(dn(Q),cos(XV*X),cos(XV*X)^2,1/(Y^2+1))*(Y^2+1));
! 16055: Q=red(Q);
! 16056: if(ptype(Q,X)<2){
! 16057: XV*=2;P=Q;
! 16058: }else{
! 16059: 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);
! 16060: P=red(P);
! 16061: }
! 16062: if(Dumb==-1){
! 16063: mycat([Y,"=",tan(XV*X/2)]);
! 16064: mycat(["integrate",P]);
! 16065: }else if(type(Dumb)==5) Dumb[0]=cons([[Y,P]],cons([[0,Y,tan(XV*X/2)]],Dumb[0]));
! 16066: R=intpoly(P,Y|dumb=Dumb);
! 16067: if(R==[]) return R;
! 16068: if(Dumb==-1) mycat(["->",R]);
! 16069: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
! 16070: for(Log=1,K=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
! 16071: VTT=car(Var);
! 16072: if(VTT[1]==log){
! 16073: C=mycoef(R,1,VTT[0]);
! 16074: VT2=VTT[2];
! 16075: if(K==0){
! 16076: K=C;Log=VT2;
! 16077: if(K<0){
! 16078: K=-K;Log=1/Log;
! 16079: }
! 16080: }else{
! 16081: if((V=red(C/K))<0){
! 16082: VT2=1/VT2;V=-V;
! 16083: }
! 16084: if(type(V)>1||ntype(V)>0){
! 16085: Log=1;break;
! 16086: }
! 16087: if(isint(V)) Log*=VT2^V;
! 16088: else{
! 16089: D=dn(V);K/=D;
! 16090: Log=Log^D*VT2^nm(V);
! 16091: }
! 16092: }
! 16093: RR=mycoef(RR,0,VTT[0]);
! 16094: }
! 16095: }
! 16096: if(Log!=1){
! 16097: R=RR;
! 16098: if(type(Dumb)==5){
! 16099: if(RR) Dumb[0]=cons([[1,K*log(Log),RR]],Dumb[0]);
! 16100: else Dumb[0]=cons([[1,K*log(Log)]],Dumb[0]);
! 16101: }
! 16102: Log=red(subst(red(Log),Y,sin(XV*X/2)/cos(XV*X/2)));
! 16103: Log=fshorter(Log,X|log=1); /* log(cos(2*x)+1)=-2*log(cos(x)) */
! 16104: Nm=fctr(nm(Log));
! 16105: for(T=[];Nm!=[];Nm=cdr(Nm)){
! 16106: if(ptype(car(Nm)[0],X)>1) T=cons(car(Nm),T);
! 16107: }
! 16108: Nm=fctr(dn(Log));
! 16109: for(;Nm!=[];Nm=cdr(Nm)){
! 16110: if(ptype(car(Nm)[0],X)>1) T=cons([car(Nm)[0],-car(Nm)[1]],T);
! 16111: }
! 16112: for(I=0,Nm=T;T!=[];T=cdr(T)){
! 16113: if(I=0) I=abs(car(T)[1]);
! 16114: else I=igcd(I,car(T)[1]);
! 16115: }
! 16116: for(Log=1;Nm!=[];Nm=cdr(Nm)) Log*=car(Nm)[0]^(car(Nm)[1]/I);
! 16117: K*=I;
! 16118: if(cmpsimple(nm(Log),dn(Log))<0){
! 16119: K=-K;Log=red(1/Log);
! 16120: }
! 16121: Log=K*log(Log);
! 16122: if(type(Dumb)==5){
! 16123: if(RR) Dumb[0]=cons([[1,Log,RR]],Dumb[0]);
! 16124: else Dumb[0]=cons([[1,Log]],Dumb[0]);
! 16125: }
! 16126: }else Log=0;
! 16127: for(Atan=0,Var=pfargs(RR=R,Y);Var!=[];Var=cdr(Var)){
! 16128: VTT=car(Var);
! 16129: if(VTT[1]==atan){
! 16130: W=subst(VTT[2],Y,sin(XV*X/2)/cos(XV*X/2));
! 16131: W=trig2exp(W,X|inv=1);
! 16132: V2=funargs(dn(W));
! 16133: if(type(V2)==4&&length(V2)==2){
! 16134: V3=V2[1]*mycoef(R,1,VTT[0]);
! 16135: Z=0;
! 16136: if(V2[0]==cos)
! 16137: Z=red(W*cos(V2[1])/sin(V2[1]));
! 16138: else if(V2[0]==sin){
! 16139: Z=red(W*sin(V2[1])/cos(V2[1]));
! 16140: V3=-V3;
! 16141: }
! 16142: if(Z==1){
! 16143: Atan+=V3;W=0;
! 16144: }else if(Z==-1){
! 16145: Atan-=V3;W=0;
! 16146: }
! 16147: }
! 16148: R0=mycoef(R,0,VTT[0]);
! 16149: if(W!=0) Atan+=subst(R-R0,VTT[0],atan(W)); /* atan(W); */
! 16150: R=R0;
! 16151: }
! 16152: }
! 16153: if(R!=0){
! 16154: R=subst(R,Y,sin(XV*X/2)/cos(XV*X/2));
! 16155: R=red(R);
! 16156: R=trig2exp(nm(R),X|inv=1)/trig2exp(dn(R),X|inv=1);
! 16157: }
! 16158: if(type(Dumb)==5){
! 16159: F=0;WL=[];
! 16160: if(R){
! 16161: WL=cons(R,WL);
! 16162: F++;
! 16163: }
! 16164: if(Atan){
! 16165: WL=cons(Atan,WL);
! 16166: F++;
! 16167: }
! 16168: if(Log){
! 16169: WL=cons(Log,WL);
! 16170: F++;
! 16171: }
! 16172: WL=cons(1,WL);
! 16173: if(F>1) Dumb[0]=cons([WL],Dumb[0]);
! 16174: }
! 16175: R=red(R+Log+Atan);
! 16176: if(Dumb==-1) mycat(["->",R]);
! 16177: else if(type(Dumb)==5) Dumb[0]=cons([[1,R]],Dumb[0]);
! 16178: return fshorter(R,X);
! 16179: }
! 16180: }
! 16181: }
! 16182: VT=pfargs(Q=P,X|level=1);
! 16183: V=(iand(ptype(P,X),7)<3)?[X]:[];
! 16184: for(;VT!=[];VT=cdr(VT))
! 16185: if(ptype(P,car(VT)[0])<3) V=cons(car(VT)[0],V);
! 16186: if(length(V)>0){ /* 1/x+tan(x)+... etc.: sums */
! 16187: for(R=0;V!=[];V=cdr(V)){
! 16188: T=mycoef(Q,0,car(V));
! 16189: W[0]=[];
! 16190: S=integrate(TD=red(Q-T),X|dumb=D2,mult=Mul,exe=1);
! 16191: if(S==[]) continue;
! 16192: if(type(Dumb)==5){
! 16193: WL=0;
! 16194: if(T!=0) WL=[[X,TD,T]];
! 16195: if(R!=0) WL=cons([1,R],WL);
! 16196: if(WL) Dumb[0]=cons(WL,Dumb[0]);
! 16197: TD=W[0];
! 16198: if(R!=0||T!=0){
! 16199: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
! 16200: if(car(TD)[0][0]){
! 16201: WL=(!T)?[]:[[X,T]];
! 16202: WL=append(car(TD),WL);
! 16203: if(R!=0) WL=cons([1,R],WL);
! 16204: }else WL=car(TD);
! 16205: Dumb[0]=cons(WL,Dumb[0]);
! 16206: }
! 16207: }else Dumb[0]=append(TD,Dumb[0]);
! 16208: }
! 16209: R+=S;Q=T;
! 16210: if(!Q) return red(R);
! 16211: }
! 16212: W[0]=[];
! 16213: if(P!=Q&&type(S=integrate(Q,X|dumb=D2,mult=Mul))<4){
! 16214: RR=red(R+S);
! 16215: if(type(Dumb)==5){
! 16216: TD=W[0];
! 16217: for(W0=[],TD=reverse(TD);TD!=[];TD=cdr(TD)){
! 16218: if(car(TD)[0][0]){
! 16219: WL=cons([1,R],car(TD));
! 16220: Dumb[0]=cons(WL,Dumb[0]);
! 16221: }
! 16222: else Dumb[0]=append(TD,Dumb[0]);
! 16223: }
! 16224: if(nmono(R)+nmono(S)!=nmono(RR)) Dumb[0]=cons([[1,R,S]],Dumb[0]);
! 16225: }
! 16226: return RR;
! 16227: }
! 16228: }
! 16229: if(Dumb!=1) mycat(SM);
! 16230: return [];
! 16231: }
! 16232:
! 16233: def fimag(P)
! 16234: {
! 16235: for(V=vars(P);V!=[];V=cdr(V)){
! 16236: Q=[];
! 16237: if(vtype(VF=car(V))==2){
! 16238: VAA=args(VF);
! 16239: if(VAA==[]) continue;
! 16240: VA=sqrt2rat(VAA[0]);
! 16241: if(functor(VF)==exp){
! 16242: if(imag(VA)!=0){
! 16243: R=(real(VA)!=0)?exp(real(VA)):1;
! 16244: Q=subst(P,VF,R*(cos(imag(VA))+sin(imag(VA))*@i));
! 16245: }
! 16246: }else if(functor(VF)==pow){
! 16247: VA=sqrt2rat(VAA[1]);
! 16248: if(imag(VA)!=0){
! 16249: R=(real(VA)!=0)?VAA[0]^(real(VA)):1;
! 16250: L=(VAA[0]!=@e)?log(VAA[0]):1;
! 16251: Q=subst(P,VAA[0]^(VAA[1]),R*(cos(L*imag(VA))+sin(L*imag(VA))*@i));
! 16252: }else if(VAA[1]!=(V0=fimag(VA)))
! 16253: Q=subst(P,VAA[0]^(VAA[1]),VAA[0]^(V0));
! 16254: }
! 16255: V0=VA;
! 16256: if(length(VAA)==1&&(VAA[0]!=V0||VA!=(V0=fimag(VA))))
! 16257: Q=subst(P,VF,subst(VF,VAA[0],V0));
! 16258: }
! 16259: if(Q!=[]&&P!=Q){
! 16260: P=Q;V=cons(0,vars(P));
! 16261: }
1.1 takayama 16262: }
16263: return P;
16264: }
16265:
1.4 ! takayama 16266:
! 16267: def trig2exp(P,X)
! 16268: {
! 16269: if(iand(ptype(P,X),128)){
! 16270: OL=getopt();
! 16271: Nm=trig2exp(nm(P),X|option_list=OL);
! 16272: Dn=trig2exp(dn(P),X|option_list=OL);
! 16273: R=red(Nm/Dn);
! 16274: if(getopt(arc)==1) return sqrt2rat(R);
! 16275: }
! 16276: if((Inv=getopt(inv))==1||type(Inv)==2){
! 16277: for(VT=T=vars(P);T!=[];T=cdr(T)){
! 16278: if(findin(functor(car(T)),[cos,sin,tan])>=0){
! 16279: P=trig2exp(P,X);VT=vars(P);break;
! 16280: }
! 16281: }
! 16282: for(;VT!=[];VT=cdr(VT)){
! 16283: if(functor(CT=car(VT))==exp){
! 16284: if((Re=real(args(CT)[0]))!=0){
! 16285: if(isint(Re)) S=@e^Re;
! 16286: else S=exp(Re);
! 16287: }else S=1;
! 16288: if((Im=imag(args(CT)[0]))!=0){
! 16289: Q=nm(Im);Q=mycoef(Q,mydeg(Q,X),X);
! 16290: if(-Q>Q) S*=cos(-Im)-@i*sin(-Im);
! 16291: else S*=cos(Im)+@i*sin(Im);
! 16292: }
! 16293: P=subst(P,CT,S);
! 16294: }
! 16295: }
! 16296: P=red(P);
! 16297: U=vars(Inv);
! 16298: if(length(U)!=1||((F=functor(car(U)))!=sin&&F!=cos&&F!=tan)) return P;
! 16299: XX=args(car(U))[0];
! 16300: if(mydeg(XX,X)!=1) return P;
! 16301: if(!isvar(XX)) P=subst(P,X,(X-mycoef(XX,0,X))/mycoef(XX,1,X));
! 16302: for(VT=vars(P);VT!=[];VT=cdr(VT)){
! 16303: if(vtype(CT=car(VT))<2) continue;
! 16304: TX=args(CT)[0];
! 16305: if(mydeg(TX,X)!=1) continue;
! 16306: if(!isint(C1=mycoef(TX,1,X))) continue;
! 16307: if((C0=mycoef(TX,0,X))==0){
! 16308: CC=1;CS=0;
! 16309: }else if(vars(C0)==[@pi]){
! 16310: CC=myval(cos(C0));
! 16311: if(CC!=0&&type(CC)==1&&ntype(CC)!=0){
! 16312: CC=cos(C0);CS=sin(C0);
! 16313: }else CS=myval(sin(C0));
! 16314: }else{
! 16315: CC=cos(C0);CS=sin(C0);
! 16316: }
! 16317: K=C1;
! 16318: if(K<0) K=-K;
! 16319: for(CC1=0,I=K;I>=0;I-=2) CC1+=(-1)^((K-I)/2)*binom(K,I)*cos(X)^I*sin(X)^(K-I);
! 16320: 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);
! 16321: if(C1<0) CS1=-CS1;
! 16322: if((TF=functor(CT))==cos) P=subst(P,cos(TX),CC1*CC-CS1*CS);
! 16323: else if(TF==sin) P=subst(P,sin(TX),CS1*CC+CC1*CS);
! 16324: }
! 16325: if(F==sin)
! 16326: P=substblock(P,cos(X),cos(X)^2,1-sin(X)^2);
! 16327: else{
! 16328: P=substblock(P,sin(X),sin(X)^2,1-cos(X)^2);
! 16329: if(F==tan){
! 16330: P=subst(P,sin(X),cos(X)*tan(X));
! 16331: P=substblock(P,cos(X),cos(X)^2,1/(tan(X)^2+1));
! 16332: }
! 16333: }
! 16334: if(!isvar(XX)) P=subst(P,X,XX);
! 16335:
! 16336: if(getopt(arc)==1){
! 16337: for(VT=vars(P);VT!=[];VT=cdr(VT)){
! 16338: FA=funargs(car(VT));
! 16339: if(type(FA)==4&&(FA[0]==cos||FA[0]==sin)&&ptype(FA[1],X)>60){
! 16340: VTT=vars(FA[1]);
! 16341: if(type(FA[1])!=2||length(VTT)!=1) break;
! 16342: FB=funargs(VTT[0]);
! 16343: if(type(FB)!=4||(FF=findin(FB[0],[asin,acos,atan]))<0) break;
! 16344: if(!isint(2*(C=mycoef(FA[1],1,VTT[0])))||mycoef(FA[1],0,VTT[0])!=0) break;
! 16345: if(C==1/2){
! 16346: if(FF==1){
! 16347: U=(FA[0]==cos)?(1+FB[1])/2:(1-FB[1])/2;
! 16348: P=subst(P,car(VT),red(U)^(1/2));
! 16349: }else if(FF==2){
! 16350: if(FA[0]==sin){
! 16351: FB1=red(FB[1]);
! 16352: Nm=nm(FB1);CC=fctr(Nm)[0][0];Dn=dn(FB1);
! 16353: if(CC<0) CC=-CC;
! 16354: Nm/=CC;Dn/=CC;
! 16355: NN=Nm^2+Dn^2;
! 16356: P=subst(P,car(VT),((NN)^(1/2)-Dn)/Nm*cos(FA[1]));
! 16357: }
! 16358: }
! 16359: P=red(P);
! 16360: }else if(C==1){
! 16361: if(FF==1){
! 16362: if(FA[0]==cos) P=subst(P,car(VT),FB[1]);
! 16363: else P=subst(P,car(VT),(1-FB[1])^(1/2));
! 16364: }else if(FF==0){
! 16365: if(FA[0]==sin) P=subst(P,car(VT),FB[1]);
! 16366: else P=subst(P,car(VT),(1-FB[1])^(1/2));
! 16367: }
! 16368: P=red(P);
! 16369: }
! 16370: }
! 16371: }
! 16372: P=sqrt2rat(P);
! 16373: }
! 16374: return red(P);
! 16375: }
! 16376: Var=pfargs(P,X);
! 16377: for(VT=Var;VT!=[];VT=cdr(VT)){
! 16378: CT=car(VT);
! 16379: if(CT[1]==cos)
! 16380: P=subst(P,CT[0],exp(CT[2]*@i)/2+exp(-CT[2]*@i)/2);
! 16381: else if(CT[1]==sin)
! 16382: P=subst(P,CT[0],exp(-CT[2]*@i)*@i/2-exp(CT[2]*@i)*@i/2);
! 16383: else if (CT[1]==tan)
! 16384: P=subst(P,CT[0],(exp(-CT[2]*@i)*@i-exp(CT[2]*@i)*@i)/(exp(CT[2]*@i)+exp(-CT[2]*@i)));
! 16385: else if(CT[1]==pow){
! 16386: if(ptype(CT[2],X)>1) continue;
! 16387: if(CT[2]==@e) P=subst(P,CT[0],exp(CT[3]));
! 16388: else P=subst(P,CT[0],exp(log(CT[2])*exp(CT[3])));
! 16389: }
! 16390: }
! 16391: P=red(P);
! 16392: for(PP=1,Lp=(dn(P)==1)?1:0;Lp<2;Lp++){
! 16393: PP=1/PP;
! 16394: U=(Lp==0)?dn(P):nm(P);
! 16395: if(U==1) continue;
! 16396: Var=vars(U);
! 16397: for(R=[],VT=Var;VT!=[];VT=cdr(VT))
! 16398: if(functor(car(VT))==exp) R=cons(car(VT),R);
! 16399: RR=os_md.terms(U,R);
! 16400: for(Q=0,RRT=RR;RRT!=[];RRT=cdr(RRT)){
! 16401: for(S=0,CT=cdr(car(RRT)),CR=R,UT=U;CR!=[];CR=cdr(CR),CT=cdr(CT)){
! 16402: UT=mycoef(UT,car(CT),car(CR));S+=car(CT)*args(car(CR))[0];
! 16403: }
! 16404: if(S==0) Q+=UT;
! 16405: else Q+=UT*exp(S);
! 16406: }
! 16407: PP*=Q;
! 16408: }
! 16409: return PP;
! 16410: }
! 16411:
1.1 takayama 16412: def powsum(N)
16413: {
16414: if (N < 0) return 0;
16415: if (N == 0) return x;
16416: P = intpoly(N*powsum(N-1),x);
16417: C = subst(P,x,1);
16418: return P+(1-C)*x;
16419: }
16420:
16421: def bernoulli(N)
16422: {
16423: return mydiff(powsum(N),x) - N*x^(N-1);
16424: }
16425:
16426: /* linfrac01([x,y]) */
16427: /* linfrac01(newvect(10,[0,1,2,3,4,5,6,7,8,9]) */
16428: /* 0:x=0, 1:x=y, 2:x=1, 3:y=0, 4:y=1, 5:x=\infty, 6:y=\infty, 7:x=y=0, 8:x=y=1, 9:x=y=\infty
16429: 10:y_2=0, 11:y_2=x, 12:y_2=y, 13: y_2=1, 14: y_2=\infty
16430: 15:y_3=0, 16:y_3=x, 17:y_3=y, 18: y_3=y_2, 19: y_3=1, 20:y_3=\infty
16431: X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
16432: X[3],X[1],X[12],X[4],X[6]
16433:
16434: T=0 (x_2,x_1,x_3,x_4,...)
16435: T=-j (x_1,x_2,..,x_{j-1},x_{j+1},x_j,x_{j+2},...)
16436: T=1 (1-x_1,1-x_2,1-x_3,1-x_4,...)
16437: T=2 (1/x_1,1/x_2,1/x_3,1/x_4,...)
16438: T=3 (x_1,x_1/x_2,x_1/x_3,x_1/x_4,...)
16439: */
16440:
16441: def lft01(X,T)
16442: {
16443: MX=getopt();
16444: if(type(X)==4){
16445: K=length(X);
16446: if(K>=1) D=1;
16447: }
16448: if(type(X)==5){
16449: K=length(X);
16450: for(J=5, F=K-10; F>0; F-=J++);
16451: if(F==0) D=2;
16452: }
16453: if(D==0) return 0;
16454: if(T==0){ /* x <-> y */
16455: if(D==1){
16456: R=cdr(X); R=cdr(R);
16457: R=cons(X[0],R);
16458: return cons(X[1],R);
16459: }
16460: R=newvect(K,[X[3],X[1],X[4],X[0],X[2],X[6],X[5]]);
16461: for(I=7;I<K;I++) R[I]=X[I];
16462: for(I=11,J=5; I<K; I+=J++){
16463: R[I]=X[I+1]; R[I+1]=X[I];
16464: }
16465: return R;
16466: }
16467: if(T==1){
16468: if(D==1){
16469: for(R=[];X!=[];X=cdr(X)) R=cons(1-car(X),R);
16470: return reverse(R);
16471: }
16472: R=newvect(K,[X[2],X[1],X[0],X[4],X[3],X[5],X[6],X[8],X[7],X[9]]);
16473: for(I=11;I<K;I++) R[I]=X[I];
16474: for(I=10, J=5; I<K; I+=J++){
16475: R[I]=X[I+J-2]; R[I+J-2]=X[I];
16476: }
16477: return R;
16478: }
16479: if(T==2){
16480: if(D==1){
16481: for(R=[]; X!=[]; X=cdr(X)) R=cons(red(1/car(X)),R);
16482: return reverse(R);
16483: }
16484: R=newvect(K,[X[5],X[1],X[2],X[6],X[4],X[0],X[3],X[9],X[8],X[7]]);
16485: for(I=11;I<K;I++) R[I]=X[I];
16486: for(I=10,J=5; I<K; I+=J++){
16487: R[I]=X[I+J-1]; R[I+J-1]=X[I];
16488: }
16489: return R;
16490: }
16491: if(T==3){
16492: if(D==1){
16493: T=car(X);
16494: for(R=[T],X=cdr(X); X!=[]; X=cdr(X))
16495: R=cons(red(T/car(X)),R);
16496: return reverse(R);
16497: }
16498: R=newvect(K,[X[7],X[4],X[2],X[6],X[1],X[9],X[3],X[0],X[8],X[5]]);
16499: for(I=10,J=5; I<K; I+=J++){
16500: R[I]=X[I+J-1]; R[I+1]=X[I+J-2]; R[I+J-2]=X[I+1]; R[I+J-1]=X[I];
16501: }
16502: return R;
16503: }
16504: if(T==-1){
16505: if(D==1){
16506: return append([X[1],X[2],X[0]],cdr(cdr(cdr(X))));
16507: }
16508: R=newvect(K,[X[0],X[11],X[2],X[10],X[13],X[5],X[14],X[7],X[8],X[9],
16509: X[3],X[1],X[12],X[4],X[6]]);
16510: for(I=11;I<K;I++) R[I]=X[I];
16511: for(I=17,J=5; I<K; I+=J++){
16512: R[I]=X[I+1]; R[I+1]=X[I];
16513: }
16514: return R;
16515: }
16516: if(T<0){
16517: if(D==1){
16518: for(R=[],I=0; X!=[]; X=cdr(X),I--){
16519: if(I==T){
16520: R=cons(X[1],R);
16521: R=cons(X[0],R);
16522: X=cdr(X);
16523: }
16524: else R=cons(car(X),R);
16525: }
16526: return reverse(R);
16527: }
16528: T=3-T;
16529: R=newvect(K);
16530: for(I=0;I<K;I++) R[I]=X[I];
16531: for(I=10,J=5;J<T;I+=J++);
16532: for(II=0; II<J-2; II++){
16533: R[I]=X[I+J]; R[I+J]=R[I];
16534: }
16535: for( ; II<J; II++){
16536: R[I]=X[I+J+1]; R[I+J+1]=X[I];
16537: }
16538: return R;
16539: }
16540: return 0;
16541: }
16542:
16543: def linfrac01(X)
16544: {
16545: if(type(X)==4) K=length(X)-2;
16546: else if(type(X)==5){
16547: L=length(X);
16548: for(K=0,I=10,J=5; I<L; K++,I+=J++);
16549: if(I!=L) return 0;
16550: }
16551: if(K>3 && getopt(over)!=1) return(-1);
16552: II=(K==-1)?3:4;
16553: for(CC=C=1,L=[X]; C!=0; CC+=C){
16554: for(F=C,C=0,R=L; F>0; R=cdr(R), F--){
16555: P=car(R);
16556: for(I=-K; I<II; I++){
16557: S=lft01(P,I);
16558: if(findin(S,L) < 0){
16559: C++; L=cons(S,L);
16560: }
16561: }
16562: }
16563: }
16564: return L;
16565: }
16566:
1.4 ! takayama 16567:
! 16568: def varargs(P)
! 16569: {
! 16570: if((All=getopt(all))!=1) All=0;
! 16571: V=vars(P);
! 16572: for(Arg=FC=[];V!=[];V=cdr(V)){
! 16573: if(vtype(CV=car(V))==0&&All==1){
! 16574: Arg=lsort([CV],Arg,0);
! 16575: }
! 16576: if(vtype(CV)!=2) continue;
! 16577: if(findin(F=functor(CV),FC)<0) FC=cons(F,FC);
! 16578: for(AT=vars(args(CV));AT!=[];AT=cdr(AT)){
! 16579: if(vtype(X=car(AT))<2){
! 16580: if(findin(X,Arg)<0) Arg=cons(X,Arg);
! 16581: }else if(vtype(X)==2){
! 16582: R=varargs(X);
! 16583: if(R[1]!=[]){
! 16584: Arg=lsort(R[1],Arg,0);
! 16585: FC=lsort(R[0],FC,0);
! 16586: }
! 16587: }
! 16588: }
! 16589: }
! 16590: return [FC,Arg];
! 16591: }
! 16592:
! 16593: def pfargs(P,X)
! 16594: {
! 16595: if(type(L=getopt(level))!=1) L=0;
! 16596: for(Var=[],V=vars(P);V!=[];V=cdr(V)){
! 16597: if(vtype(car(V))==2){
! 16598: VT=funargs(car(V));
! 16599: if(length(VT)>1){
! 16600: if(L<2 &&(ptype(VT[1],X)>1 || (length(VT)>2 && ptype(VT[2],X)>1)))
! 16601: Var=cons(cons(car(V),VT),Var);
! 16602: if(L!=1 && (R=pfargs(VT[1],X|level=L-1))!=[]) Var=append(R,Var);
! 16603: }
! 16604: }
! 16605: }
! 16606: return reverse(Var);
! 16607: }
! 16608:
1.1 takayama 16609: def ptype(P,L)
16610: {
16611: if((T=type(P))<2 || T>3) return T;
16612: if(type(L)!=4) L=[L];
1.4 ! takayama 16613: F=0;
! 16614: if(lsort(L,varargs(dn(P))[1],2)!=[]) F=128;
! 16615: if(lsort(L,varargs(nm(P))[1],2)!=[]) F+=64;
! 16616: if(lsort(L,vars(dn(P)),2)!=[]) return F+3;
! 16617: return (lsort(L,vars(nm(P)),2)==[])?(F+1):(F+2);
1.1 takayama 16618: }
16619:
16620: def nthmodp(X,N,P)
16621: {
16622: X=X%P;
16623: for(Z=1;;){
16624: if((W=iand(N,1))==1) Z=(Z*X)%P;
16625: if((N=(N-W)/2)<=0) return Z;
16626: X=irem(X*X,P);
16627: }
16628: }
16629:
16630: def issquaremodp(X,P)
16631: {
16632: N=getopt(power);
16633: if(!isint(N)) N=2;
16634: if(P<=1 || !isint(P) || !pari(ispsp,P) || !isint(X) || !isint(N) || N<1){
16635: errno(0);
16636: return -2;
16637: }
16638: M=(P-1)/igcd(N,P-1);
16639: if((X%=P) == 0) return 0;
16640: if(X==1 || M==P-1) return 1;
16641: return (nthmodp(X,M,P)==1)?1:-1;
16642: }
16643:
1.3 takayama 16644: def iscoef(P,F)
16645: {
16646: if(P==0) return 1;
16647: if(type(P)==1) return F(P);
16648: if(type(P)==2) {
16649: X=var(P);
16650: for(I=deg(P,X); I>=0; I--){
16651: if(!iscoef(mycoef(P,I,X),F)) return 0;
16652: }
16653: }else if(type(P)==3){
16654: if(!iscoef(nm(P),F)||!iscoef(dn(P),F)) return 0;
16655: }else if(type(P)==4){
16656: for(;P!=[];P=cdr(P)) if(!iscoef(P,F)) return 0;
16657: }else if(type(P)>4 && type(P)<7) return iscoef(m2l(PP),F);
16658: else return 0;
16659: return 1;
16660: }
16661:
1.1 takayama 16662: def rootmodp(X,P)
16663: {
16664: X%=P;
16665: if(X==0) return [0];
16666: N=getopt(power);
16667: PP=pari(factor,P);
16668: P0=PP[0][0]; P1=PP[0][1];
16669: P2=pari(phi,P);
16670: if(!isint(N)) N=2;
16671: N%=P2;
16672: if(P0==2 || size(PP)[0]>1){
16673: for(I=1,R=[]; I<P2; I++)
16674: if(nthmodp(I,N,P)==X) R=cons(I,R);
16675: return qsort(R);
16676: }
16677: Y=primroot(P);
16678: if(Y==0) return 0;
16679: Z=nthmodp(Y,N,P);
16680: G=igcd(N,P2);
16681: P3=P2/G;
16682: for(I=0, W=1; I<P3;I++){
16683: if(W==X) break;
16684: W=(W*Z)%P;
16685: }
16686: if(I==P3) return [];
16687: W=nthmodp(Y,I,P);
16688: Z=nthmodp(Y,P3,P);
16689: for(I=0,R=[];;){
16690: R=cons(W,R);
16691: if(++I>=G) break;
16692: W=(W*Z)%P;
16693: }
16694: return qsort(R);
16695: }
16696:
16697: def primroot(P)
16698: {
16699: PP=pari(factor,P);
16700: P0=PP[0][0]; P1=PP[0][1];
16701: S=size(PP);
16702: if(S[0]>1 || !isint(P) || P0<=2){
16703: print("Not odd prime(power)!");
16704: return 0;
16705: }
16706: if(isint(Ind=getopt(ind))){
16707: Ind %= P;
16708: if(Ind<=0 || igcd(Ind,P)!=1 || (Z=primroot(P))==0){
16709: print("Not exist!");
16710: return 0;
16711: }
16712: P2=P0^(P1-1)*(P0-1);
16713: for(I=1,S=1; I<P2; I++)
16714: if((S = (S*Z)%P) == Ind) return I;
16715: return 0;
16716: }
16717: if(getopt(all)==1){
16718: I=primroot(P);
16719: P2=P0^(P1-1)*(P0-1);
16720: for(L=[],J=1; J<P2; J++){
16721: if(P1>1 && igcd(P0,J)!=1) continue;
16722: if(igcd(P0-1,J)!=1) continue;
16723: L=cons(nthmodp(I,J,P),L);
16724: }
16725: return qsort(L);
16726: }
16727: if(PP[0][1]>1){
16728: I=primroot(P0);
16729: P2=P0^(P1-2)*(P0-1);
16730: if(nthmodp(I,P2,P)==1) I+=P0;
16731: return I;
16732: }
16733: F=pari(factor,P-1);
16734: SF=size(F)[0];
16735: for(I=2; I<P; I++){
16736: for(J=0; J<SF; J++)
16737: if(nthmodp(I,(P-1)/F[J][0],P)==1) break;
16738: if(J==SF) return I;
16739: }
16740: }
16741:
16742: def rabin(P,X)
16743: {
16744: for(M=0,Q=P-1;iand(Q,1)==0;M++,Q/=2);
16745: Z=nthmodp(X,Q,P);
16746: for(N=M;M>0&&Z!=1&&Z!=P-1;M--,Z=(Z*Z)%P);
16747: return (M<N&&(M==0||Z==1))?0:1;
16748: }
16749:
1.3 takayama 16750: def powprimroot(P,N){
16751: if(P<3) P=3;
16752: FE=getopt(exp);
16753: if(FE!=1) FE=0;
16754: if((Log=getopt(log))==1||Log==2) FE=-1;
16755: else if(Log==3){
16756: FE=-2;
16757: for(PP=1, L0=["$r$","$p/a$"];;){
16758: PP=pari(nextprime,PP+1);
16759: if(PP>=P) break;
16760: L0=cons(PP, L0);
16761: }
16762: L0=reverse(L0);
16763: }
16764: if(FE==0) All=getopt(all);
16765: for(I=0, PP=P, LL=[]; I<N; I++,PP++){
16766: PP=pari(nextprime,PP);
16767: if(All==1){
16768: PR=primroot(PP|all=1);
16769: LL=cons(cons(PP,PR),LL);
16770: continue;
16771: }
16772: PR=primroot(PP);
16773: if(FE==-2){ /* log=3 */
16774: LT=cdr(L0);LT=cdr(L0);
16775: for(L=[PP];LT!=[];LT=cdr(LT))
16776: L=cons(primroot(PP|ind=car(LT)),L);
16777: LL=cons(reverse(L),LL);
16778: if(I<N-1) L0=append(L0,[PP]);
16779: }else if(FE){
16780: for(J=1, L=[PP], K=1; J<PP; J++){
16781: if(FE==-1){ /* log=1,2 */
16782: K=primroot(PP|ind=J);
16783: if(K==0 && Log==2) K=PP-1;
16784: }
16785: else K=(K*PR)%PP; /* exp=1 */
16786: L=cons(K,L);
16787: }
16788: LL=cons(reverse(L),LL);
16789: }else
16790: LL=cons([PP,PR],LL); /* default */
16791: }
16792: LL=reverse(LL);
16793: if(!FE) return LL;
16794: PP--;
16795: if(FE==-2) return append(LL,[L0]);
16796: for(I=1,L=["$p$"];I<PP; I++) L=cons(I,L);
16797: return cons(reverse(L),LL);
16798: }
16799:
16800: def ntable(F,II,D)
16801: {
16802: F=f2df(F|opt=-1);
16803: Df=getopt(dif);
16804: if(Df!=1) Df=0;
16805: Str=getopt(str);
16806: L=[];T=II[1]-II[0];
16807: for(L=[],I=0;I<=D;I++){
16808: X=II[0]+I*T/D;
16809: L=cons([X,myfdeval(F,X)],L);
16810: }
16811: if(Df==1){
16812: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
16813: if(LD==[]) LD=cons([car(LL)[0],car(LL)[1],0],LD);
16814: else LD=cons([car(LL)[0],car(LL)[1],abs(car(LL)[1]-car(LD)[1])],LD);
16815: }
16816: L=reverse(LD);
16817: }
16818: if(type(Str=getopt(str))==4){
16819: if(length(Str)==1) Str=[Str[0],Str[0]];
16820: if(Df==1 && length(Str)==2) Str=[Str[0],Str[1],Str[2]];
16821: for(S=Str,Str=[];S!=[];S=cdr(S)){
16822: if(type(car(S))!=4) Str=cons([car(S),3],Str);
16823: else Str=cons(car(S),Str);
16824: }
16825: Str=reverse(Str);
16826: for(LD=[],LL=L;LL!=[];LL=cdr(LL)){
16827: for(K=[],J=length(Str); --J>=0; )
16828: K=cons(sint(car(LL)[J],Str[J][0]|str=Str[J][1]),K);
16829: LD=cons(K,LD);
16830: }
16831: L=LD;
16832: }else
16833: L=reverse(L);
16834: if(type(M=getopt(mult))==1){
16835: Opt=[["opt","tab"],["vline",[[0,2+Df]]],["width",-M]];
16836: if(type(T=getopt(title))==7)
16837: Opt=cons(["title",T],Opt);
16838: if(type(Tp=getopt(top))==4)
16839: Opt=cons(["top",Tp],Opt);
16840: L=ltotex(L|option_list=Opt);
16841: }
16842: return L;
16843: }
16844:
16845: def distpoint(L)
16846: {
16847: L=m2l(L|flat=1);
16848: if(getopt(div)==5) Div=5;
16849: else Div=10;
16850: V=newvect(100/Div);
16851: for(LT=L,LL=[],N=0; LT!=[]; LT=cdr(LT)){
16852: if(type(K=car(LT))>1||K<0){
16853: N++; continue;
16854: }
16855: LL=cons(K,LL);
16856: T=idiv(K,Div);
16857: if(Div==10 && T>=9) T=9;
16858: else if(Div==5 && T>=19) T=19;
16859: V[T]++;
16860: }
16861: V=vtol(V);
16862: if((Opt=getopt(opt))=="data") return V;
16863: Title=getopt(title);
16864: OpList=[["opt","tab"]];
16865: if(type(Title=getopt(title)) == 7)
16866: OpList=cons(["title",Title],OpList);
16867: if(Opt=="average"){
16868: T=isMs()?["平均点","標準偏差","最低点","最高点","受験人数"]:
16869: ["average","deviation","min","max","examinees"];
16870: L=average(LL);
16871: L=[sint(L[0],1),sint(L[1],1),L[3],L[4],L[2]];
16872: if(N>0){
16873: T=append(T,[isMs()?"欠席者":"absentees"]);L=append(L,[N]);
16874: }
16875: OpList=cons(["align","c"],OpList);
16876: return ltotex([T,L]|option_list=OpList);
16877: }
16878:
16879: if(getopt(opt)=="graph"){
16880: Mul=getopt(size);
16881: if(Div==5){
16882: V0=["00","05","10","15","20","25","30","35","40","45","50","55",
16883: "60","65","70","75","80","85","90","95"];
16884: if(type(Mul)!=4){
16885: Size = (TikZ)?[12,3,1/2,0.2]:[120,30,1/2,2];
16886: }
16887: }else{
16888: V0=["00","10-","20-","30-","40-","50-","60-","70-","80-","90-"];
16889: if(type(Mul)!=4){
16890: Size = (TikZ)?[8,3,1/2,0.2]:[80,30,1/2,2];
16891: }
16892: }
16893: return ltotex([V,V0]|opt="graph",size=Size);
16894: }
16895: if(Div==5)
16896: V0=["00--04","05--09","10--14","15--19", "20--24", "25--29", "30--34", "35-39",
16897: "40--44", "45--49","50--54", "55--59","60--64", "65--69",
16898: "70--74", "75--79","80--84", "85--89","90--94", "95--100"];
16899: else
16900: V0=["00--09","10--19","20--29","30--39","40--49","50--59","60--69",
16901: "70--79","80--89","90--100"];
16902: Title=getopt(title);
16903: return ltotex([V0,V]|option_list=OpList);
16904: }
16905:
16906: def keyin(S)
16907: {
16908: print(S,2);
16909: purge_stdin();
16910: S=get_line();
16911: L=length(S=strtoascii(S));
16912: if(L==0) return "";
16913: return str_cut(S,0,L-2);
16914: }
16915:
1.1 takayama 16916: def init() {
1.4 ! takayama 16917: LS=["DIROUT","DVIOUTA","DVIOUTB","DVIOUTH","DVIOUTL","TeXLim","TeXEq","TikZ",
! 16918: "XYPrec","XYcm","Canvas"];
1.1 takayama 16919: if(!access(get_rootdir()+"/help/os_muldif.dvi")||!access(get_rootdir()+"/help/os_muldif.pdf"))
16920: mycat(["Put os_muldif.dvi and os_muldif.pdf in", get_rootdir()+(isMs()?"\\help.":"/help.")]);
16921: if(!isMs()){
1.3 takayama 16922: DIROUT="%HOME%/asir/tex";
16923: DVIOUTA=str_subst(DVIOUTA,[["\\","/"],[".bat",".sh"]],0);
16924: DVIOUTB=str_subst(DVIOUTB,[["\\","/"],[".bat",".sh"]],0);
16925: DVIOUTL=str_subst(DVIOUTL,[["\\","/"],[".bat",".sh"]],0);
16926: DVIOUTH="%ASIRROOT%/help/os_muldif.pdf";
1.1 takayama 16927: }
16928: Home=getenv("HOME");
1.3 takayama 16929: if(type(Home)!=7) Home="";
16930: for(Id=-7, F=Home; Id<-1;){
1.1 takayama 16931: G = F+"/.muldif";
16932: if(access(G)) Id = open_file(G);
16933: else Id++;
1.3 takayama 16934: if(Id==-6) F+="/asir";
1.1 takayama 16935: else if(Id==-5) F=get_rootdir();
16936: else if(Id==-4) F+="/bin";
16937: else if(Id==-3) F=get_rootdir()+"/lib-asir-contrib";
16938: }
16939: if(Id>=0){
16940: while((S=get_line(Id))!=0){
1.3 takayama 16941: if(type(P=str_str(S,LS))==4 && (P0=str_char(S,P[1]+5,"="))>0){
16942: if(P[0]<5){
1.1 takayama 16943: P0=str_chr(S,P0+1,"\"");
16944: if(P0>0){
16945: for(P1=P0;(P2=str_char(S,P1+1,"\""))>0; P1=P2);
16946: if(P1>P0+1){
16947: SS=str_cut(S,P0+1,P1-1);
16948: SS=str_subst(SS,["\\\\","\\\""],["\\","\""]);
16949: if(P[0]==0) DIROUT=SS;
16950: else if(P[0]==1) DVIOUTA=SS;
1.3 takayama 16951: else if(P[0]==2) DVIOUTB=SS;
16952: else if(P[0]==3) DVIOUTH=SS;
16953: else if(P[0]==4) DVIOUTL=SS;
1.1 takayama 16954: }
16955: }
1.3 takayama 16956: if(P0<0 || P1<P0+2) mycat(["Error! Definiton of", LS[P[0]],
16957: "in .muldif"]);
1.1 takayama 16958: }else{
16959: SV=eval_str(str_cut(S,P0+1,str_len(S)-1));
1.3 takayama 16960: if(P[0]==5) TeXLim=SV;
16961: else if(P[0]==6) TeXEq=SV;
16962: else if(P[0]==7) TikZ=SV;
16963: else if(P[0]==8) XYPrec=SV;
16964: else if(P[0]==9) XYcm=SV;
1.4 ! takayama 16965: else if(P[0]==10) XYcm=Canvas;
1.1 takayama 16966: }
16967: }
16968: }
16969: close_file(Id);
16970: }
16971: chkfun(1,0);
16972: }
1.3 takayama 16973:
1.1 takayama 16974: #ifdef USEMODULE
16975: endmodule;
16976: os_md.init()$
16977: #else
16978: init()$
16979: #endif
16980:
16981: end$