![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to smacro.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 smacro.sm1.old1 CVS log | Up to [local] / OpenXM / src / kan96xx / Kan |
1.1 maekawa 1: /; %%% prompt of the sm1
2: {
3: [$PrintDollar$ 0] system_variable pop
4: $sm1>$ print
5: [$PrintDollar$ 1] system_variable pop
6: } def
7:
8: /?
9: {
10: show_systemdictionary
11: (------------ Use show_user_dictionary to see the user dictionary.---)
12: message
13: (------------ Use $keyWord$ usage to see the usages. ---------------)
14: message
15: } def
16:
17: /??
18: {
19: show_systemdictionary
20: (------------ system macros defined in the UserDictionary -----------)
21: message
22: show_user_dictionary %% it should use other command
23: (------------ Use $keyWord$ usage to see the usages. ---------------)
24: message
25: } def
26:
27: /::
28: {
29: print newline ;
30: } def
31:
32: /. {expand} def
33:
34: /, { } def
35:
36: /false 0 def
37:
38: /expand {
39: $poly$ data_conversion
40: } def
41:
42: /<< { } def
43: />> { } def
44:
45: % v1 v2 join
46: /join {
47: /arg2 set /arg1 set
48: [/v1 /v2] pushVariables
49: /v1 arg1 def /v2 arg2 def
50: [
51: [v1 aload pop v2 aload pop] /arg1 set
52: ] pop
53: popVariables
54: arg1
55: } def
56:
57: /n.map 0 def /i.map 0 def /ar.map 0 def /res.map 0 def %% declare variables
58: /map.old { %% recursive
59: /arg1.map set %% arg1.map = { }
60: /arg2.map set %% arg2.map = [ ]
61: %%%debug: /arg1.map load print arg2.map print
62: [n.map /com.map load i.map ar.map %% local variables. Don't push com!
63: %%It's better to use load for all variables.
64: /com.map /arg1.map load def
65: /ar.map arg2.map def %% set variables
66: /n.map ar.map length 1 sub def
67: [
68: 0 1 n.map {
69: /i.map set
70: << ar.map i.map get >> com.map
71: } for
72: ] /res.map set
73: /ar.map set /i.map set /com.map set /n.map set ] pop %% pop local variables
74: res.map %% push the result
75: } def
76:
77: /message {
78: [$PrintDollar$ 0] system_variable pop
79: print newline
80: [$PrintDollar$ 1] system_variable pop
81: } def
82:
83: /messagen {
84: [$PrintDollar$ 0] system_variable pop
85: print
86: [$PrintDollar$ 1] system_variable pop
87: } def
88:
89: /newline {
90: [$PrintDollar$ 0] system_variable pop
91: 10 $string$ data_conversion print
92: [$PrintDollar$ 1] system_variable pop
93: } def
94:
95: /pushVariables {
96: { dup [ 3 1 roll load ] } map
97: } def
98:
99: /popVariables {
100: % dup print
101: { aload pop def } map pop
102: } def
103:
104:
105:
106: /timer {
107: set_timer
108: exec
109: set_timer
110: } def
111:
112: /true 1 def
113:
114:
115:
116: %%% prompter
117: ;
118:
119:
120:
121:
122: %% dr.sm1 (Define Ring) 1994/9/25, 26
123:
124: (dr.sm1 Version 11/9,1994. ) message
125: %% n evenQ bool
126: /evenQ {
127: /arg1 set
128: arg1 2 idiv 2 mul arg1 sub 0 eq
129: { true }
130: { false } ifelse
131: } def
132:
133: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
134: /ring_of_polynomials {
135: /arg1 set
136: [/vars /n /i /xList /dList /param] pushVariables
137: %dup print (-----) message
138: [
139: (mmLarger) (matrix) switch_function
140: (mpMult) (poly) switch_function
141: (red@) (module1) switch_function
142: (groebner) (standard) switch_function
143:
144: [arg1 to_records pop] /vars set
145: vars length evenQ
146: { }
147: { vars [(PAD)] join /vars set }
148: ifelse
149: vars length 2 idiv /n set
150: [ << n 1 sub >> -1 0
151: { /i set
152: vars i get
153: } for
154: ] /xList set
155: [ << n 1 sub >> -1 0
156: { /i set
157: vars << i n add >> get
158: } for
159: ] /dList set
160:
161: [(H)] xList join [(e)] join /xList set
162: [(h)] dList join [(E)] join /dList set
163: [0 %% dummy characteristic
164: << xList length >> << xList length >> << xList length >>
165: << xList length >>
166: << xList length 1 sub >> << xList length >> << xList length >>
167: << xList length >>
168: ] /param set
169:
170: [xList dList param] /arg1 set
171: ] pop
172: popVariables
173: arg1
174: } def
175:
176: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
177: %% with no graduation and homogenization variables.
178: /ring_of_polynomials2 {
179: /arg1 set
180: [/vars /n /i /xList /dList /param] pushVariables
181: %dup print (-----) message
182: [
183: (mmLarger) (matrix) switch_function
184: (mpMult) (poly) switch_function
185: (red@) (module1) switch_function
186: (groebner) (standard) switch_function
187:
188: [arg1 to_records pop] /vars set
189: vars length evenQ
190: { }
191: { vars [(PAD)] join /vars set }
192: ifelse
193: vars length 2 idiv /n set
194: [ << n 1 sub >> -1 0
195: { /i set
196: vars i get
197: } for
198: ] /xList set
199: [ << n 1 sub >> -1 0
200: { /i set
201: vars << i n add >> get
202: } for
203: ] /dList set
204:
205: [0 %% dummy characteristic
206: << xList length >> << xList length >> << xList length >>
207: << xList length >>
208: << xList length >> << xList length >> << xList length >>
209: << xList length >>
210: ] /param set
211:
212: [xList dList param] /arg1 set
213: ] pop
214: popVariables
215: arg1
216: } def
217:
218: %% (x,y,z) polynomial_ring [x-list, d-list , paramList]
219: %% with no homogenization variables.
220: /ring_of_polynomials3 {
221: /arg1 set
222: [/vars /n /i /xList /dList /param] pushVariables
223: %dup print (-----) message
224: [
225: (mmLarger) (matrix) switch_function
226: (mpMult) (poly) switch_function
227: (red@) (module1) switch_function
228: (groebner) (standard) switch_function
229:
230: [arg1 to_records pop] /vars set
231: vars length evenQ
232: { }
233: { vars [(PAD)] join /vars set }
234: ifelse
235: vars length 2 idiv /n set
236: [ << n 1 sub >> -1 0
237: { /i set
238: vars i get
239: } for
240: ] /xList set
241: xList [(e)] join /xList set
242: [ << n 1 sub >> -1 0
243: { /i set
244: vars << i n add >> get
245: } for
246: ] /dList set
247: dList [(E)] join /dList set
248:
249: [0 %% dummy characteristic
250: << xList length >> << xList length >> << xList length >>
251: << xList length >>
252: << xList length >> << xList length >> << xList length >>
253: << xList length >>
254: ] /param set
255:
256: [xList dList param] /arg1 set
257: ] pop
258: popVariables
259: arg1
260: } def
261:
262: /ring_of_differential_operators {
263: /arg1 set
264: [/vars /n /i /xList /dList /param] pushVariables
265: [
266: (mmLarger) (matrix) switch_function
267: (mpMult) (diff) switch_function
268: (red@) (module1) switch_function
269: (groebner) (standard) switch_function
270:
271: [arg1 to_records pop] /vars set %[x y z]
272: vars reverse /xList set %[z y x]
273: vars {(D) 2 1 roll 2 cat_n} map
274: reverse /dList set %[Dz Dy Dx]
275: [(H)] xList join [(e)] join /xList set
276: [(h)] dList join [(E)] join /dList set
277: [0 1 1 1 << xList length >>
278: 1 1 1 << xList length 1 sub >> ] /param set
279: [ xList dList param ] /arg1 set
280: ] pop
281: popVariables
282: arg1
283: } def
284:
285: /ring_of_differential_operators3 {
286: %% with no homogenization variables.
287: /arg1 set
288: [/vars /n /i /xList /dList /param] pushVariables
289: [
290: (mmLarger) (matrix) switch_function
291: (mpMult) (diff) switch_function
292: (red@) (module1) switch_function
293: (groebner) (standard) switch_function
294:
295: [arg1 to_records pop] /vars set %[x y z]
296: vars reverse /xList set %[z y x]
297: vars {(D) 2 1 roll 2 cat_n} map
298: reverse /dList set %[Dz Dy Dx]
299: xList [(e)] join /xList set
300: dList [(E)] join /dList set
301: [0 0 0 0 << xList length >>
302: 0 0 0 << xList length 1 sub >> ] /param set
303: [ xList dList param ] /arg1 set
304: ] pop
305: popVariables
306: arg1
307: } def
308:
309: /ring_of_q_difference_operators {
310: /arg1 set
311: [/vars /n /i /xList /dList /param] pushVariables
312: [
313: (mmLarger) (qmatrix) switch_function
314: (mpMult) (diff) switch_function
315: (red@) (qmodule1) switch_function
316: (groebner) (standard) switch_function
317:
318: [arg1 to_records pop] /vars set %[x y z]
319: vars reverse /xList set %[z y x]
320: vars {(Q) 2 1 roll 2 cat_n} map
321: reverse /dList set %[Dz Dy Dx]
322: [(q)] xList join [(e)] join /xList set
323: [(h)] dList join [(E)] join /dList set
324: [0 1 << xList length >> << xList length >> << xList length >>
325: 1 << xList length 1 sub >> << xList length >> << xList length >> ]
326: /param set
327: [ xList dList param ] /arg1 set
328: ] pop
329: popVariables
330: arg1
331: } def
332:
333: /ring_of_q_difference_operators3 {
334: %% with no homogenization and q variables.
335: /arg1 set
336: [/vars /n /i /xList /dList /param] pushVariables
337: [
338: (mmLarger) (qmatrix) switch_function
339: (mpMult) (diff) switch_function
340: (red@) (qmodule1) switch_function
341: (groebner) (standard) switch_function
342:
343: [arg1 to_records pop] /vars set %[x y z]
344: vars reverse /xList set %[z y x]
345: vars {(Q) 2 1 roll 2 cat_n} map
346: reverse /dList set %[Dz Dy Dx]
347: xList [(e)] join /xList set
348: dList [(E)] join /dList set
349: [0 0 << xList length >> << xList length >> << xList length >>
350: 0 << xList length 1 sub >> << xList length >> << xList length >> ]
351: /param set
352: [ xList dList param ] /arg1 set
353: ] pop
354: popVariables
355: arg1
356: } def
357:
358: /reverse {
359: /arg1 set
360: arg1 length 1 lt
361: { [ ] }
362: {
363: [
364: << arg1 length 1 sub >> -1 0
365: {
366: arg1 2 1 roll get
367: } for
368: ]
369: } ifelse
370: } def
371:
372: /memberQ {
373: %% a set0 memberQ bool
374: /arg2 set /arg1 set
375: [/a /set0 /flag /i ] pushVariables
376: [
377: /a arg1 def /set0 arg2 def
378: /flag 0 def
379: 0 1 << set0 length 1 sub >>
380: {
381: /i set
382: << set0 i get >> a eq
383: {
384: /flag 1 def
385: }
386: { }
387: ifelse
388: } for
389: ] pop
390: /arg1 flag def
391: popVariables
392: arg1
393: } def
394:
395: /transpose {
396: %% mat transpose mat2
397: /arg1 set
398: [/i /j /m /n /flat /mat] pushVariables
399: [
400: /mat arg1 def
401: /n mat length def
402: /m mat 0 get length def
403:
404: [
405: 0 1 << n 1 sub >>
406: {
407: /i set
408: mat i get aload pop
409: } for
410: ] /flat set
411: %% [[1 2] [3 4]] ---> flat == [1 2 3 4]
412:
413: [
414: 0 1 << m 1 sub >>
415: {
416: /i set
417: [
418: 0 1 << n 1 sub >>
419: {
420: /j set
421: flat
422: << j m mul >> i add
423: get
424: } for
425: ]
426: } for
427: ] /arg1 set
428: ] pop
429: popVariables
430: arg1
431: } def
432:
433:
434: /getPerm {
435: %% old new getPerm perm
436: /arg2 set /arg1 set
437: [/old /new /i /j /p] pushVariables
438: [
439: /old arg1 def
440: /new arg2 def
441: [
442: /p old length def
443: 0 1 << p 1 sub >>
444: {
445: /i set
446: 0 1 << p 1 sub >>
447: {
448: /j set
449: old i get
450: new j get
451: eq
452: { j }
453: { } ifelse
454: } for
455: } for
456: ] /arg1 set
457: ] pop
458: popVariables
459: arg1
460: } def
461:
462: /permuteOrderMatrix {
463: %% order perm puermuteOrderMatrix newOrder
464: /arg2 set /arg1 set
465: [/order /perm /newOrder /k ] pushVariables
466: [
467: /order arg1 def
468: /perm arg2 def
469: order transpose /order set
470: order 1 copy /newOrder set pop
471:
472: 0 1 << perm length 1 sub >>
473: {
474: /k set
475: newOrder << perm k get >> << order k get >> put
476: } for
477: newOrder transpose /newOrder set
478: ] pop
479: /arg1 newOrder def
480: popVariables
481: arg1
482: } def
483:
484:
485:
486: /complement {
487: %% set0 universe complement compl
488: /arg2 set /arg1 set
489: [/set0 /universe /compl /i] pushVariables
490: /set0 arg1 def /universe arg2 def
491: [
492: 0 1 << universe length 1 sub >>
493: {
494: /i set
495: << universe i get >> set0 memberQ
496: { }
497: { universe i get }
498: ifelse
499: } for
500: ] /arg1 set
501: popVariables
502: arg1
503: } def
504:
505:
506: %%% from order.sm1
507:
508: %% size i evec [0 0 ... 0 1 0 ... 0]
509: /evec {
510: /arg2 set /arg1 set
511: [/size /iii] pushVariables
512: /size arg1 def /iii arg2 def
513: [
514: 0 1 << size 1 sub >>
515: {
516: iii eq
517: { 1 }
518: { 0 }
519: ifelse
520: } for
521: ] /arg1 set
522: popVariables
523: arg1
524: } def
525:
526: %% size i evec_neg [0 0 ... 0 -1 0 ... 0]
527: /evec_neg {
528: /arg2 set /arg1 set
529: [/size /iii] pushVariables
530: /size arg1 def /iii arg2 def
531: [
532: 0 1 << size 1 sub >>
533: {
534: iii eq
535: { -1 }
536: { 0 }
537: ifelse
538: } for
539: ] /arg1 set
540: popVariables
541: arg1
542: } def
543:
544:
545: %% size i j e_ij << matrix e(i,j) >>
546: /e_ij {
547: /arg3 set /arg2 set /arg1 set
548: [/size /k /i /j] pushVariables
549: [
550: /size arg1 def /i arg2 def /j arg3 def
551: [ 0 1 << size 1 sub >>
552: {
553: /k set
554: k i eq
555: { size j evec }
556: {
557: k j eq
558: { size i evec }
559: { size k evec }
560: ifelse
561: } ifelse
562: } for
563: ] /arg1 set
564: ] pop
565: popVariables
566: arg1
567: } def
568:
569:
570: %% size i j d_ij << matrix E_{ij} >>
571: /d_ij {
572: /arg3 set /arg2 set /arg1 set
573: [/size /k /i /j] pushVariables
574: [
575: /size arg1 def /i arg2 def /j arg3 def
576: [ 0 1 << size 1 sub >>
577: {
578: /k set
579: k i eq
580: { size j evec }
581: {
582: [ 0 1 << size 1 sub >> { pop 0} for ]
583: } ifelse
584: } for
585: ] /arg1 set
586: ] pop
587: popVariables
588: arg1
589: } def
590:
591: %% size matid << id matrix >>
592: /matid {
593: /arg1 set
594: [/size /k ] pushVariables
595: [
596: /size arg1 def
597: [ 0 1 << size 1 sub >>
598: {
599: /k set
600: size k evec
601: } for
602: ] /arg1 set
603: ] pop
604: popVariables
605: arg1
606: } def
607:
608:
609: %% m1 m2 oplus
610: /oplus {
611: /arg2 set /arg1 set
612: [/m1 /m2 /n /m /k ] pushVariables
613: [
614: /m1 arg1 def /m2 arg2 def
615: m1 length /n set
616: m2 length /m set
617: [
618: 0 1 << n m add 1 sub >>
619: {
620: /k set
621: k n lt
622: {
623: << m1 k get >> << m -1 evec >> join
624: }
625: {
626: << n -1 evec >> << m2 << k n sub >> get >> join
627: } ifelse
628: } for
629: ] /arg1 set
630: ] pop
631: popVariables
632: arg1
633: } def
634:
635: %%%%%%%%%%%%%%%%%%%%%%%
636:
637: /eliminationOrderTemplate { %% esize >= 1
638: %% if esize == 0, it returns reverse lexicographic order.
639: %% m esize eliminationOrderTemplate mat
640: /arg2 set /arg1 set
641: [/m /esize /m1 /m2 /k ] pushVariables
642: [
643: /m arg1 def /esize arg2 def
644: /m1 m esize sub 1 sub def
645: /m2 esize 1 sub def
646: [esize 0 gt
647: {
648: [1 1 esize
649: { pop 1 } for
650: esize 1 << m 1 sub >>
651: { pop 0 } for
652: ] %% 1st vector
653: }
654: { } ifelse
655:
656: m esize gt
657: {
658: [1 1 esize
659: { pop 0 } for
660: esize 1 << m 1 sub >>
661: { pop 1 } for
662: ] %% 2nd vector
663: }
664: { } ifelse
665:
666: m1 0 gt
667: {
668: m 1 sub -1 << m m1 sub >>
669: {
670: /k set
671: m k evec_neg
672: } for
673: }
674: { } ifelse
675:
676: m2 0 gt
677: {
678: << esize 1 sub >> -1 1
679: {
680: /k set
681: m k evec_neg
682: } for
683: }
684: { } ifelse
685:
686: ] /arg1 set
687: ] pop
688: popVariables
689: arg1
690: } def
691:
692: /elimination_order {
693: %% [x-list d-list params] (x,y,z) elimination_order
694: %% vars evars
695: %% [x-list d-list params order]
696: /arg2 set /arg1 set
697: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
698: /vars arg1 def /evars [arg2 to_records pop] def
699: [
700: /univ vars 0 get reverse
701: vars 1 get reverse join
702: def
703:
704: << univ length 2 sub >>
705: << evars length >>
706: eliminationOrderTemplate /order set
707:
708: [[1]] order oplus [[1]] oplus /order set
709:
710: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
711:
712: /compl
713: [univ 0 get] evars join evars univ0 complement join
714: def
715: compl univ
716: getPerm /perm set
717: %%perm :: univ :: compl ::
718:
719: order perm permuteOrderMatrix /order set
720:
721:
722: vars [order] join /arg1 set
723: ] pop
724: popVariables
725: arg1
726: } def
727:
728: /elimination_order2 {
729: %% [x-list d-list params] (x,y,z) elimination_order
730: %% vars evars
731: %% [x-list d-list params order]
732: %% with no graduation and homogenization variables.
733: /arg2 set /arg1 set
734: [/vars /evars /univ /order /perm /compl] pushVariables
735: /vars arg1 def /evars [arg2 to_records pop] def
736: [
737: /univ vars 0 get reverse
738: vars 1 get reverse join
739: def
740:
741: << univ length >>
742: << evars length >>
743: eliminationOrderTemplate /order set
744: /compl
745: evars << evars univ complement >> join
746: def
747: compl univ
748: getPerm /perm set
749: %%perm :: univ :: compl ::
750:
751: order perm permuteOrderMatrix /order set
752:
753: vars [order] join /arg1 set
754: ] pop
755: popVariables
756: arg1
757: } def
758:
759:
760: /elimination_order3 {
761: %% [x-list d-list params] (x,y,z) elimination_order
762: %% vars evars
763: %% [x-list d-list params order]
764: /arg2 set /arg1 set
765: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
766: /vars arg1 def /evars [arg2 to_records pop] def
767: [
768: /univ vars 0 get reverse
769: vars 1 get reverse join
770: def
771:
772: << univ length 1 sub >>
773: << evars length >>
774: eliminationOrderTemplate /order set
775:
776: [[1]] order oplus /order set
777:
778: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
779:
780: /compl
781: [univ 0 get] evars join evars univ0 complement join
782: def
783: compl univ
784: getPerm /perm set
785: %%perm :: univ :: compl ::
786:
787: order perm permuteOrderMatrix /order set
788:
789: vars [order] join /arg1 set
790: ] pop
791: popVariables
792: arg1
793: } def
794:
795:
796: /define_ring {
797: %[ (x,y,z) ring_of_polynominals
798: % (x,y) elimination_order
799: % 17
800: %] define_ring
801: /arg1 set
802: [/rp /param /foo] pushVariables
803: [/rp arg1 def
804: [
805: rp 0 get 0 get
806: rp 0 get 1 get
807: rp 0 get 2 get /param set
808: param 0 << rp 1 get >> put
809: param
810: rp 0 get 3 get
811: ] /foo set
812: foo aload pop set_up_ring@
813: ] pop
814: popVariables
815: } def
816:
817: /defineTests1 {
818: /test {
819: [[1 2 3]
820: [0 1 0]
821: [0 1 2]]
822: [0 2 1] permuteOrderMatrix ::
823: } def
824:
825: /test2 { (x,y,z) ring_of_polynomials (z,y) elimination_order /ans set } def
826:
827: /test3 {
828: [ (x,y,z) ring_of_polynomials
829: (x,y) elimination_order
830: 17
831: ] define_ring
832: } def
833:
834: /test4 {
835: [ (x,y,z) ring_of_polynomials
836: ( ) elimination_order
837: 17
838: ] define_ring
839: } def
840:
841: } def
842:
843: %% misterious bug (x,y) miss
844: /miss {
845: /arg1 set
846: %[/vars /n /i /xList /dList /param] pushVariables
847: [/vars /i] pushVariables
848: [ arg1 print
849: [arg1 to_records pop] /vars set
850:
851: ] pop
852: dup print
853: popVariables
854: arg1
855: } def
856:
857:
858: /lexicographicOrderTemplate {
859: % size lexicographicOrderTemplate matrix
860: /arg1 set
861: [/k /size] pushVariables
862: [
863: /size arg1 def
864: [ 0 1 << size 1 sub >>
865: {
866: /k set
867: size k evec
868: } for
869: ] /arg1 set
870: ] pop
871: popVariables
872: arg1
873: } def
874:
875: /lexicographic_order {
876: %% [x-list d-list params] (x,y,z) lexicograhic_order
877: %% vars evars
878: %% [x-list d-list params order]
879: /arg2 set /arg1 set
880: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
881: /vars arg1 def /evars [arg2 to_records pop] def
882: [
883: /univ vars 0 get reverse
884: vars 1 get reverse join
885: def
886:
887: << univ length 2 sub >>
888: lexicographicOrderTemplate /order set
889:
890: [[1]] order oplus [[1]] oplus /order set
891:
892: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
893:
894: /compl
895: [univ 0 get] evars join evars univ0 complement join
896: def
897: compl univ
898: getPerm /perm set
899: %%perm :: univ :: compl ::
900:
901: order perm permuteOrderMatrix /order set
902:
903: vars [order] join /arg1 set
904: ] pop
905: popVariables
906: arg1
907: } def
908:
909: /lexicographic_order2 {
910: %% [x-list d-list params] (x,y,z) lexicograhic_order
911: %% vars evars
912: %% [x-list d-list params order]
913: %% with no graduation and homogenization variables
914: /arg2 set /arg1 set
915: [/vars /evars /univ /order /perm /compl] pushVariables
916: /vars arg1 def /evars [arg2 to_records pop] def
917: [
918: /univ vars 0 get reverse
919: vars 1 get reverse join
920: def
921:
922: << univ length >>
923: lexicographicOrderTemplate /order set
924:
925: /compl
926: evars << evars univ complement >> join
927: def
928: compl univ
929: getPerm /perm set
930:
931: order perm permuteOrderMatrix /order set
932:
933: vars [order] join /arg1 set
934: ] pop
935: popVariables
936: arg1
937: } def
938:
939: /lexicographic_order3 {
940: %% [x-list d-list params] (x,y,z) lexicograhic_order
941: %% vars evars
942: %% [x-list d-list params order]
943: %% with no homogenization variable.
944: /arg2 set /arg1 set
945: [/vars /evars /univ /order /perm /univ0 /compl] pushVariables
946: /vars arg1 def /evars [arg2 to_records pop] def
947: [
948: /univ vars 0 get reverse
949: vars 1 get reverse join
950: def
951:
952: << univ length 1 sub >>
953: lexicographicOrderTemplate /order set
954:
955: [[1]] order oplus /order set
956:
957: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y] --> [x,y]
958:
959: /compl
960: [univ 0 get] evars join evars univ0 complement join
961: def
962: compl univ
963: getPerm /perm set
964: %%perm :: univ :: compl ::
965:
966: order perm permuteOrderMatrix /order set
967:
968: vars [order] join /arg1 set
969: ] pop
970: popVariables
971: arg1
972: } def
973:
974: %%%%%% add_rings %%%%%%%%%%%%%% 10/5
975:
976: /graded_reverse_lexicographic_order {
977: ( ) elimination_order
978: } def
979:
980:
981: /getX {
982: %% param [1|2|3|4] getX [var-lists] ; 1->c,2->l,3->m,4->n
983: /arg2 set /arg1 set
984: [/k /param /func /low /top] pushVariables
985: [
986: /param arg1 def /func arg2 def
987: func 1 eq
988: {
989: /low 0 def
990: }
991: {
992: /low << param 2 get >> << func 1 sub >> get def
993: } ifelse
994: /top << param 2 get >> << func 4 add >> get 1 sub def
995: [
996: low 1 top
997: {
998: /k set
999: param 0 get k get
1000: } for
1001: ] /arg1 set
1002: ] pop
1003: popVariables
1004: arg1
1005: } def
1006:
1007: /getD {
1008: %% param [1|2|3|4] getD [var-lists] ; 1->c,2->l,3->m,4->n
1009: /arg2 set /arg1 set
1010: [/k /param /func /low /top] pushVariables
1011: [
1012: /param arg1 def /func arg2 def
1013: func 1 eq
1014: {
1015: /low 0 def
1016: }
1017: {
1018: /low << param 2 get >> << func 1 sub >> get def
1019: } ifelse
1020: /top << param 2 get >> << func 4 add >> get 1 sub def
1021: [
1022: low 1 top
1023: {
1024: /k set
1025: param 1 get k get
1026: } for
1027: ] /arg1 set
1028: ] pop
1029: popVariables
1030: arg1
1031: } def
1032:
1033: /getXV {
1034: %% param [1|2|3|4] getXV [var-lists] ; 1->c,2->l,3->m,4->n
1035: /arg2 set /arg1 set
1036: [/k /param /func /low /top] pushVariables
1037: [
1038: /param arg1 def /func arg2 def
1039: /low << param 2 get >> << func 4 add >> get def
1040: /top << param 2 get >> func get 1 sub def
1041: [
1042: low 1 top
1043: {
1044: /k set
1045: param 0 get k get
1046: } for
1047: ] /arg1 set
1048: ] pop
1049: popVariables
1050: arg1
1051: } def
1052:
1053: /getDV {
1054: %% param [1|2|3|4] getDV [var-lists] ; 1->c,2->l,3->m,4->n
1055: /arg2 set /arg1 set
1056: [/k /param /func /low /top] pushVariables
1057: [
1058: /param arg1 def /func arg2 def
1059: /low << param 2 get >> << func 4 add >> get def
1060: /top << param 2 get >> func get 1 sub def
1061: [
1062: low 1 top
1063: {
1064: /k set
1065: param 1 get k get
1066: } for
1067: ] /arg1 set
1068: ] pop
1069: popVariables
1070: arg1
1071: } def
1072:
1073: /reNaming {
1074: %% It also changes oldx2 and oldd2, which are globals.
1075: /arg1 set
1076: [/i /j /new /count /ostr /k] pushVariables
1077: [
1078: /new arg1 def
1079: /count 0 def
1080: 0 1 << new length 1 sub >> {
1081: /i set
1082: << i 1 add >> 1 << new length 1 sub >> {
1083: /j set
1084: << new i get >> << new j get >> eq
1085: {
1086: new j get /ostr set
1087: (The two rings have the same name :) messagen
1088: new i get messagen (.) message
1089: (The name ) messagen
1090: new i get messagen ( is changed into ) messagen
1091: new j << new i get << 48 count add $string$ data_conversion >>
1092: 2 cat_n >> put
1093: new j get messagen (.) message
1094: /oldx2 ostr << new j get >> reNaming2
1095: /oldd2 ostr << new j get >> reNaming2
1096: /count count 1 add def
1097: }
1098: { }
1099: ifelse
1100: } for
1101: } for
1102: /arg1 new def
1103: ] pop
1104: popVariables
1105: arg1
1106: } def
1107:
1108: /reNaming2 {
1109: %% array oldString newString reNaming2
1110: %% /aa (x) (y) reNaming2
1111: /arg3 set /arg2 set /arg1 set
1112: [/array /oldString /newString /k] pushVariables
1113: [
1114: /array arg1 def /oldString arg2 def /newString arg3 def
1115: 0 1 << array load length 1 sub >>
1116: {
1117: /k set
1118: << array load k get >> oldString eq
1119: {
1120: array load k newString put
1121: }
1122: { } ifelse
1123: } for
1124: ] pop
1125: popVariables
1126: } def
1127:
1128: /add_rings {
1129: /arg2 set /arg1 set
1130: [/param1 /param2
1131: /newx /newd /newv
1132: /k /const /od1 /od2 /od
1133: /oldx2 /oldd2 % these will be changed in reNaming.
1134: /oldv
1135: ] pushVariables
1136: [
1137: /param1 arg1 def /param2 arg2 def
1138: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1139: /newx
1140: [ ]
1141: param2 1 getX join param1 1 getX join
1142: param2 1 getXV join param1 1 getXV join
1143:
1144: param2 2 getX join param1 2 getX join
1145: param2 2 getXV join param1 2 getXV join
1146:
1147: param2 3 getX join param1 3 getX join
1148: param2 3 getXV join param1 3 getXV join
1149:
1150: param2 4 getX join param1 4 getX join
1151: param2 4 getXV join param1 4 getXV join
1152: def
1153: /newd
1154: [ ]
1155: param2 1 getD join param1 1 getD join
1156: param2 1 getDV join param1 1 getDV join
1157:
1158: param2 2 getD join param1 2 getD join
1159: param2 2 getDV join param1 2 getDV join
1160:
1161: param2 3 getD join param1 3 getD join
1162: param2 3 getDV join param1 3 getDV join
1163:
1164: param2 4 getD join param1 4 getD join
1165: param2 4 getDV join param1 4 getDV join
1166: def
1167:
1168: /newv newx newd join def
1169: /oldx2 param2 0 get def /oldd2 param2 1 get def
1170: /oldx2 oldx2 {1 copy 2 1 roll pop} map def
1171: /oldd2 oldd2 {1 copy 2 1 roll pop} map def
1172: /newv newv reNaming def
1173:
1174: /newx [
1175: 0 1 << newv length 2 idiv 1 sub >>
1176: {
1177: /k set
1178: newv k get
1179: } for
1180: ] def
1181: /newd [
1182: 0 1 << newv length 2 idiv 1 sub >>
1183: {
1184: /k set
1185: newv << newv length 2 idiv k add >> get
1186: } for
1187: ] def
1188: /const [
1189: << param1 2 get 0 get >>
1190: << param1 2 get 1 get param2 2 get 1 get add >>
1191: << param1 2 get 2 get param2 2 get 2 get add >>
1192: << param1 2 get 3 get param2 2 get 3 get add >>
1193: << param1 2 get 4 get param2 2 get 4 get add >>
1194: << param1 2 get 5 get param2 2 get 5 get add >>
1195: << param1 2 get 6 get param2 2 get 6 get add >>
1196: << param1 2 get 7 get param2 2 get 7 get add >>
1197: << param1 2 get 8 get param2 2 get 8 get add >>
1198: ] def
1199:
1200: /od1 param1 3 get def /od2 param2 3 get def
1201: od1 od2 oplus /od set
1202:
1203: %%oldx2 :: oldd2 ::
1204: << param1 0 get reverse >> << param1 1 get reverse >> join
1205: << oldx2 reverse >> << oldd2 reverse >> join
1206: join /oldv set
1207:
1208:
1209: od << oldv << newx reverse newd reverse join >> getPerm >>
1210: permuteOrderMatrix /od set
1211:
1212: /arg1 [newx newd const od] def
1213: ] pop
1214: popVariables
1215: arg1
1216: } def
1217:
1218:
1219: /test5 {
1220: (t) ring_of_polynomials ( ) elimination_order /r1 set
1221: (x) ring_of_differential_operators (Dx) elimination_order /r2 set
1222: r2 r1 add_rings
1223: } def
1224:
1225: /test6 {
1226: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
1227: (x,y,z) ring_of_polynomials2 (x,y) elimination_order2 /r1 set
1228: (t) ring_of_differential_operators3 (Dt) elimination_order3 /r2 set
1229: [r2 r1 add_rings r0 add_rings 0] define_ring
1230: } def
1231:
1232: /test7 {
1233: (H,h) ring_of_polynomials2 (H,h) lexicographic_order2 /r0 set
1234: (a,b,c,cp) ring_of_polynomials2 ( ) elimination_order2 /r1 set
1235: (x,y) ring_of_differential_operators3 (Dx,Dy) elimination_order3 /r2 set
1236: [r2 r1 add_rings r0 add_rings 0] define_ring
1237: [(Dx (x Dx + c-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).
1238: (Dy (y Dy + cp-1) - (x Dx + y Dy + a) (x Dx + y Dy + b)).] /ff set
1239: ff {[[$h$. $1$.]] replace} map homogenize /ff set
1240: } def
1241: %%%% end of add_rings
1242:
1243: %%%%%%%% usages %%%%%%%%%%%%%%%%
1244: /@.usages [ ] def
1245: /putUsages {
1246: /arg1 set
1247: /@.usages @.usages [ arg1 ] join def
1248: } def
1249:
1250: /showKeywords {
1251: @.usages { 0 get } map print ( ) message
1252: } def
1253:
1254: /Usage {
1255: /arg1 set
1256: [/name /flag /n /k /slist /m /i] pushVariables
1257: [
1258: /name arg1 def
1259: /flag true def
1260: @.usages length /n set
1261: 0 1 << n 1 sub >>
1262: {
1263: /k set
1264: name << @.usages k get 0 get >> eq
1265: {
1266: /slist @.usages k get 1 get def
1267: /m slist length def
1268: 0 1 << m 1 sub >> {
1269: /i set
1270: slist i get message
1271: } for
1272: /flag false def
1273: }
1274: { }
1275: ifelse
1276: } for
1277:
1278: flag
1279: {name usage}
1280: { }
1281: ifelse
1282: ] pop
1283: popVariables
1284: } def
1285:
1286:
1287: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1288:
1289:
1290: [(swap01) [
1291: $[ .... ] swap01 [....]$
1292: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] swap01 $
1293: $ define_ring$
1294: ]] putUsages
1295: %
1296: /swap01 {
1297: /arg1 set
1298: [/rg /ch ] pushVariables
1299: [
1300: arg1 0 get /rg set % ring
1301: arg1 1 get /ch set % characteristics
1302: [rg 0 get , rg 1 get , rg 2 get ,
1303: << rg 3 get length >> 0 1 e_ij << rg 3 get >> mul ] /rg set
1304: /arg1 [ rg ch ] def
1305: ] pop
1306: popVariables
1307: arg1
1308: } def
1309:
1310: [(swap0k) [
1311: $[ .... ] k swap0k [....]$
1312: $Examples: [(x,y) ring_of_polynomials (x) elmination_order 0] 1 swap0k $
1313: $ define_ring$
1314: $swap01 == 1 swap0k$
1315: ]] putUsages
1316: %
1317: /swap0k {
1318: /arg2 set
1319: /arg1 set
1320: [/rg /ch /kk] pushVariables
1321: [
1322: arg2 /kk set
1323: arg1 0 get /rg set % ring
1324: arg1 1 get /ch set % characteristics
1325: [rg 0 get , rg 1 get , rg 2 get ,
1326: << rg 3 get length >> 0 kk e_ij << rg 3 get >> mul ] /rg set
1327: /arg1 [ rg ch ] def
1328: ] pop
1329: popVariables
1330: arg1
1331: } def
1332:
1333:
1334: ;
1335: /toVectors {
1336: { $array$ data_conversion } map
1337: } def
1338:
1339: /resolution {
1340: /arg1 set
1341: [/resol /gen /syz /maxLength] pushVariables
1342: [
1343: /gen arg1 0 get def
1344: arg1 length 1 eq
1345: { /maxLength -1 def }
1346: { /maxLength arg1 1 get def }
1347: ifelse
1348: /resol [ ] def
1349: {
1350: resol [gen] join /resol set
1351: (Betti Number = ) messagen
1352: gen length print
1353: ( ) message
1354:
1355: /maxLength maxLength 1 sub def
1356: maxLength 0 eq
1357: {(<<Stop the resolution because of the given max depth.>>) message exit}
1358: { }
1359: ifelse
1360:
1361: [gen [$needBack$ $needSyz$]] groebner 2 get /syz set
1362:
1363: syz length 0 eq
1364: {exit}
1365: { }
1366: ifelse
1367:
1368: /gen syz def
1369: %% homogenization %%%%%%%%%%%%%%%%%%
1370: (Note: The next line is removed for a test. 11/9.) message
1371: %gen { {[[$h$. $1$.]] replace} map } map /gen set
1372: gen {homogenize} map /gen set
1373: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1374: } loop
1375: /arg1 resol def
1376: ] pop
1377: popVariables
1378: arg1
1379: } def
1380:
1381: /TESTS {
1382: /test1 {
1383: $red@$ $module1$ switch_function
1384: [ [ (x^2) . (x^2-x h) . ] [ (x) . (x-h) . ] ] /ff set ;
1385: (ff is the input data.) message
1386: } def
1387:
1388: /test2 {
1389: $red@$ $module1$ switch_function
1390: [ [ (1) . (0) . ] [ (0) . (1) . ] ] /ff set ;
1391: (ff is the input data.) message
1392: } def
1393:
1394: /test3 {
1395: $red@$ $module1$ switch_function
1396: [ (x,y) ring_of_polynomials
1397: ( ) elimination_order
1398: 0
1399: ] define_ring
1400: [ [ (h) . (x) . (y ) .]
1401: [ (y) . (0) . (h) .]
1402: [ (x^2) . (x h) . (0) .]] /ff set
1403: (ff is the input data.) message
1404:
1405: } def
1406:
1407: /test4 {
1408: $red@$ $module1$ switch_function
1409: [ ${x,y}$ ring_of_polynomials
1410: ( ) elimination_order
1411: 0
1412: ] define_ring
1413: [ [ (x^2 + y^2 - h^2) . ]
1414: [ (x y - h^2) . ] ] /ff set
1415: (ff is the input data.) message
1416:
1417: } def
1418: %% characteristic variety
1419: /test4 {
1420: %% Test 1.
1421: [(x,y) ring_of_differential_operators (Dx,Dy) elimination_order 0]
1422: swap01 define_ring
1423:
1424: [((x Dx^2+Dy^2-1)+e*(Dx)). (0+e*(Dx^2)). (Dx+Dy+1). ] /ff set
1425:
1426: ff print ( ------------------ ) message
1427: ff characteristic print ( ) message ( ) message
1428:
1429: %% Test 2.
1430: [(a,b,c,d,x) ring_of_differential_operators (Dx) elimination_order 0]
1431: swap01 define_ring
1432:
1433: [[(x*Dx-a). (-b).] [(-c). ((x-1)*Dx-d).]] /ff set
1434: /ff ff homogenize def
1435: [ff] groebner /ans set
1436: ans 0 get toVectors print ( ) message
1437: ans 0 get characteristic print ( ) message ( ) message
1438:
1439: %% Test 3.
1440: [(a,b,c,d,x) ring_of_differential_operators (Dx) elimination_order 0]
1441: define_ring
1442:
1443: [[(x*Dx-a). (-b).] [(-c). ((x-1)*Dx-d).]] /ff set
1444: /ff ff homogenize def
1445: [ff] groebner /ans set
1446: ans 0 get toVectors print ( ) message ( ) message
1447:
1448: } def
1449:
1450:
1451: %%%%%%%%%%%%%%%%%%%%%%%%%%
1452:
1453: (type in test1,2,3.) message
1454: (Use toVectors to get vector representations.) message
1455:
1456: } def
1457:
1458:
1459:
1460: /lpoint { init (e). degree } def
1461: /characteristic {
1462: /arg1 set
1463: [/gb /lps /i /n /ans /maxp /ansp /k] pushVariables
1464: [ /gb arg1 def
1465: /ans [ ] def
1466: /maxp 0 def
1467: /lps gb {lpoint} map def
1468: 0 1 << lps length 1 sub >>
1469: {
1470: /i set
1471: lps i get maxp gt
1472: { /maxp lps i get def }
1473: { }
1474: ifelse
1475: } for
1476:
1477: %%lps print
1478: /ans [
1479: 0 1 maxp { pop [ ] } for
1480: ] def
1481:
1482: gb toVectors /gb set
1483:
1484: 0 1 << lps length 1 sub >>
1485: {
1486: /i set /k lps i get def
1487: /ansp ans k get def
1488: << gb i get >> k get principal /f set
1489: /ansp ansp [f] join def
1490: ans k ansp put
1491: } for
1492:
1493: /arg1 ans def
1494: ] pop
1495: popVariables
1496: arg1
1497: } def
1498:
1499: ;