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