Annotation of OpenXM/src/kan96xx/Doc/slope.sm1, Revision 1.3
1.3 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/slope.sm1,v 1.2 2001/06/18 03:12:21 takayama Exp $
1.2 takayama 2: (oxasir.sm1.loaded) boundp not {
3: [(parse) (oxasir.sm1) pushfile] extension
4: } { } ifelse
5: (cohom.sm1.loaded) boundp not {
6: [(parse) (cohom.sm1) pushfile] extension
7: } { } ifelse
1.1 takayama 8: $slope.sm1, computing the slopes of a D-ideal: June 15, 2000$ message
1.3 ! takayama 9: $ (C) N.Takayama, F.Castro-Jimenez$ message
1.1 takayama 10: $Imported commands: slope $ message
11: /slope.verbose 1 def
12: /gb.warning 0 def
13: /slope.geometric 1 def %%Computing the geometric slope. Load cohom.sm1 and oxasir.
14:
15: /slope.infinity (99999999999999999999).. def
16: /w_support {
17: /arg2 set
18: /arg1 set
19: [/in-w_support /f /wvec /ans /g /tt] pushVariables
20: [
21: /f arg1 def
22: /wvec arg2 def
23: /ans [ ] def
24: {
25: f (0). eq { exit } { } ifelse
26: f init /g set
27: wvec { g 2 1 roll ord_w (universalNumber) dc } map /tt set
28: ans tt append /ans set
29: f g sub /f set
30: } loop
31: /arg1 ans def
32: ] pop
33: popVariables
34: arg1
35: } def
36:
37: [(w_support)
38: [$f [w1 w2 ...] w_support [ [i1 i2 ...] [j1 j2 ...] [k1 k2 ...] ...]$
39: $ i1, ..., j1, ..., k1, ... are universal numbers. $
40: $Example: (x Dx+ x ). [ [(x) -1 (Dx) 1] [(Dx) 1]] w_support$
41: ]
42: ] putUsages
43:
44:
45: /w_supports_of_I {
46: /arg1 set
47: [/in-w_supports_of_I /ans /v /ff /wvec /gg /gg2] pushVariables
48: [
49: /ff arg1 0 get def
50: /v arg1 1 get def
51: /wvec arg1 2 get def
52: wvec { [ 2 1 roll ] [ ff v 4 -1 roll ] gb } map /gg set
53: gg { 0 get } map /gg set
54: gg flatten /gg2 set
55: gg2 message
56: gg2 0 get (ring) dc ring_def
57: gg2 { (string) dc . } map /gg2 set % reparse
58: gg2 { wvec w_support } map /ans set
59: /arg1 [ans gg] def
60: ] pop
61: popVariables
62: arg1
63: } def
64:
65: [(w_supports_of_I)
66: [$[f v [w1 w2 ...]] w_support_of_I [supports gb]$
67: $Example 1: [[(x Dx + 2 y Dy) (Dx^2-Dy)] (x,y) [ [(Dx) 1 (Dy) 1] [(y) -1 (Dy) 1]]]$
68: $ w_supports_of_I$
69: $Example 2: [ [[1 2 3]] [0]] gkz /ff set$
70: $ [ ff 0 get ff 1 get [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]]$
71: $ ] w_supports_of_I $
72: $Example 3: [ [[1 2 3]] [0]] gkz /ff set$
73: $ [ ff 0 get ff 1 get [ [(x1) 0 (x2) 0 (x3) -3 (Dx1) 6 (Dx2) 6 (Dx3) 9]]] gb /gg set $
74: $ gg 1 get { [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]] w_support } map /gg2 set $
75: ]
76: ] putUsages
77:
78: /w_supports_of_I_without_gb_computation {
79: /arg1 set
80: [/in-w_supports_of_I_without_gb_computation
81: /ans /v /ff /wvec /gg2] pushVariables
82: [
83: /ff arg1 0 get def
84: /v arg1 1 get def
85: /wvec arg1 2 get def
86: /gg2 ff def
87: %% gg2 message
88: gg2 0 get (ring) dc ring_def
89: gg2 { (string) dc . } map /gg2 set % reparse
90: gg2 { wvec w_support } map /ans set
91: /arg1 [ans gg2] def
92: ] pop
93: popVariables
94: arg1
95: } def
96:
97: /decompose_to_w_homogeneous {
98: /arg1 set
99: [/in-decompose_to_w_homogeneous /f /w /g /ans] pushVariables
100: [
101: /f arg1 0 get def
102: /w arg1 1 get def
103: /ans [ ] def
104: f (ring) dc ring_def
105: /w w weightv def
106: {
107: f (0). eq { exit } { } ifelse
108: f w init /g set
109: ans g append /ans set
110: f g sub /f set
111: } loop
112: /arg1 ans def
113: ] pop
114: popVariables
115: arg1
116: } def
117:
118: [(decompose_to_w_homogeneous)
119: [( [f w] decompose_to_w_homogeneous [f0 f1 f2 ...])
120: $Example: [ (x^3+x*h^4+x+1). [(x) 2 (h) 1] ] decompose_to_w_homogeneous $
121: ]] putUsages
122:
123: %% Check in the polynomial ring.
124: /w_homogeneousQ {
125: /arg1 set
126: [/in-w_homogeneousQ /ii /vv /ww /ans /gg /jj /i] pushVariables
127: [
128: /ii arg1 0 get def
129: /vv arg1 1 get def
130: /ww arg1 2 get def
131: [ii vv] pgb 0 get /gg set
132: gg 0 get (ring) dc ring_def
133: gg { (string) dc . } map /ii set
134: ii { [ 2 1 roll ww ] decompose_to_w_homogeneous } map /jj set
135: jj { dup length 1 eq { pop } { } ifelse } map /jj set
136: jj flatten /jj set
137: /ans 1 def
138: 0 1 jj length 1 sub {
139: /i set
140: jj i get gg reduction-noH 0 get (0). eq { }
141: { jj i get messagen ( does not belong to the ideal ) message
142: /ans 0 def
143: exit
144: } ifelse
145: } for
146: /arg1 ans def
147: ] pop
148: popVariables
149: arg1
150: } def
151:
152: [(w_homogeneousQ)
153: [([ideal variables weight] w_homogeneousQ bool)
154: $Example 1: [[(x) (x^2+x) (x^3-y^2)] [(x) (y)] [(x) 1 (y) 1]] w_homogeneousQ$
155: $Example 2: [[(x^2+1) (x^3-y^2)] [(x) (y)] [(x) 1 (y) 1]] w_homogeneousQ$
156: ]] putUsages
157:
158: %% Should move to hol.sm1
159: /gr_var {
160: /arg1 set
161: [/in-gr_var /v /ans /i /vec-input] pushVariables
162: [
163: /v arg1 def
164: v isArray {
165: /vec-input 1 def
166: v { toString } map /v set
167: } {
168: /vec-input 0 def
169: [v to_records pop] /v set
170: } ifelse
171: /ans v def
172: 0 1 v length 1 sub {
173: /i set
174: /ans ans [@@@.Dsymbol v i get] cat append def
175: } for
176: vec-input not {
177: ans from_records /ans set
178: } { } ifelse
179: /arg1 ans def
180: ] pop
181: popVariables
182: arg1
183: } def
184: [(gr_var)
185: [( [v1 ... vn] gr_var [v1 ... vn Dv1 ... Dvn] )
186: $ (v1,...,vn) gr_var (v1,...,vn,Dv1,...,Dvn) $
187: (cf. wToVW)
188: ]] putUsages
189:
190: %% Should move to hol.sm1
191: /reparse {
192: /arg1 set
193: [/in-reparse /f /ans] pushVariables
194: [
195: /f arg1 def
196: f isArray {
197: /ans f { reparse } map def
198: }{
199: f toString . /ans set
200: } ifelse
201: /arg1 ans def
202: ] pop
203: popVariables
204: arg1
205: } def
206: [(reparse)
207: [(obj reparse obj2)
208: (Parse the object in the current ring.)
209: (Elements in obj2 belong to the current ring.)
210: ]] putUsages
211:
212: %% Should move to hol.sm1
213: /wToVW {
214: /arg1 set
215: [/in-wToVW /ww /vv /tmp /ans /i] pushVariables
216: [
217: /tmp arg1 def
218: /ww tmp 0 get def
219: /vv tmp 1 get def
220: /ans [ ] def
221: 0 1 vv length 1 sub {
222: /i set
223: ans [ vv i get ww i get (integer) dc] append /ans set
224: } for
225: /arg1 ans flatten def
226: ] pop
227: popVariables
228: arg1
229: } def
230: [(wToVW)
231: [([ ww vv] wToVW [ v1 w1 ...])
232: (cf. gr_var)
233: (Example: [ [-1 -2 1 2] [(x) (y) (Dx) (Dy)]] wToVW :: )
234: ]] putUsages
235:
236: /gr_gb {
237: /arg1 set
238: [/in-gr_gb /ii /vv /ww /vv_gr /ans /gr_I] pushVariables
239: [(CurrentRingp)] pushEnv
240: [
241: /ii arg1 0 get def
242: /vv arg1 1 get def
243: /ww arg1 2 get def
244: [ii vv ww] gb /ans set
245: %% (gr_gb: your gb is) message ans message
246: /vv_gr vv gr_var def
247: vv_gr isArray { vv_gr from_records /vv_gr set } { } ifelse
248: [vv_gr ring_of_polynomials 0] define_ring
249: ans 1 get dehomogenize /gr_I set
250: gr_I reparse /gr_I set
251: /arg1 [ans 0 get gr_I] def
252: ] pop
253: popEnv
254: popVariables
255: arg1
256: } def
257: [(gr_gb)
258: [([ii vv ww] gr_gb [ii_gb gr_ii])
259: (It computes the Grobner basis ii_gb in D for the weight vector vv.)
260: (gr_ii is the initial ideal with respect to ww and is the ideal of)
261: (the ring of polynomials with reverse lexicographic order.)
262: (The answer is dehomogenized.)
263: (cf. gr_var, reparse. Need gb for this function --- load cohom.sm1)
264: $Example: [[(x1*Dx1+2*x2*Dx2+3*x3*Dx3) $
265: $ (Dx1^2-Dx2) (-Dx1*Dx2+Dx3) (Dx2^2-Dx1*Dx3)] $
266: $ [ (x1) (x2) (x3) ] ] /ff set $
267: $ [ff 0 get ff 1 get [[(x2) -1 (Dx1) 2 (Dx2) 3 (Dx3) 2]]] gr_gb /gg set$
268: ]] putUsages
269:
270: /firstSlope3 {
271: /arg1 set
272: [/in-firstSlope3 /ff /gv /gf /wv /wf /vv /vvdd
273: /first-slope /first-weight /first-gb
274: ] pushVariables
275: [
276: /ff arg1 def
277: /vv [(x1) (x2) (x3)] def
278: /vvdd [(x1) (x2) (x3) (Dx1) (Dx2) (Dx3)] def
279: /wf [(Dx1) 1 (Dx2) 1 (Dx3) 1] def %% F-filtration
280: /wv [(x2) -1 (Dx2) 1] def %% V-filtration
281:
282: [ff vv [wf]] gb /gf set
283: [ff vv [wv]] gb dehomogenize /gv set
284:
285: %% determine the first-slope and first-weight here.
286: %% [gf vv [wf]] w_supports_of_I
287: %% [gv vv [wv]] w_supports_of_I
288: /firstweight [ (x2) -1 (Dx1) 2 (Dx2) 3 (Dx3) 2] def
289: [ff vv [firstweight]] gr_gb
290: /first-gb set
291: [
292: [first-gb 1 get vvdd wf] w_homogeneousQ
293: [first-gb 1 get vvdd wv] w_homogeneousQ
294: first-gb
295: ] /arg1 set
296: ] pop
297: popVariables
298: arg1
299: } def
300: %% [ [[1 2 3]] [0]] gkz /ff set ff 0 get firstSlope3 /gg set
301: %% [ [[1 2 3]] [2]] gkz /ff set ff 0 get firstSlope3 /gg set
302: %% This program is used to check gr_gb and w_homogeneousQ
303:
304: /biggest_pq {
305: /arg1 set
306: [/in-biggest_pq /ex /xmax /ymax /i /ans] pushVariables
307: [
308: /ex arg1 def
309: ex length 0 eq {
310: /ans null def
311: /LLL.biggest_pq goto
312: } { } ifelse
313: /xmax ex 0 get 0 get def
314: 0 1 ex length 1 sub {
315: /i set
316: ex i get 0 get xmax ge {
317: /xmax ex i get 0 get def
318: /ymax ex i get 1 get def
319: }{ } ifelse
320: } for
321: 0 1 ex length 1 sub {
322: /i set
323: ex i get 0 get xmax eq {
324: ex i get 1 get ymax gt {
325: /ymax ex i get 1 get def
326: } { } ifelse
327: }{ } ifelse
328: } for
329: /ans [xmax ymax] def
330: /LLL.biggest_pq
331: /arg1 ans def
332: ] pop
333: popVariables
334: arg1
335: }def
336: [(biggest_pq)
337: [([[i1 j1] [i2 j2] ...] biggest_pq [ik jk])
338: (It returns the biggest [i j] with the lexicographic order x > y)
339: (Example: [ [1 2] [1 3] [2 4] [2 -1]] biggest_pq :: )
340: ]] putUsages
341:
342: /remove_x* {
343: /arg1 set
344: [/in-remove_x* /ans /i /ex /x] pushVariables
345: [
346: /ex arg1 0 get def
347: /x arg1 1 get def
348: /ans [ ] def
349: 0 1 ex length 1 sub {
350: /i set
351: ex i get 0 get x eq {
352: }{
353: /ans ans ex i get append def
354: } ifelse
355: } for
356: /arg1 ans def
357: ] pop
358: popVariables
359: arg1
360: } def
361: [(remove_x*)
362: [([[[i1 j1] [i2 j2] ...] x] remove_x* [[i1 j1] [i2 j2] ...])
363: (It removes [x *] elements from [[i1 j1] ...])
364: (Example: [ [ [1 2] [1 3] [2 4] [2 -1]] 2 ] remove_x* :: )
365: ]] putUsages
366:
367: % f > g ?
368: /greater_u {
369: /arg2 set /arg1 set
370: [/in-greater_u /f /g /tmp /ans] pushVariables
371: [
372: /f arg1 def /g arg2 def
373: f g sub /tmp set
374: /ans 0 def
375: tmp isInteger {
376: tmp 0 gt {
377: /ans 1 def
378: }{ } ifelse
379: }{
380: tmp isRational { tmp (numerator) dc /tmp set } { } ifelse
381: tmp (0).. gt {
382: /ans 1 def
383: } { } ifelse
384: } ifelse
385: /arg1 ans def
386: ] pop
387: popVariables
388: arg1
389: } def
390:
391: %% to turn around the a bug of univ-num (universalNumber) dc bug.
392: /toUniv {
393: /arg1 set
394: [/in-toUniv /p] pushVariables
395: [
396: /p arg1 def
397: p isInteger {
398: /p p (universalNumber) dc def
399: }{ } ifelse
400: /arg1 p def
401: ] pop
402: popVariables
403: arg1
404: } def
405: /smallSlope {
406: /arg1 set
407: [/in-smallSlope /ex /p /q /tmp /r /s /slope
408: /upperBoundOfSlope
409: ] pushVariables
410: [
411: /ex arg1 0 get def
412: /upperBoundOfSlope arg1 1 get def
413: (0).. upperBoundOfSlope greater_u {
414: (SmallSlope: the upperBoundOfSlope has a negative value.)
415: error
416: } { } ifelse
417: /slope (0).. def
418: /tmp ex biggest_pq def
419: /p tmp 0 get def /q tmp 1 get def
420: [ex p] remove_x* /ex set
421: {
422: ex length 0 eq { exit } { } ifelse
423: /tmp ex biggest_pq def
424: /r tmp 0 get def %% tmp = (r,s)
425: /s tmp 1 get def %% tmp = (r,s)
426: [ex r] remove_x* /ex set
427: s q greater_u {
428: %% return (s-q)/(p-r) : positiive
429: s q sub toUniv
430: p r sub toUniv div /slope set
431: [(cancel) slope] mpzext /slope set
432: upperBoundOfSlope slope greater_u {
433: exit
434: } {
435: /p r def
436: /q s def
437: /slope (0).. def % throw away this slope
438: } ifelse
439: } { } ifelse
440: } loop
441: /arg1 slope def
442: ] pop
443: popVariables
444: arg1
445: } def
446: [(smallSlope)
447: [([ [[i1 j1] [i2 j2] ...] upperBound] smallSlope b/a)
448: (The absolute value of the smallSlope must be smaller than upperBound.)
449: (Example: [ [[1 2] [1 6] [2 4] [2 -1]] slope.infinity] smallSlope :: )
450: (Example: [ [[0 7] [1 2] [1 6] [2 4] [2 -1]] (2)..] smallSlope :: )
451: (Example: [ [[1 2] [1 3] [2 4] [2 -1]] slope.infinity]smallSlope :: )
452: (Example: [ [[1 2] [1 -1]] slope.infinity] smallSlope :: )
453: $Example: [ [[1 2 3]] [0]] gkz /ff set$
454: $ [ ff 0 get ff 1 get [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(Dx3) 1 (x3) -1]]$
455: $ ] w_supports_of_I /gg set$
456: $ gg 0 get { /pp set [pp slope.infinity] smallSlope } map /hh set $
457: ]] putUsages
458:
459:
460: /maxSlope {
461: /arg1 set
462: [/in-maxSlope /ss /ans /i] pushVariables
463: [
464: /ss arg1 def
465: /ans (0).. def
466: 0 1 ss length 1 sub {
467: /i set
468: ss i get ans greater_u {
469: /ans ss i get def
470: } { } ifelse
471: } for
472: /arg1 ans def
473: ] pop
474: popVariables
475: arg1
476: } def
477:
478: /slope {
479: /arg1 set
480: [/in-slope /ff /gv /gf /wv /wf /wll /worderf
481: /vv /vvdd /f /v /ll /f-filt
482: /w_supp
483: /virtualSlope /a /b /ans /tmp /sslopes
484: /pp /maxSmallSlope
485: /first-slope /first-weight /first-gb /first-init
486: ] pushVariables
487: [
488: /ff arg1 0 get def
489: /vv arg1 1 get def
490: /f arg1 2 get def
491: /v arg1 3 get def
492: vv isArray not { [vv to_records pop] /vv set } { } ifelse
493: /f-filt f def
494: %% Example:
495: %% /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def
496: %% /f [ 0 0 1 1] def %% F-filtration
497: %% /v [ -1 0 1 0] def %% V-filtration
498: %% /vv [(x) (y)] def
499: %% -3: x=0, -2 : y =0
500:
501: /maxSmallSlope slope.infinity def
502: /vvdd vv gr_var def
503: vvdd length f length eq { }
504: { (The number of variables <<vvdd>> and the size of weight vector <<f>>do not match.)
505: error } ifelse
506: vvdd length v length eq { }
507: { (The number of variables <<vvdd>> and the size of weight vector <<v>>do not match.)
508: error } ifelse
509: /ans [ ] def
510: /wv [v vvdd] wToVW def
511:
512: /worderf [f vvdd] wToVW def
513:
514: /wf [f vvdd] wToVW def
515: slope.verbose { (Computing gb with ) messagen wf message ( and ) messagen
516: wv message } { } ifelse
517: [ff vv [wf wv]] gr_gb /first-gb set
518: /firstweight wf def
519: {
520: /wf [f vvdd] wToVW def
521:
522: first-gb 0 get dehomogenize /gf set
523: [gf vv [worderf wv]] w_supports_of_I_without_gb_computation
524: /w_supp set
525: slope.verbose { (w_supp are ) message w_supp 0 get message } { } ifelse
526: slope.verbose { (gb is ) message w_supp 1 get message } { } ifelse
527: slope.verbose { (weight is ) messagen firstweight message } { } ifelse
528: w_supp 0 get { /pp set [pp maxSmallSlope] smallSlope } map /sslopes set
529: slope.verbose { (smallSlopes are ) message sslopes message } { } ifelse
530: sslopes maxSlope /first-slope set
531: first-slope (0).. greater_u {
532: (small slope is ) messagen first-slope message
533: } {
534: (All the smallSlopes are zero. Exiting...) message
535: exit
536: } ifelse
537: /a first-slope (denominator) dc def
538: /b first-slope (numerator) dc def
539: %% a v mul b f mul add /ll set
540: a v mul b f-filt mul add /ll set
541: /firstweight [ll vvdd] wToVW def
542: (Computing the GB with the weight vector ) messagen firstweight message
543: (and ) messagen wv message
544: [ff vv [firstweight wv]] gr_gb % use two weight vectors.
545: /first-gb set
546: %% (GB is) messagen first-gb message
547: first-gb 1 get /first-init set
548: slope.geometric {
549: (To get the geometric slope, we need to compute the radical.) message
550: [ first-init vvdd] radical /first-init set
551: [first-init vvdd] pgb 0 get /first-init set
552: (Radical is ) messagen first-init message
553: } { } ifelse
554: [first-init vvdd worderf] w_homogeneousQ
555: [first-init vvdd wv] w_homogeneousQ
556: and {
557: (It is bi-homogeneous! It is not a slope.) message
558: /maxSmallSlope first-slope def %% I think it is necessary.
559: } {
560: slope.geometric {
561: (It is a geometric slope.) message
562: }{
563: (It is an algebraic slope.) message
564: } ifelse
565: /maxSmallSlope first-slope def
566: /ans ans [first-slope ll] append def
567: } ifelse
568: (-----------------------------------------------) message
569: /f ll def
570: } loop
571: /arg1 ans def
572: ] pop
573: popVariables
574: arg1
575: } def
576: [(slope)
577: [( [ii vv F-filtration V-filtration] slope [ [-slope1 weight] ...])
578: ( ii : ideal, vv : variables, F-filtration : F-filtration by vector)
579: ( V-filtration : V-filtration by vector)
580: (It computes the algebraic or geometric slopes of ii along the hyperplane)
581: (specified by the V-filtration.)
582: (When slope.geometric is one, it outputs the geometric slopes.)
583: (As to the algorithm, see A.Assi, F.J.Castro-Jimenez and J.M.Granger)
584: ( How to calculate the slopes of a D-module, Compositio Math, 104, 1-17, 1996)
585: (Note that the signs of the slopes are negative, but the absolute values)
586: (of the slopes are returned.)
587: $Example 1: [ [(x^4 Dx + 3)] (x) [0 1] [-1 1]] slope :: $
588: $ The solution is exp(x^(-3)). $
589: $Example 2: [ [(x^3 Dx^2 + (x + x^2) Dx + 1)] [(x)] $
590: $ [0 1] [-1 1]] slope :: $
591: $Example 3: [ [(x^6 Dx^3 + x^3 Dx^2 + (x + x^2) Dx + 1)] [(x)] $
592: $ [0 1] [-1 1]] slope :: $
593: $Example 4:$
594: $ /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def$
595: $ [ ff (x,y) [ 0 0 1 1] [ 0 -1 0 1] ] slope :: $
596: $ Answer should be 2 ==> -2 $
597: $Example 5:$
598: $ /ff [ [[1 2 3]] [-3]] gkz def $
599: $ [ ff 0 get ff 1 get [ 0 0 0 1 1 1] [ 0 0 -1 0 0 1] ] slope :: $
600: ]] putUsages
601:
602: /bihomogeneousGrQ {
603: /arg1 set
604: [/in-checkBihomogeneous /ff /vv /firstweight /worderf /wv
605: /first-gb /ans /vvdd
606: ] pushVariables
607: [
608: arg1 0 get /ff set
609: arg1 1 get /vv set
610: arg1 2 get /firstweight set
611: arg1 3 get 0 get /worderf set
612: arg1 3 get 1 get /wv set
613:
614: vv isArray not { [vv to_records pop] /vv set} { } ifelse
615: vv gr_var /vvdd set
616: %%(Computing the GB with the weight vector ) messagen firstweight message
617: [ff vv [firstweight]] gr_gb
618: /first-gb set
619: %% (GB is) messagen first-gb message
620: [first-gb 1 get vvdd worderf] w_homogeneousQ
621: [first-gb 1 get vvdd wv] w_homogeneousQ
622: and {
623: (It is bi-homogeneous!) message /ans 1 def
624: } {
625: (It is not bi-homogenous w.r.t ) messagen
626: [worderf wv] message
627: /ans 0 def
628: } ifelse
629: /arg1 [ans first-gb firstweight] def
630: ] pop
631: popVariables
632: arg1
633: } def
634: [(bihomogeneousGrQ)
635: [([ ii vv w [vf wv]] bihomogeneousGrQ [ans gb])
636: $It checks if in_w(ii) is bihomogeneous w.r.t. vf and wv$
637: $Example 1: [ [[1 2 3]] [0]] gkz /ff set $
638: $ [ff 0 get ff 1 get [(x3) -2 (Dx1) 1 (Dx2) 1 (Dx3) 3] $
639: $ [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(x3) -1 (x3) 1]]] $
640: $ bihomogeneousGrQ /gg set $
641: $ bi-homogeneous $
642: $Example 2: [ [[1 2 3]] [0]] gkz /ff set $
643: $ [ff 0 get ff 1 get [(x3) -1 (Dx1) 2 (Dx2) 2 (Dx3) 3] $
644: $ [ [(Dx1) 1 (Dx2) 1 (Dx3) 1] [(x3) -1 (x3) 1]]] $
645: $ bihomogeneousGrQ /gg set $
646: $ not bi-homogeneous $
647: $Example 3: [ [[1 3]] [0]] gkz /ff set $
648: $ [ff 0 get ff 1 get [(x2) -2 (Dx1) 1 (Dx2) 3] $
649: $ [ [(Dx1) 1 (Dx2) 1] [(x2) -1 (x2) 1]]] $
650: $ bihomogeneousGrQ /gg set $
651: $ not bi-homogeneous $
652: ]] putUsages
653:
654: %% Radical via primary ideal decomposition.
655: /radical {
656: /arg1 set
657: [/in-radical /ii /jj /pp0 /n /i /vv /ans] pushVariables
658: [
659: /ii arg1 def
660: ii 1 get /vv set
661: ii primadec /jj set
662: /n jj length def
663: jj { 1 get } map /pp0 set
664: vv isArray {
665: /vv vv from_records def
666: } { } ifelse
667: (Primary components are ) messagen pp0 message
668: /ans pp0 0 get def
669: pp0 rest /pp0 set
670: {
671: pp0 length 0 eq { exit } { } ifelse
672: %% [ans pp0 0 get vv] message
673: [ans pp0 0 get vv] gr_intersection /ans set
674: %%[ans pp0 0 get vv] gr_intersection /ans set
675: pp0 rest /pp0 set
676: } loop
677: ans /arg1 set
678: ] pop
679: popVariables
680: arg1
681: } def
682: [(radical)
683: [([ii vv] radical jj)
684: (Computing the radical of ii via primadec.)
685: (Example 1: [ [(x^2-1) (x^4-1)] (x)] radical ::)
686: (Example 2: [ [(x^2 y) (y^4) (x y)] (x,y)] radical ::)
687: ]] putUsages
688:
689: /gr_intersection {
690: /arg1 set
691: [/in-gr_intersection /ii /jj /rr /vlist /ii2 /jj2 ] pushVariables
692: [(CurrentRingp) (KanGBmessage)] pushEnv
693: [
694: /ii arg1 0 get def
695: /jj arg1 1 get def
696: /vlist arg1 2 get def
697:
698: [(KanGBmessage) 0] system_variable
699:
700: [vlist to_records pop] /vlist set
701: [vlist [(_t)] join from_records ring_of_polynomials
702: [[(_t) 1]] weight_vector 0] define_ring
703: ii { toString . (_t). mul } map /ii2 set
704: jj { toString . (1-_t). mul } map /jj2 set
705: [ii2 jj2 join] groebner_sugar 0 get
706: [(_t)] eliminatev /arg1 set
707: ] pop
708: popEnv
709: popVariables
710: arg1
711: } def
712: [(gr_intersection)
713: [(Ideal intersections in the ring of polynomials.)
714: $Example 1: [[(y) (Dx)] [(x) (Dy)] (x,y,Dx,Dy)] gr_intersection ::$
715: ]] putUsages
716:
717:
718: /tests {
719:
720: /ff [ [[1 2 3] ] [0]] gkz 0 get def
721: /vv [(x1) (x2) (x3)] def
722: /f [ 0 0 0 1 1 1] def %% F-filtration
723: /v [ 0 0 -1 0 0 1] def %% V-filtration
724:
725: /ff [ [[1 2 4] ] [0]] gkz 0 get def
726: /vv [(x1) (x2) (x3)] def
727: /f [ 0 0 0 1 1 1] def %% F-filtration
728: /v [ 0 0 -1 0 0 1] def %% V-filtration
729:
730: %% [1 2 3]
731: /ff [ $2*(x1-1)*Dx1+4*(x2-2)*Dx2+6*x3*Dx3-1$ , $Dx1^2-Dx2$ , $-Dx1*Dx2+Dx3$ , $Dx2^2-Dx1*Dx3$ ] def
732: /vv [(x1) (x2) (x3)] def
733: /f [ 0 0 0 1 1 1] def %% F-filtration
734: /v [ 0 0 -1 0 0 1] def %% V-filtration
735:
736: %% [1 2 4]
737: /ff [ $2*(x1-1)*Dx1+4*(x2-2)*Dx2+8*x3*Dx3-1$ , $Dx1^2-Dx2$ , $Dx2^2-Dx3$ ] def
738: /vv [(x1) (x2) (x3)] def
739: /f [ 0 0 0 1 1 1] def %% F-filtration
740: /v [ 0 0 -1 0 0 1] def %% V-filtration
741:
742: /ff [ (2 y Dx + 3 x^2 Dy) (3 y^3 Dy - 2 x^4 Dx - 6 x^3 y Dy + 6)] def
743: /f [ 0 0 1 1] def %% F-filtration
744: /v [ 0 -1 0 1] def %% V-filtration
745: /vv [(x) (y)] def
746: %% -3: x=0, -2 : y =0
747:
748: /ff [ [[1 3]] [0]] gkz 0 get def
749: /f [ 0 0 1 1] def %% F-filtration
750: /v [ 0 -1 0 1] def %% V-filtration
751: /vv [(x1) (x2)] def
752:
753:
754: } def
755:
1.2 takayama 756: /slope.sm1.loaded 1 def
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to slope.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc