%% $OpenXM: OpenXM/src/k097/lib/restriction/Srestall_s.sm1,v 1.1 2000/12/10 10:04:04 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 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