Annotation of OpenXM/src/k097/slib.k, Revision 1.9
1.9 ! takayama 1: /* $OpenXM: OpenXM/src/k097/slib.k,v 1.8 2001/01/05 11:14:25 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);
196: if (argsize == 1) {
197: sm1("[", vList,
198: "ring_of_differential_operators ( ) elimination_order 0 ] define_ring
199: /tmp set ");
1.5 takayama 200: SetRingVariables();
1.1 maekawa 201: return(tmp);
202: } else ;
203: if (argsize == 2) {
204: pp = 0;
205: }
206: pp = IntegerToSm1Integer(pp);
207: size = Length(weightMatrix);
208: new0 = NewVector(size);
209: sm1(" /@@@.indexMode.flag.save @@@.indexMode.flag def ");
210: sm1(" 0 @@@.indexMode ");
211: PSfor (i=0; i<size; i++) {
212: tmp = weightMatrix[i];
213: n = Length(tmp);
214: newtmp = NewVector(n);
215: for (j=1; j<n; j = j+2) {
216: newtmp[j-1] = tmp[j-1];
217: newtmp[j] = IntegerToSm1Integer( tmp[j] );
218: }
219: new0[i] = newtmp;
220: }
221: ringpp =
222: sm1("[", vList,
223: "ring_of_differential_operators ", new0, " weight_vector",pp, " ] define_ring");
1.5 takayama 224: SetRingVariables();
1.1 maekawa 225: sm1(" @@@.indexMode.flag.save @@@.indexMode ");
226: return( ringpp );
227: }
228:
229: /* RingD("x,y",[["x",2,"y",1]]);
230: RingD("x,y");
231: */
232:
233:
234:
235: /* from lib/setvariables.ccc : to generate sm1-package setvariables.sm1 */
236: /* 1997, 3/6 */
237: /* sm1(" 0 @@@.indexMode "); C-like notation of matrix. a[0], ... */
238:
239: def getxvar(i) {
240: sm1( "[(x) (var) ", i , " ..int ] system_variable /FunctionValue set ");
241: }
242:
243: def getdvar(i) {
244: sm1( "[(D) (var) ", i , " ..int ] system_variable /FunctionValue set ");
245: }
246:
247: def getvarn() {
248: sm1( "[(N)] system_variable (universalNumber) dc /FunctionValue set ");
249: }
250:
1.5 takayama 251: SetRingVariables_Verbose = false;
1.1 maekawa 252: def SetRingVariables() {
253: /* Don't use local variables in this function,
254: because we set global variables in this function.
255: cf. SSWork/yacc/memo.txt, 1997,3/6 */
256: if (SetRingVariables_Verbose ) {
257: Print("SetRingVariables() Setting the global variables : ");
258: }
1.5 takayama 259: if (k00setRingVariables(0,sm1( "[(N)] system_variable (universalNumber) dc "))) {
260: sm1(" define_ring_variables ");
261: }
1.1 maekawa 262: if (SetRingVariables_Verbose) {Ln();}
263: }
264:
265: def k00AreThereLeftBrace(s) {
266: local leftBrace, jj, slist;
267: leftBrace = sm1(" $[$ (array) dc 0 get (universalNumber) dc ");
1.9 ! takayama 268: jj = Position(StringToAsciiArray(s),leftBrace);
1.1 maekawa 269: if (jj != -1) return(true); else return(false);
270: }
271:
1.5 takayama 272: def k00setRingVariables(p,q) {
273: local v,i;
274: for (i = p; i< q; i++) {
275: v = getxvar(i);
276: if (k00AreThereLeftBrace(v)) {
277: return(false);
1.1 maekawa 278: }
1.5 takayama 279: v = getdvar(i);
280: if (k00AreThereLeftBrace(v)) {
281: return(false);
1.1 maekawa 282: }
283: }
1.5 takayama 284: return(true);
1.1 maekawa 285: }
286: /* ---------------------------------- */
287:
288: def AddString(f) {
289: sm1(f," aload length cat_n /FunctionValue set ");
290: }
291:
292: def IntegerToString(f) {
293: sm1(f," (string) dc /FunctionValue set ");
294: }
295:
296: def Replace(f,rule) {
297: sm1(f,rule," replace /FunctionValue set ");
298: }
299:
300: def AsciiToString(c) {
301: sm1(c," (integer) dc (string) dc /FunctionValue set ");
302: }
303:
304:
305: /* From lib/tostr.ccc */
306: def ToString(p) {
307: local n,ans,i;
308: ans = [ ];
309: if (IsArray(p)) {
310: n = Length(p);
311: ans = Append(ans,"[ ");
312: for (i=0; i<n; i++) {
313: ans = Append(ans,ToString(p[i]));
314: if (i != n-1) {
315: ans = Append(ans," , ");
316: }
317: }
318: ans = Append(ans," ] ");
319: } else {
320: ans = [ sm1(p," (dollar) dc ") ];
321: /* Println(ans); */
322: }
323: return(AddString(ans));
324: }
325:
326: def IsArray(p) {
327: sm1(p," isArray /FunctionValue set ");
328: }
329:
330:
331: /* Println(tostr2([1,[2,3,4]])); */
332:
333:
334: def Denominator(f) {
335: sm1(f," (denominator) dc /FunctionValue set ");
336: }
337:
338: def Numerator(f) {
339: sm1(f," (numerator) dc /FunctionValue set ");
340: }
341:
342:
343: def Replace(f,rule) {
344: local ans,n,tmp,i,num,den;
345: if (IsArray(f)) {
346: n = Length(f);
347: ans = [ ];
348: for (i=0; i<n; i++) {
349: ans = Append(ans, Replace(f[i],rule));
350: }
351: return(ans);
352: }
353:
354: if (sm1(f," tag RationalFunctionP eq ")) {
355: num = Numerator(f);
356: den = Denominator(f);
357: num = sm1(num,rule, " replace ");
358: den = sm1(den,rule, " replace ");
359: return( num/den );
360: }
361:
362: sm1( f, rule , " replace /FunctionValue set ");
363: }
364:
365:
366:
367: /* 1997, 3/7 */
368: def Map(karg,func) {
369: sm1(karg," { [ 2 -1 roll ] this 2 -1 roll [(parse) ",func," ] extension pop } map /FunctionValue set");
370: }
371: /* test Map
372: def foo1(i) { return(i*2); }
373: def foo() {
374: Println(Map([82,83,84],"foo1"));
375: }
376: */
377:
378: def Position(list,elem) {
379: local n,pos,i;
380: n = Length(list);
381: pos = -1;
382: for (i=0; i<n; i++) {
383: if (elem == list[i]) {
384: pos = i;
385: sm1(" /k00.label0 goto ");
386: }
387: }
388: sm1(" /k00.label0 ");
389: return(pos);
390: }
391:
1.9 ! takayama 392: def StringToAsciiArray(s) {
1.1 maekawa 393: sm1(s," (array) dc { (universalNumber) dc } map /FunctionValue set ");
394: }
395:
396: def NewArray(n) {
397: return(NewVector(n));
398: }
399:
1.3 takayama 400: def GetEnv(s) {
401: sm1(" [(getenv) s] extension /FunctionValue set ");
402: }
1.4 takayama 403: def Boundp(a) {
404: local b;
405: sm1("[(parse) [(/) ",a," ( load tag 0 eq
406: { /FunctionValue 0 def }
407: { /FunctionValue 1 def } ifelse )] cat ] extension");
408: }
409: def Rest(a) {
410: sm1(a," rest /FunctionValue set ");
411: }
412: def GetPathName(s) {
413: local t,sss;
414: sss = s;
415: sm1(" [(stat) s] extension 0 get /t set ");
416: if (Tag(t) == 0) {
417: s=AddString([GetEnv("LOAD_K_PATH"),"/",s]);
418: sm1(" [(stat) s] extension 0 get /t set ");
419: if (Tag(t) == 0) {
420: return(null);
421: }else{
422: return(s);
423: }
424: }else{
425: return(s);
426: }
427: }
428:
1.5 takayama 429: def Load_sm1(fnames,flag) {
430: local ppp,n,i,cmd;
431: if (Boundp(flag)) {
432: }else{
433: n = Length(fnames);
434: for (i=0; i<n; i++) {
435: ppp = GetPathName(fnames[i]);
436: if (Tag(ppp) != 0) {
437: sm1(" [(parse) ppp pushfile ] extension ");
438: cmd = AddString(["/",flag," 1 def "]);
439: sm1(" [(parse) cmd ] extension ");
440: i=n; /* break; */
441: }
442: }
443: }
444: }
445:
1.6 takayama 446:
447: def GetRing(f) {
448: sm1(" f getRing /FunctionValue set ");
449: }
450:
451: def SetRing(r) {
452: sm1(" r ring_def ");
453: }
1.8 takayama 454:
455: def ReParse(a) {
456: local c;
457: if (IsArray(a)) {
458: c = Map(a,"ReParse");
459: }else{
460: sm1(a," toString . /c set");
461: }
462: return(c);
463: }
464:
465: def void Pmat(a) {
466: sm1(" a pmat ");
467: }
1.9 ! takayama 468:
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