Annotation of OpenXM/src/kan96xx/Doc/hol.sm1, Revision 1.28
1.28 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.27 2012/09/16 01:53:08 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.18 takayama 17: /gb.oxRingStructure [[ ] [ ]] def
1.1 maekawa 18: /rank.v [(x) (y) (z)] def %% default value of v (variables).
19: /rank.ch [ ] def %% characteristic variety.
20: /rank.verbose 0 def
21: /rank {
22: /arg1 set
23: [/in-rank /aa /typev /setarg /f /v /vsss /vddd
24: /gg /wv /vd /vdweight /chv
25: /one
26: ] pushVariables
27: [(CurrentRingp) (KanGBmessage)] pushEnv
28: [
29:
30: /aa arg1 def
31: aa isArray { } { ( << array >> rank) error } ifelse
32: /setarg 0 def
33: aa { tag } map /typev set
34: typev [ ArrayP ] eq
35: { /f aa 0 get def
36: /v rank.v def
37: /setarg 1 def
38: } { } ifelse
39: typev [ArrayP StringP] eq
40: { /f aa 0 get def
41: /v [ aa 1 get to_records pop ] def
42: /setarg 1 def
43: } { } ifelse
44: typev [ArrayP ArrayP] eq
45: { /f aa 0 get def
46: /v aa 1 get def
47: /setarg 1 def
48: } { } ifelse
49: setarg { } { (rank : Argument mismatch) error } ifelse
50:
51: [(KanGBmessage) rank.verbose ] system_variable
52:
53: f { toString } map /f set
54: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
55: /vddd set %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
56: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
57: /vd set %% vd = [(Dx) (Dy) (Dz)]
58: /vdweight
59: vd { [ 2 1 roll -1 ] } map %% vdweight=[[(Dx) -1] [(Dy) -1] [(Dz) -1]]
60: def
61:
62: [v from_records
63: ring_of_differential_operators [vddd] weight_vector 0] define_ring
64: f { . dehomogenize } map /f set
65: [f] groebner_sugar 0 get /gg set
66:
67: /wv vddd weightv def
68: gg { wv init } map /chv set %%obtained the characteristic variety.
69: /rank.ch chv def
70: chv { toString } map /chv set
71:
72: [ v vd join from_records
73: ring_of_polynomials
74: [vddd] vdweight join weight_vector
75: 0
76: ] define_ring
77: [chv {.} map] groebner_sugar 0 get { init } map /chii set
78:
79: /rank.chii chii def
80: rank.verbose { chii message } { } ifelse
81: v {[ 2 1 roll . (1).]} map /one set
82: %% [[(x). (1).] [(y). (1).] [(z). (1).]]
83: %% chii { one replace } map %% buggy code.
84: %% Arg of hilb should be a reduced GB.
85: [chii { one replace } map] groebner 0 get
86: vd hilb /arg1 set
87: ] pop
88: popEnv
89: popVariables
90: arg1
91: } def
92:
93:
94: [(rank)
95: [( a rank b)
96: ( array a; number b)
97: (Example 1 : )
98: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rank :: $
99: (Example 2 : )
100: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] rank :: $
101: ]
102: ] putUsages
103: (rank ) messagen-quiet
104:
105: /characteristic.verbose 0 def
106: /characteristic.v [(x) (y) (z)] def
107: /characteristic.ch [ ] def
108: /ch { characteristic } def
109: /characteristic {
110: /arg1 set
111: [/in-rank /aa /typev /setarg /f /v /vsss /vddd
112: /gg /wv /vd /chv
113: /one
114: ] pushVariables
115: [(CurrentRingp) (KanGBmessage)] pushEnv
116: [
117:
118: /aa arg1 def
119: aa isArray { } { ( << array >> characteristic) error } ifelse
120: /setarg 0 def
121: aa { tag } map /typev set
122: typev [ ArrayP ] eq
123: { /f aa 0 get def
124: /v characteristic.v def
125: /setarg 1 def
126: } { } ifelse
127: typev [ArrayP StringP] eq
128: { /f aa 0 get def
129: /v [ aa 1 get to_records pop ] def
130: /setarg 1 def
131: } { } ifelse
132: typev [ArrayP ArrayP] eq
133: { /f aa 0 get def
134: /v aa 1 get def
135: /setarg 1 def
136: } { } ifelse
137: setarg { } { (rank : Argument mismatch) error } ifelse
138:
139: [(KanGBmessage) characteristic.verbose ] system_variable
140:
141: f { toString } map /f set
142: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
143: /vddd set %% vddd = [(Dx) 1 (Dy) 1 (Dz) 1]
144: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
145: /vd set %% vd = [(Dx) (Dy) (Dz)]
146:
147: [v from_records
148: ring_of_differential_operators [vddd] weight_vector 0] define_ring
149: f { . dehomogenize } map /f set
150: [f] groebner_sugar 0 get /gg set
151:
152: /wv vddd weightv def
153: gg { wv init } map /chv set
154: /characteristic.ch [chv] def
155: %% gg { wv init toString} map /chv set %%obtained the characteristic variety.
156: %% /characteristic.ch chv def
157:
158: %% [ v vd join from_records
159: %% ring_of_polynomials
160: %% [vddd] weight_vector
161: %% 0
162: %% ] define_ring
163: %% [chv {.} map] groebner_sugar 0 get /characteristic.ch set
164:
165: characteristic.ch /arg1 set
166: ] pop
167: popEnv
168: popVariables
169: arg1
170: } def
171:
172: [(characteristic)
173: [( a characteristic b)
174: ( array a; number b)
175: (b is the generator of the characteristic variety of a.)
176: (For the algorithm, see Japan J. of Industrial and Applied Math., 1994, 485--497.)
177: (Example 1 : )
178: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] characteristic :: $
179: (Example 2 : )
180: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] characteristic :: $
181: ]
182: ] putUsages
183: (characteristic ) messagen-quiet
184: [(ch)
185: [(ch is the abbreviation of characteristic.)
186: ( a ch b)
187: ( array a; number b)
188: (b is the generator of the characteristic variety of a.)
189: (For the algorithm, see, Japan J. of Industrial and Applied Math., 1994, 485--497.)
190: (Example 1 : )
191: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] ch :: $
192: (Example 2 : )
193: $[ [( (x^3-y^2) Dx + 3 x^2) ( (x^3-y^2) Dy - 2 y)] (x,y)] ch :: $
194: ]
195: ] putUsages
196: (ch ) messagen-quiet
197:
198: %%%% developing rrank.sm1
199: /rrank.v [(x) (y) (z)] def %% default value of v (variables).
200: /rrank.init [ ] def %% initial ideal.
201: /rrank.verbose 0 def
202: /rrank {
203: /arg1 set
204: [/in-rrank /aa /typev /setarg /f /v /vsss /vddd
205: /gg /wv /vd /vdweight
206: /one /i /chv
207: ] pushVariables
208: [(CurrentRingp) (KanGBmessage)] pushEnv
209: [
210:
211: /aa arg1 def
212: aa isArray { } { ( << array >> rrank) error } ifelse
213: /setarg 0 def
214: aa { tag } map /typev set
215: typev [ ArrayP ] eq
216: { /f aa 0 get def
217: /v rrank.v def
218: /setarg 1 def
219: } { } ifelse
220: typev [ArrayP StringP] eq
221: { /f aa 0 get def
222: /v [ aa 1 get to_records pop ] def
223: /setarg 1 def
224: } { } ifelse
225: typev [ArrayP ArrayP] eq
226: { /f aa 0 get def
227: /v aa 1 get def
228: /setarg 1 def
229: } { } ifelse
230: setarg { } { (rrank : Argument mismatch) error } ifelse
231:
232: [(KanGBmessage) rrank.verbose ] system_variable
233:
234: f { toString } map /f set
235: v { @@@.Dsymbol 2 1 roll 2 cat_n 1 } map
236:
237: v { @@@.Dsymbol 2 1 roll 2 cat_n } map
238: /vd set %% vd = [(Dx) (Dy) (Dz)] , v = [(x) (y) (z)]
239: /vdweight
240: [ 0 1 v length 1 sub { /i set v i get << 0 i sub >>
241: vd i get << i >> } for ]
242: def
243: rrank.verbose { vdweight message } { } ifelse
244:
245: [v from_records
246: ring_of_differential_operators [vdweight] weight_vector 0] define_ring
247: f { . dehomogenize homogenize } map /f set
248: [f] groebner 0 get {dehomogenize} map /gg set
249:
250: /wv vdweight weightv def
251: gg { wv init } map /rrank.init set %%obtained the initial ideal
252: rrank.init {toString} map /chv set
253: /arg1 [chv v] rank def
254: ] pop
255: popEnv
256: popVariables
257: arg1
258: } def
259:
260:
261: [(rrank)
262: [( a rrank b)
263: ( array a; number b)
264: (It computes the holonomic rank for regular holonomic system.)
265: (For the algorithm, see Grobner deformations of hypergeometric differential equations, 1999, Springer.)
266: (Chapter 2.)
267: (Example 1 : )
268: $ [ [( (x Dx)^2 + ( y Dy)^2) ( x Dx y Dy -1)] (x,y)] rrank :: $
269: ]
270: ] putUsages
271: (rrank ) messagen-quiet
272:
1.23 takayama 273:
274: % Take the value of arg1 in prior.
275: /mergeGroebnerOptions {
276: /arg2 set
277: /arg1 set
278: [/loc /glo /ans] pushVariables
279: [
280: /loc arg1 def
281: /glo arg2 def
282: /ans [ ] def
283: {
284: loc tag 0 eq { /ans glo def exit } { } ifelse
285: /ans glo loc join def
286: exit
287: } loop
288: /arg1 ans def
289: ] pop
290: popVariables
291: arg1
292: } def
293:
1.1 maekawa 294: /gb.v 1 def
295: /gb.verbose 0 def
1.4 takayama 296: /gb.options [ ] def
1.13 takayama 297: /gb.characteristic 0 def
1.14 takayama 298: /gb.homogenized 0 def
299: /gb.autoHomogenize 1 def
1.1 maekawa 300: /gb {
301: /arg1 set
302: [/in-gb /aa /typev /setarg /f /v
303: /gg /wv /termorder /vec /ans /rr /mm
1.23 takayama 304: /degreeShift /env2 /groebnerOptions
1.1 maekawa 305: ] pushVariables
306: [(CurrentRingp) (KanGBmessage)] pushEnv
307: [
308:
309: /aa arg1 def
310: aa isArray { } { ( << array >> gb) error } ifelse
1.23 takayama 311: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1 maekawa 312: /setarg 0 def
313: /wv 0 def
1.11 takayama 314: /degreeShift 0 def
1.1 maekawa 315: aa { tag } map /typev set
316: typev [ ArrayP ] eq
317: { /f aa 0 get def
318: /v gb.v def
319: /setarg 1 def
320: } { } ifelse
321: typev [ArrayP StringP] eq
322: { /f aa 0 get def
323: /v aa 1 get def
324: /setarg 1 def
325: } { } ifelse
1.10 takayama 326: typev [ArrayP RingP] eq
327: { /f aa 0 get def
328: /v aa 1 get def
329: /setarg 1 def
330: } { } ifelse
1.1 maekawa 331: typev [ArrayP ArrayP] eq
332: { /f aa 0 get def
333: /v aa 1 get from_records def
334: /setarg 1 def
335: } { } ifelse
336: typev [ArrayP StringP ArrayP] eq
337: { /f aa 0 get def
338: /v aa 1 get def
339: /wv aa 2 get def
340: /setarg 1 def
341: } { } ifelse
342: typev [ArrayP ArrayP ArrayP] eq
343: { /f aa 0 get def
344: /v aa 1 get from_records def
345: /wv aa 2 get def
346: /setarg 1 def
347: } { } ifelse
1.11 takayama 348: typev [ArrayP StringP ArrayP ArrayP] eq
349: { /f aa 0 get def
350: /v aa 1 get def
351: /wv aa 2 get def
352: /degreeShift aa 3 get def
353: /setarg 1 def
354: } { } ifelse
355: typev [ArrayP ArrayP ArrayP ArrayP] eq
356: { /f aa 0 get def
357: /v aa 1 get from_records def
358: /wv aa 2 get def
359: /degreeShift aa 3 get def
360: /setarg 1 def
361: } { } ifelse
1.1 maekawa 362:
1.12 takayama 363: /env1 getOptions def
364:
1.1 maekawa 365: setarg { } { (gb : Argument mismatch) error } ifelse
366:
367: [(KanGBmessage) gb.verbose ] system_variable
368:
369: %%% Start of the preprocess
1.10 takayama 370: v tag RingP eq {
371: /rr v def
372: }{
373: f getRing /rr set
374: } ifelse
1.1 maekawa 375: %% To the normal form : matrix expression.
376: f gb.toMatrixOfString /f set
377: /mm gb.itWasMatrix def
378:
1.14 takayama 379: rr tag 0 eq
380: v isInteger not
381: or {
1.1 maekawa 382: %% Define our own ring
383: v isInteger {
384: (Error in gb: Specify variables) error
385: } { } ifelse
386: wv isInteger {
387: [v ring_of_differential_operators
1.13 takayama 388: gb.characteristic] define_ring
1.1 maekawa 389: /termorder 1 def
390: }{
1.11 takayama 391: degreeShift isInteger {
392: [v ring_of_differential_operators
393: wv weight_vector
1.13 takayama 394: gb.characteristic] define_ring
1.11 takayama 395: wv gb.isTermOrder /termorder set
396: }{
397: [v ring_of_differential_operators
398: wv weight_vector
1.13 takayama 399: gb.characteristic
1.11 takayama 400: [(degreeShift) degreeShift]
401: ] define_ring
402: wv gb.isTermOrder /termorder set
403: } ifelse
1.1 maekawa 404: } ifelse
405: } {
406: %% Use the ring structre given by the input.
407: rr ring_def
408: /wv rr gb.getWeight def
409: wv gb.isTermOrder /termorder set
410: } ifelse
411: %%% Enf of the preprocess
412:
1.14 takayama 413: termorder {
414: /gb.homogenized 0 def
415: }{
416: /gb.homogenized 1 def
417: } ifelse
1.23 takayama 418: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
419: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1 maekawa 420: termorder {
1.22 takayama 421: f { {___ dehomogenize} map } map /f set
1.23 takayama 422: [f groebnerOptions] groebner_sugar 0 get /gg set
1.1 maekawa 423: }{
1.22 takayama 424: f { {___ dehomogenize} map} map /f set
1.14 takayama 425: gb.autoHomogenize {
426: f fromVectors { homogenize } map /f set
427: } { } ifelse
1.23 takayama 428: [f groebnerOptions] groebner 0 get /gg set
1.1 maekawa 429: }ifelse
430: wv isInteger {
431: /ans [gg gg {init} map] def
432: }{
433: /ans [gg gg {wv 0 get weightv init} map] def
434: }ifelse
435:
436: %% Postprocess : recover the matrix expression.
437: mm {
438: ans { /tmp set [mm tmp] toVectors } map
439: /ans set
440: }{ }
441: ifelse
1.17 takayama 442: ans getRing (oxRingStructure) dc /gb.oxRingStructure set
1.23 takayama 443: %% gg getAttributeList message
444: ans gg getAttributeList setAttributeList /ans set
1.1 maekawa 445: %%
1.12 takayama 446: env1 restoreOptions %% degreeShift changes "grade"
1.1 maekawa 447:
448: /arg1 ans def
449: ] pop
450: popEnv
451: popVariables
452: arg1
453: } def
454: (gb ) messagen-quiet
455:
456: /pgb {
457: /arg1 set
458: [/in-pgb /aa /typev /setarg /f /v
459: /gg /wv /termorder /vec /ans /rr /mm
1.23 takayama 460: /groebnerOptions
1.1 maekawa 461: ] pushVariables
462: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
463: [
464:
465: /aa arg1 def
466: aa isArray { } { (<< array >> pgb) error } ifelse
1.23 takayama 467: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1 maekawa 468: /setarg 0 def
469: /wv 0 def
470: aa { tag } map /typev set
471: typev [ ArrayP ] eq
472: { /f aa 0 get def
473: /v gb.v def
474: /setarg 1 def
475: } { } ifelse
476: typev [ArrayP StringP] eq
477: { /f aa 0 get def
478: /v aa 1 get def
479: /setarg 1 def
480: } { } ifelse
481: typev [ArrayP ArrayP] eq
482: { /f aa 0 get def
483: /v aa 1 get from_records def
484: /setarg 1 def
485: } { } ifelse
486: typev [ArrayP StringP ArrayP] eq
487: { /f aa 0 get def
488: /v aa 1 get def
489: /wv aa 2 get def
490: /setarg 1 def
491: } { } ifelse
492: typev [ArrayP ArrayP ArrayP] eq
493: { /f aa 0 get def
494: /v aa 1 get from_records def
495: /wv aa 2 get def
496: /setarg 1 def
497: } { } ifelse
498:
499: setarg { } { (pgb : Argument mismatch) error } ifelse
500:
501: [(KanGBmessage) gb.verbose ] system_variable
502:
503: %%% Start of the preprocess
504: f getRing /rr set
505: %% To the normal form : matrix expression.
506: f gb.toMatrixOfString /f set
507: /mm gb.itWasMatrix def
508:
509: rr tag 0 eq {
510: %% Define our own ring
511: v isInteger {
512: (Error in pgb: Specify variables) error
513: } { } ifelse
514: wv isInteger {
515: [v ring_of_polynomials
1.13 takayama 516: gb.characteristic] define_ring
1.1 maekawa 517: /termorder 1 def
518: }{
519: [v ring_of_polynomials
520: wv weight_vector
1.13 takayama 521: gb.characteristic] define_ring
1.1 maekawa 522: wv gb.isTermOrder /termorder set
523: } ifelse
524: } {
525: %% Use the ring structre given by the input.
526: v isInteger not {
1.7 takayama 527: gb.warning {
528: (Warning : the given ring definition is not used.) message
529: } { } ifelse
1.1 maekawa 530: } { } ifelse
531: rr ring_def
532: /wv rr gb.getWeight def
533: wv gb.isTermOrder /termorder set
534: } ifelse
535: %%% Enf of the preprocess
536:
1.23 takayama 537: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
1.25 takayama 538: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1 maekawa 539: termorder {
540: f { {. dehomogenize} map } map /f set
541: [(UseCriterion1) 1] system_variable
1.25 takayama 542: [f groebnerOptions] groebner_sugar 0 get /gg set
1.1 maekawa 543: [(UseCriterion1) 0] system_variable
544: }{
545: f { {. dehomogenize} map} map /f set
546: f fromVectors { homogenize } map /f set
547: [(UseCriterion1) 1] system_variable
1.23 takayama 548: [f groebnerOptions] groebner 0 get /gg set
1.1 maekawa 549: [(UseCriterion1) 0] system_variable
550: }ifelse
551: wv isInteger {
552: /ans [gg gg {init} map] def
553: }{
554: /ans [gg gg {wv 0 get weightv init} map] def
555: }ifelse
556:
557: %% Postprocess : recover the matrix expression.
558: mm {
559: ans { /tmp set [mm tmp] toVectors } map
560: /ans set
561: }{ }
562: ifelse
563: %%
1.23 takayama 564: ans gg getAttributeList setAttributeList /ans set
1.1 maekawa 565:
566: /arg1 ans def
567: ] pop
568: popEnv
569: popVariables
570: arg1
571: } def
572:
573: /pgb.old {
574: /arg1 set
575: [/in-pgb /aa /typev /setarg /f /v
576: /gg /wv /termorder /vec /ans
577: ] pushVariables
578: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
579: [
580:
581: /aa arg1 def
582: aa isArray { } { (array pgb) message (pgb) usage error } ifelse
583: /setarg 0 def
584: /wv 0 def
585: aa { tag } map /typev set
586: typev [ ArrayP ] eq
587: { /f aa 0 get def
588: /v gb.v def
589: /setarg 1 def
590: } { } ifelse
591: typev [ArrayP StringP] eq
592: { /f aa 0 get def
593: /v aa 1 get def
594: /setarg 1 def
595: } { } ifelse
596: typev [ArrayP ArrayP] eq
597: { /f aa 0 get def
598: /v aa 1 get from_records def
599: /setarg 1 def
600: } { } ifelse
601: typev [ArrayP StringP ArrayP] eq
602: { /f aa 0 get def
603: /v aa 1 get def
604: /wv aa 2 get def
605: /setarg 1 def
606: } { } ifelse
607: typev [ArrayP ArrayP ArrayP] eq
608: { /f aa 0 get def
609: /v aa 1 get from_records def
610: /wv aa 2 get def
611: /setarg 1 def
612: } { } ifelse
613:
614: setarg { } { (pgb : Argument mismatch) message error } ifelse
615:
616: [(KanGBmessage) gb.verbose ] system_variable
617:
618: %% Input must not be vectors.
619: f { toString } map /f set
620:
621: wv isInteger {
622: [v ring_of_polynomials
623: 0] define_ring
624: /termorder 1 def
625: }{
626: [v ring_of_polynomials
627: wv weight_vector
628: 0] define_ring
629: wv gb.isTermOrder /termorder set
630: } ifelse
631: termorder {
632: f { . dehomogenize } map /f set
633: [(UseCriterion1) 1] system_variable
634: [f] groebner_sugar 0 get /gg set
635: [(UseCriterion1) 0] system_variable
636: }{
637: f { . dehomogenize homogenize} map /f set
638: [(UseCriterion1) 1] system_variable
639: [f] groebner 0 get /gg set
640: [(UseCriterion1) 0] system_variable
641: }ifelse
642: wv isInteger {
643: /ans [gg gg {init} map] def
644: }{
645: /ans [gg gg {wv 0 get weightv init} map] def
646: }ifelse
647: /arg1 ans def
648: ] pop
649: popEnv
650: popVariables
651: arg1
652: } def
653: (pgb ) messagen-quiet
654:
655: /gb.toMatrixOfString {
656: /arg1 set
657: [/in-gb.toMatrixOfString /ff /aa /ans] pushVariables
658: [
659: /aa arg1 def
660: aa length 0 eq { /ans [ ] def /gb.toMatrixOfString.LLL goto }{ } ifelse
661: aa 0 get isArray {
662: /gb.itWasMatrix aa 0 get length def
663: }{
664: /gb.itWasMatrix 0 def
665: } ifelse
666: aa {
667: /ff set
668: ff isArray {
669: ff {toString} map /ff set
670: }{
671: [ff toString] /ff set
672: } ifelse
673: ff
674: } map /ans set
675: /gb.toMatrixOfString.LLL
676: /arg1 ans def
677: ] pop
678: popVariables
679: arg1
680: } def
681: [(gb.toMatrixOfString)
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.toMatrixOfString ==> [[(x)] [(y)]] $
687: $ gb.itWasMatrix is 0.$
688: $Example 2: $
689: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfString ==> [ [(x) (1)] [(y) (0)]] $
690: $ gb.itWasMatrix is 2.$
691: ]] putUsages
692:
693: /gb.toMatrixOfPoly {
694: /arg1 set
695: [/in-gb.toMatrixOfPoly /ff /aa /ans] pushVariables
696: [
697: /aa arg1 def
698: aa length 0 eq { /ans [ ] def /gb.toMatrixOfPoly.LLL goto }{ } ifelse
699: aa 0 get isArray {
700: /gb.itWasMatrix aa 0 get length def
701: }{
702: /gb.itWasMatrix 0 def
703: } ifelse
704: aa {
705: /ff set
706: ff isArray {
707: }{
708: [ff] /ff set
709: } ifelse
710: ff
711: } map /ans set
712: /gb.toMatrixOfPoly.LLL
713: /arg1 ans def
714: ] pop
715: popVariables
716: arg1
717: } def
718: [(gb.toMatrixOfPoly)
719: [(It translates given input into a matrix form which is a data structure)
720: (for computations of kernel, image, cokernel, etc.)
721: (gb.itWasMatrix is set to the length of the input vector.)
722: $Example 1: $
723: $ [ (x). (y).] gb.toMatrixOfPoly ==> [[(x)] [(y)]] $
724: $ gb.itWasMatrix is 0.$
725: $Example 2: $
726: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfPoly ==> [ [(x) (1)] [(y) (0)]] $
727: $ gb.itWasMatrix is 2.$
728: ]] putUsages
729:
730: /gb.getWeight {
731: /arg1 set
732: [/in-gb.getWeight /rr /ww /vv /ans /nn /ii] pushVariables
733: [(CurrentRingp)] pushEnv
734: [
735: /rr arg1 def
736: rr ring_def
737: getVariableNames /vv set
738: [(orderMatrix)] system_variable 0 get /ww set
739: /nn vv length 1 sub def
740: [0 1 nn {
741: /ii set
742: ww ii get 0 eq {
743: } {
744: vv ii get
745: ww ii get
746: } ifelse
747: } for
748: ] /ans set
749: /arg1 [ans] def
750: ] pop
751: popEnv
752: popVariables
753: arg1
754: } def
755: [(gb.getWeight)
756: [(ring gb.getWeight wv)
757: (It gets the weight vector field of the ring ring.)
758: ]] putUsages
759:
760:
761: /gb.isTermOrder {
762: /arg1 set
763: [/in-gb.isTermOrder /vv /ww /yes /i /j] pushVariables
764: [
765: /vv arg1 def
766: /yes 1 def
767: 0 1 vv length 1 sub {
768: /i set
769: /ww vv i get def
770: 0 1 ww length 1 sub {
771: /j set
772: ww j get isInteger {
773: ww j get 0 lt { /yes 0 def } { } ifelse
774: }{ } ifelse
775: }for
776: }for
777: /arg1 yes def
778: ] pop
779: popVariables
780: arg1
781: } def
782: [(gb)
783: [(a gb b)
784: (array a; array b;)
785: (b : [g ii]; array g; array in; g is a Grobner basis of f)
786: ( in the ring of differential operators.)
787: $ ii is the initial ideal in case of w is given or <<a>> belongs$
788: $ to a ring. In the other cases, it returns the initial monominal.$
789: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
790: (a : [f v]; array f; string v; v is the variables. )
791: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.11 takayama 792: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
793: ( array ds; ds is the degree shift )
1.1 maekawa 794: ( )
1.14 takayama 795: (gb.authoHomogenize 1 [default])
1.17 takayama 796: (gb.oxRingStructure )
1.14 takayama 797: ( )
1.1 maekawa 798: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
799: $ [ [ (Dx) 1 ] ] ] gb pmat ; $
800: (Example 2: )
801: (To put h=1, type in, e.g., )
802: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
803: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] gb /gg set gg dehomogenize pmat ;$
804: ( )
805: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
806: $ [ [ (Dx) 1 (Dy) 1] ] ] gb pmat ; $
807: ( )
808: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
809: $ [ [ (x) -1 (y) -1] ] ] gb pmat ; $
1.12 takayama 810: ( )
811: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
812: $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] gb pmat ; $
1.23 takayama 813: ( )
814: $Example 6: [ [( (x Dx)^2 + (y Dy)^2 - x y Dx Dy + 1) ( x y Dx Dy -1)] (x,y) $
815: $ [ [ (Dx) 1 ] ] ] [(reduceOnly) 1] setAttributeList gb pmat ; $
816: ( )
817: $Example 7: [ [( (x Dx)^2 + (y Dy)^2 + 1) ( x y Dx Dy -1)] (x,y) $
818: $ [ [ (Dx) 1 ] ] ] [(gbCheck) 1] setAttributeList gb getAttributeList ::$
1.1 maekawa 819: ( )
1.28 ! takayama 820: $Example 8: /gb.options [(StopDegree) 11] def Onverbose $
! 821: $ [ [(x^10+y^10-1) (x^5*y^5 -1)] (x,y) $
! 822: $ [ [ (x) 1 ] ]] gb pmat ; $
! 823: ( )
1.1 maekawa 824: (cf. gb, groebner, groebner_sugar, syz. )
825: ]] putUsages
826:
827: [(pgb)
828: [(a pgb b)
829: (array a; array b;)
830: (b : [g ii]; array g; array in; g is a Grobner basis of f)
831: ( in the ring of polynomials.)
832: $ ii is the initial ideal in case of w is given or <<a>>belongs$
833: $ to a ring. In the other cases, it returns the initial monominal.$
834: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
835: (a : [f v]; array f; string v; v is the variables.)
836: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
837: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
838: $ [ [(x^2+y^2-4). (x y -1).] ] pgb :: $
839: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] pgb :: $
1.23 takayama 840: $Example 3: [ [(x^2+y^2 + x y ) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] $
1.24 takayama 841: $ [(reduceOnly) 1] setAttributeList pgb :: $
1.1 maekawa 842: (cf. gb, groebner, groebner_sugar, syz. )
843: ]] putUsages
844:
845:
846: %/syz.v 1 def
847: /syz.v 1 def
848: /syz.verbose 0 def
849: /syz {
850: /arg1 set
851: [/in-syz /aa /typev /setarg /f /v
852: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
853: /rr /mm
854: ] pushVariables
855: [(CurrentRingp) (KanGBmessage)] pushEnv
856: [
857:
858: /aa arg1 def
859: aa isArray { } { (<< array >> syz) error } ifelse
860: /setarg 0 def
861: /wv 0 def
862: aa { tag } map /typev set
863: typev [ ArrayP ] eq
864: { /f aa 0 get def
865: /v syz.v def
866: /setarg 1 def
867: } { } ifelse
868: typev [ArrayP StringP] eq
869: { /f aa 0 get def
870: /v aa 1 get def
871: /setarg 1 def
872: } { } ifelse
1.9 takayama 873: typev [ArrayP RingP] eq
874: { /f aa 0 get def
875: /v aa 1 get def
876: /setarg 1 def
877: } { } ifelse
1.1 maekawa 878: typev [ArrayP ArrayP] eq
879: { /f aa 0 get def
880: /v aa 1 get from_records def
881: /setarg 1 def
882: } { } ifelse
883: typev [ArrayP StringP ArrayP] eq
884: { /f aa 0 get def
885: /v aa 1 get def
886: /wv aa 2 get def
887: /setarg 1 def
888: } { } ifelse
1.9 takayama 889: typev [ArrayP RingP ArrayP] eq
890: { /f aa 0 get def
891: /v aa 1 get def
892: /wv aa 2 get def
893: /setarg 1 def
894: } { } ifelse
1.1 maekawa 895: typev [ArrayP ArrayP ArrayP] eq
896: { /f aa 0 get def
897: /v aa 1 get from_records def
898: /wv aa 2 get def
899: /setarg 1 def
900: } { } ifelse
901:
902: setarg { } { (syz : Argument mismatch) error } ifelse
903:
904: [(KanGBmessage) syz.verbose ] system_variable
905:
906:
907:
908: %%% Start of the preprocess
1.9 takayama 909: v tag RingP eq {
910: /rr v def
911: }{
912: f getRing /rr set
913: } ifelse
1.1 maekawa 914: %% To the normal form : matrix expression.
915: f gb.toMatrixOfString /f set
916: /mm gb.itWasMatrix def
917: mm 0 gt {
918: /vectorInput 1 def
919: }{
920: /vectorInput 1 def
921: } ifelse
922:
923: rr tag 0 eq {
924: %% Define our own ring
925: v isInteger {
926: (Error in syz: Specify variables) error
927: } { } ifelse
928: wv isInteger {
929: [v ring_of_differential_operators
930: 0] define_ring
931: /termorder 1 def
932: }{
933: [v ring_of_differential_operators
934: wv weight_vector
935: 0] define_ring
936: wv gb.isTermOrder /termorder set
937: } ifelse
938: }{
939: %% Use the ring structre given by the input.
940: v isInteger not {
1.7 takayama 941: gb.warning {
942: (Warning : the given ring definition is not used.) message
943: } { } ifelse
1.1 maekawa 944: } { } ifelse
945: rr ring_def
946: /wv rr gb.getWeight def
947: wv gb.isTermOrder /termorder set
948: } ifelse
949: %%% Enf of the preprocess
950:
951: termorder {
952: f { {. dehomogenize} map } map /f set
953: [f [(needBack) (needSyz)]] groebner_sugar /ggall set
954: ggall 2 get /gg set
955: }{
956: f { {. dehomogenize } map homogenize } map /f set
957: [f [(needBack) (needSyz)]] groebner /ggall set
958: ggall 2 get /gg set
959: }ifelse
960: vectorInput {
961: /vsize f 0 get length def %% input vector size.
962: /gtmp ggall 0 get def
963: [vsize gtmp] toVectors /gtmp set
964: ggall 0 gtmp put
965: }{ } ifelse
1.19 takayama 966:
1.27 takayama 967: gg length 0 eq { % there is no syzygy
968: ggall getRing (oxRingStructure) dc /gb.oxRingStructure set
969: }{
970: gg getRing (oxRingStructure) dc /gb.oxRingStructure set
971: } ifelse
1.19 takayama 972:
973: /arg1 [gg dehomogenize ggall] def
1.1 maekawa 974: ] pop
975: popEnv
976: popVariables
977: arg1
978: } def
979: (syz ) messagen-quiet
980:
981: [(syz)
982: [(a syz [b c])
983: (array a; array b; array c)
984: (b is a set of generators of the syzygies of f.)
985: (c = [gb, backward transformation, syzygy without dehomogenization].)
986: (See groebner.)
987: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
988: (a : [f v]; array f; string v; v is the variables.)
989: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.9 takayama 990: ( v may be a ring object. )
1.1 maekawa 991: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
992: $ [ [(x^2+y^2-4). (x y -1).] ] syz :: $
993: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] syz :: $
994: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
995: $ [ [ (Dx) 1 ] ] ] syz pmat ; $
996: $Example 4: [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
997: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
998: $Example 5: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
999: $ (x,y) ] syz pmat ;$
1000: $Example 6: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
1001: $ (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
1002: $Example 7: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1003: $ [(x) (y)]] syz pmat ;$
1004: ]] putUsages
1005:
1006:
1007: %%%%%%%%%%%%%%%%%% package fs %%%%%%%%%%%%%%%%%%%%%%%
1008: [(genericAnn)
1009: [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
1010: (L1, ..., Lm are annihilating ideal for f^s.)
1011: (f is a polynomial of v1, ..., vn)
1012: (<string> | <poly> f, s, v1, ..., vn ; <poly> L1, ..., Lm )
1013: $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
1014: ]
1015: ] putUsages ( genericAnn ) messagen-quiet
1016: /fs.verbose 0 def
1017: /genericAnn {
1018: /arg2 set /arg1 set
1019: [/in-genericAnn /f /vlist /s /vvv /nnn /rrr
1020: /v1 /ops /ggg /ggg0
1021: ] pushVariables
1022: [(CurrentRingp) (KanGBmessage)] pushEnv
1023: [
1024: /f arg1 def /vlist arg2 def
1025: f toString /f set
1026: vlist { toString } map /vlist set
1027: [(KanGBmessage) fs.verbose] system_variable
1028: /s vlist 0 get def
1029: /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
1030: s nnn 2 add cat_n def
1031: fs.verbose { vvv message } { }ifelse
1032: [vvv ring_of_differential_operators
1033: [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
1034:
1035: [ (_u*_t). f . sub (_u*_v-1). ]
1036: vlist rest { /v1 set
1037: %%D-clean f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
1038: f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
1039: @@@.Dsymbol v1 2 cat_n . add } map
1040: join
1041: /ops set
1042: ops {[[(h). (1).]] replace } map /ops set
1043: fs.verbose { ops message } { }ifelse
1044: [ops] groebner_sugar 0 get /ggg0 set
1045: fs.verbose { ggg0 message } { } ifelse
1046: ggg0 [(_u) (_v)] eliminatev
1047: %%D-clean { [(_t).] [ (D_t).] [s .] distraction
1048: { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction
1049: [[s . << (0). s . sub (1). sub >>]] replace
1050: } map /arg1 set
1051: ] pop
1052: popEnv
1053: popVariables
1054: arg1
1055: } def
1056:
1057: %% Find differential equations for f^(m), r0 the minimal integral root.
1058: [(annfs)
1059: [( [ f v m r0] annfs g )
1060: (It returns the annihilating ideal of f^m where r0 must be smaller)
1061: (or equal to the minimal integral root of the b-function.)
1062: (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
1063: (where r0 is the minial integral root of b.)
1064: (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
1065: (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
1066: $ It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
1067: (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
1068: $ It returns the annihilating ideal of f^r0 and [r0, b-function]$
1069: $ where r0 is the minimal integral root of the b-function.$
1070: (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
1071: (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
1072: (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
1073: ( (t,x1,x2,x3) -1 -2] annfs :: )
1074: ( Note that the example 4 uses huge memory space.)
1.26 takayama 1075: ( )
1076: (Note: This implementation is stable but obsolete. )
1077: (As to faster implementation, we refer to ann0 and ann of Risa/Asir )
1078: (Visit http://www.math.kobe-u.ac.jp/Asir )
1.1 maekawa 1079: ]] putUsages
1080: ( annfs ) messagen-quiet
1081: /annfs.verbose fs.verbose def
1082: /annfs.v [(x) (y) (z)] def
1083: /annfs.s (_s) def
1084: %% The first variable must be s.
1085: /annfs {
1086: /arg1 set
1087: [/in-annfs /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1088: /ans /vtmp /w2 /velim /bbb /rrr /r0
1089: ] pushVariables
1090: [(CurrentRingp) (KanGBmessage)] pushEnv
1091: [
1092:
1093: /aa arg1 def
1094: aa isArray { } { ( << array >> annfs) error } ifelse
1095: /setarg 0 def
1096: aa { tag } map /typev set
1097: /r0 [ ] def
1098: /m [ ] def
1099: /v annfs.v def
1100: aa 0 << aa 0 get toString >> put
1101: typev [ StringP ] eq
1102: { /f aa 0 get def
1103: /setarg 1 def
1104: } { } ifelse
1105: typev [StringP StringP] eq
1106: { /f aa 0 get def
1107: /v [ aa 1 get to_records pop ] def
1108: /setarg 1 def
1109: } { } ifelse
1110: typev [StringP ArrayP] eq
1111: { /f aa 0 get def
1112: /v aa 1 get def
1113: /setarg 1 def
1114: } { } ifelse
1115: typev [StringP ArrayP IntegerP IntegerP] eq
1116: { /f aa 0 get def
1117: /v aa 1 get def
1118: /m aa 2 get def
1119: /r0 aa 3 get def
1120: /setarg 1 def
1121: } { } ifelse
1122: typev [StringP StringP IntegerP IntegerP] eq
1123: { /f aa 0 get def
1124: /v [ aa 1 get to_records pop ] def
1125: /m aa 2 get def
1126: /r0 aa 3 get def
1127: /setarg 1 def
1128: } { } ifelse
1129: setarg 1 eq { } { (annfs : wrong argument) error } ifelse
1130:
1131: [annfs.s] v join /v set
1132:
1133: /ss v 0 get def
1134: annfs.verbose {
1135: (f, v, s, f^{m}, m+r0 = ) messagen
1136: [ f (, ) v (, ) ss (, )
1137: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1138: } { } ifelse
1139:
1140: f v genericAnn /fs set
1141:
1142: annfs.verbose {
1143: (genericAnn is ) messagen fs message
1144: } { } ifelse
1145: [(KanGBmessage) annfs.verbose] system_variable
1146:
1147: m isArray {
1148: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1149: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1150: velim { 1 } map /w2 set
1151: annfs.verbose { w2 message } { } ifelse
1152: [v from_records ring_of_differential_operators
1153: [w2] weight_vector 0] define_ring
1154: [ fs { toString . } map [ f toString . ] join ]
1155: groebner_sugar 0 get velim eliminatev 0 get /bbb set
1156: [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
1157: bbb toString . [[annfs.s . (s).]] replace /bbb set
1158: annfs.verbose { bbb message } { } ifelse
1159: bbb findIntegralRoots /rrr set
1160: rrr 0 get /r0 set %% minimal integral root.
1161: annfs.verbose { rrr message } { } ifelse
1162: fs 0 get (ring) dc ring_def
1163: fs { [[annfs.s . r0 toString .]] replace } map /ans set
1164: /ans [ans [r0 bbb]] def
1165: /annfs.label1 goto
1166: } { } ifelse
1167: m 0 ge {
1168: (annfs works only for getting annihilating ideal for f^(negative))
1169: error
1170: } { } ifelse
1171: r0 isArray {
1172: [(Need to compute the minimal root of b-function) nl
1173: (It has not been implemented.) ] cat
1174: error
1175: } { } ifelse
1176:
1177: [v from_records ring_of_differential_operators 0] define_ring
1178: fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace}
1179: map /gg set
1180: annfs.verbose { gg message } { } ifelse
1181:
1182: [ [f . << m r0 sub >> npower ] gg join
1183: [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
1184:
1185: gg2 { 0 get } map /ans set
1186: /ans ans { dup (0). eq {pop} { } ifelse } map def
1187:
1188: /annfs.label1
1189: /arg1 ans def
1190: ] pop
1191: popEnv
1192: popVariables
1193: arg1
1194: } def
1195:
1196: /genericAnnWithL.s (s) def
1197: /annfs.verify 0 def
1198: /genericAnnWithL {
1199: /arg1 set
1200: [/in-genericAnnWithL /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1201: /ans /vtmp /w2 /velim /bbb /rrr /r0 /myL /mygb /jj
1202: ] pushVariables
1203: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1204: [
1205:
1206: /aa arg1 def
1207: aa isArray { } { ( << array >> annfs) error } ifelse
1208: /setarg 0 def
1209: aa { tag } map /typev set
1210: /r0 [ ] def
1211: /m [ ] def
1212: /v annfs.v def
1213: aa 0 << aa 0 get toString >> put
1214: typev [ StringP ] eq
1215: { /f aa 0 get def
1216: /setarg 1 def
1217: } { } ifelse
1218: typev [StringP StringP] eq
1219: { /f aa 0 get def
1220: /v [ aa 1 get to_records pop ] def
1221: /setarg 1 def
1222: } { } ifelse
1223: typev [StringP ArrayP] eq
1224: { /f aa 0 get def
1225: /v aa 1 get def
1226: /setarg 1 def
1227: } { } ifelse
1228: setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse
1229:
1230: [genericAnnWithL.s] v join /v set
1231:
1232: /ss v 0 get def
1233: annfs.verbose {
1234: (f, v, s, f^{m}, m+r0 = ) messagen
1235: [ f (, ) v (, ) ss (, )
1236: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1237: } { } ifelse
1238:
1239: f v genericAnn /fs set
1240:
1241: annfs.verbose {
1242: (genericAnn is ) messagen fs message
1243: } { } ifelse
1244: [(KanGBmessage) annfs.verbose] system_variable
1245:
1246: m isArray {
1247: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1248: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1249: velim { 1 } map /w2 set
1250: annfs.verbose { w2 message } { } ifelse
1251: [v from_records ring_of_differential_operators
1252: [w2] weight_vector 0] define_ring
1253:
1254: [ [ f toString . ] fs { toString . } map join [(needBack)]]
1255: groebner_sugar /mygb set
1256: mygb 0 get velim eliminatev 0 get /bbb set
1257: mygb 0 get bbb position /jj set
1258: mygb 1 get jj get 0 get /myL set
1259:
1260: annfs.verbose { bbb message } { } ifelse
1261:
1262: annfs.verify {
1263: (Verifying L f - b belongs to genericAnn(f)) message
1264: [(Homogenize) 0] system_variable
1265: << myL f . mul bbb sub >>
1266: [fs { toString . } map] groebner_sugar 0 get
1267: reduction 0 get message
1268: (Is it zero? Then it's fine.) message
1269: } { } ifelse
1270:
1271: /ans [bbb [myL fs] ] def
1272: /annfs.label1 goto
1273: } { } ifelse
1274:
1275: /annfs.label1
1276: /arg1 ans def
1277: ] pop
1278: popEnv
1279: popVariables
1280: arg1
1281: } def
1282:
1283:
1284: [(genericAnnWithL)
1285: [$[f v] genericAnnWithL [b [L I]]$
1286: $String f,v; poly b,L; array of poly I;$
1287: $f is a polynomial given by a string. v is the variables.$
1288: $ v must not contain names s, e.$
1289: $b is the b-function (Bernstein-Sato polynomial) for f and$
1290: $ L is the operator satisfying L f^{s+1} = b(s) f^s $
1291: $ I is the annihilating ideal of f^s.$
1292: $cf. bfunction, annfs, genericAnn.$
1293: $Example 1: [(x^2+y^2) (x,y)] genericAnnWithL ::$
1294: $Example 2: [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
1295: $Example 3: [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
1296: ]] putUsages
1.2 takayama 1297:
1298: /reduction*.noH 0 def
1299: /reduction* {
1300: /arg1 set
1301: [/in-reduction* /aa /typev /setarg /f /v
1302: /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
1.3 takayama 1303: /opt
1.2 takayama 1304: ] pushVariables
1305: [(CurrentRingp) (KanGBmessage)] pushEnv
1306: [
1307:
1308: /aa arg1 def
1309: aa isArray { } { ( << array >> reduction*) error } ifelse
1310: /setarg 0 def
1311: /wv 0 def
1312: aa { tag } map /typev set
1313: typev [StringP ArrayP ArrayP] eq
1314: typev [ArrayP ArrayP ArrayP] eq or
1315: typev [PolyP ArrayP ArrayP] eq or
1316: { /h aa 0 get def
1317: /f aa 1 get def
1318: /v aa 2 get from_records def
1319: /setarg 1 def
1320: } { } ifelse
1321: typev [StringP ArrayP ArrayP ArrayP] eq
1322: typev [ArrayP ArrayP ArrayP ArrayP] eq or
1323: typev [PolyP ArrayP ArrayP ArrayP] eq or
1324: { /h aa 0 get def
1325: /f aa 1 get def
1326: /v aa 2 get from_records def
1327: /wv aa 3 get def
1328: /setarg 1 def
1329: } { } ifelse
1330:
1331: setarg { } { (reduction* : Argument mismatch) error } ifelse
1332:
1333: [(KanGBmessage) gb.verbose ] system_variable
1334:
1335: %%% Start of the preprocess
1336: f getRing /rr set
1337:
1338:
1339: rr tag 0 eq {
1340: %% Define our own ring
1341: v isInteger {
1342: (Error in reduction*: Specify variables) error
1343: } { } ifelse
1344: wv isInteger {
1345: [v ring_of_differential_operators
1346: 0] define_ring
1347: /termorder 1 def
1348: }{
1349: [v ring_of_differential_operators
1350: wv weight_vector
1351: 0] define_ring
1352: wv gb.isTermOrder /termorder set
1353: } ifelse
1354: } {
1355: %% Use the ring structre given by the input.
1356: v isInteger not {
1.7 takayama 1357: gb.warning {
1358: (Warning : the given ring definition is not used.) message
1359: } { } ifelse
1.2 takayama 1360: } { } ifelse
1361: rr ring_def
1362: /wv rr gb.getWeight def
1363: wv gb.isTermOrder /termorder set
1364: } ifelse
1365: %%% Enf of the preprocess
1366:
1367: f 0 get isArray {
1368: /size f 0 get length def
1369: f { { toString . } map } map /f set
1370: f fromVectors /f set
1371: }{
1372: /size -1 def
1373: f { toString . } map /f set
1374: } ifelse
1375:
1376: h isArray {
1377: h { toString . } map /h set
1378: [h] fromVectors 0 get /h set
1379: }{
1380: h toString . /h set
1381: } ifelse
1382: f { toString . } map /f set
1.3 takayama 1383: getOptions /opt set
1384: [(ReduceLowerTerms) 1] system_variable
1.2 takayama 1385: reduction*.noH {
1386: h f reduction-noH /ans set
1387: } {
1388: h f reduction /ans set
1389: } ifelse
1.3 takayama 1390: opt restoreOptions
1.2 takayama 1391: size -1 eq not {
1392: [size ans 0 get] toVectors /a0 set
1393: [size ans 3 get] toVectors /a3 set
1394: /ans [a0 ans 1 get ans 2 get a3] def
1395: } { } ifelse
1396: /arg1 ans def
1397: ] pop
1398: popEnv
1399: popVariables
1400: arg1
1401: } def
1402:
1403:
1404: [(reduction*)
1405: [([f base v] reduction* [h c0 syz input])
1406: ([f base v weight] reduction* [h c0 syz input])
1407: (reduction* is an user interface for reduction and reduction-noH.)
1408: (If reduction*.noH is one, then reduction-noH will be called.)
1409: (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
1410: (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
1411: (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
1412: ]] putUsages
1.5 takayama 1413:
1414:
1415:
1416: %% 2000, 6/7, at Sevilla, Hernando Colon
1417: %% macros that deal with homogenized inputs.
1418: %% Sample: [ [(h+x). (x^3).] [(x). (x).]] /ff set
1419: %% [(Homogenize_vec) 0] system_varialbe
1420: %% (grade) (grave1v) switch_function
1421: %% YA homogenization: [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
1422: %% 4+0 3+1 2+0 1+1
1423: /gb_h {
1424: /arg1 set
1425: [/in-gb_h /aa /typev /setarg /f /v
1426: /gg /wv /termorder /vec /ans /rr /mm
1.23 takayama 1427: /gb_h.opt /groebnerOptions
1.5 takayama 1428: ] pushVariables
1429: [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
1430: [
1431:
1432: /aa arg1 def
1.6 takayama 1433: gb.verbose { (Getting in gb_h) message } { } ifelse
1.5 takayama 1434: aa isArray { } { ( << array >> gb_h) error } ifelse
1.23 takayama 1435: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.5 takayama 1436: /setarg 0 def
1437: /wv 0 def
1438: aa { tag } map /typev set
1439: typev [ ArrayP ] eq
1440: { /f aa 0 get def
1441: /v gb.v def
1442: /setarg 1 def
1443: } { } ifelse
1444: typev [ArrayP StringP] eq
1445: { /f aa 0 get def
1446: /v aa 1 get def
1447: /setarg 1 def
1448: } { } ifelse
1.10 takayama 1449: typev [ArrayP RingP] eq
1450: { /f aa 0 get def
1451: /v aa 1 get def
1452: /setarg 1 def
1453: } { } ifelse
1.5 takayama 1454: typev [ArrayP ArrayP] eq
1455: { /f aa 0 get def
1456: /v aa 1 get from_records def
1457: /setarg 1 def
1458: } { } ifelse
1459: typev [ArrayP StringP ArrayP] eq
1460: { /f aa 0 get def
1461: /v aa 1 get def
1462: /wv aa 2 get def
1463: /setarg 1 def
1464: } { } ifelse
1465: typev [ArrayP ArrayP ArrayP] eq
1466: { /f aa 0 get def
1467: /v aa 1 get from_records def
1468: /wv aa 2 get def
1469: /setarg 1 def
1470: } { } ifelse
1471:
1472: setarg { } { (gb_h : Argument mismatch) error } ifelse
1473:
1474: [(KanGBmessage) gb.verbose ] system_variable
1475:
1476: %%% Start of the preprocess
1.10 takayama 1477: v tag RingP eq {
1478: /rr v def
1479: }{
1480: f getRing /rr set
1481: } ifelse
1.5 takayama 1482: %% To the normal form : matrix expression.
1483: f gb.toMatrixOfString /f set
1484: /mm gb.itWasMatrix def
1485:
1486: rr tag 0 eq {
1487: %% Define our own ring
1488: v isInteger {
1489: (Error in gb_h: Specify variables) error
1490: } { } ifelse
1491: wv isInteger {
1492: [v ring_of_differential_operators
1493: 0] define_ring
1494: /termorder 1 def
1495: }{
1496: [v ring_of_differential_operators
1497: wv weight_vector
1498: 0] define_ring
1499: wv gb.isTermOrder /termorder set
1500: } ifelse
1501: } {
1502: %% Use the ring structre given by the input.
1503: v isInteger not {
1.7 takayama 1504: gb.warning {
1505: (Warning : the given ring definition is not used.) message
1506: } { } ifelse
1.5 takayama 1507: } { } ifelse
1508: rr ring_def
1509: /wv rr gb.getWeight def
1510: wv gb.isTermOrder /termorder set
1511: } ifelse
1512: getOptions /gb_h.opt set
1513: (grade) (module1v) switch_function
1.6 takayama 1514: [(Homogenize_vec) 0] system_variable
1.5 takayama 1515: %%% End of the preprocess
1516:
1.23 takayama 1517: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
1518: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.5 takayama 1519: termorder {
1520: f { {. } map } map /f set
1.23 takayama 1521: [f groebnerOptions] groebner 0 get /gg set %% Do not use sugar.
1.5 takayama 1522: }{
1523: f { {. } map} map /f set
1524: f fromVectors /f set
1.23 takayama 1525: [f groebnerOptions] groebner 0 get /gg set
1.5 takayama 1526: }ifelse
1527: wv isInteger {
1528: /ans [gg gg {init} map] def
1529: }{
1530: /ans [gg gg {wv 0 get weightv init} map] def
1531: }ifelse
1532:
1533: %% Postprocess : recover the matrix expression.
1534: mm {
1535: ans { /tmp set [mm tmp] toVectors } map
1536: /ans set
1537: }{ }
1538: ifelse
1.23 takayama 1539: ans gg getAttributeList setAttributeList /ans set
1.5 takayama 1540: gb_h.opt restoreOptions
1.6 takayama 1541: gb.verbose { (Getting out of gb_h) message } { } ifelse
1.5 takayama 1542: %%
1543:
1544: /arg1 ans def
1545: ] pop
1546: popEnv
1547: popVariables
1548: arg1
1549: } def
1550: (gb_h ) messagen-quiet
1551: [(gb_h)
1552: [(a gb_h b)
1553: (array a; array b;)
1554: (b : [g ii]; array g; array in; g is a Grobner basis of f)
1555: ( in the ring of homogenized differential operators.)
1556: ( The input must be homogenized properly.)
1557: ( Inproper homogenization may cause an infinite loop.)
1558: ( Each element of vectors must be homogenized. If you are using )
1559: ( non-term orders, all elements of vectors must have the same degree with)
1560: ( a proper degree shift vector.)
1561: $ ii is the initial ideal in case of w is given or <<a>> belongs$
1562: $ to a ring. In the other cases, it returns the initial monominal.$
1563: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1564: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1565: (a : [f v]; array f; string v; v is the variables. )
1.10 takayama 1566: (a : [f r]; array f; ring r )
1.5 takayama 1567: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1568: ( )
1569: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1570: $ [ [ (Dx) 1 ] ] ] gb_h pmat ; $
1571: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
1572: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1573: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1574: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1575: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1576: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1577: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1578: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1579: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1.23 takayama 1580: $Example 5: [ [[(h+x) (x^3 + 2 h^3 + 2 x h^2)] [(x) (x)]] (x)] $
1.24 takayama 1581: $ [(reduceOnly) 1] setAttributeList gb_h pmat $
1.5 takayama 1582: ( )
1583: (cf. gb, groebner, syz_h. )
1584: ]] putUsages
1585:
1586: /syz_h {
1587: /arg1 set
1588: [/in-syz_h /aa /typev /setarg /f /v
1589: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
1590: /rr /mm
1591: /syz_h.opt
1592: ] pushVariables
1593: [(CurrentRingp) (KanGBmessage)] pushEnv
1594: [
1595:
1596: /aa arg1 def
1597: aa isArray { } { (<< array >> syz_h) error } ifelse
1598: /setarg 0 def
1599: /wv 0 def
1600: aa { tag } map /typev set
1601: typev [ ArrayP ] eq
1602: { /f aa 0 get def
1603: /v syz.v def
1604: /setarg 1 def
1605: } { } ifelse
1606: typev [ArrayP StringP] eq
1607: { /f aa 0 get def
1608: /v aa 1 get def
1609: /setarg 1 def
1610: } { } ifelse
1.10 takayama 1611: typev [ArrayP RingP] eq
1612: { /f aa 0 get def
1613: /v aa 1 get def
1614: /setarg 1 def
1615: } { } ifelse
1.5 takayama 1616: typev [ArrayP ArrayP] eq
1617: { /f aa 0 get def
1618: /v aa 1 get from_records def
1619: /setarg 1 def
1620: } { } ifelse
1621: typev [ArrayP StringP ArrayP] eq
1622: { /f aa 0 get def
1623: /v aa 1 get def
1624: /wv aa 2 get def
1625: /setarg 1 def
1626: } { } ifelse
1627: typev [ArrayP ArrayP ArrayP] eq
1628: { /f aa 0 get def
1629: /v aa 1 get from_records def
1630: /wv aa 2 get def
1631: /setarg 1 def
1632: } { } ifelse
1633:
1634: setarg { } { (syz_h : Argument mismatch) error } ifelse
1635:
1636: [(KanGBmessage) syz.verbose ] system_variable
1637:
1638:
1639:
1640: %%% Start of the preprocess
1.10 takayama 1641: v tag RingP eq {
1642: /rr v def
1643: }{
1644: f getRing /rr set
1645: } ifelse
1.5 takayama 1646: %% To the normal form : matrix expression.
1647: f gb.toMatrixOfString /f set
1648: /mm gb.itWasMatrix def
1649: mm 0 gt {
1650: /vectorInput 1 def
1651: }{
1652: /vectorInput 1 def
1653: } ifelse
1654:
1655: rr tag 0 eq {
1656: %% Define our own ring
1657: v isInteger {
1658: (Error in syz_h: Specify variables) error
1659: } { } ifelse
1660: wv isInteger {
1661: [v ring_of_differential_operators
1662: 0] define_ring
1663: /termorder 1 def
1664: }{
1665: [v ring_of_differential_operators
1666: wv weight_vector
1667: 0] define_ring
1668: wv gb.isTermOrder /termorder set
1669: } ifelse
1670: }{
1671: %% Use the ring structre given by the input.
1672: v isInteger not {
1.7 takayama 1673: gb.warning {
1674: (Warning : the given ring definition is not used.) message
1675: } { } ifelse
1.5 takayama 1676: } { } ifelse
1677: rr ring_def
1678: /wv rr gb.getWeight def
1679: wv gb.isTermOrder /termorder set
1680: } ifelse
1681:
1682: getOptions /syz_h.opt set
1683: (grade) (module1v) switch_function
1684: [(Homogenize_vec) 0] system_variable
1685: %%% End of the preprocess
1686:
1687: termorder {
1688: f { {. } map } map /f set
1689: [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
1690: ggall 2 get /gg set
1691: }{
1692: f { {. } map } map /f set
1693: [f [(needBack) (needSyz)]] groebner /ggall set
1694: ggall 2 get /gg set
1695: }ifelse
1696: vectorInput {
1697: /vsize f 0 get length def %% input vector size.
1698: /gtmp ggall 0 get def
1699: [vsize gtmp] toVectors /gtmp set
1700: ggall 0 gtmp put
1701: }{ } ifelse
1702:
1703: syz_h.opt restoreOptions
1704: %%
1705:
1706: /arg1 [gg ggall] def
1707: ] pop
1708: popEnv
1709: popVariables
1710: arg1
1711: } def
1712: (syz_h ) messagen-quiet
1713:
1714: [(syz_h)
1715: [(a syz_h [b c])
1716: (array a; array b; array c)
1717: (b is a set of generators of the syzygies of f in the ring of)
1718: (homogenized differential operators.)
1719: ( The input must be homogenized properly.)
1720: ( Inproper homogenization may cause an infinite loop.)
1721: ( Each element of vectors must be homogenized. If you are using )
1722: ( non-term orders, all elements of vectors must have the same degree with)
1723: ( a proper degree shift vector.)
1724: (c = [gb, backward transformation, syzygy without dehomogenization].)
1725: (See gb_h.)
1726: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1727: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1728: (a : [f v]; array f; string v; v is the variables.)
1.10 takayama 1729: (a : [f r]; array f; ring r )
1.5 takayama 1730: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1731: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1732: $ [ [ (Dx) 1 ] ] ] syz_h pmat ; $
1733: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
1734: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1735: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1736: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1737: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1738: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1739: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1740: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1741: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1742: $Example 5: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1743: $ [(x) (y)]] syz pmat ;$
1744: ]] putUsages
1745:
1746:
1747: /isSameIdeal {
1748: /arg1 set
1749: [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
1750: [(CurrentRingp)] pushEnv
1751: [
1752: /aa arg1 def
1753: %% comparison of hilbert series has not yet been implemented.
1754: aa length 3 eq { }
1755: { ([ii jj vv] isSameIdeal) error } ifelse
1.6 takayama 1756: gb.verbose { (Getting in isSameIdeal) message } { } ifelse
1.5 takayama 1757: /ii aa 0 get def
1758: /jj aa 1 get def
1759: /vv aa 2 get def
1760: ii length 0 eq jj length 0 eq and
1761: { /ans 1 def /LLL.isSame goto } { } ifelse
1762: [ii vv] gb /iigg set
1763: [jj vv] gb /jjgg set
1764:
1765: iigg getRing ring_def
1766:
1767: /ans 1 def
1768: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1769: /iigg set
1770: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1771: /jjgg set
1772:
1773: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1774: iigg length /n set
1775: 0 1 n 1 sub {
1776: /k set
1777: iigg k get
1778: jjgg reduction-noH 0 get
1779: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1780: gb.verbose { (o) messagen } { } ifelse
1781: } for
1782: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1783: jjgg length /n set
1784: 0 1 n 1 sub {
1785: /k set
1786: jjgg k get
1787: iigg reduction-noH 0 get
1788: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1789: gb.verbose { (o) messagen } { } ifelse
1790: } for
1791: /LLL.isSame
1792: gb.verbose { ( Done) message } { } ifelse
1793: /arg1 ans def
1794: ] pop
1795: popEnv
1796: popVariables
1797: arg1
1798: } def
1799: (isSameIdeal ) messagen-quiet
1800:
1801: [(isSameIdeal)
1802: [([ii jj vv] isSameIdeal bool)
1803: (ii, jj : ideal, vv : variables)
1804: (Note that ii and jj will be dehomogenized and compared in the ring)
1805: (of differential operators. cf. isSameIdeal_h)
1806: $Example 1: [ [(x^3) (y^2)] [(x^2+y) (y)] (x,y)] isSameIdeal $
1807: $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
1808: $ [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
1809: ]] putUsages
1810:
1811: /isSameIdeal_h {
1812: /arg1 set
1.6 takayama 1813: [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
1814: /isSameIdeal_h.opt
1815: ] pushVariables
1816: [(CurrentRingp) (Homogenize_vec)] pushEnv
1.5 takayama 1817: [
1818: /aa arg1 def
1.6 takayama 1819: gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
1.5 takayama 1820: %% comparison of hilbert series has not yet been implemented.
1821: aa length 3 eq { }
1822: { ([ii jj vv] isSameIdeal_h) error } ifelse
1823: /ii aa 0 get def
1824: /jj aa 1 get def
1825: /vv aa 2 get def
1826: ii length 0 eq jj length 0 eq and
1827: { /ans 1 def /LLL.isSame_h goto } { } ifelse
1828:
1829: [ii vv] gb_h /iigg set
1830: [jj vv] gb_h /jjgg set
1831:
1832: iigg getRing ring_def
1833:
1.6 takayama 1834: getOptions /isSameIdeal_h.opt set
1835: (grade) (module1v) switch_function
1836: [(Homogenize_vec) 0] system_variable
1.5 takayama 1837: /ans 1 def
1838: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1839: /iigg set
1840: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1841: /jjgg set
1842:
1.8 takayama 1843: gb.verbose { (Comparing) message iigg message (and) message jjgg message }
1844: { } ifelse
1.5 takayama 1845: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1846: iigg length /n set
1847: 0 1 n 1 sub {
1848: /k set
1849: iigg k get
1850: jjgg reduction 0 get
1851: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1852: gb.verbose { (o) messagen } { } ifelse
1853: } for
1854: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1855: jjgg length /n set
1856: 0 1 n 1 sub {
1857: /k set
1858: jjgg k get
1859: iigg reduction 0 get
1860: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1861: gb.verbose { (o) messagen } { } ifelse
1862: } for
1863: /LLL.isSame_h
1864: gb.verbose { ( Done) message } { } ifelse
1.6 takayama 1865: isSameIdeal_h.opt restoreOptions
1.5 takayama 1866: /arg1 ans def
1867: ] pop
1868: popEnv
1869: popVariables
1870: arg1
1871: } def
1872: (isSameIdeal_h ) messagen-quiet
1873:
1874: [(isSameIdeal_h)
1875: [([ii jj vv] isSameIdeal_h bool)
1876: (ii, jj : ideal, vv : variables)
1877: (Note that ii and jj will be compared in the ring)
1878: (of homogenized differential operators. Each element of the vector must be)
1879: (homogenized.)
1880: $Example 1: [ [(x Dx - h^2) (Dx^2)] [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
1881: $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
1882: $ [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
1883: ]] putUsages
1884:
1.15 takayama 1885: /gb.reduction {
1886: /arg2 set
1887: /arg1 set
1888: [/in-gb.reduction /gbasis /flist /ans /gbasis2
1889: ] pushVariables
1890: [(CurrentRingp) (KanGBmessage)] pushEnv
1891: [
1892: /gbasis arg2 def
1893: /flist arg1 def
1894: gbasis 0 get tag 6 eq { }
1895: { (gb.reduction: the second argument must be a list of lists) error }
1896: ifelse
1897:
1898: gbasis length 1 eq {
1899: gbasis getRing ring_def
1900: /gbasis2 gbasis 0 get def
1901: } {
1902: [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22 takayama 1903: /gbasis2 gbasis 0 get ___ def
1.15 takayama 1904: } ifelse
1905:
1.5 takayama 1906:
1.22 takayama 1907: flist ___ /flist set
1.15 takayama 1908: flist tag 6 eq {
1909: flist { gbasis2 reduction } map /ans set
1910: }{
1911: flist gbasis2 reduction /ans set
1912: } ifelse
1913: /arg1 ans def
1914:
1915: ] pop
1916: popEnv
1917: popVariables
1918: arg1
1919: } def
1920:
1.20 takayama 1921: /gb.reduction_noh {
1922: /arg2 set
1923: /arg1 set
1924: [/in-gb.reduction_noh /gbasis /flist /ans /gbasis2
1925: ] pushVariables
1926: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1927: [
1928: /gbasis arg2 def
1929: /flist arg1 def
1930: gbasis 0 get tag 6 eq { }
1931: { (gb.reduction_noh: the second argument must be a list of lists) error }
1932: ifelse
1933:
1934: gbasis length 1 eq {
1935: gbasis getRing ring_def
1936: /gbasis2 gbasis 0 get def
1937: } {
1938: [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22 takayama 1939: /gbasis2 gbasis 0 get ___ def
1.20 takayama 1940: } ifelse
1941:
1942:
1.22 takayama 1943: flist ___ /flist set
1.20 takayama 1944: [(Homogenize) 0] system_variable
1945: flist tag 6 eq {
1946: flist { gbasis2 reduction } map /ans set
1947: }{
1948: flist gbasis2 reduction /ans set
1949: } ifelse
1950: /arg1 ans def
1951:
1952: ] pop
1953: popEnv
1954: popVariables
1955: arg1
1956: } def
1957:
1.15 takayama 1958: /gb.reduction.test {
1959: [
1960: [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
1961: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
1962: gb /gg set
1963:
1964: ((h-x-y)*Dx) [gg 0 get] gb.reduction /gg2 set
1965: gg2 message
1966: (-----------------------------) message
1967:
1968: [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )]
1969: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
1970: ((h-x-y)*Dx) ggg gb.reduction /gg4 set
1971: gg4 message
1972: (-----------------------------) message
1973: [gg2 gg4]
1974: } def
1975: [(gb.reduction)
1976: [ (f basis gb.reduction r)
1977: (f is reduced by basis by the normal form algorithm.)
1978: (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
1979: (r is the return value format of reduction;)
1980: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1981: (basis is given in the argument format of gb.)
1.16 takayama 1982: $h[1,1](D)-homogenization is used.$
1.15 takayama 1983: (cf. reduction, gb, ecartd.gb, gb.reduction.test )
1984: $Example:$
1985: $ [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )] $
1986: $ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
1987: $ ((h-x-y)^2*Dx*Dy) ggg gb.reduction :: $
1.20 takayama 1988: ]] putUsages
1989:
1990: [(gb.reduction_noh)
1991: [ (f basis gb.reduction_noh r)
1992: (f is reduced by basis by the normal form algorithm.)
1993: (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
1994: (r is the return value format of reduction;)
1995: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1996: (basis is given in the argument format of gb.)
1997: (cf. gb.reduction, gb )
1998: $Example:$
1999: $ [[( 2*Dx + 1 ) ( 2*Dy + 1 )] $
2000: $ (x,y) [[(Dx) 1 (Dy) 1]]] /ggg set $
2001: $ ((1-x-y)^2*Dx*Dy) ggg gb.reduction_noh :: $
1.15 takayama 2002: ]] putUsages
1.1 maekawa 2003:
2004: ( ) message-quiet ;
2005:
1.21 takayama 2006: /hol_loaded 1 def
1.1 maekawa 2007:
2008:
2009:
2010:
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