Annotation of OpenXM/src/kan96xx/Kan/dr.sm1, Revision 1.7
1.7 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Kan/dr.sm1,v 1.6 2000/12/10 07:48:42 takayama Exp $
1.1 maekawa 2: %% dr.sm1 (Define Ring) 1994/9/25, 26
3: %% This file is error clean.
4:
5: @@@.quiet { }
1.5 takayama 6: { (macro package : dr.sm1, 9/26,1995 --- Version 12/10, 2000. ) message } ifelse
1.1 maekawa 7:
8: /ctrlC-hook {
9: %%% define your own routing in case of error.
10: } def
11: [(ctrlC-hook)
12: [(When ctrl-C is pressed, this function is executed.)
13: (User can define one's own ctrlC-hook function.)
14: ]] putUsages
15:
16: %% n evenQ bool
17: /evenQ {
18: /arg1 set
19: arg1 2 idiv 2 mul arg1 sub 0 eq
20: { true }
21: { false } ifelse
22: } def
23:
24: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
25: /ring_of_polynomials {
26: /arg1 set
27: [/vars /n /i /xList /dList /param] pushVariables
28: %dup print (-----) message
29: [
30: (mmLarger) (matrix) switch_function
31: (mpMult) (poly) switch_function
32: (red@) (module1) switch_function
33: (groebner) (standard) switch_function
34: (isSameComponent) (x) switch_function
35:
36: [arg1 to_records pop] /vars set
37: vars length evenQ
38: { }
39: { vars [(PAD)] join /vars set }
40: ifelse
41: vars length 2 idiv /n set
42: [ << n 1 sub >> -1 0
43: { /i set
44: vars i get
45: } for
46: ] /xList set
47: [ << n 1 sub >> -1 0
48: { /i set
49: vars << i n add >> get
50: } for
51: ] /dList set
52:
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
1.7 ! takayama 1475: } def
! 1476:
! 1477: [(isRing)
! 1478: [(obj isRing bool) ]
! 1479: ] putUsages
! 1480: /isRing {
! 1481: (type?) data_conversion RingP eq
1.1 maekawa 1482: } def
1483:
1484: /toString.tmp {
1485: /arg1 set
1486: [/obj /fname] pushVariables
1487: /obj arg1 def
1488: [
1489: obj isArray
1490: {
1491: obj {toString.tmp} map
1492: }
1493: { } ifelse
1494: obj isInteger
1495: {
1496: obj (dollar) data_conversion %% not string. It returns the ascii code.
1497: }
1498: { } ifelse
1499: obj isPolynomial
1500: {
1501: obj (string) data_conversion
1502: }
1503: { } ifelse
1504: obj isString
1505: { obj }
1506: { } ifelse
1507: obj isUniversalNumber
1508: { obj (string) data_conversion } { } ifelse
1509: obj isDouble
1510: { obj (string) data_conversion } { } ifelse
1511: obj isRational
1512: { obj (string) data_conversion } { } ifelse
1513: obj tag 0 eq
1514: { (null) } { } ifelse
1515:
1516: %%% New code that uses a file.
1517: obj tag 2 eq obj tag 13 eq or obj tag 14 eq or obj tag 17 eq or
1518: { [(getUniqueFileName) (/tmp/sm1_toString)] extension /fname set
1519: [(outputObjectToFile) fname obj] extension pop
1520: fname pushfile
1521: [(/bin/rm -rf ) fname] cat system
1522: } { } ifelse
1523: ] /arg1 set
1524: popVariables
1525: arg1 aload pop
1526: } def
1527:
1528:
1529:
1530: %% [(xy) [(x+1) (2)]] toString.tmp2 ([ xy , [ x+1 , 2 ] ])
1531: /toString.tmp2 {
1532: /arg1 set
1533: [/obj /i /n /r] pushVariables
1534: [
1535: /obj arg1 def
1536: obj isArray
1537: {
1.2 takayama 1538: [(LeftBracket)] system_variable %%( [ )
1.1 maekawa 1539: obj {toString.tmp2} map /r set
1540: /n r length 1 sub def
1541: [0 1 n {
1542: /i set
1543: i n eq {
1544: r i get
1545: }
1546: { r i get ( , ) 2 cat_n }
1547: ifelse
1548: } for
1549: ] aload length cat_n
1.2 takayama 1550: [(RightBracket)] system_variable %%( ] )
1.1 maekawa 1551: 3 cat_n
1552: }
1553: {
1554: obj
1555: } ifelse
1556: ] /arg1 set
1557: popVariables
1558: arg1 aload pop
1559: } def
1560:
1561:
1562: [(toString)
1563: [(obj toString)
1564: (Convert obj to a string.)
1565: (Example: [ 1 (x+1). [ 2 (Hello)]] toString ==> $[ 1 , x+1 , [ 2 , Hello ] ]$)
1566: ]
1567: ] putUsages
1568: /toString {
1569: /arg1 set
1570: [/obj ] pushVariables
1571: [
1572: /obj arg1 def
1573: obj isString
1574: { obj }
1575: { obj toString.tmp toString.tmp2 }
1576: ifelse /arg1 set
1577: ] pop
1578: popVariables
1579: arg1
1580: } def
1581:
1582: [(output)
1583: [(obj output) (Output the object to the standard file sm1out.txt)]
1584: ] putUsages
1585: /output {
1586: /arg1 set
1587: [/obj /fd ] pushVariables
1588: [
1589: /obj arg1 def
1590: (sm1out.txt) (a) file /fd set
1591: (Writing to sm1out.txt ...) messagen
1592: [ fd << obj toString >> writestring ] pop
1593: [ fd << 10 (string) data_conversion >> writestring ] pop
1594: ( Done.) message
1595: fd closefile
1596: ] pop
1597: popVariables
1598: } def
1599: %%%% end of macro for output.
1600: [(tag)
1601: [(obj tag integer)
1602: (tag returns datatype.)
1603: (cf. data_conversion)
1604: (Example: 2 tag IntegerP eq ---> 1)
1605: ]
1606: ] putUsages
1607: /etag {(type??) data_conversion} def
1608: [(etag)
1609: [(obj etag integer)
1610: (etag returns extended object tag. cf. kclass.c)
1611: ]
1612: ] putUsages
1613: /tag {(type?) data_conversion} def
1614: %% datatype constants
1615: /IntegerP 1 (type?) data_conversion def
1616: /LiteralP /arg1 (type?) data_conversion def %Sstring
1617: /StringP (?) (type?) data_conversion def %Sdollar
1618: /ExecutableArrayP { 1 } (type?) data_conversion def
1619: /ArrayP [ 0 ] (type?) data_conversion def
1620: /PolyP (1). (type?) data_conversion def
1621: /FileP 13 def
1622: /RingP 14 def
1623: /UniversalNumberP 15 def
1624: /RationalFunctionP 16 def
1625: /ClassP 17 def
1626: /DoubleP 18 def
1627: /@.datatypeConstant.usage [
1628: (IntegerP, LiteralP, StringP, ExecutableArrayP, ArrayP, PolyP, FileP, RingP,)
1629: (UniversalNumberP, RationalFunctionP, ClassP, DoubleP)
1630: ( return data type identifiers.)
1631: (Example: 7 tag IntegerP eq ---> 1)
1632: ] def
1633: [(IntegerP) @.datatypeConstant.usage ] putUsages
1634: [(LiteralP) @.datatypeConstant.usage ] putUsages
1635: [(StringP) @.datatypeConstant.usage ] putUsages
1636: [(ExecutableArrayP) @.datatypeConstant.usage ] putUsages
1637: [(ArrayP) @.datatypeConstant.usage ] putUsages
1638: [(PolyP) @.datatypeConstant.usage ] putUsages
1639: [(RingP) @.datatypeConstant.usage ] putUsages
1640: [(UniversalNumberP) @.datatypeConstant.usage ] putUsages
1641: [(RationalFunctionP) @.datatypeConstant.usage ] putUsages
1642: [(ClassP) @.datatypeConstant.usage ] putUsages
1643: [(DoubleP) @.datatypeConstant.usage ] putUsages
1644:
1645: [(,,)
1646: [( string ring ,, polynomial)
1647: (Parse the <<string>> as an element in the <<ring>> and returns)
1648: (the polynomial.)
1649: (cf. define_ring, define_qring, ring_def)
1650: (Example: [(x,y) ring_of_polynomials [[(x) 1]] weight_vector 7]define_ring)
1651: ( /myring set)
1652: ( ((x+y)^4) myring ,, /f set)
1653: ]] putUsages
1654:
1655: /,, {
1656: /arg2 set /arg1 set
1657: [/rrr] pushVariables
1658: [ arg1 tag StringP eq
1659: arg2 tag RingP eq and
1660: { [(CurrentRingp)] system_variable /rrr set
1661: [(CurrentRingp) arg2] system_variable
1662: /arg1 arg1 expand def
1663: [(CurrentRingp) rrr] system_variable
1664: }
1665: {(Argument Error for ,, ) error }
1666: ifelse
1667: ] pop
1668: popVariables
1669: arg1
1670: } def
1671:
1672: [(..)
1673: [( string .. universalNumber)
1674: (Parse the << string >> as a universalNumber.)
1675: (Example: (123431232123123).. /n set)
1676: ]] putUsages
1677: /.. { (universalNumber) data_conversion } def
1678:
1679: [(dc)
1680: [(Abbreviation of data_conversion.)
1681: ]] putUsages
1682: /dc { data_conversion } def
1683:
1684:
1685: %%% start of shell sort macro.
1686: [(and) [(obj1 obj2 and bool)]] putUsages
1687: /and { add 1 copy 2 eq {pop 1} {pop 0} ifelse } def
1688:
1689: [(or) [(obj1 obj2 or bool)]] putUsages
1690: /or { add 1 copy 2 eq {pop 1} { } ifelse} def
1691:
1692: [(ge) [(obj1 obj2 ge bool) (greater than or equal)]] putUsages
1693: %% 2 copy is equivalent to dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1694: /ge { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1695: eq {pop pop 1}
1696: { gt {1}
1697: {0}
1698: ifelse}
1699: ifelse} def
1700:
1701: [(le) [(obj1 obj2 le bool) (less than or equal)]] putUsages
1702: /le { dup 3 -1 roll dup 4 -2 roll 3 -1 roll 2 -1 roll
1703: eq {pop pop 1}
1704: { lt {1}
1705: {0}
1706: ifelse}
1707: ifelse} def
1708:
1709: [(break)
1710: [(bool break)]
1711: ] putUsages
1712: /break { {exit} { } ifelse } def
1713:
1714: /not { 0 eq {1} {0} ifelse} def
1715: /append { /arg2 set [arg2] join } def
1716:
1717: [(power)
1718: [(obj1 obj2 power obj3)
1719: $obj3 is (obj1)^(obj2). cf. npower$
1720: $Example: (2). 8 power :: ===> 256 $
1721: ]
1722: ] putUsages
1723: %% From SSWork/yacc/incmac.sm1
1724: %% f k power f^k
1725: /power {
1726: /arg2 set
1727: /arg1 set
1728: [/f /k /i /ans] pushVariables
1729: [
1730: /ans (1).. def
1731: /f arg1 def /k arg2 ..int def
1732: k 0 lt {
1733: 1 1 << 0 k sub >> {
1734: /ans f ans {mul} sendmsg2 def
1735: } for
1736: /ans (1).. ans {div} sendmsg2 def
1737: }
1738: {
1739: 1 1 k {
1740: /ans f ans {mul} sendmsg2 def
1741: } for
1742: } ifelse
1743: /arg1 ans def
1744: ] pop
1745: popVariables
1746: arg1
1747: } def
1748: [(..int)
1749: [ (universalNumber ..int int)]] putUsages
1750: /..int { %% universal number to int
1751: (integer) data_conversion
1752: } def
1753: [(SmallRing) [(SmallRing is the ring of polynomials Q[t,x,T,h].)]] putUsages
1754: /SmallRing [(CurrentRingp)] system_variable def
1755:
1756: %%% From SSWork/yacc/lib/printSVector.modified.sm1
1757: %%% supporting code for printSVector.
1758: /greaterThanOrEqual {
1759: /arg2 set /arg1 set
1760: arg1 arg2 gt { 1 }
1761: { arg1 arg2 eq {1} {0} ifelse} ifelse
1762: } def
1763:
1764: /lengthUniv {
1765: length (universalNumber) dc
1766: } def
1767:
1768: /getUniv {
1769: (integer) dc get
1770: } def %% Do not forget to thow away /.
1771:
1772: %%[(@@@.printSVector)
1773: %% [( vector @@@.printSVector outputs the <<vector>> in a pretty way.)
1774: %% ( The elements of the vector must be strings.)
1775: %% ]
1776: %%] putUsages
1777:
1778: %%% compiled code by d0, 1996, 8/17.
1779: /@@@.printSVector {
1780: /arg1 set
1781: [ %%start of local variables
1782: /keys /i /j /n /max /width /m /k /kk /tmp0 ] pushVariables [ %%local variables
1783: /keys arg1 def
1784: /n
1785: keys lengthUniv
1786: def
1787: /max (0).. def
1788: /i (0).. def
1789: %%for init.
1790: %%for
1791: { i n lt
1792: { } {exit} ifelse
1793: [ {%%increment
1794: /i i (1).. add def
1795: } %%end of increment{A}
1796: {%%start of B part{B}
1797: keys i getUniv lengthUniv
1798: max gt
1799: %% if-condition
1800: { %%ifbody
1801: /max
1802: keys i getUniv lengthUniv
1803: def
1804: }%%end if if body
1805: { %%if- else part
1806: } ifelse
1807: } %% end of B part. {B}
1808: 2 1 roll] {exec} map
1809: } loop %%end of for
1810: /max max (3).. add
1811: def
1812: /width (80).. def
1813: /m (0).. def
1814:
1815: %%while
1816: { m max mul
1817: (80).. lt
1818: { } {exit} ifelse
1819: /m m (1).. add
1820: def
1821: } loop
1822: /k (0).. def
1823: /kk (0).. def
1824: /i (0).. def
1825: %%for init.
1826: %%for
1827: { i n lt
1828: { } {exit} ifelse
1829: [ {%%increment
1830: /i i (1).. add def
1831: } %%end of increment{A}
1832: {%%start of B part{B}
1833: keys i getUniv messagen
1834: /kk kk (1).. add
1835: def
1836: /k k
1837: keys i getUniv lengthUniv
1838: add
1839: def
1840: /tmp0 max
1841: keys i getUniv lengthUniv
1842: sub
1843: def
1844: /j (0).. def
1845: %%for init.
1846: %%for
1847: { j tmp0 lt
1848: { } {exit} ifelse
1849: [ {%%increment
1850: /j j (1).. add def
1851: } %%end of increment{A}
1852: {%%start of B part{B}
1853: /k k (1).. add
1854: def
1855: kk m lt
1856: %% if-condition
1857: { %%ifbody
1858: ( ) messagen
1859: }%%end if if body
1860: { %%if- else part
1861: } ifelse
1862: } %% end of B part. {B}
1863: 2 1 roll] {exec} map
1864: } loop %%end of for
1865: kk m greaterThanOrEqual
1866: %% if-condition
1867: { %%ifbody
1868: /kk (0).. def
1869: /k (0).. def
1870: newline
1871: }%%end if if body
1872: { %%if- else part
1873: } ifelse
1874: } %% end of B part. {B}
1875: 2 1 roll] {exec} map
1876: } loop %%end of for
1877: newline
1878: /ExitPoint ]pop popVariables %%pop the local variables
1879: } def
1880: %%end of function
1881:
1882: /rest { % returns remainder of a given list
1883: [ 2 1 roll aload length -1 roll pop ]
1884: } def
1885: [(rest)
1886: [(array rest the-rest-of-the-array)
1887: (Ex. [1 2 [3 0]] rest ===> [2 [3 0]])
1888: ]
1889: ] putUsages
1890:
1891: %% from SSkan/develop/minbase.sm1
1892: /reducedBase {
1893: /arg1 set
1894: [/base /minbase /n /i /j /myring /zero /f] pushVariables
1895: [
1896: /base arg1 def
1897: base isArray { }
1898: { (The argument of reducedBase must be an array of polynomials)
1899: error
1900: } ifelse
1901: base 0 get isPolynomial { }
1902: { (The element of the argument of reducedBase must be polynomials)
1903: error
1904: } ifelse
1905: /myring base 0 get (ring) dc def
1906: /zero (0) myring ,, def
1907: base length 1 sub /n set
1908: /minbase [ 0 1 n { /i set base i get } for ] def
1909: 0 1 n {
1910: /i set
1911: minbase i get /f set
1912: f zero eq {
1913: }
1914: {
1915: 0 1 n {
1916: /j set
1917: << minbase j get zero eq >> << i j eq >> or {
1918: }
1919: {
1920: [(isReducible) << minbase j get >> f] gbext
1921: {
1922: minbase j zero put
1923: }
1924: { } ifelse
1925: } ifelse
1926: } for
1927: } ifelse
1928: } for
1929: minbase { minbase.iszero } map /arg1 set
1930: ] pop
1931: popVariables
1932: arg1
1933: } def
1934:
1935: [(reducedBase)
1936: [(base reducedBase reducedBase)
1937: (<<reducedBase>> prunes redundant elements in the Grobner basis <<base>> and)
1938: (returns <<reducedBase>>.)
1939: (Ex. [(x^2+1). (x+1). (x^3).] reducedBase ---> [(x+1).])
1940: ]
1941: ] putUsages
1942:
1943: %% package functions
1944: /minbase.iszero {
1945: dup (0). eq {
1946: pop
1947: }
1948: { } ifelse
1949: } def
1950:
1951: /== {
1952: message
1953: } def
1954: [(==)
1955: [(obj ==)
1956: (Print obj)
1957: ]
1958: ] putUsages
1959:
1960: /@@@.all_variables {
1961: [/n /i] pushVariables
1962: [
1963: /n [(N)] system_variable def
1964: [
1965: 0 1 n 1 sub {
1966: /i set
1967: [(x) (var) i] system_variable
1968: } for
1969: 0 1 n 1 sub {
1970: /i set
1971: [(D) (var) i] system_variable
1972: } for
1973: ] /arg1 set
1974: ] pop
1975: popVariables
1976: arg1
1977: } def
1978:
1979: /weightv {
1980: @@@.all_variables
1981: 2 1 roll w_to_vec
1982: } def
1983:
1984: [(weightv)
1985: [(array weightv weight_vector_for_init)
1986: (cf. init)
1987: (Example: /w [(x) 10 (h) 2] weightv def)
1988: ( ((x-h)^10). w init ::)
1989: ]
1990: ] putUsages
1991:
1992: /output_order {
1993: /arg1 set
1994: [/vars /vlist /perm /total /ans] pushVariables
1995: [
1996: /vlist arg1 def
1997: /vars @@@.all_variables def
1998: vlist { vars 2 1 roll position } map /perm set
1999: perm ==
2000: /total [ 0 1 [(N)] system_variable 2 mul 1 sub { } for ] def
2001: perm perm total complement join /ans set
2002: [(outputOrder) ans] system_variable
2003: ] pop
2004: popVariables
2005: } def
2006:
2007: [(output_order)
2008: [$ [(v1) (v2) ...] output_order $
2009: (Set the order of variables to print for the current ring.)
2010: (cf. system_variable)
2011: (Example: [(y) (x)] output_order)
2012: $ (x*y). :: ===> y*x $
2013: ]
2014: ] putUsages
2015:
2016: %% destraction. SSkan/Kan/debug/des.sm1, 1998, 2/27 , 3/1
2017: %% should be included in dr.sm1
2018:
2019: /factorial {
2020: /arg2 set
2021: /arg1 set
2022: [ /f /n ] pushVariables
2023: [
2024: /f arg1 def
2025: /n arg2 def
2026: /ans (1).. def
2027: n 0 lt { (f n factorial : n must be a non-negative integer)
2028: error } { } ifelse
2029: 0 1 n 1 sub {
2030: (universalNumber) dc /i set
2031: ans << f i sub >> mul /ans set
2032: } for
2033: /arg1 ans def
2034: ] pop
2035: popVariables
2036: arg1
2037: } def
2038:
2039: [(factorial)
2040: [(f n factorial g)
2041: $integer n, g is f (f-1) ... (f-n+1)$
2042: ]
2043: ] putUsages
2044:
2045:
2046: /destraction1 {
2047: /arg4 set
2048: /arg3 set
2049: /arg2 set
2050: /arg1 set
2051: [/ww /f /dx /ss /xx /coeff0 /expvec
2052: /coeffvec /expvec2 /ans /one] pushVariables
2053: [
2054: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2055: /one (1). def %%
2056: /ww [ xx toString -1 dx toString 1 ] weightv def
2057: f ww init f sub (0). eq { }
2058: { [(destraction1 : inhomogeneous with respect to )
2059: xx ( and ) dx ] cat error } ifelse
2060: f [[xx one]] replace dx coefficients /coeff0 set
2061: /expvec coeff0 0 get { (integer) dc } map def
2062: /coeffvec coeff0 1 get def
2063: expvec { ss 2 -1 roll factorial } map /expvec2 set
2064: expvec2 coeffvec mul /ans set
2065: /arg1 ans def
2066: ] pop
2067: popVariables
2068: arg1
2069: } def
2070:
2071:
2072: /distraction {
2073: /arg4 set
2074: /arg3 set
2075: /arg2 set
2076: /arg1 set
2077: [/f /dx /ss /xx /ans /n /i] pushVariables
2078: [(CurrentRingp)] pushEnv
2079: [
2080: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2081: f (0). eq { /dist1.L goto } { f (ring) dc ring_def } ifelse
2082: /n xx length def
2083: 0 1 n 1 sub {
2084: /i set
2085: /f f xx i get dx i get ss i get destraction1 /f set
2086: } for
2087: /dist1.L
2088: /arg1 f def
2089: ]pop
2090: popEnv
2091: popVariables
2092: arg1
2093: } def
2094: [(distraction)
2095: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2096: ( distraction result )
2097: $Example: (x Dx Dy + Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction$
2098: ]
2099: ] putUsages
2100: /destraction { distraction } def
2101:
2102:
2103:
2104:
2105: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2106: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2107: %%%%%%%%%%%%%%%% sorting
2108: %/N 1000 def
2109: %/a.shell [N -1 0 { } for ] def
2110: %a.shell 0 -1000 put
2111: %% You need gate keeper.
2112: [(shell)
2113: [([gate-keeper f1 f2 ... fm] shell result)
2114: (Sort the list. Gate-keeper should be the smallest element)]
2115: ] putUsages
2116: /shell {
2117: /arg1 set
2118: [/N /a.shell /h /i /v /j] pushVariables
2119: [
2120: /a.shell arg1 def
2121: /N a.shell length 1 sub def
2122:
2123: /h 1 def
2124: {/h h 3 mul 1 add def
2125: << h N ge >> break
2126: } loop
2127: {
2128: /h << h 3 idiv >> def
2129: << h 1 add >> 1 N {
2130: /i set
2131: /v a.shell i get def
2132: /j i def
2133: {
2134: %% a.shell print newline
2135: << a.shell << j h sub >> get >> v le break
2136: a.shell j << a.shell << j h sub >> get >> put
2137: /j j h sub def
2138: j h le break
2139: } loop
2140: a.shell j v put
2141: } for
2142: h 1 lt break
2143: } loop
2144: /arg1 a.shell def
2145: ] pop
2146: popVariables
2147: arg1
2148: } def
2149: %%%% end of shell sort macro
2150:
2151: /variableNames {
2152: /arg1 set
2153: [/in-variableNames /rrr /nnn /i /cp] pushVariables
2154: [
2155: /rrr arg1 def
2156: [(CurrentRingp)] system_variable /cp set
2157: [(CurrentRingp) rrr] system_variable
2158: [(N)] system_variable /nnn set
2159: [ 0 1 nnn 1 sub {
2160: /i set [(x) (var) i] system_variable } for ]
2161: [ 0 1 nnn 1 sub {
2162: /i set [(D) (var) i] system_variable } for ]
2163: join /arg1 set
2164: [(CurrentRingp) cp] system_variable
2165: ] pop
2166: popVariables
2167: arg1
2168: } def
2169:
2170:
2171: /makeRingMap {
2172: /arg3 set /arg2 set /arg1 set
2173: [/in-makeRingMap /corres /M /N /corresM /corresN
2174: /vars /vars-org /i /p /ans /cp] pushVariables
2175: [
2176: /corres arg1 def /M arg2 def /N arg3 def
2177: /corresM corres 0 get def
2178: /corresN corres 1 get def
2179: [(CurrentRingp)] system_variable /cp set
2180: [(CurrentRingp) M] system_variable
2181: M variableNames /vars set vars 1 copy /vars-org set
2182: 0 1 corresM length 1 sub {
2183: /i set
2184: vars corresM i get position /p set
2185: p -1 gt {
2186: vars p $($ corresN i get $)$ 3 cat_n put
2187: } { } ifelse
2188: } for
2189: /arg1 [vars M N vars-org] def
2190: [(CurrentRingp) cp] system_variable
2191: ] pop
2192: popVariables
2193: arg1
2194: } def
2195:
2196:
2197:
2198: /ringmap {
2199: /arg2 set /arg1 set
2200: [/in-ringmap /f /M2N /cp /f2] pushVariables
2201: [
2202: /f arg1 def /M2N arg2 def
2203: [(CurrentRingp)] system_variable /cp set
2204: f (0). eq { /f2 f def }
2205: {
2206: %f (ring) dc M2N 1 get eq
2207: %{ }
2208: %{ (The argument polynomial does not belong to the domain ring.) message
2209: % error
2210: % } ifelse
2211: [(CurrentRingp) M2N 1 get] system_variable
2212: [(variableNames) M2N 0 get] system_variable
2213: f toString /f2 set
2214: [(variableNames) M2N 3 get] system_variable
2215: f2 M2N 2 get ,, /f2 set
2216: } ifelse
2217: [(CurrentRingp) cp] system_variable
2218: /arg1 f2 def
2219: ] pop
2220: popVariables
2221: arg1
2222: } def
2223:
2224: [(makeRingMap)
2225: [( rule ring1 ring2 makeRingMap maptable )
2226: (makeRingMap is an auxiliary function for the macro ringmap. See ringmap)
2227: ]
2228: ] putUsages
2229: [(ringmap)
2230: [(f mapTable ringmap r)
2231: (f is mapped to r where the map is defined by the mapTable, which is generated)
2232: (by makeRingMap as follows:)
2233: ( rule ring1 ring2 makeRingMap maptable )
2234: $Example:$
2235: $[(x,y) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2236: $/R1 set$
2237: $[(t,y,z) ring_of_differential_operators ( ) elimination_order 0] define_ring$
2238: $/R2 set$
2239: $[[(x) (Dx)] [((t-1) Dt) (z)]] /r0 set$
2240: $r0 R1 R2 makeRingMap /maptable set$
2241: $(Dx-1) R1 ,, /ff set$
2242: $ ff maptable ringmap :: $
2243: ]
2244: ] putUsages
2245:
2246:
2247: /getVariableNames {
2248: [/in-getVariableNames /ans /i /n] pushVariables
2249: [
2250: /n [(N)] system_variable def
2251: [
2252: n 1 sub -1 0 {
2253: /i set
2254: [(x) (var) i] system_variable
2255: } for
2256: n 1 sub -1 0{
2257: /i set
2258: [(D) (var) i] system_variable
2259: } for
2260: ] /arg1 set
2261: ] pop
2262: popVariables
2263: arg1
2264: } def
2265: [(getVariableNames)
2266: [(getVariableNames list-of-variables)
2267: (Example: getVariableNames :: [e,x,y,E,H,Dx,Dy,h])
2268: ]
2269: ] putUsages
2270:
2271: /tolower {
2272: /arg1 set
2273: [/in-tolower /s /sl] pushVariables
2274: [
2275: /s arg1 def
2276: s (array) dc /s set
2277: s { tolower.aux (string) dc } map /sl set
2278: sl aload length cat_n /arg1 set
2279: ] pop
2280: popVariables
2281: arg1
2282: } def
2283:
2284: /tolower.aux {
2285: /arg1 set
2286: arg1 64 gt arg1 96 lt and
2287: { arg1 32 add }
2288: { arg1 } ifelse
2289: } def
2290: [(tolower)
2291: [(string tolower string2)
2292: (Capital letters in string are converted to lower case letters.)
2293: $Example: (Hello World) tolower :: (hello world)$
2294: ]
2295: ] putUsages
2296:
2297: /hilbert {
2298: /arg2 set
2299: /arg1 set
2300: [/in-hilb /base /vlist /rrrorg /rrr /ff /strf] pushVariables
2301: [
2302: /base arg1 def
2303: /vlist arg2 def
2304: [(CurrentRingp)] system_variable /rrrorg set
2305: /strf 0 def
2306: vlist isString
2307: { /vlist [ vlist to_records pop ] def }
2308: { } ifelse
2309: base isArray { }
2310: { (hilb : the first argument must be an array of polynomials.)
2311: error
2312: } ifelse
2313: vlist isArray { }
2314: { (hilb : the second argument must be an array of polynomials.)
2315: error
2316: } ifelse
2317:
2318: vlist 0 get isString{ /strf 1 def } { } ifelse
2319: base 0 get isPolynomial {
2320: base 0 get (ring) dc /rrr set
2321: }
2322: {
2323: [ vlist { (,) } map aload length cat_n ring_of_polynomials 0 ] define_ring
2324: /rrr set
2325: base { . } map /base set
2326: } ifelse
2327: vlist { dup isPolynomial { } { rrr ,, } ifelse } map /vlist set
2328:
2329: [(hilbert) base vlist] extension /ff set
2330: [(CurrentRingp) rrrorg] system_variable
2331: /arg1 ff def
2332: ] pop
2333: popVariables
2334: arg1
2335: } def
2336:
2337: /hilbReduce {
2338: /arg2 set
2339: /arg1 set
2340: [/hhh /f /d /vv /ans] pushVariables
2341: [
2342: /hhh arg1 def %% hilbert function
2343: /vv arg2 def
2344: /f hhh 1 get def
2345: f (0). eq { /ans [0] def /hilbReduce.label goto } { } ifelse
2346: f vv << f (ring) dc >> ,, degree /vv set
2347: hhh 0 get /d set
2348: d d (integer) dc factorial /d set
2349: d << vv (universalNumber) dc vv factorial >> idiv /d set
2350: [(divByN) f d] gbext /ans set
2351: ans 1 get (0). eq
2352: { }
2353: { (hilbReduce : Invalid hilbert function ) error } ifelse
2354: /hilbReduce.label
2355: ans 0 get /arg1 set
2356: ] pop
2357: popVariables
2358: arg1
2359: } def
2360:
2361:
2362: [(hilbReduce)
2363: [([f,g] v hilbReduce p)
2364: (output of hilbert [f,g]; string v; poly p)
2365: (p is (g/(f!))*deg(g)!)
2366: $ [(x) (y^3)] (x,y,z) hilbert (h) hilbReduce $
2367: ]
2368: ] putUsages
2369: [(hilbert)
2370: [(base vlist hilbert [m f])
2371: (array of poly base; array of poly vlist; number m; poly f;)
2372: (array of string base; array of string vlist; number m; poly f;)
2373: (array of string base; string vlist; number m; poly f;)
2374: ([m f] represents the hilbert function (a_d x^d + ...)/m! where f=a_d x^d + ...)
2375: (The << base >> should be a reduced Grobner basis.)
2376: (Or, when the << base >> is an array of string,)
2377: (all entries should be monomials.)
2378: (Example: [(x^2) (x y )] (x,y) hilbert :: [2, 2 h + 4] )
2379: (Example: [(x^2) (y^2)] (x,y) hilbert (h) hilbReduce :: 4)
2380: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilbert (h) hilbReduce :: 3)
2381: (cf. hilb, hilbReduce)
2382: ]
2383: ] putUsages
2384:
2385: /hilb {
2386: hilbert (h) hilbReduce
2387: } def
2388: [(hilb)
2389: [(base vlist hilb f)
2390: (array of poly base; array of poly vlist; poly f;)
2391: (array of string base; array of string vlist; poly f;)
2392: (array of string base; string vlist; number m; poly f;)
2393: (f is the hilbert function (a_d x^d + ...)/m!)
2394: (The << base >> should be a reduced Grobner basis.)
2395: (Or, when the << base >> is an array of string,)
2396: (all entries should be monomials.)
2397: (Example: [(x^2) (x y )] (x,y) hilb :: h + 2 )
2398: (Example: [(x^2) (y^2)] (x,y) hilb 4)
2399: (Example: [(x^2) (y^2) (x y)] [(x) (y)] hilb :: 3)
2400: (cf. hilbert, hilbReduce)
2401: ]
2402: ] putUsages
2403:
2404: [(diff0)
2405: [ (f v n diff0 fn)
2406: (<poly> fn, v ; <integer> n ; <poly> fn)
2407: (fn = v^n f where v^n is the operator to take the n-th differential.)
2408: (We can use diff0 only in the ring of differential operators.)
2409: (Example: [(x) ring_of_differential_operators 0] define_ring )
2410: ( (x^10-x). (Dx). 1 diff0 ::)
2411: ]
2412: ] putUsages
2413: /diff0 {
2414: /arg3 set /arg2 set /arg1 set
2415: [/in-diff /f /v /n /fn /rrr] pushVariables
2416: [
2417: /f arg1 def /v arg2 def /n arg3 def
2418: f (0). eq
2419: { /fn (0). def }
2420: {
2421: f (ring) dc /rrr set
2422: v toString (^) n toString 3 cat_n rrr ,,
2423: f mul
2424: [[v (0).] [(h) rrr ,, (1) rrr ,,]] replace /fn set
2425: } ifelse
2426: fn /arg1 set
2427: ] pop
2428: popVariables
2429: arg1
2430: } def
2431:
2432: [(action)
2433: [( f g action p )
2434: (<poly> f,g,p)
2435: (Act f on g. The result is p. The homogenization variable h is put to 1.)
2436: (We can use diff0 only in the ring of differential operators.)
2437: (Example: [(x) ring_of_differential_operators 0] define_ring )
2438: ( (Dx^2). (x^2). action ::)
2439: ]
2440: ] putUsages
2441: /action {
2442: /arg2 set /arg1 set
2443: [/in-action /f /g /h /rr /rr.org /rule] pushVariables
2444: [
2445: /f arg1 def /g arg2 def
2446: /rr.org [(CurrentRingp)] system_variable def
2447: f (0). eq
2448: { /h (0). def }
2449: {
2450: f (ring) dc /rr set
2451: [(CurrentRingp) rr] system_variable
2452: f g mul /h set
2453: /rule getVariableNames def
2454: 0 1 rule length 2 idiv { rule rest /rule set } for
2455: rule { . [ 2 1 roll (0). ] } map /rule set
2456: rule << rule length 1 sub >> [(h). (1).] put
2457: %%ex. rule = [[(Dx1). (0).] [(Dx2). (0).] [(h). (1).]]
2458: /h h rule replace def
2459: } ifelse
2460: [(CurrentRingp) rr.org ] system_variable
2461: /arg1 h def
2462: ] pop
2463: popVariables
2464: arg1
2465: } def
2466:
2467: [(ord_w)
2468: [(ff [v1 w1 v2 w2 ... vm wm] ord_w d)
2469: (poly ff; string v1; integer w1; ...)
2470: (order of ff by the weight vector [w1 w2 ...])
2471: (Example: [(x,y) ring_of_polynomials 0] define_ring )
2472: ( (x^2 y^3-x). [(x) 2 (y) 1] ord_w ::)
2473: ]
2474: ] putUsages
2475: /ord_w {
2476: /arg2 set /arg1 set
2477: [/ord_w-in /fff /www /rrr /iii /ddd] pushVariables
2478: [
2479: /fff arg1 def
2480: /www arg2 def
2481: fff (0). eq { /ddd -intInfinity def /ord_w.LLL goto} { } ifelse
2482: fff (ring) dc /rrr set
2483: fff init /fff set
2484: /ddd 0 def
2485: 0 2 www length 1 sub {
2486: /iii set
2487: fff << www iii get rrr ,, >> degree
2488: << www iii 1 add get >> mul
2489: ddd add /ddd set
2490: } for
2491: /ord_w.LLL
2492: /arg1 ddd def
2493: ] pop
2494: popVariables
2495: arg1
2496: } def
2497:
2498: [(laplace0)
2499: [
2500: (f [v1 ... vn] laplace0 g)
2501: (poly f ; string v1 ... vn ; poly g;)
2502: (array of poly f ; string v1 ... vn ; array of poly g;)
2503: ( g is the lapalce transform of f with respect to variables v1, ..., vn.)
2504: $Example: (x Dx + y Dy + z Dz). [(x) (y) (Dx) (Dy)] laplace0$
2505: $ x --> -Dx, Dx --> x, y --> -Dy, Dy --> y. $
2506: ]
2507: ] putUsages
2508: /laplace0 {
2509: /arg2 set /arg1 set
2510: [/in-laplace0 /ff /rule /vv /nn /ii /v0 /v1 /rr /ans1 /Dascii
2511: ] pushVariables
2512: [
2513: /ff arg1 def /vv arg2 def
2514: /Dascii @@@.Dsymbol (array) dc 0 get def %%D-clean
2515: /rule [ ] def
2516: ff isPolynomial {
2517: ff (0). eq { /ans1 (0). def }
2518: {
2519: ff (ring) dc /rr set
2520: /nn vv length def
2521: 0 1 nn 1 sub {
2522: /ii set
2523: vv ii get (type?) dc 1 eq
2524: { } % skip, may be weight [(x) 2 ] is OK.
2525: {
2526: /v0 vv ii get (string) dc def
2527: v0 (array) dc 0 get Dascii eq %% If the first character is D?
2528: { rule %% Dx-->x
2529: [v0 rr ,,
2530: v0 (array) dc rest { (string) dc} map aload length cat_n rr ,,]
2531: append /rule set
2532: }
2533: { rule %% x --> -Dx
2534: [v0 rr ,,
2535: (0).
2536: [Dascii] v0 (array) dc join { (string) dc } map aload length
2537: cat_n rr ,, sub
2538: ]
2539: append /rule set
2540: } ifelse
2541: } ifelse
2542: } for
2543: % rule message
2544: ff rule replace [[(h) rr ,, (1) rr ,,]] replace /ans1 set
2545: } ifelse
2546: }
2547: {
2548: ff isArray { /ans1 ff {vv laplace0 } map def }
2549: {
2550: (laplace0 : the first argument must be a polynomial.) error
2551: }ifelse
2552: } ifelse
2553: /arg1 ans1 def
2554: ] pop
2555: popVariables
2556: arg1
2557: } def
2558:
2559: [(ip1)
2560: [( [v1 ... vn] [w1 ... wn] m ip1 [f1 ... fs])
2561: (<poly> v1 ... vn ; <integer> w1 ... wn m)
2562: (<poly> f1 ... fs )
2563: (Example: [(x,y) ring_of_differential_operators 0] define_ring )
2564: ( [(Dx). (Dy).] [2 1] 3 ip1 :: [(2 Dx Dy). (Dy^3).])
2565: ( Returns Dx^p Dy^q such that 2 p + 1 q = 3.)
2566: ]
2567: ] putUsages
2568: /ip1 {
2569: /arg3 set /arg2 set /arg1 set
2570: [/in-ip1 /vv /ww /m /ans /k /tt /rr /rr.org /ff /tmp1] pushVariables
2571: [
2572: /vv arg1 def /ww arg2 def /m arg3 def
2573: vv 0 get (ring) dc /rr set
2574: /rr.org [(CurrentRingp)] system_variable def
2575: [(CurrentRingp) rr] system_variable
2576: [(x) (var) [(N)] system_variable 1 sub ] system_variable . /tt set
2577: /ans [ ] def
2578: m 0 lt
2579: { }
2580: {
2581: vv
2582: ww { tt 2 1 roll power } map mul /tmp1 set
2583: %% (tmp1 = ) messagen tmp1 message
2584: 0 1 m {
2585: /k set
2586: k 0 eq {
2587: /ff (1). def
2588: }
2589: { tmp1 k power /ff set } ifelse
2590: ff [[(h). (1).]] replace /ff set
2591: %% ff message
2592: {
2593: ff init tt degree m eq {
2594: /ans ans [ ff init [[tt (1).]] replace ] join def
2595: } { } ifelse
2596: ff ff init sub /ff set
2597: ff (0). eq { exit } { } ifelse
2598: } loop
2599: } for
2600: } ifelse
2601: [(CurrentRingp) rr.org] system_variable
2602: /arg1 ans def
2603: ] pop
2604: popVariables
2605: arg1
2606: } def
2607:
2608: [(findIntegralRoots)
2609: [( f findIntegralRoots vlist)
2610: (poly f; list of integers vlist;)
2611: (string f; list of integers vlist;)
2612: (f is a polynomials in one variable s. vlist the list of integral roots sorted.)
2613: (Example: (s^4-1) findIntegralRoots )
2614: ]
2615: ] putUsages
2616:
2617: /findIntegralRoots { findIntegralRoots.slow } def
2618:
2619: /findIntegralRoots.slow { %% by a stupid algorithm
2620: /arg1 set
2621: [/in-findIntegralRoots
2622: /ff /kk /roots /rrr /nn /k0 /d.find
2623: ] pushVariables
2624: [
2625: /ff arg1 def
2626: /roots [ ] def
2627: /rrr [(CurrentRingp)] system_variable def
2628: ff toString /ff set
2629: [(s) ring_of_polynomials ( ) elimination_order 0] define_ring
2630: ff . /ff set
2631:
2632: %%ff message %% Cancel the common numerical factor of the polynomial ff.
2633: ff (s). coeff 1 get { (universalNumber) dc } map ngcd /d.find set
2634: [(divByN) ff d.find] gbext 0 get /ff set
2635: %% d.find message
2636: %% ff message
2637:
2638: ff [[(s). (0).]] replace /k0 set
2639: k0 (universalNumber) dc /k0 set
2640: k0 (0).. eq { roots (0).. append /roots set } { } ifelse
2641:
2642: {
2643: ff [[(s). (0).]] replace /nn set
2644: nn (universalNumber) dc /nn set
2645: nn (0).. eq
2646: { (s^(-1)). ff mul /ff set }
2647: { exit }
2648: ifelse
2649: } loop
2650: ff [[(s). (0).]] replace /k0 set
2651: k0 (universalNumber) dc /k0 set
2652: k0 (-40000).. gt k0 (40000).. lt and not {
2653: [(Roots of b-function cannot be obtained by a stupid method.) nl
2654: (Use ox_asir for efficient factorizations, or restall and bfm manually.)
2655: nl
2656: (ox_asir server will be distributed from the asir ftp cite.) nl
2657: (See lib/ttt.tex for details.) nl
2658: ] cat
2659: error
2660: } { } ifelse
2661: nn (0).. lt { (0).. nn sub /nn set } { } ifelse
2662: /kk (0).. nn sub def
2663: /roots [ kk (1).. sub ] roots join def
2664: {
2665: kk nn gt { exit } { } ifelse
2666: ff [[(s). kk (poly) dc]] replace
2667: (0). eq
2668: { /roots roots kk append def }
2669: { } ifelse
2670: kk (1).. add /kk set
2671: } loop
2672: [(CurrentRingp) rrr] system_variable
2673: roots { (integer) dc } map /roots set %% ?? OK?
2674: roots shell rest /roots set
2675: /arg1 roots def
2676: ] pop
2677: popVariables
2678: arg1
2679: } def
2680:
2681: /ngcd {
2682: /arg1 set
2683: [/in-ngcd /nlist /g.ngcd /ans] pushVariables
2684: [
2685: /nlist arg1 def
2686: nlist length 2 lt
2687: { /ans nlist 0 get def /L.ngcd goto }
2688: {
2689: [(gcd) nlist 0 get nlist 1 get] mpzext /g.ngcd set
2690: g.ngcd (1).. eq { /ans (1).. def /L.ngcd goto } { } ifelse
2691: [g.ngcd] nlist rest rest join ngcd /ans set
2692: } ifelse
2693: /L.ngcd
2694: ans /arg1 set
2695: ] pop
2696: popVariables
2697: arg1
2698: } def
2699:
2700: [(ngcd)
2701: [(nlist ngcd d )
2702: (list of numbers nlist; number d;)
2703: (d is the gcd of the numbers in nlist.)
2704: (Example: [(12345).. (67890).. (98765)..] ngcd )
2705: ]] putUsages
2706:
2707: /dehomogenize {
2708: /arg1 set
2709: [/in-dehomogenize /f /rr /ans /cring] pushVariables
2710: [
2711: /f arg1 def
2712: f isPolynomial {
2713: f (0). eq
2714: { f /ans set }
2715: {
2716: f (ring) dc /rr set
2717: [(CurrentRingp)] system_variable /cring set
2718: [(CurrentRingp) rr] system_variable
2719: f [[[(D) (var) 0] system_variable . (1). ]] replace /ans set
2720: [(CurrentRingp) cring] system_variable
2721: } ifelse
2722: }
2723: {
2724: f isArray {
2725: f { dehomogenize } map /ans set
2726: }
2727: {(dehomogenize: argument should be a polynomial.) error }
2728: ifelse
2729: } ifelse
2730: /arg1 ans def
2731: ] pop
2732: popVariables
2733: arg1
2734: } def
2735:
2736: [(dehomogenize)
2737: [(obj dehomogenize obj2)
2738: (dehomogenize puts the homogenization variable to 1.)
2739: (Example: (x*h+h^2). dehomogenize :: x+1 )
2740: ]
2741: ] putUsages
2742:
2743:
2744: /from_records { { (,) } map aload length cat_n } def
2745: [(from_records)
2746: [ ([s1 s2 s3 ... sn] from_records (s1,s2,...,sn,))
2747: (Example : [(x) (y)] from_records :: (x,y,))
2748: (cf. to_records)
2749: ]
2750: ] putUsages
2751: /popEnv {
2752: { system_variable pop } map pop
2753: } def
2754:
2755: /pushEnv {
2756: %% opt=[(CurrentRingp) (NN)] ==> [[(CurrentRingp) val] [(NN) val]]
2757: { [ 2 1 roll dup [ 2 1 roll ] system_variable ] } map
2758: } def
2759: [(pushEnv)
2760: [(keylist pushEnv envlist)
2761: (array of string keylist, array of [string object] envlist;)
2762: (Values <<envlist>> of the global system variables specified )
2763: (by the <<keylist>> is push on the stack.)
2764: (keylist is an array of keywords for system_variable.)
2765: (cf. system_variable, popEnv)
2766: (Example: [(CurrentRingp) (KanGBmessage)] pushEnv)
2767: ]
2768: ] putUsages
2769: [(popEnv)
2770: [(envlist popEnv)
2771: (cf. pushEnv)
2772: ]
2773: ] putUsages
2774:
2775: /npower {
2776: /arg2 set
2777: /arg1 set
2778: [/f /k /i /ans] pushVariables
2779: [
2780: /f arg1 def /k arg2 ..int def
2781: f tag PolyP eq {
2782: /ans (1). def
2783: } {
2784: /ans (1).. def
2785: } ifelse
2786: k 0 lt {
2787: 1 1 << 0 k sub >> {
2788: /ans f ans {mul} sendmsg2 def
2789: } for
2790: /ans (1).. ans {div} sendmsg2 def
2791: }
2792: {
2793: 1 1 k {
2794: /ans f ans {mul} sendmsg2 def
2795: } for
2796: } ifelse
2797: /arg1 ans def
2798: ] pop
2799: popVariables
2800: arg1
2801: } def
2802: [(npower)
2803: [(obj1 obj2 npower obj3)
2804: (npower returns obj1^obj2 as obj3)
2805: (The difference between power and npower occurs when we compute f^0)
2806: (where f is a polynomial.)
2807: $power returns number(universalNumber) 1, but npower returns 1$
2808: (in the current ring.)
2809: ]
2810: ] putUsages
2811:
2812: /gensym {
2813: (dollar) dc 2 cat_n
2814: } def
2815: [(gensym)
2816: [(x i gensym xi)
2817: (string x; integer i; string xi)
2818: (It generate a string x indexed with the number i.)
2819: $Example: (Dx) 12 gensym (Dx12)$
2820: ]
2821: ] putUsages
2822:
2823: /cat {
2824: { toString } map aload length cat_n
2825: } def
2826: [(cat)
2827: [(a cat s)
2828: (array a ; string s;)
2829: (cat converts each entry of << a >> to a string and concatenates them.)
2830: (Example: [ (x) 1 2] cat ==> (x12))
2831: ]
2832: ] putUsages
2833:
2834:
2835: %%%%%%%%%%%%%%%%%%% pmat-level
2836: /pmat-level {
2837: /arg2 set
2838: /arg1 set
2839: [/n /i /m /lev /flag] pushVariables
2840: [
2841: /m arg1 def
2842: /lev arg2 def
2843: m isArray {
2844: /n m length def
2845: n 0 eq { /flag 0 def }
2846: { m 0 get isArray { /flag 1 def } { /flag 0 def} ifelse } ifelse
2847: } { /flag 0 def } ifelse
2848:
2849: flag {
2850: 0 1 lev {
2851: pop ( ) messagen
2852: } for
2853: ([ ) message
2854: 0 1 n 1 sub {
2855: /i set
2856: m i get lev 1 add pmat-level
2857: } for
2858: 0 1 lev {
2859: pop ( ) messagen
2860: } for
2861: (]) message
2862: }
2863: {
2864: 0 1 lev {
2865: pop ( ) messagen
2866: } for
2867: ( ) messagen
2868: m message
2869: } ifelse
2870: ] pop
2871: popVariables
2872: } def
2873:
2874: /pmat { 0 pmat-level } def
2875:
2876: [(pmat)
2877: [(f pmat)
2878: (array f;)
2879: (f is pretty printed.)
2880: ]
2881: ] putUsages
2882:
2883:
2884: /adjoint1 {
2885: /arg2 set
2886: /arg1 set
2887: [/in-adjoint1 /f /p /q /xx /dxx /ans /g /one] pushVariables
2888: [
2889: /f arg1 def
2890: /xx arg2 def
2891: f isPolynomial { }
2892: { (adjoint1: the first argument must be a polynomial.) message
2893: pop popVariables
2894: (adjoint1: the first argument must be a polynomial.) error
2895: } ifelse
2896: /ans (0). def
2897: f (0). eq { }
2898: {
2899: /xx xx (string) dc def
2900: /dxx [@@@.Dsymbol xx] cat def
2901: /xx xx f (ring) dc ,, def
2902: /dxx dxx f (ring) dc ,, def
2903: /one (1) f (ring) dc ,, def
2904:
2905: {
2906: /g f init def
2907: /f f g sub def
2908: /p g xx degree def
2909: /q g dxx degree def
2910: g [[xx one] [dxx one]] replace /g set
2911: g
2912: << (0). dxx sub q npower xx p npower mul >>
2913: mul
2914: ans add /ans set
2915: f (0). eq { exit } { } ifelse
2916: } loop
2917: ans dehomogenize /ans set
2918: } ifelse
2919: /arg1 ans def
2920: ] pop
2921: popVariables
2922: arg1
2923: } def
2924:
2925: /adjoint {
2926: /arg2 set
2927: /arg1 set
2928: [/in-adjoint /f /xx /xx0] pushVariables
2929: [
2930: /f arg1 def /xx arg2 def
2931: xx toString /xx set
2932: [xx to_records pop] /xx set
2933: xx { /xx0 set f xx0 adjoint1 /f set } map
2934: /arg1 f def
2935: ]pop
2936: popVariables
2937: arg1
2938: } def
2939:
2940: [(adjoint)
2941: [(f xlist adjoint g)
2942: (poly f; string xlist; poly g;)
2943: (g is the adjoint operator of f.)
2944: (The variables to take adjoint are specified by xlist.)
2945: (Example: [(x,y) ring_of_differential_operators 0] define_ring)
2946: ( (x^2 Dx - y x Dx Dy-2). (x,y) adjoint )
2947: $ ((-Dx) x^2 - (-Dx) (-Dy) x y -2). dehomogenize sub :: ==> 0$
2948: ]] putUsages
2949:
2950: %%%%% diagonal for tensor products
2951: %% 1998, 12/4 (Sat)
2952: %% s_i = x_i, t_i = x_i - y_i, Restrict to t_i = 0.
2953: %% x_i = x_i, y_i = s_i - t_i,
2954: %% Dx_i = Dt_i + Ds_i, Dy_i = -Dt_i.
2955: /diagonalx {
2956: /arg2 set
2957: /arg1 set
2958: [/in-diagonalx /f] pushVariables
2959: [
2960: (Not implemented yet.) message
2961: ] pop
2962: popVariables
2963: arg1
2964: } def
2965:
2966:
2967:
2968: %%%%%%%%%%% distraction2 for b-function
2969: /distraction2 {
2970: /arg4 set
2971: /arg3 set
2972: /arg2 set
2973: /arg1 set
2974: [/f /dx /ss /xx /ans /n /i /rr] pushVariables
2975: [
2976: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
2977: f (0). eq { }
2978: {
2979: /rr f (ring) dc def
2980: xx {toString rr ,, } map /xx set
2981: dx {toString rr ,, } map /dx set
2982: ss {toString rr ,, } map /ss set
2983: /n xx length def
2984: 0 1 n 1 sub {
2985: /i set
2986: /f f xx i get dx i get ss i get destraction2.1 /f set
2987: } for
2988: } ifelse
2989: /arg1 f def
2990: ]pop
2991: popVariables
2992: arg1
2993: } def
2994: [(distraction2)
2995: [(f [ list of x-variables ] [ list of D-variables ] [ list of s-variables ])
2996: ( distraction2 result )
2997: $Example 1: [(x,y) ring_of_differential_operators 0] define_ring $
2998: $ (x^2 Dx Dy + x Dy). [(x). (y).] [(Dx). (Dy).] [(x). (y).] distraction2$
2999: $Example 2: (x^4 Dx^2 + x^2). [(x).] [(Dx). ] [(x).] distraction2$
3000: ]
3001: ] putUsages
3002: /destraction2.1 {
3003: /arg4 set
3004: /arg3 set
3005: /arg2 set
3006: /arg1 set
3007: [/ww /f /dx /ss /xx /coeff0 /expvec
3008: /coeffvec /expvec2 /ans /one /rr /dd] pushVariables
3009: [
3010: /f arg1 def /xx arg2 def /dx arg3 def /ss arg4 def
3011: f (ring) dc /rr set
3012: /one (1) rr ,, def %%
3013: /ww [ xx toString -1 dx toString 1 ] weightv def
3014: f ww init f sub (0). eq { }
3015: { [(destraction2.1 : inhomogeneous with respect to )
3016: xx ( and ) dx nl
3017: (Your weight vector may not be generic.)
3018: ] cat error } ifelse
3019: /dd << f dx degree >> << f xx degree >> sub def
3020: f [[xx one]] replace dx coefficients /coeff0 set
3021: /expvec coeff0 0 get { (integer) dc } map def
3022: /coeffvec coeff0 1 get def
3023: expvec { ss 2 -1 roll factorial } map /expvec2 set
3024: expvec2 coeffvec mul /ans set
3025: %% x^p d^q, (p > q) case. x^2( x^2 Dx^2 + x Dx + 1)
3026: dd 0 lt {
3027: %% (ss+1) (ss+2) ... (ss+d)
3028: one 1 1 0 dd sub { (universalNumber) dc ss add mul} for
3029: ans mul /ans set
3030: }
3031: { } ifelse
3032: /arg1 ans def
3033: ] pop
3034: popVariables
3035: arg1
1.3 takayama 3036: } def
3037:
3038: /distraction2* {
3039: /arg1 set
3040: [/in-distraction2* /aa /f /vlist /xlist /dlist /slist ] pushVariables
3041: [(CurrentRingp)] pushEnv
3042: [
3043: /aa arg1 def
3044: /f aa 0 get def
3045: /vlist aa 1 get def
3046: /xlist aa 2 get def
3047: /dlist aa 3 get def
3048: /slist aa 4 get def
3049: vlist isArray
3050: {
3051: vlist { toString } map /vlist set
3052: }
3053: {
3054: vlist toString to_records /vlist set
3055: } ifelse
3056: xlist isArray
3057: {
3058: xlist { toString } map /xlist set
3059: }
3060: {
3061: xlist toString to_records /xlist set
3062: } ifelse
3063: slist isArray
3064: {
3065: slist { toString } map /slist set
3066: }
3067: {
3068: slist toString to_records /slist set
3069: } ifelse
3070: [vlist from_records ring_of_differential_operators 0] define_ring pop
3071: f toString .
3072: xlist { . } map
3073: dlist { toString . } map
3074: slist { toString . } map
3075: distraction2 /arg1 set
3076: ] pop
3077: popEnv
3078: popVariables
3079: arg1
1.1 maekawa 3080: } def
3081:
3082: /message-quiet {
3083: @@@.quiet { pop } { message } ifelse
3084: } def
3085: [(message-quiet)
3086: [(s message-quiet )
3087: (string s;)
3088: (It outputs the message s when @@@.quiet is not equal to 1.)
3089: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3090: ]] putUsages
3091: /messagen-quiet {
3092: @@@.quiet { pop } { messagen } ifelse
3093: } def
3094: [(messagen-quiet)
3095: [(s messagen-quiet )
3096: (string s;)
3097: (It outputs the message s without the newline when @@@.quiet is not equal to 1.)
3098: (@@@.quiet is set to 1 when you start sm1 with the option -q.)
3099: ]] putUsages
3100:
3101: /getvNames0 {
3102: /arg1 set
3103: [/in-getvNames0 /nlist /nn /i] pushVariables
3104: [
3105: /nlist arg1 def
3106: [(N)] system_variable /nn set
3107: nlist { /i set
3108: i nn lt {
3109: [(x) (var) i] system_variable
3110: } {
3111: [(D) (var) i nn sub] system_variable
3112: } ifelse
3113: } map
3114: /arg1 set
3115: ] pop
3116: popVariables
3117: arg1
3118: } def
3119:
3120: /getvNames {
3121: [/in-getvNames /nn] pushVariables
3122: [
3123: [(N)] system_variable /nn set
3124: [0 1 nn 2 mul 1 sub { } for] getvNames0 /arg1 set
3125: ] pop
3126: popVariables
3127: arg1
3128: } def
3129: [(getvNames)
3130: [(getvNames vlist)
3131: (list vlist)
3132: (It returns of the list of the variables in the order x0, x1, ..., D0, ...)
3133: (Use with [(variableNames) vlist] system_variable.)
3134: (cf. nlist getvNames0 vlist is used internally. cf. getvNamesC)
3135: ]] putUsages
3136:
3137: /getvNamesC {
3138: [/in-getvNamesC /nn /i] pushVariables
3139: [
3140: [(N)] system_variable /nn set
3141: [nn 1 sub -1 0 { } for nn 2 mul 1 sub -1 nn { } for ] getvNames0 /arg1 set
3142: ] pop
3143: popVariables
3144: arg1
3145: } def
3146: [(getvNamesC)
3147: [(getvNamesC vlist)
3148: (list vlist)
3149: $It returns of the list of the variables in the order 0, 1, 2, ... $
3150: $(cmo-order and output_order).$
3151: (cf. getvNames)
3152: ]] putUsages
3153:
3154: /getvNamesCR {
3155: /arg1 set
3156: [/in-getvNamesCR /rrr] pushVariables
3157: [(CurrentRingp)] pushEnv
3158: [
3159: /rrr arg1 def
3160: rrr isPolynomial {
3161: rrr (0). eq { (No name field for 0 polynomial.) error }
3162: { rrr (ring) dc /rrr set } ifelse
3163: } { } ifelse
3164: [(CurrentRingp) rrr] system_variable
3165: getvNamesC /arg1 set
3166: ] pop
3167: popEnv
3168: popVariables
3169: arg1
3170: } def
3171: [(getvNamesCR)
3172: [(obj getvNamesCR vlist)
3173: (obj ring | poly ; list vlist)
3174: $It returns of the list of the variables in the order 0, 1, 2, ... (cmo-order)$
3175: (for <<obj>>.)
3176: (Example: ( (x-2)^3 ). /ff set )
3177: ( [(x) ring_of_differential_operators 0] define_ring ff getvNamesCR ::)
3178: ]] putUsages
3179:
3180:
3181: /reduction-noH {
3182: /arg2 set
3183: /arg1 set
3184: [/in-reduction-noH /ff /gg] pushVariables
3185: [(Homogenize)] pushEnv
3186: [
3187: /ff arg1 def
3188: /gg arg2 def
3189: [(Homogenize) 0] system_variable
3190: ff gg reduction /arg1 set
3191: ] pop
3192: popEnv
3193: popVariables
3194: arg1
3195: } def
3196: [(reduction-noH)
3197: [(f g reduction-noH r)
3198: (poly f; array g; array r;)
3199: (Apply the normal form algorithm for f with the set g. All computations are)
3200: (done with the rule Dx x = x Dx +1, i.e., no homogenization, but other)
3201: (specifications are the same with reduction. cf. reduction)
3202: (g should be dehomogenized.)
3203: ]] putUsages
3204:
3205: /-intInfinity -999999999 def
3206: /intInfinity 999999999 def
3207: [(intInfinity)
3208: [(intInfinity = 999999999)]
3209: ] putUsages
3210: [(-intInfinity)
3211: [(-intInfinity = -999999999)]
3212: ] putUsages
3213:
3214:
3215: /maxInArray {
3216: /arg1 set
3217: [/in-maxInArray /v /ans /i /n] pushVariables
3218: [
3219: /v arg1 def
3220: /n v length def
3221: /maxInArray.pos 0 def
3222: n 0 eq {
3223: /ans null def
3224: } {
3225: /ans v 0 get def
3226: 1 1 n 1 sub {
3227: /i set
3228: v i get ans gt {
3229: /ans v i get def
3230: /maxInArray.pos i def
3231: } { } ifelse
3232: } for
3233: } ifelse
3234: /arg1 ans def
3235: ] pop
3236: popVariables
3237: arg1
3238: } def
3239: [(maxInArray)
3240: [( [v1 v2 ....] maxInArray m )
3241: (m is the maximum in [v1 v2 ...].)
3242: (The position of m is stored in the global variable maxInArray.pos.)
3243: ]] putUsages
3244:
3245: /cancelCoeff {
3246: /arg1 set
3247: [/in-cancelCoeff /ff /gg /dd /dd2] pushVariables
3248: [ /ff arg1 def
3249: ff (0). eq {
3250: /label.cancelCoeff2 goto
3251: } { } ifelse
3252: /gg ff def
3253: /dd [(lcoeff) ff init ] gbext (universalNumber) dc def
3254: {
3255: gg (0). eq { exit} { } ifelse
3256: [(lcoeff) gg init] gbext (universalNumber) dc /dd2 set
3257: [(gcd) dd dd2] mpzext /dd set
3258: dd (1).. eq {
3259: /label.cancelCoeff goto
3260: } { } ifelse
3261: /gg gg gg init sub def
3262: } loop
3263: [(divByN) ff dd] gbext 0 get /ff set
3264: /label.cancelCoeff
3265: [(lcoeff) ff init] gbext (universalNumber) dc (0).. lt
3266: { ff (-1).. mul /ff set } { } ifelse
3267: /label.cancelCoeff2
3268: /arg1 ff def
3269: ] pop
3270: popVariables
3271: arg1
3272: } def
3273: [(cancelCoeff)
3274: [(f cancelcoeff g)
3275: (poly f,g;)
3276: (Factor out the gcd of the coefficients.)
3277: (Example: (6 x^2 - 10 x). cancelCoeff)
3278: (See also gbext.)
3279: ]] putUsages
3280:
3281:
3282: /flatten {
3283: /arg1 set
3284: [/in-flatten /mylist] pushVariables
3285: [
3286: /mylist arg1 def
3287: mylist isArray {
3288: mylist { dup isArray { aload pop } { } ifelse } map /mylist set
3289: }{ } ifelse
3290: /arg1 mylist def
3291: ] pop
3292: popVariables
3293: arg1
3294: } def
3295: [(flatten)
3296: [(list flatten list2)
3297: (Flatten the list.)
3298: (Example 1: [ [1 2 3] 4 [2]] flatten ===> [1 2 3 4 2])
3299: ]] putUsages
3300:
3301: %% Take first N elements.
3302: /carN {
3303: /arg2 set
3304: /arg1 set
3305: [/in-res-getN /pp /nn /ans] pushVariables
3306: [
3307: /nn arg2 def
3308: /pp arg1 def
3309: pp isArray {
3310: pp length nn lt {
3311: /ans pp def
3312: } {
3313: [pp aload length nn sub /nn set 1 1 nn { pop pop } for ] /ans set
3314: } ifelse
3315: } {
3316: /ans pp def
3317: } ifelse
3318: /arg1 ans def
3319: ] pop
3320: popVariables
3321: arg1
3322: } def
3323: [(carN)
3324: [([f1 ... fm] n carN [f1 ... fn])
3325: (carN extracts the first n elements from the list.)
3326: ]] putUsages
3327:
3328: /getRing {
3329: /arg1 set
3330: [/in-getRing /aa /n /i /ans] pushVariables
3331: [
3332: /aa arg1 def
3333: /ans null def
3334: aa isPolynomial {
3335: aa (0). eq {
3336: } {
3337: /ans aa (ring) dc def
3338: } ifelse
3339: } {
3340: aa isArray {
3341: /n aa length 1 sub def
3342: 0 1 n { /i set aa i get getRing /ans set
3343: ans tag 0 eq { } { /getRing.LLL goto } ifelse
3344: } for
3345: }{ } ifelse
3346: } ifelse
3347: /getRing.LLL
3348: /arg1 ans def
3349: ] pop
3350: popVariables
3351: arg1
3352: } def
3353: [(getRing)
3354: [(obj getRing rr)
3355: (ring rr;)
3356: (getRing obtains the ring structure from obj.)
3357: (If obj is a polynomial, it returns the ring structure associated to)
3358: (the polynomial.)
3359: (If obj is an array, it recursively looks for the ring structure.)
3360: ]] putUsages
3361: /toVectors {
3362: /arg1 set
3363: [/in-toVectors /gg /n /ans] pushVariables
3364: [
3365: /gg arg1 def
3366: gg isArray {
3367: gg length 0 eq {
3368: /ans [ ] def
3369: /toVectors.LLL goto
3370: } {
3371: gg 0 get isInteger {
3372: gg @@@.toVectors2 /ans set
3373: } {
3374: gg @@@.toVectors /ans set
3375: } ifelse
3376: /toVectors.LLL goto
3377: } ifelse
3378: } {
3379: %% It is not array.
3380: gg (array) dc /ans set
3381: } ifelse
3382: /toVectors.LLL
3383: /arg1 ans def
3384: ] pop
3385: popVariables
3386: arg1
3387: } def
3388: /@@@.toVectors2 {
3389: /arg1 set
3390: [/in-@@@.toVectors2 /gg /ans /n /tmp /notarray] pushVariables
3391: [
3392: /gg arg1 def
3393: /ans gg 1 get @@@.toVectors def
3394: /n gg 0 get def
3395: gg 1 get isArray not {
3396: /ans [ans] def
3397: /notarray 1 def
3398: }{ /notarray 0 def} ifelse
3399: ans {
3400: /tmp set
3401: tmp length n lt {
3402: tmp
3403: [1 1 n tmp length sub { pop (0). } for ]
3404: join /tmp set
3405: } { } ifelse
3406: tmp
3407: } map
3408: /ans set
3409: notarray { ans 0 get /ans set } { } ifelse
3410: /arg1 ans def
3411: ] pop
3412: popVariables
3413: arg1
3414: } def
3415:
3416: /@@@.toVectors {
3417: /arg1 set
3418: [/in-@@@.toVectors /gg ] pushVariables
3419: [
3420: /gg arg1 def
3421: gg isArray {
3422: gg { $array$ data_conversion } map
3423: } {
3424: gg (array) data_conversion
3425: }ifelse
3426: /arg1 set
3427: ] pop
3428: popVariables
3429: arg1
3430: } def
3431:
3432: /toVectors2 { toVectors } def
3433:
3434: /fromVectors { { fromVectors.aux } map } def
3435: /fromVectors.aux {
3436: /arg1 set
3437: [/in-fromVector.aux /vv /mm /ans /i /ee] pushVariables
3438: [(CurrentRingp)] pushEnv
3439: [
3440: /vv arg1 def
3441: /mm vv length def
3442: /ans (0). def
3443: /ee (0). def
3444: 0 1 mm 1 sub {
3445: /i set
3446: vv i get (0). eq {
3447: } {
3448: [(CurrentRingp) vv i get (ring) dc] system_variable
3449: [(x) (var) [(N)] system_variable 1 sub] system_variable . /ee set
3450: /fromVector.LLL goto
3451: } ifelse
3452: } for
3453: /fromVector.LLL
3454: %% vv message
3455: 0 1 mm 1 sub {
3456: /i set
3457: vv i get (0). eq {
3458: } {
3459: /ans ans
3460: << vv i get >> << ee i npower >> mul
3461: add def
3462: } ifelse
3463: %% [i ans] message
3464: } for
3465: /arg1 ans def
3466: ] pop
3467: popEnv
3468: popVariables
3469: arg1
3470: } def
3471: [(fromVectors)
3472: [
3473: ([v1 v2 ...] fromVectors [s1 s2 ...])
3474: (array of poly : v1, v2, ... ; poly : s1, s2 ....)
3475: (cf. toVectors. <<e_>> varaible is assumed to be the last )
3476: ( variable in x. @@@.esymbol)
3477: $Example: [(x,y) ring_of_differential_operators 0] define_ring$
3478: $ [(x). (y).] /ff set $
3479: $ [ff ff] fromVectors :: $
3480: ]] putUsages
3481:
3482: /getOrderMatrix {
3483: /arg1 set
3484: [/in-getOrderMatrix /obj /rr /ans /ans2 /i] pushVariables
3485: [(CurrentRingp)] pushEnv
3486: [
3487: /obj arg1 def
3488: obj isArray {
3489: obj { getOrderMatrix } map /ans set
3490: ans length 0 {
3491: /ans null def
3492: } {
3493: /ans2 null def
3494: 0 1 ans length 1 sub {
3495: /i set
3496: ans i get tag 0 eq
3497: { }
3498: { /ans2 ans i get def } ifelse
3499: } for
3500: /ans ans2 def
3501: } ifelse
3502: /getOrderMatrix.LLL goto
3503: } { } ifelse
3504: obj tag 14 eq {
3505: [(CurrentRingp) obj] system_variable
3506: [(orderMatrix)] system_variable /ans set
3507: /getOrderMatrix.LLL goto
3508: } { } ifelse
3509: obj isPolynomial {
3510: obj (0). eq
3511: { /ans null def
3512: } { obj getRing /rr set
3513: [(CurrentRingp) rr] system_variable
3514: [(orderMatrix)] system_variable /ans set
3515: } ifelse
3516: /getOrderMatrix.LLL goto
3517: } { (getOrderMatrix: wrong argument.) error } ifelse
3518: /getOrderMatrix.LLL
3519: /arg1 ans def
3520: ] pop
3521: popEnv
3522: popVariables
3523: arg1
3524: } def
3525:
3526:
3527: [(getOrderMatrix)
3528: [(obj getOrderMatrix m)
3529: (array m)
3530: (getOrderMatrix obtains the order matrix from obj.)
3531: (If obj is a polynomial, it returns the order matrix associated to)
3532: (the polynomial.)
3533: (If obj is an array, it returns an order matrix of an element.)
3534: ]] putUsages
3535:
3536: /nl {
3537: 10 $string$ data_conversion
3538: } def
3539: [(nl)
3540: [(nl is the newline character.)
3541: $Example: [(You can break line) nl (here.)] cat message$
1.4 takayama 3542: ]] putUsages
3543:
3544: /to_int {
3545: /arg1 set
3546: [/to-int /ob /ans] pushVariables
3547: [
3548: /ob arg1 def
3549: /ans ob def
3550: ob isArray {
3551: ob {to_int} map /ans set
3552: /LLL.to_int goto
3553: } { } ifelse
3554: ob isInteger {
3555: ob (universalNumber) dc /ans set
3556: /LLL.to_int goto
3557: } { } ifelse
3558: /LLL.to_int
3559: /arg1 ans def
3560: ] pop
3561: popVariables
3562: arg1
3563: } def
3564: [(to_int)
3565: [(obj to_int obj2)
3566: (All integers in obj are changed to universalNumber.)
3567: (Example: /ff [1 2 [(hello) (0).]] def ff { tag } map ::)
3568: ( ff to_int { tag } map :: )
1.5 takayama 3569: ]] putUsages
3570:
3571: /define_ring_variables {
1.6 takayama 3572: [/in-define_ring_variables /drv._v /drv._p /drv._v0] pushVariables
3573: %% You cannot use these names for names for polynomials.
1.5 takayama 3574: [
1.6 takayama 3575: /drv._v getVariableNames def
3576: /drv._v0 drv._v def
3577: drv._v { dup /drv._p set (/) 2 1 roll ( $) drv._p ($. def ) } map cat
3578: /drv._v set
3579: % drv._v message
3580: [(parse) drv._v] extension
1.5 takayama 3581: ] pop
3582: popVariables
3583: } def
3584: [(define_ring_variables)
3585: [(It binds a variable <<a>> in the current ring to the sm1 variable <<a>>.)
3586: (For example, if x is a variable in the current ring, it defines the sm1)
3587: (variable x by /x (x) def)
3588: ]] putUsages
3589:
3590: /boundp {
3591: /arg1 set
3592: [/a /ans] pushVariables
3593: [
3594: /a arg1 def
3595: [(parse) [(/) a ( load tag 0 eq { /ans 0 def } )
3596: ( { /ans 1 def } ifelse )] cat ] extension
3597: /arg1 ans def
3598: ] pop
3599: popVariables
3600: arg1
3601: } def
3602: [(boundp)
3603: [( a boundp b)
3604: (string a, b is 0 or 1.)
3605: (If the variable named << a >> is bounded to a value,)
3606: (it returns 1 else it returns 0.)
3607: $Example: (hoge) boundp ::$
1.1 maekawa 3608: ]] putUsages
3609:
3610: ;
3611:
3612:
3613:
3614:
3615:
3616:
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