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