===================================================================
RCS file: /home/cvs/OpenXM/src/kan96xx/Doc/ecart.sm1,v
retrieving revision 1.2
retrieving revision 1.13
diff -u -p -r1.2 -r1.13
--- OpenXM/src/kan96xx/Doc/ecart.sm1 2003/07/25 01:03:00 1.2
+++ OpenXM/src/kan96xx/Doc/ecart.sm1 2003/08/26 12:46:03 1.13
@@ -1,4 +1,4 @@
-% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.1 2003/07/25 01:00:38 takayama Exp $
+% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.12 2003/08/26 05:06:00 takayama Exp $
%[(parse) (hol.sm1) pushfile] extension
%[(parse) (appell.sm1) pushfile] extension
@@ -7,6 +7,14 @@
/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.dehomogenize {
/arg1 set
@@ -61,11 +69,18 @@
/ecart.homogenize01 {
/arg1 set
- [/in.ecart.homogenize01 /ll ] pushVariables
+ [/in.ecart.homogenize01 /ll /ll0] pushVariables
[
/ll arg1 def
- [(degreeShift) [ ] ll ] homogenize
- /arg1 set
+ ll tag ArrayP eq {
+ ll 0 get tag ArrayP eq not {
+ [(degreeShift) [ ] ll ] homogenize /arg1 set
+ } {
+ ll { ecart.homogenize01 } map /arg1 set
+ } ifelse
+ } {
+ [(degreeShift) [ ] ll ] homogenize /arg1 set
+ } ifelse
] pop
popVariables
arg1
@@ -80,30 +95,38 @@
( [(x1) -1 (x2) -1])
( ] weight_vector )
( 0 )
- ( [(degreeShift) [[0 0 0]]])
+ ( [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
( ] define_ring)
( ecart.begin)
( [[1 -4 -2 5]] appell4 0 get /eqs set)
( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
- ( ecart.homogenize01 /eqs2 set)
+ ( {ecart.homogenize01} map /eqs2 set)
( [eqs2] groebner )
]] putUsages
/ecart.homogenize01_with_shiftVector {
/arg2.set
/arg1 set
- [/in.ecart.homogenize01 /ll /sv] pushVariables
+ [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
[
/sv arg2 def
/ll arg1 def
- [(degreeShift) sv ll ] homogenize
- /arg1 set
+ ll tag ArrayP eq {
+ ll 0 get tag ArrayP eq not {
+ [(degreeShift) sv ll ] homogenize /arg1 set
+ } {
+ ll { ecart.homogenize01_with_shiftVector } map /arg1 set
+ } ifelse
+ } {
+ [(degreeShift) sv ll ] homogenize /arg1 set
+ } ifelse
] pop
popVariables
arg1
} def
[(ecart.dehomogenize01_with_degreeShift)
[(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
+ (cf. homogenize)
]] putUsages
%% Aux functions to return the default weight vectors.
@@ -133,20 +156,75 @@
arg1
} def
+/ecart.gb {ecartd.gb} def
+
+[(ecart.gb)
+ [(a ecart.gb b)
+ (array a; array b;)
+ $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
+ ( in the ring of differential operators.)
+ (The computation is done by using Ecart division algorithm and )
+ (the double homogenization.)
+ (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
+ $ ii is the initial ideal in case of w is given or <> belongs$
+ $ to a ring. In the other cases, it returns the initial monominal.$
+ (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
+ (a : [f v]; array f; string v; v is the variables. )
+ (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
+ (a : [f v w 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.)
+ ( 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.$
+ ( No automatic homogenization.)
+ ( )
+ $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize) $
+ ( )
+ $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
+ $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
+ (Example 2: )
+ $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
+ $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /ff set ff pmat ;$
+ (To set the current ring to the ring in which ff belongs )
+ ( ff getRing ring_def )
+ ( )
+ $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
+ $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
+ ( This example will cause an error on order.)
+ ( )
+ $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
+ $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
+ ( This example will cause an error on order.)
+ ( )
+ $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
+ $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[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
] 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
aa { tag } map /typev set
typev [ ArrayP ] eq
@@ -188,6 +266,15 @@
/degreeShift aa 3 get def
/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
@@ -195,10 +282,43 @@
/degreeShift aa 3 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
- setarg { } { (ecart.gb : Argument mismatch) error } ifelse
+ ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } { } ifelse
+ setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
[(KanGBmessage) ecart.gb.verbose ] system_variable
@@ -219,22 +339,24 @@
} { } ifelse
wv isInteger {
[v ring_of_differential_operators
- [ v ecart.wv1 v ecart.wv2 ] weight_vector
- 0
+% [ v ecart.wv1 v ecart.wv2 ] weight_vector
+ gb.characteristic
opt
] define_ring
}{
degreeShift isInteger {
[v ring_of_differential_operators
- [v ecart.wv1 v ecart.wv2] wv join weight_vector
- 0
+% [v ecart.wv1 v ecart.wv2] wv join weight_vector
+ wv weight_vector
+ gb.characteristic
opt
] define_ring
}{
[v ring_of_differential_operators
- [v ecart.wv1 v ecart.wv2] wv join weight_vector
- 0
+% [v ecart.wv1 v ecart.wv2] wv join weight_vector
+ wv weight_vector
+ gb.characteristic
[(degreeShift) degreeShift] opt join
] define_ring
@@ -254,7 +376,7 @@
%%% Enf of the preprocess
ecart.gb.verbose {
- (The first and the second weight vectors are automatically set as follows)
+ (The first and the second weight vectors for automatic homogenization: )
message
v ecart.wv1 message
v ecart.wv2 message
@@ -265,19 +387,33 @@
} ifelse
} { } ifelse
+ %%BUG: case of v is integer
+ v ecart.checkOrder
+
ecart.begin
ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
- ecart.autoHomogenize {
- (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
+
+
+ hdShift tag 1 eq {
+ ecart.autoHomogenize not hdShift -1 eq or {
+% No automatic h-s-homogenization.
+ f { {. } map} map /f set
+ } {
+% Automatic h-s-homogenization without degreeShift
+ (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
message
- } { } ifelse
- ecart.autoHomogenize {
- f { {. ecart.dehomogenize} map} map /f set
- f ecart.homogenize01 /f set
- }{
- f { {. } map } map /f set
- } ifelse
+ 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.needSyz {
[f [(needSyz)] gb.options join ] groebner /gg set
} {
@@ -287,14 +423,18 @@
ecart.needSyz {
mm {
gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
- } { /ans.gb gg 0 get def } ifelse
- /ans [gg 2 get , ans.gb , gg 1 get , f ] def
- ans pmat ;
+ } { /ans.gb gg 0 get def } ifelse
+ /ans [gg 2 get , ans.gb , gg 1 get , f ] def
+% ans pmat ;
} {
wv isInteger {
/ans [gg gg {init} map] def
}{
- /ans [gg gg {wv 0 get weightv init} map] def
+ degreeShift isInteger {
+ /ans [gg gg {wv 0 get weightv init} map] def
+ } {
+ /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
+ } ifelse
}ifelse
%% Postprocess : recover the matrix expression.
@@ -316,15 +456,16 @@
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.$
@@ -338,28 +479,27 @@
( not to dehomogenize and homogenize)
( )
$Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
- $ [ [ (Dx) 1 ] ] ] ecart.gb pmat ; $
+ $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
(Example 2: )
(To put H and h=1, type in, e.g., )
$ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
- $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /gg set gg ecart.dehomogenize pmat ;$
+ $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
( )
$Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
- $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
+ $ [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
( )
$Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
- $ [ [ (x) -1 (y) -1] ] ] ecart.gb pmat ; $
+ $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
( )
$Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
- $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.gb pmat ; $
+ $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecarth.gb pmat ; (buggy infinite loop)$
( )
- (cf. gb, groebner, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
+ (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
( ecart.dehomogenize, ecart.dehomogenizeH)
( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
( define_ring )
]] putUsages
-%% BUG: " f weight init " works well in case of vectors with degree shift ?
/ecart.syz {
/arg1 set
@@ -382,16 +522,713 @@
(array a; array b;)
$b : [syzygy gb tmat input]; gb = tmat * input $
$Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
- $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.syz /ff set $
+ $ [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
$ ff 0 get ff 3 get mul pmat $
$ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $
( )
+ (To set the current ring to the ring in which ff belongs )
+ ( ff getRing ring_def )
$Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
- $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $
+ $ [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $
( )
(cf. ecart.gb)
( /ecart.autoHomogenize 0 def )
]] putUsages
+/ecartn.begin {
+ (red@) (standard) switch_function
+%% (red@) (ecart) switch_function
+ [(Ecart) 1] system_variable
+ [(CheckHomogenization) 0] system_variable
+ [(ReduceLowerTerms) 0] system_variable
+ [(AutoReduce) 0] system_variable
+ [(EcartAutomaticHomogenization) 0] system_variable
+} def
+/ecartn.gb {
+ /arg1 set
+ [/in-ecartn.gb /aa /typev /setarg /f /v
+ /gg /wv /vec /ans /rr /mm
+ /degreeShift /env2 /opt /ans.gb
+ ] pushVariables
+ [(CurrentRingp) (KanGBmessage)] pushEnv
+ [
+ /aa arg1 def
+ aa isArray { } { ( << array >> ecartn.gb) error } ifelse
+ /setarg 0 def
+ /wv 0 def
+ /degreeShift 0 def
+ /opt [(weightedHomogenization) 1] def
+ aa { tag } map /typev set
+ typev [ ArrayP ] eq
+ { /f aa 0 get def
+ /v gb.v def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP StringP] eq
+ { /f aa 0 get def
+ /v aa 1 get def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP RingP] eq
+ { /f aa 0 get def
+ /v aa 1 get def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP ArrayP] eq
+ { /f aa 0 get def
+ /v aa 1 get from_records def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP StringP ArrayP] eq
+ { /f aa 0 get def
+ /v aa 1 get def
+ /wv aa 2 get def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP ArrayP ArrayP] eq
+ { /f aa 0 get def
+ /v aa 1 get from_records def
+ /wv aa 2 get def
+ /setarg 1 def
+ } { } ifelse
+ typev [ArrayP StringP ArrayP ArrayP] eq
+ { /f aa 0 get def
+ /v aa 1 get def
+ /wv aa 2 get def
+ /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
+ }{
+ degreeShift isInteger {
+ /ans [gg gg {wv 0 get weightv init} map] def
+ } {
+ /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
+ } ifelse
+ }ifelse
+
+ %% Postprocess : recover the matrix expression.
+ mm {
+ ans { /tmp set [mm tmp] toVectors } map
+ /ans set
+ }{ }
+ ifelse
+ } ifelse
+
+ ecart.end
+
+ %%
+ env1 restoreOptions %% degreeShift changes "grade"
+
+ /arg1 ans def
+ ] pop
+ popEnv
+ popVariables
+ arg1
+} def
+(ecartn.gb[gb by non-ecart division] ) messagen-quiet
+
+/ecartd.gb {
+ /arg1 set
+ [/in-ecart.gb /aa /typev /setarg /f /v
+ /gg /wv /vec /ans /rr /mm
+ /degreeShift /env2 /opt /ans.gb
+ /hdShift
+ ] pushVariables
+ [(CurrentRingp) (KanGBmessage)] pushEnv
+ [
+ /aa arg1 def
+ aa isArray { } { ( << array >> ecartd.gb) error } ifelse
+ /setarg 0 def
+ /wv 0 def
+ /degreeShift 0 def
+ /hdShift 0 def
+ /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
+ 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
+
+ setarg { } { (ecart.gb : Argument mismatch) error } ifelse
+
+ [(KanGBmessage) ecart.gb.verbose ] system_variable
+ $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message
+
+ %%% Start of the preprocess
+ v tag RingP eq {
+ /rr v def
+ }{
+ f getRing /rr set
+ } ifelse
+ %% To the normal form : matrix expression.
+ f gb.toMatrixOfString /f set
+ /mm gb.itWasMatrix def
+
+ rr tag 0 eq {
+ %% Define our own ring
+ v isInteger {
+ (Error in gb: Specify variables) error
+ } { } ifelse
+ wv isInteger {
+ (Give an weight vector such that x < 1) error
+ }{
+ degreeShift isInteger {
+ [v ring_of_differential_operators
+ wv weight_vector
+ gb.characteristic
+ opt
+ ] define_ring
+
+ }{
+ [v ring_of_differential_operators
+ wv weight_vector
+ gb.characteristic
+ [(degreeShift) degreeShift] opt join
+ ] define_ring
+
+ } ifelse
+ } ifelse
+ } {
+ %% Use the ring structre given by the input.
+ v isInteger not {
+ gb.warning {
+ (Warning : the given ring definition is not used.) message
+ } { } ifelse
+ } { } ifelse
+ rr ring_def
+ /wv rr gb.getWeight def
+
+ } ifelse
+ %%% Enf of the preprocess
+
+ ecart.gb.verbose {
+ degreeShift isInteger { }
+ {
+ (The degree shift is ) messagen
+ degreeShift message
+ } ifelse
+ } { } ifelse
+
+ %%BUG: case of v is integer
+ v ecart.checkOrder
+
+ ecartd.begin
+
+ ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
+
+ hdShift tag 1 eq {
+ ecart.autoHomogenize not hdShift -1 eq or {
+% No automatic h-homogenization.
+ f { {. } map} map /f set
+ } {
+% Automatic h-homogenization without degreeShift
+ (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
+ f { {. ecart.dehomogenize} map} map /f set
+ f ecart.homogenize01 /f set
+ f { { [[(H). (1).]] replace } map } map /f set
+ } ifelse
+ } {
+% Automatic h-homogenization with degreeShift
+ (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
+ f { {. ecart.dehomogenize} map} map /f set
+ f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
+ f { { [[(H). (1).]] replace } map } map /f set
+ }ifelse
+
+ ecart.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
+ }{
+%% Get the initial ideal
+ degreeShift isInteger {
+ /ans [gg gg {wv 0 get weightv init} map] def
+ } {
+ /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
+ } ifelse
+ }ifelse
+
+ %% Postprocess : recover the matrix expression.
+ mm {
+ ans { /tmp set [mm tmp] toVectors } map
+ /ans set
+ }{ }
+ ifelse
+ } ifelse
+
+ ecartd.end
+
+ %%
+ env1 restoreOptions %% degreeShift changes "grade"
+
+ /arg1 ans def
+ ] pop
+ popEnv
+ popVariables
+ arg1
+} def
+(ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
+
+/ecart.checkOrder {
+ /arg1 set
+ [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
+ [
+ /vv arg1 def
+ vv isArray
+ { } { [vv to_records pop] /vv set } ifelse
+ vv {toString} map /vv set
+ vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
+ % Starting the checks.
+ 0 1 vv length 1 sub {
+ /i set
+ vv i get . dd i get . mul /tt set
+ tt @@@.hsymbol . add init tt eq { }
+ { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
+ } for
+
+ 0 1 vv length 1 sub {
+ /i set
+ vv i get . /tt set
+ tt (1). add init (1). eq { }
+ { [vv i get ( is larger than 1 ) ] cat error} ifelse
+ } for
+ /arg1 1 def
+ ] pop
+ popVariables
+ arg1
+} def
+[(ecart.checkOrder)
+ [(v ecart.checkOrder bool checks if the given order is relevant)
+ (for the ecart division.)
+ (cf. ecartd.gb, ecart.gb, ecartn.gb)
+ ]
+] putUsages
+
+/ecart.wv_last {
+ /arg1 set
+ [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
+ [
+ /vv arg1 def
+ vv isArray
+ { } { [vv to_records pop] /vv set } ifelse
+ vv {toString} map /vv set
+ vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
+ vv { -1 } map
+ dd { 1 } map join /arg1 set
+ ] pop
+ popVariables
+ arg1
+} def
+[(ecart.wv_last)
+ [(v ecart.wv_last wt )
+ (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
+ (Use this weight vector as the last weight vector for ecart division)
+ (if ecart.checkOrder complains about the order given.)
+ ]
+] putUsages
+
+/ecart.mimimalBase.test {
+ [
+ [ (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
+ [ (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
+ [ (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
+ [ (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
+ [ (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
+ [ (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
+ [ (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
+ [ (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
+ ]
+ /ff set
+
+ /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
+ /shift [ [1 0 1 0 0] ] def
+ /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
+
+ [ff (t,x,y) weight shift 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.minimalBase)
+[([ff v weight_vector degreeShift [D_shift_n uv_shift_m]] ecart.minimalBase mbase)
+]] 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
+ aa { tag } map /typev set
+ 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
+ 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 (no)] 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
+
+ /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 def
+
+ } loop
+ /arg1 ai1 def
+ ] pop
+ popVariables
+ arg1
+} def
+
+
( ) message-quiet
+