Return to tr.rr CVS log

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

qt.dtoq(F,V) translates a distributed polynomial F into quote.
Example:
    F=dp_ptod((x-y-z)^3,[x,y]);
  qt.dtoq(F,[]);
  quote(x_1^3+-3*x_1^2*x_2+3*x_1*x_2^2-x_2^3+-3*z*x_1^2+6*z*x_1*x_2
        +-3*z*x_2^2+3*z^2*x_1+-3*z^2*x_2+-z^3)

/* $OpenXM: OpenXM/src/asir-contrib/testing/tr.rr,v 1.6 2005/04/21 10:54:50 takayama Exp $ */
/* $Id: tr.rr,v 1.12 2005/04/21 10:53:27 taka Exp $ */

/*  
  OpenXM$BHG$N(B Risa/Asir $B$G<B9T$N$3$H(B. OpenXM $BHG$N4X?t$rMQ$$$k$?$a(B.
*/
/* $Id: tr.rr,v 1.12 2005/04/21 10:53:27 taka Exp $
  $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$
def dprint(X) {
  if (Debug) print(X);
}
def dprint0(X) {
  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) {
   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];
}

/* 
   $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)  {
  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 $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;
  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 $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.
  [[$BJQ?t$NL>A0(B($BJ8;zNs(B), $BCM(B(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 $B$NCf$rI}M%@hC5:w$G8!:w$7$F(B $BCV$-49$($k(B.
   $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, 
   $BFbB&$OCV$-49$($i$l$J$$(B.
   $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) {
  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]]]  $B$N;~$O(B
   f(3) $B$r7W;;$9$k(B.
*/
def tr_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);
  N = length(Q)-1; /* $B0z?t$N?t(B */
  M = length(B);   /*  binding table $B$N%5%$%:(B */
  R = rtostr(Q[0])+"(";
  for (I=0; I<N; I++) {
    X = rtostr(Q[I+1]); /* $BJQ?t(B */
    /* binding Table $B$r%5!<%A(B */
    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 $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)),
                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 $B$KBP$9$k(B $B=R8l(B */
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 $B$N@8@.(B */
/* $B1&5,B'4X?t(B.   0 $B$rLa$9(B. */
def qt_zero() {
  return quotetolist(quote(0));
}

/* $B1&5,B'4X?t(B.   $B91Ey<0(B */
def qt_id(X) {
  if (type(X) == 17) return quotetolist(X);
  else return X;
}

/* ------------  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"]];
  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("-----------------------");
  /* $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]);
  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 */
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]]$
  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 
*/

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$