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