%% $OpenXM: OpenXM/src/k097/lib/restriction/Srestall_s.sm1,v 1.2 2015/06/02 02:42:28 takayama Exp $
%% Srestall_s.sm1,
%% Compute the cohomology groups of a free resolution
%% truncated from above by the (-1,1) filtration
%% 2000.8.7 T.Oaku
%% /BFmessage 0 def controlled from cohom.sm1
(Srestall_s.sm1 2000.8.1) message
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% The cohomology groups of the restriction without truncation from below
%% resolution [variables] [initial plane] k1 Srestall1
%% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
1 /BFunknowns set %% the number of the unknown functions
%% assumed 1 here
/Srestall1 {
% /arg5 set %% degmax
/arg4 set %% k1
/arg3 set %% [(t1) ... (td)] variables to be replaced by 0
/arg2 set %% [(t1) ... (td) (x1) ...] all variables
/arg1 set %% resolution
[
/ff /bftt /k1 /degmax /syzlist /mveclist /cohomlist
/ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
/i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
/psi1 /psi1ker /psi2image
/gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
/pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
/syz0 /BFs /dimi
] pushVariables
[
/syzlist arg1 def /ttxx arg2 def /bftt arg3 def
/k1 arg4 def
%% BF unknowns should be set properly. cf. misc-2015/06/lyon/q2.k
syzlist 0 get 0 get isArray {
syzlist 0 get 0 get length /BFunknowns set
} { /BFunknowns 1 def } ifelse
syzlist length /degmax set
bftt length /d set
BFparlist /aa set % parameters are defined in BFvarlist
[BFs] ttxx join aa join /allvarlist set
ttxx length /dn set
ttxx {xtoDx} map /Dttxx set
(s) /BFs set
/V_weight
[ 0 1 d 1 sub
{ /i set bftt i get -1 }
for
0 1 d 1 sub
{ /i set bftt i get xtoDx 1 }
for ] def
/BFs_weight
[ [ BFs 1 ]
[ 0 1 dn 1 sub
{ /i set Dttxx i get 1 }
for
0 1 dn 1 sub
{ /i set ttxx i get 1 }
for ]
] def
[ allvarlist listtostring ring_of_differential_operators
BFs_weight weight_vector 0 ] define_ring
[ ] /cohomlist set
%% Start the loop: (counter = ideg)
0 1 degmax {/ideg set
%% (new loop: ) messagen ideg ::
ideg 0 eq {
1 /r0 set
%% N.T.
BFunknowns /r1 set
[ 1 1 BFunknowns { pop [ (0) ]} for ] /gbase set
[ 0 ] /m0vec set
[ 1 1 BFunknowns { pop 0} for ] /m1vec set
%% end N.T.
}{
syzlist << ideg 1 sub >> get /gbase set
r0 /r1 set
} ifelse
ideg degmax 1 sub gt {
[ [ 1 1 r1 { pop (0) } for ] ] /o.syz set
}{
syzlist ideg get /o.syz set
} ifelse
%% (syzlist = ) messagen syzlist ::
%% (o.syz = ) messagen o.syz ::
%% o.syz gbase
%% D^{r2} --> D^{r1} --> D^{r0}
%% with weight vectors: m2vec m1vec m0vec
%% which will induce a complex
%% psi2 psi1
%% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
gbase length /r1 set
o.syz length /r2 set
BFmessage {
(m2vec = ) messagen m2vec message
(o.syz = ) messagen o.syz pmat
(m1vec = ) messagen m1vec message
(gbase = ) messagen gbase pmat
(m0vec = ) messagen m0vec message
} { } ifelse
%% Setting up a ring with V-order for computing ord_w
[ttxx listtostring ring_of_differential_operators
[V_weight] weight_vector 0 ] define_ring
%% (Computing the weight vector m2vec from m1vec and syz) message
/m2vec [
0 1 r2 1 sub {/i set
o.syz i get /syzi set
0 /nonzero set
0 1 r1 1 sub {/j set
syzi j get expand /syzij set
syzij (0). eq { }{
%% (m1vec:) messagen m1vec j get ::
%% (syzij:) messagen syzij bftt fwh_order :: syzij ::
syzij bftt fwh_order m1vec j get add /maxtmp set
%% (maxtmp:) messagen maxtmp ::
nonzero 0 eq { maxtmp /max0 set }{
maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
} ifelse
1 /nonzero set
} ifelse
} for
max0 } for ] def
%% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
BFu /estr set
/ee
[ 1 1 d {/i set estr i toString 2 cat_n} for ]
def
[@@@.esymbol ] ee join /eee set
%%(Setting up a ring that represents D_{Y->X}^{r1}) message
eee length /neee set
/eeemvec [ 1 1 neee {pop 1} for ] def
eee [ ] [BFs] ttxx join eeemvec setupDringVshift
bftt {xtoDx expand} map /bfDtt set
[ ] /psi1 set
[ ] /psi1index set
[ ] /zerolist set
%%(converting gbase to a list of polynomials) message
/gbase1
[ 0 1 r1 1 sub {/i set
gbase i get {expand [[BFs expand (1).]] replace} map vector_to_poly
} for ] def
gbase1 /gbase set
%%(ideg =) messagen ideg ::
%%(Computing psi1) message
%% psi1
%% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
%% with weight = k <= k1 - m1vec
0 /dimi set
0 1 r1 1 sub {/i set
m1vec i get /m1i set
ee {expand} map 0 k1 m1i sub monomials /emonoi set
bfDtt 0 k1 m1i sub monomials /bfDttmonoi set
bfDttmonoi length dimi add /dimi set
emonoi length /nmono set
0 1 nmono 1 sub {/j set
@@@.esymbol expand i npower /eei set
emonoi j get eei mul /eei set
gbase i get /dtp set
bfDttmonoi j get dtp mul /dtp set
0 1 d 1 sub {/k set
dtp [[bftt k get expand (0).]] replace /dtp set
dtp [[bfDtt k get ee k get expand]] replace /dtp set
} for
dtp [[(h). (1).]] replace /dtp set
dtp (0). eq {
zerolist [eei] join /zerolist set
}{
psi1index [eei] join /psi1index set
psi1 [dtp] join /psi1 set
} ifelse
} for
} for
(i = ) messagen ideg message
(dim of the i-th truncated complex = ) messagen dimi message
%%(ideg =) messagen ideg ::
%%(psi1 obtained.) message
%%(Computing psi1ker) message
%% Computing psi1ker := Ker psi1 :
psi1 length 0 eq {
[ ] /psi1ker set
}{
psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
[psi1 [(needSyz)]] groebner 2 get /psi1kervec set
psi1kervec length /pn set
psi1index length /pn0 set
[ ] /psi1ker set
0 1 pn 1 sub {/i set
psi1kervec i get /psi1i set
(0). /psi1keri set
0 1 pn0 1 sub {/j set
psi1index j get psi1i j get mul psi1keri add /psi1keri set
} for
psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
} for
} ifelse
zerolist psi1ker join /psi1ker set
% Is it all right to use reducedBase here?
% psi1ker length 0 eq { }{
% psi1ker reducedBase /psi1ker set
% } ifelse
%%(ideg =) messagen ideg ::
%%(psi1ker obtained.) message
%%(Computing psi2image ...) message
%% psi2
%% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
%% with weight m2vec <= k <= k1 - m2vec
/psi2image [
0 1 r2 1 sub {/i set
o.syz i get {expand [[BFs expand (1).]] replace} map /syzi set
syzi vector_to_poly /syzi set
m2vec i get /m2i set
bfDtt 0 k1 m2i sub monomials /bfDttmonoi set
bfDttmonoi length /nmono set
0 1 nmono 1 sub {/j set
bfDttmonoi j get syzi mul /syzij set
0 1 d 1 sub {/k set
syzij [[bftt k get expand (0).]] replace /syzij set
syzij [[bfDtt k get ee k get expand]] replace /syzij set
} for
syzij [[(h). (1).]] replace /syzij set
syzij (0). eq { }{syzij} ifelse
} for
} for
] def
%(psi2image obtained.) message
%(ideg = ) messagen ideg ::
%(psi1ker = ) message psi1ker ::
%(psi2image =) message psi2image ::
%% Computes the quotient module psi1ker/psi2image
psi1ker length /nker set
nker 0 eq {
[0 [ ]] /cohom set
}{
psi2image length /nim set
psi1ker psi2image join /psiall set
psiall {homogenize} map /psiall set
[psiall [(needSyz)]] groebner 2 get /psisyz set
psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
cohom {remove0} map /cohom set
cohom length 0 eq {
[nker [ ]] /cohom set
}{
cohom {homogenize} map /cohom set
[cohom] groebner 0 get reducedBase /cohom set
cohom {[[(h). (1).]] replace} map /cohom set
[nker cohom] trimModule /cohom set
} ifelse
} ifelse
cohomlist [cohom] join /cohomlist set
0 ideg sub print (-th cohomology: ) messagen
cohom message
r1 /r0 set
r2 /r1 set
m1vec /m0vec set
m2vec /m1vec set
} for
cohomlist /arg1 set
] pop
popVariables
arg1
} def