Annotation of OpenXM/src/kan96xx/Doc/hol.sm1, Revision 1.30
1.30 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.29 2019/08/31 06:36:28 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.29 takayama 305: /ggall
1.1 maekawa 306: ] pushVariables
307: [(CurrentRingp) (KanGBmessage)] pushEnv
308: [
309:
310: /aa arg1 def
311: aa isArray { } { ( << array >> gb) error } ifelse
1.23 takayama 312: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1 maekawa 313: /setarg 0 def
314: /wv 0 def
1.11 takayama 315: /degreeShift 0 def
1.1 maekawa 316: aa { tag } map /typev set
317: typev [ ArrayP ] eq
318: { /f aa 0 get def
319: /v gb.v def
320: /setarg 1 def
321: } { } ifelse
322: typev [ArrayP StringP] eq
323: { /f aa 0 get def
324: /v aa 1 get def
325: /setarg 1 def
326: } { } ifelse
1.10 takayama 327: typev [ArrayP RingP] eq
328: { /f aa 0 get def
329: /v aa 1 get def
330: /setarg 1 def
331: } { } ifelse
1.1 maekawa 332: typev [ArrayP ArrayP] eq
333: { /f aa 0 get def
334: /v aa 1 get from_records def
335: /setarg 1 def
336: } { } ifelse
337: typev [ArrayP StringP ArrayP] eq
338: { /f aa 0 get def
339: /v aa 1 get def
340: /wv aa 2 get def
341: /setarg 1 def
342: } { } ifelse
343: typev [ArrayP ArrayP ArrayP] eq
344: { /f aa 0 get def
345: /v aa 1 get from_records def
346: /wv aa 2 get def
347: /setarg 1 def
348: } { } ifelse
1.11 takayama 349: typev [ArrayP StringP ArrayP ArrayP] eq
350: { /f aa 0 get def
351: /v aa 1 get def
352: /wv aa 2 get def
353: /degreeShift aa 3 get def
354: /setarg 1 def
355: } { } ifelse
356: typev [ArrayP ArrayP ArrayP ArrayP] eq
357: { /f aa 0 get def
358: /v aa 1 get from_records def
359: /wv aa 2 get def
360: /degreeShift aa 3 get def
361: /setarg 1 def
362: } { } ifelse
1.1 maekawa 363:
1.12 takayama 364: /env1 getOptions def
365:
1.1 maekawa 366: setarg { } { (gb : Argument mismatch) error } ifelse
367:
368: [(KanGBmessage) gb.verbose ] system_variable
369:
370: %%% Start of the preprocess
1.10 takayama 371: v tag RingP eq {
372: /rr v def
373: }{
374: f getRing /rr set
375: } ifelse
1.1 maekawa 376: %% To the normal form : matrix expression.
377: f gb.toMatrixOfString /f set
378: /mm gb.itWasMatrix def
379:
1.14 takayama 380: rr tag 0 eq
381: v isInteger not
382: or {
1.1 maekawa 383: %% Define our own ring
384: v isInteger {
385: (Error in gb: Specify variables) error
386: } { } ifelse
387: wv isInteger {
388: [v ring_of_differential_operators
1.13 takayama 389: gb.characteristic] define_ring
1.1 maekawa 390: /termorder 1 def
391: }{
1.11 takayama 392: degreeShift isInteger {
393: [v ring_of_differential_operators
394: wv weight_vector
1.13 takayama 395: gb.characteristic] define_ring
1.11 takayama 396: wv gb.isTermOrder /termorder set
397: }{
398: [v ring_of_differential_operators
399: wv weight_vector
1.13 takayama 400: gb.characteristic
1.11 takayama 401: [(degreeShift) degreeShift]
402: ] define_ring
403: wv gb.isTermOrder /termorder set
404: } ifelse
1.1 maekawa 405: } ifelse
406: } {
407: %% Use the ring structre given by the input.
408: rr ring_def
409: /wv rr gb.getWeight def
410: wv gb.isTermOrder /termorder set
411: } ifelse
412: %%% Enf of the preprocess
413:
1.14 takayama 414: termorder {
415: /gb.homogenized 0 def
416: }{
417: /gb.homogenized 1 def
418: } ifelse
1.23 takayama 419: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
420: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1 maekawa 421: termorder {
1.22 takayama 422: f { {___ dehomogenize} map } map /f set
1.29 takayama 423: [f groebnerOptions] groebner_sugar /ggall set ggall 0 get /gg set
1.1 maekawa 424: }{
1.22 takayama 425: f { {___ dehomogenize} map} map /f set
1.14 takayama 426: gb.autoHomogenize {
427: f fromVectors { homogenize } map /f set
428: } { } ifelse
1.29 takayama 429: [f groebnerOptions] groebner /ggall set ggall 0 get /gg set
1.1 maekawa 430: }ifelse
431: wv isInteger {
432: /ans [gg gg {init} map] def
433: }{
434: /ans [gg gg {wv 0 get weightv init} map] def
435: }ifelse
436:
437: %% Postprocess : recover the matrix expression.
438: mm {
439: ans { /tmp set [mm tmp] toVectors } map
440: /ans set
441: }{ }
442: ifelse
1.17 takayama 443: ans getRing (oxRingStructure) dc /gb.oxRingStructure set
1.23 takayama 444: %% gg getAttributeList message
1.29 takayama 445: ans
446: gg getAttributeList , [(all) ggall] join
447: setAttributeList /ans set
1.1 maekawa 448: %%
1.12 takayama 449: env1 restoreOptions %% degreeShift changes "grade"
1.1 maekawa 450:
451: /arg1 ans def
452: ] pop
453: popEnv
454: popVariables
455: arg1
456: } def
457: (gb ) messagen-quiet
458:
459: /pgb {
460: /arg1 set
461: [/in-pgb /aa /typev /setarg /f /v
462: /gg /wv /termorder /vec /ans /rr /mm
1.23 takayama 463: /groebnerOptions
1.1 maekawa 464: ] pushVariables
465: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
466: [
467:
468: /aa arg1 def
469: aa isArray { } { (<< array >> pgb) error } ifelse
1.23 takayama 470: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.1 maekawa 471: /setarg 0 def
472: /wv 0 def
473: aa { tag } map /typev set
474: typev [ ArrayP ] eq
475: { /f aa 0 get def
476: /v gb.v def
477: /setarg 1 def
478: } { } ifelse
479: typev [ArrayP StringP] eq
480: { /f aa 0 get def
481: /v aa 1 get def
482: /setarg 1 def
483: } { } ifelse
484: typev [ArrayP ArrayP] eq
485: { /f aa 0 get def
486: /v aa 1 get from_records def
487: /setarg 1 def
488: } { } ifelse
489: typev [ArrayP StringP ArrayP] eq
490: { /f aa 0 get def
491: /v aa 1 get def
492: /wv aa 2 get def
493: /setarg 1 def
494: } { } ifelse
495: typev [ArrayP ArrayP ArrayP] eq
496: { /f aa 0 get def
497: /v aa 1 get from_records def
498: /wv aa 2 get def
499: /setarg 1 def
500: } { } ifelse
501:
502: setarg { } { (pgb : Argument mismatch) error } ifelse
503:
504: [(KanGBmessage) gb.verbose ] system_variable
505:
506: %%% Start of the preprocess
507: f getRing /rr set
508: %% To the normal form : matrix expression.
509: f gb.toMatrixOfString /f set
510: /mm gb.itWasMatrix def
511:
512: rr tag 0 eq {
513: %% Define our own ring
514: v isInteger {
515: (Error in pgb: Specify variables) error
516: } { } ifelse
517: wv isInteger {
518: [v ring_of_polynomials
1.13 takayama 519: gb.characteristic] define_ring
1.1 maekawa 520: /termorder 1 def
521: }{
522: [v ring_of_polynomials
523: wv weight_vector
1.13 takayama 524: gb.characteristic] define_ring
1.1 maekawa 525: wv gb.isTermOrder /termorder set
526: } ifelse
527: } {
528: %% Use the ring structre given by the input.
529: v isInteger not {
1.7 takayama 530: gb.warning {
531: (Warning : the given ring definition is not used.) message
532: } { } ifelse
1.1 maekawa 533: } { } ifelse
534: rr ring_def
535: /wv rr gb.getWeight def
536: wv gb.isTermOrder /termorder set
537: } ifelse
538: %%% Enf of the preprocess
539:
1.23 takayama 540: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
1.25 takayama 541: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.1 maekawa 542: termorder {
543: f { {. dehomogenize} map } map /f set
544: [(UseCriterion1) 1] system_variable
1.25 takayama 545: [f groebnerOptions] groebner_sugar 0 get /gg set
1.1 maekawa 546: [(UseCriterion1) 0] system_variable
547: }{
548: f { {. dehomogenize} map} map /f set
549: f fromVectors { homogenize } map /f set
550: [(UseCriterion1) 1] system_variable
1.23 takayama 551: [f groebnerOptions] groebner 0 get /gg set
1.1 maekawa 552: [(UseCriterion1) 0] system_variable
553: }ifelse
554: wv isInteger {
555: /ans [gg gg {init} map] def
556: }{
557: /ans [gg gg {wv 0 get weightv init} map] def
558: }ifelse
559:
560: %% Postprocess : recover the matrix expression.
561: mm {
562: ans { /tmp set [mm tmp] toVectors } map
563: /ans set
564: }{ }
565: ifelse
566: %%
1.23 takayama 567: ans gg getAttributeList setAttributeList /ans set
1.1 maekawa 568:
569: /arg1 ans def
570: ] pop
571: popEnv
572: popVariables
573: arg1
574: } def
575:
576: /pgb.old {
577: /arg1 set
578: [/in-pgb /aa /typev /setarg /f /v
579: /gg /wv /termorder /vec /ans
580: ] pushVariables
581: [(CurrentRingp) (KanGBmessage) (UseCriterion1)] pushEnv
582: [
583:
584: /aa arg1 def
585: aa isArray { } { (array pgb) message (pgb) usage error } ifelse
586: /setarg 0 def
587: /wv 0 def
588: aa { tag } map /typev set
589: typev [ ArrayP ] eq
590: { /f aa 0 get def
591: /v gb.v def
592: /setarg 1 def
593: } { } ifelse
594: typev [ArrayP StringP] eq
595: { /f aa 0 get def
596: /v aa 1 get def
597: /setarg 1 def
598: } { } ifelse
599: typev [ArrayP ArrayP] eq
600: { /f aa 0 get def
601: /v aa 1 get from_records def
602: /setarg 1 def
603: } { } ifelse
604: typev [ArrayP StringP ArrayP] eq
605: { /f aa 0 get def
606: /v aa 1 get def
607: /wv aa 2 get def
608: /setarg 1 def
609: } { } ifelse
610: typev [ArrayP ArrayP ArrayP] eq
611: { /f aa 0 get def
612: /v aa 1 get from_records def
613: /wv aa 2 get def
614: /setarg 1 def
615: } { } ifelse
616:
617: setarg { } { (pgb : Argument mismatch) message error } ifelse
618:
619: [(KanGBmessage) gb.verbose ] system_variable
620:
621: %% Input must not be vectors.
622: f { toString } map /f set
623:
624: wv isInteger {
625: [v ring_of_polynomials
626: 0] define_ring
627: /termorder 1 def
628: }{
629: [v ring_of_polynomials
630: wv weight_vector
631: 0] define_ring
632: wv gb.isTermOrder /termorder set
633: } ifelse
634: termorder {
635: f { . dehomogenize } map /f set
636: [(UseCriterion1) 1] system_variable
637: [f] groebner_sugar 0 get /gg set
638: [(UseCriterion1) 0] system_variable
639: }{
640: f { . dehomogenize homogenize} map /f set
641: [(UseCriterion1) 1] system_variable
642: [f] groebner 0 get /gg set
643: [(UseCriterion1) 0] system_variable
644: }ifelse
645: wv isInteger {
646: /ans [gg gg {init} map] def
647: }{
648: /ans [gg gg {wv 0 get weightv init} map] def
649: }ifelse
650: /arg1 ans def
651: ] pop
652: popEnv
653: popVariables
654: arg1
655: } def
656: (pgb ) messagen-quiet
657:
658: /gb.toMatrixOfString {
659: /arg1 set
660: [/in-gb.toMatrixOfString /ff /aa /ans] pushVariables
661: [
662: /aa arg1 def
663: aa length 0 eq { /ans [ ] def /gb.toMatrixOfString.LLL goto }{ } ifelse
664: aa 0 get isArray {
665: /gb.itWasMatrix aa 0 get length def
666: }{
667: /gb.itWasMatrix 0 def
668: } ifelse
669: aa {
670: /ff set
671: ff isArray {
672: ff {toString} map /ff set
673: }{
674: [ff toString] /ff set
675: } ifelse
676: ff
677: } map /ans set
678: /gb.toMatrixOfString.LLL
679: /arg1 ans def
680: ] pop
681: popVariables
682: arg1
683: } def
684: [(gb.toMatrixOfString)
685: [(It translates given input into a matrix form which is a data structure)
686: (for computations of kernel, image, cokernel, etc.)
687: (gb.itWasMatrix is set to the length of the input vector.)
688: $Example 1: $
689: $ [ (x). (y).] gb.toMatrixOfString ==> [[(x)] [(y)]] $
690: $ gb.itWasMatrix is 0.$
691: $Example 2: $
692: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfString ==> [ [(x) (1)] [(y) (0)]] $
693: $ gb.itWasMatrix is 2.$
694: ]] putUsages
695:
696: /gb.toMatrixOfPoly {
697: /arg1 set
698: [/in-gb.toMatrixOfPoly /ff /aa /ans] pushVariables
699: [
700: /aa arg1 def
701: aa length 0 eq { /ans [ ] def /gb.toMatrixOfPoly.LLL goto }{ } ifelse
702: aa 0 get isArray {
703: /gb.itWasMatrix aa 0 get length def
704: }{
705: /gb.itWasMatrix 0 def
706: } ifelse
707: aa {
708: /ff set
709: ff isArray {
710: }{
711: [ff] /ff set
712: } ifelse
713: ff
714: } map /ans set
715: /gb.toMatrixOfPoly.LLL
716: /arg1 ans def
717: ] pop
718: popVariables
719: arg1
720: } def
721: [(gb.toMatrixOfPoly)
722: [(It translates given input into a matrix form which is a data structure)
723: (for computations of kernel, image, cokernel, etc.)
724: (gb.itWasMatrix is set to the length of the input vector.)
725: $Example 1: $
726: $ [ (x). (y).] gb.toMatrixOfPoly ==> [[(x)] [(y)]] $
727: $ gb.itWasMatrix is 0.$
728: $Example 2: $
729: $ [ [(x). (1).] [(y). (0).]] gb.toMatrixOfPoly ==> [ [(x) (1)] [(y) (0)]] $
730: $ gb.itWasMatrix is 2.$
731: ]] putUsages
732:
733: /gb.getWeight {
734: /arg1 set
735: [/in-gb.getWeight /rr /ww /vv /ans /nn /ii] pushVariables
736: [(CurrentRingp)] pushEnv
737: [
738: /rr arg1 def
739: rr ring_def
740: getVariableNames /vv set
741: [(orderMatrix)] system_variable 0 get /ww set
742: /nn vv length 1 sub def
743: [0 1 nn {
744: /ii set
745: ww ii get 0 eq {
746: } {
747: vv ii get
748: ww ii get
749: } ifelse
750: } for
751: ] /ans set
752: /arg1 [ans] def
753: ] pop
754: popEnv
755: popVariables
756: arg1
757: } def
758: [(gb.getWeight)
759: [(ring gb.getWeight wv)
760: (It gets the weight vector field of the ring ring.)
761: ]] putUsages
762:
763:
764: /gb.isTermOrder {
765: /arg1 set
766: [/in-gb.isTermOrder /vv /ww /yes /i /j] pushVariables
767: [
768: /vv arg1 def
769: /yes 1 def
770: 0 1 vv length 1 sub {
771: /i set
772: /ww vv i get def
773: 0 1 ww length 1 sub {
774: /j set
775: ww j get isInteger {
776: ww j get 0 lt { /yes 0 def } { } ifelse
777: }{ } ifelse
778: }for
779: }for
780: /arg1 yes def
781: ] pop
782: popVariables
783: arg1
784: } def
785: [(gb)
786: [(a gb b)
787: (array a; array b;)
788: (b : [g ii]; array g; array in; g is a Grobner basis of f)
789: ( in the ring of differential operators.)
790: $ ii is the initial ideal in case of w is given or <<a>> belongs$
791: $ to a ring. In the other cases, it returns the initial monominal.$
792: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
793: (a : [f v]; array f; string v; v is the variables. )
794: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.11 takayama 795: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
796: ( array ds; ds is the degree shift )
1.1 maekawa 797: ( )
1.14 takayama 798: (gb.authoHomogenize 1 [default])
1.17 takayama 799: (gb.oxRingStructure )
1.14 takayama 800: ( )
1.1 maekawa 801: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
802: $ [ [ (Dx) 1 ] ] ] gb pmat ; $
803: (Example 2: )
804: (To put h=1, type in, e.g., )
805: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
806: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] gb /gg set gg dehomogenize pmat ;$
807: ( )
808: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
809: $ [ [ (Dx) 1 (Dy) 1] ] ] gb pmat ; $
810: ( )
811: $Example 4: [[ [(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] ] ] gb pmat ; $
1.12 takayama 813: ( )
814: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
815: $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] gb pmat ; $
1.23 takayama 816: ( )
817: $Example 6: [ [( (x Dx)^2 + (y Dy)^2 - x y Dx Dy + 1) ( x y Dx Dy -1)] (x,y) $
818: $ [ [ (Dx) 1 ] ] ] [(reduceOnly) 1] setAttributeList gb pmat ; $
819: ( )
820: $Example 7: [ [( (x Dx)^2 + (y Dy)^2 + 1) ( x y Dx Dy -1)] (x,y) $
821: $ [ [ (Dx) 1 ] ] ] [(gbCheck) 1] setAttributeList gb getAttributeList ::$
1.1 maekawa 822: ( )
1.28 takayama 823: $Example 8: /gb.options [(StopDegree) 11] def Onverbose $
824: $ [ [(x^10+y^10-1) (x^5*y^5 -1)] (x,y) $
825: $ [ [ (x) 1 ] ]] gb pmat ; $
826: ( )
1.1 maekawa 827: (cf. gb, groebner, groebner_sugar, syz. )
828: ]] putUsages
829:
830: [(pgb)
831: [(a pgb b)
832: (array a; array b;)
833: (b : [g ii]; array g; array in; g is a Grobner basis of f)
834: ( in the ring of polynomials.)
835: $ ii is the initial ideal in case of w is given or <<a>>belongs$
836: $ to a ring. In the other cases, it returns the initial monominal.$
837: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
838: (a : [f v]; array f; string v; v is the variables.)
839: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
840: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
841: $ [ [(x^2+y^2-4). (x y -1).] ] pgb :: $
842: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] pgb :: $
1.23 takayama 843: $Example 3: [ [(x^2+y^2 + x y ) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] $
1.24 takayama 844: $ [(reduceOnly) 1] setAttributeList pgb :: $
1.1 maekawa 845: (cf. gb, groebner, groebner_sugar, syz. )
846: ]] putUsages
847:
848:
849: %/syz.v 1 def
850: /syz.v 1 def
851: /syz.verbose 0 def
852: /syz {
853: /arg1 set
854: [/in-syz /aa /typev /setarg /f /v
855: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
856: /rr /mm
857: ] pushVariables
858: [(CurrentRingp) (KanGBmessage)] pushEnv
859: [
860:
861: /aa arg1 def
862: aa isArray { } { (<< array >> syz) error } ifelse
863: /setarg 0 def
864: /wv 0 def
865: aa { tag } map /typev set
866: typev [ ArrayP ] eq
867: { /f aa 0 get def
868: /v syz.v def
869: /setarg 1 def
870: } { } ifelse
871: typev [ArrayP StringP] eq
872: { /f aa 0 get def
873: /v aa 1 get def
874: /setarg 1 def
875: } { } ifelse
1.9 takayama 876: typev [ArrayP RingP] eq
877: { /f aa 0 get def
878: /v aa 1 get def
879: /setarg 1 def
880: } { } ifelse
1.1 maekawa 881: typev [ArrayP ArrayP] eq
882: { /f aa 0 get def
883: /v aa 1 get from_records def
884: /setarg 1 def
885: } { } ifelse
886: typev [ArrayP StringP ArrayP] eq
887: { /f aa 0 get def
888: /v aa 1 get def
889: /wv aa 2 get def
890: /setarg 1 def
891: } { } ifelse
1.9 takayama 892: typev [ArrayP RingP ArrayP] eq
893: { /f aa 0 get def
894: /v aa 1 get def
895: /wv aa 2 get def
896: /setarg 1 def
897: } { } ifelse
1.1 maekawa 898: typev [ArrayP ArrayP ArrayP] eq
899: { /f aa 0 get def
900: /v aa 1 get from_records def
901: /wv aa 2 get def
902: /setarg 1 def
903: } { } ifelse
904:
905: setarg { } { (syz : Argument mismatch) error } ifelse
906:
907: [(KanGBmessage) syz.verbose ] system_variable
908:
909:
910:
911: %%% Start of the preprocess
1.9 takayama 912: v tag RingP eq {
913: /rr v def
914: }{
915: f getRing /rr set
916: } ifelse
1.1 maekawa 917: %% To the normal form : matrix expression.
918: f gb.toMatrixOfString /f set
919: /mm gb.itWasMatrix def
920: mm 0 gt {
921: /vectorInput 1 def
922: }{
923: /vectorInput 1 def
924: } ifelse
925:
926: rr tag 0 eq {
927: %% Define our own ring
928: v isInteger {
929: (Error in syz: Specify variables) error
930: } { } ifelse
931: wv isInteger {
932: [v ring_of_differential_operators
933: 0] define_ring
934: /termorder 1 def
935: }{
936: [v ring_of_differential_operators
937: wv weight_vector
938: 0] define_ring
939: wv gb.isTermOrder /termorder set
940: } ifelse
941: }{
942: %% Use the ring structre given by the input.
943: v isInteger not {
1.7 takayama 944: gb.warning {
945: (Warning : the given ring definition is not used.) message
946: } { } ifelse
1.1 maekawa 947: } { } ifelse
948: rr ring_def
949: /wv rr gb.getWeight def
950: wv gb.isTermOrder /termorder set
951: } ifelse
952: %%% Enf of the preprocess
953:
954: termorder {
955: f { {. dehomogenize} map } map /f set
956: [f [(needBack) (needSyz)]] groebner_sugar /ggall set
957: ggall 2 get /gg set
958: }{
959: f { {. dehomogenize } map homogenize } map /f set
960: [f [(needBack) (needSyz)]] groebner /ggall set
961: ggall 2 get /gg set
962: }ifelse
963: vectorInput {
964: /vsize f 0 get length def %% input vector size.
965: /gtmp ggall 0 get def
966: [vsize gtmp] toVectors /gtmp set
967: ggall 0 gtmp put
968: }{ } ifelse
1.19 takayama 969:
1.27 takayama 970: gg length 0 eq { % there is no syzygy
971: ggall getRing (oxRingStructure) dc /gb.oxRingStructure set
972: }{
973: gg getRing (oxRingStructure) dc /gb.oxRingStructure set
974: } ifelse
1.19 takayama 975:
976: /arg1 [gg dehomogenize ggall] def
1.1 maekawa 977: ] pop
978: popEnv
979: popVariables
980: arg1
981: } def
982: (syz ) messagen-quiet
983:
984: [(syz)
985: [(a syz [b c])
986: (array a; array b; array c)
987: (b is a set of generators of the syzygies of f.)
988: (c = [gb, backward transformation, syzygy without dehomogenization].)
989: (See groebner.)
990: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
991: (a : [f v]; array f; string v; v is the variables.)
992: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.9 takayama 993: ( v may be a ring object. )
1.1 maekawa 994: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
995: $ [ [(x^2+y^2-4). (x y -1).] ] syz :: $
996: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] syz :: $
997: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
998: $ [ [ (Dx) 1 ] ] ] syz pmat ; $
999: $Example 4: [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1000: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
1001: $Example 5: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
1002: $ (x,y) ] syz pmat ;$
1003: $Example 6: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
1004: $ (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
1005: $Example 7: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1006: $ [(x) (y)]] syz pmat ;$
1007: ]] putUsages
1008:
1009:
1010: %%%%%%%%%%%%%%%%%% package fs %%%%%%%%%%%%%%%%%%%%%%%
1011: [(genericAnn)
1012: [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
1013: (L1, ..., Lm are annihilating ideal for f^s.)
1014: (f is a polynomial of v1, ..., vn)
1015: (<string> | <poly> f, s, v1, ..., vn ; <poly> L1, ..., Lm )
1016: $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
1017: ]
1018: ] putUsages ( genericAnn ) messagen-quiet
1019: /fs.verbose 0 def
1020: /genericAnn {
1021: /arg2 set /arg1 set
1022: [/in-genericAnn /f /vlist /s /vvv /nnn /rrr
1023: /v1 /ops /ggg /ggg0
1024: ] pushVariables
1025: [(CurrentRingp) (KanGBmessage)] pushEnv
1026: [
1027: /f arg1 def /vlist arg2 def
1028: f toString /f set
1029: vlist { toString } map /vlist set
1030: [(KanGBmessage) fs.verbose] system_variable
1031: /s vlist 0 get def
1032: /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
1033: s nnn 2 add cat_n def
1034: fs.verbose { vvv message } { }ifelse
1035: [vvv ring_of_differential_operators
1036: [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
1037:
1038: [ (_u*_t). f . sub (_u*_v-1). ]
1039: vlist rest { /v1 set
1040: %%D-clean f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
1041: f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
1042: @@@.Dsymbol v1 2 cat_n . add } map
1043: join
1044: /ops set
1045: ops {[[(h). (1).]] replace } map /ops set
1046: fs.verbose { ops message } { }ifelse
1047: [ops] groebner_sugar 0 get /ggg0 set
1048: fs.verbose { ggg0 message } { } ifelse
1049: ggg0 [(_u) (_v)] eliminatev
1050: %%D-clean { [(_t).] [ (D_t).] [s .] distraction
1051: { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction
1052: [[s . << (0). s . sub (1). sub >>]] replace
1053: } map /arg1 set
1054: ] pop
1055: popEnv
1056: popVariables
1057: arg1
1058: } def
1059:
1060: %% Find differential equations for f^(m), r0 the minimal integral root.
1061: [(annfs)
1062: [( [ f v m r0] annfs g )
1063: (It returns the annihilating ideal of f^m where r0 must be smaller)
1064: (or equal to the minimal integral root of the b-function.)
1065: (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
1066: (where r0 is the minial integral root of b.)
1067: (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
1068: (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
1069: $ It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
1070: (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
1071: $ It returns the annihilating ideal of f^r0 and [r0, b-function]$
1072: $ where r0 is the minimal integral root of the b-function.$
1073: (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
1074: (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
1075: (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
1076: ( (t,x1,x2,x3) -1 -2] annfs :: )
1077: ( Note that the example 4 uses huge memory space.)
1.26 takayama 1078: ( )
1079: (Note: This implementation is stable but obsolete. )
1080: (As to faster implementation, we refer to ann0 and ann of Risa/Asir )
1081: (Visit http://www.math.kobe-u.ac.jp/Asir )
1.1 maekawa 1082: ]] putUsages
1083: ( annfs ) messagen-quiet
1084: /annfs.verbose fs.verbose def
1085: /annfs.v [(x) (y) (z)] def
1086: /annfs.s (_s) def
1087: %% The first variable must be s.
1088: /annfs {
1089: /arg1 set
1090: [/in-annfs /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1091: /ans /vtmp /w2 /velim /bbb /rrr /r0
1092: ] pushVariables
1093: [(CurrentRingp) (KanGBmessage)] pushEnv
1094: [
1095:
1096: /aa arg1 def
1097: aa isArray { } { ( << array >> annfs) error } ifelse
1098: /setarg 0 def
1099: aa { tag } map /typev set
1100: /r0 [ ] def
1101: /m [ ] def
1102: /v annfs.v def
1103: aa 0 << aa 0 get toString >> put
1104: typev [ StringP ] eq
1105: { /f aa 0 get def
1106: /setarg 1 def
1107: } { } ifelse
1108: typev [StringP StringP] eq
1109: { /f aa 0 get def
1110: /v [ aa 1 get to_records pop ] def
1111: /setarg 1 def
1112: } { } ifelse
1113: typev [StringP ArrayP] eq
1114: { /f aa 0 get def
1115: /v aa 1 get def
1116: /setarg 1 def
1117: } { } ifelse
1118: typev [StringP ArrayP IntegerP IntegerP] eq
1119: { /f aa 0 get def
1120: /v aa 1 get def
1121: /m aa 2 get def
1122: /r0 aa 3 get def
1123: /setarg 1 def
1124: } { } ifelse
1125: typev [StringP StringP IntegerP IntegerP] eq
1126: { /f aa 0 get def
1127: /v [ aa 1 get to_records pop ] def
1128: /m aa 2 get def
1129: /r0 aa 3 get def
1130: /setarg 1 def
1131: } { } ifelse
1132: setarg 1 eq { } { (annfs : wrong argument) error } ifelse
1133:
1134: [annfs.s] v join /v set
1135:
1136: /ss v 0 get def
1137: annfs.verbose {
1138: (f, v, s, f^{m}, m+r0 = ) messagen
1139: [ f (, ) v (, ) ss (, )
1140: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1141: } { } ifelse
1142:
1143: f v genericAnn /fs set
1144:
1145: annfs.verbose {
1146: (genericAnn is ) messagen fs message
1147: } { } ifelse
1148: [(KanGBmessage) annfs.verbose] system_variable
1149:
1150: m isArray {
1151: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1152: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1153: velim { 1 } map /w2 set
1154: annfs.verbose { w2 message } { } ifelse
1155: [v from_records ring_of_differential_operators
1156: [w2] weight_vector 0] define_ring
1157: [ fs { toString . } map [ f toString . ] join ]
1158: groebner_sugar 0 get velim eliminatev 0 get /bbb set
1159: [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
1160: bbb toString . [[annfs.s . (s).]] replace /bbb set
1161: annfs.verbose { bbb message } { } ifelse
1162: bbb findIntegralRoots /rrr set
1163: rrr 0 get /r0 set %% minimal integral root.
1164: annfs.verbose { rrr message } { } ifelse
1165: fs 0 get (ring) dc ring_def
1166: fs { [[annfs.s . r0 toString .]] replace } map /ans set
1167: /ans [ans [r0 bbb]] def
1168: /annfs.label1 goto
1169: } { } ifelse
1170: m 0 ge {
1171: (annfs works only for getting annihilating ideal for f^(negative))
1172: error
1173: } { } ifelse
1174: r0 isArray {
1175: [(Need to compute the minimal root of b-function) nl
1176: (It has not been implemented.) ] cat
1177: error
1178: } { } ifelse
1179:
1180: [v from_records ring_of_differential_operators 0] define_ring
1181: fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace}
1182: map /gg set
1183: annfs.verbose { gg message } { } ifelse
1184:
1185: [ [f . << m r0 sub >> npower ] gg join
1186: [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
1187:
1188: gg2 { 0 get } map /ans set
1189: /ans ans { dup (0). eq {pop} { } ifelse } map def
1190:
1191: /annfs.label1
1192: /arg1 ans def
1193: ] pop
1194: popEnv
1195: popVariables
1196: arg1
1197: } def
1198:
1199: /genericAnnWithL.s (s) def
1200: /annfs.verify 0 def
1201: /genericAnnWithL {
1202: /arg1 set
1203: [/in-genericAnnWithL /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1204: /ans /vtmp /w2 /velim /bbb /rrr /r0 /myL /mygb /jj
1205: ] pushVariables
1206: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1207: [
1208:
1209: /aa arg1 def
1210: aa isArray { } { ( << array >> annfs) error } ifelse
1211: /setarg 0 def
1212: aa { tag } map /typev set
1213: /r0 [ ] def
1214: /m [ ] def
1215: /v annfs.v def
1216: aa 0 << aa 0 get toString >> put
1217: typev [ StringP ] eq
1218: { /f aa 0 get def
1219: /setarg 1 def
1220: } { } ifelse
1221: typev [StringP StringP] eq
1222: { /f aa 0 get def
1223: /v [ aa 1 get to_records pop ] def
1224: /setarg 1 def
1225: } { } ifelse
1226: typev [StringP ArrayP] eq
1227: { /f aa 0 get def
1228: /v aa 1 get def
1229: /setarg 1 def
1230: } { } ifelse
1231: setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse
1232:
1233: [genericAnnWithL.s] v join /v set
1234:
1235: /ss v 0 get def
1236: annfs.verbose {
1237: (f, v, s, f^{m}, m+r0 = ) messagen
1238: [ f (, ) v (, ) ss (, )
1239: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1240: } { } ifelse
1241:
1242: f v genericAnn /fs set
1243:
1244: annfs.verbose {
1245: (genericAnn is ) messagen fs message
1246: } { } ifelse
1247: [(KanGBmessage) annfs.verbose] system_variable
1248:
1249: m isArray {
1250: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1251: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1252: velim { 1 } map /w2 set
1253: annfs.verbose { w2 message } { } ifelse
1254: [v from_records ring_of_differential_operators
1255: [w2] weight_vector 0] define_ring
1256:
1257: [ [ f toString . ] fs { toString . } map join [(needBack)]]
1258: groebner_sugar /mygb set
1259: mygb 0 get velim eliminatev 0 get /bbb set
1260: mygb 0 get bbb position /jj set
1261: mygb 1 get jj get 0 get /myL set
1262:
1263: annfs.verbose { bbb message } { } ifelse
1264:
1265: annfs.verify {
1266: (Verifying L f - b belongs to genericAnn(f)) message
1267: [(Homogenize) 0] system_variable
1268: << myL f . mul bbb sub >>
1269: [fs { toString . } map] groebner_sugar 0 get
1270: reduction 0 get message
1271: (Is it zero? Then it's fine.) message
1272: } { } ifelse
1273:
1274: /ans [bbb [myL fs] ] def
1275: /annfs.label1 goto
1276: } { } ifelse
1277:
1278: /annfs.label1
1279: /arg1 ans def
1280: ] pop
1281: popEnv
1282: popVariables
1283: arg1
1284: } def
1285:
1286:
1287: [(genericAnnWithL)
1288: [$[f v] genericAnnWithL [b [L I]]$
1289: $String f,v; poly b,L; array of poly I;$
1290: $f is a polynomial given by a string. v is the variables.$
1291: $ v must not contain names s, e.$
1292: $b is the b-function (Bernstein-Sato polynomial) for f and$
1293: $ L is the operator satisfying L f^{s+1} = b(s) f^s $
1294: $ I is the annihilating ideal of f^s.$
1295: $cf. bfunction, annfs, genericAnn.$
1296: $Example 1: [(x^2+y^2) (x,y)] genericAnnWithL ::$
1297: $Example 2: [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
1298: $Example 3: [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
1299: ]] putUsages
1.2 takayama 1300:
1301: /reduction*.noH 0 def
1302: /reduction* {
1303: /arg1 set
1304: [/in-reduction* /aa /typev /setarg /f /v
1305: /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
1.3 takayama 1306: /opt
1.2 takayama 1307: ] pushVariables
1308: [(CurrentRingp) (KanGBmessage)] pushEnv
1309: [
1310:
1311: /aa arg1 def
1312: aa isArray { } { ( << array >> reduction*) error } ifelse
1313: /setarg 0 def
1314: /wv 0 def
1315: aa { tag } map /typev set
1316: typev [StringP ArrayP ArrayP] eq
1317: typev [ArrayP ArrayP ArrayP] eq or
1318: typev [PolyP ArrayP ArrayP] eq or
1319: { /h aa 0 get def
1320: /f aa 1 get def
1321: /v aa 2 get from_records def
1322: /setarg 1 def
1323: } { } ifelse
1324: typev [StringP ArrayP ArrayP ArrayP] eq
1325: typev [ArrayP ArrayP ArrayP ArrayP] eq or
1326: typev [PolyP ArrayP ArrayP ArrayP] eq or
1327: { /h aa 0 get def
1328: /f aa 1 get def
1329: /v aa 2 get from_records def
1330: /wv aa 3 get def
1331: /setarg 1 def
1332: } { } ifelse
1333:
1334: setarg { } { (reduction* : Argument mismatch) error } ifelse
1335:
1336: [(KanGBmessage) gb.verbose ] system_variable
1337:
1338: %%% Start of the preprocess
1339: f getRing /rr set
1340:
1341:
1342: rr tag 0 eq {
1343: %% Define our own ring
1344: v isInteger {
1345: (Error in reduction*: Specify variables) error
1346: } { } ifelse
1347: wv isInteger {
1348: [v ring_of_differential_operators
1349: 0] define_ring
1350: /termorder 1 def
1351: }{
1352: [v ring_of_differential_operators
1353: wv weight_vector
1354: 0] define_ring
1355: wv gb.isTermOrder /termorder set
1356: } ifelse
1357: } {
1358: %% Use the ring structre given by the input.
1359: v isInteger not {
1.7 takayama 1360: gb.warning {
1361: (Warning : the given ring definition is not used.) message
1362: } { } ifelse
1.2 takayama 1363: } { } ifelse
1364: rr ring_def
1365: /wv rr gb.getWeight def
1366: wv gb.isTermOrder /termorder set
1367: } ifelse
1368: %%% Enf of the preprocess
1369:
1370: f 0 get isArray {
1371: /size f 0 get length def
1372: f { { toString . } map } map /f set
1373: f fromVectors /f set
1374: }{
1375: /size -1 def
1376: f { toString . } map /f set
1377: } ifelse
1378:
1379: h isArray {
1380: h { toString . } map /h set
1381: [h] fromVectors 0 get /h set
1382: }{
1383: h toString . /h set
1384: } ifelse
1385: f { toString . } map /f set
1.3 takayama 1386: getOptions /opt set
1387: [(ReduceLowerTerms) 1] system_variable
1.2 takayama 1388: reduction*.noH {
1389: h f reduction-noH /ans set
1390: } {
1391: h f reduction /ans set
1392: } ifelse
1.3 takayama 1393: opt restoreOptions
1.2 takayama 1394: size -1 eq not {
1395: [size ans 0 get] toVectors /a0 set
1396: [size ans 3 get] toVectors /a3 set
1397: /ans [a0 ans 1 get ans 2 get a3] def
1398: } { } ifelse
1399: /arg1 ans def
1400: ] pop
1401: popEnv
1402: popVariables
1403: arg1
1404: } def
1405:
1406:
1407: [(reduction*)
1408: [([f base v] reduction* [h c0 syz input])
1409: ([f base v weight] reduction* [h c0 syz input])
1410: (reduction* is an user interface for reduction and reduction-noH.)
1411: (If reduction*.noH is one, then reduction-noH will be called.)
1412: (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
1413: (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
1414: (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
1415: ]] putUsages
1.5 takayama 1416:
1417:
1418:
1419: %% 2000, 6/7, at Sevilla, Hernando Colon
1420: %% macros that deal with homogenized inputs.
1421: %% Sample: [ [(h+x). (x^3).] [(x). (x).]] /ff set
1422: %% [(Homogenize_vec) 0] system_varialbe
1423: %% (grade) (grave1v) switch_function
1424: %% YA homogenization: [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
1425: %% 4+0 3+1 2+0 1+1
1426: /gb_h {
1427: /arg1 set
1428: [/in-gb_h /aa /typev /setarg /f /v
1429: /gg /wv /termorder /vec /ans /rr /mm
1.23 takayama 1430: /gb_h.opt /groebnerOptions
1.5 takayama 1431: ] pushVariables
1432: [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
1433: [
1434:
1435: /aa arg1 def
1.6 takayama 1436: gb.verbose { (Getting in gb_h) message } { } ifelse
1.5 takayama 1437: aa isArray { } { ( << array >> gb_h) error } ifelse
1.23 takayama 1438: aa getAttributeList configureGroebnerOption /groebnerOptions set
1.5 takayama 1439: /setarg 0 def
1440: /wv 0 def
1441: aa { tag } map /typev set
1442: typev [ ArrayP ] eq
1443: { /f aa 0 get def
1444: /v gb.v def
1445: /setarg 1 def
1446: } { } ifelse
1447: typev [ArrayP StringP] eq
1448: { /f aa 0 get def
1449: /v aa 1 get def
1450: /setarg 1 def
1451: } { } ifelse
1.10 takayama 1452: typev [ArrayP RingP] eq
1453: { /f aa 0 get def
1454: /v aa 1 get def
1455: /setarg 1 def
1456: } { } ifelse
1.5 takayama 1457: typev [ArrayP ArrayP] eq
1458: { /f aa 0 get def
1459: /v aa 1 get from_records def
1460: /setarg 1 def
1461: } { } ifelse
1462: typev [ArrayP StringP ArrayP] eq
1463: { /f aa 0 get def
1464: /v aa 1 get def
1465: /wv aa 2 get def
1466: /setarg 1 def
1467: } { } ifelse
1468: typev [ArrayP ArrayP ArrayP] eq
1469: { /f aa 0 get def
1470: /v aa 1 get from_records def
1471: /wv aa 2 get def
1472: /setarg 1 def
1473: } { } ifelse
1474:
1475: setarg { } { (gb_h : Argument mismatch) error } ifelse
1476:
1477: [(KanGBmessage) gb.verbose ] system_variable
1478:
1479: %%% Start of the preprocess
1.10 takayama 1480: v tag RingP eq {
1481: /rr v def
1482: }{
1483: f getRing /rr set
1484: } ifelse
1.5 takayama 1485: %% To the normal form : matrix expression.
1486: f gb.toMatrixOfString /f set
1487: /mm gb.itWasMatrix def
1488:
1489: rr tag 0 eq {
1490: %% Define our own ring
1491: v isInteger {
1492: (Error in gb_h: Specify variables) error
1493: } { } ifelse
1494: wv isInteger {
1495: [v ring_of_differential_operators
1496: 0] define_ring
1497: /termorder 1 def
1498: }{
1499: [v ring_of_differential_operators
1500: wv weight_vector
1501: 0] define_ring
1502: wv gb.isTermOrder /termorder set
1503: } ifelse
1504: } {
1505: %% Use the ring structre given by the input.
1506: v isInteger not {
1.7 takayama 1507: gb.warning {
1508: (Warning : the given ring definition is not used.) message
1509: } { } ifelse
1.5 takayama 1510: } { } ifelse
1511: rr ring_def
1512: /wv rr gb.getWeight def
1513: wv gb.isTermOrder /termorder set
1514: } ifelse
1515: getOptions /gb_h.opt set
1516: (grade) (module1v) switch_function
1.6 takayama 1517: [(Homogenize_vec) 0] system_variable
1.5 takayama 1518: %%% End of the preprocess
1519:
1.23 takayama 1520: groebnerOptions gb.options mergeGroebnerOptions /groebnerOptions set
1521: gb.verbose { (groebnerOptions = ) messagen groebnerOptions message } { } ifelse
1.5 takayama 1522: termorder {
1523: f { {. } map } map /f set
1.23 takayama 1524: [f groebnerOptions] groebner 0 get /gg set %% Do not use sugar.
1.5 takayama 1525: }{
1526: f { {. } map} map /f set
1527: f fromVectors /f set
1.23 takayama 1528: [f groebnerOptions] groebner 0 get /gg set
1.5 takayama 1529: }ifelse
1530: wv isInteger {
1531: /ans [gg gg {init} map] def
1532: }{
1533: /ans [gg gg {wv 0 get weightv init} map] def
1534: }ifelse
1535:
1536: %% Postprocess : recover the matrix expression.
1537: mm {
1538: ans { /tmp set [mm tmp] toVectors } map
1539: /ans set
1540: }{ }
1541: ifelse
1.23 takayama 1542: ans gg getAttributeList setAttributeList /ans set
1.5 takayama 1543: gb_h.opt restoreOptions
1.6 takayama 1544: gb.verbose { (Getting out of gb_h) message } { } ifelse
1.5 takayama 1545: %%
1546:
1547: /arg1 ans def
1548: ] pop
1549: popEnv
1550: popVariables
1551: arg1
1552: } def
1553: (gb_h ) messagen-quiet
1554: [(gb_h)
1555: [(a gb_h b)
1556: (array a; array b;)
1557: (b : [g ii]; array g; array in; g is a Grobner basis of f)
1558: ( in the ring of homogenized differential operators.)
1559: ( The input must be homogenized properly.)
1560: ( Inproper homogenization may cause an infinite loop.)
1561: ( Each element of vectors must be homogenized. If you are using )
1562: ( non-term orders, all elements of vectors must have the same degree with)
1563: ( a proper degree shift vector.)
1564: $ ii is the initial ideal in case of w is given or <<a>> belongs$
1565: $ to a ring. In the other cases, it returns the initial monominal.$
1566: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1567: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1568: (a : [f v]; array f; string v; v is the variables. )
1.10 takayama 1569: (a : [f r]; array f; ring r )
1.5 takayama 1570: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1571: ( )
1572: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1573: $ [ [ (Dx) 1 ] ] ] gb_h pmat ; $
1574: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
1575: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1576: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1577: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1578: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1579: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1580: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1581: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1582: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1.23 takayama 1583: $Example 5: [ [[(h+x) (x^3 + 2 h^3 + 2 x h^2)] [(x) (x)]] (x)] $
1.24 takayama 1584: $ [(reduceOnly) 1] setAttributeList gb_h pmat $
1.5 takayama 1585: ( )
1586: (cf. gb, groebner, syz_h. )
1587: ]] putUsages
1588:
1589: /syz_h {
1590: /arg1 set
1591: [/in-syz_h /aa /typev /setarg /f /v
1592: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
1593: /rr /mm
1594: /syz_h.opt
1595: ] pushVariables
1596: [(CurrentRingp) (KanGBmessage)] pushEnv
1597: [
1598:
1599: /aa arg1 def
1600: aa isArray { } { (<< array >> syz_h) error } ifelse
1601: /setarg 0 def
1602: /wv 0 def
1603: aa { tag } map /typev set
1604: typev [ ArrayP ] eq
1605: { /f aa 0 get def
1606: /v syz.v def
1607: /setarg 1 def
1608: } { } ifelse
1609: typev [ArrayP StringP] eq
1610: { /f aa 0 get def
1611: /v aa 1 get def
1612: /setarg 1 def
1613: } { } ifelse
1.10 takayama 1614: typev [ArrayP RingP] eq
1615: { /f aa 0 get def
1616: /v aa 1 get def
1617: /setarg 1 def
1618: } { } ifelse
1.5 takayama 1619: typev [ArrayP ArrayP] eq
1620: { /f aa 0 get def
1621: /v aa 1 get from_records def
1622: /setarg 1 def
1623: } { } ifelse
1624: typev [ArrayP StringP ArrayP] eq
1625: { /f aa 0 get def
1626: /v aa 1 get def
1627: /wv aa 2 get def
1628: /setarg 1 def
1629: } { } ifelse
1630: typev [ArrayP ArrayP ArrayP] eq
1631: { /f aa 0 get def
1632: /v aa 1 get from_records def
1633: /wv aa 2 get def
1634: /setarg 1 def
1635: } { } ifelse
1636:
1637: setarg { } { (syz_h : Argument mismatch) error } ifelse
1638:
1639: [(KanGBmessage) syz.verbose ] system_variable
1640:
1641:
1642:
1643: %%% Start of the preprocess
1.10 takayama 1644: v tag RingP eq {
1645: /rr v def
1646: }{
1647: f getRing /rr set
1648: } ifelse
1.5 takayama 1649: %% To the normal form : matrix expression.
1650: f gb.toMatrixOfString /f set
1651: /mm gb.itWasMatrix def
1652: mm 0 gt {
1653: /vectorInput 1 def
1654: }{
1655: /vectorInput 1 def
1656: } ifelse
1657:
1658: rr tag 0 eq {
1659: %% Define our own ring
1660: v isInteger {
1661: (Error in syz_h: Specify variables) error
1662: } { } ifelse
1663: wv isInteger {
1664: [v ring_of_differential_operators
1665: 0] define_ring
1666: /termorder 1 def
1667: }{
1668: [v ring_of_differential_operators
1669: wv weight_vector
1670: 0] define_ring
1671: wv gb.isTermOrder /termorder set
1672: } ifelse
1673: }{
1674: %% Use the ring structre given by the input.
1675: v isInteger not {
1.7 takayama 1676: gb.warning {
1677: (Warning : the given ring definition is not used.) message
1678: } { } ifelse
1.5 takayama 1679: } { } ifelse
1680: rr ring_def
1681: /wv rr gb.getWeight def
1682: wv gb.isTermOrder /termorder set
1683: } ifelse
1684:
1685: getOptions /syz_h.opt set
1686: (grade) (module1v) switch_function
1687: [(Homogenize_vec) 0] system_variable
1688: %%% End of the preprocess
1689:
1690: termorder {
1691: f { {. } map } map /f set
1692: [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
1693: ggall 2 get /gg set
1694: }{
1695: f { {. } map } map /f set
1696: [f [(needBack) (needSyz)]] groebner /ggall set
1697: ggall 2 get /gg set
1698: }ifelse
1699: vectorInput {
1700: /vsize f 0 get length def %% input vector size.
1701: /gtmp ggall 0 get def
1702: [vsize gtmp] toVectors /gtmp set
1703: ggall 0 gtmp put
1704: }{ } ifelse
1705:
1706: syz_h.opt restoreOptions
1707: %%
1708:
1709: /arg1 [gg ggall] def
1710: ] pop
1711: popEnv
1712: popVariables
1713: arg1
1714: } def
1715: (syz_h ) messagen-quiet
1716:
1717: [(syz_h)
1718: [(a syz_h [b c])
1719: (array a; array b; array c)
1720: (b is a set of generators of the syzygies of f in the ring of)
1721: (homogenized differential operators.)
1722: ( The input must be homogenized properly.)
1723: ( Inproper homogenization may cause an infinite loop.)
1724: ( Each element of vectors must be homogenized. If you are using )
1725: ( non-term orders, all elements of vectors must have the same degree with)
1726: ( a proper degree shift vector.)
1727: (c = [gb, backward transformation, syzygy without dehomogenization].)
1728: (See gb_h.)
1729: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1730: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1731: (a : [f v]; array f; string v; v is the variables.)
1.10 takayama 1732: (a : [f r]; array f; ring r )
1.5 takayama 1733: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1734: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1735: $ [ [ (Dx) 1 ] ] ] syz_h pmat ; $
1736: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
1737: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1738: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1739: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1740: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1741: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1742: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1743: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1744: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1745: $Example 5: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1746: $ [(x) (y)]] syz pmat ;$
1747: ]] putUsages
1748:
1749:
1750: /isSameIdeal {
1751: /arg1 set
1752: [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
1753: [(CurrentRingp)] pushEnv
1754: [
1755: /aa arg1 def
1756: %% comparison of hilbert series has not yet been implemented.
1757: aa length 3 eq { }
1758: { ([ii jj vv] isSameIdeal) error } ifelse
1.6 takayama 1759: gb.verbose { (Getting in isSameIdeal) message } { } ifelse
1.5 takayama 1760: /ii aa 0 get def
1761: /jj aa 1 get def
1762: /vv aa 2 get def
1763: ii length 0 eq jj length 0 eq and
1764: { /ans 1 def /LLL.isSame goto } { } ifelse
1765: [ii vv] gb /iigg set
1766: [jj vv] gb /jjgg set
1767:
1768: iigg getRing ring_def
1769:
1770: /ans 1 def
1771: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1772: /iigg set
1773: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1774: /jjgg set
1775:
1776: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1777: iigg length /n set
1778: 0 1 n 1 sub {
1779: /k set
1780: iigg k get
1781: jjgg reduction-noH 0 get
1782: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1783: gb.verbose { (o) messagen } { } ifelse
1784: } for
1785: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1786: jjgg length /n set
1787: 0 1 n 1 sub {
1788: /k set
1789: jjgg k get
1790: iigg reduction-noH 0 get
1791: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1792: gb.verbose { (o) messagen } { } ifelse
1793: } for
1794: /LLL.isSame
1795: gb.verbose { ( Done) message } { } ifelse
1796: /arg1 ans def
1797: ] pop
1798: popEnv
1799: popVariables
1800: arg1
1801: } def
1802: (isSameIdeal ) messagen-quiet
1803:
1804: [(isSameIdeal)
1805: [([ii jj vv] isSameIdeal bool)
1806: (ii, jj : ideal, vv : variables)
1807: (Note that ii and jj will be dehomogenized and compared in the ring)
1808: (of differential operators. cf. isSameIdeal_h)
1809: $Example 1: [ [(x^3) (y^2)] [(x^2+y) (y)] (x,y)] isSameIdeal $
1810: $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
1811: $ [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
1812: ]] putUsages
1813:
1814: /isSameIdeal_h {
1815: /arg1 set
1.6 takayama 1816: [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
1817: /isSameIdeal_h.opt
1818: ] pushVariables
1819: [(CurrentRingp) (Homogenize_vec)] pushEnv
1.5 takayama 1820: [
1821: /aa arg1 def
1.6 takayama 1822: gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
1.5 takayama 1823: %% comparison of hilbert series has not yet been implemented.
1824: aa length 3 eq { }
1825: { ([ii jj vv] isSameIdeal_h) error } ifelse
1826: /ii aa 0 get def
1827: /jj aa 1 get def
1828: /vv aa 2 get def
1829: ii length 0 eq jj length 0 eq and
1830: { /ans 1 def /LLL.isSame_h goto } { } ifelse
1831:
1832: [ii vv] gb_h /iigg set
1833: [jj vv] gb_h /jjgg set
1834:
1835: iigg getRing ring_def
1836:
1.6 takayama 1837: getOptions /isSameIdeal_h.opt set
1838: (grade) (module1v) switch_function
1839: [(Homogenize_vec) 0] system_variable
1.5 takayama 1840: /ans 1 def
1841: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1842: /iigg set
1843: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1844: /jjgg set
1845:
1.8 takayama 1846: gb.verbose { (Comparing) message iigg message (and) message jjgg message }
1847: { } ifelse
1.5 takayama 1848: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1849: iigg length /n set
1850: 0 1 n 1 sub {
1851: /k set
1852: iigg k get
1853: jjgg reduction 0 get
1854: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1855: gb.verbose { (o) messagen } { } ifelse
1856: } for
1857: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1858: jjgg length /n set
1859: 0 1 n 1 sub {
1860: /k set
1861: jjgg k get
1862: iigg reduction 0 get
1863: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1864: gb.verbose { (o) messagen } { } ifelse
1865: } for
1866: /LLL.isSame_h
1867: gb.verbose { ( Done) message } { } ifelse
1.6 takayama 1868: isSameIdeal_h.opt restoreOptions
1.5 takayama 1869: /arg1 ans def
1870: ] pop
1871: popEnv
1872: popVariables
1873: arg1
1874: } def
1875: (isSameIdeal_h ) messagen-quiet
1876:
1877: [(isSameIdeal_h)
1878: [([ii jj vv] isSameIdeal_h bool)
1879: (ii, jj : ideal, vv : variables)
1880: (Note that ii and jj will be compared in the ring)
1881: (of homogenized differential operators. Each element of the vector must be)
1882: (homogenized.)
1883: $Example 1: [ [(x Dx - h^2) (Dx^2)] [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
1884: $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
1885: $ [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
1886: ]] putUsages
1887:
1.15 takayama 1888: /gb.reduction {
1889: /arg2 set
1890: /arg1 set
1891: [/in-gb.reduction /gbasis /flist /ans /gbasis2
1892: ] pushVariables
1893: [(CurrentRingp) (KanGBmessage)] pushEnv
1894: [
1895: /gbasis arg2 def
1896: /flist arg1 def
1897: gbasis 0 get tag 6 eq { }
1898: { (gb.reduction: the second argument must be a list of lists) error }
1899: ifelse
1900:
1901: gbasis length 1 eq {
1902: gbasis getRing ring_def
1903: /gbasis2 gbasis 0 get def
1904: } {
1905: [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22 takayama 1906: /gbasis2 gbasis 0 get ___ def
1.15 takayama 1907: } ifelse
1908:
1.5 takayama 1909:
1.22 takayama 1910: flist ___ /flist set
1.15 takayama 1911: flist tag 6 eq {
1912: flist { gbasis2 reduction } map /ans set
1913: }{
1914: flist gbasis2 reduction /ans set
1915: } ifelse
1916: /arg1 ans def
1917:
1918: ] pop
1919: popEnv
1920: popVariables
1921: arg1
1922: } def
1923:
1.20 takayama 1924: /gb.reduction_noh {
1925: /arg2 set
1926: /arg1 set
1927: [/in-gb.reduction_noh /gbasis /flist /ans /gbasis2
1928: ] pushVariables
1929: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1930: [
1931: /gbasis arg2 def
1932: /flist arg1 def
1933: gbasis 0 get tag 6 eq { }
1934: { (gb.reduction_noh: the second argument must be a list of lists) error }
1935: ifelse
1936:
1937: gbasis length 1 eq {
1938: gbasis getRing ring_def
1939: /gbasis2 gbasis 0 get def
1940: } {
1941: [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1.22 takayama 1942: /gbasis2 gbasis 0 get ___ def
1.20 takayama 1943: } ifelse
1944:
1945:
1.22 takayama 1946: flist ___ /flist set
1.20 takayama 1947: [(Homogenize) 0] system_variable
1948: flist tag 6 eq {
1949: flist { gbasis2 reduction } map /ans set
1950: }{
1951: flist gbasis2 reduction /ans set
1952: } ifelse
1953: /arg1 ans def
1954:
1955: ] pop
1956: popEnv
1957: popVariables
1958: arg1
1959: } def
1960:
1.15 takayama 1961: /gb.reduction.test {
1962: [
1963: [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
1964: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
1965: gb /gg set
1966:
1967: ((h-x-y)*Dx) [gg 0 get] gb.reduction /gg2 set
1968: gg2 message
1969: (-----------------------------) message
1970:
1971: [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )]
1972: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
1973: ((h-x-y)*Dx) ggg gb.reduction /gg4 set
1974: gg4 message
1975: (-----------------------------) message
1976: [gg2 gg4]
1977: } def
1978: [(gb.reduction)
1979: [ (f basis gb.reduction r)
1980: (f is reduced by basis by the normal form algorithm.)
1981: (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
1982: (r is the return value format of reduction;)
1983: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1984: (basis is given in the argument format of gb.)
1.16 takayama 1985: $h[1,1](D)-homogenization is used.$
1.15 takayama 1986: (cf. reduction, gb, ecartd.gb, gb.reduction.test )
1987: $Example:$
1988: $ [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )] $
1989: $ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
1990: $ ((h-x-y)^2*Dx*Dy) ggg gb.reduction :: $
1.20 takayama 1991: ]] putUsages
1992:
1993: [(gb.reduction_noh)
1994: [ (f basis gb.reduction_noh r)
1995: (f is reduced by basis by the normal form algorithm.)
1996: (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
1997: (r is the return value format of reduction;)
1998: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1999: (basis is given in the argument format of gb.)
2000: (cf. gb.reduction, gb )
2001: $Example:$
2002: $ [[( 2*Dx + 1 ) ( 2*Dy + 1 )] $
2003: $ (x,y) [[(Dx) 1 (Dy) 1]]] /ggg set $
2004: $ ((1-x-y)^2*Dx*Dy) ggg gb.reduction_noh :: $
1.15 takayama 2005: ]] putUsages
1.1 maekawa 2006:
1.30 ! takayama 2007: %% 2019.09
! 2008: /toe_ {
! 2009: /arg1 set
! 2010: [/L /ans] pushVariables
! 2011: [
! 2012: arg1 /L set
! 2013: L length 0 eq {
! 2014: /ans [ ] def
! 2015: }{
! 2016: L 0 get tag 6 eq {
! 2017: L toe_.for_vec_of_vec /ans set
! 2018: }{
! 2019: /ans [(toe_) L] gbext def
! 2020: } ifelse
! 2021: } ifelse
! 2022: ans /arg1 set
! 2023: ] pop
! 2024: arg1
! 2025: } def
! 2026: [(toe_)
! 2027: [(vector toe_ <<sparse form of the vector>>)
! 2028: (<<list of vectors>> toe_ <<sparse form of the vectors>>)
! 2029: (Example: [[[(x*y+1) (x*y)] , [(1) (x)]] (x,y)] gb /gg set , gg 0 get toe_ reducedBase { 2 tovec.with_size } map ::)
! 2030: (cf. tovec.with_size, toVectors)
! 2031: ]
! 2032: ] putUsages
! 2033:
! 2034: /toe_.for_vec_of_vec {
! 2035: /arg1 set
! 2036: [/i /L] pushVariables
! 2037: [
! 2038: arg1 /L set
! 2039: [ 1 1 L length {
! 2040: /i set
! 2041: [(toe_) L i 1 sub get] gbext
! 2042: } for
! 2043: ] /arg1 set
! 2044: ]pop
! 2045: popVariables
! 2046: arg1
! 2047: } def
! 2048:
! 2049: /tovec.with_size {
! 2050: /arg2 set
! 2051: /arg1 set
! 2052: [/L /nn /ans /L2 ] pushVariables
! 2053: [
! 2054: arg1 /L set
! 2055: arg2 /nn set
! 2056: L tag 6 eq {
! 2057: L {nn tovec.with_size} map /ans set
! 2058: } {
! 2059: L nn tovec.with_size.single /ans set
! 2060: } ifelse
! 2061: ans /arg1 set
! 2062: ] pop
! 2063: popVariables
! 2064: arg1
! 2065: } def
! 2066:
! 2067: [(tovec.with_size)
! 2068: [ (<<sparse vector>> size tovec.with_size vector)
! 2069: (<<vector of sparse vectors>> size tovec.with_size <<vector of vectors>>)
! 2070: (cf. toe_)
! 2071: ]
! 2072: ] putUsages
! 2073:
! 2074: /tovec.with_size.single {
! 2075: /arg2 set
! 2076: /arg1 set
! 2077: [/L /nn /ans /L2 /myenv] pushVariables
! 2078: [
! 2079: arg1 /L set
! 2080: arg2 /nn set
! 2081: % [ (CurrentRingp) ] pushEnv /myenv set L getRing ring_def
! 2082: L toVectors /L set
! 2083: L length nn lt {
! 2084: L [L length 1 nn 1 sub {pop (0).} for] join /L2 set
! 2085: } { /L2 L def } ifelse
! 2086: % myenv popEnv
! 2087: ] pop
! 2088: L2 /arg1 set
! 2089: popVariables
! 2090: arg1
! 2091: } def
! 2092:
! 2093: /mod_reduction {
! 2094: /arg2 set
! 2095: /arg1 set
! 2096: [/hh /gg /nn /gge /hhe /rr] pushVariables
! 2097: [
! 2098: arg1 /hh set
! 2099: arg2 /gg set
! 2100: [hh gg] message %%%for debug
! 2101: [hh {tag} map gg { {tag} map } map] message %%% for debug
! 2102: hh length /nn set
! 2103: gg toe_ /gge set
! 2104: [(toe_) hh] gbext /hhe set
! 2105: [hhe gge] message
! 2106: hhe gge reduction /rr set
! 2107:
! 2108: [rr 0 get nn tovec.with_size ,
! 2109: rr 1 get ,
! 2110: rr 2 get {nn tovec.with_size} map ,
! 2111: rr 3 get {nn tovec.with_size} map
! 2112: ]
! 2113: /arg1 set
! 2114: ] pop
! 2115: popVariables
! 2116: arg1
! 2117: } def
! 2118:
! 2119: %% test input.
! 2120: %[ [[(x^2) (y)] [(0) (y^2)]] (x,y)] gb /ff set ff getRing ring_def [(x^2+1). (y^2+1).] /hh set hh ff 0 get mod_reduction /ans set
! 2121:
! 2122: [(mod_reduction)
! 2123: [(vector <<gb of submodules>> mod_reduction [r c0 s reducers] )
! 2124: $r = c0 <<vector>> + <<inner product of s and reducers>>$
! 2125: $vector and gb must be given by the non-sparse form (without e_)$
! 2126: (String input is not accepted.)
! 2127: (Example: [(AutoReduce) 1] system_variable [ [[(x^2) (y)] [(0) (y^2)]] (x,y)] gb /ff set ff getRing ring_def [(x^2+1). (y^2+1).] /hh set hh ff 0 get mod_reduction /ans set)
! 2128: (cf. toe_)
! 2129: ]
! 2130: ] putUsages
! 2131:
! 2132: %% 2019.09.08 transform string to poly recursively. cf. misc-2019/09/hgs/sred.sm1
! 2133: /to_poly {
! 2134: /arg1 set
! 2135: [/L /ans] pushVariables
! 2136: [
! 2137: arg1 /L set
! 2138: L tag 5 eq { % string
! 2139: L . /ans set
! 2140: } {
! 2141: L tag 6 eq { % list
! 2142: L { to_poly } map /ans set
! 2143: }{
! 2144: L tag 1 eq , L tag 15 eq , or { % int32 or univInt
! 2145: L toString to_poly /ans set
! 2146: }{
! 2147: L /ans set
! 2148: } ifelse
! 2149: }ifelse
! 2150: } ifelse
! 2151: ans /arg1 set
! 2152: ] pop
! 2153: popVariables
! 2154: arg1
! 2155: } def
! 2156:
! 2157: %
! 2158: /mod_reduction* {
! 2159: /arg1 set
! 2160: [/in-mod_reduction* /aa /ans /vv
! 2161: ] pushVariables
! 2162: [(CurrentRingp) (KanGBmessage)] pushEnv
! 2163: [
! 2164:
! 2165: /aa arg1 def
! 2166: aa isArray { } { ( << array >> mod_reduction*) error } ifelse
! 2167: aa length 2 lt {
! 2168: (<< array whose length >= 2 >> mod_reduction*) error
! 2169: } { } ifelse
! 2170: aa 0 get isArray { }
! 2171: {
! 2172: /mod_reduction*.LLL2 goto
! 2173: } ifelse
! 2174: aa length 2 eq {
! 2175: aa mod_reduction*.two.args /ans set
! 2176: /mod_reduction*.LLL goto
! 2177: } { } ifelse
! 2178:
! 2179: /mod_reduction*.LLL2
! 2180: aa 2 get /vv set
! 2181: aa 2 get tag , StringP eq {
! 2182: aa 2 , [vv to_records pop], put
! 2183: } { } ifelse
! 2184: aa reduction* /ans set
! 2185:
! 2186: /mod_reduction*.LLL
! 2187: /arg1 ans def
! 2188: ] pop
! 2189: popEnv
! 2190: popVariables
! 2191: arg1
! 2192: } def
! 2193:
! 2194:
! 2195: [(mod_reduction*)
! 2196: [([f base] mod_reduction* [h c0 syz input])
! 2197: ([f base v] mod_reduction* [h c0 syz input])
! 2198: ([f base v weight] mod_reduction* [h c0 syz input])
! 2199: (mod_reduction* is an user interface for mod_reduction.)
! 2200: (cf. reduction*)
! 2201: (Example 1. [ [(x) (y+1)] [ [(x) (0)] [(0) (y)]] (x,y)] mod_reduction* ::)
! 2202: (Example 2. [ [[(x^2) (y)] [(0) (y^2)]] (x,y)] gb /ff set ff getRing ring_def [(x^2+1). (y^2+1).] /hh set, [hh, ff 0 get] mod_reduction* /ans set)
! 2203: ]] putUsages
! 2204:
! 2205: /mod_reduction*.two.args {
! 2206: /arg1 set
! 2207: [/L ] pushVariables
! 2208: [
! 2209: arg1 /L set
! 2210: L 0 get to_poly , L 1 get to_poly , mod_reduction
! 2211: /arg1 set
! 2212: ] popVariables
! 2213: arg1
! 2214: } def
! 2215:
1.1 maekawa 2216: ( ) message-quiet ;
2217:
1.21 takayama 2218: /hol_loaded 1 def
1.1 maekawa 2219:
2220:
2221:
2222:
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