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