Annotation of OpenXM/src/kan96xx/Doc/hol.sm1, Revision 1.9
1.9 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.8 2000/08/01 05:53:18 takayama Exp $
1.5 takayama 2: %% hol.sm1, 1998, 11/8, 11/10, 11/14, 11/25, 1999, 5/18, 6/5. 2000, 6/8
1.1 maekawa 3: %% rank, rrank, characteristic
4: %% This file is error clean.
5: /hol.version (2.990515) def
6: hol.version [(Version)] system_variable gt
7: { [(This package hol.sm1 requires the latest version of kan/sm1) nl
8: (Please get it from http://www.math.kobe-u.ac.jp/KAN)
9: ] cat
10: error
11: } { } ifelse
12:
1.5 takayama 13: $hol.sm1, basic package for holonomic systems (C) N.Takayama, 2000, 06/08 $
1.1 maekawa 14: message-quiet
15:
1.7 takayama 16: /gb.warning 0 def
1.1 maekawa 17: /rank.v [(x) (y) (z)] def %% default value of v (variables).
18: /rank.ch [ ] def %% characteristic variety.
19: /rank.verbose 0 def
20: /rank {
21: /arg1 set
22: [/in-rank /aa /typev /setarg /f /v /vsss /vddd
23: /gg /wv /vd /vdweight /chv
24: /one
25: ] pushVariables
26: [(CurrentRingp) (KanGBmessage)] pushEnv
27: [
28:
29: /aa arg1 def
30: aa isArray { } { ( << array >> rank) error } ifelse
31: /setarg 0 def
32: aa { tag } map /typev set
33: typev [ ArrayP ] eq
34: { /f aa 0 get def
35: /v rank.v def
36: /setarg 1 def
37: } { } ifelse
38: typev [ArrayP StringP] eq
39: { /f aa 0 get def
40: /v [ aa 1 get to_records pop ] def
41: /setarg 1 def
42: } { } ifelse
43: typev [ArrayP ArrayP] eq
44: { /f aa 0 get def
45: /v aa 1 get def
46: /setarg 1 def
47: } { } ifelse
48: setarg { } { (rank : Argument mismatch) error } ifelse
49:
50: [(KanGBmessage) rank.verbose ] system_variable
51:
52: f { toString } map /f set
53: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
54: /vddd set %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
55: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
56: /vd set %% vd = [(Dx) (Dy) (Dz)]
57: /vdweight
58: vd { [ 2 1 roll -1 ] } map %% vdweight=[[(Dx) -1] [(Dy) -1] [(Dz) -1]]
59: def
60:
61: [v from_records
62: ring_of_differential_operators [vddd] weight_vector 0] define_ring
63: f { . dehomogenize } map /f set
64: [f] groebner_sugar 0 get /gg set
65:
66: /wv vddd weightv def
67: gg { wv init } map /chv set %%obtained the characteristic variety.
68: /rank.ch chv def
69: chv { toString } map /chv set
70:
71: [ v vd join from_records
72: ring_of_polynomials
73: [vddd] vdweight join weight_vector
74: 0
75: ] define_ring
76: [chv {.} map] groebner_sugar 0 get { init } map /chii set
77:
78: /rank.chii chii def
79: rank.verbose { chii message } { } ifelse
80: v {[ 2 1 roll . (1).]} map /one set
81: %% [[(x). (1).] [(y). (1).] [(z). (1).]]
82: %% chii { one replace } map %% buggy code.
83: %% Arg of hilb should be a reduced GB.
84: [chii { one replace } map] groebner 0 get
85: vd hilb /arg1 set
86: ] pop
87: popEnv
88: popVariables
89: arg1
90: } def
91:
92:
93: [(rank)
94: [( a rank b)
95: ( array a; number b)
96: (Example 1 : )
97: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rank :: $
98: (Example 2 : )
99: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] rank :: $
100: ]
101: ] putUsages
102: (rank ) messagen-quiet
103:
104: /characteristic.verbose 0 def
105: /characteristic.v [(x) (y) (z)] def
106: /characteristic.ch [ ] def
107: /ch { characteristic } def
108: /characteristic {
109: /arg1 set
110: [/in-rank /aa /typev /setarg /f /v /vsss /vddd
111: /gg /wv /vd /chv
112: /one
113: ] pushVariables
114: [(CurrentRingp) (KanGBmessage)] pushEnv
115: [
116:
117: /aa arg1 def
118: aa isArray { } { ( << array >> characteristic) error } ifelse
119: /setarg 0 def
120: aa { tag } map /typev set
121: typev [ ArrayP ] eq
122: { /f aa 0 get def
123: /v characteristic.v def
124: /setarg 1 def
125: } { } ifelse
126: typev [ArrayP StringP] eq
127: { /f aa 0 get def
128: /v [ aa 1 get to_records pop ] def
129: /setarg 1 def
130: } { } ifelse
131: typev [ArrayP ArrayP] eq
132: { /f aa 0 get def
133: /v aa 1 get def
134: /setarg 1 def
135: } { } ifelse
136: setarg { } { (rank : Argument mismatch) error } ifelse
137:
138: [(KanGBmessage) characteristic.verbose ] system_variable
139:
140: f { toString } map /f set
141: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
142: /vddd set %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
143: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
144: /vd set %% vd = [(Dx) (Dy) (Dz)]
145:
146: [v from_records
147: ring_of_differential_operators [vddd] weight_vector 0] define_ring
148: f { . dehomogenize } map /f set
149: [f] groebner_sugar 0 get /gg set
150:
151: /wv vddd weightv def
152: gg { wv init } map /chv set
153: /characteristic.ch [chv] def
154: %% gg { wv init toString} map /chv set %%obtained the characteristic variety.
155: %% /characteristic.ch chv def
156:
157: %% [ v vd join from_records
158: %% ring_of_polynomials
159: %% [vddd] weight_vector
160: %% 0
161: %% ] define_ring
162: %% [chv {.} map] groebner_sugar 0 get /characteristic.ch set
163:
164: characteristic.ch /arg1 set
165: ] pop
166: popEnv
167: popVariables
168: arg1
169: } def
170:
171: [(characteristic)
172: [( a characteristic b)
173: ( array a; number b)
174: (b is the generator of the characteristic variety of a.)
175: (For the algorithm, see Japan J. of Industrial and Applied Math., 1994, 485--497.)
176: (Example 1 : )
177: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] characteristic :: $
178: (Example 2 : )
179: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] characteristic :: $
180: ]
181: ] putUsages
182: (characteristic ) messagen-quiet
183: [(ch)
184: [(ch is the abbreviation of characteristic.)
185: ( a ch b)
186: ( array a; number b)
187: (b is the generator of the characteristic variety of a.)
188: (For the algorithm, see, Japan J. of Industrial and Applied Math., 1994, 485--497.)
189: (Example 1 : )
190: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] ch :: $
191: (Example 2 : )
192: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] ch :: $
193: ]
194: ] putUsages
195: (ch ) messagen-quiet
196:
197: %%%% developing rrank.sm1
198: /rrank.v [(x) (y) (z)] def %% default value of v (variables).
199: /rrank.init [ ] def %% initial ideal.
200: /rrank.verbose 0 def
201: /rrank {
202: /arg1 set
203: [/in-rrank /aa /typev /setarg /f /v /vsss /vddd
204: /gg /wv /vd /vdweight
205: /one /i /chv
206: ] pushVariables
207: [(CurrentRingp) (KanGBmessage)] pushEnv
208: [
209:
210: /aa arg1 def
211: aa isArray { } { ( << array >> rrank) error } ifelse
212: /setarg 0 def
213: aa { tag } map /typev set
214: typev [ ArrayP ] eq
215: { /f aa 0 get def
216: /v rrank.v def
217: /setarg 1 def
218: } { } ifelse
219: typev [ArrayP StringP] eq
220: { /f aa 0 get def
221: /v [ aa 1 get to_records pop ] def
222: /setarg 1 def
223: } { } ifelse
224: typev [ArrayP ArrayP] eq
225: { /f aa 0 get def
226: /v aa 1 get def
227: /setarg 1 def
228: } { } ifelse
229: setarg { } { (rrank : Argument mismatch) error } ifelse
230:
231: [(KanGBmessage) rrank.verbose ] system_variable
232:
233: f { toString } map /f set
234: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
235:
236: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
237: /vd set %% vd = [(Dx) (Dy) (Dz)] , v = [(x) (y) (z)]
238: /vdweight
239: [ 0 1 v length 1 sub { /i set v i get << 0 i sub >>
240: vd i get << i >> } for ]
241: def
242: rrank.verbose { vdweight message } { } ifelse
243:
244: [v from_records
245: ring_of_differential_operators [vdweight] weight_vector 0] define_ring
246: f { . dehomogenize homogenize } map /f set
247: [f] groebner 0 get {dehomogenize} map /gg set
248:
249: /wv vdweight weightv def
250: gg { wv init } map /rrank.init set %%obtained the initial ideal
251: rrank.init {toString} map /chv set
252: /arg1 [chv v] rank def
253: ] pop
254: popEnv
255: popVariables
256: arg1
257: } def
258:
259:
260: [(rrank)
261: [( a rrank b)
262: ( array a; number b)
263: (It computes the holonomic rank for regular holonomic system.)
264: (For the algorithm, see Grobner deformations of hypergeometric differential equations, 1999, Springer.)
265: (Chapter 2.)
266: (Example 1 : )
267: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rrank :: $
268: ]
269: ] putUsages
270: (rrank ) messagen-quiet
271:
272: /gb.v 1 def
273: /gb.verbose 0 def
1.4 takayama 274: /gb.options [ ] def
1.1 maekawa 275: /gb {
276: /arg1 set
277: [/in-gb /aa /typev /setarg /f /v
278: /gg /wv /termorder /vec /ans /rr /mm
279: ] pushVariables
280: [(CurrentRingp) (KanGBmessage)] pushEnv
281: [
282:
283: /aa arg1 def
284: aa isArray { } { ( << array >> gb) error } ifelse
285: /setarg 0 def
286: /wv 0 def
287: aa { tag } map /typev set
288: typev [ ArrayP ] eq
289: { /f aa 0 get def
290: /v gb.v def
291: /setarg 1 def
292: } { } ifelse
293: typev [ArrayP StringP] eq
294: { /f aa 0 get def
295: /v aa 1 get def
296: /setarg 1 def
297: } { } ifelse
298: typev [ArrayP ArrayP] eq
299: { /f aa 0 get def
300: /v aa 1 get from_records def
301: /setarg 1 def
302: } { } ifelse
303: typev [ArrayP StringP ArrayP] eq
304: { /f aa 0 get def
305: /v aa 1 get def
306: /wv aa 2 get def
307: /setarg 1 def
308: } { } ifelse
309: typev [ArrayP ArrayP ArrayP] eq
310: { /f aa 0 get def
311: /v aa 1 get from_records def
312: /wv aa 2 get def
313: /setarg 1 def
314: } { } ifelse
315:
316: setarg { } { (gb : Argument mismatch) error } ifelse
317:
318: [(KanGBmessage) gb.verbose ] system_variable
319:
320: %%% Start of the preprocess
321: f getRing /rr set
322: %% To the normal form : matrix expression.
323: f gb.toMatrixOfString /f set
324: /mm gb.itWasMatrix def
325:
326: rr tag 0 eq {
327: %% Define our own ring
328: v isInteger {
329: (Error in gb: Specify variables) error
330: } { } ifelse
331: wv isInteger {
332: [v ring_of_differential_operators
333: 0] define_ring
334: /termorder 1 def
335: }{
336: [v ring_of_differential_operators
337: wv weight_vector
338: 0] define_ring
339: wv gb.isTermOrder /termorder set
340: } ifelse
341: } {
342: %% Use the ring structre given by the input.
343: v isInteger not {
1.7 takayama 344: gb.warning {
345: (Warning : the given ring definition is not used.) message
346: } { } ifelse
1.1 maekawa 347: } { } ifelse
348: rr ring_def
349: /wv rr gb.getWeight def
350: wv gb.isTermOrder /termorder set
351: } ifelse
352: %%% Enf of the preprocess
353:
1.4 takayama 354: gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.1 maekawa 355: termorder {
356: f { {. dehomogenize} map } map /f set
1.4 takayama 357: [f gb.options] groebner_sugar 0 get /gg set
1.1 maekawa 358: }{
359: f { {. dehomogenize} map} map /f set
360: f fromVectors { homogenize } map /f set
1.4 takayama 361: [f gb.options] groebner 0 get /gg set
1.1 maekawa 362: }ifelse
363: wv isInteger {
364: /ans [gg gg {init} map] def
365: }{
366: /ans [gg gg {wv 0 get weightv init} map] def
367: }ifelse
368:
369: %% Postprocess : recover the matrix expression.
370: mm {
371: ans { /tmp set [mm tmp] toVectors } map
372: /ans set
373: }{ }
374: ifelse
375: %%
376:
377: /arg1 ans def
378: ] pop
379: popEnv
380: popVariables
381: arg1
382: } def
383: (gb ) messagen-quiet
384:
385: /pgb {
386: /arg1 set
387: [/in-pgb /aa /typev /setarg /f /v
388: /gg /wv /termorder /vec /ans /rr /mm
389: ] pushVariables
390: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
391: [
392:
393: /aa arg1 def
394: aa isArray { } { (<< array >> pgb) error } ifelse
395: /setarg 0 def
396: /wv 0 def
397: aa { tag } map /typev set
398: typev [ ArrayP ] eq
399: { /f aa 0 get def
400: /v gb.v def
401: /setarg 1 def
402: } { } ifelse
403: typev [ArrayP StringP] eq
404: { /f aa 0 get def
405: /v aa 1 get def
406: /setarg 1 def
407: } { } ifelse
408: typev [ArrayP ArrayP] eq
409: { /f aa 0 get def
410: /v aa 1 get from_records def
411: /setarg 1 def
412: } { } ifelse
413: typev [ArrayP StringP ArrayP] eq
414: { /f aa 0 get def
415: /v aa 1 get def
416: /wv aa 2 get def
417: /setarg 1 def
418: } { } ifelse
419: typev [ArrayP ArrayP ArrayP] eq
420: { /f aa 0 get def
421: /v aa 1 get from_records def
422: /wv aa 2 get def
423: /setarg 1 def
424: } { } ifelse
425:
426: setarg { } { (pgb : Argument mismatch) error } ifelse
427:
428: [(KanGBmessage) gb.verbose ] system_variable
429:
430: %%% Start of the preprocess
431: f getRing /rr set
432: %% To the normal form : matrix expression.
433: f gb.toMatrixOfString /f set
434: /mm gb.itWasMatrix def
435:
436: rr tag 0 eq {
437: %% Define our own ring
438: v isInteger {
439: (Error in pgb: Specify variables) error
440: } { } ifelse
441: wv isInteger {
442: [v ring_of_polynomials
443: 0] define_ring
444: /termorder 1 def
445: }{
446: [v ring_of_polynomials
447: wv weight_vector
448: 0] define_ring
449: wv gb.isTermOrder /termorder set
450: } ifelse
451: } {
452: %% Use the ring structre given by the input.
453: v isInteger not {
1.7 takayama 454: gb.warning {
455: (Warning : the given ring definition is not used.) message
456: } { } ifelse
1.1 maekawa 457: } { } ifelse
458: rr ring_def
459: /wv rr gb.getWeight def
460: wv gb.isTermOrder /termorder set
461: } ifelse
462: %%% Enf of the preprocess
463:
1.4 takayama 464: gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.1 maekawa 465: termorder {
466: f { {. dehomogenize} map } map /f set
467: [(UseCriterion1) 1] system_variable
1.4 takayama 468: [f gb.options] groebner_sugar 0 get /gg set
1.1 maekawa 469: [(UseCriterion1) 0] system_variable
470: }{
471: f { {. dehomogenize} map} map /f set
472: f fromVectors { homogenize } map /f set
473: [(UseCriterion1) 1] system_variable
1.4 takayama 474: [f gb.options] groebner 0 get /gg set
1.1 maekawa 475: [(UseCriterion1) 0] system_variable
476: }ifelse
477: wv isInteger {
478: /ans [gg gg {init} map] def
479: }{
480: /ans [gg gg {wv 0 get weightv init} map] def
481: }ifelse
482:
483: %% Postprocess : recover the matrix expression.
484: mm {
485: ans { /tmp set [mm tmp] toVectors } map
486: /ans set
487: }{ }
488: ifelse
489: %%
490:
491: /arg1 ans def
492: ] pop
493: popEnv
494: popVariables
495: arg1
496: } def
497:
498: /pgb.old {
499: /arg1 set
500: [/in-pgb /aa /typev /setarg /f /v
501: /gg /wv /termorder /vec /ans
502: ] pushVariables
503: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
504: [
505:
506: /aa arg1 def
507: aa isArray { } { (array pgb) message (pgb) usage error } ifelse
508: /setarg 0 def
509: /wv 0 def
510: aa { tag } map /typev set
511: typev [ ArrayP ] eq
512: { /f aa 0 get def
513: /v gb.v def
514: /setarg 1 def
515: } { } ifelse
516: typev [ArrayP StringP] eq
517: { /f aa 0 get def
518: /v aa 1 get def
519: /setarg 1 def
520: } { } ifelse
521: typev [ArrayP ArrayP] eq
522: { /f aa 0 get def
523: /v aa 1 get from_records def
524: /setarg 1 def
525: } { } ifelse
526: typev [ArrayP StringP ArrayP] eq
527: { /f aa 0 get def
528: /v aa 1 get def
529: /wv aa 2 get def
530: /setarg 1 def
531: } { } ifelse
532: typev [ArrayP ArrayP ArrayP] eq
533: { /f aa 0 get def
534: /v aa 1 get from_records def
535: /wv aa 2 get def
536: /setarg 1 def
537: } { } ifelse
538:
539: setarg { } { (pgb : Argument mismatch) message error } ifelse
540:
541: [(KanGBmessage) gb.verbose ] system_variable
542:
543: %% Input must not be vectors.
544: f { toString } map /f set
545:
546: wv isInteger {
547: [v ring_of_polynomials
548: 0] define_ring
549: /termorder 1 def
550: }{
551: [v ring_of_polynomials
552: wv weight_vector
553: 0] define_ring
554: wv gb.isTermOrder /termorder set
555: } ifelse
556: termorder {
557: f { . dehomogenize } map /f set
558: [(UseCriterion1) 1] system_variable
559: [f] groebner_sugar 0 get /gg set
560: [(UseCriterion1) 0] system_variable
561: }{
562: f { . dehomogenize homogenize} map /f set
563: [(UseCriterion1) 1] system_variable
564: [f] groebner 0 get /gg set
565: [(UseCriterion1) 0] system_variable
566: }ifelse
567: wv isInteger {
568: /ans [gg gg {init} map] def
569: }{
570: /ans [gg gg {wv 0 get weightv init} map] def
571: }ifelse
572: /arg1 ans def
573: ] pop
574: popEnv
575: popVariables
576: arg1
577: } def
578: (pgb ) messagen-quiet
579:
580: /gb.toMatrixOfString {
581: /arg1 set
582: [/in-gb.toMatrixOfString /ff /aa /ans] pushVariables
583: [
584: /aa arg1 def
585: aa length 0 eq { /ans [ ] def /gb.toMatrixOfString.LLL goto }{ } ifelse
586: aa 0 get isArray {
587: /gb.itWasMatrix aa 0 get length def
588: }{
589: /gb.itWasMatrix 0 def
590: } ifelse
591: aa {
592: /ff set
593: ff isArray {
594: ff {toString} map /ff set
595: }{
596: [ff toString] /ff set
597: } ifelse
598: ff
599: } map /ans set
600: /gb.toMatrixOfString.LLL
601: /arg1 ans def
602: ] pop
603: popVariables
604: arg1
605: } def
606: [(gb.toMatrixOfString)
607: [(It translates given input into a matrix form which is a data structure)
608: (for computations of kernel, image, cokernel, etc.)
609: (gb.itWasMatrix is set to the length of the input vector.)
610: $Example 1: $
611: $ [ (x). (y).] gb.toMatrixOfString ==> [[(x)] [(y)]] $
612: $ gb.itWasMatrix is 0.$
613: $Example 2: $
614: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfString ==> [ [(x) (1)] [(y) (0)]] $
615: $ gb.itWasMatrix is 2.$
616: ]] putUsages
617:
618: /gb.toMatrixOfPoly {
619: /arg1 set
620: [/in-gb.toMatrixOfPoly /ff /aa /ans] pushVariables
621: [
622: /aa arg1 def
623: aa length 0 eq { /ans [ ] def /gb.toMatrixOfPoly.LLL goto }{ } ifelse
624: aa 0 get isArray {
625: /gb.itWasMatrix aa 0 get length def
626: }{
627: /gb.itWasMatrix 0 def
628: } ifelse
629: aa {
630: /ff set
631: ff isArray {
632: }{
633: [ff] /ff set
634: } ifelse
635: ff
636: } map /ans set
637: /gb.toMatrixOfPoly.LLL
638: /arg1 ans def
639: ] pop
640: popVariables
641: arg1
642: } def
643: [(gb.toMatrixOfPoly)
644: [(It translates given input into a matrix form which is a data structure)
645: (for computations of kernel, image, cokernel, etc.)
646: (gb.itWasMatrix is set to the length of the input vector.)
647: $Example 1: $
648: $ [ (x). (y).] gb.toMatrixOfPoly ==> [[(x)] [(y)]] $
649: $ gb.itWasMatrix is 0.$
650: $Example 2: $
651: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfPoly ==> [ [(x) (1)] [(y) (0)]] $
652: $ gb.itWasMatrix is 2.$
653: ]] putUsages
654:
655: /gb.getWeight {
656: /arg1 set
657: [/in-gb.getWeight /rr /ww /vv /ans /nn /ii] pushVariables
658: [(CurrentRingp)] pushEnv
659: [
660: /rr arg1 def
661: rr ring_def
662: getVariableNames /vv set
663: [(orderMatrix)] system_variable 0 get /ww set
664: /nn vv length 1 sub def
665: [0 1 nn {
666: /ii set
667: ww ii get 0 eq {
668: } {
669: vv ii get
670: ww ii get
671: } ifelse
672: } for
673: ] /ans set
674: /arg1 [ans] def
675: ] pop
676: popEnv
677: popVariables
678: arg1
679: } def
680: [(gb.getWeight)
681: [(ring gb.getWeight wv)
682: (It gets the weight vector field of the ring ring.)
683: ]] putUsages
684:
685:
686: /gb.isTermOrder {
687: /arg1 set
688: [/in-gb.isTermOrder /vv /ww /yes /i /j] pushVariables
689: [
690: /vv arg1 def
691: /yes 1 def
692: 0 1 vv length 1 sub {
693: /i set
694: /ww vv i get def
695: 0 1 ww length 1 sub {
696: /j set
697: ww j get isInteger {
698: ww j get 0 lt { /yes 0 def } { } ifelse
699: }{ } ifelse
700: }for
701: }for
702: /arg1 yes def
703: ] pop
704: popVariables
705: arg1
706: } def
707: [(gb)
708: [(a gb b)
709: (array a; array b;)
710: (b : [g ii]; array g; array in; g is a Grobner basis of f)
711: ( in the ring of differential operators.)
712: $ ii is the initial ideal in case of w is given or <<a>> belongs$
713: $ to a ring. In the other cases, it returns the initial monominal.$
714: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
715: (a : [f v]; array f; string v; v is the variables. )
716: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
717: ( )
718: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
719: $ [ [ (Dx) 1 ] ] ] gb pmat ; $
720: (Example 2: )
721: (To put h=1, type in, e.g., )
722: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
723: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] gb /gg set gg dehomogenize pmat ;$
724: ( )
725: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
726: $ [ [ (Dx) 1 (Dy) 1] ] ] gb pmat ; $
727: ( )
728: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
729: $ [ [ (x) -1 (y) -1] ] ] gb pmat ; $
730: ( )
731: (cf. gb, groebner, groebner_sugar, syz. )
732: ]] putUsages
733:
734: [(pgb)
735: [(a pgb b)
736: (array a; array b;)
737: (b : [g ii]; array g; array in; g is a Grobner basis of f)
738: ( in the ring of polynomials.)
739: $ ii is the initial ideal in case of w is given or <<a>>belongs$
740: $ to a ring. In the other cases, it returns the initial monominal.$
741: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
742: (a : [f v]; array f; string v; v is the variables.)
743: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
744: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
745: $ [ [(x^2+y^2-4). (x y -1).] ] pgb :: $
746: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] pgb :: $
747: (cf. gb, groebner, groebner_sugar, syz. )
748: ]] putUsages
749:
750:
751: %/syz.v 1 def
752: /syz.v 1 def
753: /syz.verbose 0 def
754: /syz {
755: /arg1 set
756: [/in-syz /aa /typev /setarg /f /v
757: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
758: /rr /mm
759: ] pushVariables
760: [(CurrentRingp) (KanGBmessage)] pushEnv
761: [
762:
763: /aa arg1 def
764: aa isArray { } { (<< array >> syz) error } ifelse
765: /setarg 0 def
766: /wv 0 def
767: aa { tag } map /typev set
768: typev [ ArrayP ] eq
769: { /f aa 0 get def
770: /v syz.v def
771: /setarg 1 def
772: } { } ifelse
773: typev [ArrayP StringP] eq
774: { /f aa 0 get def
775: /v aa 1 get def
776: /setarg 1 def
777: } { } ifelse
1.9 ! takayama 778: typev [ArrayP RingP] eq
! 779: { /f aa 0 get def
! 780: /v aa 1 get def
! 781: /setarg 1 def
! 782: } { } ifelse
1.1 maekawa 783: typev [ArrayP ArrayP] eq
784: { /f aa 0 get def
785: /v aa 1 get from_records def
786: /setarg 1 def
787: } { } ifelse
788: typev [ArrayP StringP ArrayP] eq
789: { /f aa 0 get def
790: /v aa 1 get def
791: /wv aa 2 get def
792: /setarg 1 def
793: } { } ifelse
1.9 ! takayama 794: typev [ArrayP RingP ArrayP] eq
! 795: { /f aa 0 get def
! 796: /v aa 1 get def
! 797: /wv aa 2 get def
! 798: /setarg 1 def
! 799: } { } ifelse
1.1 maekawa 800: typev [ArrayP ArrayP ArrayP] eq
801: { /f aa 0 get def
802: /v aa 1 get from_records def
803: /wv aa 2 get def
804: /setarg 1 def
805: } { } ifelse
806:
807: setarg { } { (syz : Argument mismatch) error } ifelse
808:
809: [(KanGBmessage) syz.verbose ] system_variable
810:
811:
812:
813: %%% Start of the preprocess
1.9 ! takayama 814: v tag RingP eq {
! 815: /rr v def
! 816: }{
! 817: f getRing /rr set
! 818: } ifelse
1.1 maekawa 819: %% To the normal form : matrix expression.
820: f gb.toMatrixOfString /f set
821: /mm gb.itWasMatrix def
822: mm 0 gt {
823: /vectorInput 1 def
824: }{
825: /vectorInput 1 def
826: } ifelse
827:
828: rr tag 0 eq {
829: %% Define our own ring
830: v isInteger {
831: (Error in syz: Specify variables) error
832: } { } ifelse
833: wv isInteger {
834: [v ring_of_differential_operators
835: 0] define_ring
836: /termorder 1 def
837: }{
838: [v ring_of_differential_operators
839: wv weight_vector
840: 0] define_ring
841: wv gb.isTermOrder /termorder set
842: } ifelse
843: }{
844: %% Use the ring structre given by the input.
845: v isInteger not {
1.7 takayama 846: gb.warning {
847: (Warning : the given ring definition is not used.) message
848: } { } ifelse
1.1 maekawa 849: } { } ifelse
850: rr ring_def
851: /wv rr gb.getWeight def
852: wv gb.isTermOrder /termorder set
853: } ifelse
854: %%% Enf of the preprocess
855:
856: termorder {
857: f { {. dehomogenize} map } map /f set
858: [f [(needBack) (needSyz)]] groebner_sugar /ggall set
859: ggall 2 get /gg set
860: }{
861: f { {. dehomogenize } map homogenize } map /f set
862: [f [(needBack) (needSyz)]] groebner /ggall set
863: ggall 2 get /gg set
864: }ifelse
865: vectorInput {
866: /vsize f 0 get length def %% input vector size.
867: /gtmp ggall 0 get def
868: [vsize gtmp] toVectors /gtmp set
869: ggall 0 gtmp put
870: }{ } ifelse
871: /arg1 [gg dehomogenize ggall] def
872: ] pop
873: popEnv
874: popVariables
875: arg1
876: } def
877: (syz ) messagen-quiet
878:
879: [(syz)
880: [(a syz [b c])
881: (array a; array b; array c)
882: (b is a set of generators of the syzygies of f.)
883: (c = [gb, backward transformation, syzygy without dehomogenization].)
884: (See groebner.)
885: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
886: (a : [f v]; array f; string v; v is the variables.)
887: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.9 ! takayama 888: ( v may be a ring object. )
1.1 maekawa 889: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
890: $ [ [(x^2+y^2-4). (x y -1).] ] syz :: $
891: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] syz :: $
892: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
893: $ [ [ (Dx) 1 ] ] ] syz pmat ; $
894: $Example 4: [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
895: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
896: $Example 5: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
897: $ (x,y) ] syz pmat ;$
898: $Example 6: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
899: $ (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
900: $Example 7: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
901: $ [(x) (y)]] syz pmat ;$
902: ]] putUsages
903:
904:
905: %%%%%%%%%%%%%%%%%% package fs %%%%%%%%%%%%%%%%%%%%%%%
906: [(genericAnn)
907: [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
908: (L1, ..., Lm are annihilating ideal for f^s.)
909: (f is a polynomial of v1, ..., vn)
910: (<string> | <poly> f, s, v1, ..., vn ; <poly> L1, ..., Lm )
911: $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
912: ]
913: ] putUsages ( genericAnn ) messagen-quiet
914: /fs.verbose 0 def
915: /genericAnn {
916: /arg2 set /arg1 set
917: [/in-genericAnn /f /vlist /s /vvv /nnn /rrr
918: /v1 /ops /ggg /ggg0
919: ] pushVariables
920: [(CurrentRingp) (KanGBmessage)] pushEnv
921: [
922: /f arg1 def /vlist arg2 def
923: f toString /f set
924: vlist { toString } map /vlist set
925: [(KanGBmessage) fs.verbose] system_variable
926: /s vlist 0 get def
927: /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
928: s nnn 2 add cat_n def
929: fs.verbose { vvv message } { }ifelse
930: [vvv ring_of_differential_operators
931: [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
932:
933: [ (_u*_t). f . sub (_u*_v-1). ]
934: vlist rest { /v1 set
935: %%D-clean f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
936: f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
937: @@@.Dsymbol v1 2 cat_n . add } map
938: join
939: /ops set
940: ops {[[(h). (1).]] replace } map /ops set
941: fs.verbose { ops message } { }ifelse
942: [ops] groebner_sugar 0 get /ggg0 set
943: fs.verbose { ggg0 message } { } ifelse
944: ggg0 [(_u) (_v)] eliminatev
945: %%D-clean { [(_t).] [ (D_t).] [s .] distraction
946: { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction
947: [[s . << (0). s . sub (1). sub >>]] replace
948: } map /arg1 set
949: ] pop
950: popEnv
951: popVariables
952: arg1
953: } def
954:
955: %% Find differential equations for f^(m), r0 the minimal integral root.
956: [(annfs)
957: [( [ f v m r0] annfs g )
958: (It returns the annihilating ideal of f^m where r0 must be smaller)
959: (or equal to the minimal integral root of the b-function.)
960: (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
961: (where r0 is the minial integral root of b.)
962: (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
963: (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
964: $ It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
965: (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
966: $ It returns the annihilating ideal of f^r0 and [r0, b-function]$
967: $ where r0 is the minimal integral root of the b-function.$
968: (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
969: (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
970: (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
971: ( (t,x1,x2,x3) -1 -2] annfs :: )
972: ( Note that the example 4 uses huge memory space.)
973: ]] putUsages
974: ( annfs ) messagen-quiet
975: /annfs.verbose fs.verbose def
976: /annfs.v [(x) (y) (z)] def
977: /annfs.s (_s) def
978: %% The first variable must be s.
979: /annfs {
980: /arg1 set
981: [/in-annfs /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
982: /ans /vtmp /w2 /velim /bbb /rrr /r0
983: ] pushVariables
984: [(CurrentRingp) (KanGBmessage)] pushEnv
985: [
986:
987: /aa arg1 def
988: aa isArray { } { ( << array >> annfs) error } ifelse
989: /setarg 0 def
990: aa { tag } map /typev set
991: /r0 [ ] def
992: /m [ ] def
993: /v annfs.v def
994: aa 0 << aa 0 get toString >> put
995: typev [ StringP ] eq
996: { /f aa 0 get def
997: /setarg 1 def
998: } { } ifelse
999: typev [StringP StringP] eq
1000: { /f aa 0 get def
1001: /v [ aa 1 get to_records pop ] def
1002: /setarg 1 def
1003: } { } ifelse
1004: typev [StringP ArrayP] eq
1005: { /f aa 0 get def
1006: /v aa 1 get def
1007: /setarg 1 def
1008: } { } ifelse
1009: typev [StringP ArrayP IntegerP IntegerP] eq
1010: { /f aa 0 get def
1011: /v aa 1 get def
1012: /m aa 2 get def
1013: /r0 aa 3 get def
1014: /setarg 1 def
1015: } { } ifelse
1016: typev [StringP StringP IntegerP IntegerP] eq
1017: { /f aa 0 get def
1018: /v [ aa 1 get to_records pop ] def
1019: /m aa 2 get def
1020: /r0 aa 3 get def
1021: /setarg 1 def
1022: } { } ifelse
1023: setarg 1 eq { } { (annfs : wrong argument) error } ifelse
1024:
1025: [annfs.s] v join /v set
1026:
1027: /ss v 0 get def
1028: annfs.verbose {
1029: (f, v, s, f^{m}, m+r0 = ) messagen
1030: [ f (, ) v (, ) ss (, )
1031: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1032: } { } ifelse
1033:
1034: f v genericAnn /fs set
1035:
1036: annfs.verbose {
1037: (genericAnn is ) messagen fs message
1038: } { } ifelse
1039: [(KanGBmessage) annfs.verbose] system_variable
1040:
1041: m isArray {
1042: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1043: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1044: velim { 1 } map /w2 set
1045: annfs.verbose { w2 message } { } ifelse
1046: [v from_records ring_of_differential_operators
1047: [w2] weight_vector 0] define_ring
1048: [ fs { toString . } map [ f toString . ] join ]
1049: groebner_sugar 0 get velim eliminatev 0 get /bbb set
1050: [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
1051: bbb toString . [[annfs.s . (s).]] replace /bbb set
1052: annfs.verbose { bbb message } { } ifelse
1053: bbb findIntegralRoots /rrr set
1054: rrr 0 get /r0 set %% minimal integral root.
1055: annfs.verbose { rrr message } { } ifelse
1056: fs 0 get (ring) dc ring_def
1057: fs { [[annfs.s . r0 toString .]] replace } map /ans set
1058: /ans [ans [r0 bbb]] def
1059: /annfs.label1 goto
1060: } { } ifelse
1061: m 0 ge {
1062: (annfs works only for getting annihilating ideal for f^(negative))
1063: error
1064: } { } ifelse
1065: r0 isArray {
1066: [(Need to compute the minimal root of b-function) nl
1067: (It has not been implemented.) ] cat
1068: error
1069: } { } ifelse
1070:
1071: [v from_records ring_of_differential_operators 0] define_ring
1072: fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace}
1073: map /gg set
1074: annfs.verbose { gg message } { } ifelse
1075:
1076: [ [f . << m r0 sub >> npower ] gg join
1077: [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
1078:
1079: gg2 { 0 get } map /ans set
1080: /ans ans { dup (0). eq {pop} { } ifelse } map def
1081:
1082: /annfs.label1
1083: /arg1 ans def
1084: ] pop
1085: popEnv
1086: popVariables
1087: arg1
1088: } def
1089:
1090: /genericAnnWithL.s (s) def
1091: /annfs.verify 0 def
1092: /genericAnnWithL {
1093: /arg1 set
1094: [/in-genericAnnWithL /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1095: /ans /vtmp /w2 /velim /bbb /rrr /r0 /myL /mygb /jj
1096: ] pushVariables
1097: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1098: [
1099:
1100: /aa arg1 def
1101: aa isArray { } { ( << array >> annfs) error } ifelse
1102: /setarg 0 def
1103: aa { tag } map /typev set
1104: /r0 [ ] def
1105: /m [ ] def
1106: /v annfs.v def
1107: aa 0 << aa 0 get toString >> put
1108: typev [ StringP ] eq
1109: { /f aa 0 get def
1110: /setarg 1 def
1111: } { } ifelse
1112: typev [StringP StringP] eq
1113: { /f aa 0 get def
1114: /v [ aa 1 get to_records pop ] def
1115: /setarg 1 def
1116: } { } ifelse
1117: typev [StringP ArrayP] eq
1118: { /f aa 0 get def
1119: /v aa 1 get def
1120: /setarg 1 def
1121: } { } ifelse
1122: setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse
1123:
1124: [genericAnnWithL.s] v join /v set
1125:
1126: /ss v 0 get def
1127: annfs.verbose {
1128: (f, v, s, f^{m}, m+r0 = ) messagen
1129: [ f (, ) v (, ) ss (, )
1130: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1131: } { } ifelse
1132:
1133: f v genericAnn /fs set
1134:
1135: annfs.verbose {
1136: (genericAnn is ) messagen fs message
1137: } { } ifelse
1138: [(KanGBmessage) annfs.verbose] system_variable
1139:
1140: m isArray {
1141: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1142: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1143: velim { 1 } map /w2 set
1144: annfs.verbose { w2 message } { } ifelse
1145: [v from_records ring_of_differential_operators
1146: [w2] weight_vector 0] define_ring
1147:
1148: [ [ f toString . ] fs { toString . } map join [(needBack)]]
1149: groebner_sugar /mygb set
1150: mygb 0 get velim eliminatev 0 get /bbb set
1151: mygb 0 get bbb position /jj set
1152: mygb 1 get jj get 0 get /myL set
1153:
1154: annfs.verbose { bbb message } { } ifelse
1155:
1156: annfs.verify {
1157: (Verifying L f - b belongs to genericAnn(f)) message
1158: [(Homogenize) 0] system_variable
1159: << myL f . mul bbb sub >>
1160: [fs { toString . } map] groebner_sugar 0 get
1161: reduction 0 get message
1162: (Is it zero? Then it's fine.) message
1163: } { } ifelse
1164:
1165: /ans [bbb [myL fs] ] def
1166: /annfs.label1 goto
1167: } { } ifelse
1168:
1169: /annfs.label1
1170: /arg1 ans def
1171: ] pop
1172: popEnv
1173: popVariables
1174: arg1
1175: } def
1176:
1177:
1178: [(genericAnnWithL)
1179: [$[f v] genericAnnWithL [b [L I]]$
1180: $String f,v; poly b,L; array of poly I;$
1181: $f is a polynomial given by a string. v is the variables.$
1182: $ v must not contain names s, e.$
1183: $b is the b-function (Bernstein-Sato polynomial) for f and$
1184: $ L is the operator satisfying L f^{s+1} = b(s) f^s $
1185: $ I is the annihilating ideal of f^s.$
1186: $cf. bfunction, annfs, genericAnn.$
1187: $Example 1: [(x^2+y^2) (x,y)] genericAnnWithL ::$
1188: $Example 2: [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
1189: $Example 3: [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
1190: ]] putUsages
1.2 takayama 1191:
1192: /reduction*.noH 0 def
1193: /reduction* {
1194: /arg1 set
1195: [/in-reduction* /aa /typev /setarg /f /v
1196: /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
1.3 takayama 1197: /opt
1.2 takayama 1198: ] pushVariables
1199: [(CurrentRingp) (KanGBmessage)] pushEnv
1200: [
1201:
1202: /aa arg1 def
1203: aa isArray { } { ( << array >> reduction*) error } ifelse
1204: /setarg 0 def
1205: /wv 0 def
1206: aa { tag } map /typev set
1207: typev [StringP ArrayP ArrayP] eq
1208: typev [ArrayP ArrayP ArrayP] eq or
1209: typev [PolyP ArrayP ArrayP] eq or
1210: { /h aa 0 get def
1211: /f aa 1 get def
1212: /v aa 2 get from_records def
1213: /setarg 1 def
1214: } { } ifelse
1215: typev [StringP ArrayP ArrayP ArrayP] eq
1216: typev [ArrayP ArrayP ArrayP ArrayP] eq or
1217: typev [PolyP ArrayP ArrayP ArrayP] eq or
1218: { /h aa 0 get def
1219: /f aa 1 get def
1220: /v aa 2 get from_records def
1221: /wv aa 3 get def
1222: /setarg 1 def
1223: } { } ifelse
1224:
1225: setarg { } { (reduction* : Argument mismatch) error } ifelse
1226:
1227: [(KanGBmessage) gb.verbose ] system_variable
1228:
1229: %%% Start of the preprocess
1230: f getRing /rr set
1231:
1232:
1233: rr tag 0 eq {
1234: %% Define our own ring
1235: v isInteger {
1236: (Error in reduction*: Specify variables) error
1237: } { } ifelse
1238: wv isInteger {
1239: [v ring_of_differential_operators
1240: 0] define_ring
1241: /termorder 1 def
1242: }{
1243: [v ring_of_differential_operators
1244: wv weight_vector
1245: 0] define_ring
1246: wv gb.isTermOrder /termorder set
1247: } ifelse
1248: } {
1249: %% Use the ring structre given by the input.
1250: v isInteger not {
1.7 takayama 1251: gb.warning {
1252: (Warning : the given ring definition is not used.) message
1253: } { } ifelse
1.2 takayama 1254: } { } ifelse
1255: rr ring_def
1256: /wv rr gb.getWeight def
1257: wv gb.isTermOrder /termorder set
1258: } ifelse
1259: %%% Enf of the preprocess
1260:
1261: f 0 get isArray {
1262: /size f 0 get length def
1263: f { { toString . } map } map /f set
1264: f fromVectors /f set
1265: }{
1266: /size -1 def
1267: f { toString . } map /f set
1268: } ifelse
1269:
1270: h isArray {
1271: h { toString . } map /h set
1272: [h] fromVectors 0 get /h set
1273: }{
1274: h toString . /h set
1275: } ifelse
1276: f { toString . } map /f set
1.3 takayama 1277: getOptions /opt set
1278: [(ReduceLowerTerms) 1] system_variable
1.2 takayama 1279: reduction*.noH {
1280: h f reduction-noH /ans set
1281: } {
1282: h f reduction /ans set
1283: } ifelse
1.3 takayama 1284: opt restoreOptions
1.2 takayama 1285: size -1 eq not {
1286: [size ans 0 get] toVectors /a0 set
1287: [size ans 3 get] toVectors /a3 set
1288: /ans [a0 ans 1 get ans 2 get a3] def
1289: } { } ifelse
1290: /arg1 ans def
1291: ] pop
1292: popEnv
1293: popVariables
1294: arg1
1295: } def
1296:
1297:
1298: [(reduction*)
1299: [([f base v] reduction* [h c0 syz input])
1300: ([f base v weight] reduction* [h c0 syz input])
1301: (reduction* is an user interface for reduction and reduction-noH.)
1302: (If reduction*.noH is one, then reduction-noH will be called.)
1303: (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
1304: (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
1305: (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
1306: ]] putUsages
1.5 takayama 1307:
1308:
1309:
1310: %% 2000, 6/7, at Sevilla, Hernando Colon
1311: %% macros that deal with homogenized inputs.
1312: %% Sample: [ [(h+x). (x^3).] [(x). (x).]] /ff set
1313: %% [(Homogenize_vec) 0] system_varialbe
1314: %% (grade) (grave1v) switch_function
1315: %% YA homogenization: [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
1316: %% 4+0 3+1 2+0 1+1
1317: /gb_h {
1318: /arg1 set
1319: [/in-gb_h /aa /typev /setarg /f /v
1320: /gg /wv /termorder /vec /ans /rr /mm
1321: /gb_h.opt
1322: ] pushVariables
1323: [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
1324: [
1325:
1326: /aa arg1 def
1.6 takayama 1327: gb.verbose { (Getting in gb_h) message } { } ifelse
1.5 takayama 1328: aa isArray { } { ( << array >> gb_h) error } ifelse
1329: /setarg 0 def
1330: /wv 0 def
1331: aa { tag } map /typev set
1332: typev [ ArrayP ] eq
1333: { /f aa 0 get def
1334: /v gb.v def
1335: /setarg 1 def
1336: } { } ifelse
1337: typev [ArrayP StringP] eq
1338: { /f aa 0 get def
1339: /v aa 1 get def
1340: /setarg 1 def
1341: } { } ifelse
1342: typev [ArrayP ArrayP] eq
1343: { /f aa 0 get def
1344: /v aa 1 get from_records def
1345: /setarg 1 def
1346: } { } ifelse
1347: typev [ArrayP StringP ArrayP] eq
1348: { /f aa 0 get def
1349: /v aa 1 get def
1350: /wv aa 2 get def
1351: /setarg 1 def
1352: } { } ifelse
1353: typev [ArrayP ArrayP ArrayP] eq
1354: { /f aa 0 get def
1355: /v aa 1 get from_records def
1356: /wv aa 2 get def
1357: /setarg 1 def
1358: } { } ifelse
1359:
1360: setarg { } { (gb_h : Argument mismatch) error } ifelse
1361:
1362: [(KanGBmessage) gb.verbose ] system_variable
1363:
1364: %%% Start of the preprocess
1365: f getRing /rr set
1366: %% To the normal form : matrix expression.
1367: f gb.toMatrixOfString /f set
1368: /mm gb.itWasMatrix def
1369:
1370: rr tag 0 eq {
1371: %% Define our own ring
1372: v isInteger {
1373: (Error in gb_h: Specify variables) error
1374: } { } ifelse
1375: wv isInteger {
1376: [v ring_of_differential_operators
1377: 0] define_ring
1378: /termorder 1 def
1379: }{
1380: [v ring_of_differential_operators
1381: wv weight_vector
1382: 0] define_ring
1383: wv gb.isTermOrder /termorder set
1384: } ifelse
1385: } {
1386: %% Use the ring structre given by the input.
1387: v isInteger not {
1.7 takayama 1388: gb.warning {
1389: (Warning : the given ring definition is not used.) message
1390: } { } ifelse
1.5 takayama 1391: } { } ifelse
1392: rr ring_def
1393: /wv rr gb.getWeight def
1394: wv gb.isTermOrder /termorder set
1395: } ifelse
1396: getOptions /gb_h.opt set
1397: (grade) (module1v) switch_function
1.6 takayama 1398: [(Homogenize_vec) 0] system_variable
1.5 takayama 1399: %%% End of the preprocess
1400:
1401: gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1402: termorder {
1403: f { {. } map } map /f set
1404: [f gb.options] groebner 0 get /gg set %% Do not use sugar.
1405: }{
1406: f { {. } map} map /f set
1407: f fromVectors /f set
1408: [f gb.options] groebner 0 get /gg set
1409: }ifelse
1410: wv isInteger {
1411: /ans [gg gg {init} map] def
1412: }{
1413: /ans [gg gg {wv 0 get weightv init} map] def
1414: }ifelse
1415:
1416: %% Postprocess : recover the matrix expression.
1417: mm {
1418: ans { /tmp set [mm tmp] toVectors } map
1419: /ans set
1420: }{ }
1421: ifelse
1422: gb_h.opt restoreOptions
1.6 takayama 1423: gb.verbose { (Getting out of gb_h) message } { } ifelse
1.5 takayama 1424: %%
1425:
1426: /arg1 ans def
1427: ] pop
1428: popEnv
1429: popVariables
1430: arg1
1431: } def
1432: (gb_h ) messagen-quiet
1433: [(gb_h)
1434: [(a gb_h b)
1435: (array a; array b;)
1436: (b : [g ii]; array g; array in; g is a Grobner basis of f)
1437: ( in the ring of homogenized differential operators.)
1438: ( The input must be homogenized properly.)
1439: ( Inproper homogenization may cause an infinite loop.)
1440: ( Each element of vectors must be homogenized. If you are using )
1441: ( non-term orders, all elements of vectors must have the same degree with)
1442: ( a proper degree shift vector.)
1443: $ ii is the initial ideal in case of w is given or <<a>> belongs$
1444: $ to a ring. In the other cases, it returns the initial monominal.$
1445: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1446: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1447: (a : [f v]; array f; string v; v is the variables. )
1448: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1449: ( )
1450: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1451: $ [ [ (Dx) 1 ] ] ] gb_h pmat ; $
1452: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
1453: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1454: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1455: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1456: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1457: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1458: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1459: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1460: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1461: ( )
1462: (cf. gb, groebner, syz_h. )
1463: ]] putUsages
1464:
1465: /syz_h {
1466: /arg1 set
1467: [/in-syz_h /aa /typev /setarg /f /v
1468: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
1469: /rr /mm
1470: /syz_h.opt
1471: ] pushVariables
1472: [(CurrentRingp) (KanGBmessage)] pushEnv
1473: [
1474:
1475: /aa arg1 def
1476: aa isArray { } { (<< array >> syz_h) error } ifelse
1477: /setarg 0 def
1478: /wv 0 def
1479: aa { tag } map /typev set
1480: typev [ ArrayP ] eq
1481: { /f aa 0 get def
1482: /v syz.v def
1483: /setarg 1 def
1484: } { } ifelse
1485: typev [ArrayP StringP] eq
1486: { /f aa 0 get def
1487: /v aa 1 get def
1488: /setarg 1 def
1489: } { } ifelse
1490: typev [ArrayP ArrayP] eq
1491: { /f aa 0 get def
1492: /v aa 1 get from_records def
1493: /setarg 1 def
1494: } { } ifelse
1495: typev [ArrayP StringP ArrayP] eq
1496: { /f aa 0 get def
1497: /v aa 1 get def
1498: /wv aa 2 get def
1499: /setarg 1 def
1500: } { } ifelse
1501: typev [ArrayP ArrayP ArrayP] eq
1502: { /f aa 0 get def
1503: /v aa 1 get from_records def
1504: /wv aa 2 get def
1505: /setarg 1 def
1506: } { } ifelse
1507:
1508: setarg { } { (syz_h : Argument mismatch) error } ifelse
1509:
1510: [(KanGBmessage) syz.verbose ] system_variable
1511:
1512:
1513:
1514: %%% Start of the preprocess
1515: f getRing /rr set
1516: %% To the normal form : matrix expression.
1517: f gb.toMatrixOfString /f set
1518: /mm gb.itWasMatrix def
1519: mm 0 gt {
1520: /vectorInput 1 def
1521: }{
1522: /vectorInput 1 def
1523: } ifelse
1524:
1525: rr tag 0 eq {
1526: %% Define our own ring
1527: v isInteger {
1528: (Error in syz_h: Specify variables) error
1529: } { } ifelse
1530: wv isInteger {
1531: [v ring_of_differential_operators
1532: 0] define_ring
1533: /termorder 1 def
1534: }{
1535: [v ring_of_differential_operators
1536: wv weight_vector
1537: 0] define_ring
1538: wv gb.isTermOrder /termorder set
1539: } ifelse
1540: }{
1541: %% Use the ring structre given by the input.
1542: v isInteger not {
1.7 takayama 1543: gb.warning {
1544: (Warning : the given ring definition is not used.) message
1545: } { } ifelse
1.5 takayama 1546: } { } ifelse
1547: rr ring_def
1548: /wv rr gb.getWeight def
1549: wv gb.isTermOrder /termorder set
1550: } ifelse
1551:
1552: getOptions /syz_h.opt set
1553: (grade) (module1v) switch_function
1554: [(Homogenize_vec) 0] system_variable
1555: %%% End of the preprocess
1556:
1557: termorder {
1558: f { {. } map } map /f set
1559: [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
1560: ggall 2 get /gg set
1561: }{
1562: f { {. } map } map /f set
1563: [f [(needBack) (needSyz)]] groebner /ggall set
1564: ggall 2 get /gg set
1565: }ifelse
1566: vectorInput {
1567: /vsize f 0 get length def %% input vector size.
1568: /gtmp ggall 0 get def
1569: [vsize gtmp] toVectors /gtmp set
1570: ggall 0 gtmp put
1571: }{ } ifelse
1572:
1573: syz_h.opt restoreOptions
1574: %%
1575:
1576: /arg1 [gg ggall] def
1577: ] pop
1578: popEnv
1579: popVariables
1580: arg1
1581: } def
1582: (syz_h ) messagen-quiet
1583:
1584: [(syz_h)
1585: [(a syz_h [b c])
1586: (array a; array b; array c)
1587: (b is a set of generators of the syzygies of f in the ring of)
1588: (homogenized differential operators.)
1589: ( The input must be homogenized properly.)
1590: ( Inproper homogenization may cause an infinite loop.)
1591: ( Each element of vectors must be homogenized. If you are using )
1592: ( non-term orders, all elements of vectors must have the same degree with)
1593: ( a proper degree shift vector.)
1594: (c = [gb, backward transformation, syzygy without dehomogenization].)
1595: (See gb_h.)
1596: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1597: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1598: (a : [f v]; array f; string v; v is the variables.)
1599: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1600: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1601: $ [ [ (Dx) 1 ] ] ] syz_h pmat ; $
1602: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
1603: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1604: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1605: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1606: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1607: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1608: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1609: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1610: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1611: $Example 5: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1612: $ [(x) (y)]] syz pmat ;$
1613: ]] putUsages
1614:
1615:
1616: /isSameIdeal {
1617: /arg1 set
1618: [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
1619: [(CurrentRingp)] pushEnv
1620: [
1621: /aa arg1 def
1622: %% comparison of hilbert series has not yet been implemented.
1623: aa length 3 eq { }
1624: { ([ii jj vv] isSameIdeal) error } ifelse
1.6 takayama 1625: gb.verbose { (Getting in isSameIdeal) message } { } ifelse
1.5 takayama 1626: /ii aa 0 get def
1627: /jj aa 1 get def
1628: /vv aa 2 get def
1629: ii length 0 eq jj length 0 eq and
1630: { /ans 1 def /LLL.isSame goto } { } ifelse
1631: [ii vv] gb /iigg set
1632: [jj vv] gb /jjgg set
1633:
1634: iigg getRing ring_def
1635:
1636: /ans 1 def
1637: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1638: /iigg set
1639: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1640: /jjgg set
1641:
1642: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1643: iigg length /n set
1644: 0 1 n 1 sub {
1645: /k set
1646: iigg k get
1647: jjgg reduction-noH 0 get
1648: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1649: gb.verbose { (o) messagen } { } ifelse
1650: } for
1651: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1652: jjgg length /n set
1653: 0 1 n 1 sub {
1654: /k set
1655: jjgg k get
1656: iigg reduction-noH 0 get
1657: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1658: gb.verbose { (o) messagen } { } ifelse
1659: } for
1660: /LLL.isSame
1661: gb.verbose { ( Done) message } { } ifelse
1662: /arg1 ans def
1663: ] pop
1664: popEnv
1665: popVariables
1666: arg1
1667: } def
1668: (isSameIdeal ) messagen-quiet
1669:
1670: [(isSameIdeal)
1671: [([ii jj vv] isSameIdeal bool)
1672: (ii, jj : ideal, vv : variables)
1673: (Note that ii and jj will be dehomogenized and compared in the ring)
1674: (of differential operators. cf. isSameIdeal_h)
1675: $Example 1: [ [(x^3) (y^2)] [(x^2+y) (y)] (x,y)] isSameIdeal $
1676: $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
1677: $ [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
1678: ]] putUsages
1679:
1680: /isSameIdeal_h {
1681: /arg1 set
1.6 takayama 1682: [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
1683: /isSameIdeal_h.opt
1684: ] pushVariables
1685: [(CurrentRingp) (Homogenize_vec)] pushEnv
1.5 takayama 1686: [
1687: /aa arg1 def
1.6 takayama 1688: gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
1.5 takayama 1689: %% comparison of hilbert series has not yet been implemented.
1690: aa length 3 eq { }
1691: { ([ii jj vv] isSameIdeal_h) error } ifelse
1692: /ii aa 0 get def
1693: /jj aa 1 get def
1694: /vv aa 2 get def
1695: ii length 0 eq jj length 0 eq and
1696: { /ans 1 def /LLL.isSame_h goto } { } ifelse
1697:
1698: [ii vv] gb_h /iigg set
1699: [jj vv] gb_h /jjgg set
1700:
1701: iigg getRing ring_def
1702:
1.6 takayama 1703: getOptions /isSameIdeal_h.opt set
1704: (grade) (module1v) switch_function
1705: [(Homogenize_vec) 0] system_variable
1.5 takayama 1706: /ans 1 def
1707: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1708: /iigg set
1709: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1710: /jjgg set
1711:
1.8 takayama 1712: gb.verbose { (Comparing) message iigg message (and) message jjgg message }
1713: { } ifelse
1.5 takayama 1714: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1715: iigg length /n set
1716: 0 1 n 1 sub {
1717: /k set
1718: iigg k get
1719: jjgg reduction 0 get
1720: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1721: gb.verbose { (o) messagen } { } ifelse
1722: } for
1723: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1724: jjgg length /n set
1725: 0 1 n 1 sub {
1726: /k set
1727: jjgg k get
1728: iigg reduction 0 get
1729: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1730: gb.verbose { (o) messagen } { } ifelse
1731: } for
1732: /LLL.isSame_h
1733: gb.verbose { ( Done) message } { } ifelse
1.6 takayama 1734: isSameIdeal_h.opt restoreOptions
1.5 takayama 1735: /arg1 ans def
1736: ] pop
1737: popEnv
1738: popVariables
1739: arg1
1740: } def
1741: (isSameIdeal_h ) messagen-quiet
1742:
1743: [(isSameIdeal_h)
1744: [([ii jj vv] isSameIdeal_h bool)
1745: (ii, jj : ideal, vv : variables)
1746: (Note that ii and jj will be compared in the ring)
1747: (of homogenized differential operators. Each element of the vector must be)
1748: (homogenized.)
1749: $Example 1: [ [(x Dx - h^2) (Dx^2)] [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
1750: $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
1751: $ [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
1752: ]] putUsages
1753:
1754:
1.1 maekawa 1755:
1756: ( ) message-quiet ;
1757:
1758:
1759:
1760:
1761:
1762:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to hol.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc