Annotation of OpenXM/src/kan96xx/Doc/ecart.sm1, Revision 1.22
1.22 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.21 2004/05/04 08:29:35 takayama Exp $
1.1 takayama 2: %[(parse) (hol.sm1) pushfile] extension
3: %[(parse) (appell.sm1) pushfile] extension
4:
5: (ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet
6: /ecart.begin { beginEcart } def
7: /ecart.end { endEcart } def
8: /ecart.autoHomogenize 1 def
9: /ecart.needSyz 0 def
1.8 takayama 10: /ecartd.begin {
11: ecart.begin
12: [(EcartAutomaticHomogenization) 1] system_variable
13: } def
14: /ecartd.end {
15: ecart.end
16: [(EcartAutomaticHomogenization) 0] system_variable
17: } def
1.1 takayama 18:
1.22 ! takayama 19: /ecart.message.quiet 0 def
! 20: /ecart.message {
! 21: ecart.message.quiet { pop } { message } ifelse
! 22: } def
! 23: /ecart.messagen {
! 24: ecart.message.quiet { pop } { messagen } ifelse
! 25: } def
1.15 takayama 26: /ecart.setOpt {
27: /arg1 set
28: [/in-ecart.setOpt /opt /i /n /ans] pushVariables
29: [
30: /opt arg1 def
31: /ans [ ] def
32: /n opt length def
33: 0 2 n 1 sub {
34: /i set
35: opt i get tag StringP eq not {
36: (ecart.setOpt : [keyword value keyword value ....] ) error
37: } { } ifelse
38: { % start of the loop
39: % Global: degreeShift
40: opt i get (degreeShift) eq {
41: /degreeShift opt i 1 add get def
42: exit
43: } { } ifelse
44: % Global: hdShift
45: opt i get (startingShift) eq {
46: /hdShift opt i 1 add get def
47: exit
48: } { } ifelse
49: % Global: hdShift
50: opt i get (noAutoHomogenize) eq {
51: /hdShift -1 def
52: exit
53: } { } ifelse
1.16 takayama 54: % Global: ecart.useSugar
55: opt i get (sugar) eq {
56: /ecart.useSugar opt i 1 add get def
57: exit
58: } { } ifelse
59:
1.15 takayama 60: ans [opt i get opt i 1 add get ] append /ans set
61: exit
62: } loop
63: } for
64:
65: ecart.gb.verbose {
66: (ecart.setOpt:) message
67: (degreeShift=) messagen degreeShift message
68: $hdShift(startingShift)=$ messagen hdShift message
1.16 takayama 69: (sugar=) messagen ecart.useSugar message
1.15 takayama 70: (Other options=) messagen ans message
71: } { } ifelse
72:
73: /arg1 ans def
74: ] pop
75: popVariables
76: arg1
77: } def
78:
1.1 takayama 79: /ecart.dehomogenize {
80: /arg1 set
81: [/in.ecart.dehomogenize /ll /rr] pushVariables
82: [
83: /ll arg1 def
84: ll tag 6 eq {
85: ll { ecart.dehomogenize } map /ll set
86: } {
87: ll (0). eq {
88: } {
89: ll getRing /rr set
90: ll [ [ (H) rr ,, (1) rr ,, ]
91: [ (h) rr ,, (1) rr ,, ]] replace
92: /ll set
93: } ifelse
94: } ifelse
95: /arg1 ll def
96: ] pop
97: popVariables
98: arg1
99: } def
100: [(ecart.dehomogenize)
101: [(obj ecart.dehomogenize r)
102: (h->1, H->1)
103: ]] putUsages
104:
105: /ecart.dehomogenizeH {
106: /arg1 set
107: [/in.ecart.dehomogenize /ll /rr] pushVariables
108: [
109: /ll arg1 def
110: ll tag 6 eq {
111: ll { ecart.dehomogenize } map /ll set
112: } {
113: ll (0). eq {
114: } {
115: ll getRing /rr set
116: ll [ [ (H) rr ,, (1) rr ,, ] ] replace
117: /ll set
118: } ifelse
119: } ifelse
120: /arg1 ll def
121: ] pop
122: popVariables
123: arg1
124: } def
125: [(ecart.dehomogenizeH)
126: [(obj ecart.dehomogenizeH r)
127: (H->1, h is not changed.)
128: ]] putUsages
129:
130: /ecart.homogenize01 {
131: /arg1 set
1.11 takayama 132: [/in.ecart.homogenize01 /ll /ll0] pushVariables
1.1 takayama 133: [
134: /ll arg1 def
1.11 takayama 135: ll tag ArrayP eq {
136: ll 0 get tag ArrayP eq not {
137: [(degreeShift) [ ] ll ] homogenize /arg1 set
138: } {
139: ll { ecart.homogenize01 } map /arg1 set
140: } ifelse
141: } {
142: [(degreeShift) [ ] ll ] homogenize /arg1 set
1.12 takayama 143: } ifelse
1.1 takayama 144: ] pop
145: popVariables
146: arg1
147: } def
148: [(ecart.homogenize01)
149: [(obj ecart.homogenize01 r)
150: (Example: )
151: ( [(x1,x2) ring_of_differential_operators )
152: ( [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
153: ( [(h) 1 (Dx1) 1 (Dx2) 1] )
154: ( [(Dx1) 1 (Dx2) 1] )
155: ( [(x1) -1 (x2) -1])
1.18 takayama 156: ( ] ecart.weight_vector )
1.1 takayama 157: ( 0 )
1.11 takayama 158: ( [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
1.1 takayama 159: ( ] define_ring)
160: ( ecart.begin)
161: ( [[1 -4 -2 5]] appell4 0 get /eqs set)
162: ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
1.11 takayama 163: ( {ecart.homogenize01} map /eqs2 set)
1.1 takayama 164: ( [eqs2] groebner )
165: ]] putUsages
166:
167: /ecart.homogenize01_with_shiftVector {
168: /arg2.set
169: /arg1 set
1.11 takayama 170: [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
1.1 takayama 171: [
172: /sv arg2 def
173: /ll arg1 def
1.11 takayama 174: ll tag ArrayP eq {
175: ll 0 get tag ArrayP eq not {
176: [(degreeShift) sv ll ] homogenize /arg1 set
177: } {
178: ll { ecart.homogenize01_with_shiftVector } map /arg1 set
179: } ifelse
180: } {
181: [(degreeShift) sv ll ] homogenize /arg1 set
1.12 takayama 182: } ifelse
1.1 takayama 183: ] pop
184: popVariables
185: arg1
186: } def
187: [(ecart.dehomogenize01_with_degreeShift)
188: [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
1.11 takayama 189: (cf. homogenize)
1.1 takayama 190: ]] putUsages
191:
192: %% Aux functions to return the default weight vectors.
193: /ecart.wv1 {
194: /arg1 set
195: [/in.ecart.wv1 /v] pushVariables
196: [
197: /v arg1 def
198: [(H) (h) v to_records pop] /v set
199: v { 1 } map /v set
200: /arg1 v def
201: ] pop
202: popVariables
203: arg1
204: } def
205: /ecart.wv2 {
206: /arg1 set
207: [/in.ecart.wv2 /v] pushVariables
208: [
209: /v arg1 def
210: [v to_records pop] /v set
211: v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
212: [(h) 1 ] v join /v set
213: /arg1 v def
214: ] pop
215: popVariables
216: arg1
217: } def
218:
1.7 takayama 219: /ecart.gb {ecartd.gb} def
220:
1.22 ! takayama 221: [(ecartd.gb)
! 222: [(See ecart.gb)]] putUsages
! 223:
1.7 takayama 224: [(ecart.gb)
225: [(a ecart.gb b)
226: (array a; array b;)
227: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
228: ( in the ring of differential operators.)
229: (The computation is done by using Ecart division algorithm and )
230: (the double homogenization.)
231: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
232: $ ii is the initial ideal in case of w is given or <<a>> belongs$
233: $ to a ring. In the other cases, it returns the initial monominal.$
234: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
235: (a : [f v]; array f; string v; v is the variables. )
236: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.15 takayama 237: $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$
1.11 takayama 238: ( array ds; ds is the degree shift for the ring. )
1.15 takayama 239: $a : [f v w [(degreeShift) ds (startingShift) hdShift]]; array f; string v; array of array w; w is the weight matirx.$
1.11 takayama 240: ( array ds; ds is the degree shift for the ring. )
241: ( array hsShift is the degree shift for the homogenization. cf.homogenize )
1.15 takayama 242: $a : [f v w [(degreeShift) ds (noAutoHomogenize) 1]]; array f; string v; array of array w; w is the weight matirx.$
1.11 takayama 243: ( No automatic homogenization.)
1.16 takayama 244: $ [(degreeShift) ds (noAutoHomogenize) 1 (sugar) 1] -->use the sugar strate $
1.7 takayama 245: ( )
1.19 takayama 246: $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize), ecartd.reduction $
1.7 takayama 247: ( )
248: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
249: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
250: (Example 2: )
251: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.9 takayama 252: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /ff set ff pmat ;$
253: (To set the current ring to the ring in which ff belongs )
254: ( ff getRing ring_def )
1.7 takayama 255: ( )
256: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
257: $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
1.10 takayama 258: ( This example will cause an error on order.)
1.7 takayama 259: ( )
260: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
261: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
1.10 takayama 262: ( This example will cause an error on order.)
1.7 takayama 263: ( )
264: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.15 takayama 265: $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $
266: $ [(degreeShift) [[0 1] [-3 1]]] ] ecart.gb pmat ; $
1.7 takayama 267: ( )
268: (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
269: ( ecart.dehomogenize, ecart.dehomogenizeH)
270: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
271: ( define_ring )
272: (/ecart.autoHomogenize 0 def )
273: ( not to dehomogenize and homogenize)
274: ]] putUsages
275:
1.1 takayama 276: /ecart.gb.verbose 1 def
1.12 takayama 277: %ecarth.gb s(H)-homogenized outputs. GG's original version of ecart gb.
1.7 takayama 278: /ecarth.gb {
1.1 takayama 279: /arg1 set
1.7 takayama 280: [/in-ecarth.gb /aa /typev /setarg /f /v
1.1 takayama 281: /gg /wv /vec /ans /rr /mm
282: /degreeShift /env2 /opt /ans.gb
1.12 takayama 283: /hdShift
1.17 takayama 284: /ecart.useSugar
1.1 takayama 285: ] pushVariables
286: [(CurrentRingp) (KanGBmessage)] pushEnv
287: [
288: /aa arg1 def
1.13 takayama 289: aa isArray { } { ( << array >> ecarth.gb) error } ifelse
1.1 takayama 290: /setarg 0 def
291: /wv 0 def
292: /degreeShift 0 def
1.12 takayama 293: /hdShift 0 def
1.1 takayama 294: /opt [(weightedHomogenization) 1] def
1.17 takayama 295: /ecart.useSugar 0 def
1.1 takayama 296: aa { tag } map /typev set
297: typev [ ArrayP ] eq
298: { /f aa 0 get def
299: /v gb.v def
300: /setarg 1 def
301: } { } ifelse
302: typev [ArrayP StringP] eq
303: { /f aa 0 get def
304: /v aa 1 get def
305: /setarg 1 def
306: } { } ifelse
307: typev [ArrayP RingP] eq
308: { /f aa 0 get def
309: /v aa 1 get def
310: /setarg 1 def
311: } { } ifelse
312: typev [ArrayP ArrayP] eq
313: { /f aa 0 get def
314: /v aa 1 get from_records def
315: /setarg 1 def
316: } { } ifelse
317: typev [ArrayP StringP ArrayP] eq
318: { /f aa 0 get def
319: /v aa 1 get def
320: /wv aa 2 get def
321: /setarg 1 def
322: } { } ifelse
323: typev [ArrayP ArrayP ArrayP] eq
324: { /f aa 0 get def
325: /v aa 1 get from_records def
326: /wv aa 2 get def
327: /setarg 1 def
328: } { } ifelse
1.15 takayama 329:
1.1 takayama 330: typev [ArrayP StringP ArrayP ArrayP] eq
331: { /f aa 0 get def
332: /v aa 1 get def
333: /wv aa 2 get def
1.15 takayama 334: opt aa 3 get ecart.setOpt join /opt set
1.12 takayama 335: /setarg 1 def
336: } { } ifelse
1.1 takayama 337: typev [ArrayP ArrayP ArrayP ArrayP] eq
338: { /f aa 0 get def
339: /v aa 1 get from_records def
340: /wv aa 2 get def
1.15 takayama 341: opt aa 3 get ecart.setOpt join /opt set
1.13 takayama 342: /setarg 1 def
343: } { } ifelse
1.1 takayama 344:
345: /env1 getOptions def
346:
1.12 takayama 347: ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } { } ifelse
348: setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
1.1 takayama 349:
350: [(KanGBmessage) ecart.gb.verbose ] system_variable
351:
352: %%% Start of the preprocess
353: v tag RingP eq {
354: /rr v def
355: }{
356: f getRing /rr set
357: } ifelse
358: %% To the normal form : matrix expression.
359: f gb.toMatrixOfString /f set
360: /mm gb.itWasMatrix def
361:
362: rr tag 0 eq {
363: %% Define our own ring
364: v isInteger {
365: (Error in gb: Specify variables) error
366: } { } ifelse
367: wv isInteger {
368: [v ring_of_differential_operators
1.18 takayama 369: % [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector
1.3 takayama 370: gb.characteristic
1.1 takayama 371: opt
372: ] define_ring
373: }{
374: degreeShift isInteger {
375: [v ring_of_differential_operators
1.18 takayama 376: % [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
377: wv ecart.weight_vector
1.3 takayama 378: gb.characteristic
1.1 takayama 379: opt
380: ] define_ring
381:
382: }{
383: [v ring_of_differential_operators
1.18 takayama 384: % [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
385: wv ecart.weight_vector
1.3 takayama 386: gb.characteristic
1.1 takayama 387: [(degreeShift) degreeShift] opt join
388: ] define_ring
389:
390: } ifelse
391: } ifelse
392: } {
393: %% Use the ring structre given by the input.
394: v isInteger not {
395: gb.warning {
396: (Warning : the given ring definition is not used.) message
397: } { } ifelse
398: } { } ifelse
399: rr ring_def
400: /wv rr gb.getWeight def
401:
402: } ifelse
403: %%% Enf of the preprocess
404:
405: ecart.gb.verbose {
1.6 takayama 406: (The first and the second weight vectors for automatic homogenization: )
1.1 takayama 407: message
408: v ecart.wv1 message
409: v ecart.wv2 message
410: degreeShift isInteger { }
411: {
412: (The degree shift is ) messagen
413: degreeShift message
414: } ifelse
415: } { } ifelse
416:
1.5 takayama 417: %%BUG: case of v is integer
418: v ecart.checkOrder
419:
1.1 takayama 420: ecart.begin
421:
422: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.13 takayama 423:
1.12 takayama 424:
425: hdShift tag 1 eq {
426: ecart.autoHomogenize not hdShift -1 eq or {
427: % No automatic h-s-homogenization.
428: f { {. } map} map /f set
429: } {
430: % Automatic h-s-homogenization without degreeShift
1.13 takayama 431: (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
432: message
1.12 takayama 433: f { {. ecart.dehomogenize} map} map /f set
434: f ecart.homogenize01 /f set
435: } ifelse
436: } {
437: % Automatic h-s-homogenization with degreeShift
1.13 takayama 438: (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
439: message
1.12 takayama 440: f { {. ecart.dehomogenize} map} map /f set
441: f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
442: }ifelse
443:
1.17 takayama 444: ecart.useSugar {
445: ecart.needSyz {
446: [f [(needSyz)] gb.options join ] groebner_sugar /gg set
447: } {
448: [f gb.options] groebner_sugar 0 get /gg set
449: } ifelse
450: } {
451: ecart.needSyz {
452: [f [(needSyz)] gb.options join ] groebner /gg set
453: } {
454: [f gb.options] groebner 0 get /gg set
455: } ifelse
1.1 takayama 456: } ifelse
457:
458: ecart.needSyz {
459: mm {
460: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
1.11 takayama 461: } { /ans.gb gg 0 get def } ifelse
462: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
463: % ans pmat ;
1.1 takayama 464: } {
465: wv isInteger {
466: /ans [gg gg {init} map] def
467: }{
1.10 takayama 468: degreeShift isInteger {
469: /ans [gg gg {wv 0 get weightv init} map] def
470: } {
471: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
472: } ifelse
1.1 takayama 473: }ifelse
474:
475: %% Postprocess : recover the matrix expression.
476: mm {
477: ans { /tmp set [mm tmp] toVectors } map
478: /ans set
479: }{ }
480: ifelse
481: } ifelse
482:
483: ecart.end
484:
485: %%
486: env1 restoreOptions %% degreeShift changes "grade"
487:
488: /arg1 ans def
489: ] pop
490: popEnv
491: popVariables
492: arg1
493: } def
1.7 takayama 494: (ecarth.gb ) messagen-quiet
1.1 takayama 495:
1.7 takayama 496: [(ecarth.gb)
497: [(a ecarth.gb b)
1.1 takayama 498: (array a; array b;)
499: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
500: ( in the ring of differential operators.)
1.12 takayama 501: (The computation is done by using Ecart division algorithm.)
502: $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$
503: (they are not dehomogenized.)
1.1 takayama 504: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
505: $ ii is the initial ideal in case of w is given or <<a>> belongs$
506: $ to a ring. In the other cases, it returns the initial monominal.$
507: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
508: (a : [f v]; array f; string v; v is the variables. )
509: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.15 takayama 510: $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$
1.1 takayama 511: ( array ds; ds is the degree shift )
512: ( )
513: (/ecart.autoHomogenize 0 def )
514: ( not to dehomogenize and homogenize)
515: ( )
516: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 takayama 517: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 518: (Example 2: )
519: (To put H and h=1, type in, e.g., )
520: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.7 takayama 521: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
1.1 takayama 522: ( )
523: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 takayama 524: $ [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
1.1 takayama 525: ( )
526: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.7 takayama 527: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 528: ( )
529: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.15 takayama 530: $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $
531: $ [(degreeShift) [[0 1] [-3 1] ]] ] ecarth.gb pmat ; $
1.1 takayama 532: ( )
1.7 takayama 533: (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
1.1 takayama 534: ( ecart.dehomogenize, ecart.dehomogenizeH)
535: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
536: ( define_ring )
537: ]] putUsages
538:
539:
540: /ecart.syz {
541: /arg1 set
542: [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
543: [
544: /ff arg1 def
545: /ecart.save.needSyz ecart.needSyz def
546: /ecart.needSyz 1 def
547: ff ecart.gb /ff.ans set
548: /ecart.needSyz ecart.save.needSyz def
549: /arg1 ff.ans def
550: ] pop
551: popVariables
552: arg1
553: } def
554: (ecart.syz ) messagen-quiet
555:
556: [(ecart.syz)
557: [(a ecart.syz b)
558: (array a; array b;)
559: $b : [syzygy gb tmat input]; gb = tmat * input $
560: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.8 takayama 561: $ [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
1.1 takayama 562: $ ff 0 get ff 3 get mul pmat $
563: $ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $
564: ( )
1.9 takayama 565: (To set the current ring to the ring in which ff belongs )
566: ( ff getRing ring_def )
1.1 takayama 567: $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.8 takayama 568: $ [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $
1.1 takayama 569: ( )
570: (cf. ecart.gb)
571: ( /ecart.autoHomogenize 0 def )
572: ]] putUsages
1.2 takayama 573:
1.3 takayama 574:
575: /ecartn.begin {
576: (red@) (standard) switch_function
577: %% (red@) (ecart) switch_function
578: [(Ecart) 1] system_variable
579: [(CheckHomogenization) 0] system_variable
580: [(ReduceLowerTerms) 0] system_variable
581: [(AutoReduce) 0] system_variable
582: [(EcartAutomaticHomogenization) 0] system_variable
583: } def
584: /ecartn.gb {
585: /arg1 set
586: [/in-ecartn.gb /aa /typev /setarg /f /v
587: /gg /wv /vec /ans /rr /mm
588: /degreeShift /env2 /opt /ans.gb
589: ] pushVariables
590: [(CurrentRingp) (KanGBmessage)] pushEnv
591: [
592: /aa arg1 def
1.13 takayama 593: aa isArray { } { ( << array >> ecartn.gb) error } ifelse
1.3 takayama 594: /setarg 0 def
595: /wv 0 def
596: /degreeShift 0 def
597: /opt [(weightedHomogenization) 1] def
598: aa { tag } map /typev set
599: typev [ ArrayP ] eq
600: { /f aa 0 get def
601: /v gb.v def
602: /setarg 1 def
603: } { } ifelse
604: typev [ArrayP StringP] eq
605: { /f aa 0 get def
606: /v aa 1 get def
607: /setarg 1 def
608: } { } ifelse
609: typev [ArrayP RingP] eq
610: { /f aa 0 get def
611: /v aa 1 get def
612: /setarg 1 def
613: } { } ifelse
614: typev [ArrayP ArrayP] eq
615: { /f aa 0 get def
616: /v aa 1 get from_records def
617: /setarg 1 def
618: } { } ifelse
619: typev [ArrayP StringP ArrayP] eq
620: { /f aa 0 get def
621: /v aa 1 get def
622: /wv aa 2 get def
623: /setarg 1 def
624: } { } ifelse
625: typev [ArrayP ArrayP ArrayP] eq
626: { /f aa 0 get def
627: /v aa 1 get from_records def
628: /wv aa 2 get def
629: /setarg 1 def
630: } { } ifelse
1.15 takayama 631:
1.3 takayama 632: typev [ArrayP StringP ArrayP ArrayP] eq
633: { /f aa 0 get def
634: /v aa 1 get def
635: /wv aa 2 get def
1.15 takayama 636: opt aa 3 get ecart.setOpt join /opt set
1.3 takayama 637: /setarg 1 def
638: } { } ifelse
639: typev [ArrayP ArrayP ArrayP ArrayP] eq
640: { /f aa 0 get def
641: /v aa 1 get from_records def
642: /wv aa 2 get def
1.15 takayama 643: opt aa 3 get ecart.setOpt join /opt set
1.3 takayama 644: /setarg 1 def
645: } { } ifelse
646:
647: /env1 getOptions def
648:
649: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
650:
651: [(KanGBmessage) ecart.gb.verbose ] system_variable
652:
653: %%% Start of the preprocess
654: v tag RingP eq {
655: /rr v def
656: }{
657: f getRing /rr set
658: } ifelse
659: %% To the normal form : matrix expression.
660: f gb.toMatrixOfString /f set
661: /mm gb.itWasMatrix def
662:
663: rr tag 0 eq {
664: %% Define our own ring
665: v isInteger {
666: (Error in gb: Specify variables) error
667: } { } ifelse
668: wv isInteger {
669: [v ring_of_differential_operators
1.18 takayama 670: [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector
1.3 takayama 671: gb.characteristic
672: opt
673: ] define_ring
674: }{
675: degreeShift isInteger {
676: [v ring_of_differential_operators
1.18 takayama 677: [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
1.3 takayama 678: gb.characteristic
679: opt
680: ] define_ring
681:
682: }{
683: [v ring_of_differential_operators
1.18 takayama 684: [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector
1.3 takayama 685: gb.characteristic
686: [(degreeShift) degreeShift] opt join
687: ] define_ring
688:
689: } ifelse
690: } ifelse
691: } {
692: %% Use the ring structre given by the input.
693: v isInteger not {
694: gb.warning {
695: (Warning : the given ring definition is not used.) message
696: } { } ifelse
697: } { } ifelse
698: rr ring_def
699: /wv rr gb.getWeight def
700:
701: } ifelse
702: %%% Enf of the preprocess
703:
704: ecart.gb.verbose {
705: (The first and the second weight vectors are automatically set as follows)
706: message
707: v ecart.wv1 message
708: v ecart.wv2 message
709: degreeShift isInteger { }
710: {
711: (The degree shift is ) messagen
712: degreeShift message
713: } ifelse
714: } { } ifelse
715:
1.5 takayama 716: %%BUG: case of v is integer
717: v ecart.checkOrder
718:
1.3 takayama 719: ecartn.begin
720:
721: ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
722: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
723: ecart.autoHomogenize {
724: (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
725: message
726: } { } ifelse
727: ecart.autoHomogenize {
728: f { {. ecart.dehomogenize} map} map /f set
729: f ecart.homogenize01 /f set
730: }{
731: f { {. } map } map /f set
732: } ifelse
733: ecart.needSyz {
734: [f [(needSyz)] gb.options join ] groebner /gg set
735: } {
736: [f gb.options] groebner 0 get /gg set
737: } ifelse
738:
739: ecart.needSyz {
740: mm {
741: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
742: } { /ans.gb gg 0 get def } ifelse
743: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11 takayama 744: % ans pmat ;
1.3 takayama 745: } {
746: wv isInteger {
747: /ans [gg gg {init} map] def
748: }{
1.10 takayama 749: degreeShift isInteger {
750: /ans [gg gg {wv 0 get weightv init} map] def
751: } {
752: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
753: } ifelse
1.3 takayama 754: }ifelse
755:
756: %% Postprocess : recover the matrix expression.
757: mm {
758: ans { /tmp set [mm tmp] toVectors } map
759: /ans set
760: }{ }
761: ifelse
762: } ifelse
763:
764: ecart.end
765:
766: %%
767: env1 restoreOptions %% degreeShift changes "grade"
768:
769: /arg1 ans def
770: ] pop
771: popEnv
772: popVariables
773: arg1
774: } def
775: (ecartn.gb[gb by non-ecart division] ) messagen-quiet
1.4 takayama 776:
777: /ecartd.gb {
778: /arg1 set
779: [/in-ecart.gb /aa /typev /setarg /f /v
780: /gg /wv /vec /ans /rr /mm
781: /degreeShift /env2 /opt /ans.gb
1.11 takayama 782: /hdShift
1.16 takayama 783: /ecart.useSugar
1.4 takayama 784: ] pushVariables
785: [(CurrentRingp) (KanGBmessage)] pushEnv
786: [
787: /aa arg1 def
1.13 takayama 788: aa isArray { } { ( << array >> ecartd.gb) error } ifelse
1.4 takayama 789: /setarg 0 def
790: /wv 0 def
791: /degreeShift 0 def
1.11 takayama 792: /hdShift 0 def
1.16 takayama 793: /ecart.useSugar 0 def
1.4 takayama 794: /opt [(weightedHomogenization) 1] def
795: aa { tag } map /typev set
796: typev [ ArrayP ] eq
797: { /f aa 0 get def
798: /v gb.v def
799: /setarg 1 def
800: } { } ifelse
801: typev [ArrayP StringP] eq
802: { /f aa 0 get def
803: /v aa 1 get def
804: /setarg 1 def
805: } { } ifelse
806: typev [ArrayP RingP] eq
807: { /f aa 0 get def
808: /v aa 1 get def
809: /setarg 1 def
810: } { } ifelse
811: typev [ArrayP ArrayP] eq
812: { /f aa 0 get def
813: /v aa 1 get from_records def
814: /setarg 1 def
815: } { } ifelse
816: typev [ArrayP StringP ArrayP] eq
817: { /f aa 0 get def
818: /v aa 1 get def
819: /wv aa 2 get def
820: /setarg 1 def
821: } { } ifelse
822: typev [ArrayP ArrayP ArrayP] eq
823: { /f aa 0 get def
824: /v aa 1 get from_records def
825: /wv aa 2 get def
826: /setarg 1 def
827: } { } ifelse
1.15 takayama 828:
1.4 takayama 829: typev [ArrayP StringP ArrayP ArrayP] eq
830: { /f aa 0 get def
831: /v aa 1 get def
832: /wv aa 2 get def
1.15 takayama 833: opt aa 3 get ecart.setOpt join /opt set
1.4 takayama 834: /setarg 1 def
835: } { } ifelse
836: typev [ArrayP ArrayP ArrayP ArrayP] eq
837: { /f aa 0 get def
838: /v aa 1 get from_records def
839: /wv aa 2 get def
1.15 takayama 840: opt aa 3 get ecart.setOpt join /opt set
1.13 takayama 841: /setarg 1 def
842: } { } ifelse
1.4 takayama 843:
844: /env1 getOptions def
845:
846: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
847:
848: [(KanGBmessage) ecart.gb.verbose ] system_variable
1.22 ! takayama 849: $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ ecart.message
1.4 takayama 850:
851: %%% Start of the preprocess
852: v tag RingP eq {
853: /rr v def
854: }{
855: f getRing /rr set
856: } ifelse
857: %% To the normal form : matrix expression.
858: f gb.toMatrixOfString /f set
859: /mm gb.itWasMatrix def
860:
861: rr tag 0 eq {
862: %% Define our own ring
863: v isInteger {
864: (Error in gb: Specify variables) error
865: } { } ifelse
866: wv isInteger {
1.22 ! takayama 867: (Give a weight vector such that x < 1) error
1.4 takayama 868: }{
869: degreeShift isInteger {
870: [v ring_of_differential_operators
1.18 takayama 871: wv ecart.weight_vector
1.4 takayama 872: gb.characteristic
873: opt
874: ] define_ring
875:
876: }{
877: [v ring_of_differential_operators
1.18 takayama 878: wv ecart.weight_vector
1.4 takayama 879: gb.characteristic
880: [(degreeShift) degreeShift] opt join
881: ] define_ring
882:
883: } ifelse
884: } ifelse
885: } {
886: %% Use the ring structre given by the input.
887: v isInteger not {
888: gb.warning {
889: (Warning : the given ring definition is not used.) message
890: } { } ifelse
891: } { } ifelse
892: rr ring_def
893: /wv rr gb.getWeight def
894:
895: } ifelse
896: %%% Enf of the preprocess
897:
898: ecart.gb.verbose {
899: degreeShift isInteger { }
900: {
901: (The degree shift is ) messagen
902: degreeShift message
903: } ifelse
904: } { } ifelse
905:
1.5 takayama 906: %%BUG: case of v is integer
907: v ecart.checkOrder
908:
1.8 takayama 909: ecartd.begin
1.4 takayama 910:
1.22 ! takayama 911: ecart.gb.verbose { (gb.options = ) ecart.messagen gb.options ecart.message } { } ifelse
1.4 takayama 912:
1.11 takayama 913: hdShift tag 1 eq {
1.12 takayama 914: ecart.autoHomogenize not hdShift -1 eq or {
1.11 takayama 915: % No automatic h-homogenization.
916: f { {. } map} map /f set
917: } {
918: % Automatic h-homogenization without degreeShift
1.22 ! takayama 919: (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) ecart.message
1.11 takayama 920: f { {. ecart.dehomogenize} map} map /f set
921: f ecart.homogenize01 /f set
922: f { { [[(H). (1).]] replace } map } map /f set
923: } ifelse
924: } {
925: % Automatic h-homogenization with degreeShift
1.13 takayama 926: (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
1.11 takayama 927: f { {. ecart.dehomogenize} map} map /f set
928: f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
929: f { { [[(H). (1).]] replace } map } map /f set
930: }ifelse
1.4 takayama 931:
1.16 takayama 932: ecart.useSugar {
933: ecart.needSyz {
934: [f [(needSyz)] gb.options join ] groebner_sugar /gg set
935: } {
936: [f gb.options] groebner_sugar 0 get /gg set
937: } ifelse
938: } {
939: ecart.needSyz {
940: [f [(needSyz)] gb.options join ] groebner /gg set
941: } {
942: [f gb.options] groebner 0 get /gg set
943: } ifelse
1.4 takayama 944: } ifelse
945:
946: ecart.needSyz {
947: mm {
948: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
949: } { /ans.gb gg 0 get def } ifelse
950: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11 takayama 951: % ans pmat ;
1.4 takayama 952: } {
953: wv isInteger {
954: /ans [gg gg {init} map] def
955: }{
1.11 takayama 956: %% Get the initial ideal
1.10 takayama 957: degreeShift isInteger {
958: /ans [gg gg {wv 0 get weightv init} map] def
959: } {
960: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
961: } ifelse
1.4 takayama 962: }ifelse
963:
964: %% Postprocess : recover the matrix expression.
965: mm {
966: ans { /tmp set [mm tmp] toVectors } map
967: /ans set
968: }{ }
969: ifelse
970: } ifelse
971:
1.8 takayama 972: ecartd.end
1.4 takayama 973:
974: %%
975: env1 restoreOptions %% degreeShift changes "grade"
976:
977: /arg1 ans def
978: ] pop
979: popEnv
980: popVariables
981: arg1
982: } def
983: (ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
1.2 takayama 984:
1.5 takayama 985: /ecart.checkOrder {
986: /arg1 set
987: [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
988: [
989: /vv arg1 def
990: vv isArray
991: { } { [vv to_records pop] /vv set } ifelse
992: vv {toString} map /vv set
993: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
994: % Starting the checks.
995: 0 1 vv length 1 sub {
996: /i set
997: vv i get . dd i get . mul /tt set
998: tt @@@.hsymbol . add init tt eq { }
999: { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
1000: } for
1001:
1002: 0 1 vv length 1 sub {
1003: /i set
1004: vv i get . /tt set
1005: tt (1). add init (1). eq { }
1.6 takayama 1006: { [vv i get ( is larger than 1 ) ] cat error} ifelse
1.5 takayama 1007: } for
1008: /arg1 1 def
1009: ] pop
1010: popVariables
1011: arg1
1012: } def
1013: [(ecart.checkOrder)
1014: [(v ecart.checkOrder bool checks if the given order is relevant)
1015: (for the ecart division.)
1016: (cf. ecartd.gb, ecart.gb, ecartn.gb)
1017: ]
1018: ] putUsages
1019:
1020: /ecart.wv_last {
1021: /arg1 set
1022: [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
1023: [
1024: /vv arg1 def
1025: vv isArray
1026: { } { [vv to_records pop] /vv set } ifelse
1027: vv {toString} map /vv set
1028: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
1029: vv { -1 } map
1030: dd { 1 } map join /arg1 set
1031: ] pop
1032: popVariables
1033: arg1
1034: } def
1035: [(ecart.wv_last)
1036: [(v ecart.wv_last wt )
1037: (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
1038: (Use this weight vector as the last weight vector for ecart division)
1039: (if ecart.checkOrder complains about the order given.)
1040: ]
1041: ] putUsages
1.13 takayama 1042:
1043: /ecart.mimimalBase.test {
1044: [
1045: [ (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
1046: [ (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
1047: [ (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
1048: [ (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
1049: [ (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
1050: [ (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
1051: [ (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
1052: [ (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
1053: ]
1054: /ff set
1055:
1056: /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
1057: /shift [ [1 0 1 0 0] ] def
1058: /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
1059:
1.15 takayama 1060: [ff (t,x,y) weight [(degreeShift) shift (startingShift) nmshift]] ecart.minimalBase
1.13 takayama 1061:
1062:
1063: } def
1064: /test {ecart.mimimalBase.test} def
1065:
1066: %(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
1067: /ecart.minimalBase.D1 {
1068: /arg1 set
1069: [/in-ecart.minimalBase.D1 /tt /v] pushVariables
1070: [
1071: /v arg1 def
1072: [ v to_records pop] /v set
1073: v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
1074: v [(h) 1] join /arg1 set
1075: ] pop
1076: popVariables
1077: arg1
1078: } def
1079:
1080: % [0 1 2] 1 ecart.removeElem [0 2]
1081: /ecart.removeElem {
1082: /arg2 set
1083: /arg1 set
1084: [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
1085: [
1086: /v arg1 def
1087: /q arg2 def
1088: /ans v length 1 sub newVector def
1089: /j 0 def
1090: 0 1 v length 1 sub {
1091: /i set
1092: i q eq not {
1093: ans j v i get put
1094: /j j 1 add def
1095: } { } ifelse
1096: } for
1097: ] pop
1098: popVariables
1099: arg1
1100: } def
1101:
1.14 takayama 1102: /ecart.isZeroRow {
1103: /arg1 set
1104: [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables
1105: [
1106: /aa arg1 def
1107: aa length /n set
1108: /yes 1 def
1109: 0 1 n 1 sub {
1110: /i set
1111: aa i get (0). eq {
1112: } {
1113: /yes 0 def
1114: } ifelse
1115: } for
1116: /arg1 yes def
1117: ] pop
1118: popVariables
1119: arg1
1120: } def
1121:
1122: /ecart.removeZeroRow {
1123: /arg1 set
1124: [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables
1125: [
1126: /aa arg1 def
1127: aa length /n set
1128: /ans [ ] def
1129: 0 1 n 1 sub {
1130: /i set
1131: aa i get ecart.isZeroRow {
1132: } {
1133: ans aa i get append /ans set
1134: } ifelse
1135: } for
1136: /arg1 ans def
1137: ] pop
1138: popVariables
1139: arg1
1140: } def
1141:
1142: /ecart.gen_input {
1143: /arg1 set
1144: [/in-ecart.gen_input /aa /typev /setarg /f /v
1145: /gg /wv /vec /ans /rr /mm
1146: /degreeShift /env2 /opt /ss0
1147: /hdShift /ff
1148: ] pushVariables
1149: [
1150: /aa arg1 def
1151: aa isArray { } { ( << array >> ecart.gen_input) error } ifelse
1152: /setarg 0 def
1153: /wv 0 def
1154: /degreeShift 0 def
1155: /hdShift 0 def
1.15 takayama 1156: /opt [ ] def
1.14 takayama 1157: aa { tag } map /typev set
1.15 takayama 1158: typev [ArrayP StringP ArrayP ArrayP] eq
1.14 takayama 1159: { /f aa 0 get def
1160: /v aa 1 get def
1161: /wv aa 2 get def
1.15 takayama 1162: opt aa 3 get ecart.setOpt join /opt set
1.14 takayama 1163: /setarg 1 def
1164: } { } ifelse
1.15 takayama 1165: typev [ArrayP ArrayP ArrayP ArrayP] eq
1.14 takayama 1166: { /f aa 0 get def
1167: /v aa 1 get from_records def
1168: /wv aa 2 get def
1.15 takayama 1169: opt aa 3 get ecart.setOpt join /opt set
1.14 takayama 1170: /setarg 1 def
1171: } { } ifelse
1172: setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
1173:
1174: [(KanGBmessage) ecart.gb.verbose ] system_variable
1175:
1176: f 0 get tag ArrayP eq { }
1177: { f { /tt set [ tt ] } map /f set } ifelse
1178:
1.15 takayama 1179: [f v wv [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join]
1.14 takayama 1180: ecart.gb /ff set
1181: ff getRing ring_def
1182:
1183: ff 0 get { {toString } map } map /ff set
1184:
1.15 takayama 1185: [ff v wv
1186: [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join
1187: ] /arg1 set
1.14 takayama 1188: ] pop
1189: popVariables
1190: arg1
1191: } def
1192: [(ecart.gen_input)
1.18 takayama 1193: [$[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]] ] ecart.gen_input $
1194: $ [gg_h v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] $
1.14 takayama 1195: (It generates the input for the minimal filtered free resolution.)
1196: (Current ring is changed to the ring of gg_h.)
1197: (cf. ecart.minimalBase)
1198: $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
1199: $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
1.15 takayama 1200: $ [(degreeShift) [ [0] ] $
1201: $ (startingShift) [ [0] [0] ]] ] ecart.gen_input /gg set gg pmat $
1.14 takayama 1202: ]] putUsages
1203:
1204:
1.13 takayama 1205: [(ecart.minimalBase)
1.18 takayama 1206: [$[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalBase $
1.14 takayama 1207: ( [mbase gr_of_mbase )
1.18 takayama 1208: $ [syz v ecart.weight_vector [(degreeShift) new_uv_shift_m (startingShift) [new_D_shift_n new_uv_shift_m]]]$
1.14 takayama 1209: ( gr_of_syz ])
1210: (mbase is the minimal generators of ff in D^h in the sense of filtered minimal)
1211: (generators.)
1212: $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
1213: $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
1.15 takayama 1214: $ [(degreeShift) [ [0] ] $
1215: $ (startingShift) [ [0] [0] ] ] ] ecart.gen_input /gg0 set $
1.14 takayama 1216: $ gg0 ecart.minimalBase /ss0 set $
1217: $ ss0 2 get ecart.minimalBase /ss1 set $
1218: $ ss1 2 get ecart.minimalBase /ss2 set $
1219: $ (--------- minimal filtered resolution -------) message $
1220: $ ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat $
1221: $ (--------- degree shift (n,m) n:D-shift m:uv-shift -------) message $
1.15 takayama 1222: $ gg0 3 get 3 get message $
1223: $ ss0 2 get 3 get 3 get message $
1224: $ ss1 2 get 3 get 3 get message $
1225: $ ss2 2 get 3 get 3 get message ; $
1.14 takayama 1226:
1.13 takayama 1227: ]] putUsages
1228: /ecart.minimalBase {
1229: /arg1 set
1230: [/in-ecart.minimalBase /ai1 /ai /aa /typev /setarg /f /v
1231: /gg /wv /vec /ans /rr /mm
1232: /degreeShift /env2 /opt /ss0
1233: /hdShift
1234: /degreeShiftD /degreeShiftUV
1235: /degreeShiftDnew /degreeShiftUVnew
1236: /tt
1237: /ai1_gr /ai_gr
1238: /s /r /p /q /i /j /k
1239: /ai1_new /ai_new /ai_new2
1240: ] pushVariables
1241: [
1242: /aa arg1 def
1243: aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
1244: /setarg 0 def
1245: /wv 0 def
1246: /degreeShift 0 def
1247: /hdShift 0 def
1.15 takayama 1248: /opt [ ] def
1.13 takayama 1249: aa { tag } map /typev set
1.15 takayama 1250: typev [ArrayP StringP ArrayP ArrayP] eq
1.13 takayama 1251: { /f aa 0 get def
1252: /v aa 1 get def
1253: /wv aa 2 get def
1.15 takayama 1254: opt aa 3 get ecart.setOpt join /opt set
1.13 takayama 1255: /setarg 1 def
1256: } { } ifelse
1.15 takayama 1257: typev [ArrayP ArrayP ArrayP ArrayP] eq
1.13 takayama 1258: { /f aa 0 get def
1259: /v aa 1 get from_records def
1260: /wv aa 2 get def
1.15 takayama 1261: opt aa 3 get ecart.setOpt join /opt set
1.13 takayama 1262: /setarg 1 def
1263: } { } ifelse
1264: setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
1265:
1266: [(KanGBmessage) ecart.gb.verbose ] system_variable
1267:
1268: f 0 get tag ArrayP eq { }
1269: { f { /tt set [ tt ] } map /f set } ifelse
1.15 takayama 1270: [f v wv [(degreeShift) degreeShift (noAutoHomogenize) 1] opt join] ecart.syz /ss0 set
1.13 takayama 1271:
1272: ss0 getRing ring_def
1273: /degreeShiftD hdShift 0 get def
1274: /degreeShiftUV hdShift 1 get def
1275: % -- ai --> D^r -- ai1 --> D^rr
1276: /ai1 f { { . } map } map def
1277: /ai ss0 0 get def
1278:
1279: {
1280: /degreeShiftUVnew
1281: ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all } map
1282: def
1283: (degreeShiftUVnew=) messagen degreeShiftUVnew message
1284:
1285: /degreeShiftDnew
1286: ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ] ord_ws_all}
1287: map
1288: def
1289: (degreeShiftDnew=) messagen degreeShiftDnew message
1290:
1291: ai {[wv 0 get weightv degreeShiftUVnew] init} map /ai_gr set
1292:
1293: %C Note 2003.8.26
1294:
1.14 takayama 1295: ai [ ] eq {
1296: exit
1297: } { } ifelse
1298:
1.13 takayama 1299: /s ai length def
1300: /r ai 0 get length def
1301:
1302: /itIsMinimal 1 def
1303: 0 1 s 1 sub {
1304: /i set
1305: 0 1 r 1 sub {
1306: /j set
1307:
1308: [(isConstantAll) ai_gr i get j get] gbext
1309: ai_gr i get j get (0). eq not and
1310: {
1311: /itIsMinimal 0 def
1312: /p i def /q j def
1313: } { } ifelse
1314: } for
1315: } for
1316:
1317:
1318: itIsMinimal { exit } { } ifelse
1319:
1320: % construct new ai and ai1 (A_i and A_{i-1})
1321: /ai1_new r 1 sub newVector def
1322: /j 0 def
1323: 0 1 r 1 sub {
1324: /i set
1325: i q eq not {
1326: ai1_new j ai1 i get put
1327: /j j 1 add def
1328: } { } ifelse
1329: } for
1330:
1331: /ai_new [s r] newMatrix def
1332: 0 1 s 1 sub {
1333: /j set
1334: 0 1 r 1 sub {
1335: /k set
1336: ai_new [j k]
1337: << ai p get q get >> << ai j get k get >> mul
1338: << ai j get q get >> << ai p get k get >> mul
1339: sub
1340: put
1341: } for
1342: } for
1343:
1344: % remove 0 column
1345: /ai_new2 [s 1 sub r 1 sub] newMatrix def
1346: /j 0 def
1347: 0 1 s 1 sub {
1348: /i set
1349: i p eq not {
1350: ai_new2 j << ai_new i get q ecart.removeElem >> put
1351: /j j 1 add def
1352: } { } ifelse
1353: } for
1354:
1355: % ( ) error
1.14 takayama 1356: /ai1 ai1_new def
1357: /ai ai_new2 ecart.removeZeroRow def
1.13 takayama 1358:
1359: } loop
1.14 takayama 1360: /arg1
1361: [ ai1
1362: ai1 {[wv 0 get weightv degreeShift 0 get] init} map %Getting gr of A_{i-1}
1.15 takayama 1363: [ai v wv [(degreeShift) [degreeShiftUVnew] (startingShift) [degreeShiftDnew degreeShiftUVnew]]]
1.14 takayama 1364: ai {[wv 0 get weightv degreeShiftUVnew] init} map %Getting gr of A_i
1365: ]
1366: def
1.13 takayama 1367: ] pop
1368: popVariables
1369: arg1
1370: } def
1371:
1.15 takayama 1372: /ecart.minimalResol {
1373: /arg1 set
1374: [/in-ecart.minimalResol /aa /ans /gg0 /ansds /ans_gr /c] pushVariables
1375: [
1376: /aa arg1 def
1377: /ans [ ] def
1378: /ansds [ ] def
1379: /ans_gr [ ] def
1380: /c 0 def
1381:
1382: (---- ecart.gen_input ----) message
1383: aa ecart.gen_input /gg0 set
1384: ansds gg0 3 get 3 get append /ansds set
1385: (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set
1386: gg0 ecart.minimalBase /ssi set
1387: ansds ssi 2 get 3 get 3 get append /ansds set
1388: ans ssi 0 get append /ans set
1389: ans_gr ssi 1 get append /ans_gr set
1390: {
1391: ssi 3 get [ ] eq { exit } { } ifelse
1392: (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set
1393: ssi 2 get ecart.minimalBase /ssi_new set
1394: ans ssi_new 0 get append /ans set
1395: ansds ssi_new 2 get 3 get 3 get append /ansds set
1396: ans_gr ssi_new 1 get append /ans_gr set
1397: /ssi ssi_new def
1398: } loop
1399: /arg1 [ans ansds ans_gr] def
1400: ] pop
1401: popVariables
1402: arg1
1403: } def
1404:
1405: (ecart.minimalResol) message
1406:
1407: [(ecart.minimalResol)
1408: [
1409:
1.18 takayama 1410: $[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalResol $
1.15 takayama 1411: ( [resol degree_shifts gr_of_resol_by_uv_shift_m] )
1412: $Example1: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
1413: $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
1414: $ [(degreeShift) [ [0] ] $
1415: $ (startingShift) [ [0] [0] ] ] ] ecart.minimalResol /gg set gg pmat $
1416: ]] putUsages
1.18 takayama 1417:
1418: %% for ecart.weight_vector
1419: /ecart.eliminationOrderTemplate { %% esize >= 1
1420: %% if esize == 0, it returns reverse lexicographic order.
1421: %% m esize eliminationOrderTemplate mat
1422: /arg2 set /arg1 set
1423: [/m /esize /m1 /m2 /k /om /omtmp] pushVariables
1424: [
1425: /m arg1 def /esize arg2 def
1426: /m1 m esize sub 1 sub def
1427: /m2 esize 1 sub def
1428: [esize 0 gt
1429: {
1430: [1 1 esize
1431: { pop 1 } for
1432: esize 1 << m 1 sub >>
1433: { pop 0 } for
1434: ] %% 1st vector
1435: }
1436: { } ifelse
1437:
1438: m esize gt
1439: {
1440: [1 1 esize
1441: { pop 0 } for
1442: esize 1 << m 1 sub >>
1443: { pop 1 } for
1444: ] %% 2nd vector
1445: }
1446: { } ifelse
1447:
1448: m1 0 gt
1449: {
1450: m 1 sub -1 << m m1 sub >>
1451: {
1452: /k set
1453: m k evec_neg
1454: } for
1455: }
1456: { } ifelse
1457:
1458: m2 0 gt
1459: {
1460: << esize 1 sub >> -1 1
1461: {
1462: /k set
1463: m k evec_neg
1464: } for
1465: }
1466: { } ifelse
1467:
1468: ] /om set
1469: om [ 0 << m 2 idiv >> 1 sub] 0 put
1470: om [ << m 2 idiv >> 1 add << m 2 idiv >> 1 sub] 0 put
1471: /arg1 om def
1472: ] pop
1473: popVariables
1474: arg1
1475: } def
1476:
1477: %note 2003.09.29
1478: /ecart.elimination_order {
1479: %% [x-list d-list params] (x,y,z) elimination_order
1480: %% vars evars
1481: %% [x-list d-list params order]
1482: /arg2 set /arg1 set
1483: [/vars /evars /univ /order /perm /univ0 /compl /m /omtmp] pushVariables
1484: /vars arg1 def /evars [arg2 to_records pop] def
1485: [
1486: /univ vars 0 get reverse
1487: vars 1 get reverse join
1488: def
1489:
1490: << univ length 2 sub >>
1491: << evars length >>
1492: ecart.eliminationOrderTemplate /order set
1493:
1494: [[1]] order oplus [[1]] oplus /order set
1495:
1496: /m order length 2 sub def
1497: /omtmp [1 1 m 2 add { pop 0 } for ] def
1498: omtmp << m 2 idiv >> 1 put
1499: order omtmp append /order set
1500: % order pmat
1501:
1502: /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h]
1503:
1504: /compl
1505: [univ 0 get] evars join evars univ0 complement join
1506: def
1507: compl univ
1508: getPerm /perm set
1509: %%perm :: univ :: compl ::
1510:
1511: order perm permuteOrderMatrix /order set
1512:
1513:
1514: vars [order] join /arg1 set
1515: ] pop
1516: popVariables
1517: arg1
1518: } def
1519:
1520: /ecart.define_ring {
1521: /arg1 set
1522: [/rp /param /foo] pushVariables
1523: [/rp arg1 def
1524:
1525: rp 0 get length 3 eq {
1526: rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ]
1527: ( ) ecart.elimination_order put
1528: } { } ifelse
1529:
1530: [
1531: rp 0 get 0 get %% x-list
1532: rp 0 get 1 get %% d-list
1533: rp 0 get 2 get /param set
1534: param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example.
1535: param %% parameters.
1536: rp 0 get 3 get %% order matrix.
1537: rp length 2 eq
1538: { [ ] } %% null optional argument.
1539: { rp 2 get }
1540: ifelse
1541: ] /foo set
1542: foo aload pop set_up_ring@
1543: ] pop
1544: popVariables
1545: [(CurrentRingp)] system_variable
1546: } def
1547: /ecart.weight_vector {
1548: /arg2 set /arg1 set
1549: [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables
1550: /vars arg1 def /w-vectors arg2 def
1551: [
1552: /univ vars 0 get reverse
1553: vars 1 get reverse join
1554: def
1555: [
1556: 0 1 << w-vectors length 1 sub >>
1557: {
1558: /k set
1559: univ w-vectors k get w_to_vec
1560: } for
1561: ] /order1 set
1562: %% order1 ::
1563:
1564: vars ( ) ecart.elimination_order 3 get /order2 set
1565: vars [ << order1 order2 join >> ] join /arg1 set
1566: ] pop
1567: popVariables
1568: arg1
1569: } def
1570:
1571: %% end of for ecart.define_ring
1.19 takayama 1572:
1573: /ecartd.reduction {
1574: /arg2 set
1575: /arg1 set
1576: [/in-ecartd.reduction /gbasis /flist /ans /gbasis2] pushVariables
1577: [(CurrentRingp) (KanGBmessage)] pushEnv
1578: [
1579: /gbasis arg2 def
1580: /flist arg1 def
1581: gbasis 0 get tag 6 eq { }
1582: { (ecartd.reduction: the second argument must be a list of lists) error }
1583: ifelse
1584:
1585: gbasis length 1 eq {
1586: gbasis getRing ring_def
1587: /gbasis2 gbasis 0 get def
1588: } {
1589: [ [(1)] ] gbasis rest join ecartd.gb 0 get getRing ring_def
1590: /gbasis2 gbasis 0 get ,,, def
1591: } ifelse
1592: ecartd.begin
1593:
1594: flist ,,, /flist set
1595: flist tag 6 eq {
1596: flist { gbasis2 reduction } map /ans set
1597: }{
1598: flist gbasis2 reduction /ans set
1599: } ifelse
1600: /arg1 ans def
1601:
1602: ecartd.end
1603: ] pop
1604: popEnv
1605: popVariables
1606: arg1
1607: } def
1608:
1609: /ecartd.reduction.test {
1610: [
1611: [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
1612: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
1613: ecartd.gb /gg set
1614:
1615: (Dx) [gg 0 get] ecartd.reduction /gg2 set
1616: gg2 message
1617: (-----------------------------) message
1618:
1619: [(Dx) (Dy) (Dx+x*Dy)] [gg 0 get] ecartd.reduction /gg3 set
1620: gg3 message
1621:
1622: (-----------------------------) message
1623: [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )]
1624: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
1625: (Dx) ggg ecartd.reduction /gg4 set
1626: gg4 message
1627: [gg2 gg3 gg4]
1628: } def
1629:
1630: /ecarth.reduction {
1631: /arg2 set
1632: /arg1 set
1633: [/in-ecarth.reduction /gbasis /flist /ans /gbasis2] pushVariables
1634: [(CurrentRingp) (KanGBmessage)] pushEnv
1635: [
1636: /gbasis arg2 def
1637: /flist arg1 def
1638: gbasis 0 get tag 6 eq { }
1639: { (ecarth.reduction: the second argument must be a list of lists) error }
1640: ifelse
1641:
1642: gbasis length 1 eq {
1643: gbasis getRing ring_def
1644: /gbasis2 gbasis 0 get def
1645: } {
1646: [ [(1)] ] gbasis rest join ecarth.gb 0 get getRing ring_def
1647: /gbasis2 gbasis 0 get ,,, def
1648: } ifelse
1649: ecarth.begin
1650:
1651: flist ,,, /flist set
1652: flist tag 6 eq {
1653: flist { gbasis2 reduction } map /ans set
1654: }{
1655: flist gbasis2 reduction /ans set
1656: } ifelse
1657: /arg1 ans def
1658:
1659: ecarth.end
1660: ] pop
1661: popEnv
1662: popVariables
1663: arg1
1664: } def
1665:
1666: [(ecartd.reduction)
1667: [ (f basis ecartd.reduction r)
1668: (f is reduced by basis by the tangent cone algorithm.)
1.20 takayama 1669: (The first element of basis <g_1,...,g_m> must be a standard basis.)
1.19 takayama 1670: (r is the return value format of reduction.)
1.20 takayama 1671: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1672: (basis is given in the argument format of ecartd.gb.)
1.21 takayama 1673: $h[0,1](D)-homogenization is used.$
1.19 takayama 1674: (cf. reduction, ecartd.gb, ecartd.reduction.test )
1675: $Example:$
1676: $ [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] $
1677: $ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
1678: $ (Dx+Dy) ggg ecartd.reduction :: $
1679: ]] putUsages
1.22 ! takayama 1680:
! 1681: /ecart.stdOrder {
! 1682: /arg1 set
! 1683: [/in-ecart.stdOrder /vv /tt /dvv /wv1 /wv2
! 1684: ] pushVariables
! 1685: [
! 1686: /vv arg1 def
! 1687: vv isString { [ vv to_records pop] /vv set }
! 1688: { } ifelse
! 1689: vv { toString} map /vv set
! 1690:
! 1691: vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set
! 1692: dvv { 1 } map /wv1 set
! 1693: vv { -1 } map dvv { 1 } map join /wv2 set
! 1694: /arg1 [wv1 wv2 ] def
! 1695: ] popVariables
! 1696: arg1
! 1697: } def
! 1698:
! 1699: /ecartd.isSameIdeal_h {
! 1700: /arg1 set
! 1701: [/in-ecartd.isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
! 1702: /ecartd.isSameIdeal_h.opt
! 1703: /save-ecart.autoHomogenize /wv /save-ecart.message.quiet
! 1704: ] pushVariables
! 1705: [(CurrentRingp) (Homogenize_vec)] pushEnv
! 1706: [
! 1707: /aa arg1 def
! 1708: gb.verbose { (Getting in ecartd.isSameIdeal_h) message } { } ifelse
! 1709: %% comparison of hilbert series has not yet been implemented.
! 1710: /save-ecart.message.quiet ecart.message.quiet def
! 1711: aa length 3 eq { }
! 1712: { ([ii jj vv] ecartd.isSameIdeal_h) error } ifelse
! 1713: /ii aa 0 get def
! 1714: /jj aa 1 get def
! 1715: /vv aa 2 get def
! 1716: ii length 0 eq jj length 0 eq and
! 1717: { /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse
! 1718:
! 1719: vv ecart.stdOrder /wv set
! 1720:
! 1721: /save-ecart.autoHomogenize ecart.autoHomogenize def
! 1722: /ecart.autoHomogenize 0 def
! 1723: [ii vv wv] ecartd.gb /iigg set
! 1724: [jj vv wv] ecartd.gb /jjgg set
! 1725: save-ecart.autoHomogenize /ecart.autoHomogenize set
! 1726:
! 1727: iigg getRing ring_def
! 1728:
! 1729: getOptions /ecartd.isSameIdeal_h.opt set
! 1730:
! 1731: /ans 1 def
! 1732: iigg 0 get /iigg set
! 1733: jjgg 0 get /jjgg set
! 1734: %%Bug: not implemented for the case of module.
! 1735:
! 1736: /save-ecart.message.quiet ecart.message.quiet def
! 1737: /ecart.message.quiet 1 def
! 1738: gb.verbose { (Comparing) message iigg message (and) message jjgg message }
! 1739: { } ifelse
! 1740: gb.verbose { ( ii < jj ?) messagen } { } ifelse
! 1741: iigg length /n set
! 1742: 0 1 n 1 sub {
! 1743: /k set
! 1744: iigg k get
! 1745: [jjgg vv wv] ecartd.reduction 0 get
! 1746: (0). eq not { /ans 0 def /LLL.ecartd.isSame_h goto} { } ifelse
! 1747: gb.verbose { (o) messagen } { } ifelse
! 1748: } for
! 1749: gb.verbose { ( jj < ii ?) messagen } { } ifelse
! 1750: jjgg length /n set
! 1751: 0 1 n 1 sub {
! 1752: /k set
! 1753: jjgg k get
! 1754: [iigg vv wv] ecartd.reduction 0 get
! 1755: (0). eq not { /ans 0 def /LLL.ecartd.isSame_h goto} { } ifelse
! 1756: gb.verbose { (o) messagen } { } ifelse
! 1757: } for
! 1758: /LLL.ecartd.isSame_h
! 1759: gb.verbose { ( Done) message } { } ifelse
! 1760: save-ecart.message.quiet /ecart.message.quiet set
! 1761: ecartd.isSameIdeal_h.opt restoreOptions
! 1762: /arg1 ans def
! 1763: ] pop
! 1764: popEnv
! 1765: popVariables
! 1766: arg1
! 1767: } def
! 1768: (ecartd.isSameIdeal_h ) messagen-quiet
! 1769:
! 1770: [(ecartd.isSameIdeal_h)
! 1771: [([ii jj vv] ecartd.isSameIdeal_h bool)
! 1772: (ii, jj : ideal, vv : variables)
! 1773: $The ideals ii and jj will be compared in the ring h[0,1](D).$
! 1774: $ii and jj are re-parsed.$
! 1775: $Example 1: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $
! 1776: ]] putUsages
! 1777:
1.18 takayama 1778:
1.5 takayama 1779:
1.2 takayama 1780: ( ) message-quiet
1.5 takayama 1781:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to ecart.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc