Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.47
1.47 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.46 2004/09/17 00:47:08 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:
1.47 ! takayama 1531: [(isByteArray)
! 1532: [(obj isByteArray bool) ]
! 1533: ] putUsages
! 1534: /isByteArray {
! 1535: (type?) data_conversion ByteArrayP eq
! 1536: } def
! 1537:
1.1 maekawa 1538: /toString.tmp {
1539: /arg1 set
1540: [/obj /fname] pushVariables
1541: /obj arg1 def
1542: [
1543: obj isArray
1544: {
1545: obj {toString.tmp} map
1546: }
1547: { } ifelse
1548: obj isInteger
1549: {
1550: obj (dollar) data_conversion %% not string. It returns the ascii code.
1551: }
1552: { } ifelse
1553: obj isPolynomial
1554: {
1555: obj (string) data_conversion
1556: }
1557: { } ifelse
1558: obj isString
1559: { obj }
1560: { } ifelse
1561: obj isUniversalNumber
1562: { obj (string) data_conversion } { } ifelse
1563: obj isDouble
1564: { obj (string) data_conversion } { } ifelse
1565: obj isRational
1566: { obj (string) data_conversion } { } ifelse
1.47 ! takayama 1567: obj isByteArray
! 1568: { obj (array) data_conversion toString } { } ifelse
1.1 maekawa 1569: obj tag 0 eq
1570: { (null) } { } ifelse
1571:
1572: %%% New code that uses a file.
1573: obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
1574: { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
1575: [(outputObjectToFile) fname obj] extension pop
1576: fname pushfile
1577: [(/bin/rm -rf ) fname] cat system
1578: } { } ifelse
1579: ] /arg1 set
1580: popVariables
1581: arg1 aload pop
1582: } def
1583:
1584:
1585:
1586: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
1587: /toString.tmp2 {
1588: /arg1 set
1589: [/obj /i /n /r] pushVariables
1590: [
1591: /obj arg1 def
1592: obj isArray
1593: {
1.2 takayama 1594: [(LeftBracket)] system_variable %%( [ )
1.1 maekawa 1595: obj {toString.tmp2} map /r set
1596: /n r length 1 sub def
1597: [0 1 n {
1598: /i set
1599: i n eq {
1600: r i get
1601: }
1602: { r i get ( , ) 2 cat_n }
1603: ifelse
1604: } for
1605: ] aload length cat_n
1.2 takayama 1606: [(RightBracket)] system_variable %%( ] )
1.1 maekawa 1607: 3 cat_n
1608: }
1609: {
1610: obj
1611: } ifelse
1612: ] /arg1 set
1613: popVariables
1614: arg1 aload pop
1615: } def
1616:
1617:
1618: [(toString)
1619: [(obj toString)
1620: (Convert obj to a string.)
1621: (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ] ]$)
1622: ]
1623: ] putUsages
1624: /toString {
1625: /arg1 set
1626: [/obj ] pushVariables
1627: [
1628: /obj arg1 def
1629: obj isString
1630: { obj }
1631: { obj toString.tmp toString.tmp2 }
1632: ifelse /arg1 set
1633: ] pop
1634: popVariables
1635: arg1
1636: } def
1637:
1638: [(output)
1639: [(obj output) (Output the object to the standard file sm1out.txt)]
1640: ] putUsages
1641: /output {
1642: /arg1 set
1643: [/obj /fd ] pushVariables
1644: [
1645: /obj arg1 def
1646: (sm1out.txt) (a) file /fd set
1647: (Writing to sm1out.txt ...) messagen
1648: [ fd << obj toString >> writestring ] pop
1649: [ fd << 10 (string) data_conversion >> writestring ] pop
1650: ( Done.) message
1651: fd closefile
1652: ] pop
1653: popVariables
1654: } def
1655: %%%% end of macro for output.
1656: [(tag)
1657: [(obj tag integer)
1658: (tag returns datatype.)
1659: (cf. data_conversion)
1660: (Example: 2 tag IntegerP eq ---> 1)
1661: ]
1662: ] putUsages
1663: /etag {(type??) data_conversion} def
1664: [(etag)
1665: [(obj etag integer)
1666: (etag returns extended object tag. cf. kclass.c)
1667: ]
1668: ] putUsages
1669: /tag {(type?) data_conversion} def
1670: %% datatype constants
1671: /IntegerP 1 (type?) data_conversion def
1672: /LiteralP /arg1 (type?) data_conversion def %Sstring
1673: /StringP (?) (type?) data_conversion def %Sdollar
1674: /ExecutableArrayP { 1 } (type?) data_conversion def
1675: /ArrayP [ 0 ] (type?) data_conversion def
1676: /PolyP (1). (type?) data_conversion def
1677: /FileP 13 def
1678: /RingP 14 def
1679: /UniversalNumberP 15 def
1680: /RationalFunctionP 16 def
1681: /ClassP 17 def
1682: /DoubleP 18 def
1.47 ! takayama 1683: /ByteArrayP 19 def
1.1 maekawa 1684: /@.datatypeConstant.usage [
1685: (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
1.47 ! takayama 1686: (UniversalNumberP, RationalFunctionP, ClassP, DoubleP, ByteArrayP)
1.1 maekawa 1687: ( return data type identifiers.)
1688: (Example: 7 tag IntegerP eq ---> 1)
1689: ] def
1690: [(IntegerP) @.datatypeConstant.usage ] putUsages
1691: [(LiteralP) @.datatypeConstant.usage ] putUsages
1692: [(StringP) @.datatypeConstant.usage ] putUsages
1693: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
1694: [(ArrayP) @.datatypeConstant.usage ] putUsages
1695: [(PolyP) @.datatypeConstant.usage ] putUsages
1696: [(RingP) @.datatypeConstant.usage ] putUsages
1697: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
1698: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
1699: [(ClassP) @.datatypeConstant.usage ] putUsages
1700: [(DoubleP) @.datatypeConstant.usage ] putUsages
1.47 ! takayama 1701: [(ByteArrayP) @.datatypeConstant.usage ] putUsages
1.1 maekawa 1702:
1.37 takayama 1703: [(__)
1704: [( string ring __ polynomial)
1.1 maekawa 1705: (Parse the <<string>> as an element in the <<ring>> and returns)
1706: (the polynomial.)
1707: (cf. define_ring, define_qring, ring_def)
1708: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
1709: ( /myring set)
1.37 takayama 1710: ( ((x+y)^4) myring __ /f set)
1.1 maekawa 1711: ]] putUsages
1712:
1.37 takayama 1713: /__ {
1.1 maekawa 1714: /arg2 set /arg1 set
1715: [/rrr] pushVariables
1716: [ arg1 tag StringP eq
1717: arg2 tag RingP eq and
1718: { [(CurrentRingp)] system_variable /rrr set
1719: [(CurrentRingp) arg2] system_variable
1720: /arg1 arg1 expand def
1721: [(CurrentRingp) rrr] system_variable
1722: }
1.37 takayama 1723: {(Argument Error for __ ) error }
1.1 maekawa 1724: ifelse
1725: ] pop
1726: popVariables
1727: arg1
1728: } def
1729:
1730: [(..)
1731: [( string .. universalNumber)
1732: (Parse the << string >> as a universalNumber.)
1733: (Example: (123431232123123).. /n set)
1.46 takayama 1734: ({ commands }.. executes the commands. << .. >> is equivalent to exec.)
1.1 maekawa 1735: ]] putUsages
1.46 takayama 1736: /.. { dup tag 3 eq { exec } { (universalNumber) data_conversion} ifelse } def
1.1 maekawa 1737:
1738: [(dc)
1739: [(Abbreviation of data_conversion.)
1740: ]] putUsages
1741: /dc { data_conversion } def
1742:
1743:
1744: %%% start of shell sort macro.
1745: [(and) [(obj1 obj2 and bool)]] putUsages
1746: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
1747:
1748: [(or) [(obj1 obj2 or bool)]] putUsages
1749: /or { add 1 copy 2 eq {pop 1} { } ifelse} def
1750:
1751: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
1752: %% 2 copy is equivalent to dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1753: /ge { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1754: eq {pop pop 1}
1755: { gt {1}
1756: {0}
1757: ifelse}
1758: ifelse} def
1759:
1760: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
1761: /le { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1762: eq {pop pop 1}
1763: { lt {1}
1764: {0}
1765: ifelse}
1766: ifelse} def
1767:
1768: [(break)
1769: [(bool break)]
1770: ] putUsages
1771: /break { {exit} { } ifelse } def
1772:
1773: /not { 0 eq {1} {0} ifelse} def
1774: /append { /arg2 set [arg2] join } def
1775:
1776: [(power)
1777: [(obj1 obj2 power obj3)
1778: $obj3 is (obj1)^(obj2). cf. npower$
1779: $Example: (2). 8 power :: ===> 256 $
1780: ]
1781: ] putUsages
1782: %% From SSWork/yacc/incmac.sm1
1783: %% f k power f^k
1784: /power {
1785: /arg2 set
1786: /arg1 set
1787: [/f /k /i /ans] pushVariables
1788: [
1.26 takayama 1789: /ans (1).. def
1790: [(QuoteMode)] system_variable {
1791: /f arg1 def /k arg2 def
1792: [(ooPower) f k] extension /ans set
1793: } {
1.1 maekawa 1794: /f arg1 def /k arg2 ..int def
1795: k 0 lt {
1796: 1 1 << 0 k sub >> {
1797: /ans f ans {mul} sendmsg2 def
1798: } for
1799: /ans (1).. ans {div} sendmsg2 def
1800: }
1801: {
1802: 1 1 k {
1803: /ans f ans {mul} sendmsg2 def
1804: } for
1805: } ifelse
1.26 takayama 1806: } ifelse
1807: /arg1 ans def
1.1 maekawa 1808: ] pop
1809: popVariables
1810: arg1
1811: } def
1812: [(..int)
1813: [ (universalNumber ..int int)]] putUsages
1814: /..int { %% universal number to int
1815: (integer) data_conversion
1816: } def
1817: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
1818: /SmallRing [(CurrentRingp)] system_variable def
1819:
1820: %%% From SSWork/yacc/lib/printSVector.modified.sm1
1821: %%% supporting code for printSVector.
1822: /greaterThanOrEqual {
1823: /arg2 set /arg1 set
1824: arg1 arg2 gt { 1 }
1825: { arg1 arg2 eq {1} {0} ifelse} ifelse
1826: } def
1827:
1828: /lengthUniv {
1829: length (universalNumber) dc
1830: } def
1831:
1832: /getUniv {
1833: (integer) dc get
1834: } def %% Do not forget to thow away /.
1835:
1836: %%[(@@@.printSVector)
1837: %% [( vector @@@.printSVector outputs the <<vector>> in a pretty way.)
1838: %% ( The elements of the vector must be strings.)
1839: %% ]
1840: %%] putUsages
1841:
1842: %%% compiled code by d0, 1996, 8/17.
1843: /@@@.printSVector {
1844: /arg1 set
1845: [ %%start of local variables
1846: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
1847: /keys arg1 def
1848: /n
1849: keys lengthUniv
1850: def
1851: /max (0).. def
1852: /i (0).. def
1853: %%for init.
1854: %%for
1855: { i n lt
1856: { } {exit} ifelse
1857: [ {%%increment
1858: /i i (1).. add def
1859: } %%end of increment{A}
1860: {%%start of B part{B}
1861: keys i getUniv lengthUniv
1862: max gt
1863: %% if-condition
1864: { %%ifbody
1865: /max
1866: keys i getUniv lengthUniv
1867: def
1868: }%%end if if body
1869: { %%if- else part
1870: } ifelse
1871: } %% end of B part. {B}
1872: 2 1 roll] {exec} map
1873: } loop %%end of for
1874: /max max (3).. add
1875: def
1876: /width (80).. def
1877: /m (0).. def
1878:
1879: %%while
1880: { m max mul
1881: (80).. lt
1882: { } {exit} ifelse
1883: /m m (1).. add
1884: def
1885: } loop
1886: /k (0).. def
1887: /kk (0).. def
1888: /i (0).. def
1889: %%for init.
1890: %%for
1891: { i n lt
1892: { } {exit} ifelse
1893: [ {%%increment
1894: /i i (1).. add def
1895: } %%end of increment{A}
1896: {%%start of B part{B}
1897: keys i getUniv messagen
1898: /kk kk (1).. add
1899: def
1900: /k k
1901: keys i getUniv lengthUniv
1902: add
1903: def
1904: /tmp0 max
1905: keys i getUniv lengthUniv
1906: sub
1907: def
1908: /j (0).. def
1909: %%for init.
1910: %%for
1911: { j tmp0 lt
1912: { } {exit} ifelse
1913: [ {%%increment
1914: /j j (1).. add def
1915: } %%end of increment{A}
1916: {%%start of B part{B}
1917: /k k (1).. add
1918: def
1919: kk m lt
1920: %% if-condition
1921: { %%ifbody
1922: ( ) messagen
1923: }%%end if if body
1924: { %%if- else part
1925: } ifelse
1926: } %% end of B part. {B}
1927: 2 1 roll] {exec} map
1928: } loop %%end of for
1929: kk m greaterThanOrEqual
1930: %% if-condition
1931: { %%ifbody
1932: /kk (0).. def
1933: /k (0).. def
1934: newline
1935: }%%end if if body
1936: { %%if- else part
1937: } ifelse
1938: } %% end of B part. {B}
1939: 2 1 roll] {exec} map
1940: } loop %%end of for
1941: newline
1942: /ExitPoint ]pop popVariables %%pop the local variables
1943: } def
1944: %%end of function
1945:
1.35 takayama 1946: /rest {
1947: /arg1 set [(Krest) arg1] extension
1.1 maekawa 1948: } def
1949: [(rest)
1950: [(array rest the-rest-of-the-array)
1951: (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
1952: ]
1953: ] putUsages
1954:
1955: %% from SSkan/develop/minbase.sm1
1956: /reducedBase {
1957: /arg1 set
1958: [/base /minbase /n /i /j /myring /zero /f] pushVariables
1959: [
1960: /base arg1 def
1961: base isArray { }
1962: { (The argument of reducedBase must be an array of polynomials)
1963: error
1964: } ifelse
1965: base 0 get isPolynomial { }
1966: { (The element of the argument of reducedBase must be polynomials)
1967: error
1968: } ifelse
1969: /myring base 0 get (ring) dc def
1.37 takayama 1970: /zero (0) myring __ def
1.1 maekawa 1971: base length 1 sub /n set
1972: /minbase [ 0 1 n { /i set base i get } for ] def
1973: 0 1 n {
1974: /i set
1975: minbase i get /f set
1976: f zero eq {
1977: }
1978: {
1979: 0 1 n {
1980: /j set
1981: << minbase j get zero eq >> << i j eq >> or {
1982: }
1983: {
1984: [(isReducible) << minbase j get >> f] gbext
1985: {
1986: minbase j zero put
1987: }
1988: { } ifelse
1989: } ifelse
1990: } for
1991: } ifelse
1992: } for
1993: minbase { minbase.iszero } map /arg1 set
1994: ] pop
1995: popVariables
1996: arg1
1997: } def
1998:
1999: [(reducedBase)
2000: [(base reducedBase reducedBase)
2001: (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
2002: (returns <<reducedBase>>.)
2003: (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
2004: ]
2005: ] putUsages
2006:
2007: %% package functions
2008: /minbase.iszero {
2009: dup (0). eq {
2010: pop
2011: }
2012: { } ifelse
2013: } def
2014:
2015: /== {
2016: message
2017: } def
2018: [(==)
2019: [(obj ==)
2020: (Print obj)
2021: ]
2022: ] putUsages
2023:
2024: /@@@.all_variables {
2025: [/n /i] pushVariables
2026: [
2027: /n [(N)] system_variable def
2028: [
2029: 0 1 n 1 sub {
2030: /i set
2031: [(x) (var) i] system_variable
2032: } for
2033: 0 1 n 1 sub {
2034: /i set
2035: [(D) (var) i] system_variable
2036: } for
2037: ] /arg1 set
2038: ] pop
2039: popVariables
2040: arg1
2041: } def
2042:
2043: /weightv {
2044: @@@.all_variables
2045: 2 1 roll w_to_vec
2046: } def
2047:
2048: [(weightv)
2049: [(array weightv weight_vector_for_init)
2050: (cf. init)
2051: (Example: /w [(x) 10 (h) 2] weightv def)
2052: ( ((x-h)^10). w init ::)
2053: ]
2054: ] putUsages
2055:
2056: /output_order {
2057: /arg1 set
2058: [/vars /vlist /perm /total /ans] pushVariables
2059: [
2060: /vlist arg1 def
2061: /vars @@@.all_variables def
2062: vlist { vars 2 1 roll position } map /perm set
2063: perm ==
2064: /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
2065: perm perm total complement join /ans set
2066: [(outputOrder) ans] system_variable
2067: ] pop
2068: popVariables
2069: } def
2070:
2071: [(output_order)
2072: [$ [(v1) (v2) ...] output_order $
2073: (Set the order of variables to print for the current ring.)
2074: (cf. system_variable)
2075: (Example: [(y) (x)] output_order)
2076: $ (x*y). :: ===> y*x $
2077: ]
2078: ] putUsages
2079:
2080: %% destraction. SSkan/Kan/debug/des.sm1, 1998, 2/27 , 3/1
2081: %% should be included in dr.sm1
2082:
2083: /factorial {
2084: /arg2 set
2085: /arg1 set
2086: [ /f /n ] pushVariables
2087: [
2088: /f arg1 def
2089: /n arg2 def
2090: /ans (1).. def
2091: n 0 lt { (f n factorial : n must be a non-negative integer)
2092: error } { } ifelse
2093: 0 1 n 1 sub {
2094: (universalNumber) dc /i set
2095: ans << f i sub >> mul /ans set
2096: } for
2097: /arg1 ans def
2098: ] pop
2099: popVariables
2100: arg1
2101: } def
2102:
2103: [(factorial)
2104: [(f n factorial g)
2105: $integer n, g is f (f-1) ... (f-n+1)$
2106: ]
2107: ] putUsages
2108:
2109:
2110: /destraction1 {
2111: /arg4 set
2112: /arg3 set
2113: /arg2 set
2114: /arg1 set
2115: [/ww /f /dx /ss /xx /coeff0 /expvec
2116: /coeffvec /expvec2 /ans /one] pushVariables
2117: [
2118: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2119: /one (1). def %%
2120: /ww [ xx toString -1 dx toString 1 ] weightv def
2121: f ww init f sub (0). eq { }
2122: { [(destraction1 : inhomogeneous with respect to )
2123: xx ( and ) dx ] cat error } ifelse
2124: f [[xx one]] replace dx coefficients /coeff0 set
2125: /expvec coeff0 0 get { (integer) dc } map def
2126: /coeffvec coeff0 1 get def
2127: expvec { ss 2 -1 roll factorial } map /expvec2 set
2128: expvec2 coeffvec mul /ans set
2129: /arg1 ans def
2130: ] pop
2131: popVariables
2132: arg1
2133: } def
2134:
2135:
2136: /distraction {
2137: /arg4 set
2138: /arg3 set
2139: /arg2 set
2140: /arg1 set
2141: [/f /dx /ss /xx /ans /n /i] pushVariables
2142: [(CurrentRingp)] pushEnv
2143: [
2144: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2145: f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
2146: /n xx length def
2147: 0 1 n 1 sub {
2148: /i set
2149: /f f xx i get dx i get ss i get destraction1 /f set
2150: } for
2151: /dist1.L
2152: /arg1 f def
2153: ]pop
2154: popEnv
2155: popVariables
2156: arg1
2157: } def
2158: [(distraction)
2159: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2160: ( distraction result )
2161: $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
2162: ]
2163: ] putUsages
2164: /destraction { distraction } def
2165:
2166:
2167:
2168:
2169: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2170: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2171: %%%%%%%%%%%%%%%% sorting
2172: %/N 1000 def
2173: %/a.shell [N -1 0 { } for ] def
2174: %a.shell 0 -1000 put
2175: %% You need gate keeper.
2176: [(shell)
2177: [([gate-keeper f1 f2 ... fm] shell result)
2178: (Sort the list. Gate-keeper should be the smallest element)]
2179: ] putUsages
2180: /shell {
2181: /arg1 set
2182: [/N /a.shell /h /i /v /j] pushVariables
2183: [
2184: /a.shell arg1 def
2185: /N a.shell length 1 sub def
2186:
2187: /h 1 def
2188: {/h h 3 mul 1 add def
2189: << h N ge >> break
2190: } loop
2191: {
2192: /h << h 3 idiv >> def
2193: << h 1 add >> 1 N {
2194: /i set
2195: /v a.shell i get def
2196: /j i def
2197: {
2198: %% a.shell print newline
2199: << a.shell << j h sub >> get >> v le break
2200: a.shell j << a.shell << j h sub >> get >> put
2201: /j j h sub def
2202: j h le break
2203: } loop
2204: a.shell j v put
2205: } for
2206: h 1 lt break
2207: } loop
2208: /arg1 a.shell def
2209: ] pop
2210: popVariables
2211: arg1
2212: } def
2213: %%%% end of shell sort macro
2214:
2215: /variableNames {
2216: /arg1 set
2217: [/in-variableNames /rrr /nnn /i /cp] pushVariables
2218: [
2219: /rrr arg1 def
2220: [(CurrentRingp)] system_variable /cp set
2221: [(CurrentRingp) rrr] system_variable
2222: [(N)] system_variable /nnn set
2223: [ 0 1 nnn 1 sub {
2224: /i set [(x) (var) i] system_variable } for ]
2225: [ 0 1 nnn 1 sub {
2226: /i set [(D) (var) i] system_variable } for ]
2227: join /arg1 set
2228: [(CurrentRingp) cp] system_variable
2229: ] pop
2230: popVariables
2231: arg1
2232: } def
2233:
2234:
2235: /makeRingMap {
2236: /arg3 set /arg2 set /arg1 set
2237: [/in-makeRingMap /corres /M /N /corresM /corresN
2238: /vars /vars-org /i /p /ans /cp] pushVariables
2239: [
2240: /corres arg1 def /M arg2 def /N arg3 def
2241: /corresM corres 0 get def
2242: /corresN corres 1 get def
2243: [(CurrentRingp)] system_variable /cp set
2244: [(CurrentRingp) M] system_variable
2245: M variableNames /vars set vars 1 copy /vars-org set
2246: 0 1 corresM length 1 sub {
2247: /i set
2248: vars corresM i get position /p set
2249: p -1 gt {
2250: vars p $($ corresN i get $)$ 3 cat_n put
2251: } { } ifelse
2252: } for
2253: /arg1 [vars M N vars-org] def
2254: [(CurrentRingp) cp] system_variable
2255: ] pop
2256: popVariables
2257: arg1
2258: } def
2259:
2260:
2261:
2262: /ringmap {
2263: /arg2 set /arg1 set
2264: [/in-ringmap /f /M2N /cp /f2] pushVariables
2265: [
2266: /f arg1 def /M2N arg2 def
2267: [(CurrentRingp)] system_variable /cp set
2268: f (0). eq { /f2 f def }
2269: {
2270: %f (ring) dc M2N 1 get eq
2271: %{ }
2272: %{ (The argument polynomial does not belong to the domain ring.) message
2273: % error
2274: % } ifelse
2275: [(CurrentRingp) M2N 1 get] system_variable
2276: [(variableNames) M2N 0 get] system_variable
2277: f toString /f2 set
2278: [(variableNames) M2N 3 get] system_variable
1.37 takayama 2279: f2 M2N 2 get __ /f2 set
1.1 maekawa 2280: } ifelse
2281: [(CurrentRingp) cp] system_variable
2282: /arg1 f2 def
2283: ] pop
2284: popVariables
2285: arg1
2286: } def
2287:
2288: [(makeRingMap)
2289: [( rule ring1 ring2 makeRingMap maptable )
2290: (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
2291: ]
2292: ] putUsages
2293: [(ringmap)
2294: [(f mapTable ringmap r)
2295: (f is mapped to r where the map is defined by the mapTable, which is generated)
2296: (by makeRingMap as follows:)
2297: ( rule ring1 ring2 makeRingMap maptable )
2298: $Example:$
2299: $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2300: $/R1 set$
2301: $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2302: $/R2 set$
2303: $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
2304: $r0 R1 R2 makeRingMap /maptable set$
1.37 takayama 2305: $(Dx-1) R1 __ /ff set$
1.1 maekawa 2306: $ ff maptable ringmap :: $
2307: ]
2308: ] putUsages
2309:
2310:
2311: /getVariableNames {
2312: [/in-getVariableNames /ans /i /n] pushVariables
2313: [
2314: /n [(N)] system_variable def
2315: [
2316: n 1 sub -1 0 {
2317: /i set
2318: [(x) (var) i] system_variable
2319: } for
2320: n 1 sub -1 0{
2321: /i set
2322: [(D) (var) i] system_variable
2323: } for
2324: ] /arg1 set
2325: ] pop
2326: popVariables
2327: arg1
2328: } def
2329: [(getVariableNames)
2330: [(getVariableNames list-of-variables)
2331: (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
2332: ]
2333: ] putUsages
2334:
2335: /tolower {
2336: /arg1 set
2337: [/in-tolower /s /sl] pushVariables
2338: [
2339: /s arg1 def
2340: s (array) dc /s set
2341: s { tolower.aux (string) dc } map /sl set
2342: sl aload length cat_n /arg1 set
2343: ] pop
2344: popVariables
2345: arg1
2346: } def
2347:
2348: /tolower.aux {
2349: /arg1 set
1.9 takayama 2350: arg1 64 gt arg1 91 lt and
1.1 maekawa 2351: { arg1 32 add }
2352: { arg1 } ifelse
2353: } def
2354: [(tolower)
2355: [(string tolower string2)
2356: (Capital letters in string are converted to lower case letters.)
2357: $Example: (Hello World) tolower :: (hello world)$
2358: ]
2359: ] putUsages
2360:
2361: /hilbert {
2362: /arg2 set
2363: /arg1 set
2364: [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
2365: [
2366: /base arg1 def
2367: /vlist arg2 def
2368: [(CurrentRingp)] system_variable /rrrorg set
2369: /strf 0 def
2370: vlist isString
2371: { /vlist [ vlist to_records pop ] def }
2372: { } ifelse
2373: base isArray { }
2374: { (hilb : the first argument must be an array of polynomials.)
2375: error
2376: } ifelse
2377: vlist isArray { }
2378: { (hilb : the second argument must be an array of polynomials.)
2379: error
2380: } ifelse
2381:
2382: vlist 0 get isString{ /strf 1 def } { } ifelse
2383: base 0 get isPolynomial {
2384: base 0 get (ring) dc /rrr set
2385: }
2386: {
2387: [ vlist { (,) } map aload length cat_n ring_of_polynomials 0 ] define_ring
2388: /rrr set
2389: base { . } map /base set
2390: } ifelse
1.37 takayama 2391: vlist { dup isPolynomial { } { rrr __ } ifelse } map /vlist set
1.1 maekawa 2392:
2393: [(hilbert) base vlist] extension /ff set
2394: [(CurrentRingp) rrrorg] system_variable
2395: /arg1 ff def
2396: ] pop
2397: popVariables
2398: arg1
2399: } def
2400:
2401: /hilbReduce {
2402: /arg2 set
2403: /arg1 set
2404: [/hhh /f /d /vv /ans] pushVariables
2405: [
2406: /hhh arg1 def %% hilbert function
2407: /vv arg2 def
2408: /f hhh 1 get def
2409: f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
1.37 takayama 2410: f vv << f (ring) dc >> __ degree /vv set
1.1 maekawa 2411: hhh 0 get /d set
2412: d d (integer) dc factorial /d set
2413: d << vv (universalNumber) dc vv factorial >> idiv /d set
2414: [(divByN) f d] gbext /ans set
2415: ans 1 get (0). eq
2416: { }
2417: { (hilbReduce : Invalid hilbert function ) error } ifelse
2418: /hilbReduce.label
2419: ans 0 get /arg1 set
2420: ] pop
2421: popVariables
2422: arg1
2423: } def
2424:
2425:
2426: [(hilbReduce)
2427: [([f,g] v hilbReduce p)
2428: (output of hilbert [f,g]; string v; poly p)
2429: (p is (g/(f!))*deg(g)!)
2430: $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
2431: ]
2432: ] putUsages
2433: [(hilbert)
2434: [(base vlist hilbert [m f])
2435: (array of poly base; array of poly vlist; number m; poly f;)
2436: (array of string base; array of string vlist; number m; poly f;)
2437: (array of string base; string vlist; number m; poly f;)
2438: ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
2439: (The << base >> should be a reduced Grobner basis.)
2440: (Or, when the << base >> is an array of string,)
2441: (all entries should be monomials.)
2442: (Example: [(x^2) (x y )] (x,y) hilbert :: [2, 2 h + 4] )
2443: (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce :: 4)
2444: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce :: 3)
2445: (cf. hilb, hilbReduce)
2446: ]
2447: ] putUsages
2448:
2449: /hilb {
2450: hilbert (h) hilbReduce
2451: } def
2452: [(hilb)
2453: [(base vlist hilb f)
2454: (array of poly base; array of poly vlist; poly f;)
2455: (array of string base; array of string vlist; poly f;)
2456: (array of string base; string vlist; number m; poly f;)
2457: (f is the hilbert function (a_d x^d + ...)/m!)
2458: (The << base >> should be a reduced Grobner basis.)
2459: (Or, when the << base >> is an array of string,)
2460: (all entries should be monomials.)
2461: (Example: [(x^2) (x y )] (x,y) hilb :: h + 2 )
2462: (Example: [(x^2) (y^2)] (x,y) hilb 4)
2463: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb :: 3)
2464: (cf. hilbert, hilbReduce)
2465: ]
2466: ] putUsages
2467:
2468: [(diff0)
2469: [ (f v n diff0 fn)
2470: (<poly> fn, v ; <integer> n ; <poly> fn)
2471: (fn = v^n f where v^n is the operator to take the n-th differential.)
2472: (We can use diff0 only in the ring of differential operators.)
2473: (Example: [(x) ring_of_differential_operators 0] define_ring )
2474: ( (x^10-x). (Dx). 1 diff0 ::)
2475: ]
2476: ] putUsages
2477: /diff0 {
2478: /arg3 set /arg2 set /arg1 set
2479: [/in-diff /f /v /n /fn /rrr] pushVariables
2480: [
2481: /f arg1 def /v arg2 def /n arg3 def
2482: f (0). eq
2483: { /fn (0). def }
2484: {
2485: f (ring) dc /rrr set
1.37 takayama 2486: v toString (^) n toString 3 cat_n rrr __
1.1 maekawa 2487: f mul
1.37 takayama 2488: [[v (0).] [(h) rrr __ (1) rrr __]] replace /fn set
1.1 maekawa 2489: } ifelse
2490: fn /arg1 set
2491: ] pop
2492: popVariables
2493: arg1
2494: } def
2495:
2496: [(action)
2497: [( f g action p )
2498: (<poly> f,g,p)
2499: (Act f on g. The result is p. The homogenization variable h is put to 1.)
2500: (We can use diff0 only in the ring of differential operators.)
2501: (Example: [(x) ring_of_differential_operators 0] define_ring )
2502: ( (Dx^2). (x^2). action ::)
2503: ]
2504: ] putUsages
2505: /action {
2506: /arg2 set /arg1 set
2507: [/in-action /f /g /h /rr /rr.org /rule] pushVariables
2508: [
2509: /f arg1 def /g arg2 def
2510: /rr.org [(CurrentRingp)] system_variable def
2511: f (0). eq
2512: { /h (0). def }
2513: {
2514: f (ring) dc /rr set
2515: [(CurrentRingp) rr] system_variable
2516: f g mul /h set
2517: /rule getVariableNames def
2518: 0 1 rule length 2 idiv { rule rest /rule set } for
2519: rule { . [ 2 1 roll (0). ] } map /rule set
2520: rule << rule length 1 sub >> [(h). (1).] put
2521: %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
2522: /h h rule replace def
2523: } ifelse
2524: [(CurrentRingp) rr.org ] system_variable
2525: /arg1 h def
2526: ] pop
2527: popVariables
2528: arg1
2529: } def
2530:
2531: [(ord_w)
2532: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2533: (poly ff; string v1; integer w1; ...)
1.11 takayama 2534: (order of the initial of ff by the weight vector [w1 w2 ...])
1.1 maekawa 2535: (Example: [(x,y) ring_of_polynomials 0] define_ring )
2536: ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
2537: ]
2538: ] putUsages
2539: /ord_w {
2540: /arg2 set /arg1 set
2541: [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
2542: [
2543: /fff arg1 def
2544: /www arg2 def
1.33 takayama 2545: www to_int32 /www set
1.1 maekawa 2546: fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
2547: fff (ring) dc /rrr set
2548: fff init /fff set
2549: /ddd 0 def
2550: 0 2 www length 1 sub {
2551: /iii set
1.37 takayama 2552: fff << www iii get rrr __ >> degree
1.1 maekawa 2553: << www iii 1 add get >> mul
2554: ddd add /ddd set
2555: } for
1.12 takayama 2556: /ord_w.LLL
2557: /arg1 ddd def
2558: ] pop
2559: popVariables
2560: arg1
2561: } def
2562:
2563: [(ord_w_all)
2564: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2565: (poly ff; string v1; integer w1; ...)
2566: (order of ff by the weight vector [w1 w2 ...])
2567: (Example: [(x,y,t) ring_of_polynomials 0] define_ring )
2568: ( (x^2 y^3-x-t). [(t) 1 ] ord_w_all ::)
2569: ]
2570: ] putUsages
2571: /ord_w_all {
2572: /arg2 set /arg1 set
1.13 takayama 2573: [/ord_w_all-in /fff /fff-in /www /rrr /iii /ddd /zzz /ddd-tmp] pushVariables
1.12 takayama 2574: [
2575: /fff arg1 def
2576: /www arg2 def
1.33 takayama 2577: www to_int32 /www set
1.13 takayama 2578: fff (0). eq { /ddd -intInfinity def /ord_w_all.LLL goto} { } ifelse
2579: /ddd -intInfinity def
1.12 takayama 2580: fff (ring) dc /rrr set
1.37 takayama 2581: /zzz (0) rrr __ def
1.12 takayama 2582: fff init /fff-in set
2583: fff fff-in sub /fff set
2584: {
1.13 takayama 2585: /ddd-tmp 0 def
1.12 takayama 2586: 0 2 www length 1 sub {
2587: /iii set
1.37 takayama 2588: fff-in << www iii get rrr __ >> degree
1.12 takayama 2589: << www iii 1 add get >> mul
1.13 takayama 2590: ddd-tmp add /ddd-tmp set
1.12 takayama 2591: } for
1.13 takayama 2592: ddd-tmp ddd gt { /ddd ddd-tmp def } { } ifelse
1.12 takayama 2593: fff zzz eq { exit } { } ifelse
2594: fff init /fff-in set
2595: fff fff-in sub /fff set
2596: } loop
1.13 takayama 2597: /ord_w_all.LLL
1.1 maekawa 2598: /arg1 ddd def
2599: ] pop
2600: popVariables
2601: arg1
2602: } def
2603:
2604: [(laplace0)
2605: [
2606: (f [v1 ... vn] laplace0 g)
2607: (poly f ; string v1 ... vn ; poly g;)
2608: (array of poly f ; string v1 ... vn ; array of poly g;)
2609: ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
2610: $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
2611: $ x --> -Dx, Dx --> x, y --> -Dy, Dy --> y. $
2612: ]
2613: ] putUsages
2614: /laplace0 {
2615: /arg2 set /arg1 set
2616: [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
2617: ] pushVariables
2618: [
2619: /ff arg1 def /vv arg2 def
2620: /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
2621: /rule [ ] def
2622: ff isPolynomial {
2623: ff (0). eq { /ans1 (0). def }
2624: {
2625: ff (ring) dc /rr set
2626: /nn vv length def
2627: 0 1 nn 1 sub {
2628: /ii set
2629: vv ii get (type?) dc 1 eq
2630: { } % skip, may be weight [(x) 2 ] is OK.
2631: {
2632: /v0 vv ii get (string) dc def
2633: v0 (array) dc 0 get Dascii eq %% If the first character is D?
2634: { rule %% Dx-->x
1.37 takayama 2635: [v0 rr __
2636: v0 (array) dc rest { (string) dc} map aload length cat_n rr __]
1.1 maekawa 2637: append /rule set
2638: }
2639: { rule %% x --> -Dx
1.37 takayama 2640: [v0 rr __
1.1 maekawa 2641: (0).
2642: [Dascii] v0 (array) dc join { (string) dc } map aload length
1.37 takayama 2643: cat_n rr __ sub
1.1 maekawa 2644: ]
2645: append /rule set
2646: } ifelse
2647: } ifelse
2648: } for
2649: % rule message
1.37 takayama 2650: ff rule replace [[(h) rr __ (1) rr __]] replace /ans1 set
1.1 maekawa 2651: } ifelse
2652: }
2653: {
2654: ff isArray { /ans1 ff {vv laplace0 } map def }
2655: {
2656: (laplace0 : the first argument must be a polynomial.) error
2657: }ifelse
2658: } ifelse
2659: /arg1 ans1 def
2660: ] pop
2661: popVariables
2662: arg1
2663: } def
2664:
2665: [(ip1)
2666: [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
2667: (<poly> v1 ... vn ; <integer> w1 ... wn m)
2668: (<poly> f1 ... fs )
2669: (Example: [(x,y) ring_of_differential_operators 0] define_ring )
2670: ( [(Dx). (Dy).] [2 1] 3 ip1 :: [(2 Dx Dy). (Dy^3).])
2671: ( Returns Dx^p Dy^q such that 2 p + 1 q = 3.)
2672: ]
2673: ] putUsages
2674: /ip1 {
2675: /arg3 set /arg2 set /arg1 set
2676: [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
2677: [
2678: /vv arg1 def /ww arg2 def /m arg3 def
2679: vv 0 get (ring) dc /rr set
2680: /rr.org [(CurrentRingp)] system_variable def
2681: [(CurrentRingp) rr] system_variable
2682: [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
2683: /ans [ ] def
2684: m 0 lt
2685: { }
2686: {
2687: vv
2688: ww { tt 2 1 roll power } map mul /tmp1 set
2689: %% (tmp1 = ) messagen tmp1 message
2690: 0 1 m {
2691: /k set
2692: k 0 eq {
2693: /ff (1). def
2694: }
2695: { tmp1 k power /ff set } ifelse
2696: ff [[(h). (1).]] replace /ff set
2697: %% ff message
2698: {
2699: ff init tt degree m eq {
2700: /ans ans [ ff init [[tt (1).]] replace ] join def
2701: } { } ifelse
2702: ff ff init sub /ff set
2703: ff (0). eq { exit } { } ifelse
2704: } loop
2705: } for
2706: } ifelse
2707: [(CurrentRingp) rr.org] system_variable
2708: /arg1 ans def
2709: ] pop
2710: popVariables
2711: arg1
2712: } def
2713:
2714: [(findIntegralRoots)
2715: [( f findIntegralRoots vlist)
2716: (poly f; list of integers vlist;)
2717: (string f; list of integers vlist;)
2718: (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
2719: (Example: (s^4-1) findIntegralRoots )
2720: ]
2721: ] putUsages
2722:
2723: /findIntegralRoots { findIntegralRoots.slow } def
2724:
2725: /findIntegralRoots.slow { %% by a stupid algorithm
2726: /arg1 set
2727: [/in-findIntegralRoots
2728: /ff /kk /roots /rrr /nn /k0 /d.find
2729: ] pushVariables
2730: [
2731: /ff arg1 def
2732: /roots [ ] def
2733: /rrr [(CurrentRingp)] system_variable def
2734: ff toString /ff set
2735: [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
2736: ff . /ff set
2737:
2738: %%ff message %% Cancel the common numerical factor of the polynomial ff.
2739: ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
2740: [(divByN) ff d.find] gbext 0 get /ff set
2741: %% d.find message
2742: %% ff message
2743:
2744: ff [[(s). (0).]] replace /k0 set
2745: k0 (universalNumber) dc /k0 set
2746: k0 (0).. eq { roots (0).. append /roots set } { } ifelse
2747:
2748: {
2749: ff [[(s). (0).]] replace /nn set
2750: nn (universalNumber) dc /nn set
2751: nn (0).. eq
2752: { (s^(-1)). ff mul /ff set }
2753: { exit }
2754: ifelse
2755: } loop
2756: ff [[(s). (0).]] replace /k0 set
2757: k0 (universalNumber) dc /k0 set
2758: k0 (-40000).. gt k0 (40000).. lt and not {
2759: [(Roots of b-function cannot be obtained by a stupid method.) nl
2760: (Use ox_asir for efficient factorizations, or restall and bfm manually.)
2761: nl
2762: (ox_asir server will be distributed from the asir ftp cite.) nl
2763: (See lib/ttt.tex for details.) nl
2764: ] cat
2765: error
2766: } { } ifelse
2767: nn (0).. lt { (0).. nn sub /nn set } { } ifelse
2768: /kk (0).. nn sub def
2769: /roots [ kk (1).. sub ] roots join def
2770: {
2771: kk nn gt { exit } { } ifelse
2772: ff [[(s). kk (poly) dc]] replace
2773: (0). eq
2774: { /roots roots kk append def }
2775: { } ifelse
2776: kk (1).. add /kk set
2777: } loop
2778: [(CurrentRingp) rrr] system_variable
2779: roots { (integer) dc } map /roots set %% ?? OK?
2780: roots shell rest /roots set
2781: /arg1 roots def
2782: ] pop
2783: popVariables
2784: arg1
2785: } def
2786:
2787: /ngcd {
2788: /arg1 set
2789: [/in-ngcd /nlist /g.ngcd /ans] pushVariables
2790: [
2791: /nlist arg1 def
1.29 takayama 2792: nlist to_univNum /nlist set
1.1 maekawa 2793: nlist length 2 lt
2794: { /ans nlist 0 get def /L.ngcd goto }
2795: {
2796: [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
2797: g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
2798: [g.ngcd] nlist rest rest join ngcd /ans set
2799: } ifelse
2800: /L.ngcd
2801: ans /arg1 set
2802: ] pop
2803: popVariables
2804: arg1
2805: } def
2806:
2807: [(ngcd)
2808: [(nlist ngcd d )
2809: (list of numbers nlist; number d;)
2810: (d is the gcd of the numbers in nlist.)
2811: (Example: [(12345).. (67890).. (98765)..] ngcd )
2812: ]] putUsages
2813:
2814: /dehomogenize {
2815: /arg1 set
2816: [/in-dehomogenize /f /rr /ans /cring] pushVariables
2817: [
2818: /f arg1 def
2819: f isPolynomial {
2820: f (0). eq
2821: { f /ans set }
2822: {
2823: f (ring) dc /rr set
2824: [(CurrentRingp)] system_variable /cring set
2825: [(CurrentRingp) rr] system_variable
2826: f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
2827: [(CurrentRingp) cring] system_variable
2828: } ifelse
2829: }
2830: {
2831: f isArray {
2832: f { dehomogenize } map /ans set
2833: }
2834: {(dehomogenize: argument should be a polynomial.) error }
2835: ifelse
2836: } ifelse
2837: /arg1 ans def
2838: ] pop
2839: popVariables
2840: arg1
2841: } def
2842:
2843: [(dehomogenize)
2844: [(obj dehomogenize obj2)
2845: (dehomogenize puts the homogenization variable to 1.)
2846: (Example: (x*h+h^2). dehomogenize :: x+1 )
2847: ]
2848: ] putUsages
2849:
2850:
2851: /from_records { { (,) } map aload length cat_n } def
2852: [(from_records)
2853: [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
2854: (Example : [(x) (y)] from_records :: (x,y,))
2855: (cf. to_records)
2856: ]
2857: ] putUsages
2858: /popEnv {
2859: { system_variable pop } map pop
2860: } def
2861:
2862: /pushEnv {
2863: %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
2864: { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
2865: } def
2866: [(pushEnv)
2867: [(keylist pushEnv envlist)
2868: (array of string keylist, array of [string object] envlist;)
2869: (Values <<envlist>> of the global system variables specified )
2870: (by the <<keylist>> is push on the stack.)
2871: (keylist is an array of keywords for system_variable.)
2872: (cf. system_variable, popEnv)
2873: (Example: [(CurrentRingp) (KanGBmessage)] pushEnv)
2874: ]
2875: ] putUsages
2876: [(popEnv)
2877: [(envlist popEnv)
2878: (cf. pushEnv)
2879: ]
2880: ] putUsages
2881:
2882: /npower {
2883: /arg2 set
2884: /arg1 set
2885: [/f /k /i /ans] pushVariables
2886: [
2887: /f arg1 def /k arg2 ..int def
2888: f tag PolyP eq {
2889: /ans (1). def
2890: } {
2891: /ans (1).. def
2892: } ifelse
2893: k 0 lt {
2894: 1 1 << 0 k sub >> {
2895: /ans f ans {mul} sendmsg2 def
2896: } for
2897: /ans (1).. ans {div} sendmsg2 def
2898: }
2899: {
2900: 1 1 k {
2901: /ans f ans {mul} sendmsg2 def
2902: } for
2903: } ifelse
2904: /arg1 ans def
2905: ] pop
2906: popVariables
2907: arg1
2908: } def
2909: [(npower)
2910: [(obj1 obj2 npower obj3)
2911: (npower returns obj1^obj2 as obj3)
2912: (The difference between power and npower occurs when we compute f^0)
2913: (where f is a polynomial.)
2914: $power returns number(universalNumber) 1, but npower returns 1$
2915: (in the current ring.)
2916: ]
2917: ] putUsages
2918:
2919: /gensym {
2920: (dollar) dc 2 cat_n
2921: } def
2922: [(gensym)
2923: [(x i gensym xi)
2924: (string x; integer i; string xi)
2925: (It generate a string x indexed with the number i.)
2926: $Example: (Dx) 12 gensym (Dx12)$
2927: ]
2928: ] putUsages
2929:
2930: /cat {
2931: { toString } map aload length cat_n
2932: } def
2933: [(cat)
2934: [(a cat s)
2935: (array a ; string s;)
2936: (cat converts each entry of << a >> to a string and concatenates them.)
2937: (Example: [ (x) 1 2] cat ==> (x12))
2938: ]
2939: ] putUsages
2940:
2941:
2942: %%%%%%%%%%%%%%%%%%% pmat-level
2943: /pmat-level {
2944: /arg2 set
2945: /arg1 set
2946: [/n /i /m /lev /flag] pushVariables
2947: [
2948: /m arg1 def
2949: /lev arg2 def
2950: m isArray {
2951: /n m length def
2952: n 0 eq { /flag 0 def }
2953: { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
2954: } { /flag 0 def } ifelse
2955:
2956: flag {
2957: 0 1 lev {
2958: pop ( ) messagen
2959: } for
2960: ([ ) message
2961: 0 1 n 1 sub {
2962: /i set
2963: m i get lev 1 add pmat-level
2964: } for
2965: 0 1 lev {
2966: pop ( ) messagen
2967: } for
2968: (]) message
2969: }
2970: {
2971: 0 1 lev {
2972: pop ( ) messagen
2973: } for
2974: ( ) messagen
2975: m message
2976: } ifelse
2977: ] pop
2978: popVariables
2979: } def
2980:
2981: /pmat { 0 pmat-level } def
2982:
2983: [(pmat)
2984: [(f pmat)
2985: (array f;)
2986: (f is pretty printed.)
2987: ]
2988: ] putUsages
2989:
2990:
2991: /adjoint1 {
2992: /arg2 set
2993: /arg1 set
2994: [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
2995: [
2996: /f arg1 def
2997: /xx arg2 def
2998: f isPolynomial { }
2999: { (adjoint1: the first argument must be a polynomial.) message
3000: pop popVariables
3001: (adjoint1: the first argument must be a polynomial.) error
3002: } ifelse
3003: /ans (0). def
3004: f (0). eq { }
3005: {
3006: /xx xx (string) dc def
3007: /dxx [@@@.Dsymbol xx] cat def
1.37 takayama 3008: /xx xx f (ring) dc __ def
3009: /dxx dxx f (ring) dc __ def
3010: /one (1) f (ring) dc __ def
1.1 maekawa 3011:
3012: {
3013: /g f init def
3014: /f f g sub def
3015: /p g xx degree def
3016: /q g dxx degree def
3017: g [[xx one] [dxx one]] replace /g set
3018: g
3019: << (0). dxx sub q npower xx p npower mul >>
3020: mul
3021: ans add /ans set
3022: f (0). eq { exit } { } ifelse
3023: } loop
3024: ans dehomogenize /ans set
3025: } ifelse
3026: /arg1 ans def
3027: ] pop
3028: popVariables
3029: arg1
3030: } def
3031:
3032: /adjoint {
3033: /arg2 set
3034: /arg1 set
3035: [/in-adjoint /f /xx /xx0] pushVariables
3036: [
3037: /f arg1 def /xx arg2 def
3038: xx toString /xx set
3039: [xx to_records pop] /xx set
3040: xx { /xx0 set f xx0 adjoint1 /f set } map
3041: /arg1 f def
3042: ]pop
3043: popVariables
3044: arg1
3045: } def
3046:
3047: [(adjoint)
3048: [(f xlist adjoint g)
3049: (poly f; string xlist; poly g;)
3050: (g is the adjoint operator of f.)
3051: (The variables to take adjoint are specified by xlist.)
3052: (Example: [(x,y) ring_of_differential_operators 0] define_ring)
3053: ( (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
3054: $ ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
3055: ]] putUsages
3056:
3057: %%%%% diagonal for tensor products
3058: %% 1998, 12/4 (Sat)
3059: %% s_i = x_i, t_i = x_i - y_i, Restrict to t_i = 0.
3060: %% x_i = x_i, y_i = s_i - t_i,
3061: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
3062: /diagonalx {
3063: /arg2 set
3064: /arg1 set
3065: [/in-diagonalx /f] pushVariables
3066: [
3067: (Not implemented yet.) message
3068: ] pop
3069: popVariables
3070: arg1
3071: } def
3072:
3073:
3074:
3075: %%%%%%%%%%% distraction2 for b-function
3076: /distraction2 {
3077: /arg4 set
3078: /arg3 set
3079: /arg2 set
3080: /arg1 set
3081: [/f /dx /ss /xx /ans /n /i /rr] pushVariables
3082: [
3083: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3084: f (0). eq { }
3085: {
3086: /rr f (ring) dc def
1.37 takayama 3087: xx {toString rr __ } map /xx set
3088: dx {toString rr __ } map /dx set
3089: ss {toString rr __ } map /ss set
1.1 maekawa 3090: /n xx length def
3091: 0 1 n 1 sub {
3092: /i set
3093: /f f xx i get dx i get ss i get destraction2.1 /f set
3094: } for
3095: } ifelse
3096: /arg1 f def
3097: ]pop
3098: popVariables
3099: arg1
3100: } def
3101: [(distraction2)
3102: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
3103: ( distraction2 result )
3104: $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
3105: $ (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
3106: $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
3107: ]
3108: ] putUsages
3109: /destraction2.1 {
3110: /arg4 set
3111: /arg3 set
3112: /arg2 set
3113: /arg1 set
3114: [/ww /f /dx /ss /xx /coeff0 /expvec
3115: /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
3116: [
3117: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3118: f (ring) dc /rr set
1.37 takayama 3119: /one (1) rr __ def %%
1.1 maekawa 3120: /ww [ xx toString -1 dx toString 1 ] weightv def
3121: f ww init f sub (0). eq { }
3122: { [(destraction2.1 : inhomogeneous with respect to )
3123: xx ( and ) dx nl
3124: (Your weight vector may not be generic.)
3125: ] cat error } ifelse
3126: /dd << f dx degree >> << f xx degree >> sub def
3127: f [[xx one]] replace dx coefficients /coeff0 set
3128: /expvec coeff0 0 get { (integer) dc } map def
3129: /coeffvec coeff0 1 get def
3130: expvec { ss 2 -1 roll factorial } map /expvec2 set
3131: expvec2 coeffvec mul /ans set
3132: %% x^p d^q, (p > q) case. x^2( x^2 Dx^2 + x Dx + 1)
3133: dd 0 lt {
3134: %% (ss+1) (ss+2) ... (ss+d)
3135: one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
3136: ans mul /ans set
3137: }
3138: { } ifelse
3139: /arg1 ans def
3140: ] pop
3141: popVariables
3142: arg1
1.3 takayama 3143: } def
3144:
3145: /distraction2* {
3146: /arg1 set
3147: [/in-distraction2* /aa /f /vlist /xlist /dlist /slist ] pushVariables
3148: [(CurrentRingp)] pushEnv
3149: [
3150: /aa arg1 def
3151: /f aa 0 get def
3152: /vlist aa 1 get def
3153: /xlist aa 2 get def
3154: /dlist aa 3 get def
3155: /slist aa 4 get def
3156: vlist isArray
3157: {
3158: vlist { toString } map /vlist set
3159: }
3160: {
3161: vlist toString to_records /vlist set
3162: } ifelse
3163: xlist isArray
3164: {
3165: xlist { toString } map /xlist set
3166: }
3167: {
3168: xlist toString to_records /xlist set
3169: } ifelse
3170: slist isArray
3171: {
3172: slist { toString } map /slist set
3173: }
3174: {
3175: slist toString to_records /slist set
3176: } ifelse
3177: [vlist from_records ring_of_differential_operators 0] define_ring pop
3178: f toString .
3179: xlist { . } map
3180: dlist { toString . } map
3181: slist { toString . } map
3182: distraction2 /arg1 set
3183: ] pop
3184: popEnv
3185: popVariables
3186: arg1
1.1 maekawa 3187: } def
3188:
3189: /message-quiet {
3190: @@@.quiet { pop } { message } ifelse
3191: } def
3192: [(message-quiet)
3193: [(s message-quiet )
3194: (string s;)
3195: (It outputs the message s when @@@.quiet is not equal to 1.)
3196: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3197: ]] putUsages
3198: /messagen-quiet {
3199: @@@.quiet { pop } { messagen } ifelse
3200: } def
3201: [(messagen-quiet)
3202: [(s messagen-quiet )
3203: (string s;)
3204: (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
3205: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3206: ]] putUsages
3207:
3208: /getvNames0 {
3209: /arg1 set
3210: [/in-getvNames0 /nlist /nn /i] pushVariables
3211: [
3212: /nlist arg1 def
3213: [(N)] system_variable /nn set
3214: nlist { /i set
3215: i nn lt {
3216: [(x) (var) i] system_variable
3217: } {
3218: [(D) (var) i nn sub] system_variable
3219: } ifelse
3220: } map
3221: /arg1 set
3222: ] pop
3223: popVariables
3224: arg1
3225: } def
3226:
3227: /getvNames {
3228: [/in-getvNames /nn] pushVariables
3229: [
3230: [(N)] system_variable /nn set
3231: [0 1 nn 2 mul 1 sub { } for] getvNames0 /arg1 set
3232: ] pop
3233: popVariables
3234: arg1
3235: } def
3236: [(getvNames)
3237: [(getvNames vlist)
3238: (list vlist)
3239: (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
3240: (Use with [(variableNames) vlist] system_variable.)
3241: (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
3242: ]] putUsages
3243:
3244: /getvNamesC {
3245: [/in-getvNamesC /nn /i] pushVariables
3246: [
3247: [(N)] system_variable /nn set
3248: [nn 1 sub -1 0 { } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
3249: ] pop
3250: popVariables
3251: arg1
3252: } def
3253: [(getvNamesC)
3254: [(getvNamesC vlist)
3255: (list vlist)
3256: $It returns of the list of the variables in the order 0, 1, 2, ... $
3257: $(cmo-order and output_order).$
3258: (cf. getvNames)
3259: ]] putUsages
3260:
3261: /getvNamesCR {
3262: /arg1 set
3263: [/in-getvNamesCR /rrr] pushVariables
3264: [(CurrentRingp)] pushEnv
3265: [
3266: /rrr arg1 def
3267: rrr isPolynomial {
3268: rrr (0). eq { (No name field for 0 polynomial.) error }
3269: { rrr (ring) dc /rrr set } ifelse
3270: } { } ifelse
3271: [(CurrentRingp) rrr] system_variable
3272: getvNamesC /arg1 set
3273: ] pop
3274: popEnv
3275: popVariables
3276: arg1
3277: } def
3278: [(getvNamesCR)
3279: [(obj getvNamesCR vlist)
3280: (obj ring | poly ; list vlist)
3281: $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
3282: (for <<obj>>.)
3283: (Example: ( (x-2)^3 ). /ff set )
3284: ( [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
3285: ]] putUsages
3286:
3287:
3288: /reduction-noH {
3289: /arg2 set
3290: /arg1 set
3291: [/in-reduction-noH /ff /gg] pushVariables
3292: [(Homogenize)] pushEnv
3293: [
3294: /ff arg1 def
3295: /gg arg2 def
3296: [(Homogenize) 0] system_variable
3297: ff gg reduction /arg1 set
3298: ] pop
3299: popEnv
3300: popVariables
3301: arg1
3302: } def
3303: [(reduction-noH)
3304: [(f g reduction-noH r)
3305: (poly f; array g; array r;)
3306: (Apply the normal form algorithm for f with the set g. All computations are)
3307: (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
3308: (specifications are the same with reduction. cf. reduction)
3309: (g should be dehomogenized.)
3310: ]] putUsages
3311:
3312: /-intInfinity -999999999 def
3313: /intInfinity 999999999 def
3314: [(intInfinity)
3315: [(intInfinity = 999999999)]
3316: ] putUsages
3317: [(-intInfinity)
3318: [(-intInfinity = -999999999)]
3319: ] putUsages
3320:
3321:
3322: /maxInArray {
3323: /arg1 set
3324: [/in-maxInArray /v /ans /i /n] pushVariables
3325: [
3326: /v arg1 def
3327: /n v length def
3328: /maxInArray.pos 0 def
3329: n 0 eq {
3330: /ans null def
3331: } {
3332: /ans v 0 get def
3333: 1 1 n 1 sub {
3334: /i set
3335: v i get ans gt {
3336: /ans v i get def
3337: /maxInArray.pos i def
3338: } { } ifelse
3339: } for
3340: } ifelse
3341: /arg1 ans def
3342: ] pop
3343: popVariables
3344: arg1
3345: } def
3346: [(maxInArray)
3347: [( [v1 v2 ....] maxInArray m )
3348: (m is the maximum in [v1 v2 ...].)
3349: (The position of m is stored in the global variable maxInArray.pos.)
3350: ]] putUsages
3351:
3352: /cancelCoeff {
1.18 takayama 3353: /arg1 set
3354: [(reduceContent) arg1] gbext 0 get
3355: } def
3356: /cancelCoeff_org {
1.1 maekawa 3357: /arg1 set
3358: [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
3359: [ /ff arg1 def
3360: ff (0). eq {
3361: /label.cancelCoeff2 goto
3362: } { } ifelse
3363: /gg ff def
3364: /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
3365: {
3366: gg (0). eq { exit} { } ifelse
3367: [(lcoeff) gg init] gbext (universalNumber) dc /dd2 set
3368: [(gcd) dd dd2] mpzext /dd set
3369: dd (1).. eq {
3370: /label.cancelCoeff goto
3371: } { } ifelse
3372: /gg gg gg init sub def
3373: } loop
3374: [(divByN) ff dd] gbext 0 get /ff set
3375: /label.cancelCoeff
3376: [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
3377: { ff (-1).. mul /ff set } { } ifelse
3378: /label.cancelCoeff2
3379: /arg1 ff def
3380: ] pop
3381: popVariables
3382: arg1
3383: } def
3384: [(cancelCoeff)
3385: [(f cancelcoeff g)
3386: (poly f,g;)
3387: (Factor out the gcd of the coefficients.)
3388: (Example: (6 x^2 - 10 x). cancelCoeff)
3389: (See also gbext.)
3390: ]] putUsages
3391:
3392:
3393: /flatten {
3394: /arg1 set
3395: [/in-flatten /mylist] pushVariables
3396: [
3397: /mylist arg1 def
3398: mylist isArray {
3399: mylist { dup isArray { aload pop } { } ifelse } map /mylist set
3400: }{ } ifelse
3401: /arg1 mylist def
3402: ] pop
3403: popVariables
3404: arg1
3405: } def
3406: [(flatten)
3407: [(list flatten list2)
3408: (Flatten the list.)
3409: (Example 1: [ [1 2 3] 4 [2]] flatten ===> [1 2 3 4 2])
3410: ]] putUsages
3411:
3412: %% Take first N elements.
3413: /carN {
3414: /arg2 set
3415: /arg1 set
3416: [/in-res-getN /pp /nn /ans] pushVariables
3417: [
3418: /nn arg2 def
3419: /pp arg1 def
3420: pp isArray {
3421: pp length nn lt {
3422: /ans pp def
3423: } {
3424: [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
3425: } ifelse
3426: } {
3427: /ans pp def
3428: } ifelse
3429: /arg1 ans def
3430: ] pop
3431: popVariables
3432: arg1
3433: } def
3434: [(carN)
3435: [([f1 ... fm] n carN [f1 ... fn])
3436: (carN extracts the first n elements from the list.)
3437: ]] putUsages
3438:
3439: /getRing {
3440: /arg1 set
3441: [/in-getRing /aa /n /i /ans] pushVariables
3442: [
3443: /aa arg1 def
3444: /ans null def
3445: aa isPolynomial {
3446: aa (0). eq {
3447: } {
3448: /ans aa (ring) dc def
3449: } ifelse
3450: } {
3451: aa isArray {
3452: /n aa length 1 sub def
3453: 0 1 n { /i set aa i get getRing /ans set
3454: ans tag 0 eq { } { /getRing.LLL goto } ifelse
3455: } for
3456: }{ } ifelse
3457: } ifelse
3458: /getRing.LLL
3459: /arg1 ans def
3460: ] pop
3461: popVariables
3462: arg1
3463: } def
3464: [(getRing)
3465: [(obj getRing rr)
3466: (ring rr;)
3467: (getRing obtains the ring structure from obj.)
3468: (If obj is a polynomial, it returns the ring structure associated to)
3469: (the polynomial.)
3470: (If obj is an array, it recursively looks for the ring structure.)
3471: ]] putUsages
3472: /toVectors {
3473: /arg1 set
3474: [/in-toVectors /gg /n /ans] pushVariables
3475: [
3476: /gg arg1 def
3477: gg isArray {
3478: gg length 0 eq {
3479: /ans [ ] def
3480: /toVectors.LLL goto
3481: } {
3482: gg 0 get isInteger {
3483: gg @@@.toVectors2 /ans set
3484: } {
3485: gg @@@.toVectors /ans set
3486: } ifelse
3487: /toVectors.LLL goto
3488: } ifelse
3489: } {
3490: %% It is not array.
3491: gg (array) dc /ans set
3492: } ifelse
3493: /toVectors.LLL
3494: /arg1 ans def
3495: ] pop
3496: popVariables
3497: arg1
3498: } def
3499: /@@@.toVectors2 {
3500: /arg1 set
3501: [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
3502: [
3503: /gg arg1 def
3504: /ans gg 1 get @@@.toVectors def
3505: /n gg 0 get def
3506: gg 1 get isArray not {
3507: /ans [ans] def
3508: /notarray 1 def
3509: }{ /notarray 0 def} ifelse
3510: ans {
3511: /tmp set
3512: tmp length n lt {
3513: tmp
3514: [1 1 n tmp length sub { pop (0). } for ]
3515: join /tmp set
3516: } { } ifelse
3517: tmp
3518: } map
3519: /ans set
3520: notarray { ans 0 get /ans set } { } ifelse
3521: /arg1 ans def
3522: ] pop
3523: popVariables
3524: arg1
3525: } def
3526:
3527: /@@@.toVectors {
3528: /arg1 set
3529: [/in-@@@.toVectors /gg ] pushVariables
3530: [
3531: /gg arg1 def
3532: gg isArray {
3533: gg { $array$ data_conversion } map
3534: } {
3535: gg (array) data_conversion
3536: }ifelse
3537: /arg1 set
3538: ] pop
3539: popVariables
3540: arg1
3541: } def
3542:
3543: /toVectors2 { toVectors } def
3544:
3545: /fromVectors { { fromVectors.aux } map } def
3546: /fromVectors.aux {
3547: /arg1 set
3548: [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
3549: [(CurrentRingp)] pushEnv
3550: [
3551: /vv arg1 def
3552: /mm vv length def
3553: /ans (0). def
3554: /ee (0). def
3555: 0 1 mm 1 sub {
3556: /i set
3557: vv i get (0). eq {
3558: } {
3559: [(CurrentRingp) vv i get (ring) dc] system_variable
3560: [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
3561: /fromVector.LLL goto
3562: } ifelse
3563: } for
3564: /fromVector.LLL
3565: %% vv message
3566: 0 1 mm 1 sub {
3567: /i set
3568: vv i get (0). eq {
3569: } {
3570: /ans ans
3571: << vv i get >> << ee i npower >> mul
3572: add def
3573: } ifelse
3574: %% [i ans] message
3575: } for
3576: /arg1 ans def
3577: ] pop
3578: popEnv
3579: popVariables
3580: arg1
3581: } def
3582: [(fromVectors)
3583: [
3584: ([v1 v2 ...] fromVectors [s1 s2 ...])
3585: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
3586: (cf. toVectors. <<e_>> varaible is assumed to be the last )
3587: ( variable in x. @@@.esymbol)
3588: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
3589: $ [(x). (y).] /ff set $
3590: $ [ff ff] fromVectors :: $
3591: ]] putUsages
3592:
3593: /getOrderMatrix {
3594: /arg1 set
3595: [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
3596: [(CurrentRingp)] pushEnv
3597: [
3598: /obj arg1 def
3599: obj isArray {
3600: obj { getOrderMatrix } map /ans set
3601: ans length 0 {
3602: /ans null def
3603: } {
3604: /ans2 null def
3605: 0 1 ans length 1 sub {
3606: /i set
3607: ans i get tag 0 eq
3608: { }
3609: { /ans2 ans i get def } ifelse
3610: } for
3611: /ans ans2 def
3612: } ifelse
3613: /getOrderMatrix.LLL goto
3614: } { } ifelse
3615: obj tag 14 eq {
3616: [(CurrentRingp) obj] system_variable
3617: [(orderMatrix)] system_variable /ans set
3618: /getOrderMatrix.LLL goto
3619: } { } ifelse
3620: obj isPolynomial {
3621: obj (0). eq
3622: { /ans null def
3623: } { obj getRing /rr set
3624: [(CurrentRingp) rr] system_variable
3625: [(orderMatrix)] system_variable /ans set
3626: } ifelse
3627: /getOrderMatrix.LLL goto
3628: } { (getOrderMatrix: wrong argument.) error } ifelse
3629: /getOrderMatrix.LLL
3630: /arg1 ans def
3631: ] pop
3632: popEnv
3633: popVariables
3634: arg1
3635: } def
3636:
3637:
3638: [(getOrderMatrix)
3639: [(obj getOrderMatrix m)
3640: (array m)
3641: (getOrderMatrix obtains the order matrix from obj.)
3642: (If obj is a polynomial, it returns the order matrix associated to)
3643: (the polynomial.)
3644: (If obj is an array, it returns an order matrix of an element.)
3645: ]] putUsages
3646:
3647: /nl {
3648: 10 $string$ data_conversion
3649: } def
3650: [(nl)
3651: [(nl is the newline character.)
3652: $Example: [(You can break line) nl (here.)] cat message$
1.4 takayama 3653: ]] putUsages
3654:
3655: /to_int {
3656: /arg1 set
3657: [/to-int /ob /ans] pushVariables
3658: [
3659: /ob arg1 def
3660: /ans ob def
3661: ob isArray {
3662: ob {to_int} map /ans set
3663: /LLL.to_int goto
3664: } { } ifelse
3665: ob isInteger {
3666: ob (universalNumber) dc /ans set
3667: /LLL.to_int goto
3668: } { } ifelse
3669: /LLL.to_int
3670: /arg1 ans def
3671: ] pop
3672: popVariables
3673: arg1
3674: } def
3675: [(to_int)
3676: [(obj to_int obj2)
3677: (All integers in obj are changed to universalNumber.)
3678: (Example: /ff [1 2 [(hello) (0).]] def ff { tag } map ::)
3679: ( ff to_int { tag } map :: )
1.5 takayama 3680: ]] putUsages
3681:
1.33 takayama 3682: /to_int32 {
3683: /arg1 set
3684: [/to-int32 /ob /ans] pushVariables
3685: [
3686: /ob arg1 def
3687: /ans ob def
3688: ob isArray {
3689: ob {to_int32} map /ans set
3690: /LLL.to_int32 goto
3691: } { } ifelse
3692: ob isUniversalNumber {
3693: ob (integer) dc /ans set
3694: /LLL.to_int32 goto
3695: } { } ifelse
3696: /LLL.to_int32
3697: /arg1 ans def
3698: ] pop
3699: popVariables
3700: arg1
3701: } def
3702: [(to_int32)
3703: [(obj to_int32 obj2)
3704: $All universalNumber in obj are changed to integer (int32).$
3705: (Example: /ff [1 (2).. [(hello) (0).]] def ff { tag } map ::)
3706: ( ff to_int32 { tag } map :: )
3707: (cf. to_int, to_univNum )
3708: ]] putUsages
3709:
1.5 takayama 3710: /define_ring_variables {
1.6 takayama 3711: [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables
3712: %% You cannot use these names for names for polynomials.
1.5 takayama 3713: [
1.6 takayama 3714: /drv._v getVariableNames def
3715: /drv._v0 drv._v def
3716: drv._v { dup /drv._p set (/) 2 1 roll ( $) drv._p ($. def ) } map cat
3717: /drv._v set
3718: % drv._v message
3719: [(parse) drv._v] extension
1.5 takayama 3720: ] pop
3721: popVariables
3722: } def
3723: [(define_ring_variables)
3724: [(It binds a variable <<a>> in the current ring to the sm1 variable <<a>>.)
3725: (For example, if x is a variable in the current ring, it defines the sm1)
3726: (variable x by /x (x) def)
3727: ]] putUsages
3728:
3729: /boundp {
3730: /arg1 set
3731: [/a /ans] pushVariables
3732: [
3733: /a arg1 def
3734: [(parse) [(/) a ( load tag 0 eq { /ans 0 def } )
3735: ( { /ans 1 def } ifelse )] cat ] extension
3736: /arg1 ans def
3737: ] pop
3738: popVariables
3739: arg1
3740: } def
3741: [(boundp)
3742: [( a boundp b)
3743: (string a, b is 0 or 1.)
3744: (If the variable named << a >> is bounded to a value,)
3745: (it returns 1 else it returns 0.)
3746: $Example: (hoge) boundp ::$
1.1 maekawa 3747: ]] putUsages
1.10 takayama 3748: [(isSubstr)
3749: [
3750: (s1 s2 isSubstr pos)
3751: (If s1 is a substring of s2, isSubstr returns the position in s2 from which)
3752: (s1 is contained in s2.)
3753: (If s1 is not a substring of s2, then isSubstr returns -1.)
3754: ]
3755: ] putUsages
3756: /isSubstr {
3757: /arg2 set /arg1 set
3758: [/in-isSubstr /s1 /s2 /i1 /i2 /n1 /n2
3759: /ans /flg
3760: ] pushVariables
3761: [
3762: /s1 arg1 def
3763: /s2 arg2 def
3764: s1 (array) dc /s1 set
3765: s2 (array) dc /s2 set
3766: /n1 s1 length def
3767: /n2 s2 length def
3768: /ans -1 def
3769: 0 1 n2 n1 sub {
3770: /i2 set
3771: /flg 1 def
3772: 0 1 n1 1 sub {
3773: /i1 set
3774: s1 i1 get s2 i2 i1 add get eq {
3775: } {
3776: /flg 0 def exit
3777: } ifelse
3778: } for
3779: flg {
3780: /ans i2 def
3781: /isSubstr.L2 goto
3782: } { /ans -1 def } ifelse
3783: } for
3784: /isSubstr.L2
3785: /arg1 ans def
3786: ] pop
3787: popVariables
3788: arg1
1.14 takayama 3789: } def
3790:
3791: [(execve)
3792: [
3793: (command execve)
3794: ([arg0 arg1 arg2 ...] execve )
3795: (It executes the command by the system call execve.)
3796: (cf. system, forkExec)
3797: ]
3798: ] putUsages
3799:
3800: /execve {
3801: /execve.arg set
3802: [(forkExec) execve.arg [ ] 1] extension
1.15 takayama 3803: } def
3804:
3805: [(beginEcart)
3806: [
3807: (beginEcart)
3808: (Set the environments for the ecart division algorithm.)
3809: ]
3810: ] putUsages
3811:
1.23 takayama 3812: /ecart.debug_reduction1 0 def
1.15 takayama 3813: /beginEcart {
3814: (red@) (ecart) switch_function
3815: [(Ecart) 1] system_variable
1.16 takayama 3816: [(CheckHomogenization) 0] system_variable
3817: [(ReduceLowerTerms) 0] system_variable
3818: [(AutoReduce) 0] system_variable
1.17 takayama 3819: [(EcartAutomaticHomogenization) 0] system_variable
1.23 takayama 3820: ecart.debug_reduction1 {
3821: (red@) (debug) switch_function
3822: } { } ifelse
1.15 takayama 3823: } def
3824:
3825: [(endEcart)
3826: [
3827: (endEcart)
3828: (End of using the ecart division algorithm.)
3829: ]
3830: ] putUsages
3831:
3832: /endEcart {
3833: (red@) (standard) switch_function
3834: [(Ecart) 0] system_variable
1.21 takayama 3835: [(degreeShift) (reset)] homogenize pop
1.10 takayama 3836: } def
1.19 takayama 3837:
3838: /ord_ws_all {
3839: /arg2 set /arg1 set
3840: [(ord_ws_all) arg1 arg2] gbext
3841: } def
3842: [(ord_ws_all)
3843: [
3844: (fv wv ord_ws_all degree)
3845: ( ord_ws_all returns the ord with respect to the weight vector wv.)
3846: $Example: [(x,y) ring_of_differential_operators 0] define_ring $
3847: $ (Dx^2+x*Dx*Dy+2). [(Dx) 1 (Dy) 1] weightv ord_ws_all :: $
3848: ( )
3849: (fv [wv shiftv] ord_ws_all degree)
3850: ( ord_ws_all returns the ord with respect to the weight vector wv and)
3851: ( the shift vector shiftv.)
3852: $Example: [(x,y) ring_of_differential_operators 0] define_ring $
3853: $ [(Dx^2+x*Dx*Dy+2). (Dx).] [[(Dx) 1 (Dy) 1] weightv [0 2]] ord_ws_all ::$
3854: ( )
3855: (cf: init, gbext. Obsolete: ord_w, ord_w_all)
3856: ]
3857: ] putUsages
1.22 takayama 3858:
3859: [(newVector)
3860: [( n newVector vec)
3861: ]] putUsages
3862: /newVector {
3863: /arg1 set
3864: [/in-newVector /n] pushVariables
3865: [
3866: /n arg1 def
3867: [(newVector) n] extension /arg1 set
3868: ] pop
3869: popVariables
3870: arg1
3871: } def
3872:
3873: [(newMatrix)
3874: [( [m n] newMatrix mat)
3875: ]] putUsages
3876: /newMatrix {
3877: /arg1 set
3878: [/in-newMatrix /n] pushVariables
3879: [
3880: /n arg1 def
3881: [(newMatrix) n 0 get n 1 get] extension /arg1 set
3882: ] pop
3883: popVariables
3884: arg1
1.25 takayama 3885: } def
3886:
3887: /addStdoutStderr {
3888: [(>) (stringOut://@@@stdout) (2>) (stringOut://@@@stderr)] join
1.27 takayama 3889: } def
3890:
1.37 takayama 3891: [(___)
1.27 takayama 3892: [(reparse a polynomial or polynomials)]
3893: ] putUsages
1.37 takayama 3894: /___ {
1.27 takayama 3895: /arg1 set
3896: [/in-reparse /ff] pushVariables
3897: [
3898: /ff arg1 def
3899: ff tag 6 eq {
1.37 takayama 3900: ff { ___ } map /arg1 set
1.27 takayama 3901: } {
3902: ff toString . /arg1 set
3903: } ifelse
1.29 takayama 3904: ] pop
3905: popVariables
3906: arg1
3907: } def
3908:
3909: /to_univNum {
3910: /arg1 set
3911: [/rr ] pushVariables
3912: [
3913: /rr arg1 def
3914: rr isArray {
3915: rr { to_univNum } map /rr set
3916: } {
3917: } ifelse
3918: rr isInteger {
3919: rr (universalNumber) dc /rr set
3920: } {
3921: } ifelse
3922: /arg1 rr def
3923: ] pop
3924: popVariables
3925: arg1
3926: } def
3927: [(to_univNum)
3928: [(obj to_univNum obj2)
3929: (Example. [ 2 (3).. ] to_univNum)
1.33 takayama 3930: $cf. to_int32. (to_int)$
1.29 takayama 3931: ]] putUsages
3932:
3933: [(lcm)
3934: [ ([a b c ...] lcm r)
3935: (cf. polylcm, mpzext)
3936: ]
3937: ] putUsages
3938: /lcm {
3939: /arg1 set
3940: [/aa /bb /rr /pp /i] pushVariables
3941: [
3942: /aa arg1 def
3943: /rr (1).. def
3944: /pp 0 def % isPolynomial array?
3945: 0 1 aa length 1 sub {
3946: /i set
3947: aa i get isPolynomial {
3948: /pp 1 def
3949: exit
3950: } { } ifelse
3951: } for
3952:
3953: 0 1 aa length 1 sub {
3954: /i set
3955: pp {
3956: [rr aa i get] polylcm /rr set
3957: } {
3958: [(lcm) rr aa i get ] mpzext /rr set
3959: } ifelse
3960: } for
3961:
3962: /arg1 rr def
3963: ] pop
3964: popVariables
3965: arg1
3966: } def
3967: [(gcd)
3968: [ ([a b c ...] gcd r)
3969: (cf. polygcd, mpzext)
3970: ]
3971: ] putUsages
3972: /gcd {
3973: /arg1 set
3974: [/aa /bb /rr /pp /i] pushVariables
3975: [
3976: /aa arg1 def
3977: /rr (1).. def
3978: /pp 0 def % isPolynomial array?
3979: 0 1 aa length 1 sub {
3980: /i set
3981: aa i get isPolynomial {
3982: /pp 1 def
3983: /rr aa i get def
3984: exit
3985: } { } ifelse
3986: } for
3987:
3988: pp {
3989: 0 1 aa length 1 sub {
3990: /i set
3991: [rr aa i get] polygcd /rr set
3992: } for
3993: } {
3994: aa ngcd /rr set
3995: } ifelse
3996:
3997: /arg1 rr def
3998: ] pop
3999: popVariables
4000: arg1
4001: } def
4002:
4003: [(denominator)
4004: [ ([a b c ...] denominator r)
4005: ( a denominator r )
4006: (cf. dc, numerator)
1.30 takayama 4007: (Output is Z or a polynomial.)
1.29 takayama 4008: ]
4009: ] putUsages
4010: % test data.
4011: % [(1).. (2).. div (1).. (3).. div ] denominator
4012: % [(2).. (3).. (4).. ] denominator
4013: /denominator {
4014: /arg1 set
4015: [/pp /dd /ii /rr] pushVariables
4016: [
4017: /pp arg1 def
1.30 takayama 4018: pp to_univNum /pp set
1.29 takayama 4019: {
4020: pp isArray {
4021: pp { denominator } map /dd set
4022: /rr dd lcm def % rr = lcm(dd[0], dd[1], ... )
4023: rr /dd set
4024: exit
4025: } { } ifelse
4026:
4027: pp (denominator) dc /dd set
4028: exit
4029:
4030: } loop
4031: /arg1 dd def
4032: ] pop
4033: popVariables
4034: arg1
4035: } def
4036:
4037: [(numerator)
4038: [ ([a b c ...] numerator r)
4039: ( a numerator r )
4040: (cf. dc, denominator)
1.30 takayama 4041: (Output is a list of Z or polynomials.)
1.29 takayama 4042: ]
4043: ] putUsages
4044: % test data.
4045: /numerator {
4046: /arg1 set
4047: [/pp /dd /ii /rr] pushVariables
4048: [
4049: /pp arg1 def
1.30 takayama 4050: pp to_univNum /pp set
1.29 takayama 4051: {
4052: pp isArray {
4053: pp denominator /dd set
4054: pp dd mul /rr set
1.30 takayama 4055: rr cancel /rr set
1.29 takayama 4056: exit
4057: } { } ifelse
4058:
4059: pp (numerator) dc /rr set
4060: exit
4061:
4062: } loop
4063: /arg1 rr def
4064: ] pop
4065: popVariables
4066: arg1
4067: } def
4068:
1.30 takayama 4069: /cancel.Q {
1.29 takayama 4070: /arg1 set
4071: [/aa /rr /nn /dd /gg] pushVariables
4072: [
4073: /aa arg1 def
4074: {
4075: aa isRational {
4076: [(cancel) aa] mpzext /rr set
4077: rr (denominator) dc (1).. eq {
4078: /rr rr (numerator) dc def
4079: exit
4080: } { } ifelse
4081: rr (denominator) dc (-1).. eq {
4082: /rr rr (numerator) dc (-1).. mul def
4083: } { } ifelse
4084: exit
4085: } { } ifelse
4086:
4087: /rr aa def
4088: exit
4089: } loop
4090: /arg1 rr def
4091: ] pop
4092: popVariables
4093: arg1
4094: } def
4095:
1.30 takayama 4096: /cancel.one {
1.29 takayama 4097: /arg1 set
4098: [/aa /rr /nn /dd /gg] pushVariables
4099: [
4100: /aa arg1 def
4101: {
4102: aa isRational {
4103: aa (numerator) dc /nn set
4104: aa (denominator) dc /dd set
4105: nn isUniversalNumber dd isUniversalNumber and {
1.30 takayama 4106: /rr aa cancel.Q def
1.29 takayama 4107: exit
1.30 takayama 4108: } { (cancel: not implemented) error } ifelse
1.29 takayama 4109: } { } ifelse
4110:
4111: /rr aa def
4112: exit
4113: } loop
4114: /arg1 rr def
4115: ] pop
4116: popVariables
4117: arg1
4118: } def
4119:
1.30 takayama 4120: [(cancel)
4121: [ (obj cancel r)
1.29 takayama 4122: (Cancel numerators and denominators)
4123: (The implementation has not yet been completed. It works only for Q.)
4124: ]] putUsages
1.30 takayama 4125: /cancel {
1.29 takayama 4126: /arg1 set
4127: [/aa /rr] pushVariables
4128: [
4129: /aa arg1 def
4130: aa isArray {
1.30 takayama 4131: aa {cancel} map /rr set
1.29 takayama 4132: } {
1.30 takayama 4133: aa cancel.one /rr set
1.29 takayama 4134: } ifelse
4135: /arg1 rr def
1.27 takayama 4136: ] pop
4137: popVariables
4138: arg1
1.22 takayama 4139: } def
1.30 takayama 4140:
4141: /nnormalize_vec {
4142: /arg1 set
4143: [/pp /rr /dd ] pushVariables
4144: [
4145: /pp arg1 def
4146: pp denominator /dd set
4147: dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
4148: pp numerator dd mul cancel /pp set
4149: /@@@.nnormalize_vec_c dd def
4150: pp gcd /dd set
4151: dd (0).. lt { (nnormalize_vec: internal error) error } { } ifelse
4152: pp (1).. dd div mul cancel /rr set
4153: @@@.nnormalize_vec_c dd div cancel /@@@.nnormalize_vec_c set
4154: /arg1 rr def
4155: ] pop
4156: popVariables
4157: arg1
4158: } def
4159: [(nnormalize_vec)
4160: [(pp nnormalize_vec npp)
4161: (It normalizes a given vector of Q into a vector of Z with relatively prime)
4162: (entries by multiplying a postive number.)
4163: ]] putUsages
1.31 takayama 4164:
4165: /getNode {
4166: /arg2 set
4167: /arg1 set
1.43 takayama 4168: [/in-getNode /ob /key /rr /tt /ii] pushVariables
1.31 takayama 4169: [
4170: /ob arg1 def
4171: /key arg2 def
4172: /rr null def
4173: {
1.43 takayama 4174: ob isArray {
4175: ob length 1 gt {
4176: ob 0 get isString {
4177: ob 0 get , key eq {
4178: /rr ob 1 get def exit
4179: } { } ifelse
4180: } { } ifelse
4181: }{ } ifelse
4182: ob { key getNode , dup tag 0 eq {pop} { } ifelse } map /tt set
4183: tt length 0 gt { /rr tt 0 get def exit }
4184: {/rr null def exit } ifelse
4185: } { } ifelse
4186:
1.31 takayama 4187: ob isClass {
4188: ob (array) dc /ob set
1.43 takayama 4189: } { } ifelse
4190: ob isClass , ob isArray or { } { exit } ifelse
1.31 takayama 4191: ob 0 get key eq {
4192: /rr ob def
4193: exit
4194: } { } ifelse
4195: ob 2 get /ob set
4196: 0 1 ob length 1 sub {
4197: /ii set
4198: ob ii get key getNode /rr set
4199: rr tag 0 eq { } { exit } ifelse
4200: } for
4201: exit
4202: } loop
4203: /arg1 rr def
4204: ] pop
4205: popVariables
4206: arg1
4207: } def
4208: [(getNode)
1.43 takayama 4209: [(ob key getNode node-value)
4210: (ob is a class object or an array.)
1.31 takayama 4211: (The operator getNode returns the node with the key in ob.)
1.43 takayama 4212: (When ob is a class, the node is an array of the format [key attr-list node-list])
4213: (When ob is an array, the node is a value of key-value pairs.)
1.31 takayama 4214: (Example:)
4215: ( /dog [(dog) [[(legs) 4] ] [ ]] [(class) (tree)] dc def)
4216: ( /man [(man) [[(legs) 2] ] [ ]] [(class) (tree)] dc def)
4217: ( /ma [(mammal) [ ] [man dog]] [(class) (tree)] dc def)
4218: ( ma (dog) getNode )
1.43 takayama 4219: (Example 2:)
4220: ( [ [1 ] [2 3] [[(dog) 2]]] (dog) getNode ::)
1.31 takayama 4221: ]] putUsages
4222:
1.36 takayama 4223: /cons {
4224: /arg2 set /arg1 set
4225: [/aa /bb] pushVariables
4226: [
4227: /aa arg1 def /bb arg2 def
4228: [aa] (list) dc bb join /arg1 set
4229: ] pop
4230: popVariables
4231: arg1
4232: } def
4233: [(cons)
4234: [(obj list cons list)
4235: ]] putUsages
1.38 takayama 4236: /arrayToList {
4237: /arg1 set
4238: [/a /r] pushVariables
4239: [
4240: /a arg1 def
4241: {
4242: a isArray {
4243: a { arrayToList } map /a set
4244: a (list) dc /r set
4245: exit
4246: } { } ifelse
4247: /r a def
4248: exit
4249: } loop
4250: /arg1 r def
4251: ] pop
4252: popVariables
4253: arg1
4254: } def
4255: [(arrayToList)
4256: [(a arrayToList list)
4257: ]] putUsages
4258:
4259: /listToArray {
4260: /arg1 set
4261: [/a /r] pushVariables
4262: [
4263: /a arg1 def
4264: {
4265: a tag 12 eq {
4266: a (array) dc /a set
4267: a { listToArray } map /r set
4268: exit
4269: } { } ifelse
4270: a tag 0 eq {
4271: /r [ ] def
4272: exit
4273: } { } ifelse
4274: /r a def
4275: exit
4276: } loop
4277: /arg1 r def
4278: ] pop
4279: popVariables
4280: arg1
4281: } def
4282: [(listToArray)
4283: [(list listToArray a)
4284: ]] putUsages
4285:
1.44 takayama 4286: % Body is moved to smacro.sm1
1.39 takayama 4287: [(makeInfix)
4288: [(literal makeInfix)
4289: (Change literal to an infix operator.)
4290: (Example: /+ { add } def )
4291: ( /+ makeInfix)
4292: ( /s 0 def 1 1 100 { /i set s + i /s set } for s message)
4293: ( [ 1 2 3 ] { /i set i + 2 } map ::)
4294: ]] putUsages
1.22 takayama 4295:
1.24 takayama 4296: /usages {
4297: /arg1 set
1.40 takayama 4298: [/name /flag /n /k /slist /m /i /sss /key /ukeys] pushVariables
1.24 takayama 4299: [
4300: /name arg1 def
4301: /flag true def
1.40 takayama 4302: { % begin loop
4303:
4304: name isArray {
1.41 takayama 4305: /ukeys @.usages { 0 get } map shell def
1.40 takayama 4306: name { /key set [(regexec) key ukeys] extension
4307: { 0 get } map } map /sss set
4308: exit
4309: } { } ifelse
1.24 takayama 4310:
4311: name tag 1 eq {
4312: @.usages { 0 get } map shell { (, ) nl } map /sss set
1.40 takayama 4313: exit
1.24 takayama 4314: } {
4315:
4316: /sss [ ] def
4317: @.usages length /n set
4318: 0 1 << n 1 sub >>
4319: {
4320: /k set
4321: name << @.usages k get 0 get >> eq
4322: {
4323: /slist @.usages k get 1 get def
4324: /m slist length def
4325: 0 1 << m 1 sub >> {
4326: /i set
4327: sss slist i get append nl append /sss set
4328: } for
4329: /flag false def
4330: }
4331: { }
4332: ifelse
4333: } for
4334:
4335: %BUG: cannot get usages of primitives.
4336: flag
4337: {name Usage /sss [(Usage of ) name ( could not obtained.) nl ] def}
4338: { }
4339: ifelse
1.40 takayama 4340: exit
1.24 takayama 4341: } ifelse
1.40 takayama 4342:
4343: } loop
1.24 takayama 4344: /arg1 sss cat def
4345: ] pop
4346: popVariables
4347: arg1
4348: } def
4349: [(usages)
4350: [(key usages usages-as-a-string)
4351: (num usages list-of-key-words)
1.40 takayama 4352: ([key1 key2 ... ] usages list-of-key-words : it accepts regular expressions.)
1.42 takayama 4353: ]] putUsages
4354:
4355: /setMinus {
4356: /arg2 set /arg1 set
4357: [/aa /bb /i ] pushVariables
4358: [
4359: /aa arg1 def /bb arg2 def
4360: [
4361: 0 1 aa length 1 sub {
4362: /i set
4363: aa i get bb memberQ {
4364: } { aa i get } ifelse
4365: } for
4366: ] /arg1 set
4367: ] pop
4368: popVariables
4369: arg1
4370: } def
4371: [(setMinus)
4372: [(a b setMinus c)
1.24 takayama 4373: ]] putUsages
1.45 takayama 4374:
4375: % Define some infix operators
4376: /~add~ { add } def /~add~ makeInfix
4377: /~sub~ { sub } def /~sub~ makeInfix
4378: /~mul~ { mul } def /~mul~ makeInfix
4379: /~div~ { div } def /~div~ makeInfix
4380: /~power~ { power } def /~power~ makeInfix
4381: /~put~ {
4382: dup tag 3 eq { exec } { } ifelse put
4383: } def
4384: /~put~ makeInfix
4385:
1.1 maekawa 4386:
4387: ;
4388:
4389:
4390:
4391:
4392:
4393:
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