=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v retrieving revision 1.13 retrieving revision 1.19 diff -u -p -r1.13 -r1.19 --- OpenXM/src/kan96xx/Doc/ecart.sm1 2003/08/26 12:46:03 1.13 +++ OpenXM/src/kan96xx/Doc/ecart.sm1 2004/04/29 12:04:45 1.19 @@ -1,4 +1,4 @@ -% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.12 2003/08/26 05:06:00 takayama Exp $ +% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.18 2003/09/30 00:06:56 takayama Exp $ %[(parse) (hol.sm1) pushfile] extension %[(parse) (appell.sm1) pushfile] extension @@ -16,6 +16,59 @@ [(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 @@ -93,7 +146,7 @@ ( [(h) 1 (Dx1) 1 (Dx2) 1] ) ( [(Dx1) 1 (Dx2) 1] ) ( [(x1) -1 (x2) -1]) - ( ] weight_vector ) + ( ] ecart.weight_vector ) ( 0 ) ( [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]]) ( ] define_ring) @@ -171,15 +224,16 @@ (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 for the ring. ) - (a : [f v w ds hdShift]; array f; string v; array of array w; w is the weight matirx.) + $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 ds (no)]; array f; string v; array of array w; w is the weight matirx.$ + $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) $ + $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize), ecartd.reduction $ ( ) $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 ; $ @@ -198,7 +252,8 @@ ( 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] ] [[0 1] [-3 1] ] ] ecart.gb pmat ; $ + $ [ [(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) @@ -216,6 +271,7 @@ /gg /wv /vec /ans /rr /mm /degreeShift /env2 /opt /ans.gb /hdShift + /ecart.useSugar ] pushVariables [(CurrentRingp) (KanGBmessage)] pushEnv [ @@ -226,6 +282,7 @@ /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 @@ -259,61 +316,21 @@ /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 StringP ArrayP ArrayP ArrayP] eq - { /f aa 0 get def - /v aa 1 get def - /wv aa 2 get def - /degreeShift aa 3 get def - /hdShift aa 4 get def - /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 - typev [ArrayP 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 - /hdShift aa 4 get def - /setarg 1 def - } { } ifelse - typev [ArrayP ArrayP ArrayP ArrayP StringP] eq - { /f aa 0 get def - /v aa 1 get from_records def - /wv aa 2 get def - /degreeShift aa 3 get def - aa 4 get (no) eq { - /hdShift -1 def - } { - (Unknown keyword for the 5th argument) error - } ifelse - /setarg 1 def - } { } ifelse - typev [ArrayP StringP ArrayP ArrayP StringP] eq - { /f aa 0 get def - /v aa 1 get def - /wv aa 2 get def - /degreeShift aa 3 get def - aa 4 get (no) eq { - /hdShift -1 def - } { - (Unknown keyword for the 5th argument) error - } ifelse - /setarg 1 def - } { } ifelse /env1 getOptions def @@ -339,23 +356,23 @@ } { } ifelse wv isInteger { [v ring_of_differential_operators -% [ v ecart.wv1 v ecart.wv2 ] weight_vector +% [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector gb.characteristic opt ] define_ring }{ degreeShift isInteger { [v ring_of_differential_operators -% [v ecart.wv1 v ecart.wv2] wv join weight_vector - wv weight_vector +% [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector + wv ecart.weight_vector gb.characteristic opt ] define_ring }{ [v ring_of_differential_operators -% [v ecart.wv1 v ecart.wv2] wv join weight_vector - wv weight_vector +% [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector + wv ecart.weight_vector gb.characteristic [(degreeShift) degreeShift] opt join ] define_ring @@ -414,10 +431,18 @@ f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set }ifelse - ecart.needSyz { - [f [(needSyz)] gb.options join ] groebner /gg set - } { - [f gb.options] groebner 0 get /gg set + 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 { @@ -472,7 +497,7 @@ (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 ) @@ -492,7 +517,8 @@ $ [ [ (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) $ - $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecarth.gb pmat ; (buggy infinite loop)$ + $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $ + $ [(degreeShift) [[0 1] [-3 1] ]] ] ecarth.gb pmat ; $ ( ) (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, ) ( ecart.dehomogenize, ecart.dehomogenizeH) @@ -592,18 +618,19 @@ /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 @@ -630,21 +657,21 @@ } { } ifelse wv isInteger { [v ring_of_differential_operators - [ v ecart.wv1 v ecart.wv2 ] weight_vector + [ v ecart.wv1 v ecart.wv2 ] ecart.weight_vector gb.characteristic opt ] define_ring }{ degreeShift isInteger { [v ring_of_differential_operators - [v ecart.wv1 v ecart.wv2] wv join weight_vector + [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector gb.characteristic opt ] define_ring }{ [v ring_of_differential_operators - [v ecart.wv1 v ecart.wv2] wv join weight_vector + [v ecart.wv1 v ecart.wv2] wv join ecart.weight_vector gb.characteristic [(degreeShift) degreeShift] opt join ] define_ring @@ -743,6 +770,7 @@ /gg /wv /vec /ans /rr /mm /degreeShift /env2 /opt /ans.gb /hdShift + /ecart.useSugar ] pushVariables [(CurrentRingp) (KanGBmessage)] pushEnv [ @@ -752,6 +780,7 @@ /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 @@ -786,60 +815,21 @@ /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 - typev [ArrayP StringP ArrayP ArrayP ArrayP] eq - { /f aa 0 get def - /v aa 1 get def - /wv aa 2 get def - /degreeShift aa 3 get def - /hdShift aa 4 get def - /setarg 1 def - } { } ifelse - typev [ArrayP 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 - /hdShift aa 4 get def - /setarg 1 def - } { } ifelse - typev [ArrayP ArrayP ArrayP ArrayP StringP] eq - { /f aa 0 get def - /v aa 1 get from_records def - /wv aa 2 get def - /degreeShift aa 3 get def - aa 4 get (no) eq { - /hdShift -1 def - } { - (Unknown keyword for the 5th argument) error - } ifelse - /setarg 1 def - } { } ifelse - typev [ArrayP StringP ArrayP ArrayP StringP] eq - { /f aa 0 get def - /v aa 1 get def - /wv aa 2 get def - /degreeShift aa 3 get def - aa 4 get (no) eq { - /hdShift -1 def - } { - (Unknown keyword for the 5th argument) error - } ifelse - /setarg 1 def - } { } ifelse /env1 getOptions def @@ -868,14 +858,14 @@ }{ degreeShift isInteger { [v ring_of_differential_operators - wv weight_vector + wv ecart.weight_vector gb.characteristic opt ] define_ring }{ [v ring_of_differential_operators - wv weight_vector + wv ecart.weight_vector gb.characteristic [(degreeShift) degreeShift] opt join ] define_ring @@ -929,10 +919,18 @@ f { { [[(H). (1).]] replace } map } map /f set }ifelse - ecart.needSyz { - [f [(needSyz)] gb.options join ] groebner /gg set - } { - [f gb.options] groebner 0 get /gg set + 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 { @@ -1049,7 +1047,7 @@ /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 shift nmshift] ecart.minimalBase + [ff (t,x,y) weight [(degreeShift) shift (startingShift) nmshift]] ecart.minimalBase } def @@ -1091,8 +1089,131 @@ 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 ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]] ] ecart.gen_input $ + $ [gg_h v ecart.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 [D_shift_n uv_shift_m]] ecart.minimalBase mbase) +[$[ff v ecart.weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalBase $ + ( [mbase gr_of_mbase ) + $ [syz v ecart.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 @@ -1114,21 +1235,20 @@ /wv 0 def /degreeShift 0 def /hdShift 0 def + /opt [ ] def aa { tag } map /typev set - typev [ArrayP StringP ArrayP ArrayP ArrayP] eq + 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 - /hdShift aa 4 get def + opt aa 3 get ecart.setOpt join /opt set /setarg 1 def } { } ifelse - typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq + 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 - /hdShift aa 4 get def + opt aa 3 get ecart.setOpt join /opt set /setarg 1 def } { } ifelse setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse @@ -1137,7 +1257,7 @@ f 0 get tag ArrayP eq { } { f { /tt set [ tt ] } map /f set } ifelse - [f v wv degreeShift (no)] ecart.syz /ss0 set + [f v wv [(degreeShift) degreeShift (noAutoHomogenize) 1] opt join] ecart.syz /ss0 set ss0 getRing ring_def /degreeShiftD hdShift 0 get def @@ -1162,6 +1282,10 @@ %C Note 2003.8.26 + ai [ ] eq { + exit + } { } ifelse + /s ai length def /r ai 0 get length def @@ -1219,15 +1343,328 @@ } for % ( ) error - /ai1 ai1_new def - /ai ai_new2 def + /ai1 ai1_new def + /ai ai_new2 ecart.removeZeroRow def } loop - /arg1 ai1 def + /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 ecart.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 + +%% for ecart.weight_vector +/ecart.eliminationOrderTemplate { %% esize >= 1 +%% if esize == 0, it returns reverse lexicographic order. +%% m esize eliminationOrderTemplate mat + /arg2 set /arg1 set + [/m /esize /m1 /m2 /k /om /omtmp] pushVariables + [ + /m arg1 def /esize arg2 def + /m1 m esize sub 1 sub def + /m2 esize 1 sub def + [esize 0 gt + { + [1 1 esize + { pop 1 } for + esize 1 << m 1 sub >> + { pop 0 } for + ] %% 1st vector + } + { } ifelse + + m esize gt + { + [1 1 esize + { pop 0 } for + esize 1 << m 1 sub >> + { pop 1 } for + ] %% 2nd vector + } + { } ifelse + + m1 0 gt + { + m 1 sub -1 << m m1 sub >> + { + /k set + m k evec_neg + } for + } + { } ifelse + + m2 0 gt + { + << esize 1 sub >> -1 1 + { + /k set + m k evec_neg + } for + } + { } ifelse + + ] /om set + om [ 0 << m 2 idiv >> 1 sub] 0 put + om [ << m 2 idiv >> 1 add << m 2 idiv >> 1 sub] 0 put + /arg1 om def + ] pop + popVariables + arg1 +} def + +%note 2003.09.29 +/ecart.elimination_order { +%% [x-list d-list params] (x,y,z) elimination_order +%% vars evars +%% [x-list d-list params order] + /arg2 set /arg1 set + [/vars /evars /univ /order /perm /univ0 /compl /m /omtmp] pushVariables + /vars arg1 def /evars [arg2 to_records pop] def + [ + /univ vars 0 get reverse + vars 1 get reverse join + def + + << univ length 2 sub >> + << evars length >> + ecart.eliminationOrderTemplate /order set + + [[1]] order oplus [[1]] oplus /order set + + /m order length 2 sub def + /omtmp [1 1 m 2 add { pop 0 } for ] def + omtmp << m 2 idiv >> 1 put + order omtmp append /order set + % order pmat + + /univ0 [univ reverse aload pop pop] reverse def %% [e,x,y,h] --> [x,y,h] + + /compl + [univ 0 get] evars join evars univ0 complement join + def + compl univ + getPerm /perm set + %%perm :: univ :: compl :: + + order perm permuteOrderMatrix /order set + + + vars [order] join /arg1 set + ] pop + popVariables + arg1 +} def + +/ecart.define_ring { + /arg1 set + [/rp /param /foo] pushVariables + [/rp arg1 def + + rp 0 get length 3 eq { + rp 0 [rp 0 get 0 get rp 0 get 1 get rp 0 get 2 get ] + ( ) ecart.elimination_order put + } { } ifelse + + [ + rp 0 get 0 get %% x-list + rp 0 get 1 get %% d-list + rp 0 get 2 get /param set + param 0 << rp 1 get >> put %% << rp 1 get >> is 17 in the example. + param %% parameters. + rp 0 get 3 get %% order matrix. + rp length 2 eq + { [ ] } %% null optional argument. + { rp 2 get } + ifelse + ] /foo set + foo aload pop set_up_ring@ + ] pop + popVariables + [(CurrentRingp)] system_variable +} def +/ecart.weight_vector { + /arg2 set /arg1 set + [/vars /univ /w-vectors /www /k /order1 /order2] pushVariables + /vars arg1 def /w-vectors arg2 def + [ + /univ vars 0 get reverse + vars 1 get reverse join + def + [ + 0 1 << w-vectors length 1 sub >> + { + /k set + univ w-vectors k get w_to_vec + } for + ] /order1 set + %% order1 :: + + vars ( ) ecart.elimination_order 3 get /order2 set + vars [ << order1 order2 join >> ] join /arg1 set + ] pop + popVariables + arg1 +} def + +%% end of for ecart.define_ring + +/ecartd.reduction { + /arg2 set + /arg1 set + [/in-ecartd.reduction /gbasis /flist /ans /gbasis2] pushVariables + [(CurrentRingp) (KanGBmessage)] pushEnv + [ + /gbasis arg2 def + /flist arg1 def + gbasis 0 get tag 6 eq { } + { (ecartd.reduction: the second argument must be a list of lists) error } + ifelse + + gbasis length 1 eq { + gbasis getRing ring_def + /gbasis2 gbasis 0 get def + } { + [ [(1)] ] gbasis rest join ecartd.gb 0 get getRing ring_def + /gbasis2 gbasis 0 get ,,, def + } ifelse + ecartd.begin + + flist ,,, /flist set + flist tag 6 eq { + flist { gbasis2 reduction } map /ans set + }{ + flist gbasis2 reduction /ans set + } ifelse + /arg1 ans def + + ecartd.end + ] pop + popEnv + popVariables + arg1 +} def + +/ecartd.reduction.test { + [ + [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )] + (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] + ecartd.gb /gg set + + (Dx) [gg 0 get] ecartd.reduction /gg2 set + gg2 message + (-----------------------------) message + + [(Dx) (Dy) (Dx+x*Dy)] [gg 0 get] ecartd.reduction /gg3 set + gg3 message + + (-----------------------------) message + [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] + (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set + (Dx) ggg ecartd.reduction /gg4 set + gg4 message + [gg2 gg3 gg4] +} def + +/ecarth.reduction { + /arg2 set + /arg1 set + [/in-ecarth.reduction /gbasis /flist /ans /gbasis2] pushVariables + [(CurrentRingp) (KanGBmessage)] pushEnv + [ + /gbasis arg2 def + /flist arg1 def + gbasis 0 get tag 6 eq { } + { (ecarth.reduction: the second argument must be a list of lists) error } + ifelse + + gbasis length 1 eq { + gbasis getRing ring_def + /gbasis2 gbasis 0 get def + } { + [ [(1)] ] gbasis rest join ecarth.gb 0 get getRing ring_def + /gbasis2 gbasis 0 get ,,, def + } ifelse + ecarth.begin + + flist ,,, /flist set + flist tag 6 eq { + flist { gbasis2 reduction } map /ans set + }{ + flist gbasis2 reduction /ans set + } ifelse + /arg1 ans def + + ecarth.end + ] pop + popEnv + popVariables + arg1 +} def + +[(ecartd.reduction) +[ (f basis ecartd.reduction r) + (f is reduced by basis by the tangent cone algorithm.) + (r is the return value format of reduction.) + (basis is the argument format of ecartd.gb.) + (The first element of basis must be a standard basis.) + (cf. reduction, ecartd.gb, ecartd.reduction.test ) + $Example:$ + $ [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] $ + $ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $ + $ (Dx+Dy) ggg ecartd.reduction :: $ +]] putUsages ( ) message-quiet