Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.1.1.1
1.1 maekawa 1: %% dr.sm1 (Define Ring) 1994/9/25, 26
2: %% This file is error clean.
3:
4: @@@.quiet { }
5: { (macro package : dr.sm1, 9/26,1995 --- Version 9/8, 1999. ) message } ifelse
6:
7: /ctrlC-hook {
8: %%% define your own routing in case of error.
9: } def
10: [(ctrlC-hook)
11: [(When ctrl-C is pressed, this function is executed.)
12: (User can define one's own ctrlC-hook function.)
13: ]] putUsages
14:
15: %% n evenQ bool
16: /evenQ {
17: /arg1 set
18: arg1 2 idiv 2 mul arg1 sub 0 eq
19: { true }
20: { false } ifelse
21: } def
22:
23: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
24: /ring_of_polynomials {
25: /arg1 set
26: [/vars /n /i /xList /dList /param] pushVariables
27: %dup print (-----) message
28: [
29: (mmLarger) (matrix) switch_function
30: (mpMult) (poly) switch_function
31: (red@) (module1) switch_function
32: (groebner) (standard) switch_function
33: (isSameComponent) (x) switch_function
34:
35: [arg1 to_records pop] /vars set
36: vars length evenQ
37: { }
38: { vars [(PAD)] join /vars set }
39: ifelse
40: vars length 2 idiv /n set
41: [ << n 1 sub >> -1 0
42: { /i set
43: vars i get
44: } for
45: ] /xList set
46: [ << n 1 sub >> -1 0
47: { /i set
48: vars << i n add >> get
49: } for
50: ] /dList set
51:
52: [(H)] xList join [@@@.esymbol] join /xList set
53: [(h)] dList join [@@@.Esymbol] join /dList set
54: [0 %% dummy characteristic
55: << xList length >> << xList length >> << xList length >>
56: << xList length >>
57: << xList length 1 sub >> << xList length >> << xList length >>
58: << xList length >>
59: ] /param set
60:
61: [xList dList param] /arg1 set
62: ] pop
63: popVariables
64: arg1
65: } def
66:
67: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
68: %% with no graduation and homogenization variables.
69: /ring_of_polynomials2 {
70: /arg1 set
71: [/vars /n /i /xList /dList /param] pushVariables
72: %dup print (-----) message
73: [
74: (mmLarger) (matrix) switch_function
75: (mpMult) (poly) switch_function
76: (red@) (module1) switch_function
77: (groebner) (standard) switch_function
78: (isSameComponent) (x) switch_function
79:
80: [arg1 to_records pop] /vars set
81: vars length evenQ
82: { }
83: { vars [(PAD)] join /vars set }
84: ifelse
85: vars length 2 idiv /n set
86: [ << n 1 sub >> -1 0
87: { /i set
88: vars i get
89: } for
90: ] /xList set
91: [ << n 1 sub >> -1 0
92: { /i set
93: vars << i n add >> get
94: } for
95: ] /dList set
96:
97: [0 %% dummy characteristic
98: << xList length >> << xList length >> << xList length >>
99: << xList length >>
100: << xList length >> << xList length >> << xList length >>
101: << xList length >>
102: ] /param set
103:
104: [xList dList param] /arg1 set
105: ] pop
106: popVariables
107: arg1
108: } def
109:
110: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
111: %% with no homogenization variables.
112: /ring_of_polynomials3 {
113: /arg1 set
114: [/vars /n /i /xList /dList /param] pushVariables
115: %dup print (-----) message
116: [
117: (mmLarger) (matrix) switch_function
118: (mpMult) (poly) switch_function
119: (red@) (module1) switch_function
120: (groebner) (standard) switch_function
121: (isSameComponent) (x) switch_function
122:
123: [arg1 to_records pop] /vars set
124: vars length evenQ
125: { }
126: { vars [(PAD)] join /vars set }
127: ifelse
128: vars length 2 idiv /n set
129: [ << n 1 sub >> -1 0
130: { /i set
131: vars i get
132: } for
133: ] /xList set
134: xList [@@@.esymbol] join /xList set
135: [ << n 1 sub >> -1 0
136: { /i set
137: vars << i n add >> get
138: } for
139: ] /dList set
140: dList [@@@.Esymbol] join /dList set
141:
142: [0 %% dummy characteristic
143: << xList length >> << xList length >> << xList length >>
144: << xList length >>
145: << xList length >> << xList length >> << xList length >>
146: << xList length >>
147: ] /param set
148:
149: [xList dList param] /arg1 set
150: ] pop
151: popVariables
152: arg1
153: } def
154:
155: /ring_of_differential_operators {
156: /arg1 set
157: [/vars /n /i /xList /dList /param] pushVariables
158: [
159: (mmLarger) (matrix) switch_function
160: (mpMult) (diff) switch_function
161: (red@) (module1) switch_function
162: (groebner) (standard) switch_function
163: (isSameComponent) (x) switch_function
164:
165: [arg1 to_records pop] /vars set %[x y z]
166: vars reverse /xList set %[z y x]
167: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
168: reverse /dList set %[Dz Dy Dx]
169: [(H)] xList join [@@@.esymbol] join /xList set
170: [(h)] dList join [@@@.Esymbol] join /dList set
171: [0 1 1 1 << xList length >>
172: 1 1 1 << xList length 1 sub >> ] /param set
173: [ xList dList param ] /arg1 set
174: ] pop
175: popVariables
176: arg1
177: } def
178:
179: /ring_of_differential_operators3 {
180: %% with no homogenization variables.
181: /arg1 set
182: [/vars /n /i /xList /dList /param] pushVariables
183: [
184: (mmLarger) (matrix) switch_function
185: (mpMult) (diff) switch_function
186: (red@) (module1) switch_function
187: (groebner) (standard) switch_function
188: (isSameComponent) (x) switch_function
189:
190: [arg1 to_records pop] /vars set %[x y z]
191: vars reverse /xList set %[z y x]
192: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
193: reverse /dList set %[Dz Dy Dx]
194: xList [@@@.esymbol] join /xList set
195: dList [@@@.Esymbol] join /dList set
196: [0 0 0 0 << xList length >>
197: 0 0 0 << xList length 1 sub >> ] /param set
198: [ xList dList param ] /arg1 set
199: ] pop
200: popVariables
201: arg1
202: } def
203:
204: /ring_of_q_difference_operators {
205: /arg1 set
206: [/vars /n /i /xList /dList /param] pushVariables
207: [
208: (mmLarger) (matrix) switch_function
209: (mpMult) (diff) switch_function
210: (red@) (module1) switch_function
211: (groebner) (standard) switch_function
212: (isSameComponent) (x) switch_function
213:
214: [arg1 to_records pop] /vars set %[x y z]
215: vars reverse /xList set %[z y x]
216: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
217: reverse /dList set %[Dz Dy Dx]
218: [(q)] xList join [@@@.esymbol] join /xList set
219: [(h)] dList join [@@@.Esymbol] join /dList set
220: [0 1 << xList length >> << xList length >> << xList length >>
221: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
222: /param set
223: [ xList dList param ] /arg1 set
224: ] pop
225: popVariables
226: arg1
227: } def
228:
229: /ring_of_q_difference_operators3 {
230: %% with no homogenization and q variables.
231: /arg1 set
232: [/vars /n /i /xList /dList /param] pushVariables
233: [
234: (mmLarger) (matrix) switch_function
235: (mpMult) (diff) switch_function
236: (red@) (module1) switch_function
237: (groebner) (standard) switch_function
238: (isSameComponent) (x) switch_function
239:
240: [arg1 to_records pop] /vars set %[x y z]
241: vars reverse /xList set %[z y x]
242: vars {@@@.Qsymbol 2 1 roll 2 cat_n} map
243: reverse /dList set %[Dz Dy Dx]
244: xList [@@@.esymbol] join /xList set
245: dList [@@@.Esymbol] join /dList set
246: [0 0 << xList length >> << xList length >> << xList length >>
247: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
248: /param set
249: [ xList dList param ] /arg1 set
250: ] pop
251: popVariables
252: arg1
253: } def
254:
255: /ring_of_difference_operators {
256: /arg1 set
257: [/vars /n /i /xList /dList /param] pushVariables
258: [
259: (mmLarger) (matrix) switch_function
260: (mpMult) (difference) switch_function
261: (red@) (module1) switch_function
262: (groebner) (standard) switch_function
263: (isSameComponent) (x) switch_function
264:
265: [arg1 to_records pop] /vars set %[x y z]
266: vars reverse /xList set %[z y x]
267: vars {@@@.diffEsymbol 2 1 roll 2 cat_n} map
268: reverse /dList set %[Dz Dy Dx]
269: [(H)] xList join [@@@.esymbol] join /xList set
270: [(h)] dList join [@@@.Esymbol] join /dList set
271: [0 1 1 << xList length >> << xList length >>
272: 1 1 << xList length 1 sub >> << xList length >> ] /param set
273: [ xList dList param ] /arg1 set
274: ] pop
275: popVariables
276: arg1
277: } def
278:
279:
280:
281: /reverse {
282: /arg1 set
283: arg1 length 1 lt
284: { [ ] }
285: {
286: [
287: << arg1 length 1 sub >> -1 0
288: {
289: arg1 2 1 roll get
290: } for
291: ]
292: } ifelse
293: } def
294:
295: /memberQ {
296: %% a set0 memberQ bool
297: /arg2 set /arg1 set
298: [/a /set0 /flag /i ] pushVariables
299: [
300: /a arg1 def /set0 arg2 def
301: /flag 0 def
302: 0 1 << set0 length 1 sub >>
303: {
304: /i set
305: << set0 i get >> a eq
306: {
307: /flag 1 def
308: }
309: { }
310: ifelse
311: } for
312: ] pop
313: /arg1 flag def
314: popVariables
315: arg1
316: } def
317:
318: /transpose {
319: /arg1 set
320: [/mat /m /n /ans /i /j] pushVariables
321: [
322: /mat arg1 def
323: /m mat length def
324: mat 0 get isArray
325: { }
326: { (transpose: Argument must be an array of arrays.) error }
327: ifelse
328: /n mat 0 get length def
329: /ans [ 1 1 n { pop [ 1 1 m { pop 0 } for ]} for ] def
330: 0 1 << m 1 sub >> {
331: /i set
332: 0 1 << n 1 sub >> {
333: /j set
334: ans [ j i ] << mat i get j get >> put
335: } for
336: } for
337: /arg1 ans def
338: ] pop
339: popVariables
340: arg1
341: } def
342:
343:
344: /getPerm {
345: %% old new getPerm perm
346: /arg2 set /arg1 set
347: [/old /new /i /j /p] pushVariables
348: [
349: /old arg1 def
350: /new arg2 def
351: [
352: /p old length def
353: 0 1 << p 1 sub >>
354: {
355: /i set
356: 0 1 << p 1 sub >>
357: {
358: /j set
359: old i get
360: new j get
361: eq
362: { j }
363: { } ifelse
364: } for
365: } for
366: ] /arg1 set
367: ] pop
368: popVariables
369: arg1
370: } def
371:
372: /permuteOrderMatrix {
373: %% order perm puermuteOrderMatrix newOrder
374: /arg2 set /arg1 set
375: [/order /perm /newOrder /k ] pushVariables
376: [
377: /order arg1 def
378: /perm arg2 def
379: order transpose /order set
380: order 1 copy /newOrder set pop
381:
382: 0 1 << perm length 1 sub >>
383: {
384: /k set
385: newOrder << perm k get >> << order k get >> put
386: } for
387: newOrder transpose /newOrder set
388: ] pop
389: /arg1 newOrder def
390: popVariables
391: arg1
392: } def
393:
394:
395:
396: /complement {
397: %% set0 universe complement compl
398: /arg2 set /arg1 set
399: [/set0 /universe /compl /i] pushVariables
400: /set0 arg1 def /universe arg2 def
401: [
402: 0 1 << universe length 1 sub >>
403: {
404: /i set
405: << universe i get >> set0 memberQ
406: { }
407: { universe i get }
408: ifelse
409: } for
410: ] /arg1 set
411: popVariables
412: arg1
413: } def
414:
415:
416: %%% from order.sm1
417:
418: %% size i evec [0 0 ... 0 1 0 ... 0]
419: /evec {
420: /arg2 set /arg1 set
421: [/size /iii] pushVariables
422: /size arg1 def /iii arg2 def
423: [
424: 0 1 << size 1 sub >>
425: {
426: iii eq
427: { 1 }
428: { 0 }
429: ifelse
430: } for
431: ] /arg1 set
432: popVariables
433: arg1
434: } def
435:
436: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
437: /evec_neg {
438: /arg2 set /arg1 set
439: [/size /iii] pushVariables
440: /size arg1 def /iii arg2 def
441: [
442: 0 1 << size 1 sub >>
443: {
444: iii eq
445: { -1 }
446: { 0 }
447: ifelse
448: } for
449: ] /arg1 set
450: popVariables
451: arg1
452: } def
453:
454:
455: %% size i j e_ij << matrix e(i,j) >>
456: /e_ij {
457: /arg3 set /arg2 set /arg1 set
458: [/size /k /i /j] pushVariables
459: [
460: /size arg1 def /i arg2 def /j arg3 def
461: [ 0 1 << size 1 sub >>
462: {
463: /k set
464: k i eq
465: { size j evec }
466: {
467: k j eq
468: { size i evec }
469: { size k evec }
470: ifelse
471: } ifelse
472: } for
473: ] /arg1 set
474: ] pop
475: popVariables
476: arg1
477: } def
478:
479:
480: %% size i j d_ij << matrix E_{ij} >>
481: /d_ij {
482: /arg3 set /arg2 set /arg1 set
483: [/size /k /i /j] pushVariables
484: [
485: /size arg1 def /i arg2 def /j arg3 def
486: [ 0 1 << size 1 sub >>
487: {
488: /k set
489: k i eq
490: { size j evec }
491: {
492: [ 0 1 << size 1 sub >> { pop 0} for ]
493: } ifelse
494: } for
495: ] /arg1 set
496: ] pop
497: popVariables
498: arg1
499: } def
500:
501: %% size matid << id matrix >>
502: /matid {
503: /arg1 set
504: [/size /k ] pushVariables
505: [
506: /size arg1 def
507: [ 0 1 << size 1 sub >>
508: {
509: /k set
510: size k evec
511: } for
512: ] /arg1 set
513: ] pop
514: popVariables
515: arg1
516: } def
517:
518:
519: %% m1 m2 oplus
520: /oplus {
521: /arg2 set /arg1 set
522: [/m1 /m2 /n /m /k ] pushVariables
523: [
524: /m1 arg1 def /m2 arg2 def
525: m1 length /n set
526: m2 length /m set
527: [
528: 0 1 << n m add 1 sub >>
529: {
530: /k set
531: k n lt
532: {
533: << m1 k get >> << m -1 evec >> join
534: }
535: {
536: << n -1 evec >> << m2 << k n sub >> get >> join
537: } ifelse
538: } for
539: ] /arg1 set
540: ] pop
541: popVariables
542: arg1
543: } def
544:
545: %%%%%%%%%%%%%%%%%%%%%%%
546:
547: /eliminationOrderTemplate { %% esize >= 1
548: %% if esize == 0, it returns reverse lexicographic order.
549: %% m esize eliminationOrderTemplate mat
550: /arg2 set /arg1 set
551: [/m /esize /m1 /m2 /k ] pushVariables
552: [
553: /m arg1 def /esize arg2 def
554: /m1 m esize sub 1 sub def
555: /m2 esize 1 sub def
556: [esize 0 gt
557: {
558: [1 1 esize
559: { pop 1 } for
560: esize 1 << m 1 sub >>
561: { pop 0 } for
562: ] %% 1st vector
563: }
564: { } ifelse
565:
566: m esize gt
567: {
568: [1 1 esize
569: { pop 0 } for
570: esize 1 << m 1 sub >>
571: { pop 1 } for
572: ] %% 2nd vector
573: }
574: { } ifelse
575:
576: m1 0 gt
577: {
578: m 1 sub -1 << m m1 sub >>
579: {
580: /k set
581: m k evec_neg
582: } for
583: }
584: { } ifelse
585:
586: m2 0 gt
587: {
588: << esize 1 sub >> -1 1
589: {
590: /k set
591: m k evec_neg
592: } for
593: }
594: { } ifelse
595:
596: ] /arg1 set
597: ] pop
598: popVariables
599: arg1
600: } def
601:
602: /elimination_order {
603: %% [x-list d-list params] (x,y,z) elimination_order
604: %% vars evars
605: %% [x-list d-list params order]
606: /arg2 set /arg1 set
607: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
608: /vars arg1 def /evars [arg2 to_records pop] def
609: [
610: /univ vars 0 get reverse
611: vars 1 get reverse join
612: def
613:
614: << univ length 2 sub >>
615: << evars length >>
616: eliminationOrderTemplate /order set
617:
618: [[1]] order oplus [[1]] oplus /order set
619:
620: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
621:
622: /compl
623: [univ 0 get] evars join evars univ0 complement join
624: def
625: compl univ
626: getPerm /perm set
627: %%perm :: univ :: compl ::
628:
629: order perm permuteOrderMatrix /order set
630:
631:
632: vars [order] join /arg1 set
633: ] pop
634: popVariables
635: arg1
636: } def
637:
638: /elimination_order2 {
639: %% [x-list d-list params] (x,y,z) elimination_order
640: %% vars evars
641: %% [x-list d-list params order]
642: %% with no graduation and homogenization variables.
643: /arg2 set /arg1 set
644: [/vars /evars /univ /order /perm /compl] pushVariables
645: /vars arg1 def /evars [arg2 to_records pop] def
646: [
647: /univ vars 0 get reverse
648: vars 1 get reverse join
649: def
650:
651: << univ length >>
652: << evars length >>
653: eliminationOrderTemplate /order set
654: /compl
655: evars << evars univ complement >> join
656: def
657: compl univ
658: getPerm /perm set
659: %%perm :: univ :: compl ::
660:
661: order perm permuteOrderMatrix /order set
662:
663: vars [order] join /arg1 set
664: ] pop
665: popVariables
666: arg1
667: } def
668:
669:
670: /elimination_order3 {
671: %% [x-list d-list params] (x,y,z) elimination_order
672: %% vars evars
673: %% [x-list d-list params order]
674: /arg2 set /arg1 set
675: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
676: /vars arg1 def /evars [arg2 to_records pop] def
677: [
678: /univ vars 0 get reverse
679: vars 1 get reverse join
680: def
681:
682: << univ length 1 sub >>
683: << evars length >>
684: eliminationOrderTemplate /order set
685:
686: [[1]] order oplus /order set
687:
688: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
689:
690: /compl
691: [univ 0 get] evars join evars univ0 complement join
692: def
693: compl univ
694: getPerm /perm set
695: %%perm :: univ :: compl ::
696:
697: order perm permuteOrderMatrix /order set
698:
699: vars [order] join /arg1 set
700: ] pop
701: popVariables
702: arg1
703: } def
704:
705:
706: /define_ring {
707: %[ (x,y,z) ring_of_polynominals
708: % (x,y) elimination_order
709: % 17
710: %] define_ring
711: % or
712: %[ (x,y,z) ring_of_polynominals
713: % (x,y) elimination_order
714: % 17
715: % [(keyword) value (keyword) value ...]
716: %] define_ring
717: /arg1 set
718: [/rp /param /foo] pushVariables
719: [/rp arg1 def
720:
721: rp 0 get length 3 eq {
722: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
723: ( ) elimination_order put
724: } { } ifelse
725:
726: [
727: rp 0 get 0 get %% x-list
728: rp 0 get 1 get %% d-list
729: rp 0 get 2 get /param set
730: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
731: param %% parameters.
732: rp 0 get 3 get %% order matrix.
733: rp length 2 eq
734: { [ ] } %% null optional argument.
735: { rp 2 get }
736: ifelse
737: ] /foo set
738: foo aload pop set_up_ring@
739: ] pop
740: popVariables
741: [(CurrentRingp)] system_variable
742: } def
743:
744:
745: [(define_qring)
746: [( [varlist ring_of_q_difference_operators order characteristic] define_qring)
747: ( Pointer to the ring. )
748: (Example: [$x,y$ ring_of_q_difference_operators $Qx,Qy$ elimination_order)
749: ( 0] define_qring )
750: (cf. define_ring, set_up_ring@ <coefficient ring>, ring_def, << ,, >>)
751: ]
752: ] putUsages
753: /define_qring {
754: %[ (x,y,z) ring_of_q_difference_operators
755: % (Qx,Qy) elimination_order
756: % 17
757: %] define_qring
758: /arg1 set
759: [/rp /param /foo /cring /ppp] pushVariables
760: [/rp arg1 def
761: /ppp rp 1 get def
762: %% define coefficient ring.
763: [(q) @@@.esymbol] [(h) @@@.Esymbol]
764: [ppp 2 2 2 2 1 2 2 2]
765: [[1 0 0 0] [0 1 0 0] [0 0 1 0] [0 0 0 1]]
766: [(mpMult) (poly)] set_up_ring@
767: /cring [(CurrentRingp)] system_variable def
768:
769: rp 0 get length 3 eq {
770: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
771: ( ) elimination_order put
772: } { } ifelse
773:
774: [
775: rp 0 get 0 get %% x-list
776: rp 0 get 1 get %% d-list
777: rp 0 get 2 get /param set
778: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
779: param %% parameters.
780: rp 0 get 3 get %% order matrix.
781: rp length 2 eq
782: { [(mpMult) (diff) (coefficient ring) cring] } %% optional argument.
783: { [(mpMult) (diff) (coefficient ring) cring] rp 2 get join }
784: ifelse
785: ] /foo set
786: foo aload pop set_up_ring@
787: ] pop
788: popVariables
789: [(CurrentRingp)] system_variable
790: } def
791:
792: [(ring_def)
793: [(ring ring_def)
794: (Set the current ring to the <<ring>>)
795: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 0 ] define_ring)
796: ( /R set)
797: ( R ring_def)
798: (In order to get the ring object R to which a given polynomial f belongs,)
799: (one may use the command )
800: ( f (ring) data_conversion /R set)
801: (cf. define_ring, define_qring, system_variable, poly (ring) data_conversion)
802: (cf. << ,, >>)
803: ]
804: ] putUsages
805:
806: /ring_def {
807: /arg1 set
808: [(CurrentRingp) arg1] system_variable
809: } def
810:
811:
812:
813: /lexicographicOrderTemplate {
814: % size lexicographicOrderTemplate matrix
815: /arg1 set
816: [/k /size] pushVariables
817: [
818: /size arg1 def
819: [ 0 1 << size 1 sub >>
820: {
821: /k set
822: size k evec
823: } for
824: ] /arg1 set
825: ] pop
826: popVariables
827: arg1
828: } def
829:
830: /lexicographic_order {
831: %% [x-list d-list params] (x,y,z) lexicograhic_order
832: %% vars evars
833: %% [x-list d-list params order]
834: /arg2 set /arg1 set
835: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
836: /vars arg1 def /evars [arg2 to_records pop] def
837: [
838: /univ vars 0 get reverse
839: vars 1 get reverse join
840: def
841:
842: << univ length 2 sub >>
843: lexicographicOrderTemplate /order set
844:
845: [[1]] order oplus [[1]] oplus /order set
846:
847: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
848:
849: /compl
850: [univ 0 get] evars join evars univ0 complement join
851: def
852: compl univ
853: getPerm /perm set
854: %%perm :: univ :: compl ::
855:
856: order perm permuteOrderMatrix /order set
857:
858: vars [order] join /arg1 set
859: ] pop
860: popVariables
861: arg1
862: } def
863:
864: /lexicographic_order2 {
865: %% [x-list d-list params] (x,y,z) lexicograhic_order
866: %% vars evars
867: %% [x-list d-list params order]
868: %% with no graduation and homogenization variables
869: /arg2 set /arg1 set
870: [/vars /evars /univ /order /perm /compl] pushVariables
871: /vars arg1 def /evars [arg2 to_records pop] def
872: [
873: /univ vars 0 get reverse
874: vars 1 get reverse join
875: def
876:
877: << univ length >>
878: lexicographicOrderTemplate /order set
879:
880: /compl
881: evars << evars univ complement >> join
882: def
883: compl univ
884: getPerm /perm set
885:
886: order perm permuteOrderMatrix /order set
887:
888: vars [order] join /arg1 set
889: ] pop
890: popVariables
891: arg1
892: } def
893:
894: /lexicographic_order3 {
895: %% [x-list d-list params] (x,y,z) lexicograhic_order
896: %% vars evars
897: %% [x-list d-list params order]
898: %% with no homogenization variable.
899: /arg2 set /arg1 set
900: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
901: /vars arg1 def /evars [arg2 to_records pop] def
902: [
903: /univ vars 0 get reverse
904: vars 1 get reverse join
905: def
906:
907: << univ length 1 sub >>
908: lexicographicOrderTemplate /order set
909:
910: [[1]] order oplus /order set
911:
912: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
913:
914: /compl
915: [univ 0 get] evars join evars univ0 complement join
916: def
917: compl univ
918: getPerm /perm set
919: %%perm :: univ :: compl ::
920:
921: order perm permuteOrderMatrix /order set
922:
923: vars [order] join /arg1 set
924: ] pop
925: popVariables
926: arg1
927: } def
928:
929: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
930:
931: /graded_reverse_lexicographic_order {
932: ( ) elimination_order
933: } def
934:
935:
936: /getX {
937: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
938: /arg2 set /arg1 set
939: [/k /param /func /low /top] pushVariables
940: [
941: /param arg1 def /func arg2 def
942: func 1 eq
943: {
944: /low 0 def
945: }
946: {
947: /low << param 2 get >> << func 1 sub >> get def
948: } ifelse
949: /top << param 2 get >> << func 4 add >> get 1 sub def
950: [
951: low 1 top
952: {
953: /k set
954: param 0 get k get
955: } for
956: ] /arg1 set
957: ] pop
958: popVariables
959: arg1
960: } def
961:
962: /getD {
963: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
964: /arg2 set /arg1 set
965: [/k /param /func /low /top] pushVariables
966: [
967: /param arg1 def /func arg2 def
968: func 1 eq
969: {
970: /low 0 def
971: }
972: {
973: /low << param 2 get >> << func 1 sub >> get def
974: } ifelse
975: /top << param 2 get >> << func 4 add >> get 1 sub def
976: [
977: low 1 top
978: {
979: /k set
980: param 1 get k get
981: } for
982: ] /arg1 set
983: ] pop
984: popVariables
985: arg1
986: } def
987:
988: /getXV {
989: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
990: /arg2 set /arg1 set
991: [/k /param /func /low /top] pushVariables
992: [
993: /param arg1 def /func arg2 def
994: /low << param 2 get >> << func 4 add >> get def
995: /top << param 2 get >> func get 1 sub def
996: [
997: low 1 top
998: {
999: /k set
1000: param 0 get k get
1001: } for
1002: ] /arg1 set
1003: ] pop
1004: popVariables
1005: arg1
1006: } def
1007:
1008: /getDV {
1009: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
1010: /arg2 set /arg1 set
1011: [/k /param /func /low /top] pushVariables
1012: [
1013: /param arg1 def /func arg2 def
1014: /low << param 2 get >> << func 4 add >> get def
1015: /top << param 2 get >> func 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: /reNaming {
1029: %% It also changes oldx2 and oldd2, which are globals.
1030: /arg1 set
1031: [/i /j /new /count /ostr /k] pushVariables
1032: [
1033: /new arg1 def
1034: /count 0 def
1035: 0 1 << new length 1 sub >> {
1036: /i set
1037: << i 1 add >> 1 << new length 1 sub >> {
1038: /j set
1039: << new i get >> << new j get >> eq
1040: {
1041: new j get /ostr set
1042: (The two rings have the same name :) messagen
1043: new i get messagen (.) message
1044: (The name ) messagen
1045: new i get messagen ( is changed into ) messagen
1046: new j << new i get << 48 count add $string$ data_conversion >>
1047: 2 cat_n >> put
1048: new j get messagen (.) message
1049: /oldx2 ostr << new j get >> reNaming2
1050: /oldd2 ostr << new j get >> reNaming2
1051: /count count 1 add def
1052: }
1053: { }
1054: ifelse
1055: } for
1056: } for
1057: /arg1 new def
1058: ] pop
1059: popVariables
1060: arg1
1061: } def
1062:
1063: /reNaming2 {
1064: %% array oldString newString reNaming2
1065: %% /aa (x) (y) reNaming2
1066: /arg3 set /arg2 set /arg1 set
1067: [/array /oldString /newString /k] pushVariables
1068: [
1069: /array arg1 def /oldString arg2 def /newString arg3 def
1070: 0 1 << array load length 1 sub >>
1071: {
1072: /k set
1073: << array load k get >> oldString eq
1074: {
1075: array load k newString put
1076: }
1077: { } ifelse
1078: } for
1079: ] pop
1080: popVariables
1081: } def
1082:
1083: /add_rings {
1084: /arg2 set /arg1 set
1085: [/param1 /param2
1086: /newx /newd /newv
1087: /k /const /od1 /od2 /od
1088: /oldx2 /oldd2 % these will be changed in reNaming.
1089: /oldv
1090: ] pushVariables
1091: [
1092: /param1 arg1 def /param2 arg2 def
1093: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1094: /newx
1095: [ ]
1096: param2 1 getX join param1 1 getX join
1097: param2 1 getXV join param1 1 getXV join
1098:
1099: param2 2 getX join param1 2 getX join
1100: param2 2 getXV join param1 2 getXV join
1101:
1102: param2 3 getX join param1 3 getX join
1103: param2 3 getXV join param1 3 getXV join
1104:
1105: param2 4 getX join param1 4 getX join
1106: param2 4 getXV join param1 4 getXV join
1107: def
1108: /newd
1109: [ ]
1110: param2 1 getD join param1 1 getD join
1111: param2 1 getDV join param1 1 getDV join
1112:
1113: param2 2 getD join param1 2 getD join
1114: param2 2 getDV join param1 2 getDV join
1115:
1116: param2 3 getD join param1 3 getD join
1117: param2 3 getDV join param1 3 getDV join
1118:
1119: param2 4 getD join param1 4 getD join
1120: param2 4 getDV join param1 4 getDV join
1121: def
1122:
1123: /newv newx newd join def
1124: /oldx2 param2 0 get def /oldd2 param2 1 get def
1125: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
1126: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
1127: /newv newv reNaming def
1128:
1129: /newx [
1130: 0 1 << newv length 2 idiv 1 sub >>
1131: {
1132: /k set
1133: newv k get
1134: } for
1135: ] def
1136: /newd [
1137: 0 1 << newv length 2 idiv 1 sub >>
1138: {
1139: /k set
1140: newv << newv length 2 idiv k add >> get
1141: } for
1142: ] def
1143: /const [
1144: << param1 2 get 0 get >>
1145: << param1 2 get 1 get param2 2 get 1 get add >>
1146: << param1 2 get 2 get param2 2 get 2 get add >>
1147: << param1 2 get 3 get param2 2 get 3 get add >>
1148: << param1 2 get 4 get param2 2 get 4 get add >>
1149: << param1 2 get 5 get param2 2 get 5 get add >>
1150: << param1 2 get 6 get param2 2 get 6 get add >>
1151: << param1 2 get 7 get param2 2 get 7 get add >>
1152: << param1 2 get 8 get param2 2 get 8 get add >>
1153: ] def
1154:
1155: /od1 param1 3 get def /od2 param2 3 get def
1156: od1 od2 oplus /od set
1157:
1158: %%oldx2 :: oldd2 ::
1159: << param1 0 get reverse >> << param1 1 get reverse >> join
1160: << oldx2 reverse >> << oldd2 reverse >> join
1161: join /oldv set
1162:
1163:
1164: od << oldv << newx reverse newd reverse join >> getPerm >>
1165: permuteOrderMatrix /od set
1166:
1167: /arg1 [newx newd const od] def
1168: ] pop
1169: popVariables
1170: arg1
1171: } def
1172:
1173:
1174: %%%% end of add_rings
1175:
1176:
1177:
1178: [(swap01) [
1179: $[ .... ] swap01 [....]$
1180: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
1181: $ define_ring$
1182: ]] putUsages
1183: %
1184: /swap01 {
1185: /arg1 set
1186: [/rg /ch ] pushVariables
1187: [
1188: arg1 0 get /rg set % ring
1189: arg1 1 get /ch set % characteristics
1190: [rg 0 get , rg 1 get , rg 2 get ,
1191: << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
1192: /arg1 [ rg ch ] def
1193: ] pop
1194: popVariables
1195: arg1
1196: } def
1197:
1198: [(swap0k) [
1199: $[ .... ] k swap0k [....]$
1200: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
1201: $ define_ring$
1202: $swap01 == 1 swap0k$
1203: ]] putUsages
1204: %
1205: /swap0k {
1206: /arg2 set
1207: /arg1 set
1208: [/rg /ch /kk] pushVariables
1209: [
1210: arg2 /kk set
1211: arg1 0 get /rg set % ring
1212: arg1 1 get /ch set % characteristics
1213: [rg 0 get , rg 1 get , rg 2 get ,
1214: << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
1215: /arg1 [ rg ch ] def
1216: ] pop
1217: popVariables
1218: arg1
1219: } def
1220:
1221: %%%%%%%%%%%%% weight vector
1222: [(position)
1223: [(set element position number)
1224: (Example: [(cat) (dog) (hot chocolate)] (cat) position ===> 0.)
1225: ]
1226: ] putUsages
1227: /position {
1228: /arg2 set /arg1 set
1229: [/univ /elem /num /flag] pushVariables
1230: [
1231: /univ arg1 def
1232: /elem arg2 def
1233: /num -1 def /flag -1 def
1234: 0 1 << univ length 1 sub >>
1235: {
1236: /num set
1237: univ num get elem eq
1238: { /flag 0 def exit }
1239: { }
1240: ifelse
1241: } for
1242: flag -1 eq
1243: {/num -1 def}
1244: { }
1245: ifelse
1246: ] pop
1247: /arg1 num def
1248: popVariables
1249: arg1
1250: } def
1251:
1252:
1253: [(evecw)
1254: [(size position weight evecw [0 0 ... 0 weight 0 ... 0] )
1255: (Example: 3 0 113 evecw ===> [113 0 0])
1256: ]
1257: ] putUsages
1258: /evecw {
1259: /arg3 set /arg2 set /arg1 set
1260: [/size /iii /www] pushVariables
1261: /size arg1 def /iii arg2 def /www arg3 def
1262: [
1263: 0 1 << size 1 sub >>
1264: {
1265: iii eq
1266: { www }
1267: { 0 }
1268: ifelse
1269: } for
1270: ] /arg1 set
1271: popVariables
1272: arg1
1273: } def
1274:
1275: [(weight_vector)
1276: [ ([x-list d-list params] [[(name) weight ...] [...] ...] weight_vector)
1277: ([x-list d-list params order])
1278: (Example:)
1279: ( [(x,y,z) ring_of_polynomials [[(x) 100 (y) 10]] weight_vector 0] )
1280: ( define_ring )
1281: ]
1282: ] putUsages
1283: /weight_vector {
1284: /arg2 set /arg1 set
1285: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
1286: /vars arg1 def /w-vectors arg2 def
1287: [
1288: /univ vars 0 get reverse
1289: vars 1 get reverse join
1290: def
1291: [
1292: 0 1 << w-vectors length 1 sub >>
1293: {
1294: /k set
1295: univ w-vectors k get w_to_vec
1296: } for
1297: ] /order1 set
1298: %% order1 ::
1299:
1300: vars ( ) elimination_order 3 get /order2 set
1301: vars [ << order1 order2 join >> ] join /arg1 set
1302: ] pop
1303: popVariables
1304: arg1
1305: } def
1306:
1307: %% [@@@.esymbol (x) (y) (h)] [(x) 100 (y) 10] w_to_vec [0 100 10 0]
1308: %% univ www
1309: /w_to_vec {
1310: /arg2 set /arg1 set
1311: [/univ /www /k /vname /vweight /ans] pushVariables
1312: /univ arg1 def /www arg2 def
1313: [
1314: /ans << univ length >> -1 0 evecw def
1315: 0 2 << www length 2 sub >>
1316: {
1317: %% ans ::
1318: /k set
1319: www k get /vname set
1320: www << k 1 add >> get /vweight set
1321: << univ length >>
1322: << univ vname position >>
1323: vweight evecw
1324: ans add /ans set
1325: } for
1326: /arg1 ans def
1327: ] pop
1328: popVariables
1329: arg1
1330: } def
1331:
1332: %%%%%%%%%% end of weight_vector macro
1333:
1334: %%%%%%%% eliminatev macro
1335: [(eliminatev)
1336: [([g1 g2 g3 ...gm] [list of variables] eliminatev [r1 ... rp])
1337: (Example: [(x y z - 1). (z-1). (y-1).] [(x) (y)] eliminatev [ z-1 ])
1338: ]
1339: ] putUsages
1340: /eliminatev {
1341: /arg2 set /arg1 set
1342: [/gb /var /vars /ans /k] pushVariables
1343: [
1344: /gb arg1 def
1345: /vars arg2 def
1346: /ans gb def
1347: 0 1 << vars length 1 sub >> {
1348: /k set
1349: ans << vars k get >> eliminatev.tmp
1350: /ans set
1351: } for
1352: /arg1 ans def
1353: ] pop
1354: popVariables
1355: arg1
1356: } def
1357: /eliminatev.tmp {
1358: /arg2 set /arg1 set
1359: [/gb /degs /ans /n /var /ff /rr /gg] pushVariables
1360: [
1361: /gb arg1 def
1362: /var arg2 def
1363: /degs gb {
1364: /gg set
1365: gg (0). eq
1366: { 0 }
1367: { gg (ring) data_conversion /rr set
1368: gg << var rr ,, >> degree
1369: } ifelse
1370: } map def
1371: %%degs message
1372: /ans [
1373: 0 1 << gb length 1 sub >> {
1374: /n set
1375: << degs n get >> 0 eq
1376: { gb n get /ff set
1377: ff (0). eq
1378: { }
1379: { ff } ifelse
1380: }
1381: { } ifelse
1382: } for
1383: ] def
1384: /arg1 ans def
1385: ] pop
1386: popVariables
1387: arg1
1388: } def
1389:
1390: /eliminatev.tmp.org {
1391: /arg2 set /arg1 set
1392: [/gb /degs /ans /n /var /ff] pushVariables
1393: [
1394: /gb arg1 def
1395: /var arg2 def
1396: /degs gb {var . degree} map def
1397: /ans [
1398: 0 1 << gb length 1 sub >> {
1399: /n set
1400: << degs n get >> 0 eq
1401: { gb n get /ff set
1402: ff (0). eq
1403: { }
1404: { ff } ifelse
1405: }
1406: { } ifelse
1407: } for
1408: ] def
1409: /arg1 ans def
1410: ] pop
1411: popVariables
1412: arg1
1413: } def
1414: %%% end of eliminatev macro
1415:
1416: %%% macro for output
1417:
1418: [(isInteger)
1419: [(obj isInteger bool) ]
1420: ] putUsages
1421: /isInteger {
1422: (type?) data_conversion << 0 (type?) data_conversion >> eq
1423: } def
1424:
1425: [(isArray)
1426: [(obj isArray bool) ]
1427: ] putUsages
1428: /isArray {
1429: (type?) data_conversion << [ ] (type?) data_conversion >> eq
1430: } def
1431:
1432: [(isPolynomial)
1433: [(obj isPolynomial bool) ]
1434: ] putUsages
1435: /isPolynomial {
1436: (type?) data_conversion
1437: << [(x) (var) 0] system_variable . (type?) data_conversion >> eq
1438: } def
1439:
1440: [(isString)
1441: [(obj isString bool) ]
1442: ] putUsages
1443: /isString {
1444: (type?) data_conversion
1445: << (Hi) (type?) data_conversion >> eq
1446: } def
1447:
1448: [(isClass)
1449: [(obj isClass bool) ]
1450: ] putUsages
1451: /isClass {
1452: (type?) data_conversion ClassP eq
1453: } def
1454:
1455: [(isUniversalNumber)
1456: [(obj isUniversalNumber bool) ]
1457: ] putUsages
1458: /isUniversalNumber {
1459: (type?) data_conversion UniversalNumberP eq
1460: } def
1461:
1462: [(isDouble)
1463: [(obj isDouble bool) ]
1464: ] putUsages
1465: /isDouble {
1466: (type?) data_conversion DoubleP eq
1467: } def
1468:
1469: [(isRational)
1470: [(obj isRational bool) ]
1471: ] putUsages
1472: /isRational {
1473: (type?) data_conversion RationalFunctionP eq
1474: } def
1475:
1476: /toString.tmp {
1477: /arg1 set
1478: [/obj /fname] pushVariables
1479: /obj arg1 def
1480: [
1481: obj isArray
1482: {
1483: obj {toString.tmp} map
1484: }
1485: { } ifelse
1486: obj isInteger
1487: {
1488: obj (dollar) data_conversion %% not string. It returns the ascii code.
1489: }
1490: { } ifelse
1491: obj isPolynomial
1492: {
1493: obj (string) data_conversion
1494: }
1495: { } ifelse
1496: obj isString
1497: { obj }
1498: { } ifelse
1499: obj isUniversalNumber
1500: { obj (string) data_conversion } { } ifelse
1501: obj isDouble
1502: { obj (string) data_conversion } { } ifelse
1503: obj isRational
1504: { obj (string) data_conversion } { } ifelse
1505: obj tag 0 eq
1506: { (null) } { } ifelse
1507:
1508: %%% New code that uses a file.
1509: obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
1510: { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
1511: [(outputObjectToFile) fname obj] extension pop
1512: fname pushfile
1513: [(/bin/rm -rf ) fname] cat system
1514: } { } ifelse
1515: ] /arg1 set
1516: popVariables
1517: arg1 aload pop
1518: } def
1519:
1520:
1521:
1522: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
1523: /toString.tmp2 {
1524: /arg1 set
1525: [/obj /i /n /r] pushVariables
1526: [
1527: /obj arg1 def
1528: obj isArray
1529: {
1530: ( [ )
1531: obj {toString.tmp2} map /r set
1532: /n r length 1 sub def
1533: [0 1 n {
1534: /i set
1535: i n eq {
1536: r i get
1537: }
1538: { r i get ( , ) 2 cat_n }
1539: ifelse
1540: } for
1541: ] aload length cat_n
1542: ( ] )
1543: 3 cat_n
1544: }
1545: {
1546: obj
1547: } ifelse
1548: ] /arg1 set
1549: popVariables
1550: arg1 aload pop
1551: } def
1552:
1553:
1554: [(toString)
1555: [(obj toString)
1556: (Convert obj to a string.)
1557: (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ] ]$)
1558: ]
1559: ] putUsages
1560: /toString {
1561: /arg1 set
1562: [/obj ] pushVariables
1563: [
1564: /obj arg1 def
1565: obj isString
1566: { obj }
1567: { obj toString.tmp toString.tmp2 }
1568: ifelse /arg1 set
1569: ] pop
1570: popVariables
1571: arg1
1572: } def
1573:
1574: [(output)
1575: [(obj output) (Output the object to the standard file sm1out.txt)]
1576: ] putUsages
1577: /output {
1578: /arg1 set
1579: [/obj /fd ] pushVariables
1580: [
1581: /obj arg1 def
1582: (sm1out.txt) (a) file /fd set
1583: (Writing to sm1out.txt ...) messagen
1584: [ fd << obj toString >> writestring ] pop
1585: [ fd << 10 (string) data_conversion >> writestring ] pop
1586: ( Done.) message
1587: fd closefile
1588: ] pop
1589: popVariables
1590: } def
1591: %%%% end of macro for output.
1592: [(tag)
1593: [(obj tag integer)
1594: (tag returns datatype.)
1595: (cf. data_conversion)
1596: (Example: 2 tag IntegerP eq ---> 1)
1597: ]
1598: ] putUsages
1599: /etag {(type??) data_conversion} def
1600: [(etag)
1601: [(obj etag integer)
1602: (etag returns extended object tag. cf. kclass.c)
1603: ]
1604: ] putUsages
1605: /tag {(type?) data_conversion} def
1606: %% datatype constants
1607: /IntegerP 1 (type?) data_conversion def
1608: /LiteralP /arg1 (type?) data_conversion def %Sstring
1609: /StringP (?) (type?) data_conversion def %Sdollar
1610: /ExecutableArrayP { 1 } (type?) data_conversion def
1611: /ArrayP [ 0 ] (type?) data_conversion def
1612: /PolyP (1). (type?) data_conversion def
1613: /FileP 13 def
1614: /RingP 14 def
1615: /UniversalNumberP 15 def
1616: /RationalFunctionP 16 def
1617: /ClassP 17 def
1618: /DoubleP 18 def
1619: /@.datatypeConstant.usage [
1620: (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
1621: (UniversalNumberP, RationalFunctionP, ClassP, DoubleP)
1622: ( return data type identifiers.)
1623: (Example: 7 tag IntegerP eq ---> 1)
1624: ] def
1625: [(IntegerP) @.datatypeConstant.usage ] putUsages
1626: [(LiteralP) @.datatypeConstant.usage ] putUsages
1627: [(StringP) @.datatypeConstant.usage ] putUsages
1628: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
1629: [(ArrayP) @.datatypeConstant.usage ] putUsages
1630: [(PolyP) @.datatypeConstant.usage ] putUsages
1631: [(RingP) @.datatypeConstant.usage ] putUsages
1632: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
1633: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
1634: [(ClassP) @.datatypeConstant.usage ] putUsages
1635: [(DoubleP) @.datatypeConstant.usage ] putUsages
1636:
1637: [(,,)
1638: [( string ring ,, polynomial)
1639: (Parse the <<string>> as an element in the <<ring>> and returns)
1640: (the polynomial.)
1641: (cf. define_ring, define_qring, ring_def)
1642: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
1643: ( /myring set)
1644: ( ((x+y)^4) myring ,, /f set)
1645: ]] putUsages
1646:
1647: /,, {
1648: /arg2 set /arg1 set
1649: [/rrr] pushVariables
1650: [ arg1 tag StringP eq
1651: arg2 tag RingP eq and
1652: { [(CurrentRingp)] system_variable /rrr set
1653: [(CurrentRingp) arg2] system_variable
1654: /arg1 arg1 expand def
1655: [(CurrentRingp) rrr] system_variable
1656: }
1657: {(Argument Error for ,, ) error }
1658: ifelse
1659: ] pop
1660: popVariables
1661: arg1
1662: } def
1663:
1664: [(..)
1665: [( string .. universalNumber)
1666: (Parse the << string >> as a universalNumber.)
1667: (Example: (123431232123123).. /n set)
1668: ]] putUsages
1669: /.. { (universalNumber) data_conversion } def
1670:
1671: [(dc)
1672: [(Abbreviation of data_conversion.)
1673: ]] putUsages
1674: /dc { data_conversion } def
1675:
1676:
1677: %%% start of shell sort macro.
1678: [(and) [(obj1 obj2 and bool)]] putUsages
1679: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
1680:
1681: [(or) [(obj1 obj2 or bool)]] putUsages
1682: /or { add 1 copy 2 eq {pop 1} { } ifelse} def
1683:
1684: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
1685: %% 2 copy is equivalent to dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1686: /ge { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1687: eq {pop pop 1}
1688: { gt {1}
1689: {0}
1690: ifelse}
1691: ifelse} def
1692:
1693: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
1694: /le { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1695: eq {pop pop 1}
1696: { lt {1}
1697: {0}
1698: ifelse}
1699: ifelse} def
1700:
1701: [(break)
1702: [(bool break)]
1703: ] putUsages
1704: /break { {exit} { } ifelse } def
1705:
1706: /not { 0 eq {1} {0} ifelse} def
1707: /append { /arg2 set [arg2] join } def
1708:
1709: [(power)
1710: [(obj1 obj2 power obj3)
1711: $obj3 is (obj1)^(obj2). cf. npower$
1712: $Example: (2). 8 power :: ===> 256 $
1713: ]
1714: ] putUsages
1715: %% From SSWork/yacc/incmac.sm1
1716: %% f k power f^k
1717: /power {
1718: /arg2 set
1719: /arg1 set
1720: [/f /k /i /ans] pushVariables
1721: [
1722: /ans (1).. def
1723: /f arg1 def /k arg2 ..int def
1724: k 0 lt {
1725: 1 1 << 0 k sub >> {
1726: /ans f ans {mul} sendmsg2 def
1727: } for
1728: /ans (1).. ans {div} sendmsg2 def
1729: }
1730: {
1731: 1 1 k {
1732: /ans f ans {mul} sendmsg2 def
1733: } for
1734: } ifelse
1735: /arg1 ans def
1736: ] pop
1737: popVariables
1738: arg1
1739: } def
1740: [(..int)
1741: [ (universalNumber ..int int)]] putUsages
1742: /..int { %% universal number to int
1743: (integer) data_conversion
1744: } def
1745: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
1746: /SmallRing [(CurrentRingp)] system_variable def
1747:
1748: %%% From SSWork/yacc/lib/printSVector.modified.sm1
1749: %%% supporting code for printSVector.
1750: /greaterThanOrEqual {
1751: /arg2 set /arg1 set
1752: arg1 arg2 gt { 1 }
1753: { arg1 arg2 eq {1} {0} ifelse} ifelse
1754: } def
1755:
1756: /lengthUniv {
1757: length (universalNumber) dc
1758: } def
1759:
1760: /getUniv {
1761: (integer) dc get
1762: } def %% Do not forget to thow away /.
1763:
1764: %%[(@@@.printSVector)
1765: %% [( vector @@@.printSVector outputs the <<vector>> in a pretty way.)
1766: %% ( The elements of the vector must be strings.)
1767: %% ]
1768: %%] putUsages
1769:
1770: %%% compiled code by d0, 1996, 8/17.
1771: /@@@.printSVector {
1772: /arg1 set
1773: [ %%start of local variables
1774: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
1775: /keys arg1 def
1776: /n
1777: keys lengthUniv
1778: def
1779: /max (0).. def
1780: /i (0).. def
1781: %%for init.
1782: %%for
1783: { i n lt
1784: { } {exit} ifelse
1785: [ {%%increment
1786: /i i (1).. add def
1787: } %%end of increment{A}
1788: {%%start of B part{B}
1789: keys i getUniv lengthUniv
1790: max gt
1791: %% if-condition
1792: { %%ifbody
1793: /max
1794: keys i getUniv lengthUniv
1795: def
1796: }%%end if if body
1797: { %%if- else part
1798: } ifelse
1799: } %% end of B part. {B}
1800: 2 1 roll] {exec} map
1801: } loop %%end of for
1802: /max max (3).. add
1803: def
1804: /width (80).. def
1805: /m (0).. def
1806:
1807: %%while
1808: { m max mul
1809: (80).. lt
1810: { } {exit} ifelse
1811: /m m (1).. add
1812: def
1813: } loop
1814: /k (0).. def
1815: /kk (0).. def
1816: /i (0).. def
1817: %%for init.
1818: %%for
1819: { i n lt
1820: { } {exit} ifelse
1821: [ {%%increment
1822: /i i (1).. add def
1823: } %%end of increment{A}
1824: {%%start of B part{B}
1825: keys i getUniv messagen
1826: /kk kk (1).. add
1827: def
1828: /k k
1829: keys i getUniv lengthUniv
1830: add
1831: def
1832: /tmp0 max
1833: keys i getUniv lengthUniv
1834: sub
1835: def
1836: /j (0).. def
1837: %%for init.
1838: %%for
1839: { j tmp0 lt
1840: { } {exit} ifelse
1841: [ {%%increment
1842: /j j (1).. add def
1843: } %%end of increment{A}
1844: {%%start of B part{B}
1845: /k k (1).. add
1846: def
1847: kk m lt
1848: %% if-condition
1849: { %%ifbody
1850: ( ) messagen
1851: }%%end if if body
1852: { %%if- else part
1853: } ifelse
1854: } %% end of B part. {B}
1855: 2 1 roll] {exec} map
1856: } loop %%end of for
1857: kk m greaterThanOrEqual
1858: %% if-condition
1859: { %%ifbody
1860: /kk (0).. def
1861: /k (0).. def
1862: newline
1863: }%%end if if body
1864: { %%if- else part
1865: } ifelse
1866: } %% end of B part. {B}
1867: 2 1 roll] {exec} map
1868: } loop %%end of for
1869: newline
1870: /ExitPoint ]pop popVariables %%pop the local variables
1871: } def
1872: %%end of function
1873:
1874: /rest { % returns remainder of a given list
1875: [ 2 1 roll aload length -1 roll pop ]
1876: } def
1877: [(rest)
1878: [(array rest the-rest-of-the-array)
1879: (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
1880: ]
1881: ] putUsages
1882:
1883: %% from SSkan/develop/minbase.sm1
1884: /reducedBase {
1885: /arg1 set
1886: [/base /minbase /n /i /j /myring /zero /f] pushVariables
1887: [
1888: /base arg1 def
1889: base isArray { }
1890: { (The argument of reducedBase must be an array of polynomials)
1891: error
1892: } ifelse
1893: base 0 get isPolynomial { }
1894: { (The element of the argument of reducedBase must be polynomials)
1895: error
1896: } ifelse
1897: /myring base 0 get (ring) dc def
1898: /zero (0) myring ,, def
1899: base length 1 sub /n set
1900: /minbase [ 0 1 n { /i set base i get } for ] def
1901: 0 1 n {
1902: /i set
1903: minbase i get /f set
1904: f zero eq {
1905: }
1906: {
1907: 0 1 n {
1908: /j set
1909: << minbase j get zero eq >> << i j eq >> or {
1910: }
1911: {
1912: [(isReducible) << minbase j get >> f] gbext
1913: {
1914: minbase j zero put
1915: }
1916: { } ifelse
1917: } ifelse
1918: } for
1919: } ifelse
1920: } for
1921: minbase { minbase.iszero } map /arg1 set
1922: ] pop
1923: popVariables
1924: arg1
1925: } def
1926:
1927: [(reducedBase)
1928: [(base reducedBase reducedBase)
1929: (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
1930: (returns <<reducedBase>>.)
1931: (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
1932: ]
1933: ] putUsages
1934:
1935: %% package functions
1936: /minbase.iszero {
1937: dup (0). eq {
1938: pop
1939: }
1940: { } ifelse
1941: } def
1942:
1943: /== {
1944: message
1945: } def
1946: [(==)
1947: [(obj ==)
1948: (Print obj)
1949: ]
1950: ] putUsages
1951:
1952: /@@@.all_variables {
1953: [/n /i] pushVariables
1954: [
1955: /n [(N)] system_variable def
1956: [
1957: 0 1 n 1 sub {
1958: /i set
1959: [(x) (var) i] system_variable
1960: } for
1961: 0 1 n 1 sub {
1962: /i set
1963: [(D) (var) i] system_variable
1964: } for
1965: ] /arg1 set
1966: ] pop
1967: popVariables
1968: arg1
1969: } def
1970:
1971: /weightv {
1972: @@@.all_variables
1973: 2 1 roll w_to_vec
1974: } def
1975:
1976: [(weightv)
1977: [(array weightv weight_vector_for_init)
1978: (cf. init)
1979: (Example: /w [(x) 10 (h) 2] weightv def)
1980: ( ((x-h)^10). w init ::)
1981: ]
1982: ] putUsages
1983:
1984: /output_order {
1985: /arg1 set
1986: [/vars /vlist /perm /total /ans] pushVariables
1987: [
1988: /vlist arg1 def
1989: /vars @@@.all_variables def
1990: vlist { vars 2 1 roll position } map /perm set
1991: perm ==
1992: /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
1993: perm perm total complement join /ans set
1994: [(outputOrder) ans] system_variable
1995: ] pop
1996: popVariables
1997: } def
1998:
1999: [(output_order)
2000: [$ [(v1) (v2) ...] output_order $
2001: (Set the order of variables to print for the current ring.)
2002: (cf. system_variable)
2003: (Example: [(y) (x)] output_order)
2004: $ (x*y). :: ===> y*x $
2005: ]
2006: ] putUsages
2007:
2008: %% destraction. SSkan/Kan/debug/des.sm1, 1998, 2/27 , 3/1
2009: %% should be included in dr.sm1
2010:
2011: /factorial {
2012: /arg2 set
2013: /arg1 set
2014: [ /f /n ] pushVariables
2015: [
2016: /f arg1 def
2017: /n arg2 def
2018: /ans (1).. def
2019: n 0 lt { (f n factorial : n must be a non-negative integer)
2020: error } { } ifelse
2021: 0 1 n 1 sub {
2022: (universalNumber) dc /i set
2023: ans << f i sub >> mul /ans set
2024: } for
2025: /arg1 ans def
2026: ] pop
2027: popVariables
2028: arg1
2029: } def
2030:
2031: [(factorial)
2032: [(f n factorial g)
2033: $integer n, g is f (f-1) ... (f-n+1)$
2034: ]
2035: ] putUsages
2036:
2037:
2038: /destraction1 {
2039: /arg4 set
2040: /arg3 set
2041: /arg2 set
2042: /arg1 set
2043: [/ww /f /dx /ss /xx /coeff0 /expvec
2044: /coeffvec /expvec2 /ans /one] pushVariables
2045: [
2046: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2047: /one (1). def %%
2048: /ww [ xx toString -1 dx toString 1 ] weightv def
2049: f ww init f sub (0). eq { }
2050: { [(destraction1 : inhomogeneous with respect to )
2051: xx ( and ) dx ] cat error } ifelse
2052: f [[xx one]] replace dx coefficients /coeff0 set
2053: /expvec coeff0 0 get { (integer) dc } map def
2054: /coeffvec coeff0 1 get def
2055: expvec { ss 2 -1 roll factorial } map /expvec2 set
2056: expvec2 coeffvec mul /ans set
2057: /arg1 ans def
2058: ] pop
2059: popVariables
2060: arg1
2061: } def
2062:
2063:
2064: /distraction {
2065: /arg4 set
2066: /arg3 set
2067: /arg2 set
2068: /arg1 set
2069: [/f /dx /ss /xx /ans /n /i] pushVariables
2070: [(CurrentRingp)] pushEnv
2071: [
2072: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2073: f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
2074: /n xx length def
2075: 0 1 n 1 sub {
2076: /i set
2077: /f f xx i get dx i get ss i get destraction1 /f set
2078: } for
2079: /dist1.L
2080: /arg1 f def
2081: ]pop
2082: popEnv
2083: popVariables
2084: arg1
2085: } def
2086: [(distraction)
2087: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2088: ( distraction result )
2089: $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
2090: ]
2091: ] putUsages
2092: /destraction { distraction } def
2093:
2094:
2095:
2096:
2097: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2098: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2099: %%%%%%%%%%%%%%%% sorting
2100: %/N 1000 def
2101: %/a.shell [N -1 0 { } for ] def
2102: %a.shell 0 -1000 put
2103: %% You need gate keeper.
2104: [(shell)
2105: [([gate-keeper f1 f2 ... fm] shell result)
2106: (Sort the list. Gate-keeper should be the smallest element)]
2107: ] putUsages
2108: /shell {
2109: /arg1 set
2110: [/N /a.shell /h /i /v /j] pushVariables
2111: [
2112: /a.shell arg1 def
2113: /N a.shell length 1 sub def
2114:
2115: /h 1 def
2116: {/h h 3 mul 1 add def
2117: << h N ge >> break
2118: } loop
2119: {
2120: /h << h 3 idiv >> def
2121: << h 1 add >> 1 N {
2122: /i set
2123: /v a.shell i get def
2124: /j i def
2125: {
2126: %% a.shell print newline
2127: << a.shell << j h sub >> get >> v le break
2128: a.shell j << a.shell << j h sub >> get >> put
2129: /j j h sub def
2130: j h le break
2131: } loop
2132: a.shell j v put
2133: } for
2134: h 1 lt break
2135: } loop
2136: /arg1 a.shell def
2137: ] pop
2138: popVariables
2139: arg1
2140: } def
2141: %%%% end of shell sort macro
2142:
2143: /variableNames {
2144: /arg1 set
2145: [/in-variableNames /rrr /nnn /i /cp] pushVariables
2146: [
2147: /rrr arg1 def
2148: [(CurrentRingp)] system_variable /cp set
2149: [(CurrentRingp) rrr] system_variable
2150: [(N)] system_variable /nnn set
2151: [ 0 1 nnn 1 sub {
2152: /i set [(x) (var) i] system_variable } for ]
2153: [ 0 1 nnn 1 sub {
2154: /i set [(D) (var) i] system_variable } for ]
2155: join /arg1 set
2156: [(CurrentRingp) cp] system_variable
2157: ] pop
2158: popVariables
2159: arg1
2160: } def
2161:
2162:
2163: /makeRingMap {
2164: /arg3 set /arg2 set /arg1 set
2165: [/in-makeRingMap /corres /M /N /corresM /corresN
2166: /vars /vars-org /i /p /ans /cp] pushVariables
2167: [
2168: /corres arg1 def /M arg2 def /N arg3 def
2169: /corresM corres 0 get def
2170: /corresN corres 1 get def
2171: [(CurrentRingp)] system_variable /cp set
2172: [(CurrentRingp) M] system_variable
2173: M variableNames /vars set vars 1 copy /vars-org set
2174: 0 1 corresM length 1 sub {
2175: /i set
2176: vars corresM i get position /p set
2177: p -1 gt {
2178: vars p $($ corresN i get $)$ 3 cat_n put
2179: } { } ifelse
2180: } for
2181: /arg1 [vars M N vars-org] def
2182: [(CurrentRingp) cp] system_variable
2183: ] pop
2184: popVariables
2185: arg1
2186: } def
2187:
2188:
2189:
2190: /ringmap {
2191: /arg2 set /arg1 set
2192: [/in-ringmap /f /M2N /cp /f2] pushVariables
2193: [
2194: /f arg1 def /M2N arg2 def
2195: [(CurrentRingp)] system_variable /cp set
2196: f (0). eq { /f2 f def }
2197: {
2198: %f (ring) dc M2N 1 get eq
2199: %{ }
2200: %{ (The argument polynomial does not belong to the domain ring.) message
2201: % error
2202: % } ifelse
2203: [(CurrentRingp) M2N 1 get] system_variable
2204: [(variableNames) M2N 0 get] system_variable
2205: f toString /f2 set
2206: [(variableNames) M2N 3 get] system_variable
2207: f2 M2N 2 get ,, /f2 set
2208: } ifelse
2209: [(CurrentRingp) cp] system_variable
2210: /arg1 f2 def
2211: ] pop
2212: popVariables
2213: arg1
2214: } def
2215:
2216: [(makeRingMap)
2217: [( rule ring1 ring2 makeRingMap maptable )
2218: (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
2219: ]
2220: ] putUsages
2221: [(ringmap)
2222: [(f mapTable ringmap r)
2223: (f is mapped to r where the map is defined by the mapTable, which is generated)
2224: (by makeRingMap as follows:)
2225: ( rule ring1 ring2 makeRingMap maptable )
2226: $Example:$
2227: $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2228: $/R1 set$
2229: $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2230: $/R2 set$
2231: $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
2232: $r0 R1 R2 makeRingMap /maptable set$
2233: $(Dx-1) R1 ,, /ff set$
2234: $ ff maptable ringmap :: $
2235: ]
2236: ] putUsages
2237:
2238:
2239: /getVariableNames {
2240: [/in-getVariableNames /ans /i /n] pushVariables
2241: [
2242: /n [(N)] system_variable def
2243: [
2244: n 1 sub -1 0 {
2245: /i set
2246: [(x) (var) i] system_variable
2247: } for
2248: n 1 sub -1 0{
2249: /i set
2250: [(D) (var) i] system_variable
2251: } for
2252: ] /arg1 set
2253: ] pop
2254: popVariables
2255: arg1
2256: } def
2257: [(getVariableNames)
2258: [(getVariableNames list-of-variables)
2259: (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
2260: ]
2261: ] putUsages
2262:
2263: /tolower {
2264: /arg1 set
2265: [/in-tolower /s /sl] pushVariables
2266: [
2267: /s arg1 def
2268: s (array) dc /s set
2269: s { tolower.aux (string) dc } map /sl set
2270: sl aload length cat_n /arg1 set
2271: ] pop
2272: popVariables
2273: arg1
2274: } def
2275:
2276: /tolower.aux {
2277: /arg1 set
2278: arg1 64 gt arg1 96 lt and
2279: { arg1 32 add }
2280: { arg1 } ifelse
2281: } def
2282: [(tolower)
2283: [(string tolower string2)
2284: (Capital letters in string are converted to lower case letters.)
2285: $Example: (Hello World) tolower :: (hello world)$
2286: ]
2287: ] putUsages
2288:
2289: /hilbert {
2290: /arg2 set
2291: /arg1 set
2292: [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
2293: [
2294: /base arg1 def
2295: /vlist arg2 def
2296: [(CurrentRingp)] system_variable /rrrorg set
2297: /strf 0 def
2298: vlist isString
2299: { /vlist [ vlist to_records pop ] def }
2300: { } ifelse
2301: base isArray { }
2302: { (hilb : the first argument must be an array of polynomials.)
2303: error
2304: } ifelse
2305: vlist isArray { }
2306: { (hilb : the second argument must be an array of polynomials.)
2307: error
2308: } ifelse
2309:
2310: vlist 0 get isString{ /strf 1 def } { } ifelse
2311: base 0 get isPolynomial {
2312: base 0 get (ring) dc /rrr set
2313: }
2314: {
2315: [ vlist { (,) } map aload length cat_n ring_of_polynomials 0 ] define_ring
2316: /rrr set
2317: base { . } map /base set
2318: } ifelse
2319: vlist { dup isPolynomial { } { rrr ,, } ifelse } map /vlist set
2320:
2321: [(hilbert) base vlist] extension /ff set
2322: [(CurrentRingp) rrrorg] system_variable
2323: /arg1 ff def
2324: ] pop
2325: popVariables
2326: arg1
2327: } def
2328:
2329: /hilbReduce {
2330: /arg2 set
2331: /arg1 set
2332: [/hhh /f /d /vv /ans] pushVariables
2333: [
2334: /hhh arg1 def %% hilbert function
2335: /vv arg2 def
2336: /f hhh 1 get def
2337: f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
2338: f vv << f (ring) dc >> ,, degree /vv set
2339: hhh 0 get /d set
2340: d d (integer) dc factorial /d set
2341: d << vv (universalNumber) dc vv factorial >> idiv /d set
2342: [(divByN) f d] gbext /ans set
2343: ans 1 get (0). eq
2344: { }
2345: { (hilbReduce : Invalid hilbert function ) error } ifelse
2346: /hilbReduce.label
2347: ans 0 get /arg1 set
2348: ] pop
2349: popVariables
2350: arg1
2351: } def
2352:
2353:
2354: [(hilbReduce)
2355: [([f,g] v hilbReduce p)
2356: (output of hilbert [f,g]; string v; poly p)
2357: (p is (g/(f!))*deg(g)!)
2358: $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
2359: ]
2360: ] putUsages
2361: [(hilbert)
2362: [(base vlist hilbert [m f])
2363: (array of poly base; array of poly vlist; number m; poly f;)
2364: (array of string base; array of string vlist; number m; poly f;)
2365: (array of string base; string vlist; number m; poly f;)
2366: ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
2367: (The << base >> should be a reduced Grobner basis.)
2368: (Or, when the << base >> is an array of string,)
2369: (all entries should be monomials.)
2370: (Example: [(x^2) (x y )] (x,y) hilbert :: [2, 2 h + 4] )
2371: (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce :: 4)
2372: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce :: 3)
2373: (cf. hilb, hilbReduce)
2374: ]
2375: ] putUsages
2376:
2377: /hilb {
2378: hilbert (h) hilbReduce
2379: } def
2380: [(hilb)
2381: [(base vlist hilb f)
2382: (array of poly base; array of poly vlist; poly f;)
2383: (array of string base; array of string vlist; poly f;)
2384: (array of string base; string vlist; number m; poly f;)
2385: (f is the hilbert function (a_d x^d + ...)/m!)
2386: (The << base >> should be a reduced Grobner basis.)
2387: (Or, when the << base >> is an array of string,)
2388: (all entries should be monomials.)
2389: (Example: [(x^2) (x y )] (x,y) hilb :: h + 2 )
2390: (Example: [(x^2) (y^2)] (x,y) hilb 4)
2391: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb :: 3)
2392: (cf. hilbert, hilbReduce)
2393: ]
2394: ] putUsages
2395:
2396: [(diff0)
2397: [ (f v n diff0 fn)
2398: (<poly> fn, v ; <integer> n ; <poly> fn)
2399: (fn = v^n f where v^n is the operator to take the n-th differential.)
2400: (We can use diff0 only in the ring of differential operators.)
2401: (Example: [(x) ring_of_differential_operators 0] define_ring )
2402: ( (x^10-x). (Dx). 1 diff0 ::)
2403: ]
2404: ] putUsages
2405: /diff0 {
2406: /arg3 set /arg2 set /arg1 set
2407: [/in-diff /f /v /n /fn /rrr] pushVariables
2408: [
2409: /f arg1 def /v arg2 def /n arg3 def
2410: f (0). eq
2411: { /fn (0). def }
2412: {
2413: f (ring) dc /rrr set
2414: v toString (^) n toString 3 cat_n rrr ,,
2415: f mul
2416: [[v (0).] [(h) rrr ,, (1) rrr ,,]] replace /fn set
2417: } ifelse
2418: fn /arg1 set
2419: ] pop
2420: popVariables
2421: arg1
2422: } def
2423:
2424: [(action)
2425: [( f g action p )
2426: (<poly> f,g,p)
2427: (Act f on g. The result is p. The homogenization variable h is put to 1.)
2428: (We can use diff0 only in the ring of differential operators.)
2429: (Example: [(x) ring_of_differential_operators 0] define_ring )
2430: ( (Dx^2). (x^2). action ::)
2431: ]
2432: ] putUsages
2433: /action {
2434: /arg2 set /arg1 set
2435: [/in-action /f /g /h /rr /rr.org /rule] pushVariables
2436: [
2437: /f arg1 def /g arg2 def
2438: /rr.org [(CurrentRingp)] system_variable def
2439: f (0). eq
2440: { /h (0). def }
2441: {
2442: f (ring) dc /rr set
2443: [(CurrentRingp) rr] system_variable
2444: f g mul /h set
2445: /rule getVariableNames def
2446: 0 1 rule length 2 idiv { rule rest /rule set } for
2447: rule { . [ 2 1 roll (0). ] } map /rule set
2448: rule << rule length 1 sub >> [(h). (1).] put
2449: %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
2450: /h h rule replace def
2451: } ifelse
2452: [(CurrentRingp) rr.org ] system_variable
2453: /arg1 h def
2454: ] pop
2455: popVariables
2456: arg1
2457: } def
2458:
2459: [(ord_w)
2460: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2461: (poly ff; string v1; integer w1; ...)
2462: (order of ff by the weight vector [w1 w2 ...])
2463: (Example: [(x,y) ring_of_polynomials 0] define_ring )
2464: ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
2465: ]
2466: ] putUsages
2467: /ord_w {
2468: /arg2 set /arg1 set
2469: [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
2470: [
2471: /fff arg1 def
2472: /www arg2 def
2473: fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
2474: fff (ring) dc /rrr set
2475: fff init /fff set
2476: /ddd 0 def
2477: 0 2 www length 1 sub {
2478: /iii set
2479: fff << www iii get rrr ,, >> degree
2480: << www iii 1 add get >> mul
2481: ddd add /ddd set
2482: } for
2483: /ord_w.LLL
2484: /arg1 ddd def
2485: ] pop
2486: popVariables
2487: arg1
2488: } def
2489:
2490: [(laplace0)
2491: [
2492: (f [v1 ... vn] laplace0 g)
2493: (poly f ; string v1 ... vn ; poly g;)
2494: (array of poly f ; string v1 ... vn ; array of poly g;)
2495: ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
2496: $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
2497: $ x --> -Dx, Dx --> x, y --> -Dy, Dy --> y. $
2498: ]
2499: ] putUsages
2500: /laplace0 {
2501: /arg2 set /arg1 set
2502: [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
2503: ] pushVariables
2504: [
2505: /ff arg1 def /vv arg2 def
2506: /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
2507: /rule [ ] def
2508: ff isPolynomial {
2509: ff (0). eq { /ans1 (0). def }
2510: {
2511: ff (ring) dc /rr set
2512: /nn vv length def
2513: 0 1 nn 1 sub {
2514: /ii set
2515: vv ii get (type?) dc 1 eq
2516: { } % skip, may be weight [(x) 2 ] is OK.
2517: {
2518: /v0 vv ii get (string) dc def
2519: v0 (array) dc 0 get Dascii eq %% If the first character is D?
2520: { rule %% Dx-->x
2521: [v0 rr ,,
2522: v0 (array) dc rest { (string) dc} map aload length cat_n rr ,,]
2523: append /rule set
2524: }
2525: { rule %% x --> -Dx
2526: [v0 rr ,,
2527: (0).
2528: [Dascii] v0 (array) dc join { (string) dc } map aload length
2529: cat_n rr ,, sub
2530: ]
2531: append /rule set
2532: } ifelse
2533: } ifelse
2534: } for
2535: % rule message
2536: ff rule replace [[(h) rr ,, (1) rr ,,]] replace /ans1 set
2537: } ifelse
2538: }
2539: {
2540: ff isArray { /ans1 ff {vv laplace0 } map def }
2541: {
2542: (laplace0 : the first argument must be a polynomial.) error
2543: }ifelse
2544: } ifelse
2545: /arg1 ans1 def
2546: ] pop
2547: popVariables
2548: arg1
2549: } def
2550:
2551: [(ip1)
2552: [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
2553: (<poly> v1 ... vn ; <integer> w1 ... wn m)
2554: (<poly> f1 ... fs )
2555: (Example: [(x,y) ring_of_differential_operators 0] define_ring )
2556: ( [(Dx). (Dy).] [2 1] 3 ip1 :: [(2 Dx Dy). (Dy^3).])
2557: ( Returns Dx^p Dy^q such that 2 p + 1 q = 3.)
2558: ]
2559: ] putUsages
2560: /ip1 {
2561: /arg3 set /arg2 set /arg1 set
2562: [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
2563: [
2564: /vv arg1 def /ww arg2 def /m arg3 def
2565: vv 0 get (ring) dc /rr set
2566: /rr.org [(CurrentRingp)] system_variable def
2567: [(CurrentRingp) rr] system_variable
2568: [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
2569: /ans [ ] def
2570: m 0 lt
2571: { }
2572: {
2573: vv
2574: ww { tt 2 1 roll power } map mul /tmp1 set
2575: %% (tmp1 = ) messagen tmp1 message
2576: 0 1 m {
2577: /k set
2578: k 0 eq {
2579: /ff (1). def
2580: }
2581: { tmp1 k power /ff set } ifelse
2582: ff [[(h). (1).]] replace /ff set
2583: %% ff message
2584: {
2585: ff init tt degree m eq {
2586: /ans ans [ ff init [[tt (1).]] replace ] join def
2587: } { } ifelse
2588: ff ff init sub /ff set
2589: ff (0). eq { exit } { } ifelse
2590: } loop
2591: } for
2592: } ifelse
2593: [(CurrentRingp) rr.org] system_variable
2594: /arg1 ans def
2595: ] pop
2596: popVariables
2597: arg1
2598: } def
2599:
2600: [(findIntegralRoots)
2601: [( f findIntegralRoots vlist)
2602: (poly f; list of integers vlist;)
2603: (string f; list of integers vlist;)
2604: (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
2605: (Example: (s^4-1) findIntegralRoots )
2606: ]
2607: ] putUsages
2608:
2609: /findIntegralRoots { findIntegralRoots.slow } def
2610:
2611: /findIntegralRoots.slow { %% by a stupid algorithm
2612: /arg1 set
2613: [/in-findIntegralRoots
2614: /ff /kk /roots /rrr /nn /k0 /d.find
2615: ] pushVariables
2616: [
2617: /ff arg1 def
2618: /roots [ ] def
2619: /rrr [(CurrentRingp)] system_variable def
2620: ff toString /ff set
2621: [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
2622: ff . /ff set
2623:
2624: %%ff message %% Cancel the common numerical factor of the polynomial ff.
2625: ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
2626: [(divByN) ff d.find] gbext 0 get /ff set
2627: %% d.find message
2628: %% ff message
2629:
2630: ff [[(s). (0).]] replace /k0 set
2631: k0 (universalNumber) dc /k0 set
2632: k0 (0).. eq { roots (0).. append /roots set } { } ifelse
2633:
2634: {
2635: ff [[(s). (0).]] replace /nn set
2636: nn (universalNumber) dc /nn set
2637: nn (0).. eq
2638: { (s^(-1)). ff mul /ff set }
2639: { exit }
2640: ifelse
2641: } loop
2642: ff [[(s). (0).]] replace /k0 set
2643: k0 (universalNumber) dc /k0 set
2644: k0 (-40000).. gt k0 (40000).. lt and not {
2645: [(Roots of b-function cannot be obtained by a stupid method.) nl
2646: (Use ox_asir for efficient factorizations, or restall and bfm manually.)
2647: nl
2648: (ox_asir server will be distributed from the asir ftp cite.) nl
2649: (See lib/ttt.tex for details.) nl
2650: ] cat
2651: error
2652: } { } ifelse
2653: nn (0).. lt { (0).. nn sub /nn set } { } ifelse
2654: /kk (0).. nn sub def
2655: /roots [ kk (1).. sub ] roots join def
2656: {
2657: kk nn gt { exit } { } ifelse
2658: ff [[(s). kk (poly) dc]] replace
2659: (0). eq
2660: { /roots roots kk append def }
2661: { } ifelse
2662: kk (1).. add /kk set
2663: } loop
2664: [(CurrentRingp) rrr] system_variable
2665: roots { (integer) dc } map /roots set %% ?? OK?
2666: roots shell rest /roots set
2667: /arg1 roots def
2668: ] pop
2669: popVariables
2670: arg1
2671: } def
2672:
2673: /ngcd {
2674: /arg1 set
2675: [/in-ngcd /nlist /g.ngcd /ans] pushVariables
2676: [
2677: /nlist arg1 def
2678: nlist length 2 lt
2679: { /ans nlist 0 get def /L.ngcd goto }
2680: {
2681: [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
2682: g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
2683: [g.ngcd] nlist rest rest join ngcd /ans set
2684: } ifelse
2685: /L.ngcd
2686: ans /arg1 set
2687: ] pop
2688: popVariables
2689: arg1
2690: } def
2691:
2692: [(ngcd)
2693: [(nlist ngcd d )
2694: (list of numbers nlist; number d;)
2695: (d is the gcd of the numbers in nlist.)
2696: (Example: [(12345).. (67890).. (98765)..] ngcd )
2697: ]] putUsages
2698:
2699: /dehomogenize {
2700: /arg1 set
2701: [/in-dehomogenize /f /rr /ans /cring] pushVariables
2702: [
2703: /f arg1 def
2704: f isPolynomial {
2705: f (0). eq
2706: { f /ans set }
2707: {
2708: f (ring) dc /rr set
2709: [(CurrentRingp)] system_variable /cring set
2710: [(CurrentRingp) rr] system_variable
2711: f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
2712: [(CurrentRingp) cring] system_variable
2713: } ifelse
2714: }
2715: {
2716: f isArray {
2717: f { dehomogenize } map /ans set
2718: }
2719: {(dehomogenize: argument should be a polynomial.) error }
2720: ifelse
2721: } ifelse
2722: /arg1 ans def
2723: ] pop
2724: popVariables
2725: arg1
2726: } def
2727:
2728: [(dehomogenize)
2729: [(obj dehomogenize obj2)
2730: (dehomogenize puts the homogenization variable to 1.)
2731: (Example: (x*h+h^2). dehomogenize :: x+1 )
2732: ]
2733: ] putUsages
2734:
2735:
2736: /from_records { { (,) } map aload length cat_n } def
2737: [(from_records)
2738: [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
2739: (Example : [(x) (y)] from_records :: (x,y,))
2740: (cf. to_records)
2741: ]
2742: ] putUsages
2743: /popEnv {
2744: { system_variable pop } map pop
2745: } def
2746:
2747: /pushEnv {
2748: %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
2749: { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
2750: } def
2751: [(pushEnv)
2752: [(keylist pushEnv envlist)
2753: (array of string keylist, array of [string object] envlist;)
2754: (Values <<envlist>> of the global system variables specified )
2755: (by the <<keylist>> is push on the stack.)
2756: (keylist is an array of keywords for system_variable.)
2757: (cf. system_variable, popEnv)
2758: (Example: [(CurrentRingp) (KanGBmessage)] pushEnv)
2759: ]
2760: ] putUsages
2761: [(popEnv)
2762: [(envlist popEnv)
2763: (cf. pushEnv)
2764: ]
2765: ] putUsages
2766:
2767: /npower {
2768: /arg2 set
2769: /arg1 set
2770: [/f /k /i /ans] pushVariables
2771: [
2772: /f arg1 def /k arg2 ..int def
2773: f tag PolyP eq {
2774: /ans (1). def
2775: } {
2776: /ans (1).. def
2777: } ifelse
2778: k 0 lt {
2779: 1 1 << 0 k sub >> {
2780: /ans f ans {mul} sendmsg2 def
2781: } for
2782: /ans (1).. ans {div} sendmsg2 def
2783: }
2784: {
2785: 1 1 k {
2786: /ans f ans {mul} sendmsg2 def
2787: } for
2788: } ifelse
2789: /arg1 ans def
2790: ] pop
2791: popVariables
2792: arg1
2793: } def
2794: [(npower)
2795: [(obj1 obj2 npower obj3)
2796: (npower returns obj1^obj2 as obj3)
2797: (The difference between power and npower occurs when we compute f^0)
2798: (where f is a polynomial.)
2799: $power returns number(universalNumber) 1, but npower returns 1$
2800: (in the current ring.)
2801: ]
2802: ] putUsages
2803:
2804: /gensym {
2805: (dollar) dc 2 cat_n
2806: } def
2807: [(gensym)
2808: [(x i gensym xi)
2809: (string x; integer i; string xi)
2810: (It generate a string x indexed with the number i.)
2811: $Example: (Dx) 12 gensym (Dx12)$
2812: ]
2813: ] putUsages
2814:
2815: /cat {
2816: { toString } map aload length cat_n
2817: } def
2818: [(cat)
2819: [(a cat s)
2820: (array a ; string s;)
2821: (cat converts each entry of << a >> to a string and concatenates them.)
2822: (Example: [ (x) 1 2] cat ==> (x12))
2823: ]
2824: ] putUsages
2825:
2826:
2827: %%%%%%%%%%%%%%%%%%% pmat-level
2828: /pmat-level {
2829: /arg2 set
2830: /arg1 set
2831: [/n /i /m /lev /flag] pushVariables
2832: [
2833: /m arg1 def
2834: /lev arg2 def
2835: m isArray {
2836: /n m length def
2837: n 0 eq { /flag 0 def }
2838: { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
2839: } { /flag 0 def } ifelse
2840:
2841: flag {
2842: 0 1 lev {
2843: pop ( ) messagen
2844: } for
2845: ([ ) message
2846: 0 1 n 1 sub {
2847: /i set
2848: m i get lev 1 add pmat-level
2849: } for
2850: 0 1 lev {
2851: pop ( ) messagen
2852: } for
2853: (]) message
2854: }
2855: {
2856: 0 1 lev {
2857: pop ( ) messagen
2858: } for
2859: ( ) messagen
2860: m message
2861: } ifelse
2862: ] pop
2863: popVariables
2864: } def
2865:
2866: /pmat { 0 pmat-level } def
2867:
2868: [(pmat)
2869: [(f pmat)
2870: (array f;)
2871: (f is pretty printed.)
2872: ]
2873: ] putUsages
2874:
2875:
2876: /adjoint1 {
2877: /arg2 set
2878: /arg1 set
2879: [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
2880: [
2881: /f arg1 def
2882: /xx arg2 def
2883: f isPolynomial { }
2884: { (adjoint1: the first argument must be a polynomial.) message
2885: pop popVariables
2886: (adjoint1: the first argument must be a polynomial.) error
2887: } ifelse
2888: /ans (0). def
2889: f (0). eq { }
2890: {
2891: /xx xx (string) dc def
2892: /dxx [@@@.Dsymbol xx] cat def
2893: /xx xx f (ring) dc ,, def
2894: /dxx dxx f (ring) dc ,, def
2895: /one (1) f (ring) dc ,, def
2896:
2897: {
2898: /g f init def
2899: /f f g sub def
2900: /p g xx degree def
2901: /q g dxx degree def
2902: g [[xx one] [dxx one]] replace /g set
2903: g
2904: << (0). dxx sub q npower xx p npower mul >>
2905: mul
2906: ans add /ans set
2907: f (0). eq { exit } { } ifelse
2908: } loop
2909: ans dehomogenize /ans set
2910: } ifelse
2911: /arg1 ans def
2912: ] pop
2913: popVariables
2914: arg1
2915: } def
2916:
2917: /adjoint {
2918: /arg2 set
2919: /arg1 set
2920: [/in-adjoint /f /xx /xx0] pushVariables
2921: [
2922: /f arg1 def /xx arg2 def
2923: xx toString /xx set
2924: [xx to_records pop] /xx set
2925: xx { /xx0 set f xx0 adjoint1 /f set } map
2926: /arg1 f def
2927: ]pop
2928: popVariables
2929: arg1
2930: } def
2931:
2932: [(adjoint)
2933: [(f xlist adjoint g)
2934: (poly f; string xlist; poly g;)
2935: (g is the adjoint operator of f.)
2936: (The variables to take adjoint are specified by xlist.)
2937: (Example: [(x,y) ring_of_differential_operators 0] define_ring)
2938: ( (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
2939: $ ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
2940: ]] putUsages
2941:
2942: %%%%% diagonal for tensor products
2943: %% 1998, 12/4 (Sat)
2944: %% s_i = x_i, t_i = x_i - y_i, Restrict to t_i = 0.
2945: %% x_i = x_i, y_i = s_i - t_i,
2946: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
2947: /diagonalx {
2948: /arg2 set
2949: /arg1 set
2950: [/in-diagonalx /f] pushVariables
2951: [
2952: (Not implemented yet.) message
2953: ] pop
2954: popVariables
2955: arg1
2956: } def
2957:
2958:
2959:
2960: %%%%%%%%%%% distraction2 for b-function
2961: /distraction2 {
2962: /arg4 set
2963: /arg3 set
2964: /arg2 set
2965: /arg1 set
2966: [/f /dx /ss /xx /ans /n /i /rr] pushVariables
2967: [
2968: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2969: f (0). eq { }
2970: {
2971: /rr f (ring) dc def
2972: xx {toString rr ,, } map /xx set
2973: dx {toString rr ,, } map /dx set
2974: ss {toString rr ,, } map /ss set
2975: /n xx length def
2976: 0 1 n 1 sub {
2977: /i set
2978: /f f xx i get dx i get ss i get destraction2.1 /f set
2979: } for
2980: } ifelse
2981: /arg1 f def
2982: ]pop
2983: popVariables
2984: arg1
2985: } def
2986: [(distraction2)
2987: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2988: ( distraction2 result )
2989: $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
2990: $ (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
2991: $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
2992: ]
2993: ] putUsages
2994: /destraction2.1 {
2995: /arg4 set
2996: /arg3 set
2997: /arg2 set
2998: /arg1 set
2999: [/ww /f /dx /ss /xx /coeff0 /expvec
3000: /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
3001: [
3002: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3003: f (ring) dc /rr set
3004: /one (1) rr ,, def %%
3005: /ww [ xx toString -1 dx toString 1 ] weightv def
3006: f ww init f sub (0). eq { }
3007: { [(destraction2.1 : inhomogeneous with respect to )
3008: xx ( and ) dx nl
3009: (Your weight vector may not be generic.)
3010: ] cat error } ifelse
3011: /dd << f dx degree >> << f xx degree >> sub def
3012: f [[xx one]] replace dx coefficients /coeff0 set
3013: /expvec coeff0 0 get { (integer) dc } map def
3014: /coeffvec coeff0 1 get def
3015: expvec { ss 2 -1 roll factorial } map /expvec2 set
3016: expvec2 coeffvec mul /ans set
3017: %% x^p d^q, (p > q) case. x^2( x^2 Dx^2 + x Dx + 1)
3018: dd 0 lt {
3019: %% (ss+1) (ss+2) ... (ss+d)
3020: one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
3021: ans mul /ans set
3022: }
3023: { } ifelse
3024: /arg1 ans def
3025: ] pop
3026: popVariables
3027: arg1
3028: } def
3029:
3030: /message-quiet {
3031: @@@.quiet { pop } { message } ifelse
3032: } def
3033: [(message-quiet)
3034: [(s message-quiet )
3035: (string s;)
3036: (It outputs the message s when @@@.quiet is not equal to 1.)
3037: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3038: ]] putUsages
3039: /messagen-quiet {
3040: @@@.quiet { pop } { messagen } ifelse
3041: } def
3042: [(messagen-quiet)
3043: [(s messagen-quiet )
3044: (string s;)
3045: (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
3046: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3047: ]] putUsages
3048:
3049: /getvNames0 {
3050: /arg1 set
3051: [/in-getvNames0 /nlist /nn /i] pushVariables
3052: [
3053: /nlist arg1 def
3054: [(N)] system_variable /nn set
3055: nlist { /i set
3056: i nn lt {
3057: [(x) (var) i] system_variable
3058: } {
3059: [(D) (var) i nn sub] system_variable
3060: } ifelse
3061: } map
3062: /arg1 set
3063: ] pop
3064: popVariables
3065: arg1
3066: } def
3067:
3068: /getvNames {
3069: [/in-getvNames /nn] pushVariables
3070: [
3071: [(N)] system_variable /nn set
3072: [0 1 nn 2 mul 1 sub { } for] getvNames0 /arg1 set
3073: ] pop
3074: popVariables
3075: arg1
3076: } def
3077: [(getvNames)
3078: [(getvNames vlist)
3079: (list vlist)
3080: (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
3081: (Use with [(variableNames) vlist] system_variable.)
3082: (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
3083: ]] putUsages
3084:
3085: /getvNamesC {
3086: [/in-getvNamesC /nn /i] pushVariables
3087: [
3088: [(N)] system_variable /nn set
3089: [nn 1 sub -1 0 { } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
3090: ] pop
3091: popVariables
3092: arg1
3093: } def
3094: [(getvNamesC)
3095: [(getvNamesC vlist)
3096: (list vlist)
3097: $It returns of the list of the variables in the order 0, 1, 2, ... $
3098: $(cmo-order and output_order).$
3099: (cf. getvNames)
3100: ]] putUsages
3101:
3102: /getvNamesCR {
3103: /arg1 set
3104: [/in-getvNamesCR /rrr] pushVariables
3105: [(CurrentRingp)] pushEnv
3106: [
3107: /rrr arg1 def
3108: rrr isPolynomial {
3109: rrr (0). eq { (No name field for 0 polynomial.) error }
3110: { rrr (ring) dc /rrr set } ifelse
3111: } { } ifelse
3112: [(CurrentRingp) rrr] system_variable
3113: getvNamesC /arg1 set
3114: ] pop
3115: popEnv
3116: popVariables
3117: arg1
3118: } def
3119: [(getvNamesCR)
3120: [(obj getvNamesCR vlist)
3121: (obj ring | poly ; list vlist)
3122: $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
3123: (for <<obj>>.)
3124: (Example: ( (x-2)^3 ). /ff set )
3125: ( [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
3126: ]] putUsages
3127:
3128:
3129: /reduction-noH {
3130: /arg2 set
3131: /arg1 set
3132: [/in-reduction-noH /ff /gg] pushVariables
3133: [(Homogenize)] pushEnv
3134: [
3135: /ff arg1 def
3136: /gg arg2 def
3137: [(Homogenize) 0] system_variable
3138: ff gg reduction /arg1 set
3139: ] pop
3140: popEnv
3141: popVariables
3142: arg1
3143: } def
3144: [(reduction-noH)
3145: [(f g reduction-noH r)
3146: (poly f; array g; array r;)
3147: (Apply the normal form algorithm for f with the set g. All computations are)
3148: (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
3149: (specifications are the same with reduction. cf. reduction)
3150: (g should be dehomogenized.)
3151: ]] putUsages
3152:
3153: /-intInfinity -999999999 def
3154: /intInfinity 999999999 def
3155: [(intInfinity)
3156: [(intInfinity = 999999999)]
3157: ] putUsages
3158: [(-intInfinity)
3159: [(-intInfinity = -999999999)]
3160: ] putUsages
3161:
3162:
3163: /maxInArray {
3164: /arg1 set
3165: [/in-maxInArray /v /ans /i /n] pushVariables
3166: [
3167: /v arg1 def
3168: /n v length def
3169: /maxInArray.pos 0 def
3170: n 0 eq {
3171: /ans null def
3172: } {
3173: /ans v 0 get def
3174: 1 1 n 1 sub {
3175: /i set
3176: v i get ans gt {
3177: /ans v i get def
3178: /maxInArray.pos i def
3179: } { } ifelse
3180: } for
3181: } ifelse
3182: /arg1 ans def
3183: ] pop
3184: popVariables
3185: arg1
3186: } def
3187: [(maxInArray)
3188: [( [v1 v2 ....] maxInArray m )
3189: (m is the maximum in [v1 v2 ...].)
3190: (The position of m is stored in the global variable maxInArray.pos.)
3191: ]] putUsages
3192:
3193: /cancelCoeff {
3194: /arg1 set
3195: [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
3196: [ /ff arg1 def
3197: ff (0). eq {
3198: /label.cancelCoeff2 goto
3199: } { } ifelse
3200: /gg ff def
3201: /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
3202: {
3203: gg (0). eq { exit} { } ifelse
3204: [(lcoeff) gg init] gbext (universalNumber) dc /dd2 set
3205: [(gcd) dd dd2] mpzext /dd set
3206: dd (1).. eq {
3207: /label.cancelCoeff goto
3208: } { } ifelse
3209: /gg gg gg init sub def
3210: } loop
3211: [(divByN) ff dd] gbext 0 get /ff set
3212: /label.cancelCoeff
3213: [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
3214: { ff (-1).. mul /ff set } { } ifelse
3215: /label.cancelCoeff2
3216: /arg1 ff def
3217: ] pop
3218: popVariables
3219: arg1
3220: } def
3221: [(cancelCoeff)
3222: [(f cancelcoeff g)
3223: (poly f,g;)
3224: (Factor out the gcd of the coefficients.)
3225: (Example: (6 x^2 - 10 x). cancelCoeff)
3226: (See also gbext.)
3227: ]] putUsages
3228:
3229:
3230: /flatten {
3231: /arg1 set
3232: [/in-flatten /mylist] pushVariables
3233: [
3234: /mylist arg1 def
3235: mylist isArray {
3236: mylist { dup isArray { aload pop } { } ifelse } map /mylist set
3237: }{ } ifelse
3238: /arg1 mylist def
3239: ] pop
3240: popVariables
3241: arg1
3242: } def
3243: [(flatten)
3244: [(list flatten list2)
3245: (Flatten the list.)
3246: (Example 1: [ [1 2 3] 4 [2]] flatten ===> [1 2 3 4 2])
3247: ]] putUsages
3248:
3249: %% Take first N elements.
3250: /carN {
3251: /arg2 set
3252: /arg1 set
3253: [/in-res-getN /pp /nn /ans] pushVariables
3254: [
3255: /nn arg2 def
3256: /pp arg1 def
3257: pp isArray {
3258: pp length nn lt {
3259: /ans pp def
3260: } {
3261: [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
3262: } ifelse
3263: } {
3264: /ans pp def
3265: } ifelse
3266: /arg1 ans def
3267: ] pop
3268: popVariables
3269: arg1
3270: } def
3271: [(carN)
3272: [([f1 ... fm] n carN [f1 ... fn])
3273: (carN extracts the first n elements from the list.)
3274: ]] putUsages
3275:
3276: /getRing {
3277: /arg1 set
3278: [/in-getRing /aa /n /i /ans] pushVariables
3279: [
3280: /aa arg1 def
3281: /ans null def
3282: aa isPolynomial {
3283: aa (0). eq {
3284: } {
3285: /ans aa (ring) dc def
3286: } ifelse
3287: } {
3288: aa isArray {
3289: /n aa length 1 sub def
3290: 0 1 n { /i set aa i get getRing /ans set
3291: ans tag 0 eq { } { /getRing.LLL goto } ifelse
3292: } for
3293: }{ } ifelse
3294: } ifelse
3295: /getRing.LLL
3296: /arg1 ans def
3297: ] pop
3298: popVariables
3299: arg1
3300: } def
3301: [(getRing)
3302: [(obj getRing rr)
3303: (ring rr;)
3304: (getRing obtains the ring structure from obj.)
3305: (If obj is a polynomial, it returns the ring structure associated to)
3306: (the polynomial.)
3307: (If obj is an array, it recursively looks for the ring structure.)
3308: ]] putUsages
3309: /toVectors {
3310: /arg1 set
3311: [/in-toVectors /gg /n /ans] pushVariables
3312: [
3313: /gg arg1 def
3314: gg isArray {
3315: gg length 0 eq {
3316: /ans [ ] def
3317: /toVectors.LLL goto
3318: } {
3319: gg 0 get isInteger {
3320: gg @@@.toVectors2 /ans set
3321: } {
3322: gg @@@.toVectors /ans set
3323: } ifelse
3324: /toVectors.LLL goto
3325: } ifelse
3326: } {
3327: %% It is not array.
3328: gg (array) dc /ans set
3329: } ifelse
3330: /toVectors.LLL
3331: /arg1 ans def
3332: ] pop
3333: popVariables
3334: arg1
3335: } def
3336: /@@@.toVectors2 {
3337: /arg1 set
3338: [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
3339: [
3340: /gg arg1 def
3341: /ans gg 1 get @@@.toVectors def
3342: /n gg 0 get def
3343: gg 1 get isArray not {
3344: /ans [ans] def
3345: /notarray 1 def
3346: }{ /notarray 0 def} ifelse
3347: ans {
3348: /tmp set
3349: tmp length n lt {
3350: tmp
3351: [1 1 n tmp length sub { pop (0). } for ]
3352: join /tmp set
3353: } { } ifelse
3354: tmp
3355: } map
3356: /ans set
3357: notarray { ans 0 get /ans set } { } ifelse
3358: /arg1 ans def
3359: ] pop
3360: popVariables
3361: arg1
3362: } def
3363:
3364: /@@@.toVectors {
3365: /arg1 set
3366: [/in-@@@.toVectors /gg ] pushVariables
3367: [
3368: /gg arg1 def
3369: gg isArray {
3370: gg { $array$ data_conversion } map
3371: } {
3372: gg (array) data_conversion
3373: }ifelse
3374: /arg1 set
3375: ] pop
3376: popVariables
3377: arg1
3378: } def
3379:
3380: /toVectors2 { toVectors } def
3381:
3382: /fromVectors { { fromVectors.aux } map } def
3383: /fromVectors.aux {
3384: /arg1 set
3385: [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
3386: [(CurrentRingp)] pushEnv
3387: [
3388: /vv arg1 def
3389: /mm vv length def
3390: /ans (0). def
3391: /ee (0). def
3392: 0 1 mm 1 sub {
3393: /i set
3394: vv i get (0). eq {
3395: } {
3396: [(CurrentRingp) vv i get (ring) dc] system_variable
3397: [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
3398: /fromVector.LLL goto
3399: } ifelse
3400: } for
3401: /fromVector.LLL
3402: %% vv message
3403: 0 1 mm 1 sub {
3404: /i set
3405: vv i get (0). eq {
3406: } {
3407: /ans ans
3408: << vv i get >> << ee i npower >> mul
3409: add def
3410: } ifelse
3411: %% [i ans] message
3412: } for
3413: /arg1 ans def
3414: ] pop
3415: popEnv
3416: popVariables
3417: arg1
3418: } def
3419: [(fromVectors)
3420: [
3421: ([v1 v2 ...] fromVectors [s1 s2 ...])
3422: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
3423: (cf. toVectors. <<e_>> varaible is assumed to be the last )
3424: ( variable in x. @@@.esymbol)
3425: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
3426: $ [(x). (y).] /ff set $
3427: $ [ff ff] fromVectors :: $
3428: ]] putUsages
3429:
3430: /getOrderMatrix {
3431: /arg1 set
3432: [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
3433: [(CurrentRingp)] pushEnv
3434: [
3435: /obj arg1 def
3436: obj isArray {
3437: obj { getOrderMatrix } map /ans set
3438: ans length 0 {
3439: /ans null def
3440: } {
3441: /ans2 null def
3442: 0 1 ans length 1 sub {
3443: /i set
3444: ans i get tag 0 eq
3445: { }
3446: { /ans2 ans i get def } ifelse
3447: } for
3448: /ans ans2 def
3449: } ifelse
3450: /getOrderMatrix.LLL goto
3451: } { } ifelse
3452: obj tag 14 eq {
3453: [(CurrentRingp) obj] system_variable
3454: [(orderMatrix)] system_variable /ans set
3455: /getOrderMatrix.LLL goto
3456: } { } ifelse
3457: obj isPolynomial {
3458: obj (0). eq
3459: { /ans null def
3460: } { obj getRing /rr set
3461: [(CurrentRingp) rr] system_variable
3462: [(orderMatrix)] system_variable /ans set
3463: } ifelse
3464: /getOrderMatrix.LLL goto
3465: } { (getOrderMatrix: wrong argument.) error } ifelse
3466: /getOrderMatrix.LLL
3467: /arg1 ans def
3468: ] pop
3469: popEnv
3470: popVariables
3471: arg1
3472: } def
3473:
3474:
3475: [(getOrderMatrix)
3476: [(obj getOrderMatrix m)
3477: (array m)
3478: (getOrderMatrix obtains the order matrix from obj.)
3479: (If obj is a polynomial, it returns the order matrix associated to)
3480: (the polynomial.)
3481: (If obj is an array, it returns an order matrix of an element.)
3482: ]] putUsages
3483:
3484: /nl {
3485: 10 $string$ data_conversion
3486: } def
3487: [(nl)
3488: [(nl is the newline character.)
3489: $Example: [(You can break line) nl (here.)] cat message$
3490: ]] putUsages
3491:
3492: ;
3493:
3494:
3495:
3496:
3497:
3498:
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