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