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