Annotation of OpenXM/src/kan96xx/Doc/tower.sm1, Revision 1.4
1.4 ! takayama 1: %% $OpenXM: OpenXM/src/kan96xx/Doc/tower.sm1,v 1.3 2004/05/13 05:33:10 takayama Exp $
1.1 maekawa 2: %% It is used to check the mmLarger_tower, 1997, 10/26 at Heidelberg.
3: %% It is used to check the mmLarger_tower, 1997, 10/27 -- 29 at Oberwolfach.
4: %% 1997, 11/7 s_ring_of_differential_operators at Kobe
5: %% 1998, 1/28 Homogenize_vec = 0;
6: %% 1998, 11/5 Doc/tower.sm1
7: %%
8: %% tower.sm1 is kept in this directory for the compatibility to
9: %% old demo programs and packages. It is being merged to
10: %% resol0.sm1 cf. r-interface.sm1, tower.sm1, tower-sugar.sm1
11: %%
12: /tower.version (2.981105) def
13: tower.version [(Version)] system_variable gt
14: { (This package requires the latest version of kan/sm1) message
15: (Please get it from http://www.math.kobe-u.ac.jp/KAN) message
16: error
17: } { } ifelse
18:
19: /debug.res0 0 def
20: /debug.sResolution 0 def
21: /stat.tower 0 def
22: /tower.verbose 0 def
23: %(tower-test.sm1) run
24: tower.verbose
25: { (Doc/tower.sm1 is still under construction.) message } { } ifelse
26:
27: [(sResolution)
28: [( sResolution constructs the Schreyer resolution.)
29: ( depth f sResolution r where )
30: ( r = [starting Groebner basis g, [ s1, s2 , s3, ...], order-def].)
31: ( g is the reduced Groebner basis for f, )
32: ( s1 is the syzygy of f,)
33: ( s2 is the syzygy of s1,)
34: ( s3 is the syzygy of s2 and so on.)
35: (Note that es and ES are reserved for schreyer ordering.)
36: (Note also that schreyer order causes troubles for other computations)
37: (except sResolution in kan/sm1.)
38: (Example:)
39: $ [(x,y) s_ring_of_differential_operators$
40: $ [[(Dx) 1 (x) -1]] s_weight_vector$
41: $ 0 [(schreyer) 1]] define_ring$
42: $ $
43: $ [( x^3-y^2 ) tparse$
44: $ ( 2 x Dx + 3 y Dy + 6 ) tparse$
45: $ ( 2 y Dx + 3 x^2 Dy) tparse$
46: $ ] sResolution /ans set ; $
47: ]] putUsages
48:
49: /offTower {
50: [(AvoidTheSameRing)] pushEnv
51: [ [(AvoidTheSameRing) 0] system_variable
52: [(gbListTower) [[ ]] (list) dc] system_variable
53: ] pop popEnv
54: } def
55:
56:
57: /tparse {
58: /arg1 set
59: [/f /ans /fhead /val] pushVariables
60: [
61: /f arg1 def
62: (report) (mmLarger) switch_function /val set
63: f isString { } { f toString /f set } ifelse
64: (mmLarger) (matrix) switch_function
65: f expand /f set
66: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
67: /ans (0). def
68: {
69: f (0). eq {exit} { } ifelse
70: (mmLarger) (matrix) switch_function
71: f init /fhead set f fhead sub /f set
72: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
73: ans fhead add /ans set
74: } loop
75: (mmLarger) val switch_function
76: /arg1 ans def
77: ] pop
78: popVariables
79: arg1
80: } def
81:
82:
83: /toes {
84: %% [x+2, y x ] ===> x + 2 + y x es (sorted by the schreyer order.)
85: /arg1 set
86: [/vec] pushVariables
87: [
88: /vec arg1 def
89: vec isPolynomial { /vec [vec] def } { } ifelse
90: [(toes) vec] gbext /arg1 set
91: ] pop
92: popVariables
93: arg1
94: } def
95:
96: /toE {
97: %% [x+2, y x ] ===> x e + 2 e + y s e (sorted by the schreyer order.)
98: /arg1 set
99: [/n /vec /oures /i /ppp] pushVariables
100: [
101: /vec arg1 def
102: /oures @@@.esymbol . def
103: vec isPolynomial { /vec [vec] def } { } ifelse
104: vec isArray
105: { } {(error: vec toE, vec must be an array) message error} ifelse
106: /n vec length def
107: 0 1 n 1 sub
108: { /i set
109: vec i get oures degree 0 eq
110: { }
111: {(error: vec toE, vec must not contain the variable e) message error}
112: ifelse
113: } for
114:
115: [ 0 1 n 1 sub { /i set oures i power } for ] /ppp set
116: %% ppp message
117: vec ppp mul /arg1 set
118: ] pop
119: popVariables
120: arg1
121: } def
122:
123: /res0 {
124: /arg1 set
125: [/g /t.syz /nexttower /m /t.gb /skel /betti /gg
126: /k /i /j /pair /tmp /si /sj /grG /syzAll] pushVariables
127: [
128: /g arg1 def %% g = [g_1, ..., g_m] g_i does not contain h and es.
129: [(Homogenize)] system_variable 0 eq
130: { tower.verbose {
131: (Warning: Homogenization option is automatically turned on. ReduceLowerTerms = 1) message
132: } { } ifelse
133: [(Homogenize) 1] system_variable
134: [(ReduceLowerTerms) 1] system_variable
135: } { } ifelse
136: g length 0 eq { (error: [ ] argument to res0.) message error } { } ifelse
137: g { toes } map /g set
138: stat.tower { (Size of g is ) messagen g length messagen } { } ifelse
139: stat.tower { (, sizes of each element in g are ) messagen
140: g { length } map message } { } ifelse
141: debug.res0 {(es expression of g: ) messagen g message } { } ifelse
142: stat.tower { (Computing the skelton.) message } { } ifelse
143: [(schreyerSkelton) g] gbext /skel set
144: /betti skel length def
145: stat.tower { (Done. Number of skelton is ) messagen betti message } { } ifelse
146:
147: debug.res0
148: { (init of original g : ) messagen g {init} map message
149: (length of skelton ) messagen betti message
150: (schreyerSkelton g : ) messagen skel message
151: (Doing reduction ) messagen
152: } { } ifelse
153:
154: %(red@) (debug) switch_function
155: %(red@) (module1v) switch_function
156:
157: /grG g (gradedPolySet) dc def
158: [ 0 1 betti 1 sub { pop 0 } for ] /syzAll set
159: 0 1 betti 1 sub {
160: /k set
161: [
162: /pair skel k get def
163: pair 0 get 0 get /i set
164: pair 0 get 1 get /j set
165: pair 1 get 0 get /si set
166: pair 1 get 1 get /sj set
167: si g i get mul
168: sj g j get mul add
169: grG reduction /tmp set % si g[i] + sj g[j] + \sum tmp[2][k] g[k] = 0.
170: tmp 0 get (0). eq {
171: tower.verbose { (.) messagen [(flush)] extension pop } { } ifelse
172: }
173: {
174: (Error: the result of resolution is not zero) message
175: ( [i,j], [si,sj] = ) messagen [ [ i j ] [si sj ]] message
176: error
177: } ifelse
178: /t.syz tmp 2 get def
179: << tmp 1 get >> si mul << t.syz i get >> add /si set
180: << tmp 1 get >> sj mul << t.syz j get >> add /sj set
181: t.syz i si put
182: t.syz j sj put
183: ] pop
184: syzAll k t.syz put
185: } for
186:
187: /t.syz syzAll def
188: tower.verbose {
189: ( Done. betti=) messagen betti message
190: } { } ifelse
191:
192: /nexttower g {init } map def
193: /arg1 [t.syz nexttower] def
194: ] pop
195: popVariables
196: arg1
197: } def
198:
199: /sResolution {
200: /arg1 set
201: /arg2 set %% optional parameter.
202: [/g /gbTower /ans /ff /opt /count /startingGB /opts /vectorInput
203: ] pushVariables
204: [ /g arg1 def
205: /opt arg2 def
206:
207: setupEnvForResolution
208:
209: /count -1 def
210: %% optional parameter.
211: opt isInteger {
212: /count opt def
213: } { } ifelse
214:
215: (mmLarger) (matrix) switch_function
216: %% new code of 1999, 5/18
217: g 0 get isArray {
218: /vectorInput 1 def
219: } {
220: /vectorInput 0 def
221: } ifelse
222: vectorInput {
223: tower.verbose { (tower.sm1: Vector input is homogenized : ) message
224: [g { sHomogenize2 } map ] message } { } ifelse
225: [g { sHomogenize2 } map ] groebner 0 get /g set
226: } {
227: tower.verbose { (tower.sm1: Homogenize the scalar input : ) message
228: [g {sHomogenize} map ] message } { } ifelse
229: [g {sHomogenize} map ] groebner 0 get /g set
230: } ifelse
231:
232:
233: /startingGB g def
234: debug.sResolution
235: {
236: (g is ) messagen g message
237: (---------------------------------------------------) message
238: } { } ifelse
239: /ans [ ] def
240: % /gbTower [g {init} map ] def
241: /gbTower [ ] def
242: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
243: {
244: g res0 /ff set
245: ans ff 0 get append /ans set %% store the syzygy.
246: debug.sResolution
247: {
248: (Syzygy : ) messagen ff 0 get message
249: (----------------------------------------------------) message
250: } { } ifelse
251: [ff 1 get] gbTower join /gbTower set
252: /g ff 0 get def
253: g length 0 eq { exit } { } ifelse
254:
255: [(AvoidTheSameRing)] pushEnv
256: [ [(AvoidTheSameRing) 0] system_variable
257: [(gbListTower) gbTower (list) dc] system_variable
258: ] pop popEnv
259:
260: count 0 eq { (Resolution procedure stoped because counter == 0.) message
261: exit }
262: { } ifelse
263: count 1 sub /count set
264:
265:
266: } loop
267:
268: restoreEnvAfterResolution
269:
270: /arg1 [startingGB ans gbTower] def
271: ] pop
272: popVariables
273: arg1
274: } def
275:
276: /sHomogenize {
277: /arg1 set
278: [/ff ] pushVariables
279: [
280: /ff arg1 def
281: ff homogenize
282: toString tparse %% homogenization may destroy the order.
283: %% cf. 97feb4.txt 1997, 10/29
284: /arg1 set
285: ] pop
286: popVariables
287: arg1
288: } def
289:
290: /sHomogenize2 {
291: /arg1 set
292: [/ff /vectorInput /f2deg /f2 /tt /f2max /ttdeg] pushVariables
293: [
294: /ff arg1 def
295: ff isArray{
296: ff homogenize /f2 set
297: f2 {toString tparse} map /f2 set
298: f2 {/tt set [(grade) tt] gbext} map /f2deg set
299: [-1] f2deg join shell reverse 0 get /f2max set
300: f2 { /tt set [(grade) tt] gbext /ttdeg set
301: tt [@@@.hsymbol (^) f2max ttdeg sub toString] cat . mul
302: } map
303: } {
304: ff homogenize
305: toString tparse %% homogenization may destroy the order.
306: %% cf. 97feb4.txt 1997, 10/29
307: } ifelse
308: /arg1 set
309: ] pop
310: popVariables
311: arg1
312: } def
313:
314:
315:
316: /s_ring_of_differential_operators {
317: /arg1 set
318: [/vars /n /i /xList /dList /param] pushVariables
319: [
320: (mmLarger) (matrix) switch_function
321: (mpMult) (diff) switch_function
322: (red@) (module1) switch_function
323: (groebner) (standard) switch_function
324: (grade) (module1v) switch_function
325: (isSameComponent) (x) switch_function
326:
327: [arg1 to_records pop] /vars set %[x y z]
328: vars reverse /xList set %[z y x]
329: vars {@@@.Dsymbol 2 1 roll 2 cat_n} map
330: reverse /dList set %[Dz Dy Dx]
1.3 takayama 331: [@@@.Hsymbol] xList join [(es) @@@.esymbol ] join /xList set
1.1 maekawa 332: %% You cannot change the order of es and e, because
333: %% mmLarger_tower automatically assumes es is at the bottom
334: %% of [nn,n-1] variables.
335: [(h)] dList join [(ES) @@@.Esymbol ] join /dList set
336: [0 1 1 1 << xList length >>
337: 1 1 1 << xList length 2 sub >> ] /param set
338: [ xList dList param ] /arg1 set
339: ] pop
340: popVariables
341: arg1
342: } def
343:
344: /s_weight_vector {
345: /arg2 set /arg1 set
346: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
347: /vars arg1 def /w-vectors arg2 def
348: [
349: /univ vars 0 get reverse
350: vars 1 get reverse join
351: def
1.4 ! takayama 352: w-vectors to_int /w-vectors set
1.1 maekawa 353: [
354: 0 1 << w-vectors length 1 sub >>
355: {
356: /k set
357: univ w-vectors k get w_to_vec
358: } for
359: ] /order1 set
360: %% order1 ::
361:
362: vars s_reverse_lex_order 3 get /order2 set
363: vars [ << order1 order2 join >> ] join /arg1 set
364: ] pop
365: popVariables
366: arg1
367: } def
368:
369: /s_reverse_lex_order {
370: %% [x-list d-list params] elimination_order
371: %% vars
372: %% [x-list d-list params order]
373: /arg1 set
374: [/vars /univ /order /perm /univ0 /compl] pushVariables
375: /vars arg1 def
376: [
377: /univ vars 0 get reverse
378: vars 1 get reverse join
379: def
380:
381: << univ length 3 sub >>
382: 0
383: eliminationOrderTemplate /order set
384:
385: [[1]] [[1]] oplus order oplus [[1]] oplus /order set
386:
387: vars [order] join /arg1 set
388: ] pop
389: popVariables
390: arg1
391: } def
392:
393:
394: /setupEnvForResolution {
395: getOptions /opts set
396: [(Homogenize_vec)] system_variable 1 eq
397: { [(Homogenize_vec) 0] system_variable
398: (grade) (module1v) switch_function
399: tower.verbose {
400: (Homogenize_vec is automatically set to 0. grade is set to module1v) message
401: } { } ifelse
402: } { } ifelse
403:
404: [(Schreyer)] system_variable 1 eq
405: { }
406: {(Error: You can compute resolutions only in the ring defined with) message
407: $the [(schreyer) 1] option. cf. s_ring_of_differential_operators$ message
408: error
409: } ifelse
410:
411: (report) (mmLarger) switch_function (tower) eq
412: { }
413: { tower.verbose {
414: $Warning: (mmLarger) (tower) switch_function is executed.$ message
415: } { } ifelse
416: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
417: } ifelse
418:
419: } def
420:
421: /restoreEnvAfterResolution {
422: [(AvoidTheSameRing)] pushEnv
423: [ [(AvoidTheSameRing) 0] system_variable
424: [(gbListTower) [[ ]] (list) dc] system_variable
425: ] pop popEnv
426: opts restoreOptions
427: } def
428:
429: %%%%% 1998, 4/11. To get frame for homogenized resolutions.
430: /sResolutionFrame {
431: /arg1 set
432: /arg2 set %% optional parameter.
433: [/g /gbTower /ans /ff /opt /count /startingGB /opts] pushVariables
434: [ /g arg1 def
435: /opt arg2 def
436:
437:
438: stat.tower { [(Statistics) 1] system_variable } { } ifelse
439: /count -1 def
440: %% optional parameter.
441: opt isInteger {
442: /count opt def
443: } { } ifelse
444:
445: (mmLarger) (matrix) switch_function
446: [g {sHomogenize} map ] groebner 0 get /g set
447: g { init } map /g set
448:
449: setupEnvForResolution-sugar
450:
451: /startingGB g def
452: debug.sResolution
453: {
454: (g is ) messagen g message
455: (---------------------------------------------------) message
456: } { } ifelse
457: /ans [ ] def
458: % /gbTower [g {init} map ] def
459: /gbTower [ ] def
460: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
461: {
462: g res0Frame /ff set
463: ans ff 0 get append /ans set %% store the syzygy.
464: debug.sResolution
465: {
466: (Syzygy : ) messagen ff 0 get message
467: (----------------------------------------------------) message
468: } { } ifelse
469: [ff 1 get] gbTower join /gbTower set
470: /g ff 0 get def
471: g length 0 eq { exit } { } ifelse
472:
473: [(AvoidTheSameRing)] pushEnv
474: [ [(AvoidTheSameRing) 0] system_variable
475: [(gbListTower) gbTower (list) dc] system_variable
476: ] pop popEnv
477:
478: count 0 eq { (Resolution prodecure stoped because counter == 0.) message
479: exit }
480: { } ifelse
481: count 1 sub /count set
482:
483:
484: } loop
485:
486: restoreEnvAfterResolution-sugar
487:
488: /arg1 [startingGB ans gbTower] def
489: ] pop
490: popVariables
491: arg1
492: } def
493:
494: /newPolyVector {
495: /arg1 set
496: /arg2 (0). def
497: [ 1 1 arg1 { pop arg2 } for ]
498: } def
499:
500: /res0Frame {
501: /arg1 set
502: [/g /t.syz /nexttower /m /t.gb /skel /betti /gg
503: /k /i /j /pair /tmp /si /sj /grG /syzAll /gLength] pushVariables
504: [
505: /g arg1 def %% g = [g_1, ..., g_m] g_i does not contain h and es.
506: [(Homogenize)] system_variable 1 eq
507: { (Warning: Homogenization and ReduceLowerTerms options are automatically turned off.) message
508: [(Homogenize) 0] system_variable
509: [(ReduceLowerTerms) 0] system_variable
510: } { } ifelse
511: g length 0 eq { (error: [ ] argument to res0.) message error } { } ifelse
512: g { toes } map /g set
513: stat.tower { (Size of g is ) messagen g length messagen } { } ifelse
514: stat.tower { (, sizes of each element in g are ) messagen
515: g { length } map message } { } ifelse
516: debug.res0 {(es expression of g: ) messagen g message } { } ifelse
517: stat.tower { (Computing the skelton.) message } { } ifelse
518: [(schreyerSkelton) g] gbext /skel set
519: /betti skel length def
520: stat.tower { (Done. Number of skelton is ) messagen betti message } { } ifelse
521:
522: debug.res0
523: { (init of original g : ) messagen g {init} map message
524: (length of skelton ) messagen betti message
525: (schreyerSkelton g : ) messagen skel message
526: (Doing reduction ) messagen
527: } { } ifelse
528:
529: g length /gLength set
530: /grG g (gradedPolySet) dc def
531: [ 0 1 betti 1 sub { pop 0 } for ] /syzAll set
532: 0 1 betti 1 sub {
533: /k set
534: [
535: /pair skel k get def
536: pair 0 get 0 get /i set
537: pair 0 get 1 get /j set
538: pair 1 get 0 get /si set
539: pair 1 get 1 get /sj set
540: % si g[i] + sj g[j] + \sum tmp[2][k] g[k] = 0.
541: (.) messagen [(flush)] extension pop
542:
543: /t.syz gLength newPolyVector def
544: t.syz i si put
545: t.syz j sj put
546: ] pop
547: syzAll k t.syz put
548: } for
549:
550: /t.syz syzAll def
551: ( Done. betti=) messagen betti message
552:
553:
554: /nexttower g {init } map def
555: /arg1 [t.syz nexttower] def
556: %% clear all unnecessary variables to save memory.
557: /g 0 def /t.syz 0 def /nexttower 0 def /t.gb 0 def /skel 0 def /gg 0 def
558: /k 0 def /tmp 0 def /grG 0 def /syzAll 0 def
559: ] pop
560: popVariables
561: arg1
562: } def
563:
564: /s_ring_of_polynomials {
565: /arg1 set
566: [/vars /n /i /xList /dList /param] pushVariables
567: [
568: (mmLarger) (matrix) switch_function
569: (mpMult) (poly) switch_function
570: (red@) (module1) switch_function
571: (groebner) (standard) switch_function
572: (isSameComponent) (x) switch_function
573:
574: [arg1 to_records pop] /vars set
575: vars length evenQ
576: { }
577: { vars [(PAD)] join /vars set }
578: ifelse
579: vars length 2 idiv /n set
580: [ << n 1 sub >> -1 0
581: { /i set
582: vars i get
583: } for
584: ] /xList set
585: [ << n 1 sub >> -1 0
586: { /i set
587: vars << i n add >> get
588: } for
589: ] /dList set
590:
1.3 takayama 591: [@@@.Hsymbol] xList join [(es) @@@.esymbol ] join /xList set
1.1 maekawa 592: %% You cannot change the order of es and e, because
593: %% mmLarger_tower automatically assumes es is at the bottom
594: %% of [nn,n-1] variables.
595: [(h)] dList join [(ES) @@@.Esymbol ] join /dList set
596: [0 %% dummy characteristic
597: << xList length 2 sub >> << xList length 2 sub >>
598: << xList length 2 sub >> << xList length >>
599: %% c l m n
600: << xList length 2 sub >> << xList length 2 sub >>
601: << xList length 2 sub >> << xList length 2 sub >>
602: %% cc ll mm nn es must belong to differential variables.
603: ] /param set
604: [xList dList param] /arg1 set
605: ] pop
606: popVariables
607: arg1
608: } def
609:
610: /setupEnvForResolution-sugar {
611: getOptions /opts set
612: [(Homogenize)] system_variable 1 eq
613: { (Warning: Homogenization and ReduceLowerTerms options are automatically turned off.) message
614: [(Homogenize) 0] system_variable
615: [(ReduceLowerTerms) 0] system_variable
616: } { } ifelse
617:
618: [(Schreyer)] system_variable 1 eq
619: { }
620: {(Error: You can compute resolutions only in the ring defined with) message
621: $the [(schreyer) 1] option. cf. s_ring_of_differential_operators$ message
622: error
623: } ifelse
624:
625: (report) (mmLarger) switch_function (tower) eq
626: { }
627: { $Warning: (mmLarger) (tower) switch_function is executed.$ message
628: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
629: } ifelse
630:
631: } def
632:
633: /restoreEnvAfterResolution-sugar {
634: %% Turn off tower by (mmLarger) (tower) switch_function
635: %% and clear the tower of orders by [(gbListTower) [[]] (list) dc] system_variable
636: [(AvoidTheSameRing)] pushEnv
637: [ [(AvoidTheSameRing) 0] system_variable
638: [(gbListTower) [[]] (list) dc] system_variable
639: ] pop popEnv
640: opts restoreOptions
641: } def
642:
643:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to tower.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc