Annotation of OpenXM/src/kan96xx/Doc/ecart.sm1, Revision 1.7
1.7 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.6 2003/08/13 03:52:25 takayama Exp $
1.1 takayama 2: %[(parse) (hol.sm1) pushfile] extension
3: %[(parse) (appell.sm1) pushfile] extension
4:
5: (ecart.sm1 : ecart division for D, 2003/07/25 ) message-quiet
6: /ecart.begin { beginEcart } def
7: /ecart.end { endEcart } def
8: /ecart.autoHomogenize 1 def
9: /ecart.needSyz 0 def
10:
11: /ecart.dehomogenize {
12: /arg1 set
13: [/in.ecart.dehomogenize /ll /rr] pushVariables
14: [
15: /ll arg1 def
16: ll tag 6 eq {
17: ll { ecart.dehomogenize } map /ll set
18: } {
19: ll (0). eq {
20: } {
21: ll getRing /rr set
22: ll [ [ (H) rr ,, (1) rr ,, ]
23: [ (h) rr ,, (1) rr ,, ]] replace
24: /ll set
25: } ifelse
26: } ifelse
27: /arg1 ll def
28: ] pop
29: popVariables
30: arg1
31: } def
32: [(ecart.dehomogenize)
33: [(obj ecart.dehomogenize r)
34: (h->1, H->1)
35: ]] putUsages
36:
37: /ecart.dehomogenizeH {
38: /arg1 set
39: [/in.ecart.dehomogenize /ll /rr] pushVariables
40: [
41: /ll arg1 def
42: ll tag 6 eq {
43: ll { ecart.dehomogenize } map /ll set
44: } {
45: ll (0). eq {
46: } {
47: ll getRing /rr set
48: ll [ [ (H) rr ,, (1) rr ,, ] ] replace
49: /ll set
50: } ifelse
51: } ifelse
52: /arg1 ll def
53: ] pop
54: popVariables
55: arg1
56: } def
57: [(ecart.dehomogenizeH)
58: [(obj ecart.dehomogenizeH r)
59: (H->1, h is not changed.)
60: ]] putUsages
61:
62: /ecart.homogenize01 {
63: /arg1 set
64: [/in.ecart.homogenize01 /ll ] pushVariables
65: [
66: /ll arg1 def
67: [(degreeShift) [ ] ll ] homogenize
68: /arg1 set
69: ] pop
70: popVariables
71: arg1
72: } def
73: [(ecart.homogenize01)
74: [(obj ecart.homogenize01 r)
75: (Example: )
76: ( [(x1,x2) ring_of_differential_operators )
77: ( [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
78: ( [(h) 1 (Dx1) 1 (Dx2) 1] )
79: ( [(Dx1) 1 (Dx2) 1] )
80: ( [(x1) -1 (x2) -1])
81: ( ] weight_vector )
82: ( 0 )
83: ( [(degreeShift) [[0 0 0]]])
84: ( ] define_ring)
85: ( ecart.begin)
86: ( [[1 -4 -2 5]] appell4 0 get /eqs set)
87: ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
88: ( ecart.homogenize01 /eqs2 set)
89: ( [eqs2] groebner )
90: ]] putUsages
91:
92: /ecart.homogenize01_with_shiftVector {
93: /arg2.set
94: /arg1 set
95: [/in.ecart.homogenize01 /ll /sv] pushVariables
96: [
97: /sv arg2 def
98: /ll arg1 def
99: [(degreeShift) sv ll ] homogenize
100: /arg1 set
101: ] pop
102: popVariables
103: arg1
104: } def
105: [(ecart.dehomogenize01_with_degreeShift)
106: [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
107: ]] putUsages
108:
109: %% Aux functions to return the default weight vectors.
110: /ecart.wv1 {
111: /arg1 set
112: [/in.ecart.wv1 /v] pushVariables
113: [
114: /v arg1 def
115: [(H) (h) v to_records pop] /v set
116: v { 1 } map /v set
117: /arg1 v def
118: ] pop
119: popVariables
120: arg1
121: } def
122: /ecart.wv2 {
123: /arg1 set
124: [/in.ecart.wv2 /v] pushVariables
125: [
126: /v arg1 def
127: [v to_records pop] /v set
128: v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
129: [(h) 1 ] v join /v set
130: /arg1 v def
131: ] pop
132: popVariables
133: arg1
134: } def
135:
1.7 ! takayama 136: /ecart.gb {ecartd.gb} def
! 137:
! 138: [(ecart.gb)
! 139: [(a ecart.gb b)
! 140: (array a; array b;)
! 141: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
! 142: ( in the ring of differential operators.)
! 143: (The computation is done by using Ecart division algorithm and )
! 144: (the double homogenization.)
! 145: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
! 146: $ ii is the initial ideal in case of w is given or <<a>> belongs$
! 147: $ to a ring. In the other cases, it returns the initial monominal.$
! 148: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
! 149: (a : [f v]; array f; string v; v is the variables. )
! 150: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
! 151: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
! 152: ( array ds; ds is the degree shift )
! 153: ( )
! 154: $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize) $
! 155: ( )
! 156: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
! 157: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
! 158: (Example 2: )
! 159: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
! 160: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb pmat ;$
! 161: ( )
! 162: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
! 163: $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
! 164: ( )
! 165: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
! 166: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
! 167: ( )
! 168: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
! 169: $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecart.gb pmat ; $
! 170: ( )
! 171: (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
! 172: ( ecart.dehomogenize, ecart.dehomogenizeH)
! 173: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
! 174: ( define_ring )
! 175: (/ecart.autoHomogenize 0 def )
! 176: ( not to dehomogenize and homogenize)
! 177: ]] putUsages
! 178:
1.1 takayama 179: /ecart.gb.verbose 1 def
1.7 ! takayama 180: /ecarth.gb {
1.1 takayama 181: /arg1 set
1.7 ! takayama 182: [/in-ecarth.gb /aa /typev /setarg /f /v
1.1 takayama 183: /gg /wv /vec /ans /rr /mm
184: /degreeShift /env2 /opt /ans.gb
185: ] pushVariables
186: [(CurrentRingp) (KanGBmessage)] pushEnv
187: [
188: /aa arg1 def
189: aa isArray { } { ( << array >> gb) error } ifelse
190: /setarg 0 def
191: /wv 0 def
192: /degreeShift 0 def
193: /opt [(weightedHomogenization) 1] def
194: aa { tag } map /typev set
195: typev [ ArrayP ] eq
196: { /f aa 0 get def
197: /v gb.v def
198: /setarg 1 def
199: } { } ifelse
200: typev [ArrayP StringP] eq
201: { /f aa 0 get def
202: /v aa 1 get def
203: /setarg 1 def
204: } { } ifelse
205: typev [ArrayP RingP] eq
206: { /f aa 0 get def
207: /v aa 1 get def
208: /setarg 1 def
209: } { } ifelse
210: typev [ArrayP ArrayP] eq
211: { /f aa 0 get def
212: /v aa 1 get from_records def
213: /setarg 1 def
214: } { } ifelse
215: typev [ArrayP StringP ArrayP] eq
216: { /f aa 0 get def
217: /v aa 1 get def
218: /wv aa 2 get def
219: /setarg 1 def
220: } { } ifelse
221: typev [ArrayP ArrayP ArrayP] eq
222: { /f aa 0 get def
223: /v aa 1 get from_records def
224: /wv aa 2 get def
225: /setarg 1 def
226: } { } ifelse
227: typev [ArrayP StringP ArrayP ArrayP] eq
228: { /f aa 0 get def
229: /v aa 1 get def
230: /wv aa 2 get def
231: /degreeShift aa 3 get def
232: /setarg 1 def
233: } { } ifelse
234: typev [ArrayP ArrayP ArrayP ArrayP] eq
235: { /f aa 0 get def
236: /v aa 1 get from_records def
237: /wv aa 2 get def
238: /degreeShift aa 3 get def
239: /setarg 1 def
240: } { } ifelse
241:
242: /env1 getOptions def
243:
244: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
245:
246: [(KanGBmessage) ecart.gb.verbose ] system_variable
247:
248: %%% Start of the preprocess
249: v tag RingP eq {
250: /rr v def
251: }{
252: f getRing /rr set
253: } ifelse
254: %% To the normal form : matrix expression.
255: f gb.toMatrixOfString /f set
256: /mm gb.itWasMatrix def
257:
258: rr tag 0 eq {
259: %% Define our own ring
260: v isInteger {
261: (Error in gb: Specify variables) error
262: } { } ifelse
263: wv isInteger {
264: [v ring_of_differential_operators
1.6 takayama 265: % [ v ecart.wv1 v ecart.wv2 ] weight_vector
1.3 takayama 266: gb.characteristic
1.1 takayama 267: opt
268: ] define_ring
269: }{
270: degreeShift isInteger {
271: [v ring_of_differential_operators
1.6 takayama 272: % [v ecart.wv1 v ecart.wv2] wv join weight_vector
273: wv weight_vector
1.3 takayama 274: gb.characteristic
1.1 takayama 275: opt
276: ] define_ring
277:
278: }{
279: [v ring_of_differential_operators
1.6 takayama 280: % [v ecart.wv1 v ecart.wv2] wv join weight_vector
281: wv weight_vector
1.3 takayama 282: gb.characteristic
1.1 takayama 283: [(degreeShift) degreeShift] opt join
284: ] define_ring
285:
286: } ifelse
287: } ifelse
288: } {
289: %% Use the ring structre given by the input.
290: v isInteger not {
291: gb.warning {
292: (Warning : the given ring definition is not used.) message
293: } { } ifelse
294: } { } ifelse
295: rr ring_def
296: /wv rr gb.getWeight def
297:
298: } ifelse
299: %%% Enf of the preprocess
300:
301: ecart.gb.verbose {
1.6 takayama 302: (The first and the second weight vectors for automatic homogenization: )
1.1 takayama 303: message
304: v ecart.wv1 message
305: v ecart.wv2 message
306: degreeShift isInteger { }
307: {
308: (The degree shift is ) messagen
309: degreeShift message
310: } ifelse
311: } { } ifelse
312:
1.5 takayama 313: %%BUG: case of v is integer
314: v ecart.checkOrder
315:
1.1 takayama 316: ecart.begin
317:
318: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
319: ecart.autoHomogenize {
320: (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
321: message
322: } { } ifelse
323: ecart.autoHomogenize {
324: f { {. ecart.dehomogenize} map} map /f set
325: f ecart.homogenize01 /f set
326: }{
327: f { {. } map } map /f set
328: } ifelse
329: ecart.needSyz {
330: [f [(needSyz)] gb.options join ] groebner /gg set
331: } {
332: [f gb.options] groebner 0 get /gg set
333: } ifelse
334:
335: ecart.needSyz {
336: mm {
337: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
338: } { /ans.gb gg 0 get def } ifelse
339: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
340: ans pmat ;
341: } {
342: wv isInteger {
343: /ans [gg gg {init} map] def
344: }{
345: /ans [gg gg {wv 0 get weightv init} map] def
346: }ifelse
347:
348: %% Postprocess : recover the matrix expression.
349: mm {
350: ans { /tmp set [mm tmp] toVectors } map
351: /ans set
352: }{ }
353: ifelse
354: } ifelse
355:
356: ecart.end
357:
358: %%
359: env1 restoreOptions %% degreeShift changes "grade"
360:
361: /arg1 ans def
362: ] pop
363: popEnv
364: popVariables
365: arg1
366: } def
1.7 ! takayama 367: (ecarth.gb ) messagen-quiet
1.1 takayama 368:
1.7 ! takayama 369: [(ecarth.gb)
! 370: [(a ecarth.gb b)
1.1 takayama 371: (array a; array b;)
372: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
373: ( in the ring of differential operators.)
374: (The computation is done by using Ecart division algorithm and )
375: (the double homogenization.)
376: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
377: $ ii is the initial ideal in case of w is given or <<a>> belongs$
378: $ to a ring. In the other cases, it returns the initial monominal.$
379: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
380: (a : [f v]; array f; string v; v is the variables. )
381: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
382: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
383: ( array ds; ds is the degree shift )
384: ( )
385: (/ecart.autoHomogenize 0 def )
386: ( not to dehomogenize and homogenize)
387: ( )
388: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 ! takayama 389: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 390: (Example 2: )
391: (To put H and h=1, type in, e.g., )
392: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.7 ! takayama 393: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
1.1 takayama 394: ( )
395: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 ! takayama 396: $ [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
1.1 takayama 397: ( )
398: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.7 ! takayama 399: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 400: ( )
401: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.7 ! takayama 402: $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecarth.gb pmat ; (buggy infinite loop)$
1.1 takayama 403: ( )
1.7 ! takayama 404: (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
1.1 takayama 405: ( ecart.dehomogenize, ecart.dehomogenizeH)
406: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
407: ( define_ring )
408: ]] putUsages
409:
410: %% BUG: " f weight init " works well in case of vectors with degree shift ?
411:
412: /ecart.syz {
413: /arg1 set
414: [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
415: [
416: /ff arg1 def
417: /ecart.save.needSyz ecart.needSyz def
418: /ecart.needSyz 1 def
419: ff ecart.gb /ff.ans set
420: /ecart.needSyz ecart.save.needSyz def
421: /arg1 ff.ans def
422: ] pop
423: popVariables
424: arg1
425: } def
426: (ecart.syz ) messagen-quiet
427:
428: [(ecart.syz)
429: [(a ecart.syz b)
430: (array a; array b;)
431: $b : [syzygy gb tmat input]; gb = tmat * input $
432: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
433: $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.syz /ff set $
434: $ ff 0 get ff 3 get mul pmat $
435: $ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $
436: ( )
437: $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
438: $ [ [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $
439: ( )
440: (cf. ecart.gb)
441: ( /ecart.autoHomogenize 0 def )
442: ]] putUsages
1.2 takayama 443:
1.3 takayama 444:
445: /ecartn.begin {
446: (red@) (standard) switch_function
447: %% (red@) (ecart) switch_function
448: [(Ecart) 1] system_variable
449: [(CheckHomogenization) 0] system_variable
450: [(ReduceLowerTerms) 0] system_variable
451: [(AutoReduce) 0] system_variable
452: [(EcartAutomaticHomogenization) 0] system_variable
453: } def
454: /ecartn.gb {
455: /arg1 set
456: [/in-ecartn.gb /aa /typev /setarg /f /v
457: /gg /wv /vec /ans /rr /mm
458: /degreeShift /env2 /opt /ans.gb
459: ] pushVariables
460: [(CurrentRingp) (KanGBmessage)] pushEnv
461: [
462: /aa arg1 def
463: aa isArray { } { ( << array >> gb) error } ifelse
464: /setarg 0 def
465: /wv 0 def
466: /degreeShift 0 def
467: /opt [(weightedHomogenization) 1] def
468: aa { tag } map /typev set
469: typev [ ArrayP ] eq
470: { /f aa 0 get def
471: /v gb.v def
472: /setarg 1 def
473: } { } ifelse
474: typev [ArrayP StringP] eq
475: { /f aa 0 get def
476: /v aa 1 get def
477: /setarg 1 def
478: } { } ifelse
479: typev [ArrayP RingP] eq
480: { /f aa 0 get def
481: /v aa 1 get def
482: /setarg 1 def
483: } { } ifelse
484: typev [ArrayP ArrayP] eq
485: { /f aa 0 get def
486: /v aa 1 get from_records def
487: /setarg 1 def
488: } { } ifelse
489: typev [ArrayP StringP ArrayP] eq
490: { /f aa 0 get def
491: /v aa 1 get def
492: /wv aa 2 get def
493: /setarg 1 def
494: } { } ifelse
495: typev [ArrayP ArrayP ArrayP] eq
496: { /f aa 0 get def
497: /v aa 1 get from_records def
498: /wv aa 2 get def
499: /setarg 1 def
500: } { } ifelse
501: typev [ArrayP StringP ArrayP ArrayP] eq
502: { /f aa 0 get def
503: /v aa 1 get def
504: /wv aa 2 get def
505: /degreeShift aa 3 get def
506: /setarg 1 def
507: } { } ifelse
508: typev [ArrayP ArrayP ArrayP ArrayP] eq
509: { /f aa 0 get def
510: /v aa 1 get from_records def
511: /wv aa 2 get def
512: /degreeShift aa 3 get def
513: /setarg 1 def
514: } { } ifelse
515:
516: /env1 getOptions def
517:
518: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
519:
520: [(KanGBmessage) ecart.gb.verbose ] system_variable
521:
522: %%% Start of the preprocess
523: v tag RingP eq {
524: /rr v def
525: }{
526: f getRing /rr set
527: } ifelse
528: %% To the normal form : matrix expression.
529: f gb.toMatrixOfString /f set
530: /mm gb.itWasMatrix def
531:
532: rr tag 0 eq {
533: %% Define our own ring
534: v isInteger {
535: (Error in gb: Specify variables) error
536: } { } ifelse
537: wv isInteger {
538: [v ring_of_differential_operators
539: [ v ecart.wv1 v ecart.wv2 ] weight_vector
540: gb.characteristic
541: opt
542: ] define_ring
543: }{
544: degreeShift isInteger {
545: [v ring_of_differential_operators
546: [v ecart.wv1 v ecart.wv2] wv join weight_vector
547: gb.characteristic
548: opt
549: ] define_ring
550:
551: }{
552: [v ring_of_differential_operators
553: [v ecart.wv1 v ecart.wv2] wv join weight_vector
554: gb.characteristic
555: [(degreeShift) degreeShift] opt join
556: ] define_ring
557:
558: } ifelse
559: } ifelse
560: } {
561: %% Use the ring structre given by the input.
562: v isInteger not {
563: gb.warning {
564: (Warning : the given ring definition is not used.) message
565: } { } ifelse
566: } { } ifelse
567: rr ring_def
568: /wv rr gb.getWeight def
569:
570: } ifelse
571: %%% Enf of the preprocess
572:
573: ecart.gb.verbose {
574: (The first and the second weight vectors are automatically set as follows)
575: message
576: v ecart.wv1 message
577: v ecart.wv2 message
578: degreeShift isInteger { }
579: {
580: (The degree shift is ) messagen
581: degreeShift message
582: } ifelse
583: } { } ifelse
584:
1.5 takayama 585: %%BUG: case of v is integer
586: v ecart.checkOrder
587:
1.3 takayama 588: ecartn.begin
589:
590: ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
591: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
592: ecart.autoHomogenize {
593: (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
594: message
595: } { } ifelse
596: ecart.autoHomogenize {
597: f { {. ecart.dehomogenize} map} map /f set
598: f ecart.homogenize01 /f set
599: }{
600: f { {. } map } map /f set
601: } ifelse
602: ecart.needSyz {
603: [f [(needSyz)] gb.options join ] groebner /gg set
604: } {
605: [f gb.options] groebner 0 get /gg set
606: } ifelse
607:
608: ecart.needSyz {
609: mm {
610: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
611: } { /ans.gb gg 0 get def } ifelse
612: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
613: ans pmat ;
614: } {
615: wv isInteger {
616: /ans [gg gg {init} map] def
617: }{
618: /ans [gg gg {wv 0 get weightv init} map] def
619: }ifelse
620:
621: %% Postprocess : recover the matrix expression.
622: mm {
623: ans { /tmp set [mm tmp] toVectors } map
624: /ans set
625: }{ }
626: ifelse
627: } ifelse
628:
629: ecart.end
630:
631: %%
632: env1 restoreOptions %% degreeShift changes "grade"
633:
634: /arg1 ans def
635: ] pop
636: popEnv
637: popVariables
638: arg1
639: } def
640: (ecartn.gb[gb by non-ecart division] ) messagen-quiet
1.4 takayama 641:
642: /ecartd.gb {
643: /arg1 set
644: [/in-ecart.gb /aa /typev /setarg /f /v
645: /gg /wv /vec /ans /rr /mm
646: /degreeShift /env2 /opt /ans.gb
647: ] pushVariables
648: [(CurrentRingp) (KanGBmessage)] pushEnv
649: [
650: /aa arg1 def
651: aa isArray { } { ( << array >> gb) error } ifelse
652: /setarg 0 def
653: /wv 0 def
654: /degreeShift 0 def
655: /opt [(weightedHomogenization) 1] def
656: aa { tag } map /typev set
657: typev [ ArrayP ] eq
658: { /f aa 0 get def
659: /v gb.v def
660: /setarg 1 def
661: } { } ifelse
662: typev [ArrayP StringP] eq
663: { /f aa 0 get def
664: /v aa 1 get def
665: /setarg 1 def
666: } { } ifelse
667: typev [ArrayP RingP] eq
668: { /f aa 0 get def
669: /v aa 1 get def
670: /setarg 1 def
671: } { } ifelse
672: typev [ArrayP ArrayP] eq
673: { /f aa 0 get def
674: /v aa 1 get from_records def
675: /setarg 1 def
676: } { } ifelse
677: typev [ArrayP StringP ArrayP] eq
678: { /f aa 0 get def
679: /v aa 1 get def
680: /wv aa 2 get def
681: /setarg 1 def
682: } { } ifelse
683: typev [ArrayP ArrayP ArrayP] eq
684: { /f aa 0 get def
685: /v aa 1 get from_records def
686: /wv aa 2 get def
687: /setarg 1 def
688: } { } ifelse
689: typev [ArrayP StringP ArrayP ArrayP] eq
690: { /f aa 0 get def
691: /v aa 1 get def
692: /wv aa 2 get def
693: /degreeShift aa 3 get def
694: /setarg 1 def
695: } { } ifelse
696: typev [ArrayP ArrayP ArrayP ArrayP] eq
697: { /f aa 0 get def
698: /v aa 1 get from_records def
699: /wv aa 2 get def
700: /degreeShift aa 3 get def
701: /setarg 1 def
702: } { } ifelse
703:
704: /env1 getOptions def
705:
706: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
707:
708: [(KanGBmessage) ecart.gb.verbose ] system_variable
709: $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message
710:
711: %%% Start of the preprocess
712: v tag RingP eq {
713: /rr v def
714: }{
715: f getRing /rr set
716: } ifelse
717: %% To the normal form : matrix expression.
718: f gb.toMatrixOfString /f set
719: /mm gb.itWasMatrix def
720:
721: rr tag 0 eq {
722: %% Define our own ring
723: v isInteger {
724: (Error in gb: Specify variables) error
725: } { } ifelse
726: wv isInteger {
727: (Give an weight vector such that x < 1) error
728: }{
729: degreeShift isInteger {
730: [v ring_of_differential_operators
731: wv weight_vector
732: gb.characteristic
733: opt
734: ] define_ring
735:
736: }{
737: [v ring_of_differential_operators
738: wv weight_vector
739: gb.characteristic
740: [(degreeShift) degreeShift] opt join
741: ] define_ring
742:
743: } ifelse
744: } ifelse
745: } {
746: %% Use the ring structre given by the input.
747: v isInteger not {
748: gb.warning {
749: (Warning : the given ring definition is not used.) message
750: } { } ifelse
751: } { } ifelse
752: rr ring_def
753: /wv rr gb.getWeight def
754:
755: } ifelse
756: %%% Enf of the preprocess
757:
758: ecart.gb.verbose {
759: degreeShift isInteger { }
760: {
761: (The degree shift is ) messagen
762: degreeShift message
763: } ifelse
764: } { } ifelse
765:
1.5 takayama 766: %%BUG: case of v is integer
767: v ecart.checkOrder
768:
1.4 takayama 769: ecart.begin
770: [(EcartAutomaticHomogenization) 1] system_variable
771:
772: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
773:
774: f { {. ecart.dehomogenize} map} map /f set
775: f ecart.homogenize01 /f set
776: f { { [[(H). (1).]] replace } map } map /f set
777:
778: ecart.needSyz {
779: [f [(needSyz)] gb.options join ] groebner /gg set
780: } {
781: [f gb.options] groebner 0 get /gg set
782: } ifelse
783:
784: ecart.needSyz {
785: mm {
786: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
787: } { /ans.gb gg 0 get def } ifelse
788: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
789: ans pmat ;
790: } {
791: wv isInteger {
792: /ans [gg gg {init} map] def
793: }{
794: /ans [gg gg {wv 0 get weightv init} map] def
795: }ifelse
796:
797: %% Postprocess : recover the matrix expression.
798: mm {
799: ans { /tmp set [mm tmp] toVectors } map
800: /ans set
801: }{ }
802: ifelse
803: } ifelse
804:
805: ecart.end
806: [(EcartAutomaticHomogenization) 0] system_variable
807:
808: %%
809: env1 restoreOptions %% degreeShift changes "grade"
810:
811: /arg1 ans def
812: ] pop
813: popEnv
814: popVariables
815: arg1
816: } def
817: (ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
1.2 takayama 818:
1.5 takayama 819: /ecart.checkOrder {
820: /arg1 set
821: [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
822: [
823: /vv arg1 def
824: vv isArray
825: { } { [vv to_records pop] /vv set } ifelse
826: vv {toString} map /vv set
827: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
828: % Starting the checks.
829: 0 1 vv length 1 sub {
830: /i set
831: vv i get . dd i get . mul /tt set
832: tt @@@.hsymbol . add init tt eq { }
833: { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
834: } for
835:
836: 0 1 vv length 1 sub {
837: /i set
838: vv i get . /tt set
839: tt (1). add init (1). eq { }
1.6 takayama 840: { [vv i get ( is larger than 1 ) ] cat error} ifelse
1.5 takayama 841: } for
842: /arg1 1 def
843: ] pop
844: popVariables
845: arg1
846: } def
847: [(ecart.checkOrder)
848: [(v ecart.checkOrder bool checks if the given order is relevant)
849: (for the ecart division.)
850: (cf. ecartd.gb, ecart.gb, ecartn.gb)
851: ]
852: ] putUsages
853:
854: /ecart.wv_last {
855: /arg1 set
856: [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
857: [
858: /vv arg1 def
859: vv isArray
860: { } { [vv to_records pop] /vv set } ifelse
861: vv {toString} map /vv set
862: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
863: vv { -1 } map
864: dd { 1 } map join /arg1 set
865: ] pop
866: popVariables
867: arg1
868: } def
869: [(ecart.wv_last)
870: [(v ecart.wv_last wt )
871: (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
872: (Use this weight vector as the last weight vector for ecart division)
873: (if ecart.checkOrder complains about the order given.)
874: ]
875: ] putUsages
876:
1.2 takayama 877: ( ) message-quiet
1.5 takayama 878:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to ecart.sm1 CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / kan96xx / Doc