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