![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to dr.sm1.old1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Kan|
Return to dr.sm1.old1 CVS log | Up to [local] / OpenXM / src / kan96xx / Kan |
1.1 maekawa 1: %% dr.sm1 (Define Ring) 1994/9/25, 26
2:
3: (dr.sm1 Version 10/8/1994. ) message
4: %% n evenQ bool
5: /evenQ {
6: /arg1 set
7: arg1 2 idiv 2 mul arg1 sub 0 eq
8: { true }
9: { false } ifelse
10: } def
11:
12: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
13: /ring_of_polynomials {
14: /arg1 set
15: [/vars /n /i /xList /dList /param] pushVariables
16: %dup print (-----) message
17: [
18: (mmLarger) (matrix) switch_function
19: (mpMult) (poly) switch_function
20: (red@) (module1) switch_function
21: (groebner) (standard) switch_function
22:
23: [arg1 to_records pop] /vars set
24: vars length evenQ
25: { }
26: { vars [(PAD)] join /vars set }
27: ifelse
28: vars length 2 idiv /n set
29: [ << n 1 sub >> -1 0
30: { /i set
31: vars i get
32: } for
33: ] /xList set
34: [ << n 1 sub >> -1 0
35: { /i set
36: vars << i n add >> get
37: } for
38: ] /dList set
39:
40: [(H)] xList join [(e)] join /xList set
41: [(h)] dList join [(E)] join /dList set
42: [0 %% dummy characteristic
43: << xList length >> << xList length >> << xList length >>
44: << xList length >>
45: << xList length 1 sub >> << xList length >> << xList length >>
46: << xList length >>
47: ] /param set
48:
49: [xList dList param] /arg1 set
50: ] pop
51: popVariables
52: arg1
53: } def
54:
55: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
56: %% with no graduation and homogenization variables.
57: /ring_of_polynomials2 {
58: /arg1 set
59: [/vars /n /i /xList /dList /param] pushVariables
60: %dup print (-----) message
61: [
62: (mmLarger) (matrix) switch_function
63: (mpMult) (poly) switch_function
64: (red@) (module1) switch_function
65: (groebner) (standard) switch_function
66:
67: [arg1 to_records pop] /vars set
68: vars length evenQ
69: { }
70: { vars [(PAD)] join /vars set }
71: ifelse
72: vars length 2 idiv /n set
73: [ << n 1 sub >> -1 0
74: { /i set
75: vars i get
76: } for
77: ] /xList set
78: [ << n 1 sub >> -1 0
79: { /i set
80: vars << i n add >> get
81: } for
82: ] /dList set
83:
84: [0 %% dummy characteristic
85: << xList length >> << xList length >> << xList length >>
86: << xList length >>
87: << xList length >> << xList length >> << xList length >>
88: << xList length >>
89: ] /param set
90:
91: [xList dList param] /arg1 set
92: ] pop
93: popVariables
94: arg1
95: } def
96:
97: /ring_of_differential_operators {
98: /arg1 set
99: [/vars /n /i /xList /dList /param] pushVariables
100: [
101: (mmLarger) (matrix) switch_function
102: (mpMult) (diff) switch_function
103: (red@) (module1) switch_function
104: (groebner) (standard) switch_function
105:
106: [arg1 to_records pop] /vars set %[x y z]
107: vars reverse /xList set %[z y x]
108: vars {(D) 2 1 roll 2 cat_n} map
109: reverse /dList set %[Dz Dy Dx]
110: [(H)] xList join [(e)] join /xList set
111: [(h)] dList join [(E)] join /dList set
112: [0 1 1 1 << xList length >>
113: 1 1 1 << xList length 1 sub >> ] /param set
114: [ xList dList param ] /arg1 set
115: ] pop
116: popVariables
117: arg1
118: } def
119:
120: /ring_of_differential_operators3 {
121: %% with no homogenization variables.
122: /arg1 set
123: [/vars /n /i /xList /dList /param] pushVariables
124: [
125: (mmLarger) (matrix) switch_function
126: (mpMult) (diff) switch_function
127: (red@) (module1) switch_function
128: (groebner) (standard) switch_function
129:
130: [arg1 to_records pop] /vars set %[x y z]
131: vars reverse /xList set %[z y x]
132: vars {(D) 2 1 roll 2 cat_n} map
133: reverse /dList set %[Dz Dy Dx]
134: xList [(e)] join /xList set
135: dList [(E)] join /dList set
136: [0 0 0 0 << xList length >>
137: 0 0 0 << xList length 1 sub >> ] /param set
138: [ xList dList param ] /arg1 set
139: ] pop
140: popVariables
141: arg1
142: } def
143:
144: /ring_of_q_difference_operators {
145: /arg1 set
146: [/vars /n /i /xList /dList /param] pushVariables
147: [
148: (mmLarger) (qmatrix) switch_function
149: (mpMult) (diff) switch_function
150: (red@) (qmodule1) switch_function
151: (groebner) (standard) switch_function
152:
153: [arg1 to_records pop] /vars set %[x y z]
154: vars reverse /xList set %[z y x]
155: vars {(Q) 2 1 roll 2 cat_n} map
156: reverse /dList set %[Dz Dy Dx]
157: [(q)] xList join [(e)] join /xList set
158: [(h)] dList join [(E)] join /dList set
159: [0 1 << xList length >> << xList length >> << xList length >>
160: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
161: /param set
162: [ xList dList param ] /arg1 set
163: ] pop
164: popVariables
165: arg1
166: } def
167:
168: /ring_of_q_difference_operators3 {
169: %% with no homogenization and q variables.
170: /arg1 set
171: [/vars /n /i /xList /dList /param] pushVariables
172: [
173: (mmLarger) (qmatrix) switch_function
174: (mpMult) (diff) switch_function
175: (red@) (qmodule1) switch_function
176: (groebner) (standard) switch_function
177:
178: [arg1 to_records pop] /vars set %[x y z]
179: vars reverse /xList set %[z y x]
180: vars {(Q) 2 1 roll 2 cat_n} map
181: reverse /dList set %[Dz Dy Dx]
182: xList [(e)] join /xList set
183: dList [(E)] join /dList set
184: [0 0 << xList length >> << xList length >> << xList length >>
185: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
186: /param set
187: [ xList dList param ] /arg1 set
188: ] pop
189: popVariables
190: arg1
191: } def
192:
193: /reverse {
194: /arg1 set
195: arg1 length 1 lt
196: { [ ] }
197: {
198: [
199: << arg1 length 1 sub >> -1 0
200: {
201: arg1 2 1 roll get
202: } for
203: ]
204: } ifelse
205: } def
206:
207: /memberQ {
208: %% a set0 memberQ bool
209: /arg2 set /arg1 set
210: [/a /set0 /flag /i ] pushVariables
211: [
212: /a arg1 def /set0 arg2 def
213: /flag 0 def
214: 0 1 << set0 length 1 sub >>
215: {
216: /i set
217: << set0 i get >> a eq
218: {
219: /flag 1 def
220: }
221: { }
222: ifelse
223: } for
224: ] pop
225: /arg1 flag def
226: popVariables
227: arg1
228: } def
229:
230: /transpose {
231: %% mat transpose mat2
232: /arg1 set
233: [/i /j /m /n /flat /mat] pushVariables
234: [
235: /mat arg1 def
236: /n mat length def
237: /m mat 0 get length def
238:
239: [
240: 0 1 << n 1 sub >>
241: {
242: /i set
243: mat i get aload pop
244: } for
245: ] /flat set
246: %% [[1 2] [3 4]] ---> flat == [1 2 3 4]
247:
248: [
249: 0 1 << m 1 sub >>
250: {
251: /i set
252: [
253: 0 1 << n 1 sub >>
254: {
255: /j set
256: flat
257: << j m mul >> i add
258: get
259: } for
260: ]
261: } for
262: ] /arg1 set
263: ] pop
264: popVariables
265: arg1
266: } def
267:
268:
269: /getPerm {
270: %% old new getPerm perm
271: /arg2 set /arg1 set
272: [/old /new /i /j /p] pushVariables
273: [
274: /old arg1 def
275: /new arg2 def
276: [
277: /p old length def
278: 0 1 << p 1 sub >>
279: {
280: /i set
281: 0 1 << p 1 sub >>
282: {
283: /j set
284: old i get
285: new j get
286: eq
287: { j }
288: { } ifelse
289: } for
290: } for
291: ] /arg1 set
292: ] pop
293: popVariables
294: arg1
295: } def
296:
297: /permuteOrderMatrix {
298: %% order perm puermuteOrderMatrix newOrder
299: /arg2 set /arg1 set
300: [/order /perm /newOrder /k ] pushVariables
301: [
302: /order arg1 def
303: /perm arg2 def
304: order transpose /order set
305: order 1 copy /newOrder set pop
306:
307: 0 1 << perm length 1 sub >>
308: {
309: /k set
310: newOrder << perm k get >> << order k get >> put
311: } for
312: newOrder transpose /newOrder set
313: ] pop
314: /arg1 newOrder def
315: popVariables
316: arg1
317: } def
318:
319:
320:
321: /complement {
322: %% set0 universe complement compl
323: /arg2 set /arg1 set
324: [/set0 /universe /compl /i] pushVariables
325: /set0 arg1 def /universe arg2 def
326: [
327: 0 1 << universe length 1 sub >>
328: {
329: /i set
330: << universe i get >> set0 memberQ
331: { }
332: { universe i get }
333: ifelse
334: } for
335: ] /arg1 set
336: popVariables
337: arg1
338: } def
339:
340:
341: %%% from order.sm1
342:
343: %% size i evec [0 0 ... 0 1 0 ... 0]
344: /evec {
345: /arg2 set /arg1 set
346: [/size /iii] pushVariables
347: /size arg1 def /iii arg2 def
348: [
349: 0 1 << size 1 sub >>
350: {
351: iii eq
352: { 1 }
353: { 0 }
354: ifelse
355: } for
356: ] /arg1 set
357: popVariables
358: arg1
359: } def
360:
361: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
362: /evec_neg {
363: /arg2 set /arg1 set
364: [/size /iii] pushVariables
365: /size arg1 def /iii arg2 def
366: [
367: 0 1 << size 1 sub >>
368: {
369: iii eq
370: { -1 }
371: { 0 }
372: ifelse
373: } for
374: ] /arg1 set
375: popVariables
376: arg1
377: } def
378:
379:
380: %% size i j e_ij << matrix e(i,j) >>
381: /e_ij {
382: /arg3 set /arg2 set /arg1 set
383: [/size /k /i /j] pushVariables
384: [
385: /size arg1 def /i arg2 def /j arg3 def
386: [ 0 1 << size 1 sub >>
387: {
388: /k set
389: k i eq
390: { size j evec }
391: {
392: k j eq
393: { size i evec }
394: { size k evec }
395: ifelse
396: } ifelse
397: } for
398: ] /arg1 set
399: ] pop
400: popVariables
401: arg1
402: } def
403:
404:
405: %% m1 m2 oplus
406: /oplus {
407: /arg2 set /arg1 set
408: [/m1 /m2 /n /m /k ] pushVariables
409: [
410: /m1 arg1 def /m2 arg2 def
411: m1 length /n set
412: m2 length /m set
413: [
414: 0 1 << n m add 1 sub >>
415: {
416: /k set
417: k n lt
418: {
419: << m1 k get >> << m -1 evec >> join
420: }
421: {
422: << n -1 evec >> << m2 << k n sub >> get >> join
423: } ifelse
424: } for
425: ] /arg1 set
426: ] pop
427: popVariables
428: arg1
429: } def
430:
431: %%%%%%%%%%%%%%%%%%%%%%%
432:
433: /eliminationOrderTemplate { %% esize >= 1
434: %% if esize == 0, it returns reverse lexicographic order.
435: %% m esize eliminationOrderTemplate mat
436: /arg2 set /arg1 set
437: [/m /esize /m1 /m2 /k ] pushVariables
438: [
439: /m arg1 def /esize arg2 def
440: /m1 m esize sub 1 sub def
441: /m2 esize 1 sub def
442: [esize 0 gt
443: {
444: [1 1 esize
445: { pop 1 } for
446: esize 1 << m 1 sub >>
447: { pop 0 } for
448: ] %% 1st vector
449: }
450: { } ifelse
451:
452: m esize gt
453: {
454: [1 1 esize
455: { pop 0 } for
456: esize 1 << m 1 sub >>
457: { pop 1 } for
458: ] %% 2nd vector
459: }
460: { } ifelse
461:
462: m1 0 gt
463: {
464: m 1 sub -1 << m m1 sub >>
465: {
466: /k set
467: m k evec_neg
468: } for
469: }
470: { } ifelse
471:
472: m2 0 gt
473: {
474: << esize 1 sub >> -1 1
475: {
476: /k set
477: m k evec_neg
478: } for
479: }
480: { } ifelse
481:
482: ] /arg1 set
483: ] pop
484: popVariables
485: arg1
486: } def
487:
488:
489: /elimination_order {
490: %% [x-list d-list params] (x,y,z) elimination_order
491: %% vars evars
492: %% [x-list d-list params order]
493: /arg2 set /arg1 set
494: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
495: /vars arg1 def /evars [arg2 to_records pop] def
496: [
497: /univ vars 0 get reverse
498: vars 1 get reverse join
499: def
500:
501: << univ length 2 sub >>
502: << evars length >>
503: eliminationOrderTemplate /order set
504:
505: [[1]] order oplus [[1]] oplus /order set
506:
507: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
508:
509: /compl
510: [univ 0 get] evars join evars univ0 complement join
511: def
512: compl univ
513: getPerm /perm set
514: %%perm :: univ :: compl ::
515:
516: order perm permuteOrderMatrix /order set
517:
518: vars [order] join /arg1 set
519: ] pop
520: popVariables
521: arg1
522: } def
523:
524: /elimination_order2 {
525: %% [x-list d-list params] (x,y,z) elimination_order
526: %% vars evars
527: %% [x-list d-list params order]
528: %% with no graduation and homogenization variables.
529: /arg2 set /arg1 set
530: [/vars /evars /univ /order /perm /compl] pushVariables
531: /vars arg1 def /evars [arg2 to_records pop] def
532: [
533: /univ vars 0 get reverse
534: vars 1 get reverse join
535: def
536:
537: << univ length >>
538: << evars length >>
539: eliminationOrderTemplate /order set
540: /compl
541: evars << evars univ complement >> join
542: def
543: compl univ
544: getPerm /perm set
545: %%perm :: univ :: compl ::
546:
547: order perm permuteOrderMatrix /order set
548:
549: vars [order] join /arg1 set
550: ] pop
551: popVariables
552: arg1
553: } def
554:
555:
556: /elimination_order3 {
557: %% [x-list d-list params] (x,y,z) elimination_order
558: %% vars evars
559: %% [x-list d-list params order]
560: /arg2 set /arg1 set
561: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
562: /vars arg1 def /evars [arg2 to_records pop] def
563: [
564: /univ vars 0 get reverse
565: vars 1 get reverse join
566: def
567:
568: << univ length 1 sub >>
569: << evars length >>
570: eliminationOrderTemplate /order set
571:
572: [[1]] order oplus /order set
573:
574: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
575:
576: /compl
577: [univ 0 get] evars join evars univ0 complement join
578: def
579: compl univ
580: getPerm /perm set
581: %%perm :: univ :: compl ::
582:
583: order perm permuteOrderMatrix /order set
584:
585: vars [order] join /arg1 set
586: ] pop
587: popVariables
588: arg1
589: } def
590:
591:
592: /define_ring {
593: %[ (x,y,z) ring_of_polynominals
594: % (x,y) elimination_order
595: % 17
596: %] define_ring
597: /arg1 set
598: [/rp /param /foo] pushVariables
599: [/rp arg1 def
600: [
601: rp 0 get 0 get
602: rp 0 get 1 get
603: rp 0 get 2 get /param set
604: param 0 << rp 1 get >> put
605: param
606: rp 0 get 3 get
607: ] /foo set
608: foo aload pop set_up_ring@
609: ] pop
610: popVariables
611: } def
612:
613: /defineTests1 {
614: /test {
615: [[1 2 3]
616: [0 1 0]
617: [0 1 2]]
618: [0 2 1] permuteOrderMatrix ::
619: } def
620:
621: /test2 { (x,y,z) ring_of_polynomials (z,y) elimination_order /ans set } def
622:
623: /test3 {
624: [ (x,y,z) ring_of_polynomials
625: (x,y) elimination_order
626: 17
627: ] define_ring
628: } def
629:
630: /test4 {
631: [ (x,y,z) ring_of_polynomials
632: ( ) elimination_order
633: 17
634: ] define_ring
635: } def
636:
637: } def
638:
639: %% misterious bug (x,y) miss
640: /miss {
641: /arg1 set
642: %[/vars /n /i /xList /dList /param] pushVariables
643: [/vars /i] pushVariables
644: [ arg1 print
645: [arg1 to_records pop] /vars set
646:
647: ] pop
648: dup print
649: popVariables
650: arg1
651: } def
652:
653:
654: /lexicographicOrderTemplate {
655: % size lexicographicOrderTemplate matrix
656: /arg1 set
657: [/k /size] pushVariables
658: [
659: /size arg1 def
660: [ 0 1 << size 1 sub >>
661: {
662: /k set
663: size k evec
664: } for
665: ] /arg1 set
666: ] pop
667: popVariables
668: arg1
669: } def
670:
671: /lexicographic_order {
672: %% [x-list d-list params] (x,y,z) lexicograhic_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 2 sub >>
684: lexicographicOrderTemplate /order set
685:
686: [[1]] order oplus [[1]] oplus /order set
687:
688: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
689:
690: /compl
691: [univ 0 get] evars join evars univ0 complement join
692: def
693: compl univ
694: getPerm /perm set
695: %%perm :: univ :: compl ::
696:
697: order perm permuteOrderMatrix /order set
698:
699: vars [order] join /arg1 set
700: ] pop
701: popVariables
702: arg1
703: } def
704:
705: /lexicographic_order2 {
706: %% [x-list d-list params] (x,y,z) lexicograhic_order
707: %% vars evars
708: %% [x-list d-list params order]
709: %% with no graduation and homogenization variables
710: /arg2 set /arg1 set
711: [/vars /evars /univ /order /perm /compl] pushVariables
712: /vars arg1 def /evars [arg2 to_records pop] def
713: [
714: /univ vars 0 get reverse
715: vars 1 get reverse join
716: def
717:
718: << univ length >>
719: lexicographicOrderTemplate /order set
720:
721: /compl
722: evars << evars univ complement >> join
723: def
724: compl univ
725: getPerm /perm set
726:
727: order perm permuteOrderMatrix /order set
728:
729: vars [order] join /arg1 set
730: ] pop
731: popVariables
732: arg1
733: } def
734:
735: /lexicographic_order3 {
736: %% [x-list d-list params] (x,y,z) lexicograhic_order
737: %% vars evars
738: %% [x-list d-list params order]
739: %% with no homogenization variable.
740: /arg2 set /arg1 set
741: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
742: /vars arg1 def /evars [arg2 to_records pop] def
743: [
744: /univ vars 0 get reverse
745: vars 1 get reverse join
746: def
747:
748: << univ length 1 sub >>
749: lexicographicOrderTemplate /order set
750:
751: [[1]] order oplus /order set
752:
753: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
754:
755: /compl
756: [univ 0 get] evars join evars univ0 complement join
757: def
758: compl univ
759: getPerm /perm set
760: %%perm :: univ :: compl ::
761:
762: order perm permuteOrderMatrix /order set
763:
764: vars [order] join /arg1 set
765: ] pop
766: popVariables
767: arg1
768: } def
769:
770: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
771:
772:
773: /getX {
774: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
775: /arg2 set /arg1 set
776: [/k /param /func /low /top] pushVariables
777: [
778: /param arg1 def /func arg2 def
779: func 1 eq
780: {
781: /low 0 def
782: }
783: {
784: /low << param 2 get >> << func 1 sub >> get def
785: } ifelse
786: /top << param 2 get >> << func 4 add >> get 1 sub def
787: [
788: low 1 top
789: {
790: /k set
791: param 0 get k get
792: } for
793: ] /arg1 set
794: ] pop
795: popVariables
796: arg1
797: } def
798:
799: /getD {
800: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
801: /arg2 set /arg1 set
802: [/k /param /func /low /top] pushVariables
803: [
804: /param arg1 def /func arg2 def
805: func 1 eq
806: {
807: /low 0 def
808: }
809: {
810: /low << param 2 get >> << func 1 sub >> get def
811: } ifelse
812: /top << param 2 get >> << func 4 add >> get 1 sub def
813: [
814: low 1 top
815: {
816: /k set
817: param 1 get k get
818: } for
819: ] /arg1 set
820: ] pop
821: popVariables
822: arg1
823: } def
824:
825: /getXV {
826: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
827: /arg2 set /arg1 set
828: [/k /param /func /low /top] pushVariables
829: [
830: /param arg1 def /func arg2 def
831: /low << param 2 get >> << func 4 add >> get def
832: /top << param 2 get >> func get 1 sub def
833: [
834: low 1 top
835: {
836: /k set
837: param 0 get k get
838: } for
839: ] /arg1 set
840: ] pop
841: popVariables
842: arg1
843: } def
844:
845: /getDV {
846: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
847: /arg2 set /arg1 set
848: [/k /param /func /low /top] pushVariables
849: [
850: /param arg1 def /func arg2 def
851: /low << param 2 get >> << func 4 add >> get def
852: /top << param 2 get >> func get 1 sub def
853: [
854: low 1 top
855: {
856: /k set
857: param 1 get k get
858: } for
859: ] /arg1 set
860: ] pop
861: popVariables
862: arg1
863: } def
864:
865: /reNaming {
866: %% It also changes oldx2 and oldd2, which are globals.
867: /arg1 set
868: [/i /j /new /count /ostr /k] pushVariables
869: [
870: /new arg1 def
871: /count 0 def
872: 0 1 << new length 1 sub >> {
873: /i set
874: << i 1 add >> 1 << new length 1 sub >> {
875: /j set
876: << new i get >> << new j get >> eq
877: {
878: new j get /ostr set
879: (The two rings have the same name :) messagen
880: new i get messagen (.) message
881: (The name ) messagen
882: new i get messagen ( is changed into ) messagen
883: new j << new i get << 48 count add $string$ data_conversion >>
884: 2 cat_n >> put
885: new j get messagen (.) message
886: /oldx2 ostr << new j get >> reNaming2
887: /oldd2 ostr << new j get >> reNaming2
888: /count count 1 add def
889: }
890: { }
891: ifelse
892: } for
893: } for
894: /arg1 new def
895: ] pop
896: popVariables
897: arg1
898: } def
899:
900: /reNaming2 {
901: %% array oldString newString reNaming2
902: %% /aa (x) (y) reNaming2
903: /arg3 set /arg2 set /arg1 set
904: [/array /oldString /newString /k] pushVariables
905: [
906: /array arg1 def /oldString arg2 def /newString arg3 def
907: 0 1 << array load length 1 sub >>
908: {
909: /k set
910: << array load k get >> oldString eq
911: {
912: array load k newString put
913: }
914: { } ifelse
915: } for
916: ] pop
917: popVariables
918: } def
919:
920: /add_rings {
921: /arg2 set /arg1 set
922: [/param1 /param2
923: /newx /newd /newv
924: /k /const /od1 /od2 /od
925: /oldx2 /oldd2 % these will be changed in reNaming.
926: /oldv
927: ] pushVariables
928: [
929: /param1 arg1 def /param2 arg2 def
930: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
931: /newx
932: [ ]
933: param2 1 getX join param1 1 getX join
934: param2 1 getXV join param1 1 getXV join
935:
936: param2 2 getX join param1 2 getX join
937: param2 2 getXV join param1 2 getXV join
938:
939: param2 3 getX join param1 3 getX join
940: param2 3 getXV join param1 3 getXV join
941:
942: param2 4 getX join param1 4 getX join
943: param2 4 getXV join param1 4 getXV join
944: def
945: /newd
946: [ ]
947: param2 1 getD join param1 1 getD join
948: param2 1 getDV join param1 1 getDV join
949:
950: param2 2 getD join param1 2 getD join
951: param2 2 getDV join param1 2 getDV join
952:
953: param2 3 getD join param1 3 getD join
954: param2 3 getDV join param1 3 getDV join
955:
956: param2 4 getD join param1 4 getD join
957: param2 4 getDV join param1 4 getDV join
958: def
959:
960: /newv newx newd join def
961: /oldx2 param2 0 get def /oldd2 param2 1 get def
962: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
963: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
964: /newv newv reNaming def
965:
966: /newx [
967: 0 1 << newv length 2 idiv 1 sub >>
968: {
969: /k set
970: newv k get
971: } for
972: ] def
973: /newd [
974: 0 1 << newv length 2 idiv 1 sub >>
975: {
976: /k set
977: newv << newv length 2 idiv k add >> get
978: } for
979: ] def
980: /const [
981: << param1 2 get 0 get >>
982: << param1 2 get 1 get param2 2 get 1 get add >>
983: << param1 2 get 2 get param2 2 get 2 get add >>
984: << param1 2 get 3 get param2 2 get 3 get add >>
985: << param1 2 get 4 get param2 2 get 4 get add >>
986: << param1 2 get 5 get param2 2 get 5 get add >>
987: << param1 2 get 6 get param2 2 get 6 get add >>
988: << param1 2 get 7 get param2 2 get 7 get add >>
989: << param1 2 get 8 get param2 2 get 8 get add >>
990: ] def
991:
992: /od1 param1 3 get def /od2 param2 3 get def
993: od1 od2 oplus /od set
994:
995: %%oldx2 :: oldd2 ::
996: << param1 0 get reverse >> << param1 1 get reverse >> join
997: << oldx2 reverse >> << oldd2 reverse >> join
998: join /oldv set
999:
1000:
1001: od << oldv << newx reverse newd reverse join >> getPerm >>
1002: permuteOrderMatrix /od set
1003:
1004: /arg1 [newx newd const od] def
1005: ] pop
1006: popVariables
1007: arg1
1008: } def
1009:
1010:
1011: /test5 {
1012: (t) ring_of_polynomials ( ) elimination_order /r1 set
1013: (x) ring_of_differential_operators (Dx) elimination_order /r2 set
1014: r2 r1 add_rings
1015: } def
1016:
1017: /test6 {
1018: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
1019: (x,y,z) ring_of_polynomials2 (x,y) elimination_order2 /r1 set
1020: (t) ring_of_differential_operators3 (Dt) elimination_order3 /r2 set
1021: [r2 r1 add_rings r0 add_rings 0] define_ring
1022: } def
1023:
1024: /test7 {
1025: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
1026: (a,b,c,cp) ring_of_polynomials2 ( ) elimination_order2 /r1 set
1027: (x,y) ring_of_differential_operators3 (Dx,Dy) elimination_order3 /r2 set
1028: [r2 r1 add_rings r0 add_rings 0] define_ring
1029: [(Dx (x Dx + c-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).
1030: (Dy (y Dy + cp-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).] /ff set
1031: ff {[[$h$. $1$.]] replace} map homogenize /ff set
1032: } def
1033: %%%% end of add_rings
1034:
1035: ;