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