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