File: [local] / OpenXM / src / kan96xx / Doc / ecart.sm1 (download)
Revision 1.40, Sun Aug 26 01:38:02 2012 UTC (11 years, 9 months ago) by takayama
Branch: MAIN
CVS Tags: RELEASE_1_3_1_13b, HEAD
Changes since 1.39: +2 -1
lines
Fixed a typo in the example of ecart.homogenize01.
|
% $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.40 2012/08/26 01:38:02 takayama Exp $
(hol_loaded) boundp { }
{ [(parse) (hol.sm1) pushfile] extension } ifelse
%[(parse) (appell.sm1) pushfile] extension
(ecart.sm1 : ecart division for D, 2003/07/25, 2004/09/14 ) message-quiet
/ecart.begin { beginEcart } def
/ecart.end { endEcart } def
/ecart.autoHomogenize 1 def
/ecart.needSyz 0 def
/ecartd.gb.oxRingStructure [[ ] [ ] ] def
/ecart.partialEcartGlobalVarX [ ] def
/ecart.gb.verbose 1 def
/ecart.message.quiet 0 def
/ecartd.begin {
ecart.begin
[(EcartAutomaticHomogenization) 1] system_variable
} def
/ecartd.end {
ecart.end
[(EcartAutomaticHomogenization) 0] system_variable
} def
/ecart.message {
ecart.message.quiet { pop } { message } ifelse
} def
/ecart.messagen {
ecart.message.quiet { pop } { messagen } ifelse
} def
/ecart.setOpt.init {
% Initialize
/ecart.partialEcartGlobalVarX [ ] def
} def
/ecart.setOpt {
/arg1 set
[/in-ecart.setOpt /opt /i /n /ans] pushVariables
[
/opt arg1 def
/ans [ ] def
/n opt length def
ecart.setOpt.init
0 2 n 1 sub {
/i set
opt i get tag StringP eq not {
(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
% Global: ecart.partialEcartGlobalVarX
opt i get (partialEcartGlobalVarX) eq {
/ecart.partialEcartGlobalVarX opt , i 1 add , get def
% do not exit.
} { } ifelse
ans [opt i get opt i 1 add get ] join /ans set
exit
} loop
} for
ecart.gb.verbose {
(ecart.setOpt:) ecart.message
(degreeShift=) ecart.messagen degreeShift ecart.message
$hdShift(startingShift)=$ ecart.messagen hdShift ecart.message
(sugar=) ecart.messagen ecart.useSugar ecart.message
(Other options=) ecart.messagen ans ecart.message
} { } ifelse
/arg1 ans def
] 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 [ [ @@@.Hsymbol 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 [ [ @@@.Hsymbol 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: )
$(appell.sm1) run ; $
( [(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
[@@@.Hsymbol (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
[(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 <<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 $
( ecartd.gb.oxRingStructure )
( )
$Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
$ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
(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 ; $
( )
$Example 6: [ [(1-z) (-x+1-y-z)] (x,y,z) $
$ [[(y) -1 (z) -1 (Dy) 1 (Dz) 1] [(x) 1 (Dx) 1]] $
$ [(partialEcartGlobalVarX) [(x)]] ] /std set $
$ std ecart.gb pmat ; $
$ std ecart.gb getRing :: $
( )
(cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
( ecart.dehomogenize, ecart.dehomogenizeH)
( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
( define_ring )
(/ecart.autoHomogenize 0 def )
( not to dehomogenize and homogenize)
]] putUsages
%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
ecart.setOpt.init
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.partialEcartGlobalVarX] 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
ecart.setOpt.init
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.partialEcartGlobalVarX] 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
ecart.setOpt.init
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).$ ecart.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 a 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.partialEcartGlobalVarX] ecart.checkOrder
ecartd.begin
ecart.gb.verbose { (gb.options = ) ecart.messagen gb.options ecart.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) ecart.message
f { {. ecart.dehomogenize} map} map /f set
f ecart.homogenize01 /f set
f { { [[@@@.Hsymbol . (1).]] replace } map } map /f set
} ifelse
} {
% Automatic h-homogenization with degreeShift
(ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
f { {. ecart.dehomogenize} map} map /f set
f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
f { { [[@@@.Hsymbol . (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
ans getRing (oxRingStructure) dc /ecartd.gb.oxRingStructure set
%%
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
[/vv] pushVariables
[
/vv arg1 def
vv length 1 eq {
vv 0 get ecart.checkOrder.noGlobal /arg1 set
}{
vv ecart.checkOrder.global /arg1 set
} ifelse
] pop
popVariables
/arg1
} def
/ecart.checkOrder.noGlobal {
/arg1 set
[/vv /tt /dd /n /i] pushVariables
[
/vv arg1 def
vv isArray
{ } { [vv to_records pop] /vv set } ifelse
vv {toString} map /vv set
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.global {
/arg1 set
[/vv /vvGlobal /tt /dd /n /i] pushVariables
[
/vv arg1 def
/vvGlobal vv 1 get def
vv 0 get /vv set
vv isArray
{ } { [vv to_records pop] /vv set } ifelse
vv {toString} map /vv set
vvGlobal isArray
{ } { [vvGlobal to_records pop] /vvGlobal set } ifelse
vvGlobal {toString} map /vvGlobal set
vv vvGlobal setMinus /vv set
vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
% Starting the checks. Check for local variables.
0 1 vv length 1 sub {
/i set
vv i get . dd i get . mul /tt set
tt @@@.hsymbol . add init tt eq { }
{ [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
} for
0 1 vv length 1 sub {
/i set
vv i get . /tt set
tt (1). add init (1). eq { }
{ [vv i get ( is larger than 1 ) ] cat error} ifelse
} for
% check for global variables.
0 1 vvGlobal length 1 sub {
/i set
vvGlobal i get . /tt set
tt (1). add init (1). eq { [vvGlobal i get ( is smaller than 1 ) ] cat error }
{ } ifelse
} for
/arg1 1 def
] pop
popVariables
arg1
} def
[(ecart.checkOrder)
[([v vGlobal] 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
w-vectors to_int32 /w-vectors set
[
0 1 << w-vectors length 1 sub >>
{
/k set
univ w-vectors k get w_to_vec
} for
] /order1 set
%% order1 ::
vars ( ) ecart.elimination_order 3 get /order2 set
vars [ << order1 order2 join >> ] join /arg1 set
] pop
popVariables
arg1
} def
%% end of for ecart.define_ring
/ecartd.reduction {
/arg2 set
/arg1 set
[/in-ecartd.reduction /gbasis /flist /ans /gbasis2] pushVariables
[(CurrentRingp) (KanGBmessage)] pushEnv
[
/gbasis arg2 def
/flist arg1 def
gbasis 0 get tag 6 eq { }
{ (ecartd.reduction: the second argument must be a list of lists) error }
ifelse
gbasis length 1 eq {
gbasis getRing ring_def
/gbasis2 gbasis 0 get def
} {
[ [(1)] ] gbasis rest join ecartd.gb 0 get getRing ring_def
/gbasis2 gbasis 0 get ___ def
} ifelse
ecartd.begin
flist ___ /flist set
flist tag 6 eq {
flist { gbasis2 reduction } map /ans set
}{
flist gbasis2 reduction /ans set
} ifelse
/arg1 ans def
ecartd.end
] pop
popEnv
popVariables
arg1
} def
/ecartd.reduction.test {
[
[( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
(x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
ecartd.gb /gg set
(Dx) [gg 0 get] ecartd.reduction /gg2 set
gg2 message
(-----------------------------) message
[(Dx) (Dy) (Dx+x*Dy)] [gg 0 get] ecartd.reduction /gg3 set
gg3 message
(-----------------------------) message
[[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )]
(x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
(Dx) ggg ecartd.reduction /gg4 set
gg4 message
(----------- reduction by h=1 ---------------) message
[[( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
(x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
[(Homogenize) 0] system_variable
(Dx) ggg ecartd.reduction /gg5 set
[(Homogenize) 1] system_variable
gg5 message
[gg2 gg3 gg4 gg5]
} def
/ecarth.reduction {
/arg2 set
/arg1 set
[/in-ecarth.reduction /gbasis /flist /ans /gbasis2] pushVariables
[(CurrentRingp) (KanGBmessage)] pushEnv
[
/gbasis arg2 def
/flist arg1 def
gbasis 0 get tag 6 eq { }
{ (ecarth.reduction: the second argument must be a list of lists) error }
ifelse
gbasis length 1 eq {
gbasis getRing ring_def
/gbasis2 gbasis 0 get def
} {
[ [(1)] ] gbasis rest join ecarth.gb 0 get getRing ring_def
/gbasis2 gbasis 0 get ___ def
} ifelse
ecarth.begin
flist ___ /flist set
flist tag 6 eq {
flist { gbasis2 reduction } map /ans set
}{
flist gbasis2 reduction /ans set
} ifelse
/arg1 ans def
ecarth.end
] pop
popEnv
popVariables
arg1
} def
[(ecartd.reduction)
[ (f basis ecartd.reduction r)
(f is reduced by basis by the tangent cone algorithm.)
(The first element of basis <g_1,...,g_m> must be a standard basis.)
(r is the return value format of reduction.)
(r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
(basis is given in the argument format of ecartd.gb.)
$h[0,1](D)-homogenization is used.$
(cf. reduction, ecartd.gb, ecartd.reduction.test )
$Example:$
$ [[( 2*(1-x-y) Dx + h ) ( 2*(1-x-y) Dy + h )] $
$ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
$ (Dx+Dy) ggg ecartd.reduction :: $
]] putUsages
/ecartd.reduction_noh {
/arg2 set
/arg1 set
[/in-ecarth.reduction_noh /gbasis /flist] pushVariables
[(Homogenize)] pushEnv
[
/gbasis arg2 def
/flist arg1 def
[(Homogenize) 0] system_variable
flist gbasis ecartd.reduction /arg1 set
] pop
popEnv
popVariables
arg1
} def
[(ecartd.reduction_noh)
[ (f basis ecartd.reduction_noh r)
(f is reduced by basis by the tangent cone algorithm.)
(The first element of basis <g_1,...,g_m> must be a standard basis.)
(r is the return value format of reduction.)
(r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
(basis is given in the argument format of ecartd.gb and)
(it should not contain the variable h. cf. dehomogenize)
$h[0,1](D)-homogenization is NOT used.$
(cf. reduction, ecartd.gb, ecartd.reduction )
$Example:$
$ [[( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )] $
$ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
$ (Dx+Dy) ggg ecartd.reduction_noh :: $
]] putUsages
/ecart.stdOrder {
/arg1 set
[/in-ecart.stdOrder /vv /tt /dvv /wv1 /wv2
] pushVariables
[
/vv arg1 def
vv isString { [ vv to_records pop] /vv set }
{ } ifelse
vv { toString} map /vv set
vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set
dvv { 1 } map /wv1 set
vv { -1 } map dvv { 1 } map join /wv2 set
vv length 0 eq {
/arg1 [ ] def
} {
/arg1 [wv1 wv2 ] def
} ifelse
] pop
popVariables
arg1
} def
/ecartd.isSameIdeal_h {
/arg1 set
[/in-ecartd.isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
/ecartd.isSameIdeal_h.opt
/save-ecart.autoHomogenize /wv /save-ecart.message.quiet
/vvGlobal /rng /noRecomputation
] pushVariables
[(CurrentRingp) (Homogenize_vec)] pushEnv
[
/aa arg1 def
gb.verbose { (Getting in ecartd.isSameIdeal_h) message } { } ifelse
%% comparison of hilbert series has not yet been implemented.
/save-ecart.message.quiet ecart.message.quiet def
aa length 2 gt { }
{ ([ii jj vv] ecartd.isSameIdeal_h) error } ifelse
/ii aa 0 get def
/jj aa 1 get def
/vv aa 2 get def
aa length 3 gt {
/vvGlobal aa 3 get def
vvGlobal isString { [vvGlobal to_records pop] /vvGlobal set }
{ vvGlobal { toString } map /vvGlobal set } ifelse
} { /vvGlobal [ ] def } ifelse
ii length 0 eq jj length 0 eq and
{ /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse
[vv vvGlobal] ecart.stdBlockOrder /wv set
vvGlobal length 0 eq {
/rng [vv wv ] def
}{
/rng [vv wv [(partialEcartGlobalVarX) vvGlobal]] def
} ifelse
aa (noRecomputation) getNode /noRecomputation set
noRecomputation tag 0 eq { /noRecomputation 0 def } {
/noRecomputation 1 def
} ifelse
noRecomputation {
[ii] /iigg set [jj] /jjgg set
} {
/save-ecart.autoHomogenize ecart.autoHomogenize def
/ecart.autoHomogenize 0 def
[ii] rng join ecartd.gb /iigg set
[jj] rng join ecartd.gb /jjgg set
save-ecart.autoHomogenize /ecart.autoHomogenize set
} ifelse
iigg getRing ring_def
getOptions /ecartd.isSameIdeal_h.opt set
/ans 1 def
iigg 0 get /iigg set
jjgg 0 get /jjgg set
%%Bug: not implemented for the case of module.
/ecartd.isSameIdeal_h.gb [iigg jjgg] def
/save-ecart.message.quiet ecart.message.quiet def
/ecart.message.quiet 1 def
gb.verbose { (Comparing) message iigg message (and) message jjgg message }
{ } ifelse
gb.verbose { ( ii < jj ?) messagen } { } ifelse
/ecartd.isSameIdeal_h.failed [ ] def
iigg length /n set
0 1 n 1 sub {
/k set
iigg k get
[jjgg] ecartd.reduction 0 get
(0). eq not {
/ecartd.isSameIdeal_h.failed [ iigg k get jjgg] def
/ans 0 def /LLL.ecartd.isSame_h goto
} { } ifelse
gb.verbose { (o) messagen } { } ifelse
} for
gb.verbose { ( jj < ii ?) messagen } { } ifelse
jjgg length /n set
0 1 n 1 sub {
/k set
jjgg k get
[iigg] ecartd.reduction 0 get
(0). eq not {
/ecartd.isSameIdeal_h.failed [ iigg jjgg k get] def
/ans 0 def /LLL.ecartd.isSame_h goto
} { } ifelse
gb.verbose { (o) messagen } { } ifelse
} for
/LLL.ecartd.isSame_h
gb.verbose { ( Done) message } { } ifelse
save-ecart.message.quiet /ecart.message.quiet set
ecartd.isSameIdeal_h.opt restoreOptions
/arg1 ans def
] pop
popEnv
popVariables
arg1
} def
(ecartd.isSameIdeal_h ) messagen-quiet
[(ecartd.isSameIdeal_h)
[([ii jj vv] ecartd.isSameIdeal_h bool)
(ii, jj : ideal, vv : variables)
$The ideals ii and jj will be compared in the ring h[0,1](D_0).$
$ii and jj are re-parsed.$
$Example 1: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $
( )
([ii jj vv vvGlobal] ecartd.isSameIdeal_h bool)
$ Ideals are compared in Q(x')_0 [x''] <Dx',Dx'',h> $
( where x'' is specified in vvGlobal.)
(cf. partialEcartGlobalVarX option)
( )
$Option list: [(noRecomputation) 1] $
$Example 2: [ [((1-x) Dx + h)] [((1-x)^2 Dx + h (1-x))] (x)] ecartd.isSameIdeal_h $
$ ecartd.isSameIdeal_h.gb 0 get /ii set $
$ ecartd.isSameIdeal_h.gb 1 get /jj set $
$ [ ii jj (x) [[(noRecomputation) 1]] ] ecartd.isSameIdeal_h $
]] putUsages
/ecartd.isSameIdeal_noh {
/arg1 set
[/aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
/ecartd.isSameIdeal_h.opt
/save-ecart.autoHomogenize /wv /save-ecart.message.quiet
/vvGlobal /rng /noRecomputation
] pushVariables
[(CurrentRingp) (Homogenize_vec)] pushEnv
[
/aa arg1 def
gb.verbose { (Getting in ecartd.isSameIdeal_noh) message } { } ifelse
%% comparison of hilbert series has not yet been implemented.
/save-ecart.message.quiet ecart.message.quiet def
aa length 2 gt { }
{ ([ii jj vv] ecartd.isSameIdeal_noh) error } ifelse
/ii aa 0 get def
/jj aa 1 get def
/vv aa 2 get def
aa length 3 gt {
/vvGlobal aa 3 get def
vvGlobal isString { [vvGlobal to_records pop] /vvGlobal set }
{ vvGlobal { toString } map /vvGlobal set } ifelse
} { /vvGlobal [ ] def } ifelse
ii length 0 eq jj length 0 eq and
{ /ans 1 def /LLL.ecartd.isSame_h goto } { } ifelse
[vv vvGlobal] ecart.stdBlockOrder /wv set
vvGlobal length 0 eq {
/rng [vv wv ] def
}{
/rng [vv wv [(partialEcartGlobalVarX) vvGlobal]] def
} ifelse
aa (noRecomputation) getNode /noRecomputation set
noRecomputation tag 0 eq { /noRecomputation 0 def } {
/noRecomputation 1 def
} ifelse
noRecomputation {
[ii] /iigg set [jj] /jjgg set
} {
/save-ecart.autoHomogenize ecart.autoHomogenize def
/ecart.autoHomogenize 0 def
[ii] rng join ecartd.gb /iigg set
[jj] rng join ecartd.gb /jjgg set
save-ecart.autoHomogenize /ecart.autoHomogenize set
} ifelse
iigg getRing ring_def
getOptions /ecartd.isSameIdeal_h.opt set
/ans 1 def
iigg 0 get /iigg set
jjgg 0 get /jjgg set
/ecartd.isSameIdeal_noh.gb [iigg jjgg] def
%%Bug: not implemented for the case of module.
/save-ecart.message.quiet ecart.message.quiet def
/ecart.message.quiet 1 def
gb.verbose { (Comparing) message iigg message (and) message jjgg message }
{ } ifelse
gb.verbose { ( ii < jj ?) messagen } { } ifelse
/ecartd.isSameIdeal_noh.failed [ ] def
iigg length /n set
0 1 n 1 sub {
/k set
iigg k get
[jjgg] ecartd.reduction_noh 0 get
(0). eq not {
/ecartd.isSameIdeal_noh.failed [ iigg k get jjgg] def
/ans 0 def /LLL.ecartd.isSame_noh goto
} { } ifelse
gb.verbose { (o) messagen } { } ifelse
} for
gb.verbose { ( jj < ii ?) messagen } { } ifelse
jjgg length /n set
0 1 n 1 sub {
/k set
jjgg k get
[iigg] ecartd.reduction_noh 0 get
(0). eq not {
/ecartd.isSameIdeal_noh.failed [ iigg jjgg k get] def
/ans 0 def /LLL.ecartd.isSame_noh goto
} { } ifelse
gb.verbose { (o) messagen } { } ifelse
} for
/LLL.ecartd.isSame_noh
gb.verbose { ( Done) message } { } ifelse
save-ecart.message.quiet /ecart.message.quiet set
ecartd.isSameIdeal_h.opt restoreOptions
/arg1 ans def
] pop
popEnv
popVariables
arg1
} def
[(ecartd.isSameIdeal_noh)
[([ii jj vv] ecartd.isSameIdeal_noh bool)
(ii, jj : ideal, vv : variables)
$The ideals ii and jj will be compared in the ring D_0.$
$ii and jj are re-parsed.$
$Example 1: [ [((1-x) Dx + 1)] [((1-x)^2 Dx + (1-x))] (x)] ecartd.isSameIdeal_noh $
([ii jj vv vvGlobal] ecartd.isSameIdeal_noh bool)
$ Ideals are compared in Q(x')_0 [x''] <Dx',Dx''> $
( where x'' is specified in vvGlobal.)
(cf. partialEcartGlobalVarX option, ecartd.reduction_noh, ecartd.isSameIdeal_h)
$Example 2: [ [(1-z) (1-x-y-z)] [(1-x) (1-y)] (x,y,z) [(x)]] $
$ ecartd.isSameIdeal_noh $
$Option list: [(noRecomputation) 1] $
$Example 2': [ [(1-z) (1-x-y-z)] [(1-x) (1-y)] (x,y,z) [(x)]] ecartd.isSameIdeal_noh$
$ ecartd.isSameIdeal_noh.gb 0 get /ii set $
$ ecartd.isSameIdeal_noh.gb 1 get /jj set $
$ [ ii jj (x) [[(noRecomputation) 1]] ] ecartd.isSameIdeal_noh $
]] putUsages
(ecartd.isSameIdeal_noh ) messagen-quiet
/ecart.01Order {
/arg1 set
[/in-ecart.01Order /vv /tt /dvv /wv1 /wv2
] pushVariables
[
/vv arg1 def
vv isString { [ vv to_records pop] /vv set }
{ } ifelse
vv { toString} map /vv set
vv { /tt set [@@@.Dsymbol tt] cat } map /dvv set
dvv { 1 } map /wv1 set
/arg1 [wv1] def
] pop
popVariables
arg1
} def
/ecart.homogenize01Ideal {
/arg1 set
[/in.ecart.homogenize01Ideal /ll /vv /wv /ans] pushVariables
[
/ll arg1 0 get def
/vv arg1 1 get def
vv isArray { vv from_records /vv set } { } ifelse
vv ecart.01Order /wv set
[vv ring_of_differential_operators 0] define_ring
ll ___ /ll set ll dehomogenize /ll set
[ll vv wv] gb 0 get /ll set
ecart.begin
[vv ring_of_differential_operators
vv ecart.stdOrder weight_vector 0
[(weightedHomogenization) 1]] define_ring
ll ___ {ecart.homogenize01 ecart.dehomogenizeH} map /ans set
ecart.end
/arg1 ans def
] pop
popVariables
arg1
} def
[(ecart.homogenize01Ideal)
[([ii vv] ecartd.homogenize01Ideal)
(ii : ideal, vv : variables)
$The ideal ii is homogenized in h[0,1](D).$
$Example 1: [ [((1-x) Dx + 1)] (x)] ecart.homogenize01Ideal $
]] putUsages
% Example: [(x,y,z) (x)] ecart.stdBlockOrder
% [[(Dy) 1 (Dz) 1] [(y) -1 (z) -1 (Dy) 1 (Dz) 1] [(x) 1 (Dx) 1]]
% Example: [(x,y,z) [ ]] ecart.stdBlockOrder
/ecart.stdBlockOrder {
/arg1 set
[/vv /vvGlobal /tt /dd /rr] pushVariables
[
/vv arg1 0 get def
/vvGlobal arg1 1 get def
{
vv isArray
{ } { [vv to_records pop] /vv set } ifelse
vv {toString} map /vv set
vvGlobal isArray
{ } { [vvGlobal to_records pop] /vvGlobal set } ifelse
vvGlobal {toString} map /vvGlobal set
vvGlobal length 0 eq {
vv ecart.stdOrder /rr set exit
} { } ifelse
vv vvGlobal setMinus /vv set
vv ecart.stdOrder /rr set
vvGlobal { /tt set [@@@.Dsymbol tt] cat } map /dd set
[[
0 1 vvGlobal length 1 sub {
/tt set
vvGlobal tt get , 1
} for
0 1 dd length 1 sub {
/tt set
dd tt get , 1
} for
]] rr join /rr set
exit
} loop
/arg1 rr def
] pop
popVariables
arg1
} def
( ) message-quiet
/ecart_loaded 1 def![[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