/*
** copyright (c) 1995 Birk Huber
*/
#include "pelproc.h"
Gen_node PROC_ADD(Gen_node g){
Gen_node res,g1,g2;
int rt;
Gmatrix M=0;
polynomial1 tp1,tp2;
if (Gen_length(g)!=2)
return Rerror("wrong number of arguments to PROC_ADD",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
rt=Common_Type(Gen_type(g1),Gen_type(g2));
switch(rt){
case Int_T: res=INTND(Gen_To_Int(g1)+Gen_To_Int(g2));
break;
case Dbl_T: res=DBLND(Gen_To_Dbl(g1)+Gen_To_Dbl(g2));
break;
case Cpx_T: res=CPXND(Cadd(Gen_To_Cpx(g1),Gen_To_Cpx(g2)));
break;
case Ply_T: tp1=Gen_To_Ply(g1);
tp2=Gen_To_Ply(g2);
res=PLYND(addPPP(tp1,tp2,0));
freeP(tp1);
freeP(tp2);
break;
case Sys_T:
case Mtx_T: if ((Gen_type(g1)==Sys_T || Gen_type(g1)==Mtx_T)&&
(Gen_type(g2)==Sys_T || Gen_type(g2)==Mtx_T))
M=Gmatrix_Dop(Gen_Mtx(g1),Gen_Mtx(g2),PROC_ADD);
if (M==0) return Rerror("Matrices not compatable",g);
if (rt==Sys_T) res=SYSND(M);
else res=GMND(M);
break;
default: res=Rerror("PROC_ADD not defined on its arguments",0);
break;
}
free_Gen_list(g);
return(res);
}
Gen_node PROC_SUB(Gen_node g){
Gen_node res,g1,g2;
int rt;
polynomial1 tp1,tp2;
Gmatrix M=0;
if (Gen_length(g)!=2)
return Rerror("wrong number of arguments to PROC_SUB",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
rt=Common_Type(Gen_type(g1),Gen_type(g2));
switch(rt){
case Int_T: res=INTND(Gen_To_Int(g1)-Gen_To_Int(g2));
break;
case Dbl_T: res=DBLND(Gen_To_Dbl(g1)-Gen_To_Dbl(g2));
break;
case Cpx_T: res=CPXND(Csub(Gen_To_Cpx(g1),Gen_To_Cpx(g2)));
break;
case Ply_T: tp1=Gen_To_Ply(g1);
tp2=Gen_To_Ply(g2);
res=PLYND(subPPP(tp1,tp2,0));
freeP(tp1);
freeP(tp2);
break;
case Sys_T:
case Mtx_T: if ((Gen_type(g1)==Sys_T || Gen_type(g1)==Mtx_T)&&
(Gen_type(g2)==Sys_T || Gen_type(g2)==Mtx_T))
M=Gmatrix_Dop(Gen_Mtx(g1),Gen_Mtx(g2),PROC_SUB);
if (M==0) return Rerror("Matrices not compatable",g);
if (rt==Sys_T) res=SYSND(M);
else res=GMND(M);
break;
default: res=Rerror("PROC_SUB not defined on its arguments",0);
break;
}
free_Gen_list(g);
return(res);
}
Gen_node PROC_SUBM(Gen_node g){
Gen_node res,g1;
Gmatrix M=0;
polynomial1 tp1;
if (Gen_length(g)!=1)
return Rerror("wrong number of arguments to PROC_SUBM",g);
g1=Gen_elt(g,1);
switch (Gen_type(g1)){
case Int_T: res=INTND(-1*Gen_To_Int(g));
break;
case Dbl_T: res=DBLND(-1.0*Gen_To_Dbl(g));
break;
case Cpx_T: res=CPXND(RCmul(-1.0,Gen_To_Cpx(g)));
break;
case Ply_T: tp1=Gen_To_Ply(g);
res=PLYND(mulCPP(Complex(-1.0,0.0),tp1,tp1));
break;
case Sys_T:
case Mtx_T: g1=INTND(-1);
M=Gmatrix_Sop(g1,Gen_Mtx(g),PROC_MUL);
if (M==0) return Rerror("error in unary minus",g);
if (Gen_type(g1)==Sys_T) res=SYSND(M);
else res=GMND(M);
free_Gen_node(g1);
break;
default: res=Rerror("PROC_SUB not defined on its arguments",0);
break;
}
free_Gen_list(g);
return res;
}
Gen_node PROC_MUL(Gen_node g){
Gen_node res,g1,g2,scal,mtx;
int rt,t1,t2;
polynomial1 tp1,tp2;
Gmatrix M=0;
if (Gen_length(g)!=2)
return Rerror("wrong number of arguments to PROC_MUL",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
rt=Common_Type(t1=Gen_type(g1),t2=Gen_type(g2));
switch(rt){
case Int_T: res=INTND(Gen_To_Int(g1)*Gen_To_Int(g2));
break;
case Dbl_T: res=DBLND(Gen_To_Dbl(g1)*Gen_To_Dbl(g2));
break;
case Cpx_T: res=CPXND(Cmul(Gen_To_Cpx(g1),Gen_To_Cpx(g2)));
break;
case Ply_T: tp1=Gen_To_Ply(g1);
tp2=Gen_To_Ply(g2);
res=PLYND(mulPPP(tp1,tp2,0));
freeP(tp1);
freeP(tp2);
break;
case Sys_T:
case Mtx_T:if (t1==t2){
M=Gmatrix_Mop(Gen_Mtx(g1),Gen_Mtx(g2),
(res=INTND(0)),PROC_ADD,PROC_MUL);
free_Gen_node(res);
if (M==0) res= Rerror("Incompatible matrices in MUll",0);
if (rt==Sys_T) res=SYSND(M);
else res=GMND(M);
}
else {
if (t1!=Mtx_T){
scal=copy_Gen_node(g1);
mtx=g2;
}
else {
scal=copy_Gen_node(g2);
mtx=g1;
}
M=Gmatrix_Sop(scal,Gen_Mtx(mtx),PROC_MUL);
free_Gen_node(scal);
if (M==0) res =Rerror("Incompatible matrices in Mull",0);
if (rt==Sys_T) res=SYSND(M);
else res=GMND(M);
}
break;
default: res=Rerror("PROC_MUL not defined on its arguments",0);
break;
}
free_Gen_list(g);
return(res);
}
Gen_node PROC_DIV(Gen_node g){
Gen_node res,g1,g2;
int rt;
polynomial1 tp1,tp2;
Gmatrix M=0;
if (Gen_length(g)!=2)
return Rerror("wrong number of arguments to PROC_DIV",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
rt=Common_Type(Gen_type(g1),Gen_type(g2));
/* should test for zero */
switch(rt){
case Int_T:
case Dbl_T: res=DBLND(Gen_To_Dbl(g1)/Gen_To_Dbl(g2));
break;
case Cpx_T: res=CPXND(Cdiv(Gen_To_Cpx(g1),Gen_To_Cpx(g2)));
break;
case Ply_T: tp1=Gen_To_Ply(g1);
tp2=Gen_To_Ply(g2); /* should make sure tp2 is a monomial*/
res=PLYND(divMPP(tp2,tp1,0));
freeP(tp1);
freeP(tp2);
break;
case Sys_T:
case Mtx_T: if(Gen_type(g2)!=Mtx_T){
res=PROC_DIV(Link(INTND(1),copy_Gen_node(g2)));
M=Gmatrix_Sop(res,Gen_Mtx(g1),PROC_MUL);
free_Gen_node(res);
if (rt==Sys_T) res=SYSND(M);
res=GMND(M);
}
else res=Rerror("PROC_DIV cannot divide matrices",0);
break;
default: res=Rerror("PROC_DIV not defined on its arguments",0);
break;
}
free_Gen_list(g);
return(res);
}
Gen_node PROC_EXP(Gen_node g)
{
Gen_node res,g1,g2;
int i,ex,ri,ti;
double rd,td;
polynomial1 tp1,tp2;
if ( g==0 || g->next==0 || g->next->next !=0)
return Rerror("wrong number of arguments to PROC_EXP",g);
if (Gen_length(g)!=2)
return Rerror("wrong number of arguments to PROC_DIV",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
if (Can_Be_Int(g2)==TRUE){
ex=Gen_To_Int(g2);
if (Can_Be_Int(g1)==TRUE){
if (ex>=0){
ri=(ti=Gen_To_Int(g1));
for(i=2;i<=ex;i++) ri*=ti;
res=Int_To_Gen(ri);
}
else res=Dbl_To_Gen(pow(Gen_To_Dbl(g1),Gen_To_Dbl(g2)));
}
else if (Can_Be_Dbl(g1)==TRUE){
rd=(td=Gen_To_Dbl(g1));
for(i=2;i<=ex;i++) rd*=td;
res=Dbl_To_Gen(rd);
}
else if (Can_Be_Cpx(g1)==TRUE){
res=Cpx_To_Gen(Cpow(Gen_To_Cpx(g1),ex));
}
else if (Can_Be_Poly(g1)==TRUE){
if (ex<0) res=Rerror("can not divide polynomial1s",0);
else {
tp1=Gen_To_Ply(g1);
tp2=expIPP(ex,tp1,0);
res=Ply_To_Gen(tp2);
freeP(tp2);
freeP(tp1);
}
}
else res=Rerror("Exp not defined on its arguments",0);
}
else if (Can_Be_Dbl(g2)==TRUE && Can_Be_Dbl(g1)==TRUE){
res=Dbl_To_Gen(pow(Gen_To_Dbl(g1),Gen_To_Dbl(g2)));
}
else res=Rerror("Exp not defined on its arguments",0);
free_Gen_list(g);
return(res);
}
Gen_node PROC_SET(Gen_node g)
{
Gen_node res,g1,g2;
Sym_ent ent;
if (Gen_length(g)!=2)
return Rerror("wrong number of argument to PROC_SET",g);
g1=Gen_elt(g,1);
g2=Gen_elt(g,2);
if ( Gen_type(g2) == Err_T) {
free_Gen_node(g1);
g1=IDND("ANS");
}
switch(Gen_type(g1)){
case Idf_T:
ent=Slookup(Gen_idval(g1));
if (ent!=0){
if (locked(ent)!=0)
return Rerror("can not reset reserved word",g);
free_Gen_list(ent->def);
ent->def=g2;
}
else ent=install(Gen_idval(g1),g2);
free_Gen_node(g1);
res=ent->def;
break;
default:
res=Rerror("first arg to PROC_SET must be itentifyer",g);
break;
}
return res;
}
Gen_node PROC_EXIT(Gen_node g)
{
empty_symbol_table();
if(Def_Ring!=0) free_Pring(Def_Ring);
node_free_store();
exit(0);
return g;
}
Gen_node Set_Ring(Gen_node g)
{
Pring R;
polynomial1 tp;
int n=0;
Gen_node pt,pt1;
pt=g;
while(pt!=0) {
n++;
pt=Gen_next(pt);
}
R=makePR(n-1);
n=0;
pt=g;
while(n<ring_dim(R)) {
tp=makeP(R);
*poly_coef(tp)=Complex(1.0,0.0);
*poly_exp(tp,n+1)=1;
pt1=PLYND(tp);
install(pt->Genval.idval,pt1);
ring_set_var(R,n,Gen_idval(pt));
n++;
pt=Gen_next(pt);
}
tp=makeP(R);
*poly_coef(tp)=Complex(1.0,0.0);
*poly_def(tp)=1;
pt1=PLYND(tp);
install(pt->Genval.idval,pt1);
ring_set_def(R,Gen_idval(pt));
free_Gen_list(g);
Def_Ring=R;
N=ring_dim(R);
return IDND("You have tried to print the Gen_node containing the Default Ring");
}
Gen_node PROC_LUP(Gen_node g)
{ Sym_ent nd;
Gen_node res,g1;
if (Gen_length(g)!=1||Gen_type(g1=Gen_elt(g,1))!=Idf_T)
return Rerror("null or non identifier passed to PROC_LUP",g);
nd=Slookup(Gen_idval(g));
if ( nd == 0 ) return g;
free_Gen_node(g);
res=copy_Gen_list(nd->def);
return res;
}
Gen_node PROC_LAC(Gen_node g)
{
Gen_node res,g1;
int targ;
if (Gen_length(g)!=2 ||
Can_Be_List(Gen_elt(g,1))!=TRUE ||
Gen_type(Gen_elt(g,2))!=Int_T)
return Rerror("PROC_LAC wrong number of arguments",g);
g1=Gen_lval(Gen_elt(g,1));
targ=Gen_To_Int(Gen_elt(g,2));
if (targ<1||targ>Gen_length(g1) )
return Rerror("too few elements in list",g);
res=copy_Gen_node(Gen_elt(g1,targ));
free_Gen_list(g);
return res;
}
Gen_node PROC_MAC(Gen_node g)
{
Gmatrix M;
Gen_node g1,g2,g3,res;
int r,c;
if ((Gen_length(g)!=3)||
((Gen_type(g1=Gen_elt(g,1))!=Mtx_T)&&(Gen_type(g1)!=Sys_T))||
(Gen_type(g2=Gen_elt(g,2))!=Int_T)||
(Gen_type(g3=Gen_elt(g,3))!=Int_T))
return Rerror("bad args PROC_MAC",g);
M=Gen_Mtx(g1);
r=Gen_To_Int(g2);
c=Gen_To_Int(g3);
if (1>r || GMrows(M)<r || 1>c || GMcols(M)<c)
return Rerror("bad indices PROC_MAC",g);
res=copy_Gen_list(*GMref(M,r,c));
free_Gen_list(g);
return res;
}
Gen_node PROC_MAT(Gen_node g){
int i=0,j=0,r,c;
Gmatrix M;
Gen_node ptr=g,ptc;
if ((r=Gen_length(ptr))==0||Can_Be_List(ptr)==FALSE)
return Rerror("bad argument to PROC_MAT",g);
c=Gen_length(Gen_lval(ptr));
while((ptr=Gen_next(ptr))!=0){
if (Gen_length(Gen_lval(ptr))!=c) return Rerror("Bad Arg to Proc_mat",g);
}
M=Gmatrix_new(r,c);
ptr=g;
while(ptr!=0){
i++; j=0;
ptc=Gen_lval(ptr);
while(ptc!=0){
++j;
*GMref(M,i,j)=copy_Gen_node(ptc);
ptc=Gen_next(ptc);
}
ptr=Gen_next(ptr);
}
free_Gen_list(g);
return GMND(M);
}
syntax highlighted by Code2HTML, v. 0.9.1