[BACK]Return to tr.rr CVS log [TXT][DIR] Up to [local] / OpenXM / src / asir-contrib / testing

Diff for /OpenXM/src/asir-contrib/testing/tr.rr between version 1.2 and 1.6

version 1.2, 2005/04/02 05:56:57 version 1.6, 2005/04/21 10:54:50
Line 1 
Line 1 
 /* $OpenXM$ */  /* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.5 2005/04/15 12:47:14 takayama Exp $ */
 /* $Id$ */  /* $Id$ */
   
 /*  /*
Line 20  def dprint0(X) {
Line 20  def dprint0(X) {
   if (Debug) print(X,0);    if (Debug) print(X,0);
 }  }
   
   /* quotetolist $B$N5U4X?t(B. $B$?$@$7J8;zNs$G(B */
   def listtoquote_str(L) {
     return quote_input_form_quote_list(L);
   }
   
 def qt_node(F) {  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 */  /* Number of  child */
 def qt_nchild(F) {  def qt_nchild(F) {
      if (type(F) == 17) F=quotetolist(F);
    return length(F)-2;     return length(F)-2;
 }  }
 def qt_child(F,K) {  def qt_child(F,K) {
      if (type(F) == 17) F=quotetolist(F);
    return F[K+2];     return F[K+2];
 }  }
   
Line 48  def tr_match0(F,P)  {
Line 55  def tr_match0(F,P)  {
   }    }
   Node = qt_node(F);    Node = qt_node(F);
   Node2 = qt_node(P);    Node2 = qt_node(P);
   if (Node2 == ["function","pn"]) return 2;    /* pn $B$K2?$N@)Ls$b$J$1$l$P(B 2 $B$rLa$9(B. */
     if (Node2 == ["function","pn"]) return tr_check_pn(F,P);
   if (Node != Node2) return 0;    if (Node != Node2) return 0;
   N = qt_nchild(F);    N = qt_nchild(F);
   if (N != qt_nchild(P)) return 0;    if (N != qt_nchild(P)) return 0;
Line 60  def tr_match0(F,P)  {
Line 68  def tr_match0(F,P)  {
   return 1;    return 1;
 }  }
   
   /*
      P $B$NNc(B: P = pn("x");  P=pn("x",qt_is_integer(x));
      P $B$O(B [function,pn,[internal,x],[function,is_int,[internal,x]]]
      FF $B$O(B ["is_int","x"]
      $B%F%9%H%G!<%?(B.
    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 $B$H(B P $B$,(B tr_match0 $B$9$k$H$-(B  bindingTable $B$r$b$I$9(B.  /* F $B$H(B P $B$,(B tr_match0 $B$9$k$H$-(B  bindingTable $B$r$b$I$9(B.
   [[$BJQ?t$NL>A0(B($BJ8;zNs(B), $BCM(B(list)], ...]    [[$BJQ?t$NL>A0(B($BJ8;zNs(B), $BCM(B(list)], ...]
 */  */
Line 71  def tr_make_binding(F,P) {
Line 98  def tr_make_binding(F,P) {
   Node2 = qt_node(P);    Node2 = qt_node(P);
   
   if (Node2 == ["function", "pn"]) {    if (Node2 == ["function", "pn"]) {
      Ans = append(Ans,[[P[2][1],F]]);       Ans = append(Ans,[[rtostr(P[2][1]),F]]);
      return Ans;       return Ans;
   }    }
   N = qt_nchild(F);    N = qt_nchild(F);
Line 118  def tr_apply_function0(Q,BindTable) {
Line 145  def tr_apply_function0(Q,BindTable) {
   N = length(BindTable);    N = length(BindTable);
   /* BindTable $B$N1&JUCM$r(B quote(...) $B$J$kJ8;zNs$K(B */    /* BindTable $B$N1&JUCM$r(B quote(...) $B$J$kJ8;zNs$K(B */
   for (I=0; I<N; I++) {    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);    dprint0("tr_apply_function0: "); dprint(B);
   N = length(Q)-1; /* $B0z?t$N?t(B */    N = length(Q)-1; /* $B0z?t$N?t(B */
   M = length(B);   /*  binding table $B$N%5%$%:(B */    M = length(B);   /*  binding table $B$N%5%$%:(B */
   R = Q[0]+"(";    R = rtostr(Q[0])+"(";
   for (I=0; I<N; I++) {    for (I=0; I<N; I++) {
     X = rtostr(Q[I+1]); /* $BJQ?t(B */      X = rtostr(Q[I+1]); /* $BJQ?t(B */
     /* binding Table $B$r%5!<%A(B */      /* binding Table $B$r%5!<%A(B */
Line 134  def tr_apply_function0(Q,BindTable) {
Line 161  def tr_apply_function0(Q,BindTable) {
           if (I != N-1) R = R+",";            if (I != N-1) R = R+",";
           break;            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+")";    R = R+")";
   dprint0("R="); dprint(R);    dprint0("R="); dprint(R);
   return eval_str(R);    V=eval_str(R);
     if (type(V) == 17) return quotetolist(V);
     else return V;
 }  }
   
   
Line 155  def tr_apply_rule1(Obj,L,R) {
Line 188  def tr_apply_rule1(Obj,L,R) {
   Obj = quotetolist(Obj);    Obj = quotetolist(Obj);
   L = quotetolist(L);    L = quotetolist(L);
   R = tr_rp(Obj,L,R);    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 ------------ ");    dprint("--------  end of tr_apply_rule1 ------------ ");
   return eval_str(RR);    return eval_str(RR);
 }  }
   
 /* quote $B$KBP$9$k(B $B=R8l(B */  /* quote $B$KBP$9$k(B $B=R8l(B */
 def qt_is_integer(Qlist) {  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") {    if (Qlist[0] == "internal") {
      Z = eval_str(rtostr(Qlist[1]));       Z = eval_str(rtostr(Qlist[1]));
   }else{    }else{
Line 180  def qt_zero() {
Line 218  def qt_zero() {
   
 /* $B1&5,B'4X?t(B.   $B91Ey<0(B */  /* $B1&5,B'4X?t(B.   $B91Ey<0(B */
 def qt_id(X) {  def qt_id(X) {
   return quotetolist(X);    if (type(X) == 17) return quotetolist(X);
     else return X;
 }  }
   
 /* ------------  test --------------------------- */  /* ------------  test --------------------------- */
 extern Rule_test2$  extern Rule_test2$
 Rule_test2=[quote(sin(pn("x")*@pi)),["qt_sin_int2","x"]]$  /* " " $B$HIU$1$F$b$D$1$J$/$F$b$h$$(B. $BFbIt$G(B rtostr $B$7$F$k(B. */
   /* Rule_test2=[quote(sin(pn("x")*@pi)),["qt_sin_int2","x"]]$ */
   Rule_test2=[quote(sin(pn(x)*@pi)),[qt_sin_int2,x]]$
   
   
 def test2() {  def test2() {
   /* $BI}M%@hC5:w$N>l9g(B, R0 $B$O(B simplify $B$G$-$:(B.  */    /* $BI}M%@hC5:w$N>l9g(B, R0 $B$O(B simplify $B$G$-$:(B.  */
   Rule1=[quote(sin(pn("x")*@pi)),["qt_sin_int","x"]];    Rule1=[quote(sin(pn("x")*@pi)),["qt_sin_int","x"]];
Line 207  def qt_sin_int(X) {
Line 249  def qt_sin_int(X) {
   /* $B$$$^(B X $B$O(B quote $B7?(B */    /* $B$$$^(B X $B$O(B quote $B7?(B */
   Y = quotetolist(X);    Y = quotetolist(X);
   /* Todo: $B$3$N$h$&$J$b$N$r:n$k5!G=$OAH$_9~$_$GM_$7$$(B. */    /* Todo: $B$3$N$h$&$J$b$N$r:n$k5!G=$OAH$_9~$_$GM_$7$$(B. */
   R = "quote(sin("+quote_input_form_quote_list(Y)+"*@pi))";    R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
   print(R);    print(R);
   R = eval_str(R);    R = eval_str(R);
   /* Todo: X $B$,(B $B?t;z$+$I$&$+D4$Y$k5!G=$bAH$_9~$_$GM_$7$$(B.    /* Todo: X $B$,(B $B?t;z$+$I$&$+D4$Y$k5!G=$bAH$_9~$_$GM_$7$$(B.
Line 227  def qt_sin_int2(X) {
Line 269  def qt_sin_int2(X) {
   /* tr_apply_rule1 $B$r:F5"E*$K$h$V(B. $B$3$NJ}K!$G9=J82r@O$b$+$1$k(B. */    /* tr_apply_rule1 $B$r:F5"E*$K$h$V(B. $B$3$NJ}K!$G9=J82r@O$b$+$1$k(B. */
   X = tr_apply_rule1(X,Rule_test2[0],Rule_test2[1]);    X = tr_apply_rule1(X,Rule_test2[0],Rule_test2[1]);
   Y = quotetolist(X);    Y = quotetolist(X);
   R = "quote(sin("+quote_input_form_quote_list(Y)+"*@pi))";    R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
   print(R);    print(R);
   R = eval_str(R);    R = eval_str(R);
   if (qt_is_integer(Y)) return quotetolist(quote(0));    if (qt_is_integer(Y)) return quotetolist(quote(0));
   else return quotetolist(R);    else return quotetolist(R);
 }  }
   
   /* --------------- end test -----------------------*/
   def qt_replace(F,Rule) {
     return base_replace(F,Rule);
   }
   
   /*  F $B$NCf$KITDj85(B X $B$,4^$^$l$F$$$k$+(B?
       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 $B$NF0:n%F%9%H(B */
   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;
   }
   
   /* $BCm0U(B: @pi  $B$b4X?t07$$(B. */
   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)))     -->
      $B%F%9%H$O(B 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 $B$N;R6!$r(B F $B$GI>2A$9$k(B. */
     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]]);
     }
     /* $B:G8e$K;R6!$r?F(B Q[0],Q[1] $B$GI>2A$7$F$+$i(B F $B$GI>2A(B */
     T = ["function",F,T];
     dprint0("qt_map_arg:T="); dprint(T);
     T = listtoquote_str(T);
     return eval_str("quote("+T+")");
   }
   
   /* Index $BIU$-JQ?t$r<B8=$9$k(B */
   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;
   }
   
 /* $B$3$l$i0J30$N%F%9%H%W%m%0%i%`$O(B test1-tr.rr $B$r(B  /* $B$3$l$i0J30$N%F%9%H%W%m%0%i%`$O(B test1-tr.rr $B$r(B
 */  */
   
   module qt;
   localf dtoq$
   localf qtod$  /* it has not yet been implemented. /
   localf etoq$
   
   /* Distributed polynomial to quote
      qt.dtoq(dp_ptod((x-y)^3,[x,y]),[]);
   */
   def dtoq(F,V) {
     if (F == 0) return quote(0);
     N = length(dp_etov(F));
     if (N > length(V)) {
       for (I=length(V); I<N; I++) {
         V = append(V,[util_v("x",[I+1])]);
       }
     }
     R = 0;
     while (F != 0) {
       T = dp_hm(F);
       F = dp_rest(F);
       C = objtoquote(dp_hc(T));
       E = dp_etov(T);
       Mq = etoq(E,V);
       if (Mq == quote(1)) {
         R = R+C;
       }else{
         if (C == quote(1)) R = R+Mq;
         else if (C == quote(-1)) R = R-Mq;
         else R = R+C*Mq;
       }
     }
     return R;
   }
   /* bug: +-3*x should be -3*x */
   
   def etoq(E,V) {
     N = length(E);
     if (N > length(V)) {
       for (I=length(V); I<N; I++) {
         V = append(V,[util_v("x",[I+1])]);
       }
     }
     II = -1;
     for (I=0; I<N; I++) {
       if (E[I] != 0) { II=I; break; }
     }
     if (II == -1) return quote(1);
     if (E[II] == 1) R=objtoquote(V[II]);
     else {
       R=objtoquote(V[II])^objtoquote(E[II]);
     }
     for (I=II+1; I<N; I++) {
       if (E[I] != 0) {
         if (E[I] == 1) Rt=objtoquote(V[I]);
         else Rt=objtoquote(V[I])^objtoquote(E[I]);
         R = R*Rt;
       }
     }
     return R;
   }
   
   endmodule;
   
 end$  end$
   
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.6
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>