Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.46
1.46 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.45 2004/09/17 00:10:41 takayama Exp $
1.1 maekawa 2: %% dr.sm1 (Define Ring) 1994/9/25, 26
3: %% This file is error clean.
4:
5: @@@.quiet { }
1.5 takayama 6: { (macro package : dr.sm1, 9/26,1995 --- Version 12/10, 2000. ) message } ifelse
1.1 maekawa 7:
8: /ctrlC-hook {
9: %%% define your own routing in case of error.
10: } def
11: [(ctrlC-hook)
12: [(When ctrl-C is pressed, this function is executed.)
13: (User can define one's own ctrlC-hook function.)
14: ]] putUsages
15:
16: %% n evenQ bool
17: /evenQ {
18: /arg1 set
19: arg1 2 idiv 2 mul arg1 sub 0 eq
20: { true }
21: { false } ifelse
22: } def
23:
24: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
25: /ring_of_polynomials {
26: /arg1 set
27: [/vars /n /i /xList /dList /param] pushVariables
28: %dup print (-----) message
29: [
30: (mmLarger) (matrix) switch_function
31: (mpMult) (poly) switch_function
32: (red@) (module1) switch_function
33: (groebner) (standard) switch_function
34: (isSameComponent) (x) switch_function
35:
36: [arg1 to_records pop] /vars set
37: vars length evenQ
38: { }
39: { vars [(PAD)] join /vars set }
40: ifelse
41: vars length 2 idiv /n set
42: [ << n 1 sub >> -1 0
43: { /i set
44: vars i get
45: } for
46: ] /xList set
47: [ << n 1 sub >> -1 0
48: { /i set
49: vars << i n add >> get
50: } for
51: ] /dList set
52:
1.28 takayama 53: [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1 maekawa 54: [(h)] dList join [@@@.Esymbol] join /dList set
55: [0 %% dummy characteristic
56: << xList length >> << xList length >> << xList length >>
57: << xList length >>
58: << xList length 1 sub >> << xList length >> << xList length >>
59: << xList length >>
60: ] /param set
61:
62: [xList dList param] /arg1 set
63: ] pop
64: popVariables
65: arg1
66: } def
67:
68: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
69: %% with no graduation and homogenization variables.
70: /ring_of_polynomials2 {
71: /arg1 set
72: [/vars /n /i /xList /dList /param] pushVariables
73: %dup print (-----) message
74: [
75: (mmLarger) (matrix) switch_function
76: (mpMult) (poly) switch_function
77: (red@) (module1) switch_function
78: (groebner) (standard) switch_function
79: (isSameComponent) (x) switch_function
80:
81: [arg1 to_records pop] /vars set
82: vars length evenQ
83: { }
84: { vars [(PAD)] join /vars set }
85: ifelse
86: vars length 2 idiv /n set
87: [ << n 1 sub >> -1 0
88: { /i set
89: vars i get
90: } for
91: ] /xList set
92: [ << n 1 sub >> -1 0
93: { /i set
94: vars << i n add >> get
95: } for
96: ] /dList set
97:
98: [0 %% dummy characteristic
99: << xList length >> << xList length >> << xList length >>
100: << xList length >>
101: << xList length >> << xList length >> << xList length >>
102: << xList length >>
103: ] /param set
104:
105: [xList dList param] /arg1 set
106: ] pop
107: popVariables
108: arg1
109: } def
110:
111: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
112: %% with no homogenization variables.
113: /ring_of_polynomials3 {
114: /arg1 set
115: [/vars /n /i /xList /dList /param] pushVariables
116: %dup print (-----) message
117: [
118: (mmLarger) (matrix) switch_function
119: (mpMult) (poly) switch_function
120: (red@) (module1) switch_function
121: (groebner) (standard) switch_function
122: (isSameComponent) (x) switch_function
123:
124: [arg1 to_records pop] /vars set
125: vars length evenQ
126: { }
127: { vars [(PAD)] join /vars set }
128: ifelse
129: vars length 2 idiv /n set
130: [ << n 1 sub >> -1 0
131: { /i set
132: vars i get
133: } for
134: ] /xList set
135: xList [@@@.esymbol] join /xList set
136: [ << n 1 sub >> -1 0
137: { /i set
138: vars << i n add >> get
139: } for
140: ] /dList set
141: dList [@@@.Esymbol] join /dList set
142:
143: [0 %% dummy characteristic
144: << xList length >> << xList length >> << xList length >>
145: << xList length >>
146: << xList length >> << xList length >> << xList length >>
147: << xList length >>
148: ] /param set
149:
150: [xList dList param] /arg1 set
151: ] pop
152: popVariables
153: arg1
154: } def
155:
156: /ring_of_differential_operators {
157: /arg1 set
158: [/vars /n /i /xList /dList /param] pushVariables
159: [
160: (mmLarger) (matrix) switch_function
161: (mpMult) (diff) switch_function
162: (red@) (module1) switch_function
163: (groebner) (standard) switch_function
164: (isSameComponent) (x) switch_function
165:
166: [arg1 to_records pop] /vars set %[x y z]
167: vars reverse /xList set %[z y x]
168: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
169: reverse /dList set %[Dz Dy Dx]
1.28 takayama 170: [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1 maekawa 171: [(h)] dList join [@@@.Esymbol] join /dList set
172: [0 1 1 1 << xList length >>
173: 1 1 1 << xList length 1 sub >> ] /param set
174: [ xList dList param ] /arg1 set
175: ] pop
176: popVariables
177: arg1
178: } def
179:
180: /ring_of_differential_operators3 {
181: %% with no homogenization variables.
182: /arg1 set
183: [/vars /n /i /xList /dList /param] pushVariables
184: [
185: (mmLarger) (matrix) switch_function
186: (mpMult) (diff) switch_function
187: (red@) (module1) switch_function
188: (groebner) (standard) switch_function
189: (isSameComponent) (x) switch_function
190:
191: [arg1 to_records pop] /vars set %[x y z]
192: vars reverse /xList set %[z y x]
193: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
194: reverse /dList set %[Dz Dy Dx]
195: xList [@@@.esymbol] join /xList set
196: dList [@@@.Esymbol] join /dList set
197: [0 0 0 0 << xList length >>
198: 0 0 0 << xList length 1 sub >> ] /param set
199: [ xList dList param ] /arg1 set
200: ] pop
201: popVariables
202: arg1
203: } def
204:
205: /ring_of_q_difference_operators {
206: /arg1 set
207: [/vars /n /i /xList /dList /param] pushVariables
208: [
209: (mmLarger) (matrix) switch_function
210: (mpMult) (diff) switch_function
211: (red@) (module1) switch_function
212: (groebner) (standard) switch_function
213: (isSameComponent) (x) switch_function
214:
215: [arg1 to_records pop] /vars set %[x y z]
216: vars reverse /xList set %[z y x]
217: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
218: reverse /dList set %[Dz Dy Dx]
219: [(q)] xList join [@@@.esymbol] join /xList set
220: [(h)] dList join [@@@.Esymbol] join /dList set
221: [0 1 << xList length >> << xList length >> << xList length >>
222: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
223: /param set
224: [ xList dList param ] /arg1 set
225: ] pop
226: popVariables
227: arg1
228: } def
229:
230: /ring_of_q_difference_operators3 {
231: %% with no homogenization and q variables.
232: /arg1 set
233: [/vars /n /i /xList /dList /param] pushVariables
234: [
235: (mmLarger) (matrix) switch_function
236: (mpMult) (diff) switch_function
237: (red@) (module1) switch_function
238: (groebner) (standard) switch_function
239: (isSameComponent) (x) switch_function
240:
241: [arg1 to_records pop] /vars set %[x y z]
242: vars reverse /xList set %[z y x]
243: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
244: reverse /dList set %[Dz Dy Dx]
245: xList [@@@.esymbol] join /xList set
246: dList [@@@.Esymbol] join /dList set
247: [0 0 << xList length >> << xList length >> << xList length >>
248: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
249: /param set
250: [ xList dList param ] /arg1 set
251: ] pop
252: popVariables
253: arg1
254: } def
255:
256: /ring_of_difference_operators {
257: /arg1 set
258: [/vars /n /i /xList /dList /param] pushVariables
259: [
1.8 takayama 260: (This is an obsolete macro. Use ring_of_differential_difference_operators)
261: error
1.1 maekawa 262: (mmLarger) (matrix) switch_function
263: (mpMult) (difference) switch_function
264: (red@) (module1) switch_function
265: (groebner) (standard) switch_function
266: (isSameComponent) (x) switch_function
267:
268: [arg1 to_records pop] /vars set %[x y z]
269: vars reverse /xList set %[z y x]
270: vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
271: reverse /dList set %[Dz Dy Dx]
1.28 takayama 272: [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.1 maekawa 273: [(h)] dList join [@@@.Esymbol] join /dList set
274: [0 1 1 << xList length >> << xList length >>
275: 1 1 << xList length 1 sub >> << xList length >> ] /param set
276: [ xList dList param ] /arg1 set
277: ] pop
278: popVariables
279: arg1
280: } def
281:
282:
1.8 takayama 283: /ring_of_differential_difference_operators {
284: /arg1 set
285: [/vars /n /i /xList /dList /param /dvar /evar /vars2 ] pushVariables
286: [
287: /vars arg1 def
288: vars tag 6 eq not {
289: ( List is expected as the argument for ring_of_differential_difference_operators ) error
290: } { } ifelse
291: vars 0 get /dvar set
292: vars 1 get /evar set
293: (mmLarger) (matrix) switch_function
294: (mpMult) (difference) switch_function
295: (red@) (module1) switch_function
296: (groebner) (standard) switch_function
297: (isSameComponent) (x) switch_function
298:
299: [dvar to_records pop] /vars set %[x y z]
300: vars reverse /xList set %[z y x]
301:
302: [evar to_records pop] /vars2 set %[s1 s2]
303:
304: vars2 reverse {@@@.Esymbol 2 1 roll 2 cat_n} map
305: xList
306: join /xList set %[Es2 Es1 z y x]
307:
308: vars2 reverse
309: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
310: reverse join /dList set %[s2 s1 Dz Dy Dx]
1.28 takayama 311: [@@@.Hsymbol] xList join [@@@.esymbol] join /xList set
1.8 takayama 312: [(h)] dList join [@@@.Esymbol] join /dList set
313: [0 1 1 << vars2 length 1 add >> << xList length >>
314: 1 1 << vars2 length 1 add >> << xList length 1 sub >> ] /param set
315: [ xList dList param ] /arg1 set
316: ] pop
317: popVariables
318: arg1
319: } def
1.1 maekawa 320:
321: /reverse {
322: /arg1 set
323: arg1 length 1 lt
324: { [ ] }
325: {
326: [
327: << arg1 length 1 sub >> -1 0
328: {
329: arg1 2 1 roll get
330: } for
331: ]
332: } ifelse
333: } def
334:
335: /memberQ {
336: %% a set0 memberQ bool
337: /arg2 set /arg1 set
338: [/a /set0 /flag /i ] pushVariables
339: [
340: /a arg1 def /set0 arg2 def
341: /flag 0 def
342: 0 1 << set0 length 1 sub >>
343: {
344: /i set
1.42 takayama 345: set0 i get tag , a tag , eq {
346: << set0 i get >> a eq
347: {
348: /flag 1 def exit
349: }
350: { }
351: ifelse
352: } { } ifelse
1.1 maekawa 353: } for
354: ] pop
355: /arg1 flag def
356: popVariables
357: arg1
358: } def
359:
360: /transpose {
361: /arg1 set
362: [/mat /m /n /ans /i /j] pushVariables
363: [
364: /mat arg1 def
365: /m mat length def
1.34 takayama 366: {
367: m 0 eq { /ans [ ] def exit } { } ifelse
1.1 maekawa 368: mat 0 get isArray
369: { }
370: { (transpose: Argument must be an array of arrays.) error }
371: ifelse
372: /n mat 0 get length def
373: /ans [ 1 1 n { pop [ 1 1 m { pop 0 } for ]} for ] def
374: 0 1 << m 1 sub >> {
375: /i set
376: 0 1 << n 1 sub >> {
377: /j set
378: ans [ j i ] << mat i get j get >> put
379: } for
380: } for
1.34 takayama 381: exit
382: } loop
1.1 maekawa 383: /arg1 ans def
384: ] pop
385: popVariables
386: arg1
387: } def
388:
389:
390: /getPerm {
391: %% old new getPerm perm
392: /arg2 set /arg1 set
393: [/old /new /i /j /p] pushVariables
394: [
395: /old arg1 def
396: /new arg2 def
397: [
398: /p old length def
399: 0 1 << p 1 sub >>
400: {
401: /i set
402: 0 1 << p 1 sub >>
403: {
404: /j set
405: old i get
406: new j get
407: eq
408: { j }
409: { } ifelse
410: } for
411: } for
412: ] /arg1 set
413: ] pop
414: popVariables
415: arg1
416: } def
417:
418: /permuteOrderMatrix {
419: %% order perm puermuteOrderMatrix newOrder
420: /arg2 set /arg1 set
421: [/order /perm /newOrder /k ] pushVariables
422: [
423: /order arg1 def
424: /perm arg2 def
425: order transpose /order set
426: order 1 copy /newOrder set pop
427:
428: 0 1 << perm length 1 sub >>
429: {
430: /k set
431: newOrder << perm k get >> << order k get >> put
432: } for
433: newOrder transpose /newOrder set
434: ] pop
435: /arg1 newOrder def
436: popVariables
437: arg1
438: } def
439:
440:
441:
442: /complement {
443: %% set0 universe complement compl
444: /arg2 set /arg1 set
445: [/set0 /universe /compl /i] pushVariables
446: /set0 arg1 def /universe arg2 def
447: [
448: 0 1 << universe length 1 sub >>
449: {
450: /i set
451: << universe i get >> set0 memberQ
452: { }
453: { universe i get }
454: ifelse
455: } for
456: ] /arg1 set
457: popVariables
458: arg1
459: } def
460:
461:
462: %%% from order.sm1
463:
464: %% size i evec [0 0 ... 0 1 0 ... 0]
465: /evec {
466: /arg2 set /arg1 set
467: [/size /iii] pushVariables
468: /size arg1 def /iii arg2 def
469: [
470: 0 1 << size 1 sub >>
471: {
472: iii eq
473: { 1 }
474: { 0 }
475: ifelse
476: } for
477: ] /arg1 set
478: popVariables
479: arg1
480: } def
481:
482: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
483: /evec_neg {
484: /arg2 set /arg1 set
485: [/size /iii] pushVariables
486: /size arg1 def /iii arg2 def
487: [
488: 0 1 << size 1 sub >>
489: {
490: iii eq
491: { -1 }
492: { 0 }
493: ifelse
494: } for
495: ] /arg1 set
496: popVariables
497: arg1
498: } def
499:
500:
501: %% size i j e_ij << matrix e(i,j) >>
502: /e_ij {
503: /arg3 set /arg2 set /arg1 set
504: [/size /k /i /j] pushVariables
505: [
506: /size arg1 def /i arg2 def /j arg3 def
507: [ 0 1 << size 1 sub >>
508: {
509: /k set
510: k i eq
511: { size j evec }
512: {
513: k j eq
514: { size i evec }
515: { size k evec }
516: ifelse
517: } ifelse
518: } for
519: ] /arg1 set
520: ] pop
521: popVariables
522: arg1
523: } def
524:
525:
526: %% size i j d_ij << matrix E_{ij} >>
527: /d_ij {
528: /arg3 set /arg2 set /arg1 set
529: [/size /k /i /j] pushVariables
530: [
531: /size arg1 def /i arg2 def /j arg3 def
532: [ 0 1 << size 1 sub >>
533: {
534: /k set
535: k i eq
536: { size j evec }
537: {
538: [ 0 1 << size 1 sub >> { pop 0} for ]
539: } ifelse
540: } for
541: ] /arg1 set
542: ] pop
543: popVariables
544: arg1
545: } def
546:
547: %% size matid << id matrix >>
548: /matid {
549: /arg1 set
550: [/size /k ] pushVariables
551: [
552: /size arg1 def
553: [ 0 1 << size 1 sub >>
554: {
555: /k set
556: size k evec
557: } for
558: ] /arg1 set
559: ] pop
560: popVariables
561: arg1
562: } def
563:
564:
565: %% m1 m2 oplus
566: /oplus {
567: /arg2 set /arg1 set
568: [/m1 /m2 /n /m /k ] pushVariables
569: [
570: /m1 arg1 def /m2 arg2 def
571: m1 length /n set
572: m2 length /m set
573: [
574: 0 1 << n m add 1 sub >>
575: {
576: /k set
577: k n lt
578: {
579: << m1 k get >> << m -1 evec >> join
580: }
581: {
582: << n -1 evec >> << m2 << k n sub >> get >> join
583: } ifelse
584: } for
585: ] /arg1 set
586: ] pop
587: popVariables
588: arg1
589: } def
590:
591: %%%%%%%%%%%%%%%%%%%%%%%
592:
593: /eliminationOrderTemplate { %% esize >= 1
594: %% if esize == 0, it returns reverse lexicographic order.
595: %% m esize eliminationOrderTemplate mat
596: /arg2 set /arg1 set
597: [/m /esize /m1 /m2 /k ] pushVariables
598: [
599: /m arg1 def /esize arg2 def
600: /m1 m esize sub 1 sub def
601: /m2 esize 1 sub def
602: [esize 0 gt
603: {
604: [1 1 esize
605: { pop 1 } for
606: esize 1 << m 1 sub >>
607: { pop 0 } for
608: ] %% 1st vector
609: }
610: { } ifelse
611:
612: m esize gt
613: {
614: [1 1 esize
615: { pop 0 } for
616: esize 1 << m 1 sub >>
617: { pop 1 } for
618: ] %% 2nd vector
619: }
620: { } ifelse
621:
622: m1 0 gt
623: {
624: m 1 sub -1 << m m1 sub >>
625: {
626: /k set
627: m k evec_neg
628: } for
629: }
630: { } ifelse
631:
632: m2 0 gt
633: {
634: << esize 1 sub >> -1 1
635: {
636: /k set
637: m k evec_neg
638: } for
639: }
640: { } ifelse
641:
642: ] /arg1 set
643: ] pop
644: popVariables
645: arg1
646: } def
647:
648: /elimination_order {
649: %% [x-list d-list params] (x,y,z) elimination_order
650: %% vars evars
651: %% [x-list d-list params order]
652: /arg2 set /arg1 set
653: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
654: /vars arg1 def /evars [arg2 to_records pop] def
655: [
656: /univ vars 0 get reverse
657: vars 1 get reverse join
658: def
659:
660: << univ length 2 sub >>
661: << evars length >>
662: eliminationOrderTemplate /order set
663:
664: [[1]] order oplus [[1]] oplus /order set
665:
666: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
667:
668: /compl
669: [univ 0 get] evars join evars univ0 complement join
670: def
671: compl univ
672: getPerm /perm set
673: %%perm :: univ :: compl ::
674:
675: order perm permuteOrderMatrix /order set
676:
677:
678: vars [order] join /arg1 set
679: ] pop
680: popVariables
681: arg1
682: } def
683:
684: /elimination_order2 {
685: %% [x-list d-list params] (x,y,z) elimination_order
686: %% vars evars
687: %% [x-list d-list params order]
688: %% with no graduation and homogenization variables.
689: /arg2 set /arg1 set
690: [/vars /evars /univ /order /perm /compl] pushVariables
691: /vars arg1 def /evars [arg2 to_records pop] def
692: [
693: /univ vars 0 get reverse
694: vars 1 get reverse join
695: def
696:
697: << univ length >>
698: << evars length >>
699: eliminationOrderTemplate /order set
700: /compl
701: evars << evars univ complement >> join
702: def
703: compl univ
704: getPerm /perm set
705: %%perm :: univ :: compl ::
706:
707: order perm permuteOrderMatrix /order set
708:
709: vars [order] join /arg1 set
710: ] pop
711: popVariables
712: arg1
713: } def
714:
715:
716: /elimination_order3 {
717: %% [x-list d-list params] (x,y,z) elimination_order
718: %% vars evars
719: %% [x-list d-list params order]
720: /arg2 set /arg1 set
721: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
722: /vars arg1 def /evars [arg2 to_records pop] def
723: [
724: /univ vars 0 get reverse
725: vars 1 get reverse join
726: def
727:
728: << univ length 1 sub >>
729: << evars length >>
730: eliminationOrderTemplate /order set
731:
732: [[1]] order oplus /order set
733:
734: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
735:
736: /compl
737: [univ 0 get] evars join evars univ0 complement join
738: def
739: compl univ
740: getPerm /perm set
741: %%perm :: univ :: compl ::
742:
743: order perm permuteOrderMatrix /order set
744:
745: vars [order] join /arg1 set
746: ] pop
747: popVariables
748: arg1
749: } def
750:
751:
752: /define_ring {
753: %[ (x,y,z) ring_of_polynominals
754: % (x,y) elimination_order
755: % 17
756: %] define_ring
757: % or
758: %[ (x,y,z) ring_of_polynominals
759: % (x,y) elimination_order
760: % 17
761: % [(keyword) value (keyword) value ...]
762: %] define_ring
763: /arg1 set
764: [/rp /param /foo] pushVariables
765: [/rp arg1 def
766:
767: rp 0 get length 3 eq {
768: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
769: ( ) elimination_order put
770: } { } ifelse
771:
772: [
773: rp 0 get 0 get %% x-list
774: rp 0 get 1 get %% d-list
775: rp 0 get 2 get /param set
776: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
777: param %% parameters.
778: rp 0 get 3 get %% order matrix.
779: rp length 2 eq
780: { [ ] } %% null optional argument.
781: { rp 2 get }
782: ifelse
783: ] /foo set
784: foo aload pop set_up_ring@
785: ] pop
786: popVariables
787: [(CurrentRingp)] system_variable
788: } def
789:
790:
791: [(define_qring)
792: [( [varlist ring_of_q_difference_operators order characteristic] define_qring)
793: ( Pointer to the ring. )
794: (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)
795: ( 0] define_qring )
1.37 takayama 796: (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << __ >>)
1.1 maekawa 797: ]
798: ] putUsages
799: /define_qring {
800: %[ (x,y,z) ring_of_q_difference_operators
801: % (Qx,Qy) elimination_order
802: % 17
803: %] define_qring
804: /arg1 set
805: [/rp /param /foo /cring /ppp] pushVariables
806: [/rp arg1 def
807: /ppp rp 1 get def
808: %% define coefficient ring.
809: [(q) @@@.esymbol] [(h) @@@.Esymbol]
810: [ppp 2 2 2 2 1 2 2 2]
811: [[1 0 0 0] [0 1 0 0] [0 0 1 0] [0 0 0 1]]
812: [(mpMult) (poly)] set_up_ring@
813: /cring [(CurrentRingp)] system_variable def
814:
815: rp 0 get length 3 eq {
816: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
817: ( ) elimination_order put
818: } { } ifelse
819:
820: [
821: rp 0 get 0 get %% x-list
822: rp 0 get 1 get %% d-list
823: rp 0 get 2 get /param set
824: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
825: param %% parameters.
826: rp 0 get 3 get %% order matrix.
827: rp length 2 eq
828: { [(mpMult) (diff) (coefficient ring) cring] } %% optional argument.
829: { [(mpMult) (diff) (coefficient ring) cring] rp 2 get join }
830: ifelse
831: ] /foo set
832: foo aload pop set_up_ring@
833: ] pop
834: popVariables
835: [(CurrentRingp)] system_variable
836: } def
837:
838: [(ring_def)
839: [(ring ring_def)
840: (Set the current ring to the <<ring>>)
841: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 0 ] define_ring)
842: ( /R set)
843: ( R ring_def)
844: (In order to get the ring object R to which a given polynomial f belongs,)
845: (one may use the command )
846: ( f (ring) data_conversion /R set)
847: (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)
1.37 takayama 848: (cf. << __ >>)
1.1 maekawa 849: ]
850: ] putUsages
851:
852: /ring_def {
853: /arg1 set
854: [(CurrentRingp) arg1] system_variable
855: } def
856:
857:
858:
859: /lexicographicOrderTemplate {
860: % size lexicographicOrderTemplate matrix
861: /arg1 set
862: [/k /size] pushVariables
863: [
864: /size arg1 def
865: [ 0 1 << size 1 sub >>
866: {
867: /k set
868: size k evec
869: } for
870: ] /arg1 set
871: ] pop
872: popVariables
873: arg1
874: } def
875:
876: /lexicographic_order {
877: %% [x-list d-list params] (x,y,z) lexicograhic_order
878: %% vars evars
879: %% [x-list d-list params order]
880: /arg2 set /arg1 set
881: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
882: /vars arg1 def /evars [arg2 to_records pop] def
883: [
884: /univ vars 0 get reverse
885: vars 1 get reverse join
886: def
887:
888: << univ length 2 sub >>
889: lexicographicOrderTemplate /order set
890:
891: [[1]] order oplus [[1]] oplus /order set
892:
893: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
894:
895: /compl
896: [univ 0 get] evars join evars univ0 complement join
897: def
898: compl univ
899: getPerm /perm set
900: %%perm :: univ :: compl ::
901:
902: order perm permuteOrderMatrix /order set
903:
904: vars [order] join /arg1 set
905: ] pop
906: popVariables
907: arg1
908: } def
909:
910: /lexicographic_order2 {
911: %% [x-list d-list params] (x,y,z) lexicograhic_order
912: %% vars evars
913: %% [x-list d-list params order]
914: %% with no graduation and homogenization variables
915: /arg2 set /arg1 set
916: [/vars /evars /univ /order /perm /compl] pushVariables
917: /vars arg1 def /evars [arg2 to_records pop] def
918: [
919: /univ vars 0 get reverse
920: vars 1 get reverse join
921: def
922:
923: << univ length >>
924: lexicographicOrderTemplate /order set
925:
926: /compl
927: evars << evars univ complement >> join
928: def
929: compl univ
930: getPerm /perm set
931:
932: order perm permuteOrderMatrix /order set
933:
934: vars [order] join /arg1 set
935: ] pop
936: popVariables
937: arg1
938: } def
939:
940: /lexicographic_order3 {
941: %% [x-list d-list params] (x,y,z) lexicograhic_order
942: %% vars evars
943: %% [x-list d-list params order]
944: %% with no homogenization variable.
945: /arg2 set /arg1 set
946: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
947: /vars arg1 def /evars [arg2 to_records pop] def
948: [
949: /univ vars 0 get reverse
950: vars 1 get reverse join
951: def
952:
953: << univ length 1 sub >>
954: lexicographicOrderTemplate /order set
955:
956: [[1]] order oplus /order set
957:
958: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
959:
960: /compl
961: [univ 0 get] evars join evars univ0 complement join
962: def
963: compl univ
964: getPerm /perm set
965: %%perm :: univ :: compl ::
966:
967: order perm permuteOrderMatrix /order set
968:
969: vars [order] join /arg1 set
970: ] pop
971: popVariables
972: arg1
973: } def
974:
975: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
976:
977: /graded_reverse_lexicographic_order {
978: ( ) elimination_order
979: } def
980:
981:
982: /getX {
983: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
984: /arg2 set /arg1 set
985: [/k /param /func /low /top] pushVariables
986: [
987: /param arg1 def /func arg2 def
988: func 1 eq
989: {
990: /low 0 def
991: }
992: {
993: /low << param 2 get >> << func 1 sub >> get def
994: } ifelse
995: /top << param 2 get >> << func 4 add >> get 1 sub def
996: [
997: low 1 top
998: {
999: /k set
1000: param 0 get k get
1001: } for
1002: ] /arg1 set
1003: ] pop
1004: popVariables
1005: arg1
1006: } def
1007:
1008: /getD {
1009: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
1010: /arg2 set /arg1 set
1011: [/k /param /func /low /top] pushVariables
1012: [
1013: /param arg1 def /func arg2 def
1014: func 1 eq
1015: {
1016: /low 0 def
1017: }
1018: {
1019: /low << param 2 get >> << func 1 sub >> get def
1020: } ifelse
1021: /top << param 2 get >> << func 4 add >> get 1 sub def
1022: [
1023: low 1 top
1024: {
1025: /k set
1026: param 1 get k get
1027: } for
1028: ] /arg1 set
1029: ] pop
1030: popVariables
1031: arg1
1032: } def
1033:
1034: /getXV {
1035: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
1036: /arg2 set /arg1 set
1037: [/k /param /func /low /top] pushVariables
1038: [
1039: /param arg1 def /func arg2 def
1040: /low << param 2 get >> << func 4 add >> get def
1041: /top << param 2 get >> func get 1 sub def
1042: [
1043: low 1 top
1044: {
1045: /k set
1046: param 0 get k get
1047: } for
1048: ] /arg1 set
1049: ] pop
1050: popVariables
1051: arg1
1052: } def
1053:
1054: /getDV {
1055: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
1056: /arg2 set /arg1 set
1057: [/k /param /func /low /top] pushVariables
1058: [
1059: /param arg1 def /func arg2 def
1060: /low << param 2 get >> << func 4 add >> get def
1061: /top << param 2 get >> func get 1 sub def
1062: [
1063: low 1 top
1064: {
1065: /k set
1066: param 1 get k get
1067: } for
1068: ] /arg1 set
1069: ] pop
1070: popVariables
1071: arg1
1072: } def
1073:
1074: /reNaming {
1075: %% It also changes oldx2 and oldd2, which are globals.
1076: /arg1 set
1077: [/i /j /new /count /ostr /k] pushVariables
1078: [
1079: /new arg1 def
1080: /count 0 def
1081: 0 1 << new length 1 sub >> {
1082: /i set
1083: << i 1 add >> 1 << new length 1 sub >> {
1084: /j set
1085: << new i get >> << new j get >> eq
1086: {
1087: new j get /ostr set
1088: (The two rings have the same name :) messagen
1089: new i get messagen (.) message
1090: (The name ) messagen
1091: new i get messagen ( is changed into ) messagen
1092: new j << new i get << 48 count add $string$ data_conversion >>
1093: 2 cat_n >> put
1094: new j get messagen (.) message
1095: /oldx2 ostr << new j get >> reNaming2
1096: /oldd2 ostr << new j get >> reNaming2
1097: /count count 1 add def
1098: }
1099: { }
1100: ifelse
1101: } for
1102: } for
1103: /arg1 new def
1104: ] pop
1105: popVariables
1106: arg1
1107: } def
1108:
1109: /reNaming2 {
1110: %% array oldString newString reNaming2
1111: %% /aa (x) (y) reNaming2
1112: /arg3 set /arg2 set /arg1 set
1113: [/array /oldString /newString /k] pushVariables
1114: [
1115: /array arg1 def /oldString arg2 def /newString arg3 def
1116: 0 1 << array load length 1 sub >>
1117: {
1118: /k set
1119: << array load k get >> oldString eq
1120: {
1121: array load k newString put
1122: }
1123: { } ifelse
1124: } for
1125: ] pop
1126: popVariables
1127: } def
1128:
1129: /add_rings {
1130: /arg2 set /arg1 set
1131: [/param1 /param2
1132: /newx /newd /newv
1133: /k /const /od1 /od2 /od
1134: /oldx2 /oldd2 % these will be changed in reNaming.
1135: /oldv
1136: ] pushVariables
1137: [
1138: /param1 arg1 def /param2 arg2 def
1139: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1140: /newx
1141: [ ]
1142: param2 1 getX join param1 1 getX join
1143: param2 1 getXV join param1 1 getXV join
1144:
1145: param2 2 getX join param1 2 getX join
1146: param2 2 getXV join param1 2 getXV join
1147:
1148: param2 3 getX join param1 3 getX join
1149: param2 3 getXV join param1 3 getXV join
1150:
1151: param2 4 getX join param1 4 getX join
1152: param2 4 getXV join param1 4 getXV join
1153: def
1154: /newd
1155: [ ]
1156: param2 1 getD join param1 1 getD join
1157: param2 1 getDV join param1 1 getDV join
1158:
1159: param2 2 getD join param1 2 getD join
1160: param2 2 getDV join param1 2 getDV join
1161:
1162: param2 3 getD join param1 3 getD join
1163: param2 3 getDV join param1 3 getDV join
1164:
1165: param2 4 getD join param1 4 getD join
1166: param2 4 getDV join param1 4 getDV join
1167: def
1168:
1169: /newv newx newd join def
1170: /oldx2 param2 0 get def /oldd2 param2 1 get def
1171: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
1172: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
1173: /newv newv reNaming def
1174:
1175: /newx [
1176: 0 1 << newv length 2 idiv 1 sub >>
1177: {
1178: /k set
1179: newv k get
1180: } for
1181: ] def
1182: /newd [
1183: 0 1 << newv length 2 idiv 1 sub >>
1184: {
1185: /k set
1186: newv << newv length 2 idiv k add >> get
1187: } for
1188: ] def
1189: /const [
1190: << param1 2 get 0 get >>
1191: << param1 2 get 1 get param2 2 get 1 get add >>
1192: << param1 2 get 2 get param2 2 get 2 get add >>
1193: << param1 2 get 3 get param2 2 get 3 get add >>
1194: << param1 2 get 4 get param2 2 get 4 get add >>
1195: << param1 2 get 5 get param2 2 get 5 get add >>
1196: << param1 2 get 6 get param2 2 get 6 get add >>
1197: << param1 2 get 7 get param2 2 get 7 get add >>
1198: << param1 2 get 8 get param2 2 get 8 get add >>
1199: ] def
1200:
1201: /od1 param1 3 get def /od2 param2 3 get def
1202: od1 od2 oplus /od set
1203:
1204: %%oldx2 :: oldd2 ::
1205: << param1 0 get reverse >> << param1 1 get reverse >> join
1206: << oldx2 reverse >> << oldd2 reverse >> join
1207: join /oldv set
1208:
1209:
1210: od << oldv << newx reverse newd reverse join >> getPerm >>
1211: permuteOrderMatrix /od set
1212:
1213: /arg1 [newx newd const od] def
1214: ] pop
1215: popVariables
1216: arg1
1217: } def
1218:
1219:
1220: %%%% end of add_rings
1221:
1222:
1223:
1224: [(swap01) [
1225: $[ .... ] swap01 [....]$
1226: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
1227: $ define_ring$
1228: ]] putUsages
1229: %
1230: /swap01 {
1231: /arg1 set
1232: [/rg /ch ] pushVariables
1233: [
1234: arg1 0 get /rg set % ring
1235: arg1 1 get /ch set % characteristics
1236: [rg 0 get , rg 1 get , rg 2 get ,
1237: << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
1238: /arg1 [ rg ch ] def
1239: ] pop
1240: popVariables
1241: arg1
1242: } def
1243:
1244: [(swap0k) [
1245: $[ .... ] k swap0k [....]$
1246: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
1247: $ define_ring$
1248: $swap01 == 1 swap0k$
1249: ]] putUsages
1250: %
1251: /swap0k {
1252: /arg2 set
1253: /arg1 set
1254: [/rg /ch /kk] pushVariables
1255: [
1256: arg2 /kk set
1257: arg1 0 get /rg set % ring
1258: arg1 1 get /ch set % characteristics
1259: [rg 0 get , rg 1 get , rg 2 get ,
1260: << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
1261: /arg1 [ rg ch ] def
1262: ] pop
1263: popVariables
1264: arg1
1265: } def
1266:
1267: %%%%%%%%%%%%% weight vector
1268: [(position)
1269: [(set element position number)
1270: (Example: [(cat) (dog) (hot chocolate)] (cat) position ===> 0.)
1271: ]
1272: ] putUsages
1273: /position {
1274: /arg2 set /arg1 set
1275: [/univ /elem /num /flag] pushVariables
1276: [
1277: /univ arg1 def
1278: /elem arg2 def
1279: /num -1 def /flag -1 def
1280: 0 1 << univ length 1 sub >>
1281: {
1282: /num set
1283: univ num get elem eq
1284: { /flag 0 def exit }
1285: { }
1286: ifelse
1287: } for
1288: flag -1 eq
1289: {/num -1 def}
1290: { }
1291: ifelse
1292: ] pop
1293: /arg1 num def
1294: popVariables
1295: arg1
1296: } def
1297:
1298:
1299: [(evecw)
1300: [(size position weight evecw [0 0 ... 0 weight 0 ... 0] )
1301: (Example: 3 0 113 evecw ===> [113 0 0])
1302: ]
1303: ] putUsages
1304: /evecw {
1305: /arg3 set /arg2 set /arg1 set
1306: [/size /iii /www] pushVariables
1307: /size arg1 def /iii arg2 def /www arg3 def
1308: [
1309: 0 1 << size 1 sub >>
1310: {
1311: iii eq
1312: { www }
1313: { 0 }
1314: ifelse
1315: } for
1316: ] /arg1 set
1317: popVariables
1318: arg1
1319: } def
1320:
1321: [(weight_vector)
1322: [ ([x-list d-list params] [[(name) weight ...] [...] ...] weight_vector)
1323: ([x-list d-list params order])
1324: (Example:)
1325: ( [(x,y,z) ring_of_polynomials [[(x) 100 (y) 10]] weight_vector 0] )
1326: ( define_ring )
1327: ]
1328: ] putUsages
1329: /weight_vector {
1330: /arg2 set /arg1 set
1331: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
1332: /vars arg1 def /w-vectors arg2 def
1333: [
1334: /univ vars 0 get reverse
1335: vars 1 get reverse join
1336: def
1.33 takayama 1337: w-vectors to_int32 /w-vectors set
1.1 maekawa 1338: [
1339: 0 1 << w-vectors length 1 sub >>
1340: {
1341: /k set
1342: univ w-vectors k get w_to_vec
1343: } for
1344: ] /order1 set
1345: %% order1 ::
1346:
1347: vars ( ) elimination_order 3 get /order2 set
1348: vars [ << order1 order2 join >> ] join /arg1 set
1349: ] pop
1350: popVariables
1351: arg1
1352: } def
1353:
1354: %% [@@@.esymbol (x) (y) (h)] [(x) 100 (y) 10] w_to_vec [0 100 10 0]
1355: %% univ www
1356: /w_to_vec {
1357: /arg2 set /arg1 set
1358: [/univ /www /k /vname /vweight /ans] pushVariables
1359: /univ arg1 def /www arg2 def
1.32 takayama 1360: [
1.33 takayama 1361: www to_int32 /www set
1.1 maekawa 1362: /ans << univ length >> -1 0 evecw def
1363: 0 2 << www length 2 sub >>
1364: {
1365: %% ans ::
1366: /k set
1367: www k get /vname set
1368: www << k 1 add >> get /vweight set
1369: << univ length >>
1370: << univ vname position >>
1371: vweight evecw
1372: ans add /ans set
1373: } for
1374: /arg1 ans def
1375: ] pop
1376: popVariables
1377: arg1
1378: } def
1379:
1380: %%%%%%%%%% end of weight_vector macro
1381:
1382: %%%%%%%% eliminatev macro
1383: [(eliminatev)
1384: [([g1 g2 g3 ...gm] [list of variables] eliminatev [r1 ... rp])
1385: (Example: [(x y z - 1). (z-1). (y-1).] [(x) (y)] eliminatev [ z-1 ])
1386: ]
1387: ] putUsages
1388: /eliminatev {
1389: /arg2 set /arg1 set
1390: [/gb /var /vars /ans /k] pushVariables
1391: [
1392: /gb arg1 def
1393: /vars arg2 def
1394: /ans gb def
1395: 0 1 << vars length 1 sub >> {
1396: /k set
1397: ans << vars k get >> eliminatev.tmp
1398: /ans set
1399: } for
1400: /arg1 ans def
1401: ] pop
1402: popVariables
1403: arg1
1404: } def
1405: /eliminatev.tmp {
1406: /arg2 set /arg1 set
1407: [/gb /degs /ans /n /var /ff /rr /gg] pushVariables
1408: [
1409: /gb arg1 def
1410: /var arg2 def
1411: /degs gb {
1412: /gg set
1413: gg (0). eq
1414: { 0 }
1415: { gg (ring) data_conversion /rr set
1.37 takayama 1416: gg << var rr __ >> degree
1.1 maekawa 1417: } ifelse
1418: } map def
1419: %%degs message
1420: /ans [
1421: 0 1 << gb length 1 sub >> {
1422: /n set
1423: << degs n get >> 0 eq
1424: { gb n get /ff set
1425: ff (0). eq
1426: { }
1427: { ff } ifelse
1428: }
1429: { } ifelse
1430: } for
1431: ] def
1432: /arg1 ans def
1433: ] pop
1434: popVariables
1435: arg1
1436: } def
1437:
1438: /eliminatev.tmp.org {
1439: /arg2 set /arg1 set
1440: [/gb /degs /ans /n /var /ff] pushVariables
1441: [
1442: /gb arg1 def
1443: /var arg2 def
1444: /degs gb {var . degree} map def
1445: /ans [
1446: 0 1 << gb length 1 sub >> {
1447: /n set
1448: << degs n get >> 0 eq
1449: { gb n get /ff set
1450: ff (0). eq
1451: { }
1452: { ff } ifelse
1453: }
1454: { } ifelse
1455: } for
1456: ] def
1457: /arg1 ans def
1458: ] pop
1459: popVariables
1460: arg1
1461: } def
1462: %%% end of eliminatev macro
1463:
1464: %%% macro for output
1465:
1466: [(isInteger)
1467: [(obj isInteger bool) ]
1468: ] putUsages
1469: /isInteger {
1470: (type?) data_conversion << 0 (type?) data_conversion >> eq
1471: } def
1472:
1473: [(isArray)
1474: [(obj isArray bool) ]
1475: ] putUsages
1476: /isArray {
1477: (type?) data_conversion << [ ] (type?) data_conversion >> eq
1478: } def
1479:
1480: [(isPolynomial)
1481: [(obj isPolynomial bool) ]
1482: ] putUsages
1483: /isPolynomial {
1484: (type?) data_conversion
1485: << [(x) (var) 0] system_variable . (type?) data_conversion >> eq
1486: } def
1487:
1488: [(isString)
1489: [(obj isString bool) ]
1490: ] putUsages
1491: /isString {
1492: (type?) data_conversion
1493: << (Hi) (type?) data_conversion >> eq
1494: } def
1495:
1496: [(isClass)
1497: [(obj isClass bool) ]
1498: ] putUsages
1499: /isClass {
1500: (type?) data_conversion ClassP eq
1501: } def
1502:
1503: [(isUniversalNumber)
1504: [(obj isUniversalNumber bool) ]
1505: ] putUsages
1506: /isUniversalNumber {
1507: (type?) data_conversion UniversalNumberP eq
1508: } def
1509:
1510: [(isDouble)
1511: [(obj isDouble bool) ]
1512: ] putUsages
1513: /isDouble {
1514: (type?) data_conversion DoubleP eq
1515: } def
1516:
1517: [(isRational)
1518: [(obj isRational bool) ]
1519: ] putUsages
1520: /isRational {
1521: (type?) data_conversion RationalFunctionP eq
1.7 takayama 1522: } def
1523:
1524: [(isRing)
1525: [(obj isRing bool) ]
1526: ] putUsages
1527: /isRing {
1528: (type?) data_conversion RingP eq
1.1 maekawa 1529: } def
1530:
1531: /toString.tmp {
1532: /arg1 set
1533: [/obj /fname] pushVariables
1534: /obj arg1 def
1535: [
1536: obj isArray
1537: {
1538: obj {toString.tmp} map
1539: }
1540: { } ifelse
1541: obj isInteger
1542: {
1543: obj (dollar) data_conversion %% not string. It returns the ascii code.
1544: }
1545: { } ifelse
1546: obj isPolynomial
1547: {
1548: obj (string) data_conversion
1549: }
1550: { } ifelse
1551: obj isString
1552: { obj }
1553: { } ifelse
1554: obj isUniversalNumber
1555: { obj (string) data_conversion } { } ifelse
1556: obj isDouble
1557: { obj (string) data_conversion } { } ifelse
1558: obj isRational
1559: { obj (string) data_conversion } { } ifelse
1560: obj tag 0 eq
1561: { (null) } { } ifelse
1562:
1563: %%% New code that uses a file.
1564: obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
1565: { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
1566: [(outputObjectToFile) fname obj] extension pop
1567: fname pushfile
1568: [(/bin/rm -rf ) fname] cat system
1569: } { } ifelse
1570: ] /arg1 set
1571: popVariables
1572: arg1 aload pop
1573: } def
1574:
1575:
1576:
1577: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
1578: /toString.tmp2 {
1579: /arg1 set
1580: [/obj /i /n /r] pushVariables
1581: [
1582: /obj arg1 def
1583: obj isArray
1584: {
1.2 takayama 1585: [(LeftBracket)] system_variable %%( [ )
1.1 maekawa 1586: obj {toString.tmp2} map /r set
1587: /n r length 1 sub def
1588: [0 1 n {
1589: /i set
1590: i n eq {
1591: r i get
1592: }
1593: { r i get ( , ) 2 cat_n }
1594: ifelse
1595: } for
1596: ] aload length cat_n
1.2 takayama 1597: [(RightBracket)] system_variable %%( ] )
1.1 maekawa 1598: 3 cat_n
1599: }
1600: {
1601: obj
1602: } ifelse
1603: ] /arg1 set
1604: popVariables
1605: arg1 aload pop
1606: } def
1607:
1608:
1609: [(toString)
1610: [(obj toString)
1611: (Convert obj to a string.)
1612: (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ] ]$)
1613: ]
1614: ] putUsages
1615: /toString {
1616: /arg1 set
1617: [/obj ] pushVariables
1618: [
1619: /obj arg1 def
1620: obj isString
1621: { obj }
1622: { obj toString.tmp toString.tmp2 }
1623: ifelse /arg1 set
1624: ] pop
1625: popVariables
1626: arg1
1627: } def
1628:
1629: [(output)
1630: [(obj output) (Output the object to the standard file sm1out.txt)]
1631: ] putUsages
1632: /output {
1633: /arg1 set
1634: [/obj /fd ] pushVariables
1635: [
1636: /obj arg1 def
1637: (sm1out.txt) (a) file /fd set
1638: (Writing to sm1out.txt ...) messagen
1639: [ fd << obj toString >> writestring ] pop
1640: [ fd << 10 (string) data_conversion >> writestring ] pop
1641: ( Done.) message
1642: fd closefile
1643: ] pop
1644: popVariables
1645: } def
1646: %%%% end of macro for output.
1647: [(tag)
1648: [(obj tag integer)
1649: (tag returns datatype.)
1650: (cf. data_conversion)
1651: (Example: 2 tag IntegerP eq ---> 1)
1652: ]
1653: ] putUsages
1654: /etag {(type??) data_conversion} def
1655: [(etag)
1656: [(obj etag integer)
1657: (etag returns extended object tag. cf. kclass.c)
1658: ]
1659: ] putUsages
1660: /tag {(type?) data_conversion} def
1661: %% datatype constants
1662: /IntegerP 1 (type?) data_conversion def
1663: /LiteralP /arg1 (type?) data_conversion def %Sstring
1664: /StringP (?) (type?) data_conversion def %Sdollar
1665: /ExecutableArrayP { 1 } (type?) data_conversion def
1666: /ArrayP [ 0 ] (type?) data_conversion def
1667: /PolyP (1). (type?) data_conversion def
1668: /FileP 13 def
1669: /RingP 14 def
1670: /UniversalNumberP 15 def
1671: /RationalFunctionP 16 def
1672: /ClassP 17 def
1673: /DoubleP 18 def
1674: /@.datatypeConstant.usage [
1675: (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
1676: (UniversalNumberP, RationalFunctionP, ClassP, DoubleP)
1677: ( return data type identifiers.)
1678: (Example: 7 tag IntegerP eq ---> 1)
1679: ] def
1680: [(IntegerP) @.datatypeConstant.usage ] putUsages
1681: [(LiteralP) @.datatypeConstant.usage ] putUsages
1682: [(StringP) @.datatypeConstant.usage ] putUsages
1683: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
1684: [(ArrayP) @.datatypeConstant.usage ] putUsages
1685: [(PolyP) @.datatypeConstant.usage ] putUsages
1686: [(RingP) @.datatypeConstant.usage ] putUsages
1687: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
1688: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
1689: [(ClassP) @.datatypeConstant.usage ] putUsages
1690: [(DoubleP) @.datatypeConstant.usage ] putUsages
1691:
1.37 takayama 1692: [(__)
1693: [( string ring __ polynomial)
1.1 maekawa 1694: (Parse the <<string>> as an element in the <<ring>> and returns)
1695: (the polynomial.)
1696: (cf. define_ring, define_qring, ring_def)
1697: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
1698: ( /myring set)
1.37 takayama 1699: ( ((x+y)^4) myring __ /f set)
1.1 maekawa 1700: ]] putUsages
1701:
1.37 takayama 1702: /__ {
1.1 maekawa 1703: /arg2 set /arg1 set
1704: [/rrr] pushVariables
1705: [ arg1 tag StringP eq
1706: arg2 tag RingP eq and
1707: { [(CurrentRingp)] system_variable /rrr set
1708: [(CurrentRingp) arg2] system_variable
1709: /arg1 arg1 expand def
1710: [(CurrentRingp) rrr] system_variable
1711: }
1.37 takayama 1712: {(Argument Error for __ ) error }
1.1 maekawa 1713: ifelse
1714: ] pop
1715: popVariables
1716: arg1
1717: } def
1718:
1719: [(..)
1720: [( string .. universalNumber)
1721: (Parse the << string >> as a universalNumber.)
1722: (Example: (123431232123123).. /n set)
1.46 ! takayama 1723: ({ commands }.. executes the commands. << .. >> is equivalent to exec.)
1.1 maekawa 1724: ]] putUsages
1.46 ! takayama 1725: /.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def
1.1 maekawa 1726:
1727: [(dc)
1728: [(Abbreviation of data_conversion.)
1729: ]] putUsages
1730: /dc { data_conversion } def
1731:
1732:
1733: %%% start of shell sort macro.
1734: [(and) [(obj1 obj2 and bool)]] putUsages
1735: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
1736:
1737: [(or) [(obj1 obj2 or bool)]] putUsages
1738: /or { add 1 copy 2 eq {pop 1} { } ifelse} def
1739:
1740: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
1741: %% 2 copy is equivalent to dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1742: /ge { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1743: eq {pop pop 1}
1744: { gt {1}
1745: {0}
1746: ifelse}
1747: ifelse} def
1748:
1749: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
1750: /le { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1751: eq {pop pop 1}
1752: { lt {1}
1753: {0}
1754: ifelse}
1755: ifelse} def
1756:
1757: [(break)
1758: [(bool break)]
1759: ] putUsages
1760: /break { {exit} { } ifelse } def
1761:
1762: /not { 0 eq {1} {0} ifelse} def
1763: /append { /arg2 set [arg2] join } def
1764:
1765: [(power)
1766: [(obj1 obj2 power obj3)
1767: $obj3 is (obj1)^(obj2). cf. npower$
1768: $Example: (2). 8 power :: ===> 256 $
1769: ]
1770: ] putUsages
1771: %% From SSWork/yacc/incmac.sm1
1772: %% f k power f^k
1773: /power {
1774: /arg2 set
1775: /arg1 set
1776: [/f /k /i /ans] pushVariables
1777: [
1.26 takayama 1778: /ans (1).. def
1779: [(QuoteMode)] system_variable {
1780: /f arg1 def /k arg2 def
1781: [(ooPower) f k] extension /ans set
1782: } {
1.1 maekawa 1783: /f arg1 def /k arg2 ..int def
1784: k 0 lt {
1785: 1 1 << 0 k sub >> {
1786: /ans f ans {mul} sendmsg2 def
1787: } for
1788: /ans (1).. ans {div} sendmsg2 def
1789: }
1790: {
1791: 1 1 k {
1792: /ans f ans {mul} sendmsg2 def
1793: } for
1794: } ifelse
1.26 takayama 1795: } ifelse
1796: /arg1 ans def
1.1 maekawa 1797: ] pop
1798: popVariables
1799: arg1
1800: } def
1801: [(..int)
1802: [ (universalNumber ..int int)]] putUsages
1803: /..int { %% universal number to int
1804: (integer) data_conversion
1805: } def
1806: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
1807: /SmallRing [(CurrentRingp)] system_variable def
1808:
1809: %%% From SSWork/yacc/lib/printSVector.modified.sm1
1810: %%% supporting code for printSVector.
1811: /greaterThanOrEqual {
1812: /arg2 set /arg1 set
1813: arg1 arg2 gt { 1 }
1814: { arg1 arg2 eq {1} {0} ifelse} ifelse
1815: } def
1816:
1817: /lengthUniv {
1818: length (universalNumber) dc
1819: } def
1820:
1821: /getUniv {
1822: (integer) dc get
1823: } def %% Do not forget to thow away /.
1824:
1825: %%[(@@@.printSVector)
1826: %% [( vector @@@.printSVector outputs the <<vector>> in a pretty way.)
1827: %% ( The elements of the vector must be strings.)
1828: %% ]
1829: %%] putUsages
1830:
1831: %%% compiled code by d0, 1996, 8/17.
1832: /@@@.printSVector {
1833: /arg1 set
1834: [ %%start of local variables
1835: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
1836: /keys arg1 def
1837: /n
1838: keys lengthUniv
1839: def
1840: /max (0).. def
1841: /i (0).. def
1842: %%for init.
1843: %%for
1844: { i n lt
1845: { } {exit} ifelse
1846: [ {%%increment
1847: /i i (1).. add def
1848: } %%end of increment{A}
1849: {%%start of B part{B}
1850: keys i getUniv lengthUniv
1851: max gt
1852: %% if-condition
1853: { %%ifbody
1854: /max
1855: keys i getUniv lengthUniv
1856: def
1857: }%%end if if body
1858: { %%if- else part
1859: } ifelse
1860: } %% end of B part. {B}
1861: 2 1 roll] {exec} map
1862: } loop %%end of for
1863: /max max (3).. add
1864: def
1865: /width (80).. def
1866: /m (0).. def
1867:
1868: %%while
1869: { m max mul
1870: (80).. lt
1871: { } {exit} ifelse
1872: /m m (1).. add
1873: def
1874: } loop
1875: /k (0).. def
1876: /kk (0).. def
1877: /i (0).. def
1878: %%for init.
1879: %%for
1880: { i n lt
1881: { } {exit} ifelse
1882: [ {%%increment
1883: /i i (1).. add def
1884: } %%end of increment{A}
1885: {%%start of B part{B}
1886: keys i getUniv messagen
1887: /kk kk (1).. add
1888: def
1889: /k k
1890: keys i getUniv lengthUniv
1891: add
1892: def
1893: /tmp0 max
1894: keys i getUniv lengthUniv
1895: sub
1896: def
1897: /j (0).. def
1898: %%for init.
1899: %%for
1900: { j tmp0 lt
1901: { } {exit} ifelse
1902: [ {%%increment
1903: /j j (1).. add def
1904: } %%end of increment{A}
1905: {%%start of B part{B}
1906: /k k (1).. add
1907: def
1908: kk m lt
1909: %% if-condition
1910: { %%ifbody
1911: ( ) messagen
1912: }%%end if if body
1913: { %%if- else part
1914: } ifelse
1915: } %% end of B part. {B}
1916: 2 1 roll] {exec} map
1917: } loop %%end of for
1918: kk m greaterThanOrEqual
1919: %% if-condition
1920: { %%ifbody
1921: /kk (0).. def
1922: /k (0).. def
1923: newline
1924: }%%end if if body
1925: { %%if- else part
1926: } ifelse
1927: } %% end of B part. {B}
1928: 2 1 roll] {exec} map
1929: } loop %%end of for
1930: newline
1931: /ExitPoint ]pop popVariables %%pop the local variables
1932: } def
1933: %%end of function
1934:
1.35 takayama 1935: /rest {
1936: /arg1 set [(Krest) arg1] extension
1.1 maekawa 1937: } def
1938: [(rest)
1939: [(array rest the-rest-of-the-array)
1940: (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
1941: ]
1942: ] putUsages
1943:
1944: %% from SSkan/develop/minbase.sm1
1945: /reducedBase {
1946: /arg1 set
1947: [/base /minbase /n /i /j /myring /zero /f] pushVariables
1948: [
1949: /base arg1 def
1950: base isArray { }
1951: { (The argument of reducedBase must be an array of polynomials)
1952: error
1953: } ifelse
1954: base 0 get isPolynomial { }
1955: { (The element of the argument of reducedBase must be polynomials)
1956: error
1957: } ifelse
1958: /myring base 0 get (ring) dc def
1.37 takayama 1959: /zero (0) myring __ def
1.1 maekawa 1960: base length 1 sub /n set
1961: /minbase [ 0 1 n { /i set base i get } for ] def
1962: 0 1 n {
1963: /i set
1964: minbase i get /f set
1965: f zero eq {
1966: }
1967: {
1968: 0 1 n {
1969: /j set
1970: << minbase j get zero eq >> << i j eq >> or {
1971: }
1972: {
1973: [(isReducible) << minbase j get >> f] gbext
1974: {
1975: minbase j zero put
1976: }
1977: { } ifelse
1978: } ifelse
1979: } for
1980: } ifelse
1981: } for
1982: minbase { minbase.iszero } map /arg1 set
1983: ] pop
1984: popVariables
1985: arg1
1986: } def
1987:
1988: [(reducedBase)
1989: [(base reducedBase reducedBase)
1990: (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
1991: (returns <<reducedBase>>.)
1992: (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
1993: ]
1994: ] putUsages
1995:
1996: %% package functions
1997: /minbase.iszero {
1998: dup (0). eq {
1999: pop
2000: }
2001: { } ifelse
2002: } def
2003:
2004: /== {
2005: message
2006: } def
2007: [(==)
2008: [(obj ==)
2009: (Print obj)
2010: ]
2011: ] putUsages
2012:
2013: /@@@.all_variables {
2014: [/n /i] pushVariables
2015: [
2016: /n [(N)] system_variable def
2017: [
2018: 0 1 n 1 sub {
2019: /i set
2020: [(x) (var) i] system_variable
2021: } for
2022: 0 1 n 1 sub {
2023: /i set
2024: [(D) (var) i] system_variable
2025: } for
2026: ] /arg1 set
2027: ] pop
2028: popVariables
2029: arg1
2030: } def
2031:
2032: /weightv {
2033: @@@.all_variables
2034: 2 1 roll w_to_vec
2035: } def
2036:
2037: [(weightv)
2038: [(array weightv weight_vector_for_init)
2039: (cf. init)
2040: (Example: /w [(x) 10 (h) 2] weightv def)
2041: ( ((x-h)^10). w init ::)
2042: ]
2043: ] putUsages
2044:
2045: /output_order {
2046: /arg1 set
2047: [/vars /vlist /perm /total /ans] pushVariables
2048: [
2049: /vlist arg1 def
2050: /vars @@@.all_variables def
2051: vlist { vars 2 1 roll position } map /perm set
2052: perm ==
2053: /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
2054: perm perm total complement join /ans set
2055: [(outputOrder) ans] system_variable
2056: ] pop
2057: popVariables
2058: } def
2059:
2060: [(output_order)
2061: [$ [(v1) (v2) ...] output_order $
2062: (Set the order of variables to print for the current ring.)
2063: (cf. system_variable)
2064: (Example: [(y) (x)] output_order)
2065: $ (x*y). :: ===> y*x $
2066: ]
2067: ] putUsages
2068:
2069: %% destraction. SSkan/Kan/debug/des.sm1, 1998, 2/27 , 3/1
2070: %% should be included in dr.sm1
2071:
2072: /factorial {
2073: /arg2 set
2074: /arg1 set
2075: [ /f /n ] pushVariables
2076: [
2077: /f arg1 def
2078: /n arg2 def
2079: /ans (1).. def
2080: n 0 lt { (f n factorial : n must be a non-negative integer)
2081: error } { } ifelse
2082: 0 1 n 1 sub {
2083: (universalNumber) dc /i set
2084: ans << f i sub >> mul /ans set
2085: } for
2086: /arg1 ans def
2087: ] pop
2088: popVariables
2089: arg1
2090: } def
2091:
2092: [(factorial)
2093: [(f n factorial g)
2094: $integer n, g is f (f-1) ... (f-n+1)$
2095: ]
2096: ] putUsages
2097:
2098:
2099: /destraction1 {
2100: /arg4 set
2101: /arg3 set
2102: /arg2 set
2103: /arg1 set
2104: [/ww /f /dx /ss /xx /coeff0 /expvec
2105: /coeffvec /expvec2 /ans /one] pushVariables
2106: [
2107: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2108: /one (1). def %%
2109: /ww [ xx toString -1 dx toString 1 ] weightv def
2110: f ww init f sub (0). eq { }
2111: { [(destraction1 : inhomogeneous with respect to )
2112: xx ( and ) dx ] cat error } ifelse
2113: f [[xx one]] replace dx coefficients /coeff0 set
2114: /expvec coeff0 0 get { (integer) dc } map def
2115: /coeffvec coeff0 1 get def
2116: expvec { ss 2 -1 roll factorial } map /expvec2 set
2117: expvec2 coeffvec mul /ans set
2118: /arg1 ans def
2119: ] pop
2120: popVariables
2121: arg1
2122: } def
2123:
2124:
2125: /distraction {
2126: /arg4 set
2127: /arg3 set
2128: /arg2 set
2129: /arg1 set
2130: [/f /dx /ss /xx /ans /n /i] pushVariables
2131: [(CurrentRingp)] pushEnv
2132: [
2133: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2134: f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
2135: /n xx length def
2136: 0 1 n 1 sub {
2137: /i set
2138: /f f xx i get dx i get ss i get destraction1 /f set
2139: } for
2140: /dist1.L
2141: /arg1 f def
2142: ]pop
2143: popEnv
2144: popVariables
2145: arg1
2146: } def
2147: [(distraction)
2148: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2149: ( distraction result )
2150: $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
2151: ]
2152: ] putUsages
2153: /destraction { distraction } def
2154:
2155:
2156:
2157:
2158: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2159: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2160: %%%%%%%%%%%%%%%% sorting
2161: %/N 1000 def
2162: %/a.shell [N -1 0 { } for ] def
2163: %a.shell 0 -1000 put
2164: %% You need gate keeper.
2165: [(shell)
2166: [([gate-keeper f1 f2 ... fm] shell result)
2167: (Sort the list. Gate-keeper should be the smallest element)]
2168: ] putUsages
2169: /shell {
2170: /arg1 set
2171: [/N /a.shell /h /i /v /j] pushVariables
2172: [
2173: /a.shell arg1 def
2174: /N a.shell length 1 sub def
2175:
2176: /h 1 def
2177: {/h h 3 mul 1 add def
2178: << h N ge >> break
2179: } loop
2180: {
2181: /h << h 3 idiv >> def
2182: << h 1 add >> 1 N {
2183: /i set
2184: /v a.shell i get def
2185: /j i def
2186: {
2187: %% a.shell print newline
2188: << a.shell << j h sub >> get >> v le break
2189: a.shell j << a.shell << j h sub >> get >> put
2190: /j j h sub def
2191: j h le break
2192: } loop
2193: a.shell j v put
2194: } for
2195: h 1 lt break
2196: } loop
2197: /arg1 a.shell def
2198: ] pop
2199: popVariables
2200: arg1
2201: } def
2202: %%%% end of shell sort macro
2203:
2204: /variableNames {
2205: /arg1 set
2206: [/in-variableNames /rrr /nnn /i /cp] pushVariables
2207: [
2208: /rrr arg1 def
2209: [(CurrentRingp)] system_variable /cp set
2210: [(CurrentRingp) rrr] system_variable
2211: [(N)] system_variable /nnn set
2212: [ 0 1 nnn 1 sub {
2213: /i set [(x) (var) i] system_variable } for ]
2214: [ 0 1 nnn 1 sub {
2215: /i set [(D) (var) i] system_variable } for ]
2216: join /arg1 set
2217: [(CurrentRingp) cp] system_variable
2218: ] pop
2219: popVariables
2220: arg1
2221: } def
2222:
2223:
2224: /makeRingMap {
2225: /arg3 set /arg2 set /arg1 set
2226: [/in-makeRingMap /corres /M /N /corresM /corresN
2227: /vars /vars-org /i /p /ans /cp] pushVariables
2228: [
2229: /corres arg1 def /M arg2 def /N arg3 def
2230: /corresM corres 0 get def
2231: /corresN corres 1 get def
2232: [(CurrentRingp)] system_variable /cp set
2233: [(CurrentRingp) M] system_variable
2234: M variableNames /vars set vars 1 copy /vars-org set
2235: 0 1 corresM length 1 sub {
2236: /i set
2237: vars corresM i get position /p set
2238: p -1 gt {
2239: vars p $($ corresN i get $)$ 3 cat_n put
2240: } { } ifelse
2241: } for
2242: /arg1 [vars M N vars-org] def
2243: [(CurrentRingp) cp] system_variable
2244: ] pop
2245: popVariables
2246: arg1
2247: } def
2248:
2249:
2250:
2251: /ringmap {
2252: /arg2 set /arg1 set
2253: [/in-ringmap /f /M2N /cp /f2] pushVariables
2254: [
2255: /f arg1 def /M2N arg2 def
2256: [(CurrentRingp)] system_variable /cp set
2257: f (0). eq { /f2 f def }
2258: {
2259: %f (ring) dc M2N 1 get eq
2260: %{ }
2261: %{ (The argument polynomial does not belong to the domain ring.) message
2262: % error
2263: % } ifelse
2264: [(CurrentRingp) M2N 1 get] system_variable
2265: [(variableNames) M2N 0 get] system_variable
2266: f toString /f2 set
2267: [(variableNames) M2N 3 get] system_variable
1.37 takayama 2268: f2 M2N 2 get __ /f2 set
1.1 maekawa 2269: } ifelse
2270: [(CurrentRingp) cp] system_variable
2271: /arg1 f2 def
2272: ] pop
2273: popVariables
2274: arg1
2275: } def
2276:
2277: [(makeRingMap)
2278: [( rule ring1 ring2 makeRingMap maptable )
2279: (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
2280: ]
2281: ] putUsages
2282: [(ringmap)
2283: [(f mapTable ringmap r)
2284: (f is mapped to r where the map is defined by the mapTable, which is generated)
2285: (by makeRingMap as follows:)
2286: ( rule ring1 ring2 makeRingMap maptable )
2287: $Example:$
2288: $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2289: $/R1 set$
2290: $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2291: $/R2 set$
2292: $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
2293: $r0 R1 R2 makeRingMap /maptable set$
1.37 takayama 2294: $(Dx-1) R1 __ /ff set$
1.1 maekawa 2295: $ ff maptable ringmap :: $
2296: ]
2297: ] putUsages
2298:
2299:
2300: /getVariableNames {
2301: [/in-getVariableNames /ans /i /n] pushVariables
2302: [
2303: /n [(N)] system_variable def
2304: [
2305: n 1 sub -1 0 {
2306: /i set
2307: [(x) (var) i] system_variable
2308: } for
2309: n 1 sub -1 0{
2310: /i set
2311: [(D) (var) i] system_variable
2312: } for
2313: ] /arg1 set
2314: ] pop
2315: popVariables
2316: arg1
2317: } def
2318: [(getVariableNames)
2319: [(getVariableNames list-of-variables)
2320: (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
2321: ]
2322: ] putUsages
2323:
2324: /tolower {
2325: /arg1 set
2326: [/in-tolower /s /sl] pushVariables
2327: [
2328: /s arg1 def
2329: s (array) dc /s set
2330: s { tolower.aux (string) dc } map /sl set
2331: sl aload length cat_n /arg1 set
2332: ] pop
2333: popVariables
2334: arg1
2335: } def
2336:
2337: /tolower.aux {
2338: /arg1 set
1.9 takayama 2339: arg1 64 gt arg1 91 lt and
1.1 maekawa 2340: { arg1 32 add }
2341: { arg1 } ifelse
2342: } def
2343: [(tolower)
2344: [(string tolower string2)
2345: (Capital letters in string are converted to lower case letters.)
2346: $Example: (Hello World) tolower :: (hello world)$
2347: ]
2348: ] putUsages
2349:
2350: /hilbert {
2351: /arg2 set
2352: /arg1 set
2353: [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
2354: [
2355: /base arg1 def
2356: /vlist arg2 def
2357: [(CurrentRingp)] system_variable /rrrorg set
2358: /strf 0 def
2359: vlist isString
2360: { /vlist [ vlist to_records pop ] def }
2361: { } ifelse
2362: base isArray { }
2363: { (hilb : the first argument must be an array of polynomials.)
2364: error
2365: } ifelse
2366: vlist isArray { }
2367: { (hilb : the second argument must be an array of polynomials.)
2368: error
2369: } ifelse
2370:
2371: vlist 0 get isString{ /strf 1 def } { } ifelse
2372: base 0 get isPolynomial {
2373: base 0 get (ring) dc /rrr set
2374: }
2375: {
2376: [ vlist { (,) } map aload length cat_n ring_of_polynomials 0 ] define_ring
2377: /rrr set
2378: base { . } map /base set
2379: } ifelse
1.37 takayama 2380: vlist { dup isPolynomial { } { rrr __ } ifelse } map /vlist set
1.1 maekawa 2381:
2382: [(hilbert) base vlist] extension /ff set
2383: [(CurrentRingp) rrrorg] system_variable
2384: /arg1 ff def
2385: ] pop
2386: popVariables
2387: arg1
2388: } def
2389:
2390: /hilbReduce {
2391: /arg2 set
2392: /arg1 set
2393: [/hhh /f /d /vv /ans] pushVariables
2394: [
2395: /hhh arg1 def %% hilbert function
2396: /vv arg2 def
2397: /f hhh 1 get def
2398: f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
1.37 takayama 2399: f vv << f (ring) dc >> __ degree /vv set
1.1 maekawa 2400: hhh 0 get /d set
2401: d d (integer) dc factorial /d set
2402: d << vv (universalNumber) dc vv factorial >> idiv /d set
2403: [(divByN) f d] gbext /ans set
2404: ans 1 get (0). eq
2405: { }
2406: { (hilbReduce : Invalid hilbert function ) error } ifelse
2407: /hilbReduce.label
2408: ans 0 get /arg1 set
2409: ] pop
2410: popVariables
2411: arg1
2412: } def
2413:
2414:
2415: [(hilbReduce)
2416: [([f,g] v hilbReduce p)
2417: (output of hilbert [f,g]; string v; poly p)
2418: (p is (g/(f!))*deg(g)!)
2419: $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
2420: ]
2421: ] putUsages
2422: [(hilbert)
2423: [(base vlist hilbert [m f])
2424: (array of poly base; array of poly vlist; number m; poly f;)
2425: (array of string base; array of string vlist; number m; poly f;)
2426: (array of string base; string vlist; number m; poly f;)
2427: ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
2428: (The << base >> should be a reduced Grobner basis.)
2429: (Or, when the << base >> is an array of string,)
2430: (all entries should be monomials.)
2431: (Example: [(x^2) (x y )] (x,y) hilbert :: [2, 2 h + 4] )
2432: (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce :: 4)
2433: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce :: 3)
2434: (cf. hilb, hilbReduce)
2435: ]
2436: ] putUsages
2437:
2438: /hilb {
2439: hilbert (h) hilbReduce
2440: } def
2441: [(hilb)
2442: [(base vlist hilb f)
2443: (array of poly base; array of poly vlist; poly f;)
2444: (array of string base; array of string vlist; poly f;)
2445: (array of string base; string vlist; number m; poly f;)
2446: (f is the hilbert function (a_d x^d + ...)/m!)
2447: (The << base >> should be a reduced Grobner basis.)
2448: (Or, when the << base >> is an array of string,)
2449: (all entries should be monomials.)
2450: (Example: [(x^2) (x y )] (x,y) hilb :: h + 2 )
2451: (Example: [(x^2) (y^2)] (x,y) hilb 4)
2452: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb :: 3)
2453: (cf. hilbert, hilbReduce)
2454: ]
2455: ] putUsages
2456:
2457: [(diff0)
2458: [ (f v n diff0 fn)
2459: (<poly> fn, v ; <integer> n ; <poly> fn)
2460: (fn = v^n f where v^n is the operator to take the n-th differential.)
2461: (We can use diff0 only in the ring of differential operators.)
2462: (Example: [(x) ring_of_differential_operators 0] define_ring )
2463: ( (x^10-x). (Dx). 1 diff0 ::)
2464: ]
2465: ] putUsages
2466: /diff0 {
2467: /arg3 set /arg2 set /arg1 set
2468: [/in-diff /f /v /n /fn /rrr] pushVariables
2469: [
2470: /f arg1 def /v arg2 def /n arg3 def
2471: f (0). eq
2472: { /fn (0). def }
2473: {
2474: f (ring) dc /rrr set
1.37 takayama 2475: v toString (^) n toString 3 cat_n rrr __
1.1 maekawa 2476: f mul
1.37 takayama 2477: [[v (0).] [(h) rrr __ (1) rrr __]] replace /fn set
1.1 maekawa 2478: } ifelse
2479: fn /arg1 set
2480: ] pop
2481: popVariables
2482: arg1
2483: } def
2484:
2485: [(action)
2486: [( f g action p )
2487: (<poly> f,g,p)
2488: (Act f on g. The result is p. The homogenization variable h is put to 1.)
2489: (We can use diff0 only in the ring of differential operators.)
2490: (Example: [(x) ring_of_differential_operators 0] define_ring )
2491: ( (Dx^2). (x^2). action ::)
2492: ]
2493: ] putUsages
2494: /action {
2495: /arg2 set /arg1 set
2496: [/in-action /f /g /h /rr /rr.org /rule] pushVariables
2497: [
2498: /f arg1 def /g arg2 def
2499: /rr.org [(CurrentRingp)] system_variable def
2500: f (0). eq
2501: { /h (0). def }
2502: {
2503: f (ring) dc /rr set
2504: [(CurrentRingp) rr] system_variable
2505: f g mul /h set
2506: /rule getVariableNames def
2507: 0 1 rule length 2 idiv { rule rest /rule set } for
2508: rule { . [ 2 1 roll (0). ] } map /rule set
2509: rule << rule length 1 sub >> [(h). (1).] put
2510: %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
2511: /h h rule replace def
2512: } ifelse
2513: [(CurrentRingp) rr.org ] system_variable
2514: /arg1 h def
2515: ] pop
2516: popVariables
2517: arg1
2518: } def
2519:
2520: [(ord_w)
2521: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2522: (poly ff; string v1; integer w1; ...)
1.11 takayama 2523: (order of the initial of ff by the weight vector [w1 w2 ...])
1.1 maekawa 2524: (Example: [(x,y) ring_of_polynomials 0] define_ring )
2525: ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
2526: ]
2527: ] putUsages
2528: /ord_w {
2529: /arg2 set /arg1 set
2530: [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
2531: [
2532: /fff arg1 def
2533: /www arg2 def
1.33 takayama 2534: www to_int32 /www set
1.1 maekawa 2535: fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
2536: fff (ring) dc /rrr set
2537: fff init /fff set
2538: /ddd 0 def
2539: 0 2 www length 1 sub {
2540: /iii set
1.37 takayama 2541: fff << www iii get rrr __ >> degree
1.1 maekawa 2542: << www iii 1 add get >> mul
2543: ddd add /ddd set
2544: } for
1.12 takayama 2545: /ord_w.LLL
2546: /arg1 ddd def
2547: ] pop
2548: popVariables
2549: arg1
2550: } def
2551:
2552: [(ord_w_all)
2553: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2554: (poly ff; string v1; integer w1; ...)
2555: (order of ff by the weight vector [w1 w2 ...])
2556: (Example: [(x,y,t) ring_of_polynomials 0] define_ring )
2557: ( (x^2 y^3-x-t). [(t) 1 ] ord_w_all ::)
2558: ]
2559: ] putUsages
2560: /ord_w_all {
2561: /arg2 set /arg1 set
1.13 takayama 2562: [/ord_w_all-in /fff /fff-in /www /rrr /iii /ddd /zzz /ddd-tmp] pushVariables
1.12 takayama 2563: [
2564: /fff arg1 def
2565: /www arg2 def
1.33 takayama 2566: www to_int32 /www set
1.13 takayama 2567: fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse
2568: /ddd -intInfinity def
1.12 takayama 2569: fff (ring) dc /rrr set
1.37 takayama 2570: /zzz (0) rrr __ def
1.12 takayama 2571: fff init /fff-in set
2572: fff fff-in sub /fff set
2573: {
1.13 takayama 2574: /ddd-tmp 0 def
1.12 takayama 2575: 0 2 www length 1 sub {
2576: /iii set
1.37 takayama 2577: fff-in << www iii get rrr __ >> degree
1.12 takayama 2578: << www iii 1 add get >> mul
1.13 takayama 2579: ddd-tmp add /ddd-tmp set
1.12 takayama 2580: } for
1.13 takayama 2581: ddd-tmp ddd gt { /ddd ddd-tmp def } { } ifelse
1.12 takayama 2582: fff zzz eq { exit } { } ifelse
2583: fff init /fff-in set
2584: fff fff-in sub /fff set
2585: } loop
1.13 takayama 2586: /ord_w_all.LLL
1.1 maekawa 2587: /arg1 ddd def
2588: ] pop
2589: popVariables
2590: arg1
2591: } def
2592:
2593: [(laplace0)
2594: [
2595: (f [v1 ... vn] laplace0 g)
2596: (poly f ; string v1 ... vn ; poly g;)
2597: (array of poly f ; string v1 ... vn ; array of poly g;)
2598: ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
2599: $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
2600: $ x --> -Dx, Dx --> x, y --> -Dy, Dy --> y. $
2601: ]
2602: ] putUsages
2603: /laplace0 {
2604: /arg2 set /arg1 set
2605: [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
2606: ] pushVariables
2607: [
2608: /ff arg1 def /vv arg2 def
2609: /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
2610: /rule [ ] def
2611: ff isPolynomial {
2612: ff (0). eq { /ans1 (0). def }
2613: {
2614: ff (ring) dc /rr set
2615: /nn vv length def
2616: 0 1 nn 1 sub {
2617: /ii set
2618: vv ii get (type?) dc 1 eq
2619: { } % skip, may be weight [(x) 2 ] is OK.
2620: {
2621: /v0 vv ii get (string) dc def
2622: v0 (array) dc 0 get Dascii eq %% If the first character is D?
2623: { rule %% Dx-->x
1.37 takayama 2624: [v0 rr __
2625: v0 (array) dc rest { (string) dc} map aload length cat_n rr __]
1.1 maekawa 2626: append /rule set
2627: }
2628: { rule %% x --> -Dx
1.37 takayama 2629: [v0 rr __
1.1 maekawa 2630: (0).
2631: [Dascii] v0 (array) dc join { (string) dc } map aload length
1.37 takayama 2632: cat_n rr __ sub
1.1 maekawa 2633: ]
2634: append /rule set
2635: } ifelse
2636: } ifelse
2637: } for
2638: % rule message
1.37 takayama 2639: ff rule replace [[(h) rr __ (1) rr __]] replace /ans1 set
1.1 maekawa 2640: } ifelse
2641: }
2642: {
2643: ff isArray { /ans1 ff {vv laplace0 } map def }
2644: {
2645: (laplace0 : the first argument must be a polynomial.) error
2646: }ifelse
2647: } ifelse
2648: /arg1 ans1 def
2649: ] pop
2650: popVariables
2651: arg1
2652: } def
2653:
2654: [(ip1)
2655: [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
2656: (<poly> v1 ... vn ; <integer> w1 ... wn m)
2657: (<poly> f1 ... fs )
2658: (Example: [(x,y) ring_of_differential_operators 0] define_ring )
2659: ( [(Dx). (Dy).] [2 1] 3 ip1 :: [(2 Dx Dy). (Dy^3).])
2660: ( Returns Dx^p Dy^q such that 2 p + 1 q = 3.)
2661: ]
2662: ] putUsages
2663: /ip1 {
2664: /arg3 set /arg2 set /arg1 set
2665: [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
2666: [
2667: /vv arg1 def /ww arg2 def /m arg3 def
2668: vv 0 get (ring) dc /rr set
2669: /rr.org [(CurrentRingp)] system_variable def
2670: [(CurrentRingp) rr] system_variable
2671: [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
2672: /ans [ ] def
2673: m 0 lt
2674: { }
2675: {
2676: vv
2677: ww { tt 2 1 roll power } map mul /tmp1 set
2678: %% (tmp1 = ) messagen tmp1 message
2679: 0 1 m {
2680: /k set
2681: k 0 eq {
2682: /ff (1). def
2683: }
2684: { tmp1 k power /ff set } ifelse
2685: ff [[(h). (1).]] replace /ff set
2686: %% ff message
2687: {
2688: ff init tt degree m eq {
2689: /ans ans [ ff init [[tt (1).]] replace ] join def
2690: } { } ifelse
2691: ff ff init sub /ff set
2692: ff (0). eq { exit } { } ifelse
2693: } loop
2694: } for
2695: } ifelse
2696: [(CurrentRingp) rr.org] system_variable
2697: /arg1 ans def
2698: ] pop
2699: popVariables
2700: arg1
2701: } def
2702:
2703: [(findIntegralRoots)
2704: [( f findIntegralRoots vlist)
2705: (poly f; list of integers vlist;)
2706: (string f; list of integers vlist;)
2707: (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
2708: (Example: (s^4-1) findIntegralRoots )
2709: ]
2710: ] putUsages
2711:
2712: /findIntegralRoots { findIntegralRoots.slow } def
2713:
2714: /findIntegralRoots.slow { %% by a stupid algorithm
2715: /arg1 set
2716: [/in-findIntegralRoots
2717: /ff /kk /roots /rrr /nn /k0 /d.find
2718: ] pushVariables
2719: [
2720: /ff arg1 def
2721: /roots [ ] def
2722: /rrr [(CurrentRingp)] system_variable def
2723: ff toString /ff set
2724: [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
2725: ff . /ff set
2726:
2727: %%ff message %% Cancel the common numerical factor of the polynomial ff.
2728: ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
2729: [(divByN) ff d.find] gbext 0 get /ff set
2730: %% d.find message
2731: %% ff message
2732:
2733: ff [[(s). (0).]] replace /k0 set
2734: k0 (universalNumber) dc /k0 set
2735: k0 (0).. eq { roots (0).. append /roots set } { } ifelse
2736:
2737: {
2738: ff [[(s). (0).]] replace /nn set
2739: nn (universalNumber) dc /nn set
2740: nn (0).. eq
2741: { (s^(-1)). ff mul /ff set }
2742: { exit }
2743: ifelse
2744: } loop
2745: ff [[(s). (0).]] replace /k0 set
2746: k0 (universalNumber) dc /k0 set
2747: k0 (-40000).. gt k0 (40000).. lt and not {
2748: [(Roots of b-function cannot be obtained by a stupid method.) nl
2749: (Use ox_asir for efficient factorizations, or restall and bfm manually.)
2750: nl
2751: (ox_asir server will be distributed from the asir ftp cite.) nl
2752: (See lib/ttt.tex for details.) nl
2753: ] cat
2754: error
2755: } { } ifelse
2756: nn (0).. lt { (0).. nn sub /nn set } { } ifelse
2757: /kk (0).. nn sub def
2758: /roots [ kk (1).. sub ] roots join def
2759: {
2760: kk nn gt { exit } { } ifelse
2761: ff [[(s). kk (poly) dc]] replace
2762: (0). eq
2763: { /roots roots kk append def }
2764: { } ifelse
2765: kk (1).. add /kk set
2766: } loop
2767: [(CurrentRingp) rrr] system_variable
2768: roots { (integer) dc } map /roots set %% ?? OK?
2769: roots shell rest /roots set
2770: /arg1 roots def
2771: ] pop
2772: popVariables
2773: arg1
2774: } def
2775:
2776: /ngcd {
2777: /arg1 set
2778: [/in-ngcd /nlist /g.ngcd /ans] pushVariables
2779: [
2780: /nlist arg1 def
1.29 takayama 2781: nlist to_univNum /nlist set
1.1 maekawa 2782: nlist length 2 lt
2783: { /ans nlist 0 get def /L.ngcd goto }
2784: {
2785: [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
2786: g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
2787: [g.ngcd] nlist rest rest join ngcd /ans set
2788: } ifelse
2789: /L.ngcd
2790: ans /arg1 set
2791: ] pop
2792: popVariables
2793: arg1
2794: } def
2795:
2796: [(ngcd)
2797: [(nlist ngcd d )
2798: (list of numbers nlist; number d;)
2799: (d is the gcd of the numbers in nlist.)
2800: (Example: [(12345).. (67890).. (98765)..] ngcd )
2801: ]] putUsages
2802:
2803: /dehomogenize {
2804: /arg1 set
2805: [/in-dehomogenize /f /rr /ans /cring] pushVariables
2806: [
2807: /f arg1 def
2808: f isPolynomial {
2809: f (0). eq
2810: { f /ans set }
2811: {
2812: f (ring) dc /rr set
2813: [(CurrentRingp)] system_variable /cring set
2814: [(CurrentRingp) rr] system_variable
2815: f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
2816: [(CurrentRingp) cring] system_variable
2817: } ifelse
2818: }
2819: {
2820: f isArray {
2821: f { dehomogenize } map /ans set
2822: }
2823: {(dehomogenize: argument should be a polynomial.) error }
2824: ifelse
2825: } ifelse
2826: /arg1 ans def
2827: ] pop
2828: popVariables
2829: arg1
2830: } def
2831:
2832: [(dehomogenize)
2833: [(obj dehomogenize obj2)
2834: (dehomogenize puts the homogenization variable to 1.)
2835: (Example: (x*h+h^2). dehomogenize :: x+1 )
2836: ]
2837: ] putUsages
2838:
2839:
2840: /from_records { { (,) } map aload length cat_n } def
2841: [(from_records)
2842: [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
2843: (Example : [(x) (y)] from_records :: (x,y,))
2844: (cf. to_records)
2845: ]
2846: ] putUsages
2847: /popEnv {
2848: { system_variable pop } map pop
2849: } def
2850:
2851: /pushEnv {
2852: %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
2853: { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
2854: } def
2855: [(pushEnv)
2856: [(keylist pushEnv envlist)
2857: (array of string keylist, array of [string object] envlist;)
2858: (Values <<envlist>> of the global system variables specified )
2859: (by the <<keylist>> is push on the stack.)
2860: (keylist is an array of keywords for system_variable.)
2861: (cf. system_variable, popEnv)
2862: (Example: [(CurrentRingp) (KanGBmessage)] pushEnv)
2863: ]
2864: ] putUsages
2865: [(popEnv)
2866: [(envlist popEnv)
2867: (cf. pushEnv)
2868: ]
2869: ] putUsages
2870:
2871: /npower {
2872: /arg2 set
2873: /arg1 set
2874: [/f /k /i /ans] pushVariables
2875: [
2876: /f arg1 def /k arg2 ..int def
2877: f tag PolyP eq {
2878: /ans (1). def
2879: } {
2880: /ans (1).. def
2881: } ifelse
2882: k 0 lt {
2883: 1 1 << 0 k sub >> {
2884: /ans f ans {mul} sendmsg2 def
2885: } for
2886: /ans (1).. ans {div} sendmsg2 def
2887: }
2888: {
2889: 1 1 k {
2890: /ans f ans {mul} sendmsg2 def
2891: } for
2892: } ifelse
2893: /arg1 ans def
2894: ] pop
2895: popVariables
2896: arg1
2897: } def
2898: [(npower)
2899: [(obj1 obj2 npower obj3)
2900: (npower returns obj1^obj2 as obj3)
2901: (The difference between power and npower occurs when we compute f^0)
2902: (where f is a polynomial.)
2903: $power returns number(universalNumber) 1, but npower returns 1$
2904: (in the current ring.)
2905: ]
2906: ] putUsages
2907:
2908: /gensym {
2909: (dollar) dc 2 cat_n
2910: } def
2911: [(gensym)
2912: [(x i gensym xi)
2913: (string x; integer i; string xi)
2914: (It generate a string x indexed with the number i.)
2915: $Example: (Dx) 12 gensym (Dx12)$
2916: ]
2917: ] putUsages
2918:
2919: /cat {
2920: { toString } map aload length cat_n
2921: } def
2922: [(cat)
2923: [(a cat s)
2924: (array a ; string s;)
2925: (cat converts each entry of << a >> to a string and concatenates them.)
2926: (Example: [ (x) 1 2] cat ==> (x12))
2927: ]
2928: ] putUsages
2929:
2930:
2931: %%%%%%%%%%%%%%%%%%% pmat-level
2932: /pmat-level {
2933: /arg2 set
2934: /arg1 set
2935: [/n /i /m /lev /flag] pushVariables
2936: [
2937: /m arg1 def
2938: /lev arg2 def
2939: m isArray {
2940: /n m length def
2941: n 0 eq { /flag 0 def }
2942: { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
2943: } { /flag 0 def } ifelse
2944:
2945: flag {
2946: 0 1 lev {
2947: pop ( ) messagen
2948: } for
2949: ([ ) message
2950: 0 1 n 1 sub {
2951: /i set
2952: m i get lev 1 add pmat-level
2953: } for
2954: 0 1 lev {
2955: pop ( ) messagen
2956: } for
2957: (]) message
2958: }
2959: {
2960: 0 1 lev {
2961: pop ( ) messagen
2962: } for
2963: ( ) messagen
2964: m message
2965: } ifelse
2966: ] pop
2967: popVariables
2968: } def
2969:
2970: /pmat { 0 pmat-level } def
2971:
2972: [(pmat)
2973: [(f pmat)
2974: (array f;)
2975: (f is pretty printed.)
2976: ]
2977: ] putUsages
2978:
2979:
2980: /adjoint1 {
2981: /arg2 set
2982: /arg1 set
2983: [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
2984: [
2985: /f arg1 def
2986: /xx arg2 def
2987: f isPolynomial { }
2988: { (adjoint1: the first argument must be a polynomial.) message
2989: pop popVariables
2990: (adjoint1: the first argument must be a polynomial.) error
2991: } ifelse
2992: /ans (0). def
2993: f (0). eq { }
2994: {
2995: /xx xx (string) dc def
2996: /dxx [@@@.Dsymbol xx] cat def
1.37 takayama 2997: /xx xx f (ring) dc __ def
2998: /dxx dxx f (ring) dc __ def
2999: /one (1) f (ring) dc __ def
1.1 maekawa 3000:
3001: {
3002: /g f init def
3003: /f f g sub def
3004: /p g xx degree def
3005: /q g dxx degree def
3006: g [[xx one] [dxx one]] replace /g set
3007: g
3008: << (0). dxx sub q npower xx p npower mul >>
3009: mul
3010: ans add /ans set
3011: f (0). eq { exit } { } ifelse
3012: } loop
3013: ans dehomogenize /ans set
3014: } ifelse
3015: /arg1 ans def
3016: ] pop
3017: popVariables
3018: arg1
3019: } def
3020:
3021: /adjoint {
3022: /arg2 set
3023: /arg1 set
3024: [/in-adjoint /f /xx /xx0] pushVariables
3025: [
3026: /f arg1 def /xx arg2 def
3027: xx toString /xx set
3028: [xx to_records pop] /xx set
3029: xx { /xx0 set f xx0 adjoint1 /f set } map
3030: /arg1 f def
3031: ]pop
3032: popVariables
3033: arg1
3034: } def
3035:
3036: [(adjoint)
3037: [(f xlist adjoint g)
3038: (poly f; string xlist; poly g;)
3039: (g is the adjoint operator of f.)
3040: (The variables to take adjoint are specified by xlist.)
3041: (Example: [(x,y) ring_of_differential_operators 0] define_ring)
3042: ( (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
3043: $ ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
3044: ]] putUsages
3045:
3046: %%%%% diagonal for tensor products
3047: %% 1998, 12/4 (Sat)
3048: %% s_i = x_i, t_i = x_i - y_i, Restrict to t_i = 0.
3049: %% x_i = x_i, y_i = s_i - t_i,
3050: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
3051: /diagonalx {
3052: /arg2 set
3053: /arg1 set
3054: [/in-diagonalx /f] pushVariables
3055: [
3056: (Not implemented yet.) message
3057: ] pop
3058: popVariables
3059: arg1
3060: } def
3061:
3062:
3063:
3064: %%%%%%%%%%% distraction2 for b-function
3065: /distraction2 {
3066: /arg4 set
3067: /arg3 set
3068: /arg2 set
3069: /arg1 set
3070: [/f /dx /ss /xx /ans /n /i /rr] pushVariables
3071: [
3072: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3073: f (0). eq { }
3074: {
3075: /rr f (ring) dc def
1.37 takayama 3076: xx {toString rr __ } map /xx set
3077: dx {toString rr __ } map /dx set
3078: ss {toString rr __ } map /ss set
1.1 maekawa 3079: /n xx length def
3080: 0 1 n 1 sub {
3081: /i set
3082: /f f xx i get dx i get ss i get destraction2.1 /f set
3083: } for
3084: } ifelse
3085: /arg1 f def
3086: ]pop
3087: popVariables
3088: arg1
3089: } def
3090: [(distraction2)
3091: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
3092: ( distraction2 result )
3093: $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
3094: $ (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
3095: $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
3096: ]
3097: ] putUsages
3098: /destraction2.1 {
3099: /arg4 set
3100: /arg3 set
3101: /arg2 set
3102: /arg1 set
3103: [/ww /f /dx /ss /xx /coeff0 /expvec
3104: /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
3105: [
3106: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3107: f (ring) dc /rr set
1.37 takayama 3108: /one (1) rr __ def %%
1.1 maekawa 3109: /ww [ xx toString -1 dx toString 1 ] weightv def
3110: f ww init f sub (0). eq { }
3111: { [(destraction2.1 : inhomogeneous with respect to )
3112: xx ( and ) dx nl
3113: (Your weight vector may not be generic.)
3114: ] cat error } ifelse
3115: /dd << f dx degree >> << f xx degree >> sub def
3116: f [[xx one]] replace dx coefficients /coeff0 set
3117: /expvec coeff0 0 get { (integer) dc } map def
3118: /coeffvec coeff0 1 get def
3119: expvec { ss 2 -1 roll factorial } map /expvec2 set
3120: expvec2 coeffvec mul /ans set
3121: %% x^p d^q, (p > q) case. x^2( x^2 Dx^2 + x Dx + 1)
3122: dd 0 lt {
3123: %% (ss+1) (ss+2) ... (ss+d)
3124: one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
3125: ans mul /ans set
3126: }
3127: { } ifelse
3128: /arg1 ans def
3129: ] pop
3130: popVariables
3131: arg1
1.3 takayama 3132: } def
3133:
3134: /distraction2* {
3135: /arg1 set
3136: [/in-distraction2* /aa /f /vlist /xlist /dlist /slist ] pushVariables
3137: [(CurrentRingp)] pushEnv
3138: [
3139: /aa arg1 def
3140: /f aa 0 get def
3141: /vlist aa 1 get def
3142: /xlist aa 2 get def
3143: /dlist aa 3 get def
3144: /slist aa 4 get def
3145: vlist isArray
3146: {
3147: vlist { toString } map /vlist set
3148: }
3149: {
3150: vlist toString to_records /vlist set
3151: } ifelse
3152: xlist isArray
3153: {
3154: xlist { toString } map /xlist set
3155: }
3156: {
3157: xlist toString to_records /xlist set
3158: } ifelse
3159: slist isArray
3160: {
3161: slist { toString } map /slist set
3162: }
3163: {
3164: slist toString to_records /slist set
3165: } ifelse
3166: [vlist from_records ring_of_differential_operators 0] define_ring pop
3167: f toString .
3168: xlist { . } map
3169: dlist { toString . } map
3170: slist { toString . } map
3171: distraction2 /arg1 set
3172: ] pop
3173: popEnv
3174: popVariables
3175: arg1
1.1 maekawa 3176: } def
3177:
3178: /message-quiet {
3179: @@@.quiet { pop } { message } ifelse
3180: } def
3181: [(message-quiet)
3182: [(s message-quiet )
3183: (string s;)
3184: (It outputs the message s when @@@.quiet is not equal to 1.)
3185: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3186: ]] putUsages
3187: /messagen-quiet {
3188: @@@.quiet { pop } { messagen } ifelse
3189: } def
3190: [(messagen-quiet)
3191: [(s messagen-quiet )
3192: (string s;)
3193: (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
3194: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3195: ]] putUsages
3196:
3197: /getvNames0 {
3198: /arg1 set
3199: [/in-getvNames0 /nlist /nn /i] pushVariables
3200: [
3201: /nlist arg1 def
3202: [(N)] system_variable /nn set
3203: nlist { /i set
3204: i nn lt {
3205: [(x) (var) i] system_variable
3206: } {
3207: [(D) (var) i nn sub] system_variable
3208: } ifelse
3209: } map
3210: /arg1 set
3211: ] pop
3212: popVariables
3213: arg1
3214: } def
3215:
3216: /getvNames {
3217: [/in-getvNames /nn] pushVariables
3218: [
3219: [(N)] system_variable /nn set
3220: [0 1 nn 2 mul 1 sub { } for] getvNames0 /arg1 set
3221: ] pop
3222: popVariables
3223: arg1
3224: } def
3225: [(getvNames)
3226: [(getvNames vlist)
3227: (list vlist)
3228: (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
3229: (Use with [(variableNames) vlist] system_variable.)
3230: (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
3231: ]] putUsages
3232:
3233: /getvNamesC {
3234: [/in-getvNamesC /nn /i] pushVariables
3235: [
3236: [(N)] system_variable /nn set
3237: [nn 1 sub -1 0 { } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
3238: ] pop
3239: popVariables
3240: arg1
3241: } def
3242: [(getvNamesC)
3243: [(getvNamesC vlist)
3244: (list vlist)
3245: $It returns of the list of the variables in the order 0, 1, 2, ... $
3246: $(cmo-order and output_order).$
3247: (cf. getvNames)
3248: ]] putUsages
3249:
3250: /getvNamesCR {
3251: /arg1 set
3252: [/in-getvNamesCR /rrr] pushVariables
3253: [(CurrentRingp)] pushEnv
3254: [
3255: /rrr arg1 def
3256: rrr isPolynomial {
3257: rrr (0). eq { (No name field for 0 polynomial.) error }
3258: { rrr (ring) dc /rrr set } ifelse
3259: } { } ifelse
3260: [(CurrentRingp) rrr] system_variable
3261: getvNamesC /arg1 set
3262: ] pop
3263: popEnv
3264: popVariables
3265: arg1
3266: } def
3267: [(getvNamesCR)
3268: [(obj getvNamesCR vlist)
3269: (obj ring | poly ; list vlist)
3270: $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
3271: (for <<obj>>.)
3272: (Example: ( (x-2)^3 ). /ff set )
3273: ( [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
3274: ]] putUsages
3275:
3276:
3277: /reduction-noH {
3278: /arg2 set
3279: /arg1 set
3280: [/in-reduction-noH /ff /gg] pushVariables
3281: [(Homogenize)] pushEnv
3282: [
3283: /ff arg1 def
3284: /gg arg2 def
3285: [(Homogenize) 0] system_variable
3286: ff gg reduction /arg1 set
3287: ] pop
3288: popEnv
3289: popVariables
3290: arg1
3291: } def
3292: [(reduction-noH)
3293: [(f g reduction-noH r)
3294: (poly f; array g; array r;)
3295: (Apply the normal form algorithm for f with the set g. All computations are)
3296: (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
3297: (specifications are the same with reduction. cf. reduction)
3298: (g should be dehomogenized.)
3299: ]] putUsages
3300:
3301: /-intInfinity -999999999 def
3302: /intInfinity 999999999 def
3303: [(intInfinity)
3304: [(intInfinity = 999999999)]
3305: ] putUsages
3306: [(-intInfinity)
3307: [(-intInfinity = -999999999)]
3308: ] putUsages
3309:
3310:
3311: /maxInArray {
3312: /arg1 set
3313: [/in-maxInArray /v /ans /i /n] pushVariables
3314: [
3315: /v arg1 def
3316: /n v length def
3317: /maxInArray.pos 0 def
3318: n 0 eq {
3319: /ans null def
3320: } {
3321: /ans v 0 get def
3322: 1 1 n 1 sub {
3323: /i set
3324: v i get ans gt {
3325: /ans v i get def
3326: /maxInArray.pos i def
3327: } { } ifelse
3328: } for
3329: } ifelse
3330: /arg1 ans def
3331: ] pop
3332: popVariables
3333: arg1
3334: } def
3335: [(maxInArray)
3336: [( [v1 v2 ....] maxInArray m )
3337: (m is the maximum in [v1 v2 ...].)
3338: (The position of m is stored in the global variable maxInArray.pos.)
3339: ]] putUsages
3340:
3341: /cancelCoeff {
1.18 takayama 3342: /arg1 set
3343: [(reduceContent) arg1] gbext 0 get
3344: } def
3345: /cancelCoeff_org {
1.1 maekawa 3346: /arg1 set
3347: [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
3348: [ /ff arg1 def
3349: ff (0). eq {
3350: /label.cancelCoeff2 goto
3351: } { } ifelse
3352: /gg ff def
3353: /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
3354: {
3355: gg (0). eq { exit} { } ifelse
3356: [(lcoeff) gg init] gbext (universalNumber) dc /dd2 set
3357: [(gcd) dd dd2] mpzext /dd set
3358: dd (1).. eq {
3359: /label.cancelCoeff goto
3360: } { } ifelse
3361: /gg gg gg init sub def
3362: } loop
3363: [(divByN) ff dd] gbext 0 get /ff set
3364: /label.cancelCoeff
3365: [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
3366: { ff (-1).. mul /ff set } { } ifelse
3367: /label.cancelCoeff2
3368: /arg1 ff def
3369: ] pop
3370: popVariables
3371: arg1
3372: } def
3373: [(cancelCoeff)
3374: [(f cancelcoeff g)
3375: (poly f,g;)
3376: (Factor out the gcd of the coefficients.)
3377: (Example: (6 x^2 - 10 x). cancelCoeff)
3378: (See also gbext.)
3379: ]] putUsages
3380:
3381:
3382: /flatten {
3383: /arg1 set
3384: [/in-flatten /mylist] pushVariables
3385: [
3386: /mylist arg1 def
3387: mylist isArray {
3388: mylist { dup isArray { aload pop } { } ifelse } map /mylist set
3389: }{ } ifelse
3390: /arg1 mylist def
3391: ] pop
3392: popVariables
3393: arg1
3394: } def
3395: [(flatten)
3396: [(list flatten list2)
3397: (Flatten the list.)
3398: (Example 1: [ [1 2 3] 4 [2]] flatten ===> [1 2 3 4 2])
3399: ]] putUsages
3400:
3401: %% Take first N elements.
3402: /carN {
3403: /arg2 set
3404: /arg1 set
3405: [/in-res-getN /pp /nn /ans] pushVariables
3406: [
3407: /nn arg2 def
3408: /pp arg1 def
3409: pp isArray {
3410: pp length nn lt {
3411: /ans pp def
3412: } {
3413: [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
3414: } ifelse
3415: } {
3416: /ans pp def
3417: } ifelse
3418: /arg1 ans def
3419: ] pop
3420: popVariables
3421: arg1
3422: } def
3423: [(carN)
3424: [([f1 ... fm] n carN [f1 ... fn])
3425: (carN extracts the first n elements from the list.)
3426: ]] putUsages
3427:
3428: /getRing {
3429: /arg1 set
3430: [/in-getRing /aa /n /i /ans] pushVariables
3431: [
3432: /aa arg1 def
3433: /ans null def
3434: aa isPolynomial {
3435: aa (0). eq {
3436: } {
3437: /ans aa (ring) dc def
3438: } ifelse
3439: } {
3440: aa isArray {
3441: /n aa length 1 sub def
3442: 0 1 n { /i set aa i get getRing /ans set
3443: ans tag 0 eq { } { /getRing.LLL goto } ifelse
3444: } for
3445: }{ } ifelse
3446: } ifelse
3447: /getRing.LLL
3448: /arg1 ans def
3449: ] pop
3450: popVariables
3451: arg1
3452: } def
3453: [(getRing)
3454: [(obj getRing rr)
3455: (ring rr;)
3456: (getRing obtains the ring structure from obj.)
3457: (If obj is a polynomial, it returns the ring structure associated to)
3458: (the polynomial.)
3459: (If obj is an array, it recursively looks for the ring structure.)
3460: ]] putUsages
3461: /toVectors {
3462: /arg1 set
3463: [/in-toVectors /gg /n /ans] pushVariables
3464: [
3465: /gg arg1 def
3466: gg isArray {
3467: gg length 0 eq {
3468: /ans [ ] def
3469: /toVectors.LLL goto
3470: } {
3471: gg 0 get isInteger {
3472: gg @@@.toVectors2 /ans set
3473: } {
3474: gg @@@.toVectors /ans set
3475: } ifelse
3476: /toVectors.LLL goto
3477: } ifelse
3478: } {
3479: %% It is not array.
3480: gg (array) dc /ans set
3481: } ifelse
3482: /toVectors.LLL
3483: /arg1 ans def
3484: ] pop
3485: popVariables
3486: arg1
3487: } def
3488: /@@@.toVectors2 {
3489: /arg1 set
3490: [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
3491: [
3492: /gg arg1 def
3493: /ans gg 1 get @@@.toVectors def
3494: /n gg 0 get def
3495: gg 1 get isArray not {
3496: /ans [ans] def
3497: /notarray 1 def
3498: }{ /notarray 0 def} ifelse
3499: ans {
3500: /tmp set
3501: tmp length n lt {
3502: tmp
3503: [1 1 n tmp length sub { pop (0). } for ]
3504: join /tmp set
3505: } { } ifelse
3506: tmp
3507: } map
3508: /ans set
3509: notarray { ans 0 get /ans set } { } ifelse
3510: /arg1 ans def
3511: ] pop
3512: popVariables
3513: arg1
3514: } def
3515:
3516: /@@@.toVectors {
3517: /arg1 set
3518: [/in-@@@.toVectors /gg ] pushVariables
3519: [
3520: /gg arg1 def
3521: gg isArray {
3522: gg { $array$ data_conversion } map
3523: } {
3524: gg (array) data_conversion
3525: }ifelse
3526: /arg1 set
3527: ] pop
3528: popVariables
3529: arg1
3530: } def
3531:
3532: /toVectors2 { toVectors } def
3533:
3534: /fromVectors { { fromVectors.aux } map } def
3535: /fromVectors.aux {
3536: /arg1 set
3537: [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
3538: [(CurrentRingp)] pushEnv
3539: [
3540: /vv arg1 def
3541: /mm vv length def
3542: /ans (0). def
3543: /ee (0). def
3544: 0 1 mm 1 sub {
3545: /i set
3546: vv i get (0). eq {
3547: } {
3548: [(CurrentRingp) vv i get (ring) dc] system_variable
3549: [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
3550: /fromVector.LLL goto
3551: } ifelse
3552: } for
3553: /fromVector.LLL
3554: %% vv message
3555: 0 1 mm 1 sub {
3556: /i set
3557: vv i get (0). eq {
3558: } {
3559: /ans ans
3560: << vv i get >> << ee i npower >> mul
3561: add def
3562: } ifelse
3563: %% [i ans] message
3564: } for
3565: /arg1 ans def
3566: ] pop
3567: popEnv
3568: popVariables
3569: arg1
3570: } def
3571: [(fromVectors)
3572: [
3573: ([v1 v2 ...] fromVectors [s1 s2 ...])
3574: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
3575: (cf. toVectors. <<e_>> varaible is assumed to be the last )
3576: ( variable in x. @@@.esymbol)
3577: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
3578: $ [(x). (y).] /ff set $
3579: $ [ff ff] fromVectors :: $
3580: ]] putUsages
3581:
3582: /getOrderMatrix {
3583: /arg1 set
3584: [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
3585: [(CurrentRingp)] pushEnv
3586: [
3587: /obj arg1 def
3588: obj isArray {
3589: obj { getOrderMatrix } map /ans set
3590: ans length 0 {
3591: /ans null def
3592: } {
3593: /ans2 null def
3594: 0 1 ans length 1 sub {
3595: /i set
3596: ans i get tag 0 eq
3597: { }
3598: { /ans2 ans i get def } ifelse
3599: } for
3600: /ans ans2 def
3601: } ifelse
3602: /getOrderMatrix.LLL goto
3603: } { } ifelse
3604: obj tag 14 eq {
3605: [(CurrentRingp) obj] system_variable
3606: [(orderMatrix)] system_variable /ans set
3607: /getOrderMatrix.LLL goto
3608: } { } ifelse
3609: obj isPolynomial {
3610: obj (0). eq
3611: { /ans null def
3612: } { obj getRing /rr set
3613: [(CurrentRingp) rr] system_variable
3614: [(orderMatrix)] system_variable /ans set
3615: } ifelse
3616: /getOrderMatrix.LLL goto
3617: } { (getOrderMatrix: wrong argument.) error } ifelse
3618: /getOrderMatrix.LLL
3619: /arg1 ans def
3620: ] pop
3621: popEnv
3622: popVariables
3623: arg1
3624: } def
3625:
3626:
3627: [(getOrderMatrix)
3628: [(obj getOrderMatrix m)
3629: (array m)
3630: (getOrderMatrix obtains the order matrix from obj.)
3631: (If obj is a polynomial, it returns the order matrix associated to)
3632: (the polynomial.)
3633: (If obj is an array, it returns an order matrix of an element.)
3634: ]] putUsages
3635:
3636: /nl {
3637: 10 $string$ data_conversion
3638: } def
3639: [(nl)
3640: [(nl is the newline character.)
3641: $Example: [(You can break line) nl (here.)] cat message$
1.4 takayama 3642: ]] putUsages
3643:
3644: /to_int {
3645: /arg1 set
3646: [/to-int /ob /ans] pushVariables
3647: [
3648: /ob arg1 def
3649: /ans ob def
3650: ob isArray {
3651: ob {to_int} map /ans set
3652: /LLL.to_int goto
3653: } { } ifelse
3654: ob isInteger {
3655: ob (universalNumber) dc /ans set
3656: /LLL.to_int goto
3657: } { } ifelse
3658: /LLL.to_int
3659: /arg1 ans def
3660: ] pop
3661: popVariables
3662: arg1
3663: } def
3664: [(to_int)
3665: [(obj to_int obj2)
3666: (All integers in obj are changed to universalNumber.)
3667: (Example: /ff [1 2 [(hello) (0).]] def ff { tag } map ::)
3668: ( ff to_int { tag } map :: )
1.5 takayama 3669: ]] putUsages
3670:
1.33 takayama 3671: /to_int32 {
3672: /arg1 set
3673: [/to-int32 /ob /ans] pushVariables
3674: [
3675: /ob arg1 def
3676: /ans ob def
3677: ob isArray {
3678: ob {to_int32} map /ans set
3679: /LLL.to_int32 goto
3680: } { } ifelse
3681: ob isUniversalNumber {
3682: ob (integer) dc /ans set
3683: /LLL.to_int32 goto
3684: } { } ifelse
3685: /LLL.to_int32
3686: /arg1 ans def
3687: ] pop
3688: popVariables
3689: arg1
3690: } def
3691: [(to_int32)
3692: [(obj to_int32 obj2)
3693: $All universalNumber in obj are changed to integer (int32).$
3694: (Example: /ff [1 (2).. [(hello) (0).]] def ff { tag } map ::)
3695: ( ff to_int32 { tag } map :: )
3696: (cf. to_int, to_univNum )
3697: ]] putUsages
3698:
1.5 takayama 3699: /define_ring_variables {
1.6 takayama 3700: [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables
3701: %% You cannot use these names for names for polynomials.
1.5 takayama 3702: [
1.6 takayama 3703: /drv._v getVariableNames def
3704: /drv._v0 drv._v def
3705: drv._v { dup /drv._p set (/) 2 1 roll ( $) drv._p ($. def ) } map cat
3706: /drv._v set
3707: % drv._v message
3708: [(parse) drv._v] extension
1.5 takayama 3709: ] pop
3710: popVariables
3711: } def
3712: [(define_ring_variables)
3713: [(It binds a variable <<a>> in the current ring to the sm1 variable <<a>>.)
3714: (For example, if x is a variable in the current ring, it defines the sm1)
3715: (variable x by /x (x) def)
3716: ]] putUsages
3717:
3718: /boundp {
3719: /arg1 set
3720: [/a /ans] pushVariables
3721: [
3722: /a arg1 def
3723: [(parse) [(/) a ( load tag 0 eq { /ans 0 def } )
3724: ( { /ans 1 def } ifelse )] cat ] extension
3725: /arg1 ans def
3726: ] pop
3727: popVariables
3728: arg1
3729: } def
3730: [(boundp)
3731: [( a boundp b)
3732: (string a, b is 0 or 1.)
3733: (If the variable named << a >> is bounded to a value,)
3734: (it returns 1 else it returns 0.)
3735: $Example: (hoge) boundp ::$
1.1 maekawa 3736: ]] putUsages
1.10 takayama 3737: [(isSubstr)
3738: [
3739: (s1 s2 isSubstr pos)
3740: (If s1 is a substring of s2, isSubstr returns the position in s2 from which)
3741: (s1 is contained in s2.)
3742: (If s1 is not a substring of s2, then isSubstr returns -1.)
3743: ]
3744: ] putUsages
3745: /isSubstr {
3746: /arg2 set /arg1 set
3747: [/in-isSubstr /s1 /s2 /i1 /i2 /n1 /n2
3748: /ans /flg
3749: ] pushVariables
3750: [
3751: /s1 arg1 def
3752: /s2 arg2 def
3753: s1 (array) dc /s1 set
3754: s2 (array) dc /s2 set
3755: /n1 s1 length def
3756: /n2 s2 length def
3757: /ans -1 def
3758: 0 1 n2 n1 sub {
3759: /i2 set
3760: /flg 1 def
3761: 0 1 n1 1 sub {
3762: /i1 set
3763: s1 i1 get s2 i2 i1 add get eq {
3764: } {
3765: /flg 0 def exit
3766: } ifelse
3767: } for
3768: flg {
3769: /ans i2 def
3770: /isSubstr.L2 goto
3771: } { /ans -1 def } ifelse
3772: } for
3773: /isSubstr.L2
3774: /arg1 ans def
3775: ] pop
3776: popVariables
3777: arg1
1.14 takayama 3778: } def
3779:
3780: [(execve)
3781: [
3782: (command execve)
3783: ([arg0 arg1 arg2 ...] execve )
3784: (It executes the command by the system call execve.)
3785: (cf. system, forkExec)
3786: ]
3787: ] putUsages
3788:
3789: /execve {
3790: /execve.arg set
3791: [(forkExec) execve.arg [ ] 1] extension
1.15 takayama 3792: } def
3793:
3794: [(beginEcart)
3795: [
3796: (beginEcart)
3797: (Set the environments for the ecart division algorithm.)
3798: ]
3799: ] putUsages
3800:
1.23 takayama 3801: /ecart.debug_reduction1 0 def
1.15 takayama 3802: /beginEcart {
3803: (red@) (ecart) switch_function
3804: [(Ecart) 1] system_variable
1.16 takayama 3805: [(CheckHomogenization) 0] system_variable
3806: [(ReduceLowerTerms) 0] system_variable
3807: [(AutoReduce) 0] system_variable
1.17 takayama 3808: [(EcartAutomaticHomogenization) 0] system_variable
1.23 takayama 3809: ecart.debug_reduction1 {
3810: (red@) (debug) switch_function
3811: } { } ifelse
1.15 takayama 3812: } def
3813:
3814: [(endEcart)
3815: [
3816: (endEcart)
3817: (End of using the ecart division algorithm.)
3818: ]
3819: ] putUsages
3820:
3821: /endEcart {
3822: (red@) (standard) switch_function
3823: [(Ecart) 0] system_variable
1.21 takayama 3824: [(degreeShift) (reset)] homogenize pop
1.10 takayama 3825: } def
1.19 takayama 3826:
3827: /ord_ws_all {
3828: /arg2 set /arg1 set
3829: [(ord_ws_all) arg1 arg2] gbext
3830: } def
3831: [(ord_ws_all)
3832: [
3833: (fv wv ord_ws_all degree)
3834: ( ord_ws_all returns the ord with respect to the weight vector wv.)
3835: $Example: [(x,y) ring_of_differential_operators 0] define_ring $
3836: $ (Dx^2+x*Dx*Dy+2). [(Dx) 1 (Dy) 1] weightv ord_ws_all :: $
3837: ( )
3838: (fv [wv shiftv] ord_ws_all degree)
3839: ( ord_ws_all returns the ord with respect to the weight vector wv and)
3840: ( the shift vector shiftv.)
3841: $Example: [(x,y) ring_of_differential_operators 0] define_ring $
3842: $ [(Dx^2+x*Dx*Dy+2). (Dx).] [[(Dx) 1 (Dy) 1] weightv [0 2]] ord_ws_all ::$
3843: ( )
3844: (cf: init, gbext. Obsolete: ord_w, ord_w_all)
3845: ]
3846: ] putUsages
1.22 takayama 3847:
3848: [(newVector)
3849: [( n newVector vec)
3850: ]] putUsages
3851: /newVector {
3852: /arg1 set
3853: [/in-newVector /n] pushVariables
3854: [
3855: /n arg1 def
3856: [(newVector) n] extension /arg1 set
3857: ] pop
3858: popVariables
3859: arg1
3860: } def
3861:
3862: [(newMatrix)
3863: [( [m n] newMatrix mat)
3864: ]] putUsages
3865: /newMatrix {
3866: /arg1 set
3867: [/in-newMatrix /n] pushVariables
3868: [
3869: /n arg1 def
3870: [(newMatrix) n 0 get n 1 get] extension /arg1 set
3871: ] pop
3872: popVariables
3873: arg1
1.25 takayama 3874: } def
3875:
3876: /addStdoutStderr {
3877: [(>) (stringOut://@@@stdout) (2>) (stringOut://@@@stderr)] join
1.27 takayama 3878: } def
3879:
1.37 takayama 3880: [(___)
1.27 takayama 3881: [(reparse a polynomial or polynomials)]
3882: ] putUsages
1.37 takayama 3883: /___ {
1.27 takayama 3884: /arg1 set
3885: [/in-reparse /ff] pushVariables
3886: [
3887: /ff arg1 def
3888: ff tag 6 eq {
1.37 takayama 3889: ff { ___ } map /arg1 set
1.27 takayama 3890: } {
3891: ff toString . /arg1 set
3892: } ifelse
1.29 takayama 3893: ] pop
3894: popVariables
3895: arg1
3896: } def
3897:
3898: /to_univNum {
3899: /arg1 set
3900: [/rr ] pushVariables
3901: [
3902: /rr arg1 def
3903: rr isArray {
3904: rr { to_univNum } map /rr set
3905: } {
3906: } ifelse
3907: rr isInteger {
3908: rr (universalNumber) dc /rr set
3909: } {
3910: } ifelse
3911: /arg1 rr def
3912: ] pop
3913: popVariables
3914: arg1
3915: } def
3916: [(to_univNum)
3917: [(obj to_univNum obj2)
3918: (Example. [ 2 (3).. ] to_univNum)
1.33 takayama 3919: $cf. to_int32. (to_int)$
1.29 takayama 3920: ]] putUsages
3921:
3922: [(lcm)
3923: [ ([a b c ...] lcm r)
3924: (cf. polylcm, mpzext)
3925: ]
3926: ] putUsages
3927: /lcm {
3928: /arg1 set
3929: [/aa /bb /rr /pp /i] pushVariables
3930: [
3931: /aa arg1 def
3932: /rr (1).. def
3933: /pp 0 def % isPolynomial array?
3934: 0 1 aa length 1 sub {
3935: /i set
3936: aa i get isPolynomial {
3937: /pp 1 def
3938: exit
3939: } { } ifelse
3940: } for
3941:
3942: 0 1 aa length 1 sub {
3943: /i set
3944: pp {
3945: [rr aa i get] polylcm /rr set
3946: } {
3947: [(lcm) rr aa i get ] mpzext /rr set
3948: } ifelse
3949: } for
3950:
3951: /arg1 rr def
3952: ] pop
3953: popVariables
3954: arg1
3955: } def
3956: [(gcd)
3957: [ ([a b c ...] gcd r)
3958: (cf. polygcd, mpzext)
3959: ]
3960: ] putUsages
3961: /gcd {
3962: /arg1 set
3963: [/aa /bb /rr /pp /i] pushVariables
3964: [
3965: /aa arg1 def
3966: /rr (1).. def
3967: /pp 0 def % isPolynomial array?
3968: 0 1 aa length 1 sub {
3969: /i set
3970: aa i get isPolynomial {
3971: /pp 1 def
3972: /rr aa i get def
3973: exit
3974: } { } ifelse
3975: } for
3976:
3977: pp {
3978: 0 1 aa length 1 sub {
3979: /i set
3980: [rr aa i get] polygcd /rr set
3981: } for
3982: } {
3983: aa ngcd /rr set
3984: } ifelse
3985:
3986: /arg1 rr def
3987: ] pop
3988: popVariables
3989: arg1
3990: } def
3991:
3992: [(denominator)
3993: [ ([a b c ...] denominator r)
3994: ( a denominator r )
3995: (cf. dc, numerator)
1.30 takayama 3996: (Output is Z or a polynomial.)
1.29 takayama 3997: ]
3998: ] putUsages
3999: % test data.
4000: % [(1).. (2).. div (1).. (3).. div ] denominator
4001: % [(2).. (3).. (4).. ] denominator
4002: /denominator {
4003: /arg1 set
4004: [/pp /dd /ii /rr] pushVariables
4005: [
4006: /pp arg1 def
1.30 takayama 4007: pp to_univNum /pp set
1.29 takayama 4008: {
4009: pp isArray {
4010: pp { denominator } map /dd set
4011: /rr dd lcm def % rr = lcm(dd[0], dd[1], ... )
4012: rr /dd set
4013: exit
4014: } { } ifelse
4015:
4016: pp (denominator) dc /dd set
4017: exit
4018:
4019: } loop
4020: /arg1 dd def
4021: ] pop
4022: popVariables
4023: arg1
4024: } def
4025:
4026: [(numerator)
4027: [ ([a b c ...] numerator r)
4028: ( a numerator r )
4029: (cf. dc, denominator)
1.30 takayama 4030: (Output is a list of Z or polynomials.)
1.29 takayama 4031: ]
4032: ] putUsages
4033: % test data.
4034: /numerator {
4035: /arg1 set
4036: [/pp /dd /ii /rr] pushVariables
4037: [
4038: /pp arg1 def
1.30 takayama 4039: pp to_univNum /pp set
1.29 takayama 4040: {
4041: pp isArray {
4042: pp denominator /dd set
4043: pp dd mul /rr set
1.30 takayama 4044: rr cancel /rr set
1.29 takayama 4045: exit
4046: } { } ifelse
4047:
4048: pp (numerator) dc /rr set
4049: exit
4050:
4051: } loop
4052: /arg1 rr def
4053: ] pop
4054: popVariables
4055: arg1
4056: } def
4057:
1.30 takayama 4058: /cancel.Q {
1.29 takayama 4059: /arg1 set
4060: [/aa /rr /nn /dd /gg] pushVariables
4061: [
4062: /aa arg1 def
4063: {
4064: aa isRational {
4065: [(cancel) aa] mpzext /rr set
4066: rr (denominator) dc (1).. eq {
4067: /rr rr (numerator) dc def
4068: exit
4069: } { } ifelse
4070: rr (denominator) dc (-1).. eq {
4071: /rr rr (numerator) dc (-1).. mul def
4072: } { } ifelse
4073: exit
4074: } { } ifelse
4075:
4076: /rr aa def
4077: exit
4078: } loop
4079: /arg1 rr def
4080: ] pop
4081: popVariables
4082: arg1
4083: } def
4084:
1.30 takayama 4085: /cancel.one {
1.29 takayama 4086: /arg1 set
4087: [/aa /rr /nn /dd /gg] pushVariables
4088: [
4089: /aa arg1 def
4090: {
4091: aa isRational {
4092: aa (numerator) dc /nn set
4093: aa (denominator) dc /dd set
4094: nn isUniversalNumber dd isUniversalNumber and {
1.30 takayama 4095: /rr aa cancel.Q def
1.29 takayama 4096: exit
1.30 takayama 4097: } { (cancel: not implemented) error } ifelse
1.29 takayama 4098: } { } ifelse
4099:
4100: /rr aa def
4101: exit
4102: } loop
4103: /arg1 rr def
4104: ] pop
4105: popVariables
4106: arg1
4107: } def
4108:
1.30 takayama 4109: [(cancel)
4110: [ (obj cancel r)
1.29 takayama 4111: (Cancel numerators and denominators)
4112: (The implementation has not yet been completed. It works only for Q.)
4113: ]] putUsages
1.30 takayama 4114: /cancel {
1.29 takayama 4115: /arg1 set
4116: [/aa /rr] pushVariables
4117: [
4118: /aa arg1 def
4119: aa isArray {
1.30 takayama 4120: aa {cancel} map /rr set
1.29 takayama 4121: } {
1.30 takayama 4122: aa cancel.one /rr set
1.29 takayama 4123: } ifelse
4124: /arg1 rr def
1.27 takayama 4125: ] pop
4126: popVariables
4127: arg1
1.22 takayama 4128: } def
1.30 takayama 4129:
4130: /nnormalize_vec {
4131: /arg1 set
4132: [/pp /rr /dd ] pushVariables
4133: [
4134: /pp arg1 def
4135: pp denominator /dd set
4136: dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
4137: pp numerator dd mul cancel /pp set
4138: /@@@.nnormalize_vec_c dd def
4139: pp gcd /dd set
4140: dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
4141: pp (1).. dd div mul cancel /rr set
4142: @@@.nnormalize_vec_c dd div cancel /@@@.nnormalize_vec_c set
4143: /arg1 rr def
4144: ] pop
4145: popVariables
4146: arg1
4147: } def
4148: [(nnormalize_vec)
4149: [(pp nnormalize_vec npp)
4150: (It normalizes a given vector of Q into a vector of Z with relatively prime)
4151: (entries by multiplying a postive number.)
4152: ]] putUsages
1.31 takayama 4153:
4154: /getNode {
4155: /arg2 set
4156: /arg1 set
1.43 takayama 4157: [/in-getNode /ob /key /rr /tt /ii] pushVariables
1.31 takayama 4158: [
4159: /ob arg1 def
4160: /key arg2 def
4161: /rr null def
4162: {
1.43 takayama 4163: ob isArray {
4164: ob length 1 gt {
4165: ob 0 get isString {
4166: ob 0 get , key eq {
4167: /rr ob 1 get def exit
4168: } { } ifelse
4169: } { } ifelse
4170: }{ } ifelse
4171: ob { key getNode , dup tag 0 eq {pop} { } ifelse } map /tt set
4172: tt length 0 gt { /rr tt 0 get def exit }
4173: {/rr null def exit } ifelse
4174: } { } ifelse
4175:
1.31 takayama 4176: ob isClass {
4177: ob (array) dc /ob set
1.43 takayama 4178: } { } ifelse
4179: ob isClass , ob isArray or { } { exit } ifelse
1.31 takayama 4180: ob 0 get key eq {
4181: /rr ob def
4182: exit
4183: } { } ifelse
4184: ob 2 get /ob set
4185: 0 1 ob length 1 sub {
4186: /ii set
4187: ob ii get key getNode /rr set
4188: rr tag 0 eq { } { exit } ifelse
4189: } for
4190: exit
4191: } loop
4192: /arg1 rr def
4193: ] pop
4194: popVariables
4195: arg1
4196: } def
4197: [(getNode)
1.43 takayama 4198: [(ob key getNode node-value)
4199: (ob is a class object or an array.)
1.31 takayama 4200: (The operator getNode returns the node with the key in ob.)
1.43 takayama 4201: (When ob is a class, the node is an array of the format [key attr-list node-list])
4202: (When ob is an array, the node is a value of key-value pairs.)
1.31 takayama 4203: (Example:)
4204: ( /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
4205: ( /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
4206: ( /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
4207: ( ma (dog) getNode )
1.43 takayama 4208: (Example 2:)
4209: ( [ [1 ] [2 3] [[(dog) 2]]] (dog) getNode ::)
1.31 takayama 4210: ]] putUsages
4211:
1.36 takayama 4212: /cons {
4213: /arg2 set /arg1 set
4214: [/aa /bb] pushVariables
4215: [
4216: /aa arg1 def /bb arg2 def
4217: [aa] (list) dc bb join /arg1 set
4218: ] pop
4219: popVariables
4220: arg1
4221: } def
4222: [(cons)
4223: [(obj list cons list)
4224: ]] putUsages
1.38 takayama 4225: /arrayToList {
4226: /arg1 set
4227: [/a /r] pushVariables
4228: [
4229: /a arg1 def
4230: {
4231: a isArray {
4232: a { arrayToList } map /a set
4233: a (list) dc /r set
4234: exit
4235: } { } ifelse
4236: /r a def
4237: exit
4238: } loop
4239: /arg1 r def
4240: ] pop
4241: popVariables
4242: arg1
4243: } def
4244: [(arrayToList)
4245: [(a arrayToList list)
4246: ]] putUsages
4247:
4248: /listToArray {
4249: /arg1 set
4250: [/a /r] pushVariables
4251: [
4252: /a arg1 def
4253: {
4254: a tag 12 eq {
4255: a (array) dc /a set
4256: a { listToArray } map /r set
4257: exit
4258: } { } ifelse
4259: a tag 0 eq {
4260: /r [ ] def
4261: exit
4262: } { } ifelse
4263: /r a def
4264: exit
4265: } loop
4266: /arg1 r def
4267: ] pop
4268: popVariables
4269: arg1
4270: } def
4271: [(listToArray)
4272: [(list listToArray a)
4273: ]] putUsages
4274:
1.44 takayama 4275: % Body is moved to smacro.sm1
1.39 takayama 4276: [(makeInfix)
4277: [(literal makeInfix)
4278: (Change literal to an infix operator.)
4279: (Example: /+ { add } def )
4280: ( /+ makeInfix)
4281: ( /s 0 def 1 1 100 { /i set s + i /s set } for s message)
4282: ( [ 1 2 3 ] { /i set i + 2 } map ::)
4283: ]] putUsages
1.22 takayama 4284:
1.24 takayama 4285: /usages {
4286: /arg1 set
1.40 takayama 4287: [/name /flag /n /k /slist /m /i /sss /key /ukeys] pushVariables
1.24 takayama 4288: [
4289: /name arg1 def
4290: /flag true def
1.40 takayama 4291: { % begin loop
4292:
4293: name isArray {
1.41 takayama 4294: /ukeys @.usages { 0 get } map shell def
1.40 takayama 4295: name { /key set [(regexec) key ukeys] extension
4296: { 0 get } map } map /sss set
4297: exit
4298: } { } ifelse
1.24 takayama 4299:
4300: name tag 1 eq {
4301: @.usages { 0 get } map shell { (, ) nl } map /sss set
1.40 takayama 4302: exit
1.24 takayama 4303: } {
4304:
4305: /sss [ ] def
4306: @.usages length /n set
4307: 0 1 << n 1 sub >>
4308: {
4309: /k set
4310: name << @.usages k get 0 get >> eq
4311: {
4312: /slist @.usages k get 1 get def
4313: /m slist length def
4314: 0 1 << m 1 sub >> {
4315: /i set
4316: sss slist i get append nl append /sss set
4317: } for
4318: /flag false def
4319: }
4320: { }
4321: ifelse
4322: } for
4323:
4324: %BUG: cannot get usages of primitives.
4325: flag
4326: {name Usage /sss [(Usage of ) name ( could not obtained.) nl ] def}
4327: { }
4328: ifelse
1.40 takayama 4329: exit
1.24 takayama 4330: } ifelse
1.40 takayama 4331:
4332: } loop
1.24 takayama 4333: /arg1 sss cat def
4334: ] pop
4335: popVariables
4336: arg1
4337: } def
4338: [(usages)
4339: [(key usages usages-as-a-string)
4340: (num usages list-of-key-words)
1.40 takayama 4341: ([key1 key2 ... ] usages list-of-key-words : it accepts regular expressions.)
1.42 takayama 4342: ]] putUsages
4343:
4344: /setMinus {
4345: /arg2 set /arg1 set
4346: [/aa /bb /i ] pushVariables
4347: [
4348: /aa arg1 def /bb arg2 def
4349: [
4350: 0 1 aa length 1 sub {
4351: /i set
4352: aa i get bb memberQ {
4353: } { aa i get } ifelse
4354: } for
4355: ] /arg1 set
4356: ] pop
4357: popVariables
4358: arg1
4359: } def
4360: [(setMinus)
4361: [(a b setMinus c)
1.24 takayama 4362: ]] putUsages
1.45 takayama 4363:
4364: % Define some infix operators
4365: /~add~ { add } def /~add~ makeInfix
4366: /~sub~ { sub } def /~sub~ makeInfix
4367: /~mul~ { mul } def /~mul~ makeInfix
4368: /~div~ { div } def /~div~ makeInfix
4369: /~power~ { power } def /~power~ makeInfix
4370: /~put~ {
4371: dup tag 3 eq { exec } { } ifelse put
4372: } def
4373: /~put~ makeInfix
4374:
1.1 maekawa 4375:
4376: ;
4377:
4378:
4379:
4380:
4381:
4382:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to dr.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Kan