===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.6
retrieving revision 1.22
diff -u -p -r1.6 -r1.22
--- OpenXM/src/kan96xx/Doc/ecart.sm1 2003/08/13 03:52:25 1.6
+++ OpenXM/src/kan96xx/Doc/ecart.sm1 2004/05/05 06:57:09 1.22
@@ -1,4 +1,4 @@
-% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.5 2003/08/04 11:42:42 takayama Exp $
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.21 2004/05/04 08:29:35 takayama Exp $
%[(parse) (hol.sm1) pushfile] extension
%[(parse) (appell.sm1) pushfile] extension
@@ -7,7 +7,75 @@
/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.message.quiet 0 def
+/ecart.message {
+ ecart.message.quiet { pop } { message } ifelse
+} def
+/ecart.messagen {
+ ecart.message.quiet { pop } { messagen } ifelse
+} 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 +129,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
@@ -78,32 +153,40 @@
( [(h) 1 (Dx1) 1 (Dx2) 1] )
( [(Dx1) 1 (Dx2) 1] )
( [(x1) -1 (x2) -1])
- ( ] weight_vector )
+ ( ] ecart.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 +216,83 @@
arg1
} def
+/ecart.gb {ecartd.gb} def
+
+[(ecartd.gb)
+[(See ecart.gb)]] putUsages
+
+[(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), 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 ; $
+ (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 +326,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,23 +366,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
@@ -273,33 +420,56 @@
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.
@@ -321,50 +491,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 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 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] [(x) -1 (y) -1 (Dx) 1 (Dy) 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) $
- $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecart.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.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
@@ -387,12 +558,14 @@
(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 )
@@ -417,7 +590,7 @@
[(CurrentRingp) (KanGBmessage)] pushEnv
[
/aa arg1 def
- aa isArray { } { ( << array >> gb) error } ifelse
+ aa isArray { } { ( << array >> ecartn.gb) error } ifelse
/setarg 0 def
/wv 0 def
/degreeShift 0 def
@@ -455,18 +628,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
@@ -493,21 +667,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
@@ -567,12 +741,16 @@
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 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.
@@ -601,14 +779,18 @@
[/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 >> gb) error } ifelse
+ 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
@@ -643,18 +825,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
@@ -663,7 +846,7 @@
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 {
@@ -681,18 +864,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
@@ -723,19 +906,41 @@
%%BUG: case of v is integer
v ecart.checkOrder
- ecart.begin
- [(EcartAutomaticHomogenization) 1] system_variable
+ ecartd.begin
- ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
+ ecart.gb.verbose { (gb.options = ) ecart.messagen gb.options ecart.message } { } ifelse
- f { {. ecart.dehomogenize} map} map /f set
- f ecart.homogenize01 /f set
- f { { [[(H). (1).]] replace } map } map /f set
+ 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) ecart.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.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 {
@@ -743,12 +948,17 @@
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 pmat ;
} {
wv isInteger {
/ans [gg gg {init} map] def
}{
- /ans [gg gg {wv 0 get weightv 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.
@@ -759,8 +969,7 @@
ifelse
} ifelse
- ecart.end
- [(EcartAutomaticHomogenization) 0] system_variable
+ ecartd.end
%%
env1 restoreOptions %% degreeShift changes "grade"
@@ -830,6 +1039,743 @@
(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 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 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
+ [/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 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.)
+ (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
+
+/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
+ /arg1 [wv1 wv2 ] def
+ ] 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
+ ] 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 3 eq { }
+ { ([ii jj vv] ecartd.isSameIdeal_h) error } ifelse
+ /ii aa 0 get def
+ /jj aa 1 get def
+ /vv aa 2 get def
+ ii length 0 eq jj length 0 eq and
+ { /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse
+
+ vv ecart.stdOrder /wv set
+
+ /save-ecart.autoHomogenize ecart.autoHomogenize def
+ /ecart.autoHomogenize 0 def
+ [ii vv wv] ecartd.gb /iigg set
+ [jj vv wv] ecartd.gb /jjgg set
+ save-ecart.autoHomogenize /ecart.autoHomogenize set
+
+ 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.
+
+ /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
+ iigg length /n set
+ 0 1 n 1 sub {
+ /k set
+ iigg k get
+ [jjgg vv wv] ecartd.reduction 0 get
+ (0). eq not { /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 vv wv] ecartd.reduction 0 get
+ (0). eq not { /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).$
+ $ii and jj are re-parsed.$
+ $Example 1: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $
+]] putUsages
+
+
( ) message-quiet