OpenXM/src/asir-contrib/testing/tr.rr - diff

Return to tr.rr CVS log

Up to [local] / OpenXM / src / asir-contrib / testing

Diff for /OpenXM/src/asir-contrib/testing/tr.rr between version 1.5 and 1.8

-version 1.5, 2005/04/15 12:47:14
+version 1.8, 2005/05/11 06:40:10
 Line 1
 Line 1
 Line 1
- /* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.4 2005/04/06 09:26:28 takayama Exp $ */
+ /* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.7 2005/05/04 05:47:03 takayama Exp $ */
  /* $Id$ */
  /*
    OpenXM$BHG$N(B Risa/Asir $B$G<B9T$N$3$H(B. OpenXM $BHG$N4X?t$rMQ$$$k$?$a(B.
  */
- /* $Id$
+ /*
    $B$3$N%U%!%$%k$O(B quotetolist $B$G%j%9%H$KJQ49$7$?%G!<%?$KBP$7$F(B
    $B%Q%?!<%s%^%C%A$*$h$S$=$l$r1~MQ$7$?JQ7A$r9T$&(B.
    tr.oxt $B$N;EMM$H$3$H$J$j(B quotetolist $B$GJQ49$7$?$b$N$r07$&(B.
    $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))
  */
  extern Debug$
  Debug=0$
+ extern Debug2$  /* For tr.apply_or_rules. $B$H$F$bJXMx(B. */
+ Debug2=0$
  def dprint(X) {
    if (Debug) print(X);
  }
  def dprint0(X) {
    if (Debug) print(X,0);
  }
+ extern Debug2$
+ Debug2=0$
  /* quotetolist $B$N5U4X?t(B. $B$?$@$7J8;zNs$G(B */
  def listtoquote_str(L) {
    return quote_input_form_quote_list(L);
  }
+ /* quotetolist $B$N5U4X?t(B. quote $B$rLa$9(B */
+ def listtoquote(L) {
+   return eval_str("quote("+quote_input_form_quote_list(L)+")");
+ }
- def qt_node(F) {
+ /* unix $B$N(B uniq $B$KF1$8(B */
-    if (type(F) == 17) F=quotetolist(F);
+ def uniq(L) {
+   N = length(L);
+   if (N > 0) A = [L[0]]; else A=[];
+   for (I=1; I<N; I++) {
+     if (A[0] != L[I]) A=cons(L[I],A);
+   }
+   return reverse(A);
+ }
+ /* Object id */
+ #define O_N 1
+ #define O_P 2
+ #define O_R 3
+ #define O_LIST 4
+ #define O_VECT 5
+ #define O_MAT 6
+ #define O_STR 7
+ #define O_COMP 8
+ #define O_DP 9
+ #define O_USINT 10
+ #define O_ERR 11
+ #define O_GF2MAT 12
+ #define O_MATHCAP 13
+ #define O_F 14
+ #define O_GFMMAT 15
+ #define O_BYTEARRAY 16
+ #define O_QUOTE 17
+ #define O_OPTLIST 18
+ #define O_SYMBOL 19
+ #define O_RANGE 20
+ #define O_TB 21
+ #define O_DPV 22
+ #define O_QUOTEARG 23
+ #define O_VOID -1
+ /* Numbers for the first element of quote_to_funargs */
+ #define I_BOP 0
+ #define I_COP 1
+ #define I_AND 2
+ #define I_OR 3
+ #define I_NOT 4
+ #define I_CE 5
+ #define I_PRESELF 6
+ #define I_POSTSELF 7
+ #define I_FUNC 8
+ #define I_FUNC_OPT 9
+ #define I_IFUNC 10
+ #define I_MAP 11
+ #define I_RECMAP 12
+ #define I_PFDERIV 13
+ #define I_ANS 14
+ #define I_PVAR 15
+ #define I_ASSPVAR 16
+ #define I_FORMULA 17
+ #define I_LIST 18
+ #define I_STR 19
+ #define I_NEWCOMP 20
+ #define I_CAR 21
+ #define I_CDR 22
+ #define I_CAST 23
+ #define I_INDEX 24
+ #define I_EV 25
+ #define I_TIMER 26
+ #define I_GF2NGEN 27
+ #define I_GFPNGEN 28
+ #define I_GFSNGEN 29
+ #define I_LOP 30
+ #define I_OPT 31
+ #define I_GETOPT 32
+ #define I_POINT 33
+ #define I_PAREN 34
+ #define I_MINUS 35
+ #define I_NARYOP 36
+ module qt;
+ localf node $
+ localf nchild $
+ localf child $
+ localf is_integer $
+ localf replace $
+ localf is_dependent $
+ localf is_function $
+ localf map_arg $
+ localf zero $
+ localf id $
+ localf one $
+ localf plus $
+ localf minus $
+ localf sin_int $
+ localf sin_int2 $
+ localf is_rational $
+ localf cancel_number $
+ /*  2/4 $B$,F~$C$F$k$J$i$P(B 1/2 $B$KJQ99$9$k$J$I(B. tkseries.expand1(1/(1-x),...) */
+ localf is_minus $  /* $B@hF,$K(B - $B$,$"$k$+7A<0E*$K$_$k(B. */
+ localf add_paren0 $
+ localf add_paren $ /* +- $BEy$K(B ( ) $B$r2C$($k(B. */
+ localf vars $
+ localf etov_pair$
+ localf hm $
+ localf rest $
+ localf hop $
+ localf input_form $
+ def node(F) {
+    if (type(F) == O_QUOTE) F=quotetolist(F);
     return [rtostr(F[0]),rtostr(F[1])];
  }
  /* Number of  child */
- def qt_nchild(F) {
+ def nchild(F) {
-    if (type(F) == 17) F=quotetolist(F);
+    if (type(F) == O_QUOTE) F=quotetolist(F);
     return length(F)-2;
  }
- def qt_child(F,K) {
+ def child(F,K) {
-    if (type(F) == 17) F=quotetolist(F);
+    if (type(F) == O_QUOTE) F=quotetolist(F);
     return F[K+2];
  }
+ /* quote $B$KBP$9$k(B $B=R8l(B */
+ def is_integer(Qlist) {
+   if (type(Qlist) == O_QUOTE) 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 $B$N@8@.(B */
+ /* $B1&5,B'4X?t(B.   0 $B$rLa$9(B. */
+ def zero() {
+   return quotetolist(quote(0));
+ }
+ /* $B1&5,B'4X?t(B.   $B91Ey<0(B */
+ def id(X) {
+   if (type(X) == O_QUOTE) return quotetolist(X);
+   else return X;
+ }
+ def one() {
+   return quote(1);
+ }
+ def plus(X,Y) {
+   if ((type(X) == O_QUOTE) && (type(Y) == O_QUOTE)) return X+Y;
+   return ["b_op","+",X,Y];
+ }
+ def minus(X,Y) {
+   if ((type(X) == O_QUOTE) && (type(Y) == O_QUOTE)) return X-Y;
+   return ["b_op","-",X,Y];
+ }
+ /* $B1&5,B'4X?t(B.  sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B */
+ def sin_int(X) {
+   /* $B$$$^(B X $B$O(B quote $B7?(B */
+   Y = quotetolist(X);
+   /* Todo: $B$3$N$h$&$J$b$N$r:n$k5!G=$OAH$_9~$_$GM_$7$$(B. */
+   R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
+   print(R);
+   R = eval_str(R);
+   /* Todo: X $B$,(B $B?t;z$+$I$&$+D4$Y$k5!G=$bAH$_9~$_$GM_$7$$(B.
+   */
+   if (Y[0] == "internal") {
+      Z = eval_str(rtostr(Y[1]));
+   }else{
+     return R;
+   }
+   if (type(Z) == 0) return quote(0);
+   if ((type(Z) == 1) &&   (ntype(Z) == 0)) return quote(0);
+   return R;
+ }
+ /* $B1&5,B'4X?t(B.  sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B. $B?<$5M%@hMQ(B */
+ def 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. */
+   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 quote(0);
+   else return R;
+ }
+ def 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 is_dependent(F,X) {
+   if (type(F) == O_QUOTE) 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;
+   }
+ }
+ /* $BCm0U(B: @pi  $B$b4X?t07$$(B. */
+ def is_function(X) {
+   if (type(X) == O_QUOTE) 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 map_arg(F,Q) {
+   F = rtostr(F);
+   if (type(Q) == O_QUOTE) 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+")");
+ }
+ /* ($B7A<0E*$K(B) Q $B$KB0$9$k(B quote $B$+(B? */
+ def is_rational(X) {
+   if (type(X) == O_LIST)  X=listtoquote(X);
+   A = quote_to_funargs(X);
+   if (A[0] == I_FORMULA) {  /* 1, x */
+    if (type(A[1]) <= O_N) return 1;
+    else return 0;
+   }
+   if (A[0] == I_BOP) {  /* 2+3, 2/x */
+     Op = get_function_name(A[1]);
+     if ((Op == "+") || (Op == "-") || (Op == "*") || (Op == "/")
+         || (Op == "^")) {
+        if (qt.is_rational(A[2]) && qt.is_rational(A[3])) return 1;
+        else return 0;
+     }
+   }
+   if (A[0] == I_PAREN) {
+     if (qt.is_rational(A[1])) return 1;
+     else return 0;
+   }
+   if (A[0] == I_MINUS) {
+     if (qt.is_rational(A[1])) return 1;
+     else return 0;
+   }
+   return 0;
+ }
+ /* 2/4 --> 1/2 $B$X(B
+    $B$3$N<BAu$O8zN($O0-$$(B.
+ */
+ def cancel_number(Q) {
+   if (type(Q) == O_LIST)  Q=listtoquote(Q);
+   if (qt.is_rational(Q)) {
+     Ans = eval_quote(Q);
+     return objtoquote(Ans);
+   }
+   A = quote_to_funargs(Q);
+   N = length(A); R=[];
+   for (I=N-1; I>= 0; I--) {
+     if (type(A[I]) == O_QUOTE)
+       R = cons(qt.cancel_number(A[I]),R);
+     else
+       R = cons(A[I],R);
+   }
+   return funargs_to_quote(R);
+ }
+ /* $B@hF,$K(B - $B$,$"$k$+7A<0E*$K$_$k(B.
+    -a+b
+    -3
+    -34/y $BEy(B.
+ */
+ def is_minus(Q) {
+   if (type(Q) == O_LIST)  Q=listtoquote(Q);
+   A = quote_to_funargs(Q);
+   if (A[0] == I_MINUS) return 1;
+   if (A[0] == I_BOP) {
+     if (qt.is_minus(A[2])) return 1;
+     else return 0;
+   }
+   return 0;
+ }
+ /* $BL5>r7o$K(B ( ) $B$r2C$($k(B. */
+ def add_paren0(Q) {
+   A = [I_PAREN,Q];
+   return funargs_to_quote(A);
+ }
+ /* +- $BEy$K(B ( ) $B$r2C$($k(B.
+    $BF0:n$,IT?3$J$N$G(B bug $B$,$"$k$+$b(B.
+ */
+ def add_paren(Q) {
+   if (type(Q) == O_LIST)  Q=listtoquote(Q);
+   A = quote_to_funargs(Q);
+   /* $B$3$N=hM}$OKhEY;H$&$N$G$^$H$a$?J}$,$$$$$N$G$O(B? */
+   N = length(A); R=[];
+   for (I=N-1; I>= 0; I--) {
+     if (type(A[I]) == O_QUOTE)
+       R = cons(qt.add_paren(A[I]),R);
+     else
+       R = cons(A[I],R);
+   }
+   A = R;
+   if (A[0] == I_BOP) {
+      if (get_function_name(A[1]) == "+") {
+         if (qt.is_minus(A[3])) {  /* x+-y ==> x+(-y) */
+            A2 = [I_BOP,A[1],
+                   qt.add_paren(A[2]),
+                   qt.add_paren0(A[3])];
+            return funargs_to_quote(A2);
+         }
+      }else if (get_function_name(A[1]) == "*" ||
+                get_function_name(A[1]) == "/")
+      {
+         if (qt.is_minus(A[2])) {  /* -x*y ==> (-x)*y */
+            A2 = [I_BOP,A[1],
+                   qt.add_paren0(A[2]),
+                   qt.add_paren(A[3])];
+            return funargs_to_quote(A2);
+         }
+      }
+   }
+   return funargs_to_quote(A);
+ }
+ /* vars $B$N??;w(B.
+    $B$3$N4X?t$b(B $BJQ?t$N=P8=2s?tJ,$N%j%9%H$r:n$k$N$G8zN($o$k$$(B.
+  */
+ def vars(Q) {
+   R = [ ];
+   if (type(Q) == O_LIST)  Q=listtoquote(Q);
+   A = quote_to_funargs(Q);
+   if (A[0] == I_FORMULA) {
+     if (type(A[1]) == O_P) {
+        R = cons(A[1],R);
+     }
+   }
+   /* $B$3$N=hM}$OKhEY;H$&$N$G$^$H$a$?J}$,$$$$$N$G$O(B? */
+   N = length(A);
+   for (I=1; I<N; I++) {
+     if (type(A[I]) == O_QUOTE)
+       R = append(qt.vars(A[I]),R);
+   }
+   R=qsort(R);
+   R=uniq(R);
+   return reverse(R);
+ }
+ /* p^q $B$r:F5"$GC5$7$F(B [p,q] $B$rLa$9(B. */
+ def etov_pair(Q) {
+   R = [ ];
+   if (type(Q) == O_LIST)  Q=listtoquote(Q);
+   A = quote_to_funargs(Q);
+   if (A[0] == I_BOP) {
+     if (get_function_name(A[1]) == "^") {
+        R=[[A[2],A[3]]];
+     }
+   }
+   /* $B$3$N=hM}$OKhEY;H$&$N$G$^$H$a$?J}$,$$$$$N$G$O(B? */
+   N = length(A);
+   for (I=1; I<N; I++) {
+     if (type(A[I]) == O_QUOTE)
+       R = append(qt.etov_pair(A[I]),R);
+   }
+   return R;
+ }
+ /* dp_hm + dp_rest $B$N%"%J%m%8!<(B.
+    $B$?$@$7(B * $BEy(B binary operator $B$G>o$KF0:n(B.
+    $BNc(B:  Q=h*r*r2  --> hm(Q)=h, rest(Q)=r*r2, hop(Q)="*".
+    $B$?$@$7(B rest $B$G(B quote $B$O(B $B:87k9gE*$KJQ99(B. flatten_quote().
+ */
+ def hm(Q) {
+   if (type(Q) == O_LIST) Q = listtoquote(Q);
+   A=quote_to_funargs(Q);
+   if (A[0] == I_BOP) {
+     Op = get_function_name(A[1]);
+     if (Op == "+") {
+       return A[2];
+     }else if (Op == "-") {
+       return A[2];
+     }else if (Op == "*") {
+       return A[2];
+     }else if (Op == "/") {
+       return A[2];
+     }else if (Op == "^") {
+       return A[2];
+     }
+   }
+   return Q;
+ }
+ def rest(Q) {
+   if (type(Q) == O_LIST) Q = listtoquote(Q);
+   A=quote_to_funargs(Q);
+   if (A[0] == I_BOP) {
+     Op = get_function_name(A[1]);
+     if (Op == "+") {
+       return flatten_quote(A[3],"+");
+     }else if (Op == "-") {
+       return "not implented to return -A[3]";
+     }else if (Op == "*") {
+       return flatten_quote(A[3],"*");
+     }else if (Op == "/") {
+       return flatten_quote(A[3],"/");
+     }else if (Op == "^") {
+       return flatten_quote(A[3],"^");
+     }else return 0;
+   }
+   return 0;
+ }
+ def hop(Q) {
+   if (type(Q) == O_LIST) Q = listtoquote(Q);
+   A=quote_to_funargs(Q);
+   if (A[0] == I_BOP) return get_function_name(A[1]);
+   return 0;
+ }
+ def input_form(Q) {
+   T = type(Q);
+   if ((T == O_VECT) || (T == O_MAT)) {
+      Q = matrix_matrix_to_list(Q);
+   }
+   if (type(Q) == O_LIST) {
+     A = [];
+     for (I=length(Q)-1; I>=0; I--) {
+        A = cons(qt.input_form(Q[I]),A);
+     }
+     if ((T == O_VECT) || (T == O_MAT)) { A = matrix_list_to_matrix(A); }
+     return A;
+   }
+   if (T == O_QUOTE) return quote_input_form(Q);
+   return rtostr(Q);
+ }
+ endmodule$
+ module tr;
+ localf match0$
+ localf check_pn$
+ localf make_binding$
+ localf rp$
+ localf apply_function0$
+ localf apply_rule1$
+ localf rp_flag$
+ localf apply_rule1_flag$
+ localf apply_or_rules$
+ static Rule_test2$   /* int_sin2 $B$,MxMQ(B */
+ /* " " $B$HIU$1$F$b$D$1$J$/$F$b$h$$(B. $BFbIt$G(B rtostr $B$7$F$k(B.
+    . $B$,IU$$$?$iIU$1$k$7$+$J$$(B.
+ */
+ /* Rule_test2=[quote(sin(pn("x")*@pi)),["qt.sin_int2","x"]]$ */
+ Rule_test2=[quote(sin(pn(x)*@pi)),["qt.sin_int2",x]]$
  /*
     $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.
     $B$=$&$G$J$$$+$i(B 0.  $BI}M%@hC5:w(B.
      Todo: P $B$KG$0U4X?t$r4^$`;EAH$_$O$^$@<BAu$7$F$J$$(B.
  */
- def tr_match0(F,P)  {
+ def match0(F,P)  {
-   dprint0("tr_match0: F="); dprint(F);
+   dprint0("tr.match0: F="); dprint(F);
-   dprint0("tr_match0: P="); dprint(P);
+   dprint0("tr.match0: P="); dprint(P);
    if (type(F) != type(P)) return 0;
-   if (type(F) != 4) {
+   if (type(F) == O_QUOTE) {F=quotetolist(F); P=quotetolist(P);}
+   if (type(F) != O_LIST) {
      if (F == P) return 1;
      else return 0;
    }
-   Node = qt_node(F);
+   Node = qt.node(F);
-   Node2 = qt_node(P);
+   Node2 = qt.node(P);
    /* 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 (Node2 == ["function","pn"]) return tr.check_pn(F,P);
    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;
    for (I=0; I<N; I++) {
-      C = qt_child(F,I);
+      C = qt.child(F,I);
-      C2 = qt_child(P,I);
+      C2 = qt.child(P,I);
-      if (!tr_match0(C,C2)) return 0;
+      if (!tr.match0(C,C2)) return 0;
    }
    return 1;
  }
  /*
-    P $B$NNc(B: P = pn("x");  P=pn("x",qt_is_integer(x));
+    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))));
+    tr.check_pn(quote(1/2),quote(pn("x",qt.is_integer(x))));
  */
- def tr_check_pn(F,P) {
+ def check_pn(F,P) {
-   if (type(F) ==17) F=quotetolist(F);
+   if (type(F) ==O_QUOTE) F=quotetolist(F);
-   if (type(P) == 17) P=quotetolist(P);
+   if (type(P) == O_QUOTE) P=quotetolist(P);
-   N=qt_nchild(P);
+   /* print(F);print(P); */
+   N=qt.nchild(P);
    if (N == 1) return 2;
-   X = rtostr(qt_child(P,0)[1]);
+   X = rtostr(qt.child(P,0)[1]);
    BindingTable = [[X,F]];
-   FF = [rtostr(qt_child(P,1)[1]),rtostr(qt_child(P,1)[2][1])];
+   /* FF = [rtostr(qt.child(P,1)[1]),rtostr(qt.child(P,1)[2][1])]; */
-   R = tr_apply_function0(FF,BindingTable);
+   FF = [rtostr(qt.child(P,1)[1])];
+   M = length(qt.child(P,1));
+   for (I=2; I<M; I++) {
+     FF = append(FF,[rtostr(qt.child(P,1)[I][1])]);
+   }
+   /* print(FF); print(BindingTable); */
+   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)], ...]
  */
- def tr_make_binding(F,P) {
+ def make_binding(F,P) {
    Ans = [ ];
    if (F == P) return Ans;
-   Node = qt_node(F);
+   Node = qt.node(F);
-   Node2 = qt_node(P);
+   Node2 = qt.node(P);
    if (Node2 == ["function", "pn"]) {
       Ans = append(Ans,[[rtostr(P[2][1]),F]]);
       return Ans;
    }
-   N = qt_nchild(F);
+   N = qt.nchild(F);
    for (I=0; I<N; I++) {
-      C = qt_child(F,I);
+      C = qt.child(F,I);
-      C2 = qt_child(P,I);
+      C2 = qt.child(P,I);
-      Ans = append(Ans,tr_make_binding(C,C2));
+      Ans = append(Ans,tr.make_binding(C,C2));
    }
    return Ans;
  }
-Line 117  def tr_make_binding(F,P) {
+Line 607  def tr_make_binding(F,P) {
 Line 117  def tr_make_binding(F,P) {
 Line 607  def tr_make_binding(F,P) {
     $B?<$5M%@hC5:w$K$7$?(B --> action $B4X?t$NCf$G:F5"E*$K8F$Y$P?<$5M%@h$H$J$k(B.
     Todo: $B=q$-49$($,$*$3$C$?$+$N%U%i%0(B.
  */
- def tr_rp(F,P,Q) {
+ def rp(F,P,Q) {
-   dprint0("tr_rp, F="); dprint(F);
+   dprint0("tr.rp, F="); dprint(F);
-   dprint0("tr_rp, P="); dprint(P);
+   dprint0("tr.rp, P="); dprint(P);
-   dprint0("tr_rp, Q="); dprint(Q);
+   dprint0("tr.rp, Q="); dprint(Q);
-   if (tr_match0(F,P)) {
+   if (tr.match0(F,P)) {
-      BindTable = tr_make_binding(F,P);
+      BindTable = tr.make_binding(F,P);
       dprint0("BindTable="); dprint(BindTable);
-      return tr_apply_function0(Q,BindTable);
+      return tr.apply_function0(Q,BindTable);
    }
-   if (type(F) != 4) return F;
+   if (type(F) != O_LIST) return F;
-   Node = qt_node(F);
+   Node = qt.node(F);
-   N = qt_nchild(F);
+   N = qt.nchild(F);
    Ans = Node;
    for (I=0; I<N; I++) {
-     T = tr_rp(qt_child(F,I),P,Q);
+     T = tr.rp(qt.child(F,I),P,Q);
      Ans = append(Ans,[T]);
    }
    return Ans;
-Line 140  def tr_rp(F,P,Q) {
+Line 630  def tr_rp(F,P,Q) {
 Line 140  def tr_rp(F,P,Q) {
 Line 630  def tr_rp(F,P,Q) {
  /* ["f","x"],[["x",[internal,3]]]  $B$N;~$O(B
     f(3) $B$r7W;;$9$k(B.
  */
- def tr_apply_function0(Q,BindTable) {
+ def apply_function0(Q,BindTable) {
    B = [ ];
    N = length(BindTable);
    /* BindTable $B$N1&JUCM$r(B quote(...) $B$J$kJ8;zNs$K(B */
    for (I=0; I<N; I++) {
      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 */
    M = length(B);   /*  binding table $B$N%5%$%:(B */
    R = rtostr(Q[0])+"(";
-Line 171  def tr_apply_function0(Q,BindTable) {
+Line 661  def tr_apply_function0(Q,BindTable) {
 Line 171  def tr_apply_function0(Q,BindTable) {
 Line 661  def tr_apply_function0(Q,BindTable) {
    R = R+")";
    dprint0("R="); dprint(R);
    V=eval_str(R);
-   if (type(V) == 17) return quotetolist(V);
+   if (type(V) == O_QUOTE) return quotetolist(V);
    else return V;
  }
-Line 179  def tr_apply_function0(Q,BindTable) {
+Line 669  def tr_apply_function0(Q,BindTable) {
 Line 179  def tr_apply_function0(Q,BindTable) {
 Line 669  def tr_apply_function0(Q,BindTable) {
  /* L $B$,:85,B'(B. R $B$,1&5,B'(B.  $BI}M%@hC5:w(B.
     $B=q$-49$($r$9$k$?$a$N%H%C%W%l%Y%k$N4X?t(B ($B$N$R$H$D(B).
    $BNc(B:
-     tr_apply_rule1(quote(1+sin(3*@pi)*sin(@pi/2)),
+     tr.apply_rule1(quote(1+sin(3*@pi)*sin(@pi/2)),
                  quote(sin(pn("x")*@pi)),
-                 ["qt_sin_int","x"]);
+                 ["qt.sin_int","x"]);
  */
- def tr_apply_rule1(Obj,L,R) {
+ def apply_rule1(Obj,L,R) {
-   dprint("--------  start of tr_apply_rule1 ------------ ");
+   dprint("--------  start of tr.apply_rule1 ------------ ");
    Obj = quotetolist(Obj);
    L = quotetolist(L);
-   R = tr_rp(Obj,L,R);
+   R = tr.rp(Obj,L,R);
-   if (type(R) == 17) R=quotetolist(R);
+   if (type(R) == O_QUOTE) R=quotetolist(R);
    RR = "quote("+listtoquote_str(R)+")";
-   dprint("--------  end of tr_apply_rule1 ------------ ");
+   dprint("--------  end of tr.apply_rule1 ------------ ");
    return eval_str(RR);
  }
- /* quote $B$KBP$9$k(B $B=R8l(B */
+ /* Flag $BIU$-(B $B$N(B tr.rp. $BB0@-$,$J$$$N$G$3$l$G$d$k(B. */
- def qt_is_integer(Qlist) {
+ def rp_flag(F,P,Q) {
-   if (type(Qlist) == 17) Qlist=quotetolist(Qlist);
+   Flag = 0;
-   if ((rtostr(Qlist[0]) == "u_op")  && (rtostr(Qlist[1]) == "-")) {
+   dprint0("tr.rp, F="); dprint(F);
-     return qt_is_integer(cdr(cdr(Qlist))[0]);
+   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 [1,tr.apply_function0(Q,BindTable)];
    }
-   if (Qlist[0] == "internal") {
+   if (type(F) != O_LIST) return F;
-      Z = eval_str(rtostr(Qlist[1]));
+   Node = qt.node(F);
-   }else{
+   N = qt.nchild(F);
-      return 0;
+   Ans = Node;
+   for (I=0; I<N; I++) {
+     T = tr.rp_flag(qt.child(F,I),P,Q);
+     if (T[0] == 1) Flag = 1;
+     Ans = append(Ans,[T[1]]);
    }
-   if (type(Z) == 0) return 1;
+   return [Flag,Ans];
-   if ((type(Z) == 1) && (ntype(Z) == 0)) return 1;
-   return 0;
  }
- /* quote $B$N@8@.(B */
+ /* $B=q$-49$((B flag $BIU$-$N(B tr.apply_rule_flag */
- /* $B1&5,B'4X?t(B.   0 $B$rLa$9(B. */
+ def apply_rule1_flag(Obj,L,R) {
- def qt_zero() {
+   Flag = 0;
-   return quotetolist(quote(0));
+   if (Debug2)
+    print("--------  start of tr.apply_rule1_flag ------------ ");
+   if (Debug2) print(print_input_form(Obj));
+   Obj = quotetolist(Obj);
+   L = quotetolist(L);
+   R = tr.rp_flag(Obj,L,R);
+   Flag=R[0]; R=R[1];
+   if (type(R) == O_QUOTE) R=quotetolist(R);
+   RR = "quote("+listtoquote_str(R)+")";
+   if (Debug2) {print("==> "+RR+"  by  "); print(listtoquote_str(L));}
+   if (Debug2) print("--------  end of tr.apply_rule1_flag ------------ ");
+   return [Flag,eval_str(RR)];
  }
- /* $B1&5,B'4X?t(B.   $B91Ey<0(B */
+ def apply_or_rules(Q,R) {
- def qt_id(X) {
+   Flag = 1;
-   if (type(X) == 17) return quotetolist(X);
+   N = length(R);
-   else return X;
+   while (Flag) {
+    Flag = 0;
+    for (I=0; I<N; I++) {
+      Q = tr.apply_rule1_flag(Q,R[I][0],R[I][1]);
+      if (Q[0]) {
+        Flag = 1;
+        dprint("Applied the rule "+rtostr(I));
+      }
+      Q = Q[1];
+    }
+   }
+   return Q;
  }
+ endmodule$
+ /* tr $B$N=q$-49$(%k!<%k(B */
+ module tr;
+ localf simp_zero$
+ localf simp_unary$
+ localf simp_sin$
+ /* 0+any, 0*any $B$K$J$k(B quote $B$r(B 0 $B$K$9$k(B. $BI,?\(B. cf. taka_series.expand1
+    test_0();  $B$G%F%9%H$9$k(B.
+ */
+ def simp_zero(R0) {
+   Rule1=[quote(0*pn(y)),       ["qt.zero"]];       /* 0*any --> 0 */
+   Rule2=[quote(pn(y)*0),       ["qt.zero"]];       /* any*0 --> 0 */
+   Rule3=[quote(0/pn(y)),       ["qt.zero"]];       /* 0/any --> 0 */
+   Rule4=[quote(pn(y)+0),       ["qt.id",y]];       /* any+0 --> any */
+   Rule5=[quote(0+pn(y)),       ["qt.id",y]];       /* 0+any --> any */
+   Rule6=[quote(-0),            ["qt.zero",y]];       /* -0 --> 0 */
+   Rule7=[quote((0)),            ["qt.zero",y]];       /* (0) --> 0 */
+   Rule8=[quote(1*pn(y)),       ["qt.id",y]];       /* 1*any --> any */
+   Rule9=[quote(pn(y)*1),       ["qt.id",y]];       /* any*1 --> any */
+   R=tr.apply_or_rules(R0,[Rule1,Rule2,Rule3,Rule4,Rule5, Rule6,Rule7,
+                           Rule8, Rule9]);
+   return R;
+ }
+ def simp_unary(R0) {
+   Rule1=[quote(pn(x))+quote(-pn(y)), ["qt.minus",x,y]];  /* x+-y -> x-y */
+   Rule2=[quote(-(-pn(x))), ["qt.id",x]];  /* -(-x) --> x */
+   Rule3=[quote(pn(x)-(-pn(y))), ["qt.plus",x,y]];  /* x-(-y) --> x+y */
+   R=tr.apply_or_rules(R0,[Rule1,Rule2,Rule3]);
+   return R;
+ }
+ /*
+   test_1() $B$O%5%s%W%k%F%9%H(B.
+ */
+ def simp_sin(R0) {
+   Rule1=[quote(sin(pn(x)*@pi)),["qt.sin_int",x]]; /* sin($B@0?t(B*@pi) --> 0 */
+   Rule2=[quote(0*pn(y)),       ["qt.zero"]];       /* 0*any --> 0 */
+   Rule3=[quote(pn(y)*0),       ["qt.zero"]];       /* any*0 --> 0 */
+   Rule4=[quote(pn(y)+0),       ["qt.id",y]];       /* any+0 --> any */
+   Rule5=[quote(0+pn(y)),       ["qt.id",y]];       /* 0+any --> any */
+   Rule6=[quote(sin(0)),        ["qt.zero"]];       /* sin(0) --> 0 */
+   Rule7=[quote(cos(0)),        ["qt.one"]];         /* cos(0) --> 1 */
+   /* print(print_input_form(R0)); */
+   R=tr.apply_rule1_flag(R0,Rule1[0],Rule1[1]);
+   /* print([R[0],print_input_form(R[1])]); */
+   R=tr.apply_or_rules(R0,[Rule1,Rule2,Rule3,Rule4,Rule5,Rule6,Rule7]);
+   return R;
+ }
+ endmodule$
  /* ------------  test --------------------------- */
- extern Rule_test2$
- /* " " $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() {
    /* $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"]];
    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]);
+   R=tr.apply_rule1(R0,Rule1[0],Rule1[1]);
    print(print_input_form(R));
    print("-----------------------");
    /* $B<!$N$h$&$K=q$/$H?<$5M%@h$G=q$1$k(B */
    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]);
+   R=tr.apply_rule1(R0,Rule_test2[0],Rule_test2[1]);
    print(print_input_form(R));
  }
- /* $B1&5,B'4X?t(B.  sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B */
- def qt_sin_int(X) {
-   /* $B$$$^(B X $B$O(B quote $B7?(B */
-   Y = quotetolist(X);
-   /* Todo: $B$3$N$h$&$J$b$N$r:n$k5!G=$OAH$_9~$_$GM_$7$$(B. */
-   R = "quote(sin("+listtoquote_str(Y)+"*@pi))";
-   print(R);
-   R = eval_str(R);
-   /* Todo: X $B$,(B $B?t;z$+$I$&$+D4$Y$k5!G=$bAH$_9~$_$GM_$7$$(B.
-   */
-   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);
- }
- /* $B1&5,B'4X?t(B.  sin($B@0?t(B*@pi) $B$r(B 0 $B$K(B. $B?<$5M%@hMQ(B */
+ /* tr.check_pn $B$NF0:n%F%9%H(B */
- 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. */
-   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 $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]]$
+   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]);
+   R=tr.apply_rule1(R0,Rule[0],Rule[1]);
    return R;
  }
- /* $BCm0U(B: @pi  $B$b4X?t07$$(B. */
+ /* tr.simp_zero $B$N%F%9%H(B */
- def qt_is_function(X) {
+ def test_0() {
-   if (type(X) == 17) X=quotetolist(X);
+   F = quote(x+(0*x+0));
-   if (rtostr(X[0]) == "function") return 1;
+   print(quote_input_form(F));
-   else return 0;
+   return tr.simp_zero(F);
  }
- /* qt_map_arg(nn,quote(f(x,y)))  --> nn(f(nn(x),nn(y)))
+ /* tr.simp_sin $B$N%F%9%H(B */
-    qt_map_arg(nn,quote(1/4+f(x)))     -->
+ def test_1() {
-    $B%F%9%H$O(B test4().
+   F = quote(sin(sin(0))+sin(0));
- */
+   print(quote_input_form(F));
- def qt_map_arg(F,Q) {
+   return tr.simp_sin(F);
-   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(I) != O_LIST) I=[I];
    if (type(V) != 2) V=rtostr(V);
    return util_v(V,I);
  }
-Line 359  def vtoidx(V) {
+Line 854  def vtoidx(V) {
 Line 359  def vtoidx(V) {
 Line 854  def vtoidx(V) {
    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$r8+$h(B.
  */
+ module qt;
+ localf dtoq$
+ localf qtod$  /* it has not yet been implemented. */
+ localf etoq$
+ localf hc_etov$
+ /* 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));
+     if (qt.is_minus(C)) {
+       C = qt.add_paren0(C);
+     }
+     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 flatten_quote(R,"+");
+ }
+ 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 flatten_quote(R,"*");
+ }
+ def hc_etov(Q,V) {
+   HC=quote(1);
+   N = length(V);
+   E = newvect(N);
+   while (type(Q) != 0) {
+     Q = flatten_quote(Q,"*");
+     A = quote_to_funargs(Q);
+     Sign = 1;
+     if (A[0] == I_MINUS) {
+       Sign = -1;
+       Q = A[1];
+     }
+     Q = flatten_quote(Q,"*");
+     Op=qt.hop(Q);
+     if (Op != "*") {
+       F=Q; if (Sign == -1) F = quote((-1))*F;
+       Q=0;
+     }else{
+       F=qt.hm(Q); if (Sign == -1) F = quote((-1))*F;
+       Q=qt.rest(Q);
+     }
+     print(quote_input_form(F));
+     print(Op);
+     print(quote_input_form(Q));
+     Const = 1;
+     for (I=0; I<N; I++) {
+       if (qt.is_dependent(F,V[I])) {
+         Const = 0;
+         EE=qt.etov_pair(F);
+         if (EE != []) E[I] = EE[0][1];
+         else E[I] = quote(1);
+       }
+     }
+     if (Const) HC=HC*F;
+   }
+   return [HC,E];
+ }
+ endmodule;
  end$

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>