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