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