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