=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v retrieving revision 1.2 retrieving revision 1.17 diff -u -p -r1.2 -r1.17 --- OpenXM/src/kan96xx/Doc/ecart.sm1 2003/07/25 01:03:00 1.2 +++ OpenXM/src/kan96xx/Doc/ecart.sm1 2003/09/20 22:10:04 1.17 @@ -1,4 +1,4 @@ -% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.1 2003/07/25 01:00:38 takayama Exp $ +% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.16 2003/09/12 02:52:49 takayama Exp $ %[(parse) (hol.sm1) pushfile] extension %[(parse) (appell.sm1) pushfile] extension @@ -7,7 +7,68 @@ /ecart.end { endEcart } def /ecart.autoHomogenize 1 def /ecart.needSyz 0 def +/ecartd.begin { + ecart.begin + [(EcartAutomaticHomogenization) 1] system_variable +} def +/ecartd.end { + ecart.end + [(EcartAutomaticHomogenization) 0] system_variable +} def +/ecart.setOpt { + /arg1 set + [/in-ecart.setOpt /opt /i /n /ans] pushVariables + [ + /opt arg1 def + /ans [ ] def + /n opt length def + 0 2 n 1 sub { + /i set + opt i get tag StringP eq not { + (ecart.setOpt : [keyword value keyword value ....] ) error + } { } ifelse + { % start of the loop +% Global: degreeShift + opt i get (degreeShift) eq { + /degreeShift opt i 1 add get def + exit + } { } ifelse +% Global: hdShift + opt i get (startingShift) eq { + /hdShift opt i 1 add get def + exit + } { } ifelse +% Global: hdShift + opt i get (noAutoHomogenize) eq { + /hdShift -1 def + exit + } { } ifelse +% Global: ecart.useSugar + opt i get (sugar) eq { + /ecart.useSugar opt i 1 add get def + exit + } { } ifelse + + ans [opt i get opt i 1 add get ] append /ans set + exit + } loop + } for + + ecart.gb.verbose { + (ecart.setOpt:) message + (degreeShift=) messagen degreeShift message + $hdShift(startingShift)=$ messagen hdShift message + (sugar=) messagen ecart.useSugar message + (Other options=) messagen ans message + } { } ifelse + + /arg1 ans def + ] pop + popVariables + arg1 +} def + /ecart.dehomogenize { /arg1 set [/in.ecart.dehomogenize /ll /rr] pushVariables @@ -61,11 +122,18 @@ /ecart.homogenize01 { /arg1 set - [/in.ecart.homogenize01 /ll ] pushVariables + [/in.ecart.homogenize01 /ll /ll0] pushVariables [ /ll arg1 def - [(degreeShift) [ ] ll ] homogenize - /arg1 set + ll tag ArrayP eq { + ll 0 get tag ArrayP eq not { + [(degreeShift) [ ] ll ] homogenize /arg1 set + } { + ll { ecart.homogenize01 } map /arg1 set + } ifelse + } { + [(degreeShift) [ ] ll ] homogenize /arg1 set + } ifelse ] pop popVariables arg1 @@ -80,30 +148,38 @@ ( [(x1) -1 (x2) -1]) ( ] weight_vector ) ( 0 ) - ( [(degreeShift) [[0 0 0]]]) + ( [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]]) ( ] define_ring) ( ecart.begin) ( [[1 -4 -2 5]] appell4 0 get /eqs set) ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map ) - ( ecart.homogenize01 /eqs2 set) + ( {ecart.homogenize01} map /eqs2 set) ( [eqs2] groebner ) ]] putUsages /ecart.homogenize01_with_shiftVector { /arg2.set /arg1 set - [/in.ecart.homogenize01 /ll /sv] pushVariables + [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables [ /sv arg2 def /ll arg1 def - [(degreeShift) sv ll ] homogenize - /arg1 set + ll tag ArrayP eq { + ll 0 get tag ArrayP eq not { + [(degreeShift) sv ll ] homogenize /arg1 set + } { + ll { ecart.homogenize01_with_shiftVector } map /arg1 set + } ifelse + } { + [(degreeShift) sv ll ] homogenize /arg1 set + } ifelse ] pop popVariables arg1 } def [(ecart.dehomogenize01_with_degreeShift) [(obj shift-vector ecart.dehomogenize01_with_degreeShift r) + (cf. homogenize) ]] putUsages %% Aux functions to return the default weight vectors. @@ -133,21 +209,80 @@ arg1 } def +/ecart.gb {ecartd.gb} def + +[(ecart.gb) + [(a ecart.gb b) + (array a; array b;) + $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$ + ( in the ring of differential operators.) + (The computation is done by using Ecart division algorithm and ) + (the double homogenization.) + (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003) + $ ii is the initial ideal in case of w is given or <> belongs$ + $ to a ring. In the other cases, it returns the initial monominal.$ + (a : [f ]; array f; f is a set of generators of an ideal in a ring.) + (a : [f v]; array f; string v; v is the variables. ) + (a : [f v w]; array f; string v; array of array w; w is the weight matirx.) + $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$ + ( array ds; ds is the degree shift for the ring. ) + $a : [f v w [(degreeShift) ds (startingShift) hdShift]]; array f; string v; array of array w; w is the weight matirx.$ + ( array ds; ds is the degree shift for the ring. ) + ( array hsShift is the degree shift for the homogenization. cf.homogenize ) + $a : [f v w [(degreeShift) ds (noAutoHomogenize) 1]]; array f; string v; array of array w; w is the weight matirx.$ + ( No automatic homogenization.) + $ [(degreeShift) ds (noAutoHomogenize) 1 (sugar) 1] -->use the sugar strate $ + ( ) + $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize) $ + ( ) + $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ + $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $ + (Example 2: ) + $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $ + $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /ff set ff pmat ;$ + (To set the current ring to the ring in which ff belongs ) + ( ff getRing ring_def ) + ( ) + $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ + $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $ + ( This example will cause an error on order.) + ( ) + $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $ + $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $ + ( This example will cause an error on order.) + ( ) + $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $ + $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $ + $ [(degreeShift) [[0 1] [-3 1]]] ] ecart.gb pmat ; $ + ( ) + (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, ) + ( ecart.dehomogenize, ecart.dehomogenizeH) + ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for ) + ( define_ring ) + (/ecart.autoHomogenize 0 def ) + ( not to dehomogenize and homogenize) +]] putUsages + /ecart.gb.verbose 1 def -/ecart.gb { +%ecarth.gb s(H)-homogenized outputs. GG's original version of ecart gb. +/ecarth.gb { /arg1 set - [/in-ecart.gb /aa /typev /setarg /f /v + [/in-ecarth.gb /aa /typev /setarg /f /v /gg /wv /vec /ans /rr /mm /degreeShift /env2 /opt /ans.gb + /hdShift + /ecart.useSugar ] pushVariables [(CurrentRingp) (KanGBmessage)] pushEnv [ /aa arg1 def - aa isArray { } { ( << array >> gb) error } ifelse + aa isArray { } { ( << array >> ecarth.gb) error } ifelse /setarg 0 def /wv 0 def /degreeShift 0 def + /hdShift 0 def /opt [(weightedHomogenization) 1] def + /ecart.useSugar 0 def aa { tag } map /typev set typev [ ArrayP ] eq { /f aa 0 get def @@ -181,24 +316,26 @@ /wv aa 2 get def /setarg 1 def } { } ifelse + typev [ArrayP StringP ArrayP ArrayP] eq { /f aa 0 get def /v aa 1 get def /wv aa 2 get def - /degreeShift aa 3 get def + opt aa 3 get ecart.setOpt join /opt set /setarg 1 def } { } ifelse typev [ArrayP ArrayP ArrayP ArrayP] eq { /f aa 0 get def /v aa 1 get from_records def /wv aa 2 get def - /degreeShift aa 3 get def + opt aa 3 get ecart.setOpt join /opt set /setarg 1 def } { } ifelse /env1 getOptions def - setarg { } { (ecart.gb : Argument mismatch) error } ifelse + ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } { } ifelse + setarg { } { (ecarth.gb : Argument mismatch) error } ifelse [(KanGBmessage) ecart.gb.verbose ] system_variable @@ -219,22 +356,24 @@ } { } ifelse wv isInteger { [v ring_of_differential_operators - [ v ecart.wv1 v ecart.wv2 ] weight_vector - 0 +% [ v ecart.wv1 v ecart.wv2 ] weight_vector + gb.characteristic opt ] define_ring }{ degreeShift isInteger { [v ring_of_differential_operators - [v ecart.wv1 v ecart.wv2] wv join weight_vector - 0 +% [v ecart.wv1 v ecart.wv2] wv join weight_vector + wv weight_vector + gb.characteristic opt ] define_ring }{ [v ring_of_differential_operators - [v ecart.wv1 v ecart.wv2] wv join weight_vector - 0 +% [v ecart.wv1 v ecart.wv2] wv join weight_vector + wv weight_vector + gb.characteristic [(degreeShift) degreeShift] opt join ] define_ring @@ -254,7 +393,7 @@ %%% Enf of the preprocess ecart.gb.verbose { - (The first and the second weight vectors are automatically set as follows) + (The first and the second weight vectors for automatic homogenization: ) message v ecart.wv1 message v ecart.wv2 message @@ -265,36 +404,62 @@ } ifelse } { } ifelse + %%BUG: case of v is integer + v ecart.checkOrder + ecart.begin ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse - ecart.autoHomogenize { - (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.) + + + hdShift tag 1 eq { + ecart.autoHomogenize not hdShift -1 eq or { +% No automatic h-s-homogenization. + f { {. } map} map /f set + } { +% Automatic h-s-homogenization without degreeShift + (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.) message - } { } ifelse - ecart.autoHomogenize { - f { {. ecart.dehomogenize} map} map /f set - f ecart.homogenize01 /f set - }{ - f { {. } map } map /f set + f { {. ecart.dehomogenize} map} map /f set + f ecart.homogenize01 /f set + } ifelse + } { +% Automatic h-s-homogenization with degreeShift + (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.) + message + f { {. ecart.dehomogenize} map} map /f set + f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set + }ifelse + + ecart.useSugar { + ecart.needSyz { + [f [(needSyz)] gb.options join ] groebner_sugar /gg set + } { + [f gb.options] groebner_sugar 0 get /gg set + } ifelse + } { + ecart.needSyz { + [f [(needSyz)] gb.options join ] groebner /gg set + } { + [f gb.options] groebner 0 get /gg set + } ifelse } ifelse - ecart.needSyz { - [f [(needSyz)] gb.options join ] groebner /gg set - } { - [f gb.options] groebner 0 get /gg set - } ifelse ecart.needSyz { mm { gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set - } { /ans.gb gg 0 get def } ifelse - /ans [gg 2 get , ans.gb , gg 1 get , f ] def - ans pmat ; + } { /ans.gb gg 0 get def } ifelse + /ans [gg 2 get , ans.gb , gg 1 get , f ] def +% ans pmat ; } { wv isInteger { /ans [gg gg {init} map] def }{ - /ans [gg gg {wv 0 get weightv init} map] def + degreeShift isInteger { + /ans [gg gg {wv 0 get weightv init} map] def + } { + /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def + } ifelse }ifelse %% Postprocess : recover the matrix expression. @@ -316,50 +481,51 @@ popVariables arg1 } def -(ecart.gb ) messagen-quiet +(ecarth.gb ) messagen-quiet -[(ecart.gb) - [(a ecart.gb b) +[(ecarth.gb) + [(a ecarth.gb b) (array a; array b;) $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$ ( in the ring of differential operators.) - (The computation is done by using Ecart division algorithm and ) - (the double homogenization.) + (The computation is done by using Ecart division algorithm.) + $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$ + (they are not dehomogenized.) (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003) $ ii is the initial ideal in case of w is given or <> belongs$ $ to a ring. In the other cases, it returns the initial monominal.$ (a : [f ]; array f; f is a set of generators of an ideal in a ring.) (a : [f v]; array f; string v; v is the variables. ) (a : [f v w]; array f; string v; array of array w; w is the weight matirx.) - (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.) + $a : [f v w [(degreeShift) ds]]; array f; string v; array of array w; w is the weight matirx.$ ( array ds; ds is the degree shift ) ( ) (/ecart.autoHomogenize 0 def ) ( not to dehomogenize and homogenize) ( ) $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ - $ [ [ (Dx) 1 ] ] ] ecart.gb pmat ; $ + $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $ (Example 2: ) (To put H and h=1, type in, e.g., ) $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $ - $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /gg set gg ecart.dehomogenize pmat ;$ + $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$ ( ) $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ - $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $ + $ [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $ ( ) $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $ - $ [ [ (x) -1 (y) -1] ] ] ecart.gb pmat ; $ + $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $ ( ) $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $ - $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.gb pmat ; $ + $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $ + $ [(degreeShift) [[0 1] [-3 1] ]] ] ecarth.gb pmat ; $ ( ) - (cf. gb, groebner, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, ) + (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, ) ( ecart.dehomogenize, ecart.dehomogenizeH) ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for ) ( define_ring ) ]] putUsages -%% BUG: " f weight init " works well in case of vectors with degree shift ? /ecart.syz { /arg1 set @@ -382,16 +548,862 @@ (array a; array b;) $b : [syzygy gb tmat input]; gb = tmat * input $ $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ - $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.syz /ff set $ + $ [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $ $ ff 0 get ff 3 get mul pmat $ $ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $ ( ) + (To set the current ring to the ring in which ff belongs ) + ( ff getRing ring_def ) $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $ - $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $ + $ [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $ ( ) (cf. ecart.gb) ( /ecart.autoHomogenize 0 def ) ]] putUsages +/ecartn.begin { + (red@) (standard) switch_function +%% (red@) (ecart) switch_function + [(Ecart) 1] system_variable + [(CheckHomogenization) 0] system_variable + [(ReduceLowerTerms) 0] system_variable + [(AutoReduce) 0] system_variable + [(EcartAutomaticHomogenization) 0] system_variable +} def +/ecartn.gb { + /arg1 set + [/in-ecartn.gb /aa /typev /setarg /f /v + /gg /wv /vec /ans /rr /mm + /degreeShift /env2 /opt /ans.gb + ] pushVariables + [(CurrentRingp) (KanGBmessage)] pushEnv + [ + /aa arg1 def + aa isArray { } { ( << array >> ecartn.gb) error } ifelse + /setarg 0 def + /wv 0 def + /degreeShift 0 def + /opt [(weightedHomogenization) 1] def + aa { tag } map /typev set + typev [ ArrayP ] eq + { /f aa 0 get def + /v gb.v def + /setarg 1 def + } { } ifelse + typev [ArrayP StringP] eq + { /f aa 0 get def + /v aa 1 get def + /setarg 1 def + } { } ifelse + typev [ArrayP RingP] eq + { /f aa 0 get def + /v aa 1 get def + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /setarg 1 def + } { } ifelse + typev [ArrayP StringP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + /setarg 1 def + } { } ifelse + + typev [ArrayP StringP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + + /env1 getOptions def + + setarg { } { (ecart.gb : Argument mismatch) error } ifelse + + [(KanGBmessage) ecart.gb.verbose ] system_variable + + %%% Start of the preprocess + v tag RingP eq { + /rr v def + }{ + f getRing /rr set + } ifelse + %% To the normal form : matrix expression. + f gb.toMatrixOfString /f set + /mm gb.itWasMatrix def + + rr tag 0 eq { + %% Define our own ring + v isInteger { + (Error in gb: Specify variables) error + } { } ifelse + wv isInteger { + [v ring_of_differential_operators + [ v ecart.wv1 v ecart.wv2 ] weight_vector + gb.characteristic + opt + ] define_ring + }{ + degreeShift isInteger { + [v ring_of_differential_operators + [v ecart.wv1 v ecart.wv2] wv join weight_vector + gb.characteristic + opt + ] define_ring + + }{ + [v ring_of_differential_operators + [v ecart.wv1 v ecart.wv2] wv join weight_vector + gb.characteristic + [(degreeShift) degreeShift] opt join + ] define_ring + + } ifelse + } ifelse + } { + %% Use the ring structre given by the input. + v isInteger not { + gb.warning { + (Warning : the given ring definition is not used.) message + } { } ifelse + } { } ifelse + rr ring_def + /wv rr gb.getWeight def + + } ifelse + %%% Enf of the preprocess + + ecart.gb.verbose { + (The first and the second weight vectors are automatically set as follows) + message + v ecart.wv1 message + v ecart.wv2 message + degreeShift isInteger { } + { + (The degree shift is ) messagen + degreeShift message + } ifelse + } { } ifelse + + %%BUG: case of v is integer + v ecart.checkOrder + + ecartn.begin + + ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse + ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse + ecart.autoHomogenize { + (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.) + message + } { } ifelse + ecart.autoHomogenize { + f { {. ecart.dehomogenize} map} map /f set + f ecart.homogenize01 /f set + }{ + f { {. } map } map /f set + } ifelse + ecart.needSyz { + [f [(needSyz)] gb.options join ] groebner /gg set + } { + [f gb.options] groebner 0 get /gg set + } ifelse + + ecart.needSyz { + mm { + gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set + } { /ans.gb gg 0 get def } ifelse + /ans [gg 2 get , ans.gb , gg 1 get , f ] def +% ans pmat ; + } { + wv isInteger { + /ans [gg gg {init} map] def + }{ + degreeShift isInteger { + /ans [gg gg {wv 0 get weightv init} map] def + } { + /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def + } ifelse + }ifelse + + %% Postprocess : recover the matrix expression. + mm { + ans { /tmp set [mm tmp] toVectors } map + /ans set + }{ } + ifelse + } ifelse + + ecart.end + + %% + env1 restoreOptions %% degreeShift changes "grade" + + /arg1 ans def + ] pop + popEnv + popVariables + arg1 +} def +(ecartn.gb[gb by non-ecart division] ) messagen-quiet + +/ecartd.gb { + /arg1 set + [/in-ecart.gb /aa /typev /setarg /f /v + /gg /wv /vec /ans /rr /mm + /degreeShift /env2 /opt /ans.gb + /hdShift + /ecart.useSugar + ] pushVariables + [(CurrentRingp) (KanGBmessage)] pushEnv + [ + /aa arg1 def + aa isArray { } { ( << array >> ecartd.gb) error } ifelse + /setarg 0 def + /wv 0 def + /degreeShift 0 def + /hdShift 0 def + /ecart.useSugar 0 def + /opt [(weightedHomogenization) 1] def + aa { tag } map /typev set + typev [ ArrayP ] eq + { /f aa 0 get def + /v gb.v def + /setarg 1 def + } { } ifelse + typev [ArrayP StringP] eq + { /f aa 0 get def + /v aa 1 get def + /setarg 1 def + } { } ifelse + typev [ArrayP RingP] eq + { /f aa 0 get def + /v aa 1 get def + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /setarg 1 def + } { } ifelse + typev [ArrayP StringP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + /setarg 1 def + } { } ifelse + + typev [ArrayP StringP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + + /env1 getOptions def + + setarg { } { (ecart.gb : Argument mismatch) error } ifelse + + [(KanGBmessage) ecart.gb.verbose ] system_variable + $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message + + %%% Start of the preprocess + v tag RingP eq { + /rr v def + }{ + f getRing /rr set + } ifelse + %% To the normal form : matrix expression. + f gb.toMatrixOfString /f set + /mm gb.itWasMatrix def + + rr tag 0 eq { + %% Define our own ring + v isInteger { + (Error in gb: Specify variables) error + } { } ifelse + wv isInteger { + (Give an weight vector such that x < 1) error + }{ + degreeShift isInteger { + [v ring_of_differential_operators + wv weight_vector + gb.characteristic + opt + ] define_ring + + }{ + [v ring_of_differential_operators + wv weight_vector + gb.characteristic + [(degreeShift) degreeShift] opt join + ] define_ring + + } ifelse + } ifelse + } { + %% Use the ring structre given by the input. + v isInteger not { + gb.warning { + (Warning : the given ring definition is not used.) message + } { } ifelse + } { } ifelse + rr ring_def + /wv rr gb.getWeight def + + } ifelse + %%% Enf of the preprocess + + ecart.gb.verbose { + degreeShift isInteger { } + { + (The degree shift is ) messagen + degreeShift message + } ifelse + } { } ifelse + + %%BUG: case of v is integer + v ecart.checkOrder + + ecartd.begin + + ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse + + hdShift tag 1 eq { + ecart.autoHomogenize not hdShift -1 eq or { +% No automatic h-homogenization. + f { {. } map} map /f set + } { +% Automatic h-homogenization without degreeShift + (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message + f { {. ecart.dehomogenize} map} map /f set + f ecart.homogenize01 /f set + f { { [[(H). (1).]] replace } map } map /f set + } ifelse + } { +% Automatic h-homogenization with degreeShift + (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message + f { {. ecart.dehomogenize} map} map /f set + f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set + f { { [[(H). (1).]] replace } map } map /f set + }ifelse + + ecart.useSugar { + ecart.needSyz { + [f [(needSyz)] gb.options join ] groebner_sugar /gg set + } { + [f gb.options] groebner_sugar 0 get /gg set + } ifelse + } { + ecart.needSyz { + [f [(needSyz)] gb.options join ] groebner /gg set + } { + [f gb.options] groebner 0 get /gg set + } ifelse + } ifelse + + ecart.needSyz { + mm { + gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set + } { /ans.gb gg 0 get def } ifelse + /ans [gg 2 get , ans.gb , gg 1 get , f ] def +% ans pmat ; + } { + wv isInteger { + /ans [gg gg {init} map] def + }{ +%% Get the initial ideal + degreeShift isInteger { + /ans [gg gg {wv 0 get weightv init} map] def + } { + /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def + } ifelse + }ifelse + + %% Postprocess : recover the matrix expression. + mm { + ans { /tmp set [mm tmp] toVectors } map + /ans set + }{ } + ifelse + } ifelse + + ecartd.end + + %% + env1 restoreOptions %% degreeShift changes "grade" + + /arg1 ans def + ] pop + popEnv + popVariables + arg1 +} def +(ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet + +/ecart.checkOrder { + /arg1 set + [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables + [ + /vv arg1 def + vv isArray + { } { [vv to_records pop] /vv set } ifelse + vv {toString} map /vv set + vv { /tt set [@@@.Dsymbol tt] cat } map /dd set + % Starting the checks. + 0 1 vv length 1 sub { + /i set + vv i get . dd i get . mul /tt set + tt @@@.hsymbol . add init tt eq { } + { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse + } for + + 0 1 vv length 1 sub { + /i set + vv i get . /tt set + tt (1). add init (1). eq { } + { [vv i get ( is larger than 1 ) ] cat error} ifelse + } for + /arg1 1 def + ] pop + popVariables + arg1 +} def +[(ecart.checkOrder) + [(v ecart.checkOrder bool checks if the given order is relevant) + (for the ecart division.) + (cf. ecartd.gb, ecart.gb, ecartn.gb) + ] +] putUsages + +/ecart.wv_last { + /arg1 set + [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables + [ + /vv arg1 def + vv isArray + { } { [vv to_records pop] /vv set } ifelse + vv {toString} map /vv set + vv { /tt set [@@@.Dsymbol tt] cat } map /dd set + vv { -1 } map + dd { 1 } map join /arg1 set + ] pop + popVariables + arg1 +} def +[(ecart.wv_last) + [(v ecart.wv_last wt ) + (It returns the weight vector -1,-1,...-1; 1,1, ..., 1) + (Use this weight vector as the last weight vector for ecart division) + (if ecart.checkOrder complains about the order given.) + ] +] putUsages + +/ecart.mimimalBase.test { + [ + [ (0) , (-2*Dx) , (2*t) , (y) , (x^2) ] + [ (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ] + [ (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ] + [ (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )] + [ (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ] + [ (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ] + [ (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ] + [ (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ] + ] + /ff set + + /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def + /shift [ [1 0 1 0 0] ] def + /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def + + [ff (t,x,y) weight [(degreeShift) shift (startingShift) nmshift]] ecart.minimalBase + + +} def +/test {ecart.mimimalBase.test} def + +%(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1] +/ecart.minimalBase.D1 { + /arg1 set + [/in-ecart.minimalBase.D1 /tt /v] pushVariables + [ + /v arg1 def + [ v to_records pop] /v set + v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set + v [(h) 1] join /arg1 set + ] pop + popVariables + arg1 +} def + +% [0 1 2] 1 ecart.removeElem [0 2] +/ecart.removeElem { + /arg2 set + /arg1 set + [/in-ecart.removeElem /v /q /i /ans /j] pushVariables + [ + /v arg1 def + /q arg2 def + /ans v length 1 sub newVector def + /j 0 def + 0 1 v length 1 sub { + /i set + i q eq not { + ans j v i get put + /j j 1 add def + } { } ifelse + } for + ] pop + popVariables + arg1 +} def + +/ecart.isZeroRow { + /arg1 set + [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables + [ + /aa arg1 def + aa length /n set + /yes 1 def + 0 1 n 1 sub { + /i set + aa i get (0). eq { + } { + /yes 0 def + } ifelse + } for + /arg1 yes def + ] pop + popVariables + arg1 +} def + +/ecart.removeZeroRow { + /arg1 set + [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables + [ + /aa arg1 def + aa length /n set + /ans [ ] def + 0 1 n 1 sub { + /i set + aa i get ecart.isZeroRow { + } { + ans aa i get append /ans set + } ifelse + } for + /arg1 ans def + ] pop + popVariables + arg1 +} def + +/ecart.gen_input { + /arg1 set + [/in-ecart.gen_input /aa /typev /setarg /f /v + /gg /wv /vec /ans /rr /mm + /degreeShift /env2 /opt /ss0 + /hdShift /ff + ] pushVariables + [ + /aa arg1 def + aa isArray { } { ( << array >> ecart.gen_input) error } ifelse + /setarg 0 def + /wv 0 def + /degreeShift 0 def + /hdShift 0 def + /opt [ ] def + aa { tag } map /typev set + typev [ArrayP StringP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse + + [(KanGBmessage) ecart.gb.verbose ] system_variable + + f 0 get tag ArrayP eq { } + { f { /tt set [ tt ] } map /f set } ifelse + + [f v wv [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join] + ecart.gb /ff set + ff getRing ring_def + + ff 0 get { {toString } map } map /ff set + + [ff v wv + [(degreeShift) degreeShift (startingShift) [hdShift 0 get degreeShift 0 get]] opt join + ] /arg1 set + ] pop + popVariables + arg1 +} def +[(ecart.gen_input) +[$[ff v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]] ] ecart.gen_input $ + $ [gg_h v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] $ + (It generates the input for the minimal filtered free resolution.) + (Current ring is changed to the ring of gg_h.) + (cf. ecart.minimalBase) + $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $ + $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $ + $ [(degreeShift) [ [0] ] $ + $ (startingShift) [ [0] [0] ]] ] ecart.gen_input /gg set gg pmat $ +]] putUsages + + +[(ecart.minimalBase) +[$[ff v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalBase $ + ( [mbase gr_of_mbase ) + $ [syz v weight_vector [(degreeShift) new_uv_shift_m (startingShift) [new_D_shift_n new_uv_shift_m]]]$ + ( gr_of_syz ]) + (mbase is the minimal generators of ff in D^h in the sense of filtered minimal) + (generators.) + $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $ + $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $ + $ [(degreeShift) [ [0] ] $ + $ (startingShift) [ [0] [0] ] ] ] ecart.gen_input /gg0 set $ + $ gg0 ecart.minimalBase /ss0 set $ + $ ss0 2 get ecart.minimalBase /ss1 set $ + $ ss1 2 get ecart.minimalBase /ss2 set $ + $ (--------- minimal filtered resolution -------) message $ + $ ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat $ + $ (--------- degree shift (n,m) n:D-shift m:uv-shift -------) message $ + $ gg0 3 get 3 get message $ + $ ss0 2 get 3 get 3 get message $ + $ ss1 2 get 3 get 3 get message $ + $ ss2 2 get 3 get 3 get message ; $ + +]] putUsages +/ecart.minimalBase { + /arg1 set + [/in-ecart.minimalBase /ai1 /ai /aa /typev /setarg /f /v + /gg /wv /vec /ans /rr /mm + /degreeShift /env2 /opt /ss0 + /hdShift + /degreeShiftD /degreeShiftUV + /degreeShiftDnew /degreeShiftUVnew + /tt + /ai1_gr /ai_gr + /s /r /p /q /i /j /k + /ai1_new /ai_new /ai_new2 + ] pushVariables + [ + /aa arg1 def + aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse + /setarg 0 def + /wv 0 def + /degreeShift 0 def + /hdShift 0 def + /opt [ ] def + aa { tag } map /typev set + typev [ArrayP StringP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + typev [ArrayP ArrayP ArrayP ArrayP] eq + { /f aa 0 get def + /v aa 1 get from_records def + /wv aa 2 get def + opt aa 3 get ecart.setOpt join /opt set + /setarg 1 def + } { } ifelse + setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse + + [(KanGBmessage) ecart.gb.verbose ] system_variable + + f 0 get tag ArrayP eq { } + { f { /tt set [ tt ] } map /f set } ifelse + [f v wv [(degreeShift) degreeShift (noAutoHomogenize) 1] opt join] ecart.syz /ss0 set + + ss0 getRing ring_def + /degreeShiftD hdShift 0 get def + /degreeShiftUV hdShift 1 get def +% -- ai --> D^r -- ai1 --> D^rr + /ai1 f { { . } map } map def + /ai ss0 0 get def + + { + /degreeShiftUVnew + ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all } map + def + (degreeShiftUVnew=) messagen degreeShiftUVnew message + + /degreeShiftDnew + ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ] ord_ws_all} + map + def + (degreeShiftDnew=) messagen degreeShiftDnew message + + ai {[wv 0 get weightv degreeShiftUVnew] init} map /ai_gr set + +%C Note 2003.8.26 + + ai [ ] eq { + exit + } { } ifelse + + /s ai length def + /r ai 0 get length def + + /itIsMinimal 1 def + 0 1 s 1 sub { + /i set + 0 1 r 1 sub { + /j set + + [(isConstantAll) ai_gr i get j get] gbext + ai_gr i get j get (0). eq not and + { + /itIsMinimal 0 def + /p i def /q j def + } { } ifelse + } for + } for + + + itIsMinimal { exit } { } ifelse + +% construct new ai and ai1 (A_i and A_{i-1}) + /ai1_new r 1 sub newVector def + /j 0 def + 0 1 r 1 sub { + /i set + i q eq not { + ai1_new j ai1 i get put + /j j 1 add def + } { } ifelse + } for + + /ai_new [s r] newMatrix def + 0 1 s 1 sub { + /j set + 0 1 r 1 sub { + /k set + ai_new [j k] + << ai p get q get >> << ai j get k get >> mul + << ai j get q get >> << ai p get k get >> mul + sub + put + } for + } for + +% remove 0 column + /ai_new2 [s 1 sub r 1 sub] newMatrix def + /j 0 def + 0 1 s 1 sub { + /i set + i p eq not { + ai_new2 j << ai_new i get q ecart.removeElem >> put + /j j 1 add def + } { } ifelse + } for + +% ( ) error + /ai1 ai1_new def + /ai ai_new2 ecart.removeZeroRow def + + } loop + /arg1 + [ ai1 + ai1 {[wv 0 get weightv degreeShift 0 get] init} map %Getting gr of A_{i-1} + [ai v wv [(degreeShift) [degreeShiftUVnew] (startingShift) [degreeShiftDnew degreeShiftUVnew]]] + ai {[wv 0 get weightv degreeShiftUVnew] init} map %Getting gr of A_i + ] + def + ] pop + popVariables + arg1 +} def + +/ecart.minimalResol { + /arg1 set + [/in-ecart.minimalResol /aa /ans /gg0 /ansds /ans_gr /c] pushVariables + [ + /aa arg1 def + /ans [ ] def + /ansds [ ] def + /ans_gr [ ] def + /c 0 def + + (---- ecart.gen_input ----) message + aa ecart.gen_input /gg0 set + ansds gg0 3 get 3 get append /ansds set + (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set + gg0 ecart.minimalBase /ssi set + ansds ssi 2 get 3 get 3 get append /ansds set + ans ssi 0 get append /ans set + ans_gr ssi 1 get append /ans_gr set + { + ssi 3 get [ ] eq { exit } { } ifelse + (---- ecart.minimalBase --- Degree ) messagen c message c 1 add /c set + ssi 2 get ecart.minimalBase /ssi_new set + ans ssi_new 0 get append /ans set + ansds ssi_new 2 get 3 get 3 get append /ansds set + ans_gr ssi_new 1 get append /ans_gr set + /ssi ssi_new def + } loop + /arg1 [ans ansds ans_gr] def + ] pop + popVariables + arg1 +} def + +(ecart.minimalResol) message + +[(ecart.minimalResol) +[ + + $[ff v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalResol $ + ( [resol degree_shifts gr_of_resol_by_uv_shift_m] ) + $Example1: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $ + $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $ + $ [(degreeShift) [ [0] ] $ + $ (startingShift) [ [0] [0] ] ] ] ecart.minimalResol /gg set gg pmat $ +]] putUsages + ( ) message-quiet +