Return to Srestall_s.sm1 CVS log

Up to [local] / OpenXM / src / k097 / lib / restriction

Bug fix for Srestall(L,...) in case that L is a submodule.

%% $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