Annotation of OpenXM/src/k097/slib.k, Revision 1.10
1.10 ! takayama 1: /* $OpenXM: OpenXM/src/k097/slib.k,v 1.9 2001/01/08 05:26:49 takayama Exp $ */
1.1 maekawa 2: /* slib.sm1, standard library. */
3: /* April 26-- , 1996 */
4: /* Don't use function names that is already used as a postscipt macro names*/
5: /* You may encounter operand stack overflow. */
6: /* sm1("(incmac.sm1) run (slib.sm1) run ");
7: */
8: if (K00_verbose)
9: sm1(" ( slib.k (slib.ccc): 8/17,1996, 3/4 -- 3/10,1997 ) message ");
10:
1.9 takayama 11:
12: /*
13: Each Helplist[i] has the format
14: [ category, [ key, explanations, ( args ,) (refs ,) (short descriptions)]]
15: category : null or string
16: key : string
17: explanations : string or array of string (Ex. and << >> are key words)
18: args : null or list of strings
19: refs : null or list of strings
20: short descriptions : string
21: */
1.1 maekawa 22: Helplist = [ ];
1.9 takayama 23: def void HelpAdd(s,category) {
24: local n;
25: n = Length(Arglist);
26: if (n <= 1) {
27: category = null;
28: }
29: if (true) {
30: /* Assert the args */
31: /* You can use functions only defined before using HelpAdd */
32: if (!(n == 1 || n == 2)) {
33: Println(s);
34: Error("HelpAdd: wrong argument length.");
35: }
36: if (!(Tag(category) == 0 || Tag(category) == 5)) {
37: Println(category);
38: Error("HelpAdd: wrong category.");
39: }
40: if (!(Tag(s) == 6)) {
41: Println(s);
42: Error("HelpAdd: s must be an array.");
43: }
44: if (! (Tag(s[0]) == 5)) {
45: Println(s);
46: Error("HelpAdd: s[0] must be a string.");
47: }
48: if (! (Tag(s[1]) == 5 || Tag(s[1]) == 6)) {
49: Println(s);
50: Error("HelpAdd: s[1] must be a string or an array.");
51: }
52: /* End of assert */
53: }
54: s = [category,s];
1.1 maekawa 55: Helplist = Append(Helplist,s);
56: }
57:
1.9 takayama 58: def Tag(f) {
59: local ans;
60: ans = sm1(f," etag (universalNumber) dc ");
61: return(ans);
62: }
63: def Error(s) {
64: sm1(" s error ");
65: }
66:
1.1 maekawa 67: def Print(a) { /* print object without new line */
68: sm1(a," messagen");
69: }
70: def Println(a) { /* print object with new line */
71: sm1(a," message");
72: }
73: def Ln() { sm1(" ( ) message"); } /* newline */
74: /* Warning!! When use sm1 as f = sm1(...), Never set /FunctionValue.
75: Example: f = sm1(" 1 1 add /FunctionValue set ") causes error.
76: */
77: def Poly(f) {
78: sm1(f," (poly) data_conversion /FunctionValue set");
79: }
80: def PolyR(f,r) { /* parse the polynomial in R */
81: sm1(f,r," ,, /FunctionValue set");
82: }
83: def Degree(f,v) {
84: sm1(f,v," degree (universalNumber) dc /FunctionValue set");
85: }
86:
87: def Append(f,g) { return(Join(f,[g])); }
88:
89: def Length(f) { sm1(f," length (universalNumber) dc /FunctionValue set"); }
90:
91: def Transpose(mat) {
92: sm1(mat," transpose /FunctionValue set ");
93: }
94:
95: sm1("
96: /s.Indexed {
97: (integer) dc /arg2 set
98: /arg1 set
99: arg1 ([) arg2 (dollar) dc (]) 4 cat_n
100: } def
101:
102: /s.Indexed2 {
103: (integer) dc /arg3 set
104: (integer) dc /arg2 set
105: /arg1 set
106: arg1 ([) arg2 (dollar) dc (,) arg3 (dollar) dc (]) 6 cat_n
107: } def
108: ");
109:
110: def Groebner(F) { /* Print("Input is "); Println(F); */
111: sm1(F," {[[(h). (1).]] replace homogenize} map /arg1 set
112: [arg1] groebner 0 get
113: /FunctionValue set "); }
114:
115: def GroebnerTime(F) { /* Print("Input is "); Println(F); */
116: sm1(F," {[[(h). (1).]] replace homogenize} map /arg1 set
117: { [arg1] groebner 0 get } timer
118: /FunctionValue set "); }
119:
120: def LiftStd(F) { /* Print("Input is "); Println(F); */
121: sm1(F," {[[(h). (1).]] replace homogenize} map /arg1 set
122: [arg1 [(needBack)]] groebner
123: /FunctionValue set "); }
124:
1.7 takayama 125: /*
1.1 maekawa 126: def Reduction(f,G) {
127: sm1(f,G," reduction /FunctionValue set ");
1.7 takayama 128: }
129: */
130: def Reduction(f,myset) {
131: local n, indexTable, set2, i, j, tmp, t_syz,r,rng,
132: vsize,tt;
133: vsize = null;
134: r = GetRing(Poly("1")); /* Save the current ring */
135: rng = GetRing(f);
136: if (Tag(rng) == 0) {
137: rng = GetRing(myset);
138: }
139: if (Tag(rng) != 0) {SetRing(rng);}
140:
141: if (IsArray(f)) {
142: vsize = Length(f);
143: sm1(" [f] fromVectors 0 get /f set ");
144: }
145:
146: n = Length(myset);
147: if (n > 0) {
148: if (IsArray(myset[0])) {
149: if (vsize != Length(myset[0])) {
150: Error("Reduction: size mismatch.");
151: }
152: sm1(" myset fromVectors /myset set ");
153: }
154: }
155:
156: indexTable = NewArray(n);
157: set2 = [ ];
158: j = 0;
159: for (i=0; i<n; i++) {
160: if (Tag(myset[i]) == 0) {
161: indexTable[i] = -1;
162: }else if (myset[i] == Poly("0")) {
163: indexTable[i] = -1;
164: }else{
165: set2 = Append(set2,myset[i]);
166: indexTable[i] = j;
167: j++;
168: }
169: }
170: sm1(" f set2 (gradedPolySet) dc reduction /tmp set ");
171: t_syz = NewArray(n);
172: for (i=0; i<n; i++) {
173: if (indexTable[i] != -1) {
174: t_syz[i] = tmp[2, indexTable[i]];
175: }else{
176: t_syz[i] = Poly("0");
177: }
178: }
179: if (Tag(vsize) != 0) {
180: tt = tmp[0];
181: sm1(" [vsize (integer) dc tt] toVectors /tt set ");
182: tmp[0] = tt;
183: }
184: SetRing(r);
185: return([tmp[0],tmp[1],t_syz]);
1.1 maekawa 186: }
187:
188:
189:
190: def IntegerToSm1Integer(f) {
191: sm1(f, " (integer) dc /FunctionValue set ");
192: }
193: def RingD(vList,weightMatrix,pp) {
194: local new0,tmp,size,n,i,j,newtmp,ringpp,argsize;
195: argsize = Length(Arglist);
1.10 ! takayama 196: if (IsArray(vList)) {
! 197: sm1(" vList {toString} map from_records /vList set ");
! 198: }
1.1 maekawa 199: if (argsize == 1) {
200: sm1("[", vList,
201: "ring_of_differential_operators ( ) elimination_order 0 ] define_ring
202: /tmp set ");
1.5 takayama 203: SetRingVariables();
1.1 maekawa 204: return(tmp);
205: } else ;
206: if (argsize == 2) {
207: pp = 0;
208: }
209: pp = IntegerToSm1Integer(pp);
210: size = Length(weightMatrix);
211: new0 = NewVector(size);
212: sm1(" /@@@.indexMode.flag.save @@@.indexMode.flag def ");
213: sm1(" 0 @@@.indexMode ");
214: PSfor (i=0; i<size; i++) {
215: tmp = weightMatrix[i];
216: n = Length(tmp);
217: newtmp = NewVector(n);
218: for (j=1; j<n; j = j+2) {
219: newtmp[j-1] = tmp[j-1];
220: newtmp[j] = IntegerToSm1Integer( tmp[j] );
221: }
222: new0[i] = newtmp;
223: }
224: ringpp =
225: sm1("[", vList,
226: "ring_of_differential_operators ", new0, " weight_vector",pp, " ] define_ring");
1.5 takayama 227: SetRingVariables();
1.1 maekawa 228: sm1(" @@@.indexMode.flag.save @@@.indexMode ");
229: return( ringpp );
230: }
231:
232: /* RingD("x,y",[["x",2,"y",1]]);
233: RingD("x,y");
234: */
235:
236:
237:
238: /* from lib/setvariables.ccc : to generate sm1-package setvariables.sm1 */
239: /* 1997, 3/6 */
240: /* sm1(" 0 @@@.indexMode "); C-like notation of matrix. a[0], ... */
241:
242: def getxvar(i) {
243: sm1( "[(x) (var) ", i , " ..int ] system_variable /FunctionValue set ");
244: }
245:
246: def getdvar(i) {
247: sm1( "[(D) (var) ", i , " ..int ] system_variable /FunctionValue set ");
248: }
249:
250: def getvarn() {
251: sm1( "[(N)] system_variable (universalNumber) dc /FunctionValue set ");
252: }
253:
1.5 takayama 254: SetRingVariables_Verbose = false;
1.1 maekawa 255: def SetRingVariables() {
256: /* Don't use local variables in this function,
257: because we set global variables in this function.
258: cf. SSWork/yacc/memo.txt, 1997,3/6 */
259: if (SetRingVariables_Verbose ) {
260: Print("SetRingVariables() Setting the global variables : ");
261: }
1.5 takayama 262: if (k00setRingVariables(0,sm1( "[(N)] system_variable (universalNumber) dc "))) {
263: sm1(" define_ring_variables ");
264: }
1.1 maekawa 265: if (SetRingVariables_Verbose) {Ln();}
266: }
267:
268: def k00AreThereLeftBrace(s) {
269: local leftBrace, jj, slist;
270: leftBrace = sm1(" $[$ (array) dc 0 get (universalNumber) dc ");
1.9 takayama 271: jj = Position(StringToAsciiArray(s),leftBrace);
1.1 maekawa 272: if (jj != -1) return(true); else return(false);
273: }
274:
1.5 takayama 275: def k00setRingVariables(p,q) {
276: local v,i;
277: for (i = p; i< q; i++) {
278: v = getxvar(i);
279: if (k00AreThereLeftBrace(v)) {
280: return(false);
1.1 maekawa 281: }
1.5 takayama 282: v = getdvar(i);
283: if (k00AreThereLeftBrace(v)) {
284: return(false);
1.1 maekawa 285: }
286: }
1.5 takayama 287: return(true);
1.1 maekawa 288: }
289: /* ---------------------------------- */
290:
291: def AddString(f) {
292: sm1(f," aload length cat_n /FunctionValue set ");
293: }
294:
295: def IntegerToString(f) {
296: sm1(f," (string) dc /FunctionValue set ");
297: }
298:
299: def Replace(f,rule) {
300: sm1(f,rule," replace /FunctionValue set ");
301: }
302:
303: def AsciiToString(c) {
304: sm1(c," (integer) dc (string) dc /FunctionValue set ");
305: }
306:
307:
308: /* From lib/tostr.ccc */
309: def ToString(p) {
310: local n,ans,i;
311: ans = [ ];
312: if (IsArray(p)) {
313: n = Length(p);
314: ans = Append(ans,"[ ");
315: for (i=0; i<n; i++) {
316: ans = Append(ans,ToString(p[i]));
317: if (i != n-1) {
318: ans = Append(ans," , ");
319: }
320: }
321: ans = Append(ans," ] ");
322: } else {
323: ans = [ sm1(p," (dollar) dc ") ];
324: /* Println(ans); */
325: }
326: return(AddString(ans));
327: }
328:
329: def IsArray(p) {
330: sm1(p," isArray /FunctionValue set ");
331: }
332:
333:
334: /* Println(tostr2([1,[2,3,4]])); */
335:
336:
337: def Denominator(f) {
338: sm1(f," (denominator) dc /FunctionValue set ");
339: }
340:
341: def Numerator(f) {
342: sm1(f," (numerator) dc /FunctionValue set ");
343: }
344:
345:
346: def Replace(f,rule) {
347: local ans,n,tmp,i,num,den;
348: if (IsArray(f)) {
349: n = Length(f);
350: ans = [ ];
351: for (i=0; i<n; i++) {
352: ans = Append(ans, Replace(f[i],rule));
353: }
354: return(ans);
355: }
356:
357: if (sm1(f," tag RationalFunctionP eq ")) {
358: num = Numerator(f);
359: den = Denominator(f);
360: num = sm1(num,rule, " replace ");
361: den = sm1(den,rule, " replace ");
362: return( num/den );
363: }
364:
365: sm1( f, rule , " replace /FunctionValue set ");
366: }
367:
368:
369:
370: /* 1997, 3/7 */
371: def Map(karg,func) {
372: sm1(karg," { [ 2 -1 roll ] this 2 -1 roll [(parse) ",func," ] extension pop } map /FunctionValue set");
373: }
374: /* test Map
375: def foo1(i) { return(i*2); }
376: def foo() {
377: Println(Map([82,83,84],"foo1"));
378: }
379: */
380:
381: def Position(list,elem) {
382: local n,pos,i;
383: n = Length(list);
384: pos = -1;
385: for (i=0; i<n; i++) {
386: if (elem == list[i]) {
387: pos = i;
388: sm1(" /k00.label0 goto ");
389: }
390: }
391: sm1(" /k00.label0 ");
392: return(pos);
393: }
394:
1.9 takayama 395: def StringToAsciiArray(s) {
1.1 maekawa 396: sm1(s," (array) dc { (universalNumber) dc } map /FunctionValue set ");
397: }
398:
399: def NewArray(n) {
400: return(NewVector(n));
401: }
402:
1.3 takayama 403: def GetEnv(s) {
404: sm1(" [(getenv) s] extension /FunctionValue set ");
405: }
1.4 takayama 406: def Boundp(a) {
407: local b;
408: sm1("[(parse) [(/) ",a," ( load tag 0 eq
409: { /FunctionValue 0 def }
410: { /FunctionValue 1 def } ifelse )] cat ] extension");
411: }
412: def Rest(a) {
413: sm1(a," rest /FunctionValue set ");
414: }
415: def GetPathName(s) {
416: local t,sss;
417: sss = s;
418: sm1(" [(stat) s] extension 0 get /t set ");
419: if (Tag(t) == 0) {
420: s=AddString([GetEnv("LOAD_K_PATH"),"/",s]);
421: sm1(" [(stat) s] extension 0 get /t set ");
422: if (Tag(t) == 0) {
423: return(null);
424: }else{
425: return(s);
426: }
427: }else{
428: return(s);
429: }
430: }
431:
1.5 takayama 432: def Load_sm1(fnames,flag) {
433: local ppp,n,i,cmd;
434: if (Boundp(flag)) {
435: }else{
436: n = Length(fnames);
437: for (i=0; i<n; i++) {
438: ppp = GetPathName(fnames[i]);
439: if (Tag(ppp) != 0) {
440: sm1(" [(parse) ppp pushfile ] extension ");
441: cmd = AddString(["/",flag," 1 def "]);
442: sm1(" [(parse) cmd ] extension ");
443: i=n; /* break; */
444: }
445: }
446: }
447: }
448:
1.6 takayama 449:
450: def GetRing(f) {
451: sm1(" f getRing /FunctionValue set ");
452: }
453:
454: def SetRing(r) {
455: sm1(" r ring_def ");
456: }
1.8 takayama 457:
458: def ReParse(a) {
459: local c;
460: if (IsArray(a)) {
461: c = Map(a,"ReParse");
462: }else{
463: sm1(a," toString . /c set");
464: }
465: return(c);
466: }
467:
468: def void Pmat(a) {
469: sm1(" a pmat ");
470: }
1.9 takayama 471:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to slib.k CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / k097