Annotation of OpenXM/src/kan96xx/Doc/hol.sm1, Revision 1.17
1.17 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/hol.sm1,v 1.16 2004/05/04 08:29:35 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.17 ! 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.14 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.14 takayama 401: f { {,,, dehomogenize} map} map /f set
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
925: /arg1 [gg dehomogenize ggall] def
926: ] pop
927: popEnv
928: popVariables
929: arg1
930: } def
931: (syz ) messagen-quiet
932:
933: [(syz)
934: [(a syz [b c])
935: (array a; array b; array c)
936: (b is a set of generators of the syzygies of f.)
937: (c = [gb, backward transformation, syzygy without dehomogenization].)
938: (See groebner.)
939: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
940: (a : [f v]; array f; string v; v is the variables.)
941: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1.9 takayama 942: ( v may be a ring object. )
1.1 maekawa 943: $Example 1: [(x,y) ring_of_polynomials 0] define_ring $
944: $ [ [(x^2+y^2-4). (x y -1).] ] syz :: $
945: $Example 2: [ [(x^2+y^2) (x y)] (x,y) [ [(x) -1 (y) -1] ] ] syz :: $
946: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
947: $ [ [ (Dx) 1 ] ] ] syz pmat ; $
948: $Example 4: [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
949: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] syz pmat ;$
950: $Example 5: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
951: $ (x,y) ] syz pmat ;$
952: $Example 6: [ [ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] $
953: $ (x,y) [[(x) -1 (y) -2]] ] syz pmat ;$
954: $Example 7: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
955: $ [(x) (y)]] syz pmat ;$
956: ]] putUsages
957:
958:
959: %%%%%%%%%%%%%%%%%% package fs %%%%%%%%%%%%%%%%%%%%%%%
960: [(genericAnn)
961: [ (f [s v1 v2 ... vn] genericAnn [L1 ... Lm])
962: (L1, ..., Lm are annihilating ideal for f^s.)
963: (f is a polynomial of v1, ..., vn)
964: (<string> | <poly> f, s, v1, ..., vn ; <poly> L1, ..., Lm )
965: $Example: (x^3+y^3+z^3) [(s) (x) (y) (z)] genericAnn$
966: ]
967: ] putUsages ( genericAnn ) messagen-quiet
968: /fs.verbose 0 def
969: /genericAnn {
970: /arg2 set /arg1 set
971: [/in-genericAnn /f /vlist /s /vvv /nnn /rrr
972: /v1 /ops /ggg /ggg0
973: ] pushVariables
974: [(CurrentRingp) (KanGBmessage)] pushEnv
975: [
976: /f arg1 def /vlist arg2 def
977: f toString /f set
978: vlist { toString } map /vlist set
979: [(KanGBmessage) fs.verbose] system_variable
980: /s vlist 0 get def
981: /vvv (_u,_v,_t,) vlist rest { (,) 2 cat_n } map aload length /nnn set
982: s nnn 2 add cat_n def
983: fs.verbose { vvv message } { }ifelse
984: [vvv ring_of_differential_operators
985: [[(_u) 1 (_v) 1]] weight_vector 0] define_ring /rrr set
986:
987: [ (_u*_t). f . sub (_u*_v-1). ]
988: vlist rest { /v1 set
989: %%D-clean f . (D) v1 2 cat_n . 1 diff0 (_v*D_t). mul
990: f . @@@.Dsymbol v1 2 cat_n . 1 diff0 [(_v*) @@@.Dsymbol (_t)] cat . mul
991: @@@.Dsymbol v1 2 cat_n . add } map
992: join
993: /ops set
994: ops {[[(h). (1).]] replace } map /ops set
995: fs.verbose { ops message } { }ifelse
996: [ops] groebner_sugar 0 get /ggg0 set
997: fs.verbose { ggg0 message } { } ifelse
998: ggg0 [(_u) (_v)] eliminatev
999: %%D-clean { [(_t).] [ (D_t).] [s .] distraction
1000: { [(_t).] [ [@@@.Dsymbol (_t)] cat .] [s .] distraction
1001: [[s . << (0). s . sub (1). sub >>]] replace
1002: } map /arg1 set
1003: ] pop
1004: popEnv
1005: popVariables
1006: arg1
1007: } def
1008:
1009: %% Find differential equations for f^(m), r0 the minimal integral root.
1010: [(annfs)
1011: [( [ f v m r0] annfs g )
1012: (It returns the annihilating ideal of f^m where r0 must be smaller)
1013: (or equal to the minimal integral root of the b-function.)
1014: (Or, it returns the annihilating ideal of f^r0, r0 and the b-function)
1015: (where r0 is the minial integral root of b.)
1016: (For the algorithm, see J. Pure and Applied Algebra 117&118(1997), 495--518.)
1017: (Example 1: [(x^2+y^2+z^2+t^2) (x,y,z,t) -1 -2] annfs :: )
1018: $ It returns the annihilating ideal of (x^2+y^2+z^2+t^2)^(-1).$
1019: (Example 2: [(x^2+y^2+z^2+t^2) (x,y,z,t)] annfs :: )
1020: $ It returns the annihilating ideal of f^r0 and [r0, b-function]$
1021: $ where r0 is the minimal integral root of the b-function.$
1022: (Example 3: [(x^2+y^2+z^2) (x,y,z) -1 -1] annfs :: )
1023: (Example 4: [(x^3+y^3+z^3) (x,y,z)] annfs :: )
1024: (Example 5: [((x1+x2+x3)(x1 x2 + x2 x3 + x1 x3) - t x1 x2 x3 ) )
1025: ( (t,x1,x2,x3) -1 -2] annfs :: )
1026: ( Note that the example 4 uses huge memory space.)
1027: ]] putUsages
1028: ( annfs ) messagen-quiet
1029: /annfs.verbose fs.verbose def
1030: /annfs.v [(x) (y) (z)] def
1031: /annfs.s (_s) def
1032: %% The first variable must be s.
1033: /annfs {
1034: /arg1 set
1035: [/in-annfs /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1036: /ans /vtmp /w2 /velim /bbb /rrr /r0
1037: ] pushVariables
1038: [(CurrentRingp) (KanGBmessage)] pushEnv
1039: [
1040:
1041: /aa arg1 def
1042: aa isArray { } { ( << array >> annfs) error } ifelse
1043: /setarg 0 def
1044: aa { tag } map /typev set
1045: /r0 [ ] def
1046: /m [ ] def
1047: /v annfs.v def
1048: aa 0 << aa 0 get toString >> put
1049: typev [ StringP ] eq
1050: { /f aa 0 get def
1051: /setarg 1 def
1052: } { } ifelse
1053: typev [StringP StringP] eq
1054: { /f aa 0 get def
1055: /v [ aa 1 get to_records pop ] def
1056: /setarg 1 def
1057: } { } ifelse
1058: typev [StringP ArrayP] eq
1059: { /f aa 0 get def
1060: /v aa 1 get def
1061: /setarg 1 def
1062: } { } ifelse
1063: typev [StringP ArrayP IntegerP IntegerP] eq
1064: { /f aa 0 get def
1065: /v aa 1 get def
1066: /m aa 2 get def
1067: /r0 aa 3 get def
1068: /setarg 1 def
1069: } { } ifelse
1070: typev [StringP StringP IntegerP IntegerP] eq
1071: { /f aa 0 get def
1072: /v [ aa 1 get to_records pop ] def
1073: /m aa 2 get def
1074: /r0 aa 3 get def
1075: /setarg 1 def
1076: } { } ifelse
1077: setarg 1 eq { } { (annfs : wrong argument) error } ifelse
1078:
1079: [annfs.s] v join /v set
1080:
1081: /ss v 0 get def
1082: annfs.verbose {
1083: (f, v, s, f^{m}, m+r0 = ) messagen
1084: [ f (, ) v (, ) ss (, )
1085: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1086: } { } ifelse
1087:
1088: f v genericAnn /fs set
1089:
1090: annfs.verbose {
1091: (genericAnn is ) messagen fs message
1092: } { } ifelse
1093: [(KanGBmessage) annfs.verbose] system_variable
1094:
1095: m isArray {
1096: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1097: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1098: velim { 1 } map /w2 set
1099: annfs.verbose { w2 message } { } ifelse
1100: [v from_records ring_of_differential_operators
1101: [w2] weight_vector 0] define_ring
1102: [ fs { toString . } map [ f toString . ] join ]
1103: groebner_sugar 0 get velim eliminatev 0 get /bbb set
1104: [[(s) annfs.s] from_records ring_of_polynomials 0] define_ring
1105: bbb toString . [[annfs.s . (s).]] replace /bbb set
1106: annfs.verbose { bbb message } { } ifelse
1107: bbb findIntegralRoots /rrr set
1108: rrr 0 get /r0 set %% minimal integral root.
1109: annfs.verbose { rrr message } { } ifelse
1110: fs 0 get (ring) dc ring_def
1111: fs { [[annfs.s . r0 toString .]] replace } map /ans set
1112: /ans [ans [r0 bbb]] def
1113: /annfs.label1 goto
1114: } { } ifelse
1115: m 0 ge {
1116: (annfs works only for getting annihilating ideal for f^(negative))
1117: error
1118: } { } ifelse
1119: r0 isArray {
1120: [(Need to compute the minimal root of b-function) nl
1121: (It has not been implemented.) ] cat
1122: error
1123: } { } ifelse
1124:
1125: [v from_records ring_of_differential_operators 0] define_ring
1126: fs {toString . dehomogenize [[ss . r0 (poly) dc]] replace}
1127: map /gg set
1128: annfs.verbose { gg message } { } ifelse
1129:
1130: [ [f . << m r0 sub >> npower ] gg join
1131: [(needBack) (needSyz)]] groebner_sugar 2 get /gg2 set
1132:
1133: gg2 { 0 get } map /ans set
1134: /ans ans { dup (0). eq {pop} { } ifelse } map def
1135:
1136: /annfs.label1
1137: /arg1 ans def
1138: ] pop
1139: popEnv
1140: popVariables
1141: arg1
1142: } def
1143:
1144: /genericAnnWithL.s (s) def
1145: /annfs.verify 0 def
1146: /genericAnnWithL {
1147: /arg1 set
1148: [/in-genericAnnWithL /aa /typev /setarg /v /m /r0 /gg /ss /fs /gg2
1149: /ans /vtmp /w2 /velim /bbb /rrr /r0 /myL /mygb /jj
1150: ] pushVariables
1151: [(CurrentRingp) (KanGBmessage) (Homogenize)] pushEnv
1152: [
1153:
1154: /aa arg1 def
1155: aa isArray { } { ( << array >> annfs) error } ifelse
1156: /setarg 0 def
1157: aa { tag } map /typev set
1158: /r0 [ ] def
1159: /m [ ] def
1160: /v annfs.v def
1161: aa 0 << aa 0 get toString >> put
1162: typev [ StringP ] eq
1163: { /f aa 0 get def
1164: /setarg 1 def
1165: } { } ifelse
1166: typev [StringP StringP] eq
1167: { /f aa 0 get def
1168: /v [ aa 1 get to_records pop ] def
1169: /setarg 1 def
1170: } { } ifelse
1171: typev [StringP ArrayP] eq
1172: { /f aa 0 get def
1173: /v aa 1 get def
1174: /setarg 1 def
1175: } { } ifelse
1176: setarg 1 eq { } { (genericAnnWithL : wrong argument) error } ifelse
1177:
1178: [genericAnnWithL.s] v join /v set
1179:
1180: /ss v 0 get def
1181: annfs.verbose {
1182: (f, v, s, f^{m}, m+r0 = ) messagen
1183: [ f (, ) v (, ) ss (, )
1184: (f^) m (,) m (+) r0 ] {messagen} map ( ) message
1185: } { } ifelse
1186:
1187: f v genericAnn /fs set
1188:
1189: annfs.verbose {
1190: (genericAnn is ) messagen fs message
1191: } { } ifelse
1192: [(KanGBmessage) annfs.verbose] system_variable
1193:
1194: m isArray {
1195: %% Now, let us find the b-function. /vtmp /w2 /velim /bbb /rrr /r0
1196: v rest { /vtmp set vtmp @@@.Dsymbol vtmp 2 cat_n } map /velim set
1197: velim { 1 } map /w2 set
1198: annfs.verbose { w2 message } { } ifelse
1199: [v from_records ring_of_differential_operators
1200: [w2] weight_vector 0] define_ring
1201:
1202: [ [ f toString . ] fs { toString . } map join [(needBack)]]
1203: groebner_sugar /mygb set
1204: mygb 0 get velim eliminatev 0 get /bbb set
1205: mygb 0 get bbb position /jj set
1206: mygb 1 get jj get 0 get /myL set
1207:
1208: annfs.verbose { bbb message } { } ifelse
1209:
1210: annfs.verify {
1211: (Verifying L f - b belongs to genericAnn(f)) message
1212: [(Homogenize) 0] system_variable
1213: << myL f . mul bbb sub >>
1214: [fs { toString . } map] groebner_sugar 0 get
1215: reduction 0 get message
1216: (Is it zero? Then it's fine.) message
1217: } { } ifelse
1218:
1219: /ans [bbb [myL fs] ] def
1220: /annfs.label1 goto
1221: } { } ifelse
1222:
1223: /annfs.label1
1224: /arg1 ans def
1225: ] pop
1226: popEnv
1227: popVariables
1228: arg1
1229: } def
1230:
1231:
1232: [(genericAnnWithL)
1233: [$[f v] genericAnnWithL [b [L I]]$
1234: $String f,v; poly b,L; array of poly I;$
1235: $f is a polynomial given by a string. v is the variables.$
1236: $ v must not contain names s, e.$
1237: $b is the b-function (Bernstein-Sato polynomial) for f and$
1238: $ L is the operator satisfying L f^{s+1} = b(s) f^s $
1239: $ I is the annihilating ideal of f^s.$
1240: $cf. bfunction, annfs, genericAnn.$
1241: $Example 1: [(x^2+y^2) (x,y)] genericAnnWithL ::$
1242: $Example 2: [(x^2+y^2+z^2) (x,y,z)] genericAnnWithL ::$
1243: $Example 3: [(x^3-y^2 z^2) (x,y,z)] genericAnnWithL ::$
1244: ]] putUsages
1.2 takayama 1245:
1246: /reduction*.noH 0 def
1247: /reduction* {
1248: /arg1 set
1249: [/in-reduction* /aa /typev /setarg /f /v
1250: /gg /wv /termorder /vec /ans /rr /mm /h /size /a0 /a3
1.3 takayama 1251: /opt
1.2 takayama 1252: ] pushVariables
1253: [(CurrentRingp) (KanGBmessage)] pushEnv
1254: [
1255:
1256: /aa arg1 def
1257: aa isArray { } { ( << array >> reduction*) error } ifelse
1258: /setarg 0 def
1259: /wv 0 def
1260: aa { tag } map /typev set
1261: typev [StringP ArrayP ArrayP] eq
1262: typev [ArrayP ArrayP ArrayP] eq or
1263: typev [PolyP ArrayP ArrayP] eq or
1264: { /h aa 0 get def
1265: /f aa 1 get def
1266: /v aa 2 get from_records def
1267: /setarg 1 def
1268: } { } ifelse
1269: typev [StringP ArrayP ArrayP ArrayP] eq
1270: typev [ArrayP ArrayP ArrayP ArrayP] eq or
1271: typev [PolyP ArrayP ArrayP ArrayP] eq or
1272: { /h aa 0 get def
1273: /f aa 1 get def
1274: /v aa 2 get from_records def
1275: /wv aa 3 get def
1276: /setarg 1 def
1277: } { } ifelse
1278:
1279: setarg { } { (reduction* : Argument mismatch) error } ifelse
1280:
1281: [(KanGBmessage) gb.verbose ] system_variable
1282:
1283: %%% Start of the preprocess
1284: f getRing /rr set
1285:
1286:
1287: rr tag 0 eq {
1288: %% Define our own ring
1289: v isInteger {
1290: (Error in reduction*: Specify variables) error
1291: } { } ifelse
1292: wv isInteger {
1293: [v ring_of_differential_operators
1294: 0] define_ring
1295: /termorder 1 def
1296: }{
1297: [v ring_of_differential_operators
1298: wv weight_vector
1299: 0] define_ring
1300: wv gb.isTermOrder /termorder set
1301: } ifelse
1302: } {
1303: %% Use the ring structre given by the input.
1304: v isInteger not {
1.7 takayama 1305: gb.warning {
1306: (Warning : the given ring definition is not used.) message
1307: } { } ifelse
1.2 takayama 1308: } { } ifelse
1309: rr ring_def
1310: /wv rr gb.getWeight def
1311: wv gb.isTermOrder /termorder set
1312: } ifelse
1313: %%% Enf of the preprocess
1314:
1315: f 0 get isArray {
1316: /size f 0 get length def
1317: f { { toString . } map } map /f set
1318: f fromVectors /f set
1319: }{
1320: /size -1 def
1321: f { toString . } map /f set
1322: } ifelse
1323:
1324: h isArray {
1325: h { toString . } map /h set
1326: [h] fromVectors 0 get /h set
1327: }{
1328: h toString . /h set
1329: } ifelse
1330: f { toString . } map /f set
1.3 takayama 1331: getOptions /opt set
1332: [(ReduceLowerTerms) 1] system_variable
1.2 takayama 1333: reduction*.noH {
1334: h f reduction-noH /ans set
1335: } {
1336: h f reduction /ans set
1337: } ifelse
1.3 takayama 1338: opt restoreOptions
1.2 takayama 1339: size -1 eq not {
1340: [size ans 0 get] toVectors /a0 set
1341: [size ans 3 get] toVectors /a3 set
1342: /ans [a0 ans 1 get ans 2 get a3] def
1343: } { } ifelse
1344: /arg1 ans def
1345: ] pop
1346: popEnv
1347: popVariables
1348: arg1
1349: } def
1350:
1351:
1352: [(reduction*)
1353: [([f base v] reduction* [h c0 syz input])
1354: ([f base v weight] reduction* [h c0 syz input])
1355: (reduction* is an user interface for reduction and reduction-noH.)
1356: (If reduction*.noH is one, then reduction-noH will be called.)
1357: (Example 1: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)]] reduction* )
1358: (Example 2: [[(1) (y^2-1)] [ [(0) (y-1)] [(1) (y+1)]] [(x) (y)]] reduction*)
1359: (Example 3: [(x^2) [(x^2+y^2-4) (x y-1)] [(x) (y)] [[(x) 10]] ] reduction* )
1360: ]] putUsages
1.5 takayama 1361:
1362:
1363:
1364: %% 2000, 6/7, at Sevilla, Hernando Colon
1365: %% macros that deal with homogenized inputs.
1366: %% Sample: [ [(h+x). (x^3).] [(x). (x).]] /ff set
1367: %% [(Homogenize_vec) 0] system_varialbe
1368: %% (grade) (grave1v) switch_function
1369: %% YA homogenization: [ [(h^3*(h+x)). (x^3).] [(h x). (x).]] /ff set
1370: %% 4+0 3+1 2+0 1+1
1371: /gb_h {
1372: /arg1 set
1373: [/in-gb_h /aa /typev /setarg /f /v
1374: /gg /wv /termorder /vec /ans /rr /mm
1375: /gb_h.opt
1376: ] pushVariables
1377: [(CurrentRingp) (KanGBmessage) (Homogenize_vec)] pushEnv
1378: [
1379:
1380: /aa arg1 def
1.6 takayama 1381: gb.verbose { (Getting in gb_h) message } { } ifelse
1.5 takayama 1382: aa isArray { } { ( << array >> gb_h) error } ifelse
1383: /setarg 0 def
1384: /wv 0 def
1385: aa { tag } map /typev set
1386: typev [ ArrayP ] eq
1387: { /f aa 0 get def
1388: /v gb.v def
1389: /setarg 1 def
1390: } { } ifelse
1391: typev [ArrayP StringP] eq
1392: { /f aa 0 get def
1393: /v aa 1 get def
1394: /setarg 1 def
1395: } { } ifelse
1.10 takayama 1396: typev [ArrayP RingP] eq
1397: { /f aa 0 get def
1398: /v aa 1 get def
1399: /setarg 1 def
1400: } { } ifelse
1.5 takayama 1401: typev [ArrayP ArrayP] eq
1402: { /f aa 0 get def
1403: /v aa 1 get from_records def
1404: /setarg 1 def
1405: } { } ifelse
1406: typev [ArrayP StringP ArrayP] eq
1407: { /f aa 0 get def
1408: /v aa 1 get def
1409: /wv aa 2 get def
1410: /setarg 1 def
1411: } { } ifelse
1412: typev [ArrayP ArrayP ArrayP] eq
1413: { /f aa 0 get def
1414: /v aa 1 get from_records def
1415: /wv aa 2 get def
1416: /setarg 1 def
1417: } { } ifelse
1418:
1419: setarg { } { (gb_h : Argument mismatch) error } ifelse
1420:
1421: [(KanGBmessage) gb.verbose ] system_variable
1422:
1423: %%% Start of the preprocess
1.10 takayama 1424: v tag RingP eq {
1425: /rr v def
1426: }{
1427: f getRing /rr set
1428: } ifelse
1.5 takayama 1429: %% To the normal form : matrix expression.
1430: f gb.toMatrixOfString /f set
1431: /mm gb.itWasMatrix def
1432:
1433: rr tag 0 eq {
1434: %% Define our own ring
1435: v isInteger {
1436: (Error in gb_h: Specify variables) error
1437: } { } ifelse
1438: wv isInteger {
1439: [v ring_of_differential_operators
1440: 0] define_ring
1441: /termorder 1 def
1442: }{
1443: [v ring_of_differential_operators
1444: wv weight_vector
1445: 0] define_ring
1446: wv gb.isTermOrder /termorder set
1447: } ifelse
1448: } {
1449: %% Use the ring structre given by the input.
1450: v isInteger not {
1.7 takayama 1451: gb.warning {
1452: (Warning : the given ring definition is not used.) message
1453: } { } ifelse
1.5 takayama 1454: } { } ifelse
1455: rr ring_def
1456: /wv rr gb.getWeight def
1457: wv gb.isTermOrder /termorder set
1458: } ifelse
1459: getOptions /gb_h.opt set
1460: (grade) (module1v) switch_function
1.6 takayama 1461: [(Homogenize_vec) 0] system_variable
1.5 takayama 1462: %%% End of the preprocess
1463:
1464: gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1465: termorder {
1466: f { {. } map } map /f set
1467: [f gb.options] groebner 0 get /gg set %% Do not use sugar.
1468: }{
1469: f { {. } map} map /f set
1470: f fromVectors /f set
1471: [f gb.options] groebner 0 get /gg set
1472: }ifelse
1473: wv isInteger {
1474: /ans [gg gg {init} map] def
1475: }{
1476: /ans [gg gg {wv 0 get weightv init} map] def
1477: }ifelse
1478:
1479: %% Postprocess : recover the matrix expression.
1480: mm {
1481: ans { /tmp set [mm tmp] toVectors } map
1482: /ans set
1483: }{ }
1484: ifelse
1485: gb_h.opt restoreOptions
1.6 takayama 1486: gb.verbose { (Getting out of gb_h) message } { } ifelse
1.5 takayama 1487: %%
1488:
1489: /arg1 ans def
1490: ] pop
1491: popEnv
1492: popVariables
1493: arg1
1494: } def
1495: (gb_h ) messagen-quiet
1496: [(gb_h)
1497: [(a gb_h b)
1498: (array a; array b;)
1499: (b : [g ii]; array g; array in; g is a Grobner basis of f)
1500: ( in the ring of homogenized differential operators.)
1501: ( The input must be homogenized properly.)
1502: ( Inproper homogenization may cause an infinite loop.)
1503: ( Each element of vectors must be homogenized. If you are using )
1504: ( non-term orders, all elements of vectors must have the same degree with)
1505: ( a proper degree shift vector.)
1506: $ ii is the initial ideal in case of w is given or <<a>> belongs$
1507: $ to a ring. In the other cases, it returns the initial monominal.$
1508: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1509: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1510: (a : [f v]; array f; string v; v is the variables. )
1.10 takayama 1511: (a : [f r]; array f; ring r )
1.5 takayama 1512: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1513: ( )
1514: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1515: $ [ [ (Dx) 1 ] ] ] gb_h pmat ; $
1516: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] gb_h pmat $
1517: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1518: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1519: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1520: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1521: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1522: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1523: $ [ [ (x) -1 (y) -1] ] ] gb_h pmat ; $
1524: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1525: ( )
1526: (cf. gb, groebner, syz_h. )
1527: ]] putUsages
1528:
1529: /syz_h {
1530: /arg1 set
1531: [/in-syz_h /aa /typev /setarg /f /v
1532: /gg /wv /termorder /vec /ans /ggall /vectorInput /vsize /gtmp /gtmp2
1533: /rr /mm
1534: /syz_h.opt
1535: ] pushVariables
1536: [(CurrentRingp) (KanGBmessage)] pushEnv
1537: [
1538:
1539: /aa arg1 def
1540: aa isArray { } { (<< array >> syz_h) error } ifelse
1541: /setarg 0 def
1542: /wv 0 def
1543: aa { tag } map /typev set
1544: typev [ ArrayP ] eq
1545: { /f aa 0 get def
1546: /v syz.v def
1547: /setarg 1 def
1548: } { } ifelse
1549: typev [ArrayP StringP] eq
1550: { /f aa 0 get def
1551: /v aa 1 get def
1552: /setarg 1 def
1553: } { } ifelse
1.10 takayama 1554: typev [ArrayP RingP] eq
1555: { /f aa 0 get def
1556: /v aa 1 get def
1557: /setarg 1 def
1558: } { } ifelse
1.5 takayama 1559: typev [ArrayP ArrayP] eq
1560: { /f aa 0 get def
1561: /v aa 1 get from_records def
1562: /setarg 1 def
1563: } { } ifelse
1564: typev [ArrayP StringP ArrayP] eq
1565: { /f aa 0 get def
1566: /v aa 1 get def
1567: /wv aa 2 get def
1568: /setarg 1 def
1569: } { } ifelse
1570: typev [ArrayP ArrayP ArrayP] eq
1571: { /f aa 0 get def
1572: /v aa 1 get from_records def
1573: /wv aa 2 get def
1574: /setarg 1 def
1575: } { } ifelse
1576:
1577: setarg { } { (syz_h : Argument mismatch) error } ifelse
1578:
1579: [(KanGBmessage) syz.verbose ] system_variable
1580:
1581:
1582:
1583: %%% Start of the preprocess
1.10 takayama 1584: v tag RingP eq {
1585: /rr v def
1586: }{
1587: f getRing /rr set
1588: } ifelse
1.5 takayama 1589: %% To the normal form : matrix expression.
1590: f gb.toMatrixOfString /f set
1591: /mm gb.itWasMatrix def
1592: mm 0 gt {
1593: /vectorInput 1 def
1594: }{
1595: /vectorInput 1 def
1596: } ifelse
1597:
1598: rr tag 0 eq {
1599: %% Define our own ring
1600: v isInteger {
1601: (Error in syz_h: Specify variables) error
1602: } { } ifelse
1603: wv isInteger {
1604: [v ring_of_differential_operators
1605: 0] define_ring
1606: /termorder 1 def
1607: }{
1608: [v ring_of_differential_operators
1609: wv weight_vector
1610: 0] define_ring
1611: wv gb.isTermOrder /termorder set
1612: } ifelse
1613: }{
1614: %% Use the ring structre given by the input.
1615: v isInteger not {
1.7 takayama 1616: gb.warning {
1617: (Warning : the given ring definition is not used.) message
1618: } { } ifelse
1.5 takayama 1619: } { } ifelse
1620: rr ring_def
1621: /wv rr gb.getWeight def
1622: wv gb.isTermOrder /termorder set
1623: } ifelse
1624:
1625: getOptions /syz_h.opt set
1626: (grade) (module1v) switch_function
1627: [(Homogenize_vec) 0] system_variable
1628: %%% End of the preprocess
1629:
1630: termorder {
1631: f { {. } map } map /f set
1632: [f [(needBack) (needSyz)]] groebner /ggall set %% Do not use sugar.
1633: ggall 2 get /gg set
1634: }{
1635: f { {. } map } map /f set
1636: [f [(needBack) (needSyz)]] groebner /ggall set
1637: ggall 2 get /gg set
1638: }ifelse
1639: vectorInput {
1640: /vsize f 0 get length def %% input vector size.
1641: /gtmp ggall 0 get def
1642: [vsize gtmp] toVectors /gtmp set
1643: ggall 0 gtmp put
1644: }{ } ifelse
1645:
1646: syz_h.opt restoreOptions
1647: %%
1648:
1649: /arg1 [gg ggall] def
1650: ] pop
1651: popEnv
1652: popVariables
1653: arg1
1654: } def
1655: (syz_h ) messagen-quiet
1656:
1657: [(syz_h)
1658: [(a syz_h [b c])
1659: (array a; array b; array c)
1660: (b is a set of generators of the syzygies of f in the ring of)
1661: (homogenized differential operators.)
1662: ( The input must be homogenized properly.)
1663: ( Inproper homogenization may cause an infinite loop.)
1664: ( Each element of vectors must be homogenized. If you are using )
1665: ( non-term orders, all elements of vectors must have the same degree with)
1666: ( a proper degree shift vector.)
1667: (c = [gb, backward transformation, syzygy without dehomogenization].)
1668: (See gb_h.)
1669: $ [(Homogenize_vec) 0] system_variable (grade) (module1v) switch_function$
1670: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
1671: (a : [f v]; array f; string v; v is the variables.)
1.10 takayama 1672: (a : [f r]; array f; ring r )
1.5 takayama 1673: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
1674: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -h^4) ( x y Dx Dy -h^4)] (x,y) $
1675: $ [ [ (Dx) 1 ] ] ] syz_h pmat ; $
1676: $Example 2: [ [[(h+x) (x^3)] [(x) (x)]] (x)] syz_h pmat $
1677: $Example 3: [[ [(x^2) (y+x)] [(x+y) (y^3)] $
1678: $ [(2 x^2+x y) (y h^3 +x h^3 +x y^3)]] (x,y) $
1679: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1680: $ Infinite loop: see by [(DebugReductionRed) 1] system_variable$
1681: $Example 4: [[ [(x^2) (y+x)] [(x^2+y^2) (y)] $
1682: $ [(2 x^5+x y^4) (y h^3 +x h^3 +x y^3)]] (x,y) $
1683: $ [ [ (x) -1 (y) -1] ] ] syz_h pmat ; $
1684: $ This is fine because grade(v_1) = grade(v_2)+1 for all vectors. $
1685: $Example 5: [ [ [(0) (0)] [(0) (0)] [(x) (y)]] $
1686: $ [(x) (y)]] syz pmat ;$
1687: ]] putUsages
1688:
1689:
1690: /isSameIdeal {
1691: /arg1 set
1692: [/in-isSameIdeal /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f] pushVariables
1693: [(CurrentRingp)] pushEnv
1694: [
1695: /aa arg1 def
1696: %% comparison of hilbert series has not yet been implemented.
1697: aa length 3 eq { }
1698: { ([ii jj vv] isSameIdeal) error } ifelse
1.6 takayama 1699: gb.verbose { (Getting in isSameIdeal) message } { } ifelse
1.5 takayama 1700: /ii aa 0 get def
1701: /jj aa 1 get def
1702: /vv aa 2 get def
1703: ii length 0 eq jj length 0 eq and
1704: { /ans 1 def /LLL.isSame goto } { } ifelse
1705: [ii vv] gb /iigg set
1706: [jj vv] gb /jjgg set
1707:
1708: iigg getRing ring_def
1709:
1710: /ans 1 def
1711: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1712: /iigg set
1713: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1714: /jjgg set
1715:
1716: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1717: iigg length /n set
1718: 0 1 n 1 sub {
1719: /k set
1720: iigg k get
1721: jjgg reduction-noH 0 get
1722: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1723: gb.verbose { (o) messagen } { } ifelse
1724: } for
1725: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1726: jjgg length /n set
1727: 0 1 n 1 sub {
1728: /k set
1729: jjgg k get
1730: iigg reduction-noH 0 get
1731: (0). eq not { /ans 0 def /LLL.isSame goto} { } ifelse
1732: gb.verbose { (o) messagen } { } ifelse
1733: } for
1734: /LLL.isSame
1735: gb.verbose { ( Done) message } { } ifelse
1736: /arg1 ans def
1737: ] pop
1738: popEnv
1739: popVariables
1740: arg1
1741: } def
1742: (isSameIdeal ) messagen-quiet
1743:
1744: [(isSameIdeal)
1745: [([ii jj vv] isSameIdeal bool)
1746: (ii, jj : ideal, vv : variables)
1747: (Note that ii and jj will be dehomogenized and compared in the ring)
1748: (of differential operators. cf. isSameIdeal_h)
1749: $Example 1: [ [(x^3) (y^2)] [(x^2+y) (y)] (x,y)] isSameIdeal $
1750: $Example 2: [ [[(x^3) (0)] [(y^2) (1)]] $
1751: $ [[(x^3+y^2) (1)] [(y^2) (1)]] (x,y)] isSameIdeal $
1752: ]] putUsages
1753:
1754: /isSameIdeal_h {
1755: /arg1 set
1.6 takayama 1756: [/in-isSameIdeal_h /aa /ii /jj /iigg /jjgg /vv /ans /k /n /f
1757: /isSameIdeal_h.opt
1758: ] pushVariables
1759: [(CurrentRingp) (Homogenize_vec)] pushEnv
1.5 takayama 1760: [
1761: /aa arg1 def
1.6 takayama 1762: gb.verbose { (Getting in isSameIdeal_h) message } { } ifelse
1.5 takayama 1763: %% comparison of hilbert series has not yet been implemented.
1764: aa length 3 eq { }
1765: { ([ii jj vv] isSameIdeal_h) error } ifelse
1766: /ii aa 0 get def
1767: /jj aa 1 get def
1768: /vv aa 2 get def
1769: ii length 0 eq jj length 0 eq and
1770: { /ans 1 def /LLL.isSame_h goto } { } ifelse
1771:
1772: [ii vv] gb_h /iigg set
1773: [jj vv] gb_h /jjgg set
1774:
1775: iigg getRing ring_def
1776:
1.6 takayama 1777: getOptions /isSameIdeal_h.opt set
1778: (grade) (module1v) switch_function
1779: [(Homogenize_vec) 0] system_variable
1.5 takayama 1780: /ans 1 def
1781: iigg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1782: /iigg set
1783: jjgg 0 get { [ (toe_) 3 -1 roll ] gbext } map
1784: /jjgg set
1785:
1.8 takayama 1786: gb.verbose { (Comparing) message iigg message (and) message jjgg message }
1787: { } ifelse
1.5 takayama 1788: gb.verbose { ( ii < jj ?) messagen } { } ifelse
1789: iigg length /n set
1790: 0 1 n 1 sub {
1791: /k set
1792: iigg k get
1793: jjgg reduction 0 get
1794: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1795: gb.verbose { (o) messagen } { } ifelse
1796: } for
1797: gb.verbose { ( jj < ii ?) messagen } { } ifelse
1798: jjgg length /n set
1799: 0 1 n 1 sub {
1800: /k set
1801: jjgg k get
1802: iigg reduction 0 get
1803: (0). eq not { /ans 0 def /LLL.isSame_h goto} { } ifelse
1804: gb.verbose { (o) messagen } { } ifelse
1805: } for
1806: /LLL.isSame_h
1807: gb.verbose { ( Done) message } { } ifelse
1.6 takayama 1808: isSameIdeal_h.opt restoreOptions
1.5 takayama 1809: /arg1 ans def
1810: ] pop
1811: popEnv
1812: popVariables
1813: arg1
1814: } def
1815: (isSameIdeal_h ) messagen-quiet
1816:
1817: [(isSameIdeal_h)
1818: [([ii jj vv] isSameIdeal_h bool)
1819: (ii, jj : ideal, vv : variables)
1820: (Note that ii and jj will be compared in the ring)
1821: (of homogenized differential operators. Each element of the vector must be)
1822: (homogenized.)
1823: $Example 1: [ [(x Dx - h^2) (Dx^2)] [(Dx^3) (x Dx-h^2)] (x)] isSameIdeal_h $
1824: $Example 2: [ [[(x Dx -h^2) (0)] [(Dx^2) (1)]] $
1825: $ [[(x Dx -h^2) (0)] [(Dx^2) (1)] [(Dx^3) (Dx)]] (x,y)] isSameIdeal_h $
1826: ]] putUsages
1827:
1.15 takayama 1828: /gb.reduction {
1829: /arg2 set
1830: /arg1 set
1831: [/in-gb.reduction /gbasis /flist /ans /gbasis2
1832: ] pushVariables
1833: [(CurrentRingp) (KanGBmessage)] pushEnv
1834: [
1835: /gbasis arg2 def
1836: /flist arg1 def
1837: gbasis 0 get tag 6 eq { }
1838: { (gb.reduction: the second argument must be a list of lists) error }
1839: ifelse
1840:
1841: gbasis length 1 eq {
1842: gbasis getRing ring_def
1843: /gbasis2 gbasis 0 get def
1844: } {
1845: [ [(1)] ] gbasis rest join gb 0 get getRing ring_def
1846: /gbasis2 gbasis 0 get ,,, def
1847: } ifelse
1848:
1.5 takayama 1849:
1.15 takayama 1850: flist ,,, /flist set
1851: flist tag 6 eq {
1852: flist { gbasis2 reduction } map /ans set
1853: }{
1854: flist gbasis2 reduction /ans set
1855: } ifelse
1856: /arg1 ans def
1857:
1858: ] pop
1859: popEnv
1860: popVariables
1861: arg1
1862: } def
1863:
1864: /gb.reduction.test {
1865: [
1866: [( 2*(1-x-y) Dx + 1 ) ( 2*(1-x-y) Dy + 1 )]
1867: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]]
1868: gb /gg set
1869:
1870: ((h-x-y)*Dx) [gg 0 get] gb.reduction /gg2 set
1871: gg2 message
1872: (-----------------------------) message
1873:
1874: [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )]
1875: (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set
1876: ((h-x-y)*Dx) ggg gb.reduction /gg4 set
1877: gg4 message
1878: (-----------------------------) message
1879: [gg2 gg4]
1880: } def
1881: [(gb.reduction)
1882: [ (f basis gb.reduction r)
1883: (f is reduced by basis by the normal form algorithm.)
1884: (The first element of basis <g_1,...,g_m> must be a Grobner basis.)
1885: (r is the return value format of reduction;)
1886: (r=[h,c0,syz,input], h = c0 f + \sum syz_i g_i)
1887: (basis is given in the argument format of gb.)
1.16 takayama 1888: $h[1,1](D)-homogenization is used.$
1.15 takayama 1889: (cf. reduction, gb, ecartd.gb, gb.reduction.test )
1890: $Example:$
1891: $ [[( 2*(h-x-y) Dx + h^2 ) ( 2*(h-x-y) Dy + h^2 )] $
1892: $ (x,y) [[(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]]] /ggg set $
1893: $ ((h-x-y)^2*Dx*Dy) ggg gb.reduction :: $
1894: ]] putUsages
1.1 maekawa 1895:
1896: ( ) message-quiet ;
1897:
1898:
1899:
1900:
1901:
1902:
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