Annotation of OpenXM/src/kan96xx/Doc/tower.sm1, Revision 1.3
1.3 ! takayama 1: %% $OpenXM: OpenXM/src/kan96xx/Doc/tower.sm1,v 1.2 2000/04/19 08:01:32 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
352: [
353: 0 1 << w-vectors length 1 sub >>
354: {
355: /k set
356: univ w-vectors k get w_to_vec
357: } for
358: ] /order1 set
359: %% order1 ::
360:
361: vars s_reverse_lex_order 3 get /order2 set
362: vars [ << order1 order2 join >> ] join /arg1 set
363: ] pop
364: popVariables
365: arg1
366: } def
367:
368: /s_reverse_lex_order {
369: %% [x-list d-list params] elimination_order
370: %% vars
371: %% [x-list d-list params order]
372: /arg1 set
373: [/vars /univ /order /perm /univ0 /compl] pushVariables
374: /vars arg1 def
375: [
376: /univ vars 0 get reverse
377: vars 1 get reverse join
378: def
379:
380: << univ length 3 sub >>
381: 0
382: eliminationOrderTemplate /order set
383:
384: [[1]] [[1]] oplus order oplus [[1]] oplus /order set
385:
386: vars [order] join /arg1 set
387: ] pop
388: popVariables
389: arg1
390: } def
391:
392:
393: /setupEnvForResolution {
394: getOptions /opts set
395: [(Homogenize_vec)] system_variable 1 eq
396: { [(Homogenize_vec) 0] system_variable
397: (grade) (module1v) switch_function
398: tower.verbose {
399: (Homogenize_vec is automatically set to 0. grade is set to module1v) message
400: } { } ifelse
401: } { } ifelse
402:
403: [(Schreyer)] system_variable 1 eq
404: { }
405: {(Error: You can compute resolutions only in the ring defined with) message
406: $the [(schreyer) 1] option. cf. s_ring_of_differential_operators$ message
407: error
408: } ifelse
409:
410: (report) (mmLarger) switch_function (tower) eq
411: { }
412: { tower.verbose {
413: $Warning: (mmLarger) (tower) switch_function is executed.$ message
414: } { } ifelse
415: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
416: } ifelse
417:
418: } def
419:
420: /restoreEnvAfterResolution {
421: [(AvoidTheSameRing)] pushEnv
422: [ [(AvoidTheSameRing) 0] system_variable
423: [(gbListTower) [[ ]] (list) dc] system_variable
424: ] pop popEnv
425: opts restoreOptions
426: } def
427:
428: %%%%% 1998, 4/11. To get frame for homogenized resolutions.
429: /sResolutionFrame {
430: /arg1 set
431: /arg2 set %% optional parameter.
432: [/g /gbTower /ans /ff /opt /count /startingGB /opts] pushVariables
433: [ /g arg1 def
434: /opt arg2 def
435:
436:
437: stat.tower { [(Statistics) 1] system_variable } { } ifelse
438: /count -1 def
439: %% optional parameter.
440: opt isInteger {
441: /count opt def
442: } { } ifelse
443:
444: (mmLarger) (matrix) switch_function
445: [g {sHomogenize} map ] groebner 0 get /g set
446: g { init } map /g set
447:
448: setupEnvForResolution-sugar
449:
450: /startingGB g def
451: debug.sResolution
452: {
453: (g is ) messagen g message
454: (---------------------------------------------------) message
455: } { } ifelse
456: /ans [ ] def
457: % /gbTower [g {init} map ] def
458: /gbTower [ ] def
459: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
460: {
461: g res0Frame /ff set
462: ans ff 0 get append /ans set %% store the syzygy.
463: debug.sResolution
464: {
465: (Syzygy : ) messagen ff 0 get message
466: (----------------------------------------------------) message
467: } { } ifelse
468: [ff 1 get] gbTower join /gbTower set
469: /g ff 0 get def
470: g length 0 eq { exit } { } ifelse
471:
472: [(AvoidTheSameRing)] pushEnv
473: [ [(AvoidTheSameRing) 0] system_variable
474: [(gbListTower) gbTower (list) dc] system_variable
475: ] pop popEnv
476:
477: count 0 eq { (Resolution prodecure stoped because counter == 0.) message
478: exit }
479: { } ifelse
480: count 1 sub /count set
481:
482:
483: } loop
484:
485: restoreEnvAfterResolution-sugar
486:
487: /arg1 [startingGB ans gbTower] def
488: ] pop
489: popVariables
490: arg1
491: } def
492:
493: /newPolyVector {
494: /arg1 set
495: /arg2 (0). def
496: [ 1 1 arg1 { pop arg2 } for ]
497: } def
498:
499: /res0Frame {
500: /arg1 set
501: [/g /t.syz /nexttower /m /t.gb /skel /betti /gg
502: /k /i /j /pair /tmp /si /sj /grG /syzAll /gLength] pushVariables
503: [
504: /g arg1 def %% g = [g_1, ..., g_m] g_i does not contain h and es.
505: [(Homogenize)] system_variable 1 eq
506: { (Warning: Homogenization and ReduceLowerTerms options are automatically turned off.) message
507: [(Homogenize) 0] system_variable
508: [(ReduceLowerTerms) 0] system_variable
509: } { } ifelse
510: g length 0 eq { (error: [ ] argument to res0.) message error } { } ifelse
511: g { toes } map /g set
512: stat.tower { (Size of g is ) messagen g length messagen } { } ifelse
513: stat.tower { (, sizes of each element in g are ) messagen
514: g { length } map message } { } ifelse
515: debug.res0 {(es expression of g: ) messagen g message } { } ifelse
516: stat.tower { (Computing the skelton.) message } { } ifelse
517: [(schreyerSkelton) g] gbext /skel set
518: /betti skel length def
519: stat.tower { (Done. Number of skelton is ) messagen betti message } { } ifelse
520:
521: debug.res0
522: { (init of original g : ) messagen g {init} map message
523: (length of skelton ) messagen betti message
524: (schreyerSkelton g : ) messagen skel message
525: (Doing reduction ) messagen
526: } { } ifelse
527:
528: g length /gLength set
529: /grG g (gradedPolySet) dc def
530: [ 0 1 betti 1 sub { pop 0 } for ] /syzAll set
531: 0 1 betti 1 sub {
532: /k set
533: [
534: /pair skel k get def
535: pair 0 get 0 get /i set
536: pair 0 get 1 get /j set
537: pair 1 get 0 get /si set
538: pair 1 get 1 get /sj set
539: % si g[i] + sj g[j] + \sum tmp[2][k] g[k] = 0.
540: (.) messagen [(flush)] extension pop
541:
542: /t.syz gLength newPolyVector def
543: t.syz i si put
544: t.syz j sj put
545: ] pop
546: syzAll k t.syz put
547: } for
548:
549: /t.syz syzAll def
550: ( Done. betti=) messagen betti message
551:
552:
553: /nexttower g {init } map def
554: /arg1 [t.syz nexttower] def
555: %% clear all unnecessary variables to save memory.
556: /g 0 def /t.syz 0 def /nexttower 0 def /t.gb 0 def /skel 0 def /gg 0 def
557: /k 0 def /tmp 0 def /grG 0 def /syzAll 0 def
558: ] pop
559: popVariables
560: arg1
561: } def
562:
563: /s_ring_of_polynomials {
564: /arg1 set
565: [/vars /n /i /xList /dList /param] pushVariables
566: [
567: (mmLarger) (matrix) switch_function
568: (mpMult) (poly) switch_function
569: (red@) (module1) switch_function
570: (groebner) (standard) switch_function
571: (isSameComponent) (x) switch_function
572:
573: [arg1 to_records pop] /vars set
574: vars length evenQ
575: { }
576: { vars [(PAD)] join /vars set }
577: ifelse
578: vars length 2 idiv /n set
579: [ << n 1 sub >> -1 0
580: { /i set
581: vars i get
582: } for
583: ] /xList set
584: [ << n 1 sub >> -1 0
585: { /i set
586: vars << i n add >> get
587: } for
588: ] /dList set
589:
1.3 ! takayama 590: [@@@.Hsymbol] xList join [(es) @@@.esymbol ] join /xList set
1.1 maekawa 591: %% You cannot change the order of es and e, because
592: %% mmLarger_tower automatically assumes es is at the bottom
593: %% of [nn,n-1] variables.
594: [(h)] dList join [(ES) @@@.Esymbol ] join /dList set
595: [0 %% dummy characteristic
596: << xList length 2 sub >> << xList length 2 sub >>
597: << xList length 2 sub >> << xList length >>
598: %% c l m n
599: << xList length 2 sub >> << xList length 2 sub >>
600: << xList length 2 sub >> << xList length 2 sub >>
601: %% cc ll mm nn es must belong to differential variables.
602: ] /param set
603: [xList dList param] /arg1 set
604: ] pop
605: popVariables
606: arg1
607: } def
608:
609: /setupEnvForResolution-sugar {
610: getOptions /opts set
611: [(Homogenize)] system_variable 1 eq
612: { (Warning: Homogenization and ReduceLowerTerms options are automatically turned off.) message
613: [(Homogenize) 0] system_variable
614: [(ReduceLowerTerms) 0] system_variable
615: } { } ifelse
616:
617: [(Schreyer)] system_variable 1 eq
618: { }
619: {(Error: You can compute resolutions only in the ring defined with) message
620: $the [(schreyer) 1] option. cf. s_ring_of_differential_operators$ message
621: error
622: } ifelse
623:
624: (report) (mmLarger) switch_function (tower) eq
625: { }
626: { $Warning: (mmLarger) (tower) switch_function is executed.$ message
627: [(AvoidTheSameRing)] pushEnv [ [(AvoidTheSameRing) 0] system_variable (mmLarger) (tower) switch_function ] pop popEnv
628: } ifelse
629:
630: } def
631:
632: /restoreEnvAfterResolution-sugar {
633: %% Turn off tower by (mmLarger) (tower) switch_function
634: %% and clear the tower of orders by [(gbListTower) [[]] (list) dc] system_variable
635: [(AvoidTheSameRing)] pushEnv
636: [ [(AvoidTheSameRing) 0] system_variable
637: [(gbListTower) [[]] (list) dc] system_variable
638: ] pop popEnv
639: opts restoreOptions
640: } def
641:
642:
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