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