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