===================================================================
RCS file: /home/cvs/OpenXM/src/asir-contrib/testing/tr.rr,v
retrieving revision 1.1
retrieving revision 1.5
diff -u -p -r1.1 -r1.5
--- OpenXM/src/asir-contrib/testing/tr.rr	2005/04/01 08:08:36	1.1
+++ OpenXM/src/asir-contrib/testing/tr.rr	2005/04/15 12:47:14	1.5
@@ -0,0 +1,365 @@
+/* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.4 2005/04/06 09:26:28 takayama Exp $ */
+/* $Id: tr.rr,v 1.5 2005/04/15 12:47:14 takayama Exp $ */
+
+/*  
+  OpenXM版の Risa/Asir で実行のこと. OpenXM 版の関数を用いるため.
+*/
+/* $Id: tr.rr,v 1.5 2005/04/15 12:47:14 takayama Exp $
+  このファイルは quotetolist でリストに変換したデータに対して
+  パターンマッチおよびそれを応用した変形を行う.
+  tr.oxt の仕様とことなり quotetolist で変換したものを扱う.
+  テストプログラムのため効率は無視.   (append の多用, 無駄な2重呼び出し, など))
+*/
+
+extern Debug$
+Debug=0$
+def dprint(X) {
+  if (Debug) print(X);
+}
+def dprint0(X) {
+  if (Debug) print(X,0);
+}
+
+/* quotetolist の逆関数. ただし文字列で */
+def listtoquote_str(L) {
+  return quote_input_form_quote_list(L);
+}
+
+def qt_node(F) {
+   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];
+}
+
+/* 
+   リスト F が リスト P に(先頭からの比較で)マッチしたら 1.
+   そうでないから 0.  幅優先探索.
+    Todo: P に任意関数を含む仕組みはまだ実装してない.  
+*/
+def tr_match0(F,P)  {
+  dprint0("tr_match0: F="); dprint(F);
+  dprint0("tr_match0: P="); dprint(P);  
+
+  if (type(F) != type(P)) return 0;
+  if (type(F) != 4) {
+    if (F == P) return 1;
+    else return 0;
+  }
+  Node = qt_node(F);
+  Node2 = qt_node(P);
+  /* 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;
+  for (I=0; I<N; I++) {
+     C = qt_child(F,I);
+     C2 = qt_child(P,I);
+     if (!tr_match0(C,C2)) return 0;
+  }
+  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)], ...]
+*/
+def tr_make_binding(F,P) {
+  Ans = [ ];
+  if (F == P) return Ans;
+
+  Node = qt_node(F);
+  Node2 = qt_node(P);
+
+  if (Node2 == ["function", "pn"]) {
+     Ans = append(Ans,[[rtostr(P[2][1]),F]]);
+     return Ans;
+  }
+  N = qt_nchild(F);
+  for (I=0; I<N; I++) {
+     C = qt_child(F,I);
+     C2 = qt_child(P,I);
+     Ans = append(Ans,tr_make_binding(C,C2));
+  }
+  return Ans;
+}
+
+/* 
+   Tree の中を幅優先探索で検索して 置き換える.
+   幅優先探索なので, 同じ rule にマッチするものが入れ子になった場合, 
+   内側は置き換えられない.
+   深さ優先探索にした --> action 関数の中で再帰的に呼べば深さ優先となる.
+   Todo: 書き換えがおこったかのフラグ.
+*/
+def tr_rp(F,P,Q) {
+  dprint0("tr_rp, F="); dprint(F);
+  dprint0("tr_rp, P="); dprint(P);
+  dprint0("tr_rp, Q="); dprint(Q);
+  if (tr_match0(F,P)) {
+     BindTable = tr_make_binding(F,P);
+     dprint0("BindTable="); dprint(BindTable);
+     return tr_apply_function0(Q,BindTable);
+  }
+  if (type(F) != 4) return F;
+  Node = qt_node(F);
+  N = qt_nchild(F);
+  Ans = Node;
+  for (I=0; I<N; I++) {
+    T = tr_rp(qt_child(F,I),P,Q);
+    Ans = append(Ans,[T]); 
+  }
+  return Ans;
+}
+
+/* ["f","x"],[["x",[internal,3]]]  の時は
+   f(3) を計算する.
+*/
+def tr_apply_function0(Q,BindTable) {
+  B = [ ];
+  N = length(BindTable);
+  /* BindTable の右辺値を quote(...) なる文字列に */
+  for (I=0; I<N; I++) {
+    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 = rtostr(Q[0])+"(";
+  for (I=0; I<N; I++) {
+    X = rtostr(Q[I+1]); /* 変数 */
+    /* binding Table をサーチ */
+    for (J=0; J<M; J++) {
+       Y = rtostr(B[J][0]);
+       if (X == Y) {
+          R = R+B[J][1];
+          if (I != N-1) R = R+",";
+          break;
+       }
+       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+")";
+  dprint0("R="); dprint(R);
+  V=eval_str(R);
+  if (type(V) == 17) return quotetolist(V);
+  else return V;
+}
+
+
+/* L が左規則. R が右規則.  幅優先探索.
+   書き換えをするためのトップレベルの関数 (のひとつ).
+  例: 
+    tr_apply_rule1(quote(1+sin(3*@pi)*sin(@pi/2)),
+                quote(sin(pn("x")*@pi)),
+                ["qt_sin_int","x"]);
+*/
+def tr_apply_rule1(Obj,L,R) {
+  dprint("--------  start of tr_apply_rule1 ------------ ");
+  Obj = quotetolist(Obj);
+  L = quotetolist(L);
+  R = tr_rp(Obj,L,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{ 
+     return 0;
+  }
+  if (type(Z) == 0) return 1;
+  if ((type(Z) == 1) && (ntype(Z) == 0)) return 1;
+  return 0;
+}
+
+/* quote の生成 */
+/* 右規則関数.   0 を戻す. */
+def qt_zero() {
+  return quotetolist(quote(0));
+}
+
+/* 右規則関数.   恒等式 */
+def qt_id(X) {
+  if (type(X) == 17) return quotetolist(X);
+  else return X;
+}
+
+/* ------------  test --------------------------- */
+extern Rule_test2$
+/* " " と付けてもつけなくてもよい. 内部で 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"]];
+  R0 = quote(1+sin(sin(2*@pi)*@pi)*sin(@pi/2));
+  print(print_input_form(R0));
+  R=tr_apply_rule1(R0,Rule1[0],Rule1[1]);
+  print(print_input_form(R));
+  print("-----------------------");
+  /* 次のように書くと深さ優先で書ける */
+  R0 = quote(1+sin(sin(2*@pi)*@pi)*sin(@pi/2));
+  print(print_input_form(R0));
+  R=tr_apply_rule1(R0,Rule_test2[0],Rule_test2[1]);
+  print(print_input_form(R));
+}
+
+/* 右規則関数.  sin(整数*@pi) を 0 に */
+def qt_sin_int(X) {
+  /* いま X は quote 型 */
+  Y = quotetolist(X);
+  /* Todo: このようなものを作る機能は組み込みで欲しい. */
+  R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
+  print(R);
+  R = eval_str(R);
+  /* Todo: X が 数字かどうか調べる機能も組み込みで欲しい.
+  */
+  if (Y[0] == "internal") {
+     Z = eval_str(rtostr(Y[1]));
+  }else{ 
+    return quotetolist(R);
+  }
+  if (type(Z) == 0) return quotetolist(quote(0));
+  if ((type(Z) == 1) &&   (ntype(Z) == 0)) return quotetolist(quote(0));
+  return quotetolist(R);
+}
+
+/* 右規則関数.  sin(整数*@pi) を 0 に. 深さ優先用 */
+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("+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_is_dependent(quotetolist(quote(1+1/x)),x)
+*/
+def qt_is_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_is_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+")");
+}
+
+/* Index 付き変数を実現する */
+def idxtov(V,I) {
+  if (type(I) == 5) I=vtol(I); 
+  if (type(I) != 4) I=[I];
+  if (type(V) != 2) V=rtostr(V);
+  return util_v(V,I);
+}
+
+def vtoidx(V) {
+  A = util_index(V);
+  if (length(A[1]) == 0) return [A[0]];
+  if (length(A[1]) == 1) return [A[0],A[1][0]];
+  return A;
+}
+
+/* これら以外のテストプログラムは test1-tr.rr を 
+*/
+
+end$
\ No newline at end of file