Annotation of OpenXM/src/kan96xx/Doc/bfunction.sm1, Revision 1.1.1.1
1.1 maekawa 1: %%% oaku/kan/bfunction.sm1, 1998, 11/5
2:
3: %%% global variables for bfunction
4: %%% bfunction.*
5: /bfunction.version (2.981105) def
6: bfunction.version [(Version)] system_variable gt
7: { (This package requires the latest version of kan/sm1) message
8: (Please get it from http://www.math.kobe-u.ac.jp/KAN) message
9: error
10: } { } ifelse
11: /bfunction.v [(x) (y) (z)] def %% default variables of the input polynomial
12: /bfunction.s (s) def %% default variable of the output b-function
13: /bfunction.vh (v_) def %% default variable for V-homogenization
14: /bfunction.t (t_) def %% default variable for t in delta(t-f)
15: /bfunction.a [] def %% parameters are not available yet
16: /bfunction.verbose 0 def %% no messages if 0
17: /bfunction.strategy 0 def %% V-homogenization + h-homogenization if 0
18: %% V-homogenization if 1 (not available yet)
19: %% h-homogenization if 2 (not available yet)
20: /bfunction.result 0 def
21:
22: (bfunction.sm1, 11/05,1998 (C) T. Oaku. bfunction ) message-quiet
23:
24: [(bfunction)
25: [( a bfunction b)
26: (array a; poly b;)
27: (a : [f] ; string f ;)
28: (a : [f] ; polynomial f ;)
29: (a : [f v] ; string f,v; )
30: (a : [f v] ; polynomial f, string v; )
31: (b is the b-function (=Bernstein-Sato polynomial) of a polynomial f)
32: (in variables v.)
33: (If v is not specified, the variables are assumed to be (x,y,z). )
34: (b will be a polynomial in s. This variable can be changed by typing in)
35: ( (variable) /bfunction.s set )
36: (For the algorithm, see Duke Math. J. 87 (1997),115-132,)
37: ( J. Pure and Applied Algebra 117&118(1997), 495--518.)
38: $Example [(x^3-y^2) (x,y)] bfunction :: $
39: ]
40: ] putUsages
41:
42: /bfunction {
43: /arg1 set
44: [/aa /typev /setarg /f /s /v /bf /bfs /vt ] pushVariables
45: [(CurrentRingp) (KanGBmessage)] pushEnv %% push current global environment.
46: [
47:
48: /aa arg1 def
49: aa isArray { } { (array bfunction) message error } ifelse
50: /setarg 0 def
51: aa { tag } map /typev set
52: typev [ StringP ] eq
53: { /f aa 0 get def
54: /v bfunction.v def
55: /s bfunction.s def
56: /setarg 1 def
57: } { } ifelse
58: typev [ PolyP ] eq
59: { /f aa 0 get (string) data_conversion def
60: /v bfunction.v def
61: /s bfunction.s def
62: /setarg 1 def
63: } { } ifelse
64: typev [StringP StringP] eq
65: { /f aa 0 get def
66: /v [ aa 1 get to_records pop ] def
67: /s bfunction.s def
68: /setarg 1 def
69: } { } ifelse
70: typev [PolyP StringP] eq
71: { /f aa 0 get (string) data_conversion def
72: /v [ aa 1 get to_records pop ] def
73: /s bfunction.s def
74: /setarg 1 def
75: } { } ifelse
76: typev [StringP ArrayP] eq
77: { /f aa 0 get def
78: /v aa 1 get def
79: /s bfunction.s def
80: /setarg 1 def
81: } { } ifelse
82: typev [PolyP ArrayP] eq
83: { /f aa 0 get (string) data_conversion def
84: /v aa 1 get def
85: /s bfunction.s def
86: /setarg 1 def
87: } { } ifelse
88: setarg { } { (Argument mismatch) message error } ifelse
89:
90: [(KanGBmessage) bfunction.verbose] system_variable
91:
92: v bfunction.t append /vt set
93:
94: [f v fw_delta bfunction.t vt] indicial 0 get /bf set
95: [bfunction.s ring_of_polynomials 0] define_ring
96: bf . /bf set
97: bfunction.s . /bfs set
98: bf [[bfs (-1). bfs sub]] replace /bf set
99: /bfunction.result bf def
100: /arg1 bf def
101: ] pop
102: popEnv
103: popVariables
104: arg1
105: } def
106:
107: %% Computing the indicial polynomial (the b-function) of a D-module
108: /indicial {
109: /arg1 set %% [equations, the variable to be restricted to 0, all variables]
110: [/eqs /t /vars /allvars /newvars /x_vars /ans1 /ans2 ] pushVariables
111: [(CurrentRingp)] pushEnv
112: [
113: arg1 0 get /eqs set
114: arg1 1 get /t set
115: arg1 2 get /vars set
116: vars bfunction.s append /allvars set
117: [bfunction.t] allvars complement /newvars set
118: [bfunction.t] vars complement /x_vars set
119: [eqs t vars] indicial1 /ans1 set
120: [ans1 x_vars newvars] eliminate_Dx /ans2 set
121: [ans2 x_vars newvars] eliminate_x /arg1 set
122: ] pop
123: popEnv
124: popVariables
125: arg1
126: } def
127:
128: %% (-1,0;1,0)-Groebner basis
129: %% [equations (t) vars] indical1 ---> psi(BFequations) (as a list of strings)
130: /indicial1 {
131: /arg1 set
132: [/bft /bfs /bfh /bf1 /ff /ans /n /i /BFallvarlist /BFDvarlist
133: /BFs_weight /BFvarlist ] pushVariables
134: [(CurrentRingp)] pushEnv
135: [
136: /ff arg1 0 get def
137: /bft arg1 1 get def
138: /BFvarlist arg1 2 get def
139: /BFallvarlist
140: [ bfunction.vh bfunction.s] BFvarlist concat bfunction.a concat
141: def
142: BFvarlist length /n set
143: BFvarlist {xtoDx} map /BFDvarlist set
144: /BFs_weight
145: [ [ bfunction.vh 1 ]
146: [ 0 1 n 1 sub
147: { /i set BFDvarlist i get 1 }
148: for
149: 0 1 n 1 sub
150: { /i set BFvarlist i get 1 }
151: for ]
152: ] def
153:
154: [ BFallvarlist listtostring ring_of_differential_operators
155: BFs_weight weight_vector
156: 0] define_ring
157:
158: /bfh (h). def
159: /bfs bfunction.vh . def
160: /bf1 (1). def
161: ff { bft fw_homogenize . } map /ff set
162: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
163: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
164: ff reducedBase /ans set
165: ans {bft fw_psi} map /ans set
166: ans {(string) data_conversion} map /arg1 set
167: ] pop
168: popEnv
169: popVariables
170: arg1
171: } def
172:
173: %% eliminates Dx in the ring of differential operators
174: /eliminate_Dx {
175: /arg1 set %% [operators x variables]
176: [/bfh /bf1 /ff /ans /nx /ny /x_varlist /Dx_weight /BFvarlist
177: /allvarlist /Dx_varlist /y_varlist /Dy_varlist /allvarlist /i
178: ] pushVariables
179: [(CurrentRingp)] pushEnv
180: [
181: /ff arg1 0 get def
182: /x_varlist arg1 1 get def
183: /BFvarlist arg1 2 get def
184: x_varlist length /nx set
185: BFvarlist bfunction.a concat /allvarlist set
186:
187: x_varlist {xtoDx} map /Dx_varlist set
188: x_varlist BFvarlist complement /y_varlist set
189: y_varlist length /ny set
190: y_varlist {xtoDx} map /Dy_varlist set
191:
192: /Dx_weight
193: [ [ 0 1 nx 1 sub
194: { /i set Dx_varlist i get 1 }
195: for ]
196: [ 0 1 nx 1 sub
197: { /i set x_varlist i get 1 }
198: for
199: 0 1 ny 1 sub
200: { /i set y_varlist i get 1 }
201: for
202: 0 1 ny 1 sub
203: { /i set Dy_varlist i get 1 }
204: for
205: ]
206: ] def
207:
208: [ allvarlist listtostring ring_of_differential_operators
209: Dx_weight weight_vector
210: 0] define_ring
211:
212: /bfh (h). def
213: /bf1 (1). def
214: ff {.} map /ff set
215: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
216: bfunction.verbose 1 eq
217: {(Eliminating the derivations w.r.t. ) messagen x_varlist ::}
218: { }
219: ifelse
220: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
221: ff reducedBase /ans set
222: ans Dx_varlist eliminatev /ans set
223: ans {(string) data_conversion} map /arg1 set
224: ] pop
225: popEnv
226: popVariables
227: arg1
228: } def
229:
230: %% eliminates x in the ring of polynomials
231: /eliminate_x {
232: /arg1 set %% [operators x variables]
233: [/bfh /bfs /bf1 /ff /ans /nx /ny /x_varlist /BFvarlist
234: /allvarlist /y_varlist /i
235: ] pushVariables
236: [(CurrentRingp)] pushEnv
237: [
238: /ff arg1 0 get def
239: /x_varlist arg1 1 get def
240: /BFvarlist arg1 2 get def
241: x_varlist length /nx set
242: BFvarlist bfunction.a concat /allvarlist set
243:
244: x_varlist BFvarlist complement /y_varlist set
245: y_varlist length /ny set
246:
247: /x_weight
248: [ [ 0 1 nx 1 sub
249: { /i set x_varlist i get 1 }
250: for ]
251: [ 0 1 ny 1 sub
252: { /i set y_varlist i get 1 }
253: for
254: ]
255: ] def
256:
257: [ allvarlist listtostring ring_of_polynomials x_weight weight_vector
258: 0] define_ring
259:
260: /bfh (h). def
261: /bf1 (1). def
262: ff {.} map /ff set
263: ff {[[bfh bf1]] replace} map {homogenize} map /ff set
264: bfunction.verbose 1 eq
265: {(Eliminating the variables ) messagen x_varlist ::}
266: { }
267: ifelse
268: [ff] groebner 0 get {[[bfh bf1]] replace} map /ff set
269: ff reducedBase /ans set
270: ans x_varlist eliminatev /ans set
271: ans {(string) data_conversion} map /arg1 set
272: ] pop
273: popEnv
274: popVariables
275: arg1
276: } def
277: %%%%%%%%%%%%%%%%%%%%%%% libraries %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
278:
279: %% FW-principal part of an operator (FW-homogeneous)
280: %% Op (poly) fw_symbol ---> FW-symbol(Op) (poly)
281: /fw_symbol {
282: [[(h). (1).]] replace bfunction.vh . coefficients 1 get 0 get
283: } def
284:
285: %% FW-homogenization
286: %% Op (string) (t) fw_homogenize ---> h(Op) (string)
287: /fw_homogenize {
288: /arg2 set %% bft (string)
289: /arg1 set %% an operator (string)
290: [ /bft /bfDt /bfht /bfhDt /Op /degs /m /mn ] pushVariables
291: [
292: /Op arg1 expand def
293: /bft arg2 def
294: bft xtoDx /bfDt set
295: bfunction.vh (^(-1)*) bft 3 cat_n /bfht set
296: bfunction.vh (*) bfDt 3 cat_n /bfhDt set
297: Op [[bft expand bfht expand][bfDt expand bfhDt expand]] replace
298: /Op set
299: Op bfunction.vh expand coefficients 0 get
300: {(integer) data_conversion} map /degs set
301: degs << degs length 1 sub >> get /m set
302: 0 m sub /mn set
303: << bfunction.vh expand mn powerZ >> Op mul /Op set
304: Op (string) data_conversion /arg1 set
305: ] pop
306: popVariables
307: arg1
308: } def
309:
310: %% setup the ring of differential operators with the variables varlist
311: %% and parameters bfunction.a
312: %% varlist setupBFring
313: /setupDring {
314: /arg1 set
315: [ /varlist /bft /allvarlist /n /dvarlist /D_weight /i
316: ] pushVariables
317: [
318: arg1 /varlist set
319: /allvarlist
320: varlist bfunction.a join
321: def
322: varlist length /n set
323: varlist {xtoDx} map /dvarlist set
324: /D_weight
325: [ [ 0 1 n 1 sub
326: { /i set dvarlist i get 1 }
327: for ]
328: [
329: 0 1 n 1 sub
330: { /i set varlist i get 1 }
331: for ]
332: ] def
333:
334: [ allvarlist listtostring ring_of_differential_operators
335: D_weight weight_vector
336: 0] define_ring
337:
338: ] pop
339: popVariables
340: } def
341:
342: %% psi(P)(s)
343: %% Op (poly) (t) (string) fw_psi ---> psi(P) (poly)
344: %% Op should be FW-homogeneous.
345: /fw_psi {
346: /arg2 set %% bft (string)
347: /arg1 set %% Op (polynomial)
348: [/bft /bfDt /P /tt /dtt /k /Q /i /m /kk /PPt /PPC /kk /Ss] pushVariables
349: [
350: arg2 /bft set
351: arg1 fw_symbol /P set
352: /bfDt bft xtoDx def
353: /tt bft expand def /dtt bfDt expand def
354: P bft fw_order /k set
355: << 1 1 k >>
356: {pop tt P mul /P set }
357: for
358: << -1 -1 k >>
359: {pop dtt P mul /P set }
360: for
361: (0) expand /Q set
362: P dtt coefficients 0 get length /m set
363: 0 1 << m 1 sub >>
364: {
365: /i set
366: P dtt coefficients 0 get i get /kk set
367: kk (integer) data_conversion /kk set
368: P dtt coefficients 1 get i get /PPt set
369: PPt tt coefficients 1 get 0 get /PPC set
370: bfunction.s expand /Ss set
371: 0 1 << kk 1 sub >> {
372: pop
373: PPC Ss mul /PPC set
374: Ss (1) expand sub /Ss set
375: } for
376: Q PPC add /Q set
377: } for
378: Q /arg1 set
379: ] pop
380: popVariables
381: arg1
382: } def
383:
384: %% get the FW-order
385: %% Op (poly) (t) fw_order ---> FW-ord(Op) (integer)
386: %% Op should be FW-homogenized.
387: /fw_order {
388: /arg2 set %% bft (string)
389: /arg1 set %% Op (poly)
390: [/Op /bft /fws /m /fwsDt /k /tt /dtt] pushVariables
391: [
392: arg1 /Op set
393: arg2 /bft set
394: Op fw_symbol /fws set
395: /tt bft expand def
396: /dtt bft xtoDx expand def
397: fws [[bfunction.s expand (1).]] replace /fws set
398: fws dtt coefficients 0 get 0 get /m set
399: fws dtt coefficients 1 get 0 get /fwsDt set
400: fwsDt tt coefficients 0 get 0 get /k set
401: m k sub (integer) data_conversion /arg1 set
402: ] pop
403: popVariables
404: arg1
405: } def
406:
407: /remove0 {
408: /arg1 set
409: arg1 (0). eq
410: { } {arg1} ifelse
411: } def
412:
413: %% functions for list operations etc.
414:
415: /notidentical {
416: /arg2 set
417: /arg1 set
418: arg1 arg2 eq
419: { } {arg1} ifelse
420: } def
421:
422: %% [(x1) (x2) (x3)] ---> (x1,x2,x3)
423: /listtostring {
424: /arg1 set
425: [/n /j /ary /str] pushVariables
426: [
427: /ary arg1 def
428: /n ary length def
429: arg1 0 get /str set
430: n 1 gt
431: { str (,) 2 cat_n /str set }{ }
432: ifelse
433: 1 1 n 1 sub {
434: /j set
435: j n 1 sub eq
436: {str << ary j get >> 2 cat_n /str set}
437: {str << ary j get >> (,) 3 cat_n /str set}
438: ifelse
439: } for
440: /arg1 str def
441: ] pop
442: popVariables
443: arg1
444: } def
445:
446: %% (x1) --> (Dx1)
447: /xtoDx {
448: /arg1 set
449: @@@.Dsymbol arg1 2 cat_n
450: } def
451:
452: %% concatenate two lists
453: /concat {
454: /arg2 set
455: /arg1 set
456: [/n /j /lst1 /lst2 ] pushVariables
457: [
458: /lst1 arg1 def
459: /lst2 arg2 def
460: /n lst2 length def
461: 0 1 n 1 sub {
462: /j set
463: lst1 lst2 j get append /lst1 set
464: } for
465: /arg1 lst1 def
466: ] pop
467: popVariables
468: arg1
469: } def
470:
471: %% var (poly) m (integer) ---> var^m (poly)
472: /powerZ {
473: /arg2 set %% m
474: /arg1 set %% Var
475: [ /m /var /varstr /pow /nvar] pushVariables
476: [
477: arg1 /var set
478: arg2 /m set
479: var (string) data_conversion /varstr set
480: m -1 gt
481: { var m npower /pow set}
482: { varstr (^(-1)) 2 cat_n expand /nvar set
483: nvar << 0 m sub >> npower /pow set
484: }
485: ifelse
486: pow /arg1 set
487: ] pop
488: popVariables
489: arg1
490: } def
491:
492:
493: %% (f) varlist fw_delta ---> [t - f, Dx + f_xDt, ...]
494: /fw_delta {
495: /arg2 set %% [(x) (y) ...]
496: /arg1 set %% (f)
497: [ /fstr /f /bft /n /j /varlist /dxvarlist /allvarlist /xi /fxi /dxi /dt
498: /delta /BFdt /BFDtx_weight ] pushVariables
499: [
500: arg1 /fstr set
501: arg2 /varlist set
502: [bfunction.t] varlist join bfunction.a join /allvarlist set
503: bfunction.t xtoDx /BFdt set
504: varlist {xtoDx} map /dxvarlist set
505: varlist length /n set
506: /BFDtx_weight [ [ BFdt 1
507: 0 1 n 1 sub {/j set varlist j get 1} for ]
508: [ bfunction.t 1
509: 0 1 n 1 sub {/j set dxvarlist j get 1} for ]
510: ] def
511:
512: [ allvarlist listtostring ring_of_differential_operators
513: BFDtx_weight weight_vector 0 ] define_ring
514:
515: fstr expand /f set
516: bfunction.t expand /bft set
517: BFdt expand /dt set
518: /delta [
519: bft f sub
520: 0 1 n 1 sub {
521: /i set
522: varlist i get xtoDx expand /dxi set
523: << dxi f mul >> << f dxi mul >> sub [[(h). (1).]] replace /fxi set
524: dxi << fxi dt mul >> add
525: } for
526: ] def
527: delta {(string) data_conversion} map /arg1 set
528: ] pop
529: popVariables
530: arg1
531: } def
532:
533:
534:
535:
536:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to bfunction.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc