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