=================================================================== RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v retrieving revision 1.16 retrieving revision 1.39 diff -u -p -r1.16 -r1.39 --- OpenXM/src/kan96xx/Doc/ecart.sm1 2003/09/12 02:52:49 1.16 +++ OpenXM/src/kan96xx/Doc/ecart.sm1 2004/09/14 11:51:20 1.39 @@ -1,12 +1,19 @@ -% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.15 2003/08/29 04:34:07 takayama Exp $ -%[(parse) (hol.sm1) pushfile] extension +% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.38 2004/09/14 10:50:49 takayama Exp $ +(hol_loaded) boundp { } +{ [(parse) (hol.sm1) pushfile] extension } ifelse %[(parse) (appell.sm1) pushfile] extension -(ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet +(ecart.sm1 : ecart division for D, 2003/07/25, 2004/09/14 ) message-quiet /ecart.begin { beginEcart } def /ecart.end { endEcart } def /ecart.autoHomogenize 1 def /ecart.needSyz 0 def +/ecartd.gb.oxRingStructure [[ ] [ ] ] def +/ecart.partialEcartGlobalVarX [ ] def + +/ecart.gb.verbose 1 def +/ecart.message.quiet 0 def + /ecartd.begin { ecart.begin [(EcartAutomaticHomogenization) 1] system_variable @@ -16,6 +23,16 @@ [(EcartAutomaticHomogenization) 0] system_variable } def +/ecart.message { + ecart.message.quiet { pop } { message } ifelse +} def +/ecart.messagen { + ecart.message.quiet { pop } { messagen } ifelse +} def +/ecart.setOpt.init { +% Initialize + /ecart.partialEcartGlobalVarX [ ] def +} def /ecart.setOpt { /arg1 set [/in-ecart.setOpt /opt /i /n /ans] pushVariables @@ -23,6 +40,9 @@ /opt arg1 def /ans [ ] def /n opt length def + + ecart.setOpt.init + 0 2 n 1 sub { /i set opt i get tag StringP eq not { @@ -50,17 +70,23 @@ exit } { } ifelse - ans [opt i get opt i 1 add get ] append /ans set +% Global: ecart.partialEcartGlobalVarX + opt i get (partialEcartGlobalVarX) eq { + /ecart.partialEcartGlobalVarX opt , i 1 add , get def + % do not exit. + } { } ifelse + + ans [opt i get opt i 1 add get ] join /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 + (ecart.setOpt:) ecart.message + (degreeShift=) ecart.messagen degreeShift ecart.message + $hdShift(startingShift)=$ ecart.messagen hdShift ecart.message + (sugar=) ecart.messagen ecart.useSugar ecart.message + (Other options=) ecart.messagen ans ecart.message } { } ifelse /arg1 ans def @@ -80,8 +106,8 @@ ll (0). eq { } { ll getRing /rr set - ll [ [ (H) rr ,, (1) rr ,, ] - [ (h) rr ,, (1) rr ,, ]] replace + ll [ [ @@@.Hsymbol rr __ (1) rr __ ] + [ (h) rr __ (1) rr __ ]] replace /ll set } ifelse } ifelse @@ -106,7 +132,7 @@ ll (0). eq { } { ll getRing /rr set - ll [ [ (H) rr ,, (1) rr ,, ] ] replace + ll [ [ @@@.Hsymbol rr __ (1) rr __ ] ] replace /ll set } ifelse } ifelse @@ -146,7 +172,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) @@ -188,7 +214,7 @@ [/in.ecart.wv1 /v] pushVariables [ /v arg1 def - [(H) (h) v to_records pop] /v set + [@@@.Hsymbol (h) v to_records pop] /v set v { 1 } map /v set /arg1 v def ] pop @@ -211,6 +237,9 @@ /ecart.gb {ecartd.gb} def +[(ecartd.gb) +[(See ecart.gb)]] putUsages + [(ecart.gb) [(a ecart.gb b) (array a; array b;) @@ -233,7 +262,8 @@ ( 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 $ + ( ecartd.gb.oxRingStructure ) ( ) $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 ; $ @@ -255,6 +285,12 @@ $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] $ $ [(degreeShift) [[0 1] [-3 1]]] ] ecart.gb pmat ; $ ( ) + $Example 6: [ [(1-z) (-x+1-y-z)] (x,y,z) $ + $ [[(y) -1 (z) -1 (Dy) 1 (Dz) 1] [(x) 1 (Dx) 1]] $ + $ [(partialEcartGlobalVarX) [(x)]] ] /std set $ + $ std ecart.gb pmat ; $ + $ std ecart.gb getRing :: $ + ( ) (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 ) @@ -263,7 +299,6 @@ ( not to dehomogenize and homogenize) ]] putUsages -/ecart.gb.verbose 1 def %ecarth.gb s(H)-homogenized outputs. GG's original version of ecart gb. /ecarth.gb { /arg1 set @@ -271,6 +306,7 @@ /gg /wv /vec /ans /rr /mm /degreeShift /env2 /opt /ans.gb /hdShift + /ecart.useSugar ] pushVariables [(CurrentRingp) (KanGBmessage)] pushEnv [ @@ -281,6 +317,8 @@ /degreeShift 0 def /hdShift 0 def /opt [(weightedHomogenization) 1] def + /ecart.useSugar 0 def + ecart.setOpt.init aa { tag } map /typev set typev [ ArrayP ] eq { /f aa 0 get def @@ -354,23 +392,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 @@ -403,7 +441,7 @@ } { } ifelse %%BUG: case of v is integer - v ecart.checkOrder + [v ecart.partialEcartGlobalVarX] ecart.checkOrder ecart.begin @@ -429,10 +467,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 { @@ -575,6 +621,7 @@ /wv 0 def /degreeShift 0 def /opt [(weightedHomogenization) 1] def + ecart.setOpt.init aa { tag } map /typev set typev [ ArrayP ] eq { /f aa 0 get def @@ -647,21 +694,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 @@ -694,7 +741,7 @@ } { } ifelse %%BUG: case of v is integer - v ecart.checkOrder + [v ecart.partialEcartGlobalVarX] ecart.checkOrder ecartn.begin @@ -772,6 +819,7 @@ /hdShift 0 def /ecart.useSugar 0 def /opt [(weightedHomogenization) 1] def + ecart.setOpt.init aa { tag } map /typev set typev [ ArrayP ] eq { /f aa 0 get def @@ -826,7 +874,8 @@ 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 + $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ ecart.message + %%% Start of the preprocess v tag RingP eq { @@ -844,18 +893,18 @@ (Error in gb: Specify variables) error } { } ifelse wv isInteger { - (Give an weight vector such that x < 1) error + (Give a weight vector such that x < 1) error }{ 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 @@ -884,11 +933,12 @@ } { } ifelse %%BUG: case of v is integer - v ecart.checkOrder + [v ecart.partialEcartGlobalVarX] ecart.checkOrder + ecartd.begin - ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse + ecart.gb.verbose { (gb.options = ) ecart.messagen gb.options ecart.message } { } ifelse hdShift tag 1 eq { ecart.autoHomogenize not hdShift -1 eq or { @@ -896,17 +946,17 @@ f { {. } map} map /f set } { % Automatic h-homogenization without degreeShift - (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message + (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) ecart.message f { {. ecart.dehomogenize} map} map /f set f ecart.homogenize01 /f set - f { { [[(H). (1).]] replace } map } map /f set + f { { [[@@@.Hsymbol . (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 + f { { [[@@@.Hsymbol . (1).]] replace } map } map /f set }ifelse ecart.useSugar { @@ -951,6 +1001,7 @@ ecartd.end + ans getRing (oxRingStructure) dc /ecartd.gb.oxRingStructure set %% env1 restoreOptions %% degreeShift changes "grade" @@ -964,9 +1015,23 @@ /ecart.checkOrder { /arg1 set - [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables + [/vv] pushVariables [ /vv arg1 def + vv length 1 eq { + vv 0 get ecart.checkOrder.noGlobal /arg1 set + }{ + vv ecart.checkOrder.global /arg1 set + } ifelse + ] pop + popVariables + /arg1 +} def +/ecart.checkOrder.noGlobal { + /arg1 set + [/vv /tt /dd /n /i] pushVariables + [ + /vv arg1 def vv isArray { } { [vv to_records pop] /vv set } ifelse vv {toString} map /vv set @@ -990,8 +1055,54 @@ popVariables arg1 } def + +/ecart.checkOrder.global { + /arg1 set + [/vv /vvGlobal /tt /dd /n /i] pushVariables + [ + /vv arg1 def + /vvGlobal vv 1 get def + vv 0 get /vv set + vv isArray + { } { [vv to_records pop] /vv set } ifelse + vv {toString} map /vv set + vvGlobal isArray + { } { [vvGlobal to_records pop] /vvGlobal set } ifelse + vvGlobal {toString} map /vvGlobal set + + vv vvGlobal setMinus /vv set + vv { /tt set [@@@.Dsymbol tt] cat } map /dd set + % Starting the checks. Check for local variables. + 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 + + % check for global variables. + 0 1 vvGlobal length 1 sub { + /i set + vvGlobal i get . /tt set + tt (1). add init (1). eq { [vvGlobal i get ( is smaller 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) + [([v vGlobal] ecart.checkOrder bool checks if the given order is relevant) (for the ecart division.) (cf. ecartd.gb, ecart.gb, ecartn.gb) ] @@ -1170,8 +1281,8 @@ 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]]] $ +[$[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) @@ -1183,9 +1294,9 @@ [(ecart.minimalBase) -[$[ff v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] ecart.minimalBase $ +[$[ff v ecart.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]]]$ + $ [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.) @@ -1387,7 +1498,7 @@ [(ecart.minimalResol) [ - $[ff v weight_vector [(degreeShift) uv_shift_m (startingShift) [D_shift_n uv_shift_m]]] 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]] $ @@ -1395,5 +1506,662 @@ $ (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 + w-vectors to_int32 /w-vectors set + [ + 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 + + (----------- reduction by h=1 ---------------) message + [[( 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]]] /ggg set + [(Homogenize) 0] system_variable + (Dx) ggg ecartd.reduction /gg5 set + [(Homogenize) 1] system_variable + gg5 message + + [gg2 gg3 gg4 gg5] +} 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.) + (The first element of basis must be a standard basis.) + (r is the return value format of reduction.) + (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i) + (basis is given in the argument format of ecartd.gb.) + $h[0,1](D)-homogenization is used.$ + (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 + +/ecartd.reduction_noh { + /arg2 set + /arg1 set + [/in-ecarth.reduction_noh /gbasis /flist] pushVariables + [(Homogenize)] pushEnv + [ + /gbasis arg2 def + /flist arg1 def + [(Homogenize) 0] system_variable + flist gbasis ecartd.reduction /arg1 set + ] pop + popEnv + popVariables + arg1 +} def + +[(ecartd.reduction_noh) +[ (f basis ecartd.reduction_noh r) + (f is reduced by basis by the tangent cone algorithm.) + (The first element of basis must be a standard basis.) + (r is the return value format of reduction.) + (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i) + (basis is given in the argument format of ecartd.gb and) + (it should not contain the variable h. cf. dehomogenize) + $h[0,1](D)-homogenization is NOT used.$ + (cf. reduction, ecartd.gb, ecartd.reduction ) + $Example:$ + $ [[( 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]]] /ggg set $ + $ (Dx+Dy) ggg ecartd.reduction_noh :: $ +]] putUsages + +/ecart.stdOrder { + /arg1 set + [/in-ecart.stdOrder /vv /tt /dvv /wv1 /wv2 + ] pushVariables + [ + /vv arg1 def + vv isString { [ vv to_records pop] /vv set } + { } ifelse + vv { toString} map /vv set + + vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set + dvv { 1 } map /wv1 set + vv { -1 } map dvv { 1 } map join /wv2 set + vv length 0 eq { + /arg1 [ ] def + } { + /arg1 [wv1 wv2 ] def + } ifelse + ] pop + popVariables + arg1 +} def + +/ecartd.isSameIdeal_h { + /arg1 set + [/in-ecartd.isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f + /ecartd.isSameIdeal_h.opt + /save-ecart.autoHomogenize /wv /save-ecart.message.quiet + /vvGlobal /rng /noRecomputation + ] pushVariables + [(CurrentRingp) (Homogenize_vec)] pushEnv + [ + /aa arg1 def + gb.verbose { (Getting in ecartd.isSameIdeal_h) message } { } ifelse + %% comparison of hilbert series has not yet been implemented. + /save-ecart.message.quiet ecart.message.quiet def + aa length 2 gt { } + { ([ii jj vv] ecartd.isSameIdeal_h) error } ifelse + /ii aa 0 get def + /jj aa 1 get def + /vv aa 2 get def + + aa length 3 gt { + /vvGlobal aa 3 get def + vvGlobal isString { [vvGlobal to_records pop] /vvGlobal set } + { vvGlobal { toString } map /vvGlobal set } ifelse + } { /vvGlobal [ ] def } ifelse + + ii length 0 eq jj length 0 eq and + { /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse + + [vv vvGlobal] ecart.stdBlockOrder /wv set + vvGlobal length 0 eq { + /rng [vv wv ] def + }{ + /rng [vv wv [(partialEcartGlobalVarX) vvGlobal]] def + } ifelse + + aa (noRecomputation) getNode /noRecomputation set + noRecomputation tag 0 eq { /noRecomputation 0 def } { + /noRecomputation 1 def + } ifelse + noRecomputation { + [ii] /iigg set [jj] /jjgg set + } { + /save-ecart.autoHomogenize ecart.autoHomogenize def + /ecart.autoHomogenize 0 def + [ii] rng join ecartd.gb /iigg set + [jj] rng join ecartd.gb /jjgg set + save-ecart.autoHomogenize /ecart.autoHomogenize set + } ifelse + + iigg getRing ring_def + + getOptions /ecartd.isSameIdeal_h.opt set + + /ans 1 def + iigg 0 get /iigg set + jjgg 0 get /jjgg set + %%Bug: not implemented for the case of module. + /ecartd.isSameIdeal_h.gb [iigg jjgg] def + + /save-ecart.message.quiet ecart.message.quiet def + /ecart.message.quiet 1 def + gb.verbose { (Comparing) message iigg message (and) message jjgg message } + { } ifelse + gb.verbose { ( ii < jj ?) messagen } { } ifelse + /ecartd.isSameIdeal_h.failed [ ] def + iigg length /n set + 0 1 n 1 sub { + /k set + iigg k get + [jjgg] ecartd.reduction 0 get + (0). eq not { + /ecartd.isSameIdeal_h.failed [ iigg k get jjgg] def + /ans 0 def /LLL.ecartd.isSame_h goto + } { } ifelse + gb.verbose { (o) messagen } { } ifelse + } for + gb.verbose { ( jj < ii ?) messagen } { } ifelse + jjgg length /n set + 0 1 n 1 sub { + /k set + jjgg k get + [iigg] ecartd.reduction 0 get + (0). eq not { + /ecartd.isSameIdeal_h.failed [ iigg jjgg k get] def + /ans 0 def /LLL.ecartd.isSame_h goto + } { } ifelse + gb.verbose { (o) messagen } { } ifelse + } for + /LLL.ecartd.isSame_h + gb.verbose { ( Done) message } { } ifelse + save-ecart.message.quiet /ecart.message.quiet set + ecartd.isSameIdeal_h.opt restoreOptions + /arg1 ans def + ] pop + popEnv + popVariables + arg1 +} def +(ecartd.isSameIdeal_h ) messagen-quiet + +[(ecartd.isSameIdeal_h) +[([ii jj vv] ecartd.isSameIdeal_h bool) + (ii, jj : ideal, vv : variables) + $The ideals ii and jj will be compared in the ring h[0,1](D_0).$ + $ii and jj are re-parsed.$ + $Example 1: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $ + ( ) + ([ii jj vv vvGlobal] ecartd.isSameIdeal_h bool) + $ Ideals are compared in Q(x')_0 [x''] $ + ( where x'' is specified in vvGlobal.) + (cf. partialEcartGlobalVarX option) + ( ) + $Option list: [(noRecomputation) 1] $ + $Example 2: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $ + $ ecartd.isSameIdeal_h.gb 0 get /ii set $ + $ ecartd.isSameIdeal_h.gb 1 get /jj set $ + $ [ ii jj (x) [[(noRecomputation) 1]] ] ecartd.isSameIdeal_h $ +]] putUsages + +/ecartd.isSameIdeal_noh { + /arg1 set + [/aa /ii /jj /iigg /jjgg /vv /ans /k /n /f + /ecartd.isSameIdeal_h.opt + /save-ecart.autoHomogenize /wv /save-ecart.message.quiet + /vvGlobal /rng /noRecomputation + ] pushVariables + [(CurrentRingp) (Homogenize_vec)] pushEnv + [ + /aa arg1 def + gb.verbose { (Getting in ecartd.isSameIdeal_noh) message } { } ifelse + %% comparison of hilbert series has not yet been implemented. + /save-ecart.message.quiet ecart.message.quiet def + aa length 2 gt { } + { ([ii jj vv] ecartd.isSameIdeal_noh) error } ifelse + /ii aa 0 get def + /jj aa 1 get def + /vv aa 2 get def + + aa length 3 gt { + /vvGlobal aa 3 get def + vvGlobal isString { [vvGlobal to_records pop] /vvGlobal set } + { vvGlobal { toString } map /vvGlobal set } ifelse + } { /vvGlobal [ ] def } ifelse + + ii length 0 eq jj length 0 eq and + { /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse + + [vv vvGlobal] ecart.stdBlockOrder /wv set + vvGlobal length 0 eq { + /rng [vv wv ] def + }{ + /rng [vv wv [(partialEcartGlobalVarX) vvGlobal]] def + } ifelse + + aa (noRecomputation) getNode /noRecomputation set + noRecomputation tag 0 eq { /noRecomputation 0 def } { + /noRecomputation 1 def + } ifelse + noRecomputation { + [ii] /iigg set [jj] /jjgg set + } { + /save-ecart.autoHomogenize ecart.autoHomogenize def + /ecart.autoHomogenize 0 def + [ii] rng join ecartd.gb /iigg set + [jj] rng join ecartd.gb /jjgg set + save-ecart.autoHomogenize /ecart.autoHomogenize set + } ifelse + + iigg getRing ring_def + + getOptions /ecartd.isSameIdeal_h.opt set + + /ans 1 def + iigg 0 get /iigg set + jjgg 0 get /jjgg set + /ecartd.isSameIdeal_noh.gb [iigg jjgg] def + %%Bug: not implemented for the case of module. + + /save-ecart.message.quiet ecart.message.quiet def + /ecart.message.quiet 1 def + gb.verbose { (Comparing) message iigg message (and) message jjgg message } + { } ifelse + gb.verbose { ( ii < jj ?) messagen } { } ifelse + /ecartd.isSameIdeal_noh.failed [ ] def + iigg length /n set + 0 1 n 1 sub { + /k set + iigg k get + [jjgg] ecartd.reduction_noh 0 get + (0). eq not { + /ecartd.isSameIdeal_noh.failed [ iigg k get jjgg] def + /ans 0 def /LLL.ecartd.isSame_noh goto + } { } ifelse + gb.verbose { (o) messagen } { } ifelse + } for + gb.verbose { ( jj < ii ?) messagen } { } ifelse + jjgg length /n set + 0 1 n 1 sub { + /k set + jjgg k get + [iigg] ecartd.reduction_noh 0 get + (0). eq not { + /ecartd.isSameIdeal_noh.failed [ iigg jjgg k get] def + /ans 0 def /LLL.ecartd.isSame_noh goto + } { } ifelse + gb.verbose { (o) messagen } { } ifelse + } for + /LLL.ecartd.isSame_noh + gb.verbose { ( Done) message } { } ifelse + save-ecart.message.quiet /ecart.message.quiet set + ecartd.isSameIdeal_h.opt restoreOptions + /arg1 ans def + ] pop + popEnv + popVariables + arg1 +} def + +[(ecartd.isSameIdeal_noh) +[([ii jj vv] ecartd.isSameIdeal_noh bool) + (ii, jj : ideal, vv : variables) + $The ideals ii and jj will be compared in the ring D_0.$ + $ii and jj are re-parsed.$ + $Example 1: [ [((1-x) Dx + 1)] [((1-x)^2 Dx + (1-x))] (x)] ecartd.isSameIdeal_noh $ + ([ii jj vv vvGlobal] ecartd.isSameIdeal_noh bool) + $ Ideals are compared in Q(x')_0 [x''] $ + ( where x'' is specified in vvGlobal.) + (cf. partialEcartGlobalVarX option, ecartd.reduction_noh, ecartd.isSameIdeal_h) + $Example 2: [ [(1-z) (1-x-y-z)] [(1-x) (1-y)] (x,y,z) [(x)]] $ + $ ecartd.isSameIdeal_noh $ + $Option list: [(noRecomputation) 1] $ + $Example 2': [ [(1-z) (1-x-y-z)] [(1-x) (1-y)] (x,y,z) [(x)]] ecartd.isSameIdeal_noh$ + $ ecartd.isSameIdeal_noh.gb 0 get /ii set $ + $ ecartd.isSameIdeal_noh.gb 1 get /jj set $ + $ [ ii jj (x) [[(noRecomputation) 1]] ] ecartd.isSameIdeal_noh $ +]] putUsages +(ecartd.isSameIdeal_noh ) messagen-quiet + +/ecart.01Order { + /arg1 set + [/in-ecart.01Order /vv /tt /dvv /wv1 /wv2 + ] pushVariables + [ + /vv arg1 def + vv isString { [ vv to_records pop] /vv set } + { } ifelse + vv { toString} map /vv set + + vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set + dvv { 1 } map /wv1 set + /arg1 [wv1] def + ] pop + popVariables + arg1 +} def +/ecart.homogenize01Ideal { + /arg1 set + [/in.ecart.homogenize01Ideal /ll /vv /wv /ans] pushVariables + [ + /ll arg1 0 get def + /vv arg1 1 get def + vv isArray { vv from_records /vv set } { } ifelse + vv ecart.01Order /wv set + [vv ring_of_differential_operators 0] define_ring + ll ___ /ll set ll dehomogenize /ll set + [ll vv wv] gb 0 get /ll set + + ecart.begin + [vv ring_of_differential_operators + vv ecart.stdOrder weight_vector 0 + [(weightedHomogenization) 1]] define_ring + ll ___ {ecart.homogenize01 ecart.dehomogenizeH} map /ans set + ecart.end + /arg1 ans def + ] pop + popVariables + arg1 +} def +[(ecart.homogenize01Ideal) +[([ii vv] ecartd.homogenize01Ideal) + (ii : ideal, vv : variables) + $The ideal ii is homogenized in h[0,1](D).$ + $Example 1: [ [((1-x) Dx + 1)] (x)] ecart.homogenize01Ideal $ +]] putUsages + +% Example: [(x,y,z) (x)] ecart.stdBlockOrder +% [[(Dy) 1 (Dz) 1] [(y) -1 (z) -1 (Dy) 1 (Dz) 1] [(x) 1 (Dx) 1]] +% Example: [(x,y,z) [ ]] ecart.stdBlockOrder +/ecart.stdBlockOrder { + /arg1 set + [/vv /vvGlobal /tt /dd /rr] pushVariables + [ + /vv arg1 0 get def + /vvGlobal arg1 1 get def + { + vv isArray + { } { [vv to_records pop] /vv set } ifelse + vv {toString} map /vv set + vvGlobal isArray + { } { [vvGlobal to_records pop] /vvGlobal set } ifelse + vvGlobal {toString} map /vvGlobal set + + vvGlobal length 0 eq { + vv ecart.stdOrder /rr set exit + } { } ifelse + + vv vvGlobal setMinus /vv set + vv ecart.stdOrder /rr set + + vvGlobal { /tt set [@@@.Dsymbol tt] cat } map /dd set + [[ + 0 1 vvGlobal length 1 sub { + /tt set + vvGlobal tt get , 1 + } for + 0 1 dd length 1 sub { + /tt set + dd tt get , 1 + } for + ]] rr join /rr set + exit + } loop + /arg1 rr def + ] pop + popVariables + arg1 +} def + ( ) message-quiet +/ecart_loaded 1 def \ No newline at end of file