Return to taka_base.rr CVS log

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

Bug fix: number_eval works for rational functions.

/* $OpenXM: OpenXM/src/asir-contrib/packages/src/taka_base.rr,v 1.38 2021/09/24 22:47:06 takayama Exp $ */
#include "tags.h"

def taka_base_rule_name(I) {
  return strtov("taka_base_v"+rtostr(I));
}

def taka_base_cancel(S) {
  if (type(S) == LIST || type(S) == MATRIX || type(S) == VECTOR) {
    return(map(taka_base_cancel,S));
  }
  if (type(S) == 3) {
    return red(S);
  }else{
    return S;
  }
}

def taka_base_flatten(S) {
/*  RemoveZero = getopt(remove_zero);
  if (type(RemoveZero) == -1) {
    RemoveZero = 0;
  }else{
    RemoveZero = 1;
  } Options should be passed to the subroutine. */
  Ans = [ ];
  if (type(S) == LIST) {
    N = length(S);
    for (I=0; I<N; I++) {
      T = taka_base_flatten(S[I]);
      Ans = append(Ans,T);
    }
    return Ans;
  }
  if (type(S) == VECTOR) {
    N = size(S)[0];
    for (I=0; I<N; I++) {
      T = taka_base_flatten(S[I]);
      Ans = append(Ans,T);
    }
    return Ans;
  }
  if (type(S) == MATRIX) {
    N = size(S)[0];
    M = size(S)[1];
    for (I=0; I<N; I++) {
      for (J=0; J<M; J++) {
        T = taka_base_flatten(S[I][J]);
        Ans = append(Ans,T);
      }
    }
    return Ans;
  }
  return [S];
}

def taka_base_replace(S,Rule) {
  if (type(Rule) == STRUCT) {  /* cf. datatype.rr  struct base_rule*/
    Rule = Rule->Rule;
  }
  N = length(Rule);
  for (I=0; I<N; I++) {
    S = taka_subst(S,Rule[I][0],taka_base_rule_name(I));
  }
  for (I=0; I<N; I++) {
    S = taka_subst(S,taka_base_rule_name(I),Rule[I][1]);
  }
  return S;
}

/*
def taka_subst(S,X,A) {
  if (type(S) == QUOTE) {
    if (type(A) != QUOTE) {
      A = quote_to_quote(A);
    }
  }else{
    return(subst(S,X,A));
  }
  return quote_replace(S,X,A);
}
*/
def taka_subst(S,X,A) {
  if (type(S) == QUOTE) {
    if (type(A) != QUOTE) {
      A = quote_to_quote(A);
    }
  }else{
    return(subst(S,X,A));
  }
  return subst_quote(S,X,A);
}

def taka_base_replace_n(F,L) {
  if ((type(F) == 1) || (type(F)==0)) {
    return F;
  }else if ((type(F) == 2) || (type(F) ==3)) {
    return substr2np(F,L);
  }else if (type(F) == LIST) {
    return map(taka_base_replace_n,F,L);
  }else if ((type(F) == VECTOR) || (type(F)==MATRIX)) {
     return map(taka_base_replace_n,F,L);
  }else return base_replace(F,L);
}

def taka_base_set_minus(A,B) {
  Ans = [ ];
  N = length(A);
  for (I=0; I<N; I++) {
    if (!taka_base_memberq(A[I],B)) {
      Ans = append(Ans,[A[I]]);
    }
  }
  return Ans;
}

def taka_base_set_union(A,B) {
  Ans = [ ];
  N = length(A);
  for (I=0; I<N; I++) {
    if (!taka_base_memberq(A[I],Ans)) {
      Ans = cons(A[I],Ans);
    }
  }
  N = length(B);
  for (I=0; I<N; I++) {
    if (!taka_base_memberq(B[I],Ans)) {
      Ans = cons(B[I],Ans);
    }
  }
  return reverse(vtol(qsort(newvect(length(Ans),Ans))));
}

def taka_base_memberq(A,S) {
  N = length(S);
  for (I=0; I<N; I++) {
    if (type(A) == type(S[I])) {
      if (A == S[I]) return 1;
    }
  }
  return 0;
}

def taka_base_position(A,S) {
  N = length(S);
  for (I=0; I<N; I++) {
    if (type(A) == type(S[I])) {
      if (A == S[I]) return I;
    }
  }
  return -1;
}

def taka_base_subsetq(A,B) {
  /* Better algorithm should be used in the final version. */
  N = length(A);
  for (I=0; I<N; I++) {
    if (!taka_base_memberq(A[I],B)) return 0;
  }
  return 1;
}
def taka_base_subsequenceq(A,B) {
  /* A is a part of B? */
  /* Better algorithm should be used in the final version. */
  NA = length(A);
  NB = length(B);
  if (NA==0) return 1;
  Flag=0;
  for (I=0; I<=NB-NA;I++) {
    if (B[I]==A[0]) {
      Flag=1;
      for (J=1; J<NA; J++) {
	if (B[I+J]!=A[J]) { Flag=0; break; }
      }
      if (Flag) return 1;
    }
  }
  return Flag;
}

def taka_base_intersection(A,B) {
  /* Better algorithm should be used in the final version. */
  Ans = [ ];
  N = length(A);
  for (I=0; I<N; I++) {
    if (taka_base_memberq(A[I],B)) {
      Ans = append(Ans,[A[I]]);
    }
  }
  return Ans;
}

def taka_base_prune(A,S) {
  N = length(S);
  Ans = [ ];
  for (I=0; I<N; I++) {
    if (type(A) == type(S[I])) {
      if (A != S[I])  {
        Ans = append(Ans,[S[I]]);
      }
    }else{
      Ans = append(Ans,[S[I]]);
    }
  }
  return Ans;
}

/*&usage
  Syntax: list base_permutation(list L) :   All permutations of L.
  Example: 
  [771] base_permutation([1,2,3]);
        [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
*/
def taka_base_permutation(L) {
  N = length(L);
  if (N <= 1) {
    return [L];
  }
  Ans = [ ];
  for (I = 0; I<N; I++) {
    C = base_set_minus(L,[L[I]]);
    V = taka_base_permutation(C);
    for (J=0; J<length(V); J++) {
      Ans = append(Ans,[cons(L[I],V[J])]);
    }
  }
  return(Ans);
}

/*&usage
  Syntax: list base_choose(list L,number M) : all subsets of L of size M.
  Example: 
  [841] taka_base_choose([1,2,3,4],2);
        [[4,3],[3,2],[4,2],[2,1],[3,1],[4,1]]
*/
def taka_base_choose(L,M) {
  N = length(L);
  if (length(L) == 0) return [ ];
  if (M < 1) return [ ];
  if (M == 1) {
    A = newvect(N);
    for (I=0; I<N; I++) {
      A[I] = [L[I]];
    }
    return vtol(A);
  }
  V1 = taka_base_choose(cdr(L),M);
  V2 = taka_base_choose(cdr(L),M-1);
  V2 = map(append,V2,[car(L)]);
  return append(V1,V2);
}

def taka_base_subsets_of_size(K,S) {
  if (length(S) < K) return [ ];
  if (K < 0) error("base_subsets_of_size: the size must be non-negative.");
  if (K == 0) return [ ];
  if (K == 1) {
    N = length(S);
    R = [];
    for (I=0; I<N; I++) {
       R = cons([S[I]],R);
    }
    return R;
  }else {
    N = length(S);
    R = []; P = [];
    for (I=0; I<N; I++) {
      P = cons(S[I],P);
      T = taka_base_set_minus(S,P);
      Ri = taka_base_subsets_of_size(K-1,T);
      M = length(Ri);
      for (J=0; J<M; J++) {
        R = cons( cons(S[I],Ri[J]), R);
      }
    }
    return R;
  }
}

def taka_base_real_part(T) {
  if (type(T) <= 1) {
    if (ntype(T) == 4) return real(T);
    else return T;
  }
  if (type(T) == 4 || type(T) == 5) {
    return map(taka_base_real_part,T);
  }  else  return T;
}
def taka_base_imaginary_part(T) {
  if (type(T) <= 1) {
    if (ntype(T) == 4) return imag(T);
    else return 0;
  }
  if (type(T) == 4 || type(T) == 5) {
    return map(taka_base_imaginary_part,T);
  }  else  return T;
}

def taka_base_is_integer(T) {
  if (type(T) == 0) return 1;
  if (type(T) == 1) {
   if (ntype(T) == 0) {
     if (dn(T) == 1) return 1;
   }
  }
  return 0;
}

def taka_base_makelist(Obj,Ksym,S,T) {
  KeepQuote=0;
  Step=1;
  if (type(getopt(qt))>=0) KeepQuote=1;
  if (type(getopt(step))>=0) Step=getopt(step);
  L=[];
  if (type(S) != LIST) {
    for (K=S;K<=T; K += Step) {
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L=cons(O2,L);
      else L=cons(eval_quote(O2),L);
    }
  }else{
    for (;S != []; S = cdr(S)) {
      K=car(S);
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L=cons(O2,L);
      else L=cons(eval_quote(O2),L);
    }
  }
  return(reverse(L));
}


def taka_base_sum(Obj,Ksym,S,T) {
  KeepQuote=0;
  Step=1;
  if (type(getopt(qt))>=0) KeepQuote=1;
  if (type(getopt(step))>=0) Step=getopt(step);
  if (Ksym == 0) {
    L = 0;
    for (I=S; I<=T; I++) L += Obj[I];
    return(L);
  }
  L=0;
  if (type(S) != LIST) {
    for (K=S;K<=T; K += Step) {
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L += O2;
      else L += eval_quote(O2);
    } 
  }else{
    for (;S != []; S=cdr(S)) {
      K=car(S);
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L += O2;
      else L += eval_quote(O2);
    } 
  }
  return(L);
}

def taka_base_product(Obj,Ksym,S,T) {
  KeepQuote=0;
  Step = 1;
  if (type(getopt(qt))>=0) KeepQuote=1;
  if (type(getopt(step))>=0) Step=getopt(step);
  L=1;
  if (type(S) != LIST) {
    for (K=S;K<=T; K += Step) {
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L *= O2;
      else L *= eval_quote(O2);
    }
  }else{
    for (;S != []; S=cdr(S)) {
      K=car(S);
      O2=base_replace(Obj,[[Ksym,K]]);
      if (KeepQuote) L *= O2;
      else L *= eval_quote(O2);
    }
  }
  return(L);
}

def taka_base_str_add(Idx,Name) {
  return(rtostr(Name)+rtostr(Idx));
}
def taka_base_var_list(Name,B,T) {
  D=0;
  if (type(getopt(d))>0) D=1;
  Name=rtostr(Name);
  if (D) Name = "d"+Name;
  L=base_makelist(k,k,B,T);
  L=map(taka_base_str_add,L,Name);
  /* it does not work. base_makelist(quote(eval_str(Name+rtostr(k))),k,B,T);*/
  L=map(eval_str,L);
  return(L);
}

/* 
  taka_base_rebuild_opt(Opt | remove_keys=["hoge","foo"]);
*/ 
def taka_base_rebuild_opt(Opt) {
  Rkeys=getopt(remove_keys);
  if (type(Rkeys) < 0) Rkeys=0;
  if (Rkeys != 0) {
    A = [];
    while (Opt != []) {
      O1 = car(Opt); Opt=cdr(Opt);
      if (! base_memberq(rtostr(O1[0]),Rkeys)) A = cons(O1,A); 
    }
  }else{
    A=Opt;
  }  
  return(A);
}

def taka_base_number_abs(X) {
  if (type(X)<=0) return(X);
  if (type(X) == 1) {
    if (ntype(X)<=1) return((X>0?X:-X));
    if (ntype(X)==3) return((X>0?X:-X));
    if (ntype(X)==4) {
      Val=real(X)^2+imag(X)^2;
      return Val^(1/2);
    }
  }
  printf("taka_base_number_abs(%a) is not implemented.\n",X);
  error("taka_base_number_abs2");
}

def taka_base_number_eval(F) {
  if (type(F)==0) return(F);
  if (type(F)<3) return(eval(exp(0)*F));
  if (type(F)==3) return(taka_base_number_eval(nm(F))/taka_base_number_eval(dn(F)));
  if ((type(F)>=4) && (type(F)<=6)) return(map(number_eval,F));
  return(F); 
}

def taka_base_is_equal(L1,L2) {
  if (type(L1) != type(L2)) return 0;
  if (type(L1) < 4) return (L1==L2);
  if (type(L1) == 9) return (L1==L2);  /* dist poly */
  if ((type(L1) >= 4) && (type(L1) <=5)) {
    if (length(L1) != length(L2)) return 0;
    for (I=0; I<length(L1); I++) {  
      if (taka_base_is_equal(L1[I],L2[I]) == 0) return 0;
    }
    return 1;
  }
  if (type(L1) == 6) {
    if (taka_base_is_equal(size(L1),size(L2))) {
       M = size(L1)[0]; N = size(L1)[1];
       for (I=0; I<M; I++) {
         for (J=0; J<N; J++) {
            if (!taka_base_is_equal(L1[I][J],L2[I][J])) return 0;
         }
       }
       return 1;
    }else return 0;
  }
  error("taka_base_is_equal is not implemented for this data type.");
}

def taka_base_f_definedp(Func) {
  Pos = taka_base_position(rtostr(Func),flist());
  if (Pos < 0) return 0;
  return 1;
}

def taka_psubst(S,X,A) {
  if (type(S) == QUOTE) {
    if (type(A) != QUOTE) {
      A = quote_to_quote(A);
    }
  }else{
    return(psubst(S,X,A));
  }
  return subst_quote(S,X,A);
}
def taka_base_preplace(S,Rule) {
  //printf("S=%a, Rule=%a\n",S,Rule);
  if (type(Rule) == STRUCT) {  /* cf. datatype.rr  struct base_rule*/
    Rule = Rule->Rule;
  }
  N = length(Rule);
  for (I=0; I<N; I++) {
    S = taka_psubst(Sorig=S,Rule[I][0],taka_base_rule_name(I));
    //printf("Step1: %a ==> %a\n",Sorig,S);
  }
  for (I=0; I<N; I++) {
    S = taka_psubst(Sorig=S,taka_base_rule_name(I),Rule[I][1]);
    //printf("Step2: %a ==> %a\n",Sorig,S);
  }
  return S;
}

Taka_base_loaded = 1$
end$