Annotation of OpenXM/src/k097/lib/restriction/Srestall_s.sm1, Revision 1.1
1.1 ! takayama 1: %% $OpenXM$
! 2: %% Srestall_s.sm1,
! 3: %% Compute the cohomology groups of a free resolution
! 4: %% truncated from above by the (-1,1) filtration
! 5: %% 2000.8.7 T.Oaku
! 6: %% /BFmessage 0 def controlled from cohom.sm1
! 7: (Srestall_s.sm1 2000.8.1) message
! 8: %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! 9: %% The cohomology groups of the restriction without truncation from below
! 10: %% resolution [variables] [initial plane] k1 Srestall1
! 11: %% --> [0-th cohomology -1-th cohomology, ...,-degmax-th cohomology]
! 12: 1 /BFunknowns set %% the number of the unknown functions
! 13: %% assumed 1 here
! 14:
! 15: /Srestall1 {
! 16: % /arg5 set %% degmax
! 17: /arg4 set %% k1
! 18: /arg3 set %% [(t1) ... (td)] variables to be replaced by 0
! 19: /arg2 set %% [(t1) ... (td) (x1) ...] all variables
! 20: /arg1 set %% resolution
! 21: [
! 22: /ff /bftt /k1 /degmax /syzlist /mveclist /cohomlist
! 23: /ideg /gbase /o.syz /m1vec /m2vec /r1 /r2
! 24: /i /syzi /j /syzij /maxtmp /max0 /ee /psi1index /zerolist
! 25: /psi1 /psi1ker /psi2image
! 26: /gbase1 /m1i /emonoi /nmono /bfDttmonoi /eei /dtp /k /psi1kervec
! 27: /pn /pn0 /psi1i /psi1keri /m2i /nker /nim /cohm /psiall /psisyz /cohom0
! 28: /syz0 /BFs /dimi
! 29: ] pushVariables
! 30: [
! 31: /syzlist arg1 def /ttxx arg2 def /bftt arg3 def
! 32: /k1 arg4 def
! 33: syzlist length /degmax set
! 34: bftt length /d set
! 35: BFparlist /aa set % parameters are defined in BFvarlist
! 36: [BFs] ttxx join aa join /allvarlist set
! 37: ttxx length /dn set
! 38: ttxx {xtoDx} map /Dttxx set
! 39: (s) /BFs set
! 40:
! 41: /V_weight
! 42: [ 0 1 d 1 sub
! 43: { /i set bftt i get -1 }
! 44: for
! 45: 0 1 d 1 sub
! 46: { /i set bftt i get xtoDx 1 }
! 47: for ] def
! 48:
! 49: /BFs_weight
! 50: [ [ BFs 1 ]
! 51: [ 0 1 dn 1 sub
! 52: { /i set Dttxx i get 1 }
! 53: for
! 54: 0 1 dn 1 sub
! 55: { /i set ttxx i get 1 }
! 56: for ]
! 57: ] def
! 58:
! 59: [ allvarlist listtostring ring_of_differential_operators
! 60: BFs_weight weight_vector 0 ] define_ring
! 61: [ ] /cohomlist set
! 62:
! 63: %% Start the loop: (counter = ideg)
! 64: 0 1 degmax {/ideg set
! 65:
! 66: %% (new loop: ) messagen ideg ::
! 67:
! 68:
! 69: ideg 0 eq {
! 70: 1 /r0 set
! 71: %% N.T.
! 72: BFunknowns /r1 set
! 73: [ 1 1 BFunknowns { pop [ (0) ]} for ] /gbase set
! 74: [ 0 ] /m0vec set
! 75: [ 1 1 BFunknowns { pop 0} for ] /m1vec set
! 76: %% end N.T.
! 77: }{
! 78: syzlist << ideg 1 sub >> get /gbase set
! 79: r0 /r1 set
! 80: } ifelse
! 81: ideg degmax 1 sub gt {
! 82: [ [ 1 1 r1 { pop (0) } for ] ] /o.syz set
! 83: }{
! 84: syzlist ideg get /o.syz set
! 85: } ifelse
! 86: %% (syzlist = ) messagen syzlist ::
! 87: %% (o.syz = ) messagen o.syz ::
! 88:
! 89: %% o.syz gbase
! 90: %% D^{r2} --> D^{r1} --> D^{r0}
! 91: %% with weight vectors: m2vec m1vec m0vec
! 92: %% which will induce a complex
! 93: %% psi2 psi1
! 94: %% D_{Y->X}^{r2} --> D_{Y->X}^{r1} --> D_{Y->X}^{r0}
! 95:
! 96: gbase length /r1 set
! 97: o.syz length /r2 set
! 98:
! 99: BFmessage {
! 100: (m2vec = ) messagen m2vec message
! 101: (o.syz = ) messagen o.syz pmat
! 102: (m1vec = ) messagen m1vec message
! 103: (gbase = ) messagen gbase pmat
! 104: (m0vec = ) messagen m0vec message
! 105: } { } ifelse
! 106:
! 107: %% Setting up a ring with V-order for computing ord_w
! 108: [ttxx listtostring ring_of_differential_operators
! 109: [V_weight] weight_vector 0 ] define_ring
! 110:
! 111: %% (Computing the weight vector m2vec from m1vec and syz) message
! 112: /m2vec [
! 113: 0 1 r2 1 sub {/i set
! 114: o.syz i get /syzi set
! 115: 0 /nonzero set
! 116: 0 1 r1 1 sub {/j set
! 117: syzi j get expand /syzij set
! 118: syzij (0). eq { }{
! 119: %% (m1vec:) messagen m1vec j get ::
! 120: %% (syzij:) messagen syzij bftt fwh_order :: syzij ::
! 121: syzij bftt fwh_order m1vec j get add /maxtmp set
! 122: %% (maxtmp:) messagen maxtmp ::
! 123: nonzero 0 eq { maxtmp /max0 set }{
! 124: maxtmp max0 gt { maxtmp /max0 set }{ } ifelse
! 125: } ifelse
! 126: 1 /nonzero set
! 127: } ifelse
! 128: } for
! 129: max0 } for ] def
! 130:
! 131: %% ee = [u1,...,ud] corresponds to [Dt1,...,Dtd] (for graduation)
! 132: BFu /estr set
! 133: /ee
! 134: [ 1 1 d {/i set estr i toString 2 cat_n} for ]
! 135: def
! 136: [@@@.esymbol ] ee join /eee set
! 137:
! 138: %%(Setting up a ring that represents D_{Y->X}^{r1}) message
! 139: eee length /neee set
! 140: /eeemvec [ 1 1 neee {pop 1} for ] def
! 141: eee [ ] [BFs] ttxx join eeemvec setupDringVshift
! 142: bftt {xtoDx expand} map /bfDtt set
! 143: [ ] /psi1 set
! 144: [ ] /psi1index set
! 145: [ ] /zerolist set
! 146:
! 147: %%(converting gbase to a list of polynomials) message
! 148: /gbase1
! 149: [ 0 1 r1 1 sub {/i set
! 150: gbase i get {expand [[BFs expand (1).]] replace} map vector_to_poly
! 151: } for ] def
! 152:
! 153: gbase1 /gbase set
! 154:
! 155: %%(ideg =) messagen ideg ::
! 156: %%(Computing psi1) message
! 157: %% psi1
! 158: %% Computes D_{Y->X}^{r1} --> D_{Y->X}^{r0} induced by gbase
! 159: %% with weight = k <= k1 - m1vec
! 160: 0 /dimi set
! 161: 0 1 r1 1 sub {/i set
! 162: m1vec i get /m1i set
! 163: ee {expand} map 0 k1 m1i sub monomials /emonoi set
! 164: bfDtt 0 k1 m1i sub monomials /bfDttmonoi set
! 165: bfDttmonoi length dimi add /dimi set
! 166: emonoi length /nmono set
! 167: 0 1 nmono 1 sub {/j set
! 168: @@@.esymbol expand i npower /eei set
! 169: emonoi j get eei mul /eei set
! 170: gbase i get /dtp set
! 171: bfDttmonoi j get dtp mul /dtp set
! 172: 0 1 d 1 sub {/k set
! 173: dtp [[bftt k get expand (0).]] replace /dtp set
! 174: dtp [[bfDtt k get ee k get expand]] replace /dtp set
! 175: } for
! 176: dtp [[(h). (1).]] replace /dtp set
! 177: dtp (0). eq {
! 178: zerolist [eei] join /zerolist set
! 179: }{
! 180: psi1index [eei] join /psi1index set
! 181: psi1 [dtp] join /psi1 set
! 182: } ifelse
! 183: } for
! 184: } for
! 185:
! 186: (i = ) messagen ideg message
! 187: (dim of the i-th truncated complex = ) messagen dimi message
! 188:
! 189: %%(ideg =) messagen ideg ::
! 190: %%(psi1 obtained.) message
! 191: %%(Computing psi1ker) message
! 192:
! 193: %% Computing psi1ker := Ker psi1 :
! 194: psi1 length 0 eq {
! 195: [ ] /psi1ker set
! 196: }{
! 197: psi1 {[[(h). (1).]] replace homogenize} map /psi1 set
! 198: [psi1 [(needSyz)]] groebner 2 get /psi1kervec set
! 199: psi1kervec length /pn set
! 200: psi1index length /pn0 set
! 201: [ ] /psi1ker set
! 202: 0 1 pn 1 sub {/i set
! 203: psi1kervec i get /psi1i set
! 204: (0). /psi1keri set
! 205: 0 1 pn0 1 sub {/j set
! 206: psi1index j get psi1i j get mul psi1keri add /psi1keri set
! 207: } for
! 208: psi1ker [ psi1keri [[(h). (1).]] replace ] join /psi1ker set
! 209: } for
! 210: } ifelse
! 211: zerolist psi1ker join /psi1ker set
! 212: % Is it all right to use reducedBase here?
! 213: % psi1ker length 0 eq { }{
! 214: % psi1ker reducedBase /psi1ker set
! 215: % } ifelse
! 216: %%(ideg =) messagen ideg ::
! 217: %%(psi1ker obtained.) message
! 218: %%(Computing psi2image ...) message
! 219:
! 220: %% psi2
! 221: %% Computes the image of D_{Y->X}^{r2} --> D_{Y->X}^{r1} induced by syz
! 222: %% with weight m2vec <= k <= k1 - m2vec
! 223: /psi2image [
! 224: 0 1 r2 1 sub {/i set
! 225: o.syz i get {expand [[BFs expand (1).]] replace} map /syzi set
! 226: syzi vector_to_poly /syzi set
! 227: m2vec i get /m2i set
! 228: bfDtt 0 k1 m2i sub monomials /bfDttmonoi set
! 229: bfDttmonoi length /nmono set
! 230: 0 1 nmono 1 sub {/j set
! 231: bfDttmonoi j get syzi mul /syzij set
! 232: 0 1 d 1 sub {/k set
! 233: syzij [[bftt k get expand (0).]] replace /syzij set
! 234: syzij [[bfDtt k get ee k get expand]] replace /syzij set
! 235: } for
! 236: syzij [[(h). (1).]] replace /syzij set
! 237: syzij (0). eq { }{syzij} ifelse
! 238: } for
! 239: } for
! 240: ] def
! 241:
! 242: %(psi2image obtained.) message
! 243: %(ideg = ) messagen ideg ::
! 244: %(psi1ker = ) message psi1ker ::
! 245: %(psi2image =) message psi2image ::
! 246:
! 247: %% Computes the quotient module psi1ker/psi2image
! 248: psi1ker length /nker set
! 249: nker 0 eq {
! 250: [0 [ ]] /cohom set
! 251: }{
! 252: psi2image length /nim set
! 253: psi1ker psi2image join /psiall set
! 254: psiall {homogenize} map /psiall set
! 255: [psiall [(needSyz)]] groebner 2 get /psisyz set
! 256: psisyz {nker proj vector_to_poly [[(h). (1).]] replace} map /cohom set
! 257: cohom {remove0} map /cohom set
! 258: cohom length 0 eq {
! 259: [nker [ ]] /cohom set
! 260: }{
! 261: cohom {homogenize} map /cohom set
! 262: [cohom] groebner 0 get reducedBase /cohom set
! 263: cohom {[[(h). (1).]] replace} map /cohom set
! 264: [nker cohom] trimModule /cohom set
! 265: } ifelse
! 266: } ifelse
! 267: cohomlist [cohom] join /cohomlist set
! 268: 0 ideg sub print (-th cohomology: ) messagen
! 269: cohom message
! 270: r1 /r0 set
! 271: r2 /r1 set
! 272: m1vec /m0vec set
! 273: m2vec /m1vec set
! 274: } for
! 275:
! 276: cohomlist /arg1 set
! 277: ] pop
! 278: popVariables
! 279: arg1
! 280: } def
! 281:
! 282:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to Srestall_s.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / k097 / lib / restriction