% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.6 2003/08/13 03:52:25 takayama Exp $ %[(parse) (hol.sm1) pushfile] extension %[(parse) (appell.sm1) pushfile] extension (ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet /ecart.begin { beginEcart } def /ecart.end { endEcart } def /ecart.autoHomogenize 1 def /ecart.needSyz 0 def /ecart.dehomogenize { /arg1 set [/in.ecart.dehomogenize /ll /rr] pushVariables [ /ll arg1 def ll tag 6 eq { ll { ecart.dehomogenize } map /ll set } { ll (0). eq { } { ll getRing /rr set ll [ [ (H) rr ,, (1) rr ,, ] [ (h) rr ,, (1) rr ,, ]] replace /ll set } ifelse } ifelse /arg1 ll def ] pop popVariables arg1 } def [(ecart.dehomogenize) [(obj ecart.dehomogenize r) (h->1, H->1) ]] putUsages /ecart.dehomogenizeH { /arg1 set [/in.ecart.dehomogenize /ll /rr] pushVariables [ /ll arg1 def ll tag 6 eq { ll { ecart.dehomogenize } map /ll set } { ll (0). eq { } { ll getRing /rr set ll [ [ (H) rr ,, (1) rr ,, ] ] replace /ll set } ifelse } ifelse /arg1 ll def ] pop popVariables arg1 } def [(ecart.dehomogenizeH) [(obj ecart.dehomogenizeH r) (H->1, h is not changed.) ]] putUsages /ecart.homogenize01 { /arg1 set [/in.ecart.homogenize01 /ll ] pushVariables [ /ll arg1 def [(degreeShift) [ ] ll ] homogenize /arg1 set ] pop popVariables arg1 } def [(ecart.homogenize01) [(obj ecart.homogenize01 r) (Example: ) ( [(x1,x2) ring_of_differential_operators ) ( [[(H) 1 (h) 1 (x1) 1 (x2) 1] ) ( [(h) 1 (Dx1) 1 (Dx2) 1] ) ( [(Dx1) 1 (Dx2) 1] ) ( [(x1) -1 (x2) -1]) ( ] weight_vector ) ( 0 ) ( [(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) ( [eqs2] groebner ) ]] putUsages /ecart.homogenize01_with_shiftVector { /arg2.set /arg1 set [/in.ecart.homogenize01 /ll /sv] pushVariables [ /sv arg2 def /ll arg1 def [(degreeShift) sv ll ] homogenize /arg1 set ] pop popVariables arg1 } def [(ecart.dehomogenize01_with_degreeShift) [(obj shift-vector ecart.dehomogenize01_with_degreeShift r) ]] putUsages %% Aux functions to return the default weight vectors. /ecart.wv1 { /arg1 set [/in.ecart.wv1 /v] pushVariables [ /v arg1 def [(H) (h) v to_records pop] /v set v { 1 } map /v set /arg1 v def ] pop popVariables arg1 } def /ecart.wv2 { /arg1 set [/in.ecart.wv2 /v] pushVariables [ /v arg1 def [v to_records pop] /v set v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set [(h) 1 ] v join /v set /arg1 v def ] pop popVariables arg1 } def /ecart.gb.verbose 1 def /ecart.gb { /arg1 set [/in-ecart.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 >> 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 /degreeShift aa 3 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 /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 wv 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 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 for automatic homogenization: ) 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 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.) 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 }{ /ans [gg gg {wv 0 get weightv init} map] def }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 (ecart.gb ) messagen-quiet [(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 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 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.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 ;$ ( ) $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $ $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.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] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.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] ] ] ecart.gb pmat ; (buggy infinite loop)$ ( ) (cf. gb, groebner, 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 [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables [ /ff arg1 def /ecart.save.needSyz ecart.needSyz def /ecart.needSyz 1 def ff ecart.gb /ff.ans set /ecart.needSyz ecart.save.needSyz def /arg1 ff.ans def ] pop popVariables arg1 } def (ecart.syz ) messagen-quiet [(ecart.syz) [(a ecart.syz b) (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 $ $ ff 0 get ff 3 get mul pmat $ $ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $ ( ) $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 ; $ ( ) (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 >> 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 /degreeShift aa 3 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 /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 }{ /ans [gg gg {wv 0 get weightv init} map] def }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 ] pushVariables [(CurrentRingp) (KanGBmessage)] pushEnv [ /aa arg1 def aa isArray { } { ( << array >> 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 /degreeShift aa 3 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 /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 ecart.begin [(EcartAutomaticHomogenization) 1] system_variable ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse f { {. ecart.dehomogenize} map} map /f set f ecart.homogenize01 /f set f { { [[(H). (1).]] replace } map } map /f set 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 }{ /ans [gg gg {wv 0 get weightv init} map] def }ifelse %% Postprocess : recover the matrix expression. mm { ans { /tmp set [mm tmp] toVectors } map /ans set }{ } ifelse } ifelse ecart.end [(EcartAutomaticHomogenization) 0] system_variable %% 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 ( ) message-quiet