File: [local] / OpenXM / src / kan96xx / Doc / ecart.sm1 (download)
Revision 1.19, Thu Apr 29 12:04:45 2004 UTC (20 years, 1 month ago) by takayama
Branch: MAIN
Changes since 1.18: +108 -2
lines
New macro:
f basis ecartd.reduction r
Divide f by basis by the tangent cone reduction.
|
% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.19 2004/04/29 12:04:45 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
/ecartd.begin {
ecart.begin
[(EcartAutomaticHomogenization) 1] system_variable
} def
/ecartd.end {
ecart.end
[(EcartAutomaticHomogenization) 0] system_variable
} def
/ecart.setOpt {
/arg1 set
[/in-ecart.setOpt /opt /i /n /ans] pushVariables
[
/opt arg1 def
/ans [ ] def
/n opt length def
0 2 n 1 sub {
/i set
opt i get tag StringP eq not {
(ecart.setOpt : [keyword value keyword value ....] ) error
} { } ifelse
{ % start of the loop
% Global: degreeShift
opt i get (degreeShift) eq {
/degreeShift opt i 1 add get def
exit
} { } ifelse
% Global: hdShift
opt i get (startingShift) eq {
/hdShift opt i 1 add get def
exit
} { } ifelse
% Global: hdShift
opt i get (noAutoHomogenize) eq {
/hdShift -1 def
exit
} { } ifelse
% Global: ecart.useSugar
opt i get (sugar) eq {
/ecart.useSugar opt i 1 add get def
exit
} { } ifelse
ans [opt i get opt i 1 add get ] append /ans set
exit
} loop
} for
ecart.gb.verbose {
(ecart.setOpt:) message
(degreeShift=) messagen degreeShift message
$hdShift(startingShift)=$ messagen hdShift message
(sugar=) messagen ecart.useSugar message
(Other options=) messagen ans message
} { } ifelse
/arg1 ans def
] pop
popVariables
arg1
} def
/ecart.dehomogenize {
/arg1 set
[/in.ecart.dehomogenize /ll /rr] pushVariables
[
/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 /ll0] pushVariables
[
/ll arg1 def
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
} 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])
( ] ecart.weight_vector )
( 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} map /eqs2 set)
( [eqs2] groebner )
]] putUsages
/ecart.homogenize01_with_shiftVector {
/arg2.set
/arg1 set
[/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
[
/sv arg2 def
/ll arg1 def
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.
/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 {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 <<a>> 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
%ecarth.gb s(H)-homogenized outputs. GG's original version of ecart gb.
/ecarth.gb {
/arg1 set
[/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 >> 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
/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
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
/env1 getOptions def
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
%%% 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 ] ecart.weight_vector
gb.characteristic
opt
] define_ring
}{
degreeShift isInteger {
[v ring_of_differential_operators
% [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 ecart.weight_vector
wv ecart.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
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
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 {
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
(ecarth.gb ) messagen-quiet
[(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.)
$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 <<a>> 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 )
( )
(/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]] ] 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]]] 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] ] ] 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]] ] 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] ] $
$ [(degreeShift) [[0 1] [-3 1] ]] ] ecarth.gb pmat ; $
( )
(cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
( ecart.dehomogenize, ecart.dehomogenizeH)
( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
( define_ring )
]] putUsages
/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] [(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) $
$ [ [(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
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
/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 ] ecart.weight_vector
gb.characteristic
opt
] define_ring
}{
degreeShift isInteger {
[v ring_of_differential_operators
[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 ecart.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
/ecart.useSugar
] 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
/ecart.useSugar 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
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
/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 ecart.weight_vector
gb.characteristic
opt
] define_ring
}{
[v ring_of_differential_operators
wv ecart.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.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 {
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 [(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.)
(r is the return value format of reduction.)
(basis is the argument format of ecartd.gb.)
(The first element of basis must be a standard basis.)
(cf. reduction, ecartd.gb, ecartd.reduction.test )
$Example:$
$ [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] $
$ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
$ (Dx+Dy) ggg ecartd.reduction :: $
]] putUsages
( ) message-quiet
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to ecart.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc