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