Annotation of OpenXM/src/kan96xx/Doc/ecart.sm1, Revision 1.14
1.14 ! takayama 1: % $OpenXM: OpenXM/src/kan96xx/Doc/ecart.sm1,v 1.13 2003/08/26 12:46:03 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
1.8 takayama 10: /ecartd.begin {
11: ecart.begin
12: [(EcartAutomaticHomogenization) 1] system_variable
13: } def
14: /ecartd.end {
15: ecart.end
16: [(EcartAutomaticHomogenization) 0] system_variable
17: } def
1.1 takayama 18:
19: /ecart.dehomogenize {
20: /arg1 set
21: [/in.ecart.dehomogenize /ll /rr] pushVariables
22: [
23: /ll arg1 def
24: ll tag 6 eq {
25: ll { ecart.dehomogenize } map /ll set
26: } {
27: ll (0). eq {
28: } {
29: ll getRing /rr set
30: ll [ [ (H) rr ,, (1) rr ,, ]
31: [ (h) rr ,, (1) rr ,, ]] replace
32: /ll set
33: } ifelse
34: } ifelse
35: /arg1 ll def
36: ] pop
37: popVariables
38: arg1
39: } def
40: [(ecart.dehomogenize)
41: [(obj ecart.dehomogenize r)
42: (h->1, H->1)
43: ]] putUsages
44:
45: /ecart.dehomogenizeH {
46: /arg1 set
47: [/in.ecart.dehomogenize /ll /rr] pushVariables
48: [
49: /ll arg1 def
50: ll tag 6 eq {
51: ll { ecart.dehomogenize } map /ll set
52: } {
53: ll (0). eq {
54: } {
55: ll getRing /rr set
56: ll [ [ (H) rr ,, (1) rr ,, ] ] replace
57: /ll set
58: } ifelse
59: } ifelse
60: /arg1 ll def
61: ] pop
62: popVariables
63: arg1
64: } def
65: [(ecart.dehomogenizeH)
66: [(obj ecart.dehomogenizeH r)
67: (H->1, h is not changed.)
68: ]] putUsages
69:
70: /ecart.homogenize01 {
71: /arg1 set
1.11 takayama 72: [/in.ecart.homogenize01 /ll /ll0] pushVariables
1.1 takayama 73: [
74: /ll arg1 def
1.11 takayama 75: ll tag ArrayP eq {
76: ll 0 get tag ArrayP eq not {
77: [(degreeShift) [ ] ll ] homogenize /arg1 set
78: } {
79: ll { ecart.homogenize01 } map /arg1 set
80: } ifelse
81: } {
82: [(degreeShift) [ ] ll ] homogenize /arg1 set
1.12 takayama 83: } ifelse
1.1 takayama 84: ] pop
85: popVariables
86: arg1
87: } def
88: [(ecart.homogenize01)
89: [(obj ecart.homogenize01 r)
90: (Example: )
91: ( [(x1,x2) ring_of_differential_operators )
92: ( [[(H) 1 (h) 1 (x1) 1 (x2) 1] )
93: ( [(h) 1 (Dx1) 1 (Dx2) 1] )
94: ( [(Dx1) 1 (Dx2) 1] )
95: ( [(x1) -1 (x2) -1])
96: ( ] weight_vector )
97: ( 0 )
1.11 takayama 98: ( [(weightedHomogenization) 1 (degreeShift) [[0 0 0]]])
1.1 takayama 99: ( ] define_ring)
100: ( ecart.begin)
101: ( [[1 -4 -2 5]] appell4 0 get /eqs set)
102: ( eqs { . [[(x1). (x1+2).] [(x2). (x2+4).]] replace} map )
1.11 takayama 103: ( {ecart.homogenize01} map /eqs2 set)
1.1 takayama 104: ( [eqs2] groebner )
105: ]] putUsages
106:
107: /ecart.homogenize01_with_shiftVector {
108: /arg2.set
109: /arg1 set
1.11 takayama 110: [/in.ecart.homogenize01 /ll /sv /ll0] pushVariables
1.1 takayama 111: [
112: /sv arg2 def
113: /ll arg1 def
1.11 takayama 114: ll tag ArrayP eq {
115: ll 0 get tag ArrayP eq not {
116: [(degreeShift) sv ll ] homogenize /arg1 set
117: } {
118: ll { ecart.homogenize01_with_shiftVector } map /arg1 set
119: } ifelse
120: } {
121: [(degreeShift) sv ll ] homogenize /arg1 set
1.12 takayama 122: } ifelse
1.1 takayama 123: ] pop
124: popVariables
125: arg1
126: } def
127: [(ecart.dehomogenize01_with_degreeShift)
128: [(obj shift-vector ecart.dehomogenize01_with_degreeShift r)
1.11 takayama 129: (cf. homogenize)
1.1 takayama 130: ]] putUsages
131:
132: %% Aux functions to return the default weight vectors.
133: /ecart.wv1 {
134: /arg1 set
135: [/in.ecart.wv1 /v] pushVariables
136: [
137: /v arg1 def
138: [(H) (h) v to_records pop] /v set
139: v { 1 } map /v set
140: /arg1 v def
141: ] pop
142: popVariables
143: arg1
144: } def
145: /ecart.wv2 {
146: /arg1 set
147: [/in.ecart.wv2 /v] pushVariables
148: [
149: /v arg1 def
150: [v to_records pop] /v set
151: v { [ @@@.Dsymbol 3 -1 roll ] cat 1 } map /v set
152: [(h) 1 ] v join /v set
153: /arg1 v def
154: ] pop
155: popVariables
156: arg1
157: } def
158:
1.7 takayama 159: /ecart.gb {ecartd.gb} def
160:
161: [(ecart.gb)
162: [(a ecart.gb b)
163: (array a; array b;)
164: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
165: ( in the ring of differential operators.)
166: (The computation is done by using Ecart division algorithm and )
167: (the double homogenization.)
168: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
169: $ ii is the initial ideal in case of w is given or <<a>> belongs$
170: $ to a ring. In the other cases, it returns the initial monominal.$
171: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
172: (a : [f v]; array f; string v; v is the variables. )
173: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
174: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
1.11 takayama 175: ( array ds; ds is the degree shift for the ring. )
176: (a : [f v w ds hdShift]; array f; string v; array of array w; w is the weight matirx.)
177: ( array ds; ds is the degree shift for the ring. )
178: ( array hsShift is the degree shift for the homogenization. cf.homogenize )
179: $a : [f v w ds (no)]; array f; string v; array of array w; w is the weight matirx.$
180: ( No automatic homogenization.)
1.7 takayama 181: ( )
182: $cf. ecarth.gb (homogenized), ecartd.gb (dehomogenize) $
183: ( )
184: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
185: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
186: (Example 2: )
187: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.9 takayama 188: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecart.gb /ff set ff pmat ;$
189: (To set the current ring to the ring in which ff belongs )
190: ( ff getRing ring_def )
1.7 takayama 191: ( )
192: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
193: $ [ [ (Dx) 1 (Dy) 1] ] ] ecart.gb pmat ; $
1.10 takayama 194: ( This example will cause an error on order.)
1.7 takayama 195: ( )
196: $Example 4: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
197: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.gb pmat ; $
1.10 takayama 198: ( This example will cause an error on order.)
1.7 takayama 199: ( )
200: $Example 5: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
201: $ [ [(Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1] ] [[0 1] [-3 1] ] ] ecart.gb pmat ; $
202: ( )
203: (cf. gb, groebner, ecarth.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
204: ( ecart.dehomogenize, ecart.dehomogenizeH)
205: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
206: ( define_ring )
207: (/ecart.autoHomogenize 0 def )
208: ( not to dehomogenize and homogenize)
209: ]] putUsages
210:
1.1 takayama 211: /ecart.gb.verbose 1 def
1.12 takayama 212: %ecarth.gb s(H)-homogenized outputs. GG's original version of ecart gb.
1.7 takayama 213: /ecarth.gb {
1.1 takayama 214: /arg1 set
1.7 takayama 215: [/in-ecarth.gb /aa /typev /setarg /f /v
1.1 takayama 216: /gg /wv /vec /ans /rr /mm
217: /degreeShift /env2 /opt /ans.gb
1.12 takayama 218: /hdShift
1.1 takayama 219: ] pushVariables
220: [(CurrentRingp) (KanGBmessage)] pushEnv
221: [
222: /aa arg1 def
1.13 takayama 223: aa isArray { } { ( << array >> ecarth.gb) error } ifelse
1.1 takayama 224: /setarg 0 def
225: /wv 0 def
226: /degreeShift 0 def
1.12 takayama 227: /hdShift 0 def
1.1 takayama 228: /opt [(weightedHomogenization) 1] def
229: aa { tag } map /typev set
230: typev [ ArrayP ] eq
231: { /f aa 0 get def
232: /v gb.v def
233: /setarg 1 def
234: } { } ifelse
235: typev [ArrayP StringP] eq
236: { /f aa 0 get def
237: /v aa 1 get def
238: /setarg 1 def
239: } { } ifelse
240: typev [ArrayP RingP] eq
241: { /f aa 0 get def
242: /v aa 1 get def
243: /setarg 1 def
244: } { } ifelse
245: typev [ArrayP ArrayP] eq
246: { /f aa 0 get def
247: /v aa 1 get from_records def
248: /setarg 1 def
249: } { } ifelse
250: typev [ArrayP StringP ArrayP] eq
251: { /f aa 0 get def
252: /v aa 1 get def
253: /wv aa 2 get def
254: /setarg 1 def
255: } { } ifelse
256: typev [ArrayP ArrayP ArrayP] eq
257: { /f aa 0 get def
258: /v aa 1 get from_records def
259: /wv aa 2 get def
260: /setarg 1 def
261: } { } ifelse
262: typev [ArrayP StringP ArrayP ArrayP] eq
263: { /f aa 0 get def
264: /v aa 1 get def
265: /wv aa 2 get def
266: /degreeShift aa 3 get def
267: /setarg 1 def
268: } { } ifelse
1.12 takayama 269:
270: typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
271: { /f aa 0 get def
272: /v aa 1 get def
273: /wv aa 2 get def
274: /degreeShift aa 3 get def
275: /hdShift aa 4 get def
276: /setarg 1 def
277: } { } ifelse
1.1 takayama 278: typev [ArrayP ArrayP ArrayP ArrayP] eq
279: { /f aa 0 get def
280: /v aa 1 get from_records def
281: /wv aa 2 get def
282: /degreeShift aa 3 get def
283: /setarg 1 def
284: } { } ifelse
1.12 takayama 285: typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
286: { /f aa 0 get def
287: /v aa 1 get from_records def
288: /wv aa 2 get def
289: /degreeShift aa 3 get def
290: /hdShift aa 4 get def
291: /setarg 1 def
292: } { } ifelse
293: typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
294: { /f aa 0 get def
295: /v aa 1 get from_records def
296: /wv aa 2 get def
297: /degreeShift aa 3 get def
298: aa 4 get (no) eq {
299: /hdShift -1 def
300: } {
301: (Unknown keyword for the 5th argument) error
302: } ifelse
303: /setarg 1 def
304: } { } ifelse
1.13 takayama 305: typev [ArrayP StringP ArrayP ArrayP StringP] eq
306: { /f aa 0 get def
307: /v aa 1 get def
308: /wv aa 2 get def
309: /degreeShift aa 3 get def
310: aa 4 get (no) eq {
311: /hdShift -1 def
312: } {
313: (Unknown keyword for the 5th argument) error
314: } ifelse
315: /setarg 1 def
316: } { } ifelse
1.1 takayama 317:
318: /env1 getOptions def
319:
1.12 takayama 320: ecart.gb.verbose { $ecarth.gb computes std basis with h-s(H)-homogenized buchberger algorithm.$ message } { } ifelse
321: setarg { } { (ecarth.gb : Argument mismatch) error } ifelse
1.1 takayama 322:
323: [(KanGBmessage) ecart.gb.verbose ] system_variable
324:
325: %%% Start of the preprocess
326: v tag RingP eq {
327: /rr v def
328: }{
329: f getRing /rr set
330: } ifelse
331: %% To the normal form : matrix expression.
332: f gb.toMatrixOfString /f set
333: /mm gb.itWasMatrix def
334:
335: rr tag 0 eq {
336: %% Define our own ring
337: v isInteger {
338: (Error in gb: Specify variables) error
339: } { } ifelse
340: wv isInteger {
341: [v ring_of_differential_operators
1.6 takayama 342: % [ v ecart.wv1 v ecart.wv2 ] weight_vector
1.3 takayama 343: gb.characteristic
1.1 takayama 344: opt
345: ] define_ring
346: }{
347: degreeShift isInteger {
348: [v ring_of_differential_operators
1.6 takayama 349: % [v ecart.wv1 v ecart.wv2] wv join weight_vector
350: wv weight_vector
1.3 takayama 351: gb.characteristic
1.1 takayama 352: opt
353: ] define_ring
354:
355: }{
356: [v ring_of_differential_operators
1.6 takayama 357: % [v ecart.wv1 v ecart.wv2] wv join weight_vector
358: wv weight_vector
1.3 takayama 359: gb.characteristic
1.1 takayama 360: [(degreeShift) degreeShift] opt join
361: ] define_ring
362:
363: } ifelse
364: } ifelse
365: } {
366: %% Use the ring structre given by the input.
367: v isInteger not {
368: gb.warning {
369: (Warning : the given ring definition is not used.) message
370: } { } ifelse
371: } { } ifelse
372: rr ring_def
373: /wv rr gb.getWeight def
374:
375: } ifelse
376: %%% Enf of the preprocess
377:
378: ecart.gb.verbose {
1.6 takayama 379: (The first and the second weight vectors for automatic homogenization: )
1.1 takayama 380: message
381: v ecart.wv1 message
382: v ecart.wv2 message
383: degreeShift isInteger { }
384: {
385: (The degree shift is ) messagen
386: degreeShift message
387: } ifelse
388: } { } ifelse
389:
1.5 takayama 390: %%BUG: case of v is integer
391: v ecart.checkOrder
392:
1.1 takayama 393: ecart.begin
394:
395: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
1.13 takayama 396:
1.12 takayama 397:
398: hdShift tag 1 eq {
399: ecart.autoHomogenize not hdShift -1 eq or {
400: % No automatic h-s-homogenization.
401: f { {. } map} map /f set
402: } {
403: % Automatic h-s-homogenization without degreeShift
1.13 takayama 404: (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized without degree shift.)
405: message
1.12 takayama 406: f { {. ecart.dehomogenize} map} map /f set
407: f ecart.homogenize01 /f set
408: } ifelse
409: } {
410: % Automatic h-s-homogenization with degreeShift
1.13 takayama 411: (ecarth.gb: Input polynomial or vectors are automatically h-H-homogenized with degree shift.)
412: message
1.12 takayama 413: f { {. ecart.dehomogenize} map} map /f set
414: f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
415: }ifelse
416:
1.1 takayama 417: ecart.needSyz {
418: [f [(needSyz)] gb.options join ] groebner /gg set
419: } {
420: [f gb.options] groebner 0 get /gg set
421: } ifelse
422:
423: ecart.needSyz {
424: mm {
425: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
1.11 takayama 426: } { /ans.gb gg 0 get def } ifelse
427: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
428: % ans pmat ;
1.1 takayama 429: } {
430: wv isInteger {
431: /ans [gg gg {init} map] def
432: }{
1.10 takayama 433: degreeShift isInteger {
434: /ans [gg gg {wv 0 get weightv init} map] def
435: } {
436: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
437: } ifelse
1.1 takayama 438: }ifelse
439:
440: %% Postprocess : recover the matrix expression.
441: mm {
442: ans { /tmp set [mm tmp] toVectors } map
443: /ans set
444: }{ }
445: ifelse
446: } ifelse
447:
448: ecart.end
449:
450: %%
451: env1 restoreOptions %% degreeShift changes "grade"
452:
453: /arg1 ans def
454: ] pop
455: popEnv
456: popVariables
457: arg1
458: } def
1.7 takayama 459: (ecarth.gb ) messagen-quiet
1.1 takayama 460:
1.7 takayama 461: [(ecarth.gb)
462: [(a ecarth.gb b)
1.1 takayama 463: (array a; array b;)
464: $b : [g ii]; array g; array in; g is a standard (Grobner) basis of f$
465: ( in the ring of differential operators.)
1.12 takayama 466: (The computation is done by using Ecart division algorithm.)
467: $Buchberger algorithm is applied for double h-H(s)-homogenized elements and$
468: (they are not dehomogenized.)
1.1 takayama 469: (cf. M.Granger and T.Oaku: Minimal filtered free resolutions ... 2003)
470: $ ii is the initial ideal in case of w is given or <<a>> belongs$
471: $ to a ring. In the other cases, it returns the initial monominal.$
472: (a : [f ]; array f; f is a set of generators of an ideal in a ring.)
473: (a : [f v]; array f; string v; v is the variables. )
474: (a : [f v w]; array f; string v; array of array w; w is the weight matirx.)
475: (a : [f v w ds]; array f; string v; array of array w; w is the weight matirx.)
476: ( array ds; ds is the degree shift )
477: ( )
478: (/ecart.autoHomogenize 0 def )
479: ( not to dehomogenize and homogenize)
480: ( )
481: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 takayama 482: $ [ [ (Dx) 1 ] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 483: (Example 2: )
484: (To put H and h=1, type in, e.g., )
485: $ [ [(2 x Dx + 3 y Dy+6) (2 y Dx + 3 x^2 Dy)] (x,y) $
1.7 takayama 486: $ [[(x) -1 (Dx) 1 (y) -1 (Dy) 1]]] ecarth.gb /gg set gg ecart.dehomogenize pmat ;$
1.1 takayama 487: ( )
488: $Example 3: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.7 takayama 489: $ [ [ (Dx) 1 (Dy) 1] ] ] ecarth.gb pmat ; $
1.1 takayama 490: ( )
491: $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 492: $ [ [ (x) -1 (y) -1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecarth.gb pmat ; $
1.1 takayama 493: ( )
494: $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 495: $ [ [(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 496: ( )
1.7 takayama 497: (cf. gb, groebner, ecart.gb, ecartd.gb, ecart.syz, ecart.begin, ecart.end, ecart.homogenize01, )
1.1 takayama 498: ( ecart.dehomogenize, ecart.dehomogenizeH)
499: ( [(weightedHomogenization) 1 (degreeShift) [[1 2 1]]] : options for )
500: ( define_ring )
501: ]] putUsages
502:
503:
504: /ecart.syz {
505: /arg1 set
506: [/in-ecart.syz /ecart.save.needSyz /ff /ff.ans] pushVariables
507: [
508: /ff arg1 def
509: /ecart.save.needSyz ecart.needSyz def
510: /ecart.needSyz 1 def
511: ff ecart.gb /ff.ans set
512: /ecart.needSyz ecart.save.needSyz def
513: /arg1 ff.ans def
514: ] pop
515: popVariables
516: arg1
517: } def
518: (ecart.syz ) messagen-quiet
519:
520: [(ecart.syz)
521: [(a ecart.syz b)
522: (array a; array b;)
523: $b : [syzygy gb tmat input]; gb = tmat * input $
524: $Example 1: [ [( (x Dx)^2 + (y Dy)^2 -1) ( x y Dx Dy -1)] (x,y) $
1.8 takayama 525: $ [ [ (Dx) 1 (Dy) 1] [(x) -1 (y) -1 (Dx) 1 (Dy) 1]] ] ecart.syz /ff set $
1.1 takayama 526: $ ff 0 get ff 3 get mul pmat $
527: $ ff 2 get ff 3 get mul [ff 1 get ] transpose sub pmat ; $
528: ( )
1.9 takayama 529: (To set the current ring to the ring in which ff belongs )
530: ( ff getRing ring_def )
1.1 takayama 531: $Example 2: [[ [(x^2) (y+x)] [(x+y) (y^3)] [(2 x^2+x y) (y+x+x y^3)]] (x,y) $
1.8 takayama 532: $ [ [(Dx) 1 (Dy) 1] [ (x) -1 (y) -1] ] [[0 1] [-3 1] ] ] ecart.syz pmat ; $
1.1 takayama 533: ( )
534: (cf. ecart.gb)
535: ( /ecart.autoHomogenize 0 def )
536: ]] putUsages
1.2 takayama 537:
1.3 takayama 538:
539: /ecartn.begin {
540: (red@) (standard) switch_function
541: %% (red@) (ecart) switch_function
542: [(Ecart) 1] system_variable
543: [(CheckHomogenization) 0] system_variable
544: [(ReduceLowerTerms) 0] system_variable
545: [(AutoReduce) 0] system_variable
546: [(EcartAutomaticHomogenization) 0] system_variable
547: } def
548: /ecartn.gb {
549: /arg1 set
550: [/in-ecartn.gb /aa /typev /setarg /f /v
551: /gg /wv /vec /ans /rr /mm
552: /degreeShift /env2 /opt /ans.gb
553: ] pushVariables
554: [(CurrentRingp) (KanGBmessage)] pushEnv
555: [
556: /aa arg1 def
1.13 takayama 557: aa isArray { } { ( << array >> ecartn.gb) error } ifelse
1.3 takayama 558: /setarg 0 def
559: /wv 0 def
560: /degreeShift 0 def
561: /opt [(weightedHomogenization) 1] def
562: aa { tag } map /typev set
563: typev [ ArrayP ] eq
564: { /f aa 0 get def
565: /v gb.v def
566: /setarg 1 def
567: } { } ifelse
568: typev [ArrayP StringP] eq
569: { /f aa 0 get def
570: /v aa 1 get def
571: /setarg 1 def
572: } { } ifelse
573: typev [ArrayP RingP] eq
574: { /f aa 0 get def
575: /v aa 1 get def
576: /setarg 1 def
577: } { } ifelse
578: typev [ArrayP ArrayP] eq
579: { /f aa 0 get def
580: /v aa 1 get from_records def
581: /setarg 1 def
582: } { } ifelse
583: typev [ArrayP StringP ArrayP] eq
584: { /f aa 0 get def
585: /v aa 1 get def
586: /wv aa 2 get def
587: /setarg 1 def
588: } { } ifelse
589: typev [ArrayP ArrayP ArrayP] eq
590: { /f aa 0 get def
591: /v aa 1 get from_records def
592: /wv aa 2 get def
593: /setarg 1 def
594: } { } ifelse
595: typev [ArrayP StringP ArrayP ArrayP] eq
596: { /f aa 0 get def
597: /v aa 1 get def
598: /wv aa 2 get def
599: /degreeShift aa 3 get def
600: /setarg 1 def
601: } { } ifelse
602: typev [ArrayP ArrayP ArrayP ArrayP] eq
603: { /f aa 0 get def
604: /v aa 1 get from_records def
605: /wv aa 2 get def
606: /degreeShift aa 3 get def
607: /setarg 1 def
608: } { } ifelse
609:
610: /env1 getOptions def
611:
612: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
613:
614: [(KanGBmessage) ecart.gb.verbose ] system_variable
615:
616: %%% Start of the preprocess
617: v tag RingP eq {
618: /rr v def
619: }{
620: f getRing /rr set
621: } ifelse
622: %% To the normal form : matrix expression.
623: f gb.toMatrixOfString /f set
624: /mm gb.itWasMatrix def
625:
626: rr tag 0 eq {
627: %% Define our own ring
628: v isInteger {
629: (Error in gb: Specify variables) error
630: } { } ifelse
631: wv isInteger {
632: [v ring_of_differential_operators
633: [ v ecart.wv1 v ecart.wv2 ] weight_vector
634: gb.characteristic
635: opt
636: ] define_ring
637: }{
638: degreeShift isInteger {
639: [v ring_of_differential_operators
640: [v ecart.wv1 v ecart.wv2] wv join weight_vector
641: gb.characteristic
642: opt
643: ] define_ring
644:
645: }{
646: [v ring_of_differential_operators
647: [v ecart.wv1 v ecart.wv2] wv join weight_vector
648: gb.characteristic
649: [(degreeShift) degreeShift] opt join
650: ] define_ring
651:
652: } ifelse
653: } ifelse
654: } {
655: %% Use the ring structre given by the input.
656: v isInteger not {
657: gb.warning {
658: (Warning : the given ring definition is not used.) message
659: } { } ifelse
660: } { } ifelse
661: rr ring_def
662: /wv rr gb.getWeight def
663:
664: } ifelse
665: %%% Enf of the preprocess
666:
667: ecart.gb.verbose {
668: (The first and the second weight vectors are automatically set as follows)
669: message
670: v ecart.wv1 message
671: v ecart.wv2 message
672: degreeShift isInteger { }
673: {
674: (The degree shift is ) messagen
675: degreeShift message
676: } ifelse
677: } { } ifelse
678:
1.5 takayama 679: %%BUG: case of v is integer
680: v ecart.checkOrder
681:
1.3 takayama 682: ecartn.begin
683:
684: ecart.gb.verbose { (ecartn.gb : ecart.gb without ecart division.) message } { } ifelse
685: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
686: ecart.autoHomogenize {
687: (ecart.gb: Input polynomial or vectors are automatically h-H-homogenized.)
688: message
689: } { } ifelse
690: ecart.autoHomogenize {
691: f { {. ecart.dehomogenize} map} map /f set
692: f ecart.homogenize01 /f set
693: }{
694: f { {. } map } map /f set
695: } ifelse
696: ecart.needSyz {
697: [f [(needSyz)] gb.options join ] groebner /gg set
698: } {
699: [f gb.options] groebner 0 get /gg set
700: } ifelse
701:
702: ecart.needSyz {
703: mm {
704: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
705: } { /ans.gb gg 0 get def } ifelse
706: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11 takayama 707: % ans pmat ;
1.3 takayama 708: } {
709: wv isInteger {
710: /ans [gg gg {init} map] def
711: }{
1.10 takayama 712: degreeShift isInteger {
713: /ans [gg gg {wv 0 get weightv init} map] def
714: } {
715: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
716: } ifelse
1.3 takayama 717: }ifelse
718:
719: %% Postprocess : recover the matrix expression.
720: mm {
721: ans { /tmp set [mm tmp] toVectors } map
722: /ans set
723: }{ }
724: ifelse
725: } ifelse
726:
727: ecart.end
728:
729: %%
730: env1 restoreOptions %% degreeShift changes "grade"
731:
732: /arg1 ans def
733: ] pop
734: popEnv
735: popVariables
736: arg1
737: } def
738: (ecartn.gb[gb by non-ecart division] ) messagen-quiet
1.4 takayama 739:
740: /ecartd.gb {
741: /arg1 set
742: [/in-ecart.gb /aa /typev /setarg /f /v
743: /gg /wv /vec /ans /rr /mm
744: /degreeShift /env2 /opt /ans.gb
1.11 takayama 745: /hdShift
1.4 takayama 746: ] pushVariables
747: [(CurrentRingp) (KanGBmessage)] pushEnv
748: [
749: /aa arg1 def
1.13 takayama 750: aa isArray { } { ( << array >> ecartd.gb) error } ifelse
1.4 takayama 751: /setarg 0 def
752: /wv 0 def
753: /degreeShift 0 def
1.11 takayama 754: /hdShift 0 def
1.4 takayama 755: /opt [(weightedHomogenization) 1] def
756: aa { tag } map /typev set
757: typev [ ArrayP ] eq
758: { /f aa 0 get def
759: /v gb.v def
760: /setarg 1 def
761: } { } ifelse
762: typev [ArrayP StringP] eq
763: { /f aa 0 get def
764: /v aa 1 get def
765: /setarg 1 def
766: } { } ifelse
767: typev [ArrayP RingP] eq
768: { /f aa 0 get def
769: /v aa 1 get def
770: /setarg 1 def
771: } { } ifelse
772: typev [ArrayP ArrayP] eq
773: { /f aa 0 get def
774: /v aa 1 get from_records def
775: /setarg 1 def
776: } { } ifelse
777: typev [ArrayP StringP ArrayP] eq
778: { /f aa 0 get def
779: /v aa 1 get def
780: /wv aa 2 get def
781: /setarg 1 def
782: } { } ifelse
783: typev [ArrayP ArrayP ArrayP] eq
784: { /f aa 0 get def
785: /v aa 1 get from_records def
786: /wv aa 2 get def
787: /setarg 1 def
788: } { } ifelse
789: typev [ArrayP StringP ArrayP ArrayP] eq
790: { /f aa 0 get def
791: /v aa 1 get def
792: /wv aa 2 get def
793: /degreeShift aa 3 get def
794: /setarg 1 def
795: } { } ifelse
796: typev [ArrayP ArrayP ArrayP ArrayP] eq
797: { /f aa 0 get def
798: /v aa 1 get from_records def
799: /wv aa 2 get def
800: /degreeShift aa 3 get def
801: /setarg 1 def
802: } { } ifelse
1.11 takayama 803: typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
804: { /f aa 0 get def
805: /v aa 1 get def
806: /wv aa 2 get def
807: /degreeShift aa 3 get def
808: /hdShift aa 4 get def
809: /setarg 1 def
810: } { } ifelse
811: typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
812: { /f aa 0 get def
813: /v aa 1 get from_records def
814: /wv aa 2 get def
815: /degreeShift aa 3 get def
816: /hdShift aa 4 get def
817: /setarg 1 def
818: } { } ifelse
819: typev [ArrayP ArrayP ArrayP ArrayP StringP] eq
820: { /f aa 0 get def
821: /v aa 1 get from_records def
822: /wv aa 2 get def
823: /degreeShift aa 3 get def
824: aa 4 get (no) eq {
825: /hdShift -1 def
826: } {
827: (Unknown keyword for the 5th argument) error
828: } ifelse
829: /setarg 1 def
830: } { } ifelse
1.13 takayama 831: typev [ArrayP StringP ArrayP ArrayP StringP] eq
832: { /f aa 0 get def
833: /v aa 1 get def
834: /wv aa 2 get def
835: /degreeShift aa 3 get def
836: aa 4 get (no) eq {
837: /hdShift -1 def
838: } {
839: (Unknown keyword for the 5th argument) error
840: } ifelse
841: /setarg 1 def
842: } { } ifelse
1.4 takayama 843:
844: /env1 getOptions def
845:
846: setarg { } { (ecart.gb : Argument mismatch) error } ifelse
847:
848: [(KanGBmessage) ecart.gb.verbose ] system_variable
849: $ecartd.gb dehomogenizes at each reduction step w.r.t. s (H).$ message
850:
851: %%% Start of the preprocess
852: v tag RingP eq {
853: /rr v def
854: }{
855: f getRing /rr set
856: } ifelse
857: %% To the normal form : matrix expression.
858: f gb.toMatrixOfString /f set
859: /mm gb.itWasMatrix def
860:
861: rr tag 0 eq {
862: %% Define our own ring
863: v isInteger {
864: (Error in gb: Specify variables) error
865: } { } ifelse
866: wv isInteger {
867: (Give an weight vector such that x < 1) error
868: }{
869: degreeShift isInteger {
870: [v ring_of_differential_operators
871: wv weight_vector
872: gb.characteristic
873: opt
874: ] define_ring
875:
876: }{
877: [v ring_of_differential_operators
878: wv weight_vector
879: gb.characteristic
880: [(degreeShift) degreeShift] opt join
881: ] define_ring
882:
883: } ifelse
884: } ifelse
885: } {
886: %% Use the ring structre given by the input.
887: v isInteger not {
888: gb.warning {
889: (Warning : the given ring definition is not used.) message
890: } { } ifelse
891: } { } ifelse
892: rr ring_def
893: /wv rr gb.getWeight def
894:
895: } ifelse
896: %%% Enf of the preprocess
897:
898: ecart.gb.verbose {
899: degreeShift isInteger { }
900: {
901: (The degree shift is ) messagen
902: degreeShift message
903: } ifelse
904: } { } ifelse
905:
1.5 takayama 906: %%BUG: case of v is integer
907: v ecart.checkOrder
908:
1.8 takayama 909: ecartd.begin
1.4 takayama 910:
911: ecart.gb.verbose { (gb.options = ) messagen gb.options message } { } ifelse
912:
1.11 takayama 913: hdShift tag 1 eq {
1.12 takayama 914: ecart.autoHomogenize not hdShift -1 eq or {
1.11 takayama 915: % No automatic h-homogenization.
916: f { {. } map} map /f set
917: } {
918: % Automatic h-homogenization without degreeShift
1.13 takayama 919: (ecartd.gb : Input polynomial or vectors are automatically homogenized without degreeShift) message
1.11 takayama 920: f { {. ecart.dehomogenize} map} map /f set
921: f ecart.homogenize01 /f set
922: f { { [[(H). (1).]] replace } map } map /f set
923: } ifelse
924: } {
925: % Automatic h-homogenization with degreeShift
1.13 takayama 926: (ecartd.gb : Input polynomial or vectors are automatically homogenized with degreeShift) message
1.11 takayama 927: f { {. ecart.dehomogenize} map} map /f set
928: f {/fi set [(degreeShift) hdShift fi] homogenize} map /f set
929: f { { [[(H). (1).]] replace } map } map /f set
930: }ifelse
1.4 takayama 931:
932: ecart.needSyz {
933: [f [(needSyz)] gb.options join ] groebner /gg set
934: } {
935: [f gb.options] groebner 0 get /gg set
936: } ifelse
937:
938: ecart.needSyz {
939: mm {
940: gg 0 get { /tmp set [mm tmp] toVectors } map /ans.gb set
941: } { /ans.gb gg 0 get def } ifelse
942: /ans [gg 2 get , ans.gb , gg 1 get , f ] def
1.11 takayama 943: % ans pmat ;
1.4 takayama 944: } {
945: wv isInteger {
946: /ans [gg gg {init} map] def
947: }{
1.11 takayama 948: %% Get the initial ideal
1.10 takayama 949: degreeShift isInteger {
950: /ans [gg gg {wv 0 get weightv init} map] def
951: } {
952: /ans [gg gg {[wv 0 get weightv degreeShift 0 get ] init} map] def
953: } ifelse
1.4 takayama 954: }ifelse
955:
956: %% Postprocess : recover the matrix expression.
957: mm {
958: ans { /tmp set [mm tmp] toVectors } map
959: /ans set
960: }{ }
961: ifelse
962: } ifelse
963:
1.8 takayama 964: ecartd.end
1.4 takayama 965:
966: %%
967: env1 restoreOptions %% degreeShift changes "grade"
968:
969: /arg1 ans def
970: ] pop
971: popEnv
972: popVariables
973: arg1
974: } def
975: (ecartd.gb[results are dehomogenized at each reduction step] ) messagen-quiet
1.2 takayama 976:
1.5 takayama 977: /ecart.checkOrder {
978: /arg1 set
979: [/in-ecart.checkOrder /vv /tt /dd /n /i] pushVariables
980: [
981: /vv arg1 def
982: vv isArray
983: { } { [vv to_records pop] /vv set } ifelse
984: vv {toString} map /vv set
985: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
986: % Starting the checks.
987: 0 1 vv length 1 sub {
988: /i set
989: vv i get . dd i get . mul /tt set
990: tt @@@.hsymbol . add init tt eq { }
991: { [@@@.hsymbol ( is larger than ) vv i get ( ) dd i get] cat error} ifelse
992: } for
993:
994: 0 1 vv length 1 sub {
995: /i set
996: vv i get . /tt set
997: tt (1). add init (1). eq { }
1.6 takayama 998: { [vv i get ( is larger than 1 ) ] cat error} ifelse
1.5 takayama 999: } for
1000: /arg1 1 def
1001: ] pop
1002: popVariables
1003: arg1
1004: } def
1005: [(ecart.checkOrder)
1006: [(v ecart.checkOrder bool checks if the given order is relevant)
1007: (for the ecart division.)
1008: (cf. ecartd.gb, ecart.gb, ecartn.gb)
1009: ]
1010: ] putUsages
1011:
1012: /ecart.wv_last {
1013: /arg1 set
1014: [/in-ecart.wv_last /vv /tt /dd /n /i] pushVariables
1015: [
1016: /vv arg1 def
1017: vv isArray
1018: { } { [vv to_records pop] /vv set } ifelse
1019: vv {toString} map /vv set
1020: vv { /tt set [@@@.Dsymbol tt] cat } map /dd set
1021: vv { -1 } map
1022: dd { 1 } map join /arg1 set
1023: ] pop
1024: popVariables
1025: arg1
1026: } def
1027: [(ecart.wv_last)
1028: [(v ecart.wv_last wt )
1029: (It returns the weight vector -1,-1,...-1; 1,1, ..., 1)
1030: (Use this weight vector as the last weight vector for ecart division)
1031: (if ecart.checkOrder complains about the order given.)
1032: ]
1033: ] putUsages
1.13 takayama 1034:
1035: /ecart.mimimalBase.test {
1036: [
1037: [ (0) , (-2*Dx) , (2*t) , (y) , (x^2) ]
1038: [ (3*t ) , ( -3*Dy ) , ( 0 ) , ( -x ) , ( -y) ]
1039: [ (3*y ) , ( 6*Dt ) , ( 2*x ) , ( 0 ) , ( 1) ]
1040: [ (-3*x^2 ) , ( 0 ) , ( -2*y ) , ( 1 ) , ( 0 )]
1041: [ (Dx ) , ( 0 ) , ( -Dy ) , ( Dt ) , ( 0) ]
1042: [ (0 ) , ( 0 ) , ( 6*t*Dt+2*x*Dx+3*y*Dy+8*h ) , ( 0 ) , ( 3*x^2*Dt+Dx) ]
1043: [ (6*t*Dx ) , ( 0 ) , ( -6*t*Dy ) , ( -2*x*Dx-3*y*Dy-5*h ) , ( -2*y*Dx-3*x^2*Dy) ]
1044: [ (6*t*Dt+3*y*Dy+9*h ) , ( 0 ) , ( 2*x*Dy ) , ( -2*x*Dt ) , ( -2*y*Dt+Dy) ]
1045: ]
1046: /ff set
1047:
1048: /nmshift [ [1 0 1 1 1] [1 0 1 0 0] ] def
1049: /shift [ [1 0 1 0 0] ] def
1050: /weight [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] def
1051:
1052: [ff (t,x,y) weight shift nmshift] ecart.minimalBase
1053:
1054:
1055: } def
1056: /test {ecart.mimimalBase.test} def
1057:
1058: %(x,y) ==> [(Dx) 1 (Dy) 1 (h) 1]
1059: /ecart.minimalBase.D1 {
1060: /arg1 set
1061: [/in-ecart.minimalBase.D1 /tt /v] pushVariables
1062: [
1063: /v arg1 def
1064: [ v to_records pop] /v set
1065: v { /tt set [@@@.Dsymbol tt] cat 1 } map /v set
1066: v [(h) 1] join /arg1 set
1067: ] pop
1068: popVariables
1069: arg1
1070: } def
1071:
1072: % [0 1 2] 1 ecart.removeElem [0 2]
1073: /ecart.removeElem {
1074: /arg2 set
1075: /arg1 set
1076: [/in-ecart.removeElem /v /q /i /ans /j] pushVariables
1077: [
1078: /v arg1 def
1079: /q arg2 def
1080: /ans v length 1 sub newVector def
1081: /j 0 def
1082: 0 1 v length 1 sub {
1083: /i set
1084: i q eq not {
1085: ans j v i get put
1086: /j j 1 add def
1087: } { } ifelse
1088: } for
1089: ] pop
1090: popVariables
1091: arg1
1092: } def
1093:
1.14 ! takayama 1094: /ecart.isZeroRow {
! 1095: /arg1 set
! 1096: [/in-ecart.isZeroRow /aa /i /n /yes] pushVariables
! 1097: [
! 1098: /aa arg1 def
! 1099: aa length /n set
! 1100: /yes 1 def
! 1101: 0 1 n 1 sub {
! 1102: /i set
! 1103: aa i get (0). eq {
! 1104: } {
! 1105: /yes 0 def
! 1106: } ifelse
! 1107: } for
! 1108: /arg1 yes def
! 1109: ] pop
! 1110: popVariables
! 1111: arg1
! 1112: } def
! 1113:
! 1114: /ecart.removeZeroRow {
! 1115: /arg1 set
! 1116: [/in-ecart.removeZeroRow /aa /i /n /ans] pushVariables
! 1117: [
! 1118: /aa arg1 def
! 1119: aa length /n set
! 1120: /ans [ ] def
! 1121: 0 1 n 1 sub {
! 1122: /i set
! 1123: aa i get ecart.isZeroRow {
! 1124: } {
! 1125: ans aa i get append /ans set
! 1126: } ifelse
! 1127: } for
! 1128: /arg1 ans def
! 1129: ] pop
! 1130: popVariables
! 1131: arg1
! 1132: } def
! 1133:
! 1134: /ecart.gen_input {
! 1135: /arg1 set
! 1136: [/in-ecart.gen_input /aa /typev /setarg /f /v
! 1137: /gg /wv /vec /ans /rr /mm
! 1138: /degreeShift /env2 /opt /ss0
! 1139: /hdShift /ff
! 1140: ] pushVariables
! 1141: [
! 1142: /aa arg1 def
! 1143: aa isArray { } { ( << array >> ecart.gen_input) error } ifelse
! 1144: /setarg 0 def
! 1145: /wv 0 def
! 1146: /degreeShift 0 def
! 1147: /hdShift 0 def
! 1148: aa { tag } map /typev set
! 1149: typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
! 1150: { /f aa 0 get def
! 1151: /v aa 1 get def
! 1152: /wv aa 2 get def
! 1153: /degreeShift aa 3 get def
! 1154: /hdShift aa 4 get def
! 1155: /setarg 1 def
! 1156: } { } ifelse
! 1157: typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
! 1158: { /f aa 0 get def
! 1159: /v aa 1 get from_records def
! 1160: /wv aa 2 get def
! 1161: /degreeShift aa 3 get def
! 1162: /hdShift aa 4 get def
! 1163: /setarg 1 def
! 1164: } { } ifelse
! 1165: setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
! 1166:
! 1167: [(KanGBmessage) ecart.gb.verbose ] system_variable
! 1168:
! 1169: f 0 get tag ArrayP eq { }
! 1170: { f { /tt set [ tt ] } map /f set } ifelse
! 1171:
! 1172: [f v wv degreeShift [hdShift 0 get degreeShift 0 get]]
! 1173: ecart.gb /ff set
! 1174: ff getRing ring_def
! 1175:
! 1176: ff 0 get { {toString } map } map /ff set
! 1177:
! 1178: [ff v wv degreeShift [hdShift 0 get degreeShift 0 get]] /arg1 set
! 1179: ] pop
! 1180: popVariables
! 1181: arg1
! 1182: } def
! 1183: [(ecart.gen_input)
! 1184: [([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]] ecart.gen_input )
! 1185: ( [gg_h v weight_vector uv_shift_m [D_shift_n uv_shift_m]] )
! 1186: (It generates the input for the minimal filtered free resolution.)
! 1187: (Current ring is changed to the ring of gg_h.)
! 1188: (cf. ecart.minimalBase)
! 1189: $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
! 1190: $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
! 1191: $ [ [0] ] $
! 1192: $ [ [0] [0] ] ] ecart.gen_input /gg set gg pmat $
! 1193: ]] putUsages
! 1194:
! 1195:
1.13 takayama 1196: [(ecart.minimalBase)
1.14 ! takayama 1197: [([ff v weight_vector uv_shift_m [D_shift_n uv_shift_m]] ecart.minimalBase )
! 1198: ( [mbase gr_of_mbase )
! 1199: ( [syz v weight_vector new_uv_shift_m [new_D_shift_n new_uv_shift_m]])
! 1200: ( gr_of_syz ])
! 1201: (mbase is the minimal generators of ff in D^h in the sense of filtered minimal)
! 1202: (generators.)
! 1203: $Example: [ [(t-x^3+y^2) (Dx+ 3 x^2 Dt) (Dy - 2 y Dt)] (t,x,y) $
! 1204: $ [ [(t) -1 (Dt) 1] [(t) -1 (x) -1 (y) -1 (Dt) 1 (Dx) 1 (Dy) 1]] $
! 1205: $ [ [0] ] $
! 1206: $ [ [0] [0] ] ] ecart.gen_input /gg0 set $
! 1207: $ gg0 ecart.minimalBase /ss0 set $
! 1208: $ ss0 2 get ecart.minimalBase /ss1 set $
! 1209: $ ss1 2 get ecart.minimalBase /ss2 set $
! 1210: $ (--------- minimal filtered resolution -------) message $
! 1211: $ ss0 0 get pmat ss1 0 get pmat ss2 0 get pmat $
! 1212: $ (--------- degree shift (n,m) n:D-shift m:uv-shift -------) message $
! 1213: $ gg0 4 get message $
! 1214: $ ss0 2 get 4 get message $
! 1215: $ ss1 2 get 4 get message $
! 1216: $ ss2 2 get 4 get message ; $
! 1217:
1.13 takayama 1218: ]] putUsages
1219: /ecart.minimalBase {
1220: /arg1 set
1221: [/in-ecart.minimalBase /ai1 /ai /aa /typev /setarg /f /v
1222: /gg /wv /vec /ans /rr /mm
1223: /degreeShift /env2 /opt /ss0
1224: /hdShift
1225: /degreeShiftD /degreeShiftUV
1226: /degreeShiftDnew /degreeShiftUVnew
1227: /tt
1228: /ai1_gr /ai_gr
1229: /s /r /p /q /i /j /k
1230: /ai1_new /ai_new /ai_new2
1231: ] pushVariables
1232: [
1233: /aa arg1 def
1234: aa isArray { } { ( << array >> ecart.minimalBase) error } ifelse
1235: /setarg 0 def
1236: /wv 0 def
1237: /degreeShift 0 def
1238: /hdShift 0 def
1239: aa { tag } map /typev set
1240: typev [ArrayP StringP ArrayP ArrayP ArrayP] eq
1241: { /f aa 0 get def
1242: /v aa 1 get def
1243: /wv aa 2 get def
1244: /degreeShift aa 3 get def
1245: /hdShift aa 4 get def
1246: /setarg 1 def
1247: } { } ifelse
1248: typev [ArrayP ArrayP ArrayP ArrayP ArrayP] eq
1249: { /f aa 0 get def
1250: /v aa 1 get from_records def
1251: /wv aa 2 get def
1252: /degreeShift aa 3 get def
1253: /hdShift aa 4 get def
1254: /setarg 1 def
1255: } { } ifelse
1256: setarg { } { (ecart.minimalBase : Argument mismatch) error } ifelse
1257:
1258: [(KanGBmessage) ecart.gb.verbose ] system_variable
1259:
1260: f 0 get tag ArrayP eq { }
1261: { f { /tt set [ tt ] } map /f set } ifelse
1262: [f v wv degreeShift (no)] ecart.syz /ss0 set
1263:
1264: ss0 getRing ring_def
1265: /degreeShiftD hdShift 0 get def
1266: /degreeShiftUV hdShift 1 get def
1267: % -- ai --> D^r -- ai1 --> D^rr
1268: /ai1 f { { . } map } map def
1269: /ai ss0 0 get def
1270:
1271: {
1272: /degreeShiftUVnew
1273: ai1 { [ << wv 0 get weightv >> degreeShiftUV ] ord_ws_all } map
1274: def
1275: (degreeShiftUVnew=) messagen degreeShiftUVnew message
1276:
1277: /degreeShiftDnew
1278: ai1 { [ << v ecart.minimalBase.D1 weightv >> degreeShiftD ] ord_ws_all}
1279: map
1280: def
1281: (degreeShiftDnew=) messagen degreeShiftDnew message
1282:
1283: ai {[wv 0 get weightv degreeShiftUVnew] init} map /ai_gr set
1284:
1285: %C Note 2003.8.26
1286:
1.14 ! takayama 1287: ai [ ] eq {
! 1288: exit
! 1289: } { } ifelse
! 1290:
1.13 takayama 1291: /s ai length def
1292: /r ai 0 get length def
1293:
1294: /itIsMinimal 1 def
1295: 0 1 s 1 sub {
1296: /i set
1297: 0 1 r 1 sub {
1298: /j set
1299:
1300: [(isConstantAll) ai_gr i get j get] gbext
1301: ai_gr i get j get (0). eq not and
1302: {
1303: /itIsMinimal 0 def
1304: /p i def /q j def
1305: } { } ifelse
1306: } for
1307: } for
1308:
1309:
1310: itIsMinimal { exit } { } ifelse
1311:
1312: % construct new ai and ai1 (A_i and A_{i-1})
1313: /ai1_new r 1 sub newVector def
1314: /j 0 def
1315: 0 1 r 1 sub {
1316: /i set
1317: i q eq not {
1318: ai1_new j ai1 i get put
1319: /j j 1 add def
1320: } { } ifelse
1321: } for
1322:
1323: /ai_new [s r] newMatrix def
1324: 0 1 s 1 sub {
1325: /j set
1326: 0 1 r 1 sub {
1327: /k set
1328: ai_new [j k]
1329: << ai p get q get >> << ai j get k get >> mul
1330: << ai j get q get >> << ai p get k get >> mul
1331: sub
1332: put
1333: } for
1334: } for
1335:
1336: % remove 0 column
1337: /ai_new2 [s 1 sub r 1 sub] newMatrix def
1338: /j 0 def
1339: 0 1 s 1 sub {
1340: /i set
1341: i p eq not {
1342: ai_new2 j << ai_new i get q ecart.removeElem >> put
1343: /j j 1 add def
1344: } { } ifelse
1345: } for
1346:
1347: % ( ) error
1.14 ! takayama 1348: /ai1 ai1_new def
! 1349: /ai ai_new2 ecart.removeZeroRow def
1.13 takayama 1350:
1351: } loop
1.14 ! takayama 1352: /arg1
! 1353: [ ai1
! 1354: ai1 {[wv 0 get weightv degreeShift 0 get] init} map %Getting gr of A_{i-1}
! 1355: [ai v wv [degreeShiftUVnew] [degreeShiftDnew degreeShiftUVnew]]
! 1356: ai {[wv 0 get weightv degreeShiftUVnew] init} map %Getting gr of A_i
! 1357: ]
! 1358: def
1.13 takayama 1359: ] pop
1360: popVariables
1361: arg1
1362: } def
1363:
1.5 takayama 1364:
1.2 takayama 1365: ( ) message-quiet
1.5 takayama 1366:
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