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