===================================================================
RCS file: /home/cvs/OpenXM/src/asir-contrib/testing/tr.rr,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -p -r1.2 -r1.3
--- OpenXM/src/asir-contrib/testing/tr.rr	2005/04/02 05:56:57	1.2
+++ OpenXM/src/asir-contrib/testing/tr.rr	2005/04/03 11:05:21	1.3
@@ -1,10 +1,10 @@
-/* $OpenXM$ */
-/* $Id: tr.rr,v 1.2 2005/04/02 05:56:57 takayama Exp $ */
+/* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.2 2005/04/02 05:56:57 takayama Exp $ */
+/* $Id: tr.rr,v 1.3 2005/04/03 11:05:21 takayama Exp $ */
 
 /*  
   OpenXM版の Risa/Asir で実行のこと. OpenXM 版の関数を用いるため.
 */
-/* $Id: tr.rr,v 1.2 2005/04/02 05:56:57 takayama Exp $
+/* $Id: tr.rr,v 1.3 2005/04/03 11:05:21 takayama Exp $
   このファイルは quotetolist でリストに変換したデータに対して
   パターンマッチおよびそれを応用した変形を行う.
   tr.oxt の仕様とことなり quotetolist で変換したものを扱う.
@@ -20,15 +20,22 @@ def dprint0(X) {
   if (Debug) print(X,0);
 }
 
+/* quotetolist の逆関数. ただし文字列で */
+def listtoquote_str(L) {
+  return quote_input_form_quote_list(L);
+}
 
 def qt_node(F) {
-   return [F[0],F[1]];
+   if (type(F) == 17) F=quotetolist(F);
+   return [rtostr(F[0]),rtostr(F[1])];
 }
 /* Number of  child */
 def qt_nchild(F) {
+   if (type(F) == 17) F=quotetolist(F);
    return length(F)-2;
 }
 def qt_child(F,K) {
+   if (type(F) == 17) F=quotetolist(F);
    return F[K+2];
 }
 
@@ -48,7 +55,8 @@ def tr_match0(F,P)  {
   }
   Node = qt_node(F);
   Node2 = qt_node(P);
-  if (Node2 == ["function","pn"]) return 2;
+  /* pn に何の制約もなければ 2 を戻す. */
+  if (Node2 == ["function","pn"]) return tr_check_pn(F,P);
   if (Node != Node2) return 0;
   N = qt_nchild(F);
   if (N != qt_nchild(P)) return 0;
@@ -60,6 +68,25 @@ def tr_match0(F,P)  {
   return 1;
 }
 
+/* 
+   P の例: P = pn("x");  P=pn("x",qt_is_integer(x));
+   P は [function,pn,[internal,x],[function,is_int,[internal,x]]]
+   FF は ["is_int","x"]
+   テストデータ.
+ tr_check_pn(quote(1/2),quote(pn("x",qt_is_integer(x))));
+*/
+def tr_check_pn(F,P) {
+  if (type(F) ==17) F=quotetolist(F);
+  if (type(P) == 17) P=quotetolist(P); 
+  N=qt_nchild(P);
+  if (N == 1) return 2;
+  X = rtostr(qt_child(P,0)[1]);
+  BindingTable = [[X,F]];
+  FF = [rtostr(qt_child(P,1)[1]),rtostr(qt_child(P,1)[2][1])];
+  R = tr_apply_function0(FF,BindingTable);
+  return R;
+}
+
 /* F と P が tr_match0 するとき  bindingTable をもどす.
   [[変数の名前(文字列), 値(list)], ...]
 */
@@ -71,7 +98,7 @@ def tr_make_binding(F,P) {
   Node2 = qt_node(P);
 
   if (Node2 == ["function", "pn"]) {
-     Ans = append(Ans,[[P[2][1],F]]);
+     Ans = append(Ans,[[rtostr(P[2][1]),F]]);
      return Ans;
   }
   N = qt_nchild(F);
@@ -118,12 +145,12 @@ def tr_apply_function0(Q,BindTable) {
   N = length(BindTable);
   /* BindTable の右辺値を quote(...) なる文字列に */
   for (I=0; I<N; I++) {
-    B = append(B,[[BindTable[I][0],"quote("+quote_input_form_quote_list(BindTable[I][1])+")"]]);
+    B = append(B,[[BindTable[I][0],"quote("+listtoquote_str(BindTable[I][1])+")"]]);
   } 
   dprint0("tr_apply_function0: "); dprint(B);
   N = length(Q)-1; /* 引数の数 */
   M = length(B);   /*  binding table のサイズ */
-  R = Q[0]+"(";
+  R = rtostr(Q[0])+"(";
   for (I=0; I<N; I++) {
     X = rtostr(Q[I+1]); /* 変数 */
     /* binding Table をサーチ */
@@ -134,7 +161,11 @@ def tr_apply_function0(Q,BindTable) {
           if (I != N-1) R = R+",";
           break;
        }
-       if (J == M-1) error("No binding data.");
+       if (J == M-1) {
+         dprint0("No binding data. Use the X itself. X="); dprint(X);
+         R = R+X;
+         if (I != N-1) R = R+",";
+       }
     }
   }
   R = R+")";
@@ -155,13 +186,18 @@ def tr_apply_rule1(Obj,L,R) {
   Obj = quotetolist(Obj);
   L = quotetolist(L);
   R = tr_rp(Obj,L,R);
-  RR = "quote("+quote_input_form_quote_list(R)+")";
+  if (type(R) == 17) R=quotetolist(R);
+  RR = "quote("+listtoquote_str(R)+")";
   dprint("--------  end of tr_apply_rule1 ------------ ");
   return eval_str(RR);  
 }
 
 /* quote に対する 述語 */
 def qt_is_integer(Qlist) {
+  if (type(Qlist) == 17) Qlist=quotetolist(Qlist);
+  if ((rtostr(Qlist[0]) == "u_op")  && (rtostr(Qlist[1]) == "-")) {
+    return qt_is_integer(cdr(cdr(Qlist))[0]);
+  }
   if (Qlist[0] == "internal") {
      Z = eval_str(rtostr(Qlist[1]));
   }else{ 
@@ -180,13 +216,17 @@ def qt_zero() {
 
 /* 右規則関数.   恒等式 */
 def qt_id(X) {
-  return quotetolist(X);
+  if (type(X) == 17) return quotetolist(X);
+  else return X;
 }
 
 /* ------------  test --------------------------- */
 extern Rule_test2$
-Rule_test2=[quote(sin(pn("x")*@pi)),["qt_sin_int2","x"]]$
+/* " " と付けてもつけなくてもよい. 内部で rtostr してる. */
+/* Rule_test2=[quote(sin(pn("x")*@pi)),["qt_sin_int2","x"]]$ */
+Rule_test2=[quote(sin(pn(x)*@pi)),[qt_sin_int2,x]]$
 
+
 def test2() {
   /* 幅優先探索の場合, R0 は simplify できず.  */
   Rule1=[quote(sin(pn("x")*@pi)),["qt_sin_int","x"]];
@@ -207,7 +247,7 @@ def qt_sin_int(X) {
   /* いま X は quote 型 */
   Y = quotetolist(X);
   /* Todo: このようなものを作る機能は組み込みで欲しい. */
-  R = "quote(sin("+quote_input_form_quote_list(Y)+"*@pi))";
+  R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
   print(R);
   R = eval_str(R);
   /* Todo: X が 数字かどうか調べる機能も組み込みで欲しい.
@@ -227,13 +267,80 @@ def qt_sin_int2(X) {
   /* tr_apply_rule1 を再帰的によぶ. この方法で構文解析もかける. */
   X = tr_apply_rule1(X,Rule_test2[0],Rule_test2[1]);
   Y = quotetolist(X);
-  R = "quote(sin("+quote_input_form_quote_list(Y)+"*@pi))";
+  R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
   print(R);
   R = eval_str(R);
   if (qt_is_integer(Y)) return quotetolist(quote(0));
   else return quotetolist(R);
 }
 
+/* --------------- end test -----------------------*/
+def qt_replace(F,Rule) {
+  return base_replace(F,Rule);
+}
+
+/*  F の中に不定元 X が含まれているか? 
+    qt_dependent(quotetolist(quote(1+1/x)),x)
+*/
+def qt_dependent(F,X) {
+  if (type(F) == 17) F = quotetolist(F);
+  Node = qt_node(F);
+  if ((F[0] == "internal") && (rtostr(F[1]) == rtostr(X))) {
+    return 1;
+  }else{
+     N = qt_nchild(F);
+     for (I=0; I<N;I++) {
+       C = qt_child(F,I);
+       if (qt_dependent(C,X)) return 1;
+     }
+     return 0;
+  }
+}
+
+/* tr_check_pn の動作テスト */
+def test2b() {
+  Rule=[quote(sin(pn(x,qt_is_integer(x))*@pi)),[qt_zero]]$
+  R0 = quote(1+sin(2*@pi)*sin(a*@pi));;
+  print(print_input_form(R0));
+  R=tr_apply_rule1(R0,Rule[0],Rule[1]);
+  return R;
+}
+
+/* 注意: @pi  も関数扱い. */
+def qt_is_function(X) {
+  if (type(X) == 17) X=quotetolist(X);
+  if (rtostr(X[0]) == "function") return 1;
+  else return 0;
+}
+
+/* qt_map_arg(nn,quote(f(x,y)))  --> nn(f(nn(x),nn(y))) 
+   qt_map_arg(nn,quote(1/4+f(x)))     --> 
+   テストは test4().
+*/
+def qt_map_arg(F,Q) {
+  F = rtostr(F);
+  if (type(Q) == 17) Q=quotetolist(Q);
+  if (rtostr(Q[0]) == "internal") {
+     T = listtoquote_str(Q);
+     return eval_str( "quote("+F+"("+T+"))" );
+  }
+  /* node の子供を F で評価する. */
+  N = qt_nchild(Q);
+  L = [];
+  for (I=0; I<N; I++) {
+    L = append(L,[quotetolist(qt_map_arg(F,qt_child(Q,I)))]);
+  }
+  dprint0("qt_map_arg:L="); dprint(L);
+  T = [Q[0],Q[1]];
+  for (I=0; I<N; I++) {
+    T = append(T,[L[I]]);
+  }
+  /* 最後に子供を親 Q[0],Q[1] で評価してから F で評価 */
+  T = ["function",F,T];
+  dprint0("qt_map_arg:T="); dprint(T);
+  T = listtoquote_str(T);
+  return eval_str("quote("+T+")");
+}
 
 /* これら以外のテストプログラムは test1-tr.rr を 
 */