Annotation of OpenXM/src/asir-contrib/testing/tr.rr, Revision 1.6
1.6 ! takayama 1: /* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.5 2005/04/15 12:47:14 takayama Exp $ */
! 2: /* $Id: tr.rr,v 1.12 2005/04/21 10:53:27 taka Exp $ */
1.2 takayama 3:
4: /*
5: OpenXM$BHG$N(B Risa/Asir $B$G<B9T$N$3$H(B. OpenXM $BHG$N4X?t$rMQ$$$k$?$a(B.
6: */
1.6 ! takayama 7: /* $Id: tr.rr,v 1.12 2005/04/21 10:53:27 taka Exp $
1.2 takayama 8: $B$3$N%U%!%$%k$O(B quotetolist $B$G%j%9%H$KJQ49$7$?%G!<%?$KBP$7$F(B
9: $B%Q%?!<%s%^%C%A$*$h$S$=$l$r1~MQ$7$?JQ7A$r9T$&(B.
10: tr.oxt $B$N;EMM$H$3$H$J$j(B quotetolist $B$GJQ49$7$?$b$N$r07$&(B.
11: $B%F%9%H%W%m%0%i%`$N$?$a8zN($OL5;k(B. (append $B$NB?MQ(B, $BL5BL$J(B2$B=E8F$S=P$7(B, $B$J$I(B))
12: */
13:
14: extern Debug$
15: Debug=0$
16: def dprint(X) {
17: if (Debug) print(X);
18: }
19: def dprint0(X) {
20: if (Debug) print(X,0);
21: }
22:
1.3 takayama 23: /* quotetolist $B$N5U4X?t(B. $B$?$@$7J8;zNs$G(B */
24: def listtoquote_str(L) {
25: return quote_input_form_quote_list(L);
26: }
1.2 takayama 27:
28: def qt_node(F) {
1.3 takayama 29: if (type(F) == 17) F=quotetolist(F);
30: return [rtostr(F[0]),rtostr(F[1])];
1.2 takayama 31: }
32: /* Number of child */
33: def qt_nchild(F) {
1.3 takayama 34: if (type(F) == 17) F=quotetolist(F);
1.2 takayama 35: return length(F)-2;
36: }
37: def qt_child(F,K) {
1.3 takayama 38: if (type(F) == 17) F=quotetolist(F);
1.2 takayama 39: return F[K+2];
40: }
41:
42: /*
43: $B%j%9%H(B F $B$,(B $B%j%9%H(B P $B$K(B($B@hF,$+$i$NHf3S$G(B)$B%^%C%A$7$?$i(B 1.
44: $B$=$&$G$J$$$+$i(B 0. $BI}M%@hC5:w(B.
45: Todo: P $B$KG$0U4X?t$r4^$`;EAH$_$O$^$@<BAu$7$F$J$$(B.
46: */
47: def tr_match0(F,P) {
48: dprint0("tr_match0: F="); dprint(F);
49: dprint0("tr_match0: P="); dprint(P);
50:
51: if (type(F) != type(P)) return 0;
52: if (type(F) != 4) {
53: if (F == P) return 1;
54: else return 0;
55: }
56: Node = qt_node(F);
57: Node2 = qt_node(P);
1.3 takayama 58: /* pn $B$K2?$N@)Ls$b$J$1$l$P(B 2 $B$rLa$9(B. */
59: if (Node2 == ["function","pn"]) return tr_check_pn(F,P);
1.2 takayama 60: if (Node != Node2) return 0;
61: N = qt_nchild(F);
62: if (N != qt_nchild(P)) return 0;
63: for (I=0; I<N; I++) {
64: C = qt_child(F,I);
65: C2 = qt_child(P,I);
66: if (!tr_match0(C,C2)) return 0;
67: }
68: return 1;
69: }
70:
1.3 takayama 71: /*
72: P $B$NNc(B: P = pn("x"); P=pn("x",qt_is_integer(x));
73: P $B$O(B [function,pn,[internal,x],[function,is_int,[internal,x]]]
74: FF $B$O(B ["is_int","x"]
75: $B%F%9%H%G!<%?(B.
76: tr_check_pn(quote(1/2),quote(pn("x",qt_is_integer(x))));
77: */
78: def tr_check_pn(F,P) {
79: if (type(F) ==17) F=quotetolist(F);
80: if (type(P) == 17) P=quotetolist(P);
81: N=qt_nchild(P);
82: if (N == 1) return 2;
83: X = rtostr(qt_child(P,0)[1]);
84: BindingTable = [[X,F]];
85: FF = [rtostr(qt_child(P,1)[1]),rtostr(qt_child(P,1)[2][1])];
86: R = tr_apply_function0(FF,BindingTable);
87: return R;
88: }
89:
1.2 takayama 90: /* F $B$H(B P $B$,(B tr_match0 $B$9$k$H$-(B bindingTable $B$r$b$I$9(B.
91: [[$BJQ?t$NL>A0(B($BJ8;zNs(B), $BCM(B(list)], ...]
92: */
93: def tr_make_binding(F,P) {
94: Ans = [ ];
95: if (F == P) return Ans;
96:
97: Node = qt_node(F);
98: Node2 = qt_node(P);
99:
100: if (Node2 == ["function", "pn"]) {
1.3 takayama 101: Ans = append(Ans,[[rtostr(P[2][1]),F]]);
1.2 takayama 102: return Ans;
103: }
104: N = qt_nchild(F);
105: for (I=0; I<N; I++) {
106: C = qt_child(F,I);
107: C2 = qt_child(P,I);
108: Ans = append(Ans,tr_make_binding(C,C2));
109: }
110: return Ans;
111: }
112:
113: /*
114: Tree $B$NCf$rI}M%@hC5:w$G8!:w$7$F(B $BCV$-49$($k(B.
115: $BI}M%@hC5:w$J$N$G(B, $BF1$8(B rule $B$K%^%C%A$9$k$b$N$,F~$l;R$K$J$C$?>l9g(B,
116: $BFbB&$OCV$-49$($i$l$J$$(B.
117: $B?<$5M%@hC5:w$K$7$?(B --> action $B4X?t$NCf$G:F5"E*$K8F$Y$P?<$5M%@h$H$J$k(B.
118: Todo: $B=q$-49$($,$*$3$C$?$+$N%U%i%0(B.
119: */
120: def tr_rp(F,P,Q) {
121: dprint0("tr_rp, F="); dprint(F);
122: dprint0("tr_rp, P="); dprint(P);
123: dprint0("tr_rp, Q="); dprint(Q);
124: if (tr_match0(F,P)) {
125: BindTable = tr_make_binding(F,P);
126: dprint0("BindTable="); dprint(BindTable);
127: return tr_apply_function0(Q,BindTable);
128: }
129: if (type(F) != 4) return F;
130: Node = qt_node(F);
131: N = qt_nchild(F);
132: Ans = Node;
133: for (I=0; I<N; I++) {
134: T = tr_rp(qt_child(F,I),P,Q);
135: Ans = append(Ans,[T]);
136: }
137: return Ans;
138: }
139:
140: /* ["f","x"],[["x",[internal,3]]] $B$N;~$O(B
141: f(3) $B$r7W;;$9$k(B.
142: */
143: def tr_apply_function0(Q,BindTable) {
144: B = [ ];
145: N = length(BindTable);
146: /* BindTable $B$N1&JUCM$r(B quote(...) $B$J$kJ8;zNs$K(B */
147: for (I=0; I<N; I++) {
1.3 takayama 148: B = append(B,[[BindTable[I][0],"quote("+listtoquote_str(BindTable[I][1])+")"]]);
1.2 takayama 149: }
150: dprint0("tr_apply_function0: "); dprint(B);
151: N = length(Q)-1; /* $B0z?t$N?t(B */
152: M = length(B); /* binding table $B$N%5%$%:(B */
1.3 takayama 153: R = rtostr(Q[0])+"(";
1.2 takayama 154: for (I=0; I<N; I++) {
155: X = rtostr(Q[I+1]); /* $BJQ?t(B */
156: /* binding Table $B$r%5!<%A(B */
157: for (J=0; J<M; J++) {
158: Y = rtostr(B[J][0]);
159: if (X == Y) {
160: R = R+B[J][1];
161: if (I != N-1) R = R+",";
162: break;
163: }
1.3 takayama 164: if (J == M-1) {
165: dprint0("No binding data. Use the X itself. X="); dprint(X);
166: R = R+X;
167: if (I != N-1) R = R+",";
168: }
1.2 takayama 169: }
170: }
171: R = R+")";
172: dprint0("R="); dprint(R);
1.5 takayama 173: V=eval_str(R);
174: if (type(V) == 17) return quotetolist(V);
175: else return V;
1.2 takayama 176: }
177:
178:
179: /* L $B$,:85,B'(B. R $B$,1&5,B'(B. $BI}M%@hC5:w(B.
180: $B=q$-49$($r$9$k$?$a$N%H%C%W%l%Y%k$N4X?t(B ($B$N$R$H$D(B).
181: $BNc(B:
182: tr_apply_rule1(quote(1+sin(3*@pi)*sin(@pi/2)),
183: quote(sin(pn("x")*@pi)),
184: ["qt_sin_int","x"]);
185: */
186: def tr_apply_rule1(Obj,L,R) {
187: dprint("-------- start of tr_apply_rule1 ------------ ");
188: Obj = quotetolist(Obj);
189: L = quotetolist(L);
190: R = tr_rp(Obj,L,R);
1.3 takayama 191: if (type(R) == 17) R=quotetolist(R);
192: RR = "quote("+listtoquote_str(R)+")";
1.2 takayama 193: dprint("-------- end of tr_apply_rule1 ------------ ");
194: return eval_str(RR);
195: }
196:
197: /* quote $B$KBP$9$k(B $B=R8l(B */
198: def qt_is_integer(Qlist) {
1.3 takayama 199: if (type(Qlist) == 17) Qlist=quotetolist(Qlist);
200: if ((rtostr(Qlist[0]) == "u_op") && (rtostr(Qlist[1]) == "-")) {
201: return qt_is_integer(cdr(cdr(Qlist))[0]);
202: }
1.2 takayama 203: if (Qlist[0] == "internal") {
204: Z = eval_str(rtostr(Qlist[1]));
205: }else{
206: return 0;
207: }
208: if (type(Z) == 0) return 1;
209: if ((type(Z) == 1) && (ntype(Z) == 0)) return 1;
210: return 0;
211: }
212:
213: /* quote $B$N@8@.(B */
214: /* $B1&5,B'4X?t(B. 0 $B$rLa$9(B. */
215: def qt_zero() {
216: return quotetolist(quote(0));
217: }
218:
219: /* $B1&5,B'4X?t(B. $B91Ey<0(B */
220: def qt_id(X) {
1.3 takayama 221: if (type(X) == 17) return quotetolist(X);
222: else return X;
1.2 takayama 223: }
224:
225: /* ------------ test --------------------------- */
226: extern Rule_test2$
1.3 takayama 227: /* " " $B$HIU$1$F$b$D$1$J$/$F$b$h$$(B. $BFbIt$G(B rtostr $B$7$F$k(B. */
228: /* Rule_test2=[quote(sin(pn("x")*@pi)),["qt_sin_int2","x"]]$ */
229: Rule_test2=[quote(sin(pn(x)*@pi)),[qt_sin_int2,x]]$
230:
1.2 takayama 231:
232: def test2() {
233: /* $BI}M%@hC5:w$N>l9g(B, R0 $B$O(B simplify $B$G$-$:(B. */
234: Rule1=[quote(sin(pn("x")*@pi)),["qt_sin_int","x"]];
235: R0 = quote(1+sin(sin(2*@pi)*@pi)*sin(@pi/2));
236: print(print_input_form(R0));
237: R=tr_apply_rule1(R0,Rule1[0],Rule1[1]);
238: print(print_input_form(R));
239: print("-----------------------");
240: /* $B<!$N$h$&$K=q$/$H?<$5M%@h$G=q$1$k(B */
241: R0 = quote(1+sin(sin(2*@pi)*@pi)*sin(@pi/2));
242: print(print_input_form(R0));
243: R=tr_apply_rule1(R0,Rule_test2[0],Rule_test2[1]);
244: print(print_input_form(R));
245: }
246:
247: /* $B1&5,B'4X?t(B. sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B */
248: def qt_sin_int(X) {
249: /* $B$$$^(B X $B$O(B quote $B7?(B */
250: Y = quotetolist(X);
251: /* Todo: $B$3$N$h$&$J$b$N$r:n$k5!G=$OAH$_9~$_$GM_$7$$(B. */
1.3 takayama 252: R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
1.2 takayama 253: print(R);
254: R = eval_str(R);
255: /* Todo: X $B$,(B $B?t;z$+$I$&$+D4$Y$k5!G=$bAH$_9~$_$GM_$7$$(B.
256: */
257: if (Y[0] == "internal") {
258: Z = eval_str(rtostr(Y[1]));
259: }else{
260: return quotetolist(R);
261: }
262: if (type(Z) == 0) return quotetolist(quote(0));
263: if ((type(Z) == 1) && (ntype(Z) == 0)) return quotetolist(quote(0));
264: return quotetolist(R);
265: }
266:
267: /* $B1&5,B'4X?t(B. sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B. $B?<$5M%@hMQ(B */
268: def qt_sin_int2(X) {
269: /* tr_apply_rule1 $B$r:F5"E*$K$h$V(B. $B$3$NJ}K!$G9=J82r@O$b$+$1$k(B. */
270: X = tr_apply_rule1(X,Rule_test2[0],Rule_test2[1]);
271: Y = quotetolist(X);
1.3 takayama 272: R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
1.2 takayama 273: print(R);
274: R = eval_str(R);
275: if (qt_is_integer(Y)) return quotetolist(quote(0));
276: else return quotetolist(R);
277: }
278:
1.3 takayama 279: /* --------------- end test -----------------------*/
280: def qt_replace(F,Rule) {
281: return base_replace(F,Rule);
282: }
283:
284: /* F $B$NCf$KITDj85(B X $B$,4^$^$l$F$$$k$+(B?
1.5 takayama 285: qt_is_dependent(quotetolist(quote(1+1/x)),x)
1.3 takayama 286: */
1.5 takayama 287: def qt_is_dependent(F,X) {
1.3 takayama 288: if (type(F) == 17) F = quotetolist(F);
289: Node = qt_node(F);
290: if ((F[0] == "internal") && (rtostr(F[1]) == rtostr(X))) {
291: return 1;
292: }else{
293: N = qt_nchild(F);
294: for (I=0; I<N;I++) {
295: C = qt_child(F,I);
1.5 takayama 296: if (qt_is_dependent(C,X)) return 1;
1.3 takayama 297: }
298: return 0;
299: }
300: }
301:
302: /* tr_check_pn $B$NF0:n%F%9%H(B */
303: def test2b() {
304: Rule=[quote(sin(pn(x,qt_is_integer(x))*@pi)),[qt_zero]]$
305: R0 = quote(1+sin(2*@pi)*sin(a*@pi));;
306: print(print_input_form(R0));
307: R=tr_apply_rule1(R0,Rule[0],Rule[1]);
308: return R;
309: }
310:
311: /* $BCm0U(B: @pi $B$b4X?t07$$(B. */
312: def qt_is_function(X) {
313: if (type(X) == 17) X=quotetolist(X);
314: if (rtostr(X[0]) == "function") return 1;
315: else return 0;
316: }
317:
318: /* qt_map_arg(nn,quote(f(x,y))) --> nn(f(nn(x),nn(y)))
319: qt_map_arg(nn,quote(1/4+f(x))) -->
320: $B%F%9%H$O(B test4().
321: */
322: def qt_map_arg(F,Q) {
323: F = rtostr(F);
324: if (type(Q) == 17) Q=quotetolist(Q);
325: if (rtostr(Q[0]) == "internal") {
326: T = listtoquote_str(Q);
327: return eval_str( "quote("+F+"("+T+"))" );
328: }
329: /* node $B$N;R6!$r(B F $B$GI>2A$9$k(B. */
330: N = qt_nchild(Q);
331: L = [];
332: for (I=0; I<N; I++) {
333: L = append(L,[quotetolist(qt_map_arg(F,qt_child(Q,I)))]);
334: }
335: dprint0("qt_map_arg:L="); dprint(L);
336: T = [Q[0],Q[1]];
337: for (I=0; I<N; I++) {
338: T = append(T,[L[I]]);
339: }
340: /* $B:G8e$K;R6!$r?F(B Q[0],Q[1] $B$GI>2A$7$F$+$i(B F $B$GI>2A(B */
341: T = ["function",F,T];
342: dprint0("qt_map_arg:T="); dprint(T);
343: T = listtoquote_str(T);
344: return eval_str("quote("+T+")");
1.5 takayama 345: }
346:
347: /* Index $BIU$-JQ?t$r<B8=$9$k(B */
348: def idxtov(V,I) {
349: if (type(I) == 5) I=vtol(I);
350: if (type(I) != 4) I=[I];
351: if (type(V) != 2) V=rtostr(V);
352: return util_v(V,I);
353: }
354:
355: def vtoidx(V) {
356: A = util_index(V);
357: if (length(A[1]) == 0) return [A[0]];
358: if (length(A[1]) == 1) return [A[0],A[1][0]];
359: return A;
1.3 takayama 360: }
1.2 takayama 361:
362: /* $B$3$l$i0J30$N%F%9%H%W%m%0%i%`$O(B test1-tr.rr $B$r(B
363: */
1.6 ! takayama 364:
! 365: module qt;
! 366: localf dtoq$
! 367: localf qtod$ /* it has not yet been implemented. /
! 368: localf etoq$
! 369:
! 370: /* Distributed polynomial to quote
! 371: qt.dtoq(dp_ptod((x-y)^3,[x,y]),[]);
! 372: */
! 373: def dtoq(F,V) {
! 374: if (F == 0) return quote(0);
! 375: N = length(dp_etov(F));
! 376: if (N > length(V)) {
! 377: for (I=length(V); I<N; I++) {
! 378: V = append(V,[util_v("x",[I+1])]);
! 379: }
! 380: }
! 381: R = 0;
! 382: while (F != 0) {
! 383: T = dp_hm(F);
! 384: F = dp_rest(F);
! 385: C = objtoquote(dp_hc(T));
! 386: E = dp_etov(T);
! 387: Mq = etoq(E,V);
! 388: if (Mq == quote(1)) {
! 389: R = R+C;
! 390: }else{
! 391: if (C == quote(1)) R = R+Mq;
! 392: else if (C == quote(-1)) R = R-Mq;
! 393: else R = R+C*Mq;
! 394: }
! 395: }
! 396: return R;
! 397: }
! 398: /* bug: +-3*x should be -3*x */
! 399:
! 400: def etoq(E,V) {
! 401: N = length(E);
! 402: if (N > length(V)) {
! 403: for (I=length(V); I<N; I++) {
! 404: V = append(V,[util_v("x",[I+1])]);
! 405: }
! 406: }
! 407: II = -1;
! 408: for (I=0; I<N; I++) {
! 409: if (E[I] != 0) { II=I; break; }
! 410: }
! 411: if (II == -1) return quote(1);
! 412: if (E[II] == 1) R=objtoquote(V[II]);
! 413: else {
! 414: R=objtoquote(V[II])^objtoquote(E[II]);
! 415: }
! 416: for (I=II+1; I<N; I++) {
! 417: if (E[I] != 0) {
! 418: if (E[I] == 1) Rt=objtoquote(V[I]);
! 419: else Rt=objtoquote(V[I])^objtoquote(E[I]);
! 420: R = R*Rt;
! 421: }
! 422: }
! 423: return R;
! 424: }
! 425:
! 426: endmodule;
1.2 takayama 427:
428: end$
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to tr.rr CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM / src / asir-contrib / testing