Logo Search packages:      
Sourcecode: gambit version File versions  Download package

pelprgen.cc

/*
**  Proc_Gen.c 
**     Commands defining Pelican functions 
** 
**    copyright (c) 1995  Birk Huber
*/

/* This version is obtained from editing by Andy McLennan - 1999 */

#include "pelprgen.h"

/* --------------------------------------------------------------
 Install_Command(Gen_node (*G)(),char *s)
   takes a pointer to a Shell Procedure and a string s, installs
   the pair on the symbol table-- and returns the value of the 
   resulting symbol table entry. 

 Error Conditions: 
    if either G or S are NULL nothing is done and Null is returned
    if Gen_node() fails NULL is returned.
    install will return NULL on some error conditions and this
    will be passed through lock and returned.
                   
--------------------------------------------------------------*/
/*
Sym_ent Install_Command(Gen_node (*G)(),char *s){
    return lock(install(s,PND(G))); 
}
*/

/*----------------------------------------------------------------- 
int Install_Gen_Commands()    
        Uses Install_Command to install all Commands
        On the symbol table. Always returns 1;
  
Error Conditions: None;
-----------------------------------------------------------------*/


/********************************************************************
 Begin Command Definitions
********************************************************************/

/*
** Help Command:
*/
Gen_node G_Help(Gen_node g){
 char *lable;
 if (Gen_length(g)!=1 || (lable=Gen_idval(Gen_elt(g,1)))==0)
   return Rerror("usage: help(topic) where topic is a string",g);
 /*  print_doc(lable); REMOVED */
 free_Gen_list(g);
 g=IDND("");
 return g;
}

/* 
** Aset Command          (tested on poly's)
*/
/* aset psys_to_aset(psys); IN psys.h */
Gen_node G_Aset(Gen_node g){
  psys P;
  aset A=0;
  /*
  if (Gen_length(g)==1&&Can_Be_Vector(g,Ply_T)>0){
  
 
  */
if (Gen_length(g)==1&&Can_Be_Vector(g,Ply_T)>0){
  
P=Gen_to_psys(g);
/*
    free_Gen_list(g);
    */
    A=psys_to_aset(P);

    psys_free(P);

    return ASTND(A);
  }

 return List_To_Aset(g);
}

/* 
** Cayley Triangulation Command      (tested: looses 2 )
**                                (problem probably in cly_triangulate)
*/
Gen_node G_Ctrig(Gen_node g){
  aset A=0,CP=0;
  Ivector T=0;
  int r = 0;
  Gen_node ptr;
  int nargs;
  LOCS(2);
  PUSH_LOC(A);
  PUSH_LOC(CP);
  nargs=Gen_length(g);
  if (  (nargs ==0) ||
        (nargs==1  && Can_Be_Aset(Gen_elt(g,1))!=TRUE)||
        (nargs==2  && (r=Can_Be_Vector(Gen_elt(g,2),Int_T))<0)){
        POP_LOCS();
        return Rerror("Usage: Ctrig(Aset,<Int>)",g);
  }
  A=Gen_aset(Gen_elt(g,1));
  if (nargs==2 ){
     if (r==aset_r(A)) T=Gen_to_Imatrix(Gen_elt(g,2));
     else {
       POP_LOCS();
       return Rerror("Usage: Ctrig(Aset,<Int>)",g);
     }
  }
  
  time0=set_mark();
  CP=cly_triangulate(A,T,TRUE,TRUE); 
#ifdef LOG_PRINT 
 fprintf(stdout /* was Pel_Out */,"\ntime used %d,\n",read_mark(time0))
#endif
;
  free_Gen_list(g);

  if (CP!=0){
     ptr=(g=Imatrix_to_Gen((Imatrix)Car(Car(CP))));
     while((CP=Cdr(CP))!=0) ptr=Gen_set_next(ptr,
                              Imatrix_to_Gen((Imatrix)Car(Car(CP))));
     g=List(g);
  }
  else g=IDND("");

  if (T!=0) Imatrix_free(T);
  POP_LOCS();
  return g;
}

/*
** Cayley Triangulation Command      (tested: looses 2 )
**                                (problem probably in cly_triangulate
)
*/
Gen_node G_GenSolve(Gen_node g, int tweak){
  aset A=0;
  int seed;
  psys Sys;
  /* Cayley_continue(aset,Ivector,node *,int,int); IN cly_all.h */
  node Sols=0;
  Ivector T=0;
  int r;
  int nargs;
  LOCS(2);
  PUSH_LOC(A);
  PUSH_LOC(Sols);
  nargs=Gen_length(g);
  if (  (nargs <2) ||
      (Can_Be_Aset(Gen_elt(g,1))!=TRUE)||
      ((r=Can_Be_Vector(Gen_elt(g,2),Int_T))<0)||
      (nargs>=3  && Can_Be_Int(Gen_elt(g,3))!=TRUE)||
      (nargs>3)){
    POP_LOCS();
    return Rerror("Usage: GenSolve(Aset,<Int>,Int)",g);
  }
  A=Gen_aset(Gen_elt(g,1));
  if (nargs>=2 ){
    if (r==aset_r(A)) T=Gen_to_Imatrix(Gen_elt(g,2));
    else {
      POP_LOCS();
      return Rerror("Usage: GenSolve(Aset,<Int>,Int)",g);
    }
  }
  if (nargs==3) seed=Gen_To_Int(Gen_elt(g,3));
  else seed=20;

  time0=set_mark();
  Sys=Cayley_continue(A,T,&Sols,seed,tweak);
#ifdef LOG_PRINT  
fprintf(stdout /* was Pel_Out */,"\ntime used %d,\n",read_mark(time0))
#endif
;
#ifdef LOG_PRINT
  xpl_fprint(stdout /* was Pel_Out */,Sols)
#endif
;
  free_Gen_list(g);
  g=List(Link(Gen_from_psys(Sys),Xpl_to_Gen(Sols))); 
  if (T!=0) Imatrix_free(T);
  psys_free(Sys);
  POP_LOCS();
  return g;
}



/*
** MSD Command           (not working, not tested)
*/
Gen_node G_MSD(Gen_node g){
  aset A=0,CP=0;
  Ivector T=0;
  int r;
  Gen_node ptr;
  int nargs;
  LOCS(2);
  PUSH_LOC(A);
  PUSH_LOC(CP);
  nargs=Gen_length(g);
  if((nargs!=2) ||
     (Can_Be_Aset(Gen_elt(g,1))!=TRUE)||
     ((r=Can_Be_Vector(Gen_elt(g,2),Int_T))<0)){
       POP_LOCS();
       return Rerror("Usage: Ctrig(Aset,<Int>)",g);
  }
  A=Gen_aset(Gen_elt(g,1));
  if (r==aset_r(A)) T=Gen_to_Imatrix(Gen_elt(g,2));
  else {
    POP_LOCS();
    return Rerror("Usage: Ctrig(Aset,<Int>)",g);
  }

  time0=set_mark();
  CP=MSD(A,T); 
#ifdef LOG_PRINT 
 fprintf(stdout /* was Pel_Out */,"\ntime used %d,\n",read_mark(time0))
#endif
;
  free_Gen_list(g);
  if (CP!=0){
     ptr=(g=Imatrix_to_Gen((Imatrix)Car(Car(CP))));
     while((CP=Cdr(CP))!=0) ptr=Gen_set_next(ptr,
                              Imatrix_to_Gen((Imatrix)Car(Car(CP))));
     g=List(g);
  }
  else g=IDND("");
  if (T!=0) Imatrix_free(T);
  POP_LOCS();
  return g;
}

/*
** Qtrig Command               (tested)
*/
Gen_node G_Qtrig(Gen_node g){
  aset A=0,CP=0;
  Ivector T=0;
  int r = 0;
  Gen_node ptr;
  int nargs;
  LOCS(2);
  PUSH_LOC(A);
  PUSH_LOC(CP);
  nargs=Gen_length(g);
  if ((nargs ==0) ||
      (nargs==1  && Can_Be_Aset(Gen_elt(g,1))!=TRUE )||
      (nargs==2  && (r=Can_Be_Vector(Gen_elt(g,2),Int_T))<0)){
    POP_LOCS();
    return Rerror("Usage: Qtrig(Aset,<Int>)",g);
  }
  A=Gen_aset(Gen_elt(g,1));
  if (nargs==2 ){
    if (r==aset_r(A)) T=Gen_to_Imatrix(Gen_elt(g,2));
    else {
      POP_LOCS();
      return Rerror("Usage: Qtrig(Aset,<Int>)",g);
    }
  }
  time0=set_mark();
  CP=aset_print_subdiv(A,aset_lower_facets(A),T);   

  /*
#ifdef LOG_PRINT 
 fprintf(stdout // was Pel_Out
 ,"\ntime used %d,\n",read_mark(time0))
#endif
;
*/
  /*  -- SUSPICIOUS
 free_Gen_list(g);
 */  
if (CP!=0){
    ptr=(g=Imatrix_to_Gen((Imatrix)Car(Car(CP))));
    while((CP=Cdr(CP))!=0){
      ptr=Gen_set_next(ptr,Imatrix_to_Gen((Imatrix)Car(Car(CP))));
    }
    g=List(g);
  }
  else g=IDND("");
  if (T!=0) Imatrix_free(T);
  POP_LOCS();
  return g;
}


/* 
** Extremal Command                 (tested)
*/
Gen_node G_Extremal(Gen_node g){
  aset A;
  if (Gen_length(g)!=1 || Can_Be_Aset(Gen_elt(g,1))!=TRUE)
        return Rerror("Extremal: Usage Extremal(Ast)",g);
  A=Gen_aset(g);
  time0=set_mark();
  aset_extremal(A);
  /*
#ifdef LOG_PRINT
  fprintf(stdout // was Pel_Out
,"\ntime used %d,\n",read_mark(time0))
#endif
;
*/
  return g;
}

/*
** UnLift Command         (tested)
*/
Gen_node G_UnLift(Gen_node g){
  Gen_node ptr;
  psys M;




  if (Gen_length(g)==1){
    switch (Gen_type(g)){
       case Ast_T: aset_unlift(Gen_aset(g));
                   return g;
                   break;
       case Ply_T: unliftP(Gen_poly(g));
                   return g;
                   break;
       case Sys_T:
       case Mtx_T: if (Can_Be_Vector(g,Ply_T)>0){
                    M=Gen_to_psys(g);
                /*                    
free_Gen_list(g);
*/                    
psys_lift(M,0);
                    g=Gen_from_psys(M);
                    psys_free(M);
                    return g;
                   }
                   break;
       default: 
          if ( Can_Be_List(g)==TRUE ){
              ptr=Gen_lval(g);
              while(ptr!=0){
                if (Can_Be_Vector(ptr,Dbl_T)<1){
                   return Rerror("Usage: Unlift({<Dbl>})",g);
                 }
                free_Gen_node(*GMref(Gen_Mtx(ptr),1,
                                     GMcols(Gen_Mtx(ptr))));
                *GMref(Gen_Mtx(ptr),1,GMcols(Gen_Mtx(ptr)))=DBLND(0.0);
                 ptr=Gen_next(ptr);
              }
              return g;
          }
          else return Rerror("Usage: Unlift(Aset|<Ply>|{<Dbl>})",g);

    }
  }
return 0; /* not reachable */
}

/*
** Randlift Command          (tested)
*/
Gen_node G_RandLift(Gen_node g){
  aset A;
  /* 
  int seed, low, high;

 if (Gen_length(g)!=4 || 
      Can_Be_Aset(Gen_elt(g,1))!=TRUE||
      Can_Be_Int(Gen_elt(g,2))!=TRUE||
      Can_Be_Int(Gen_elt(g,3))!=TRUE||
      Can_Be_Int(Gen_elt(g,4))!=TRUE)
        return Rerror("Usage: RandLift(Ast,Int,Int,Int)",g);
  A=Gen_aset(Gen_elt(g,1));
  seed=Gen_To_Int(Gen_elt(g,2));
  low=Gen_To_Int(Gen_elt(g,3));
  high=Gen_To_Int(Gen_elt(g,4));
  aset_randlift(A,seed,low,high);
  free_Gen_list(Gen_elt(g,2));
   
 return g;
 */
  
  A=Gen_aset(g);
  aset_randlift(A,10,0,200);
  return g;
}

/*
** Lift Command
*/

/*
** Face Command
*/
Gen_node G_Face(Gen_node g){
  aset A;
  int n;
  Imatrix Norm;
  if (Gen_length(g)==2 &&  Can_Be_Aset(Gen_elt(g,1))==TRUE ) {
     A=Gen_aset(Gen_elt(g,1));
     n=Can_Be_Vector(Gen_elt(g,2),Int_T);
     if (n==aset_dim(A)) {
        Norm=Gen_to_Imatrix(Gen_elt(g,2));
        free_Gen_list(g);
        g=ASTND(aset_face(A,Norm));
        Imatrix_free(Norm);
        return g;
     }
  }
 return Rerror("Usage: Face(Aset,Norm)",g);
}

Gen_node G_Save(Gen_node g){
  FILE *tmp;
  if (Gen_length(g)!=1) return Rerror("Print: too many arguments",g);
  tmp=stdout /* was Pel_Out */;
/*  stdout // was Pel_Out 
=Pel_Log; */
#ifdef LOG_PRINT
  fprintf(stdout /* was Pel_Out */,"\n")
#endif
;                                             
  switch (Gen_type(g)){ 
      case Ast_T:  aset_print(Gen_aset(g));
                    break;                 
      default: print_Gen_node(g);          
  }                              

#ifdef LOG_PRINT
 fprintf(stdout /* was Pel_Out */,"\n")
#endif
;          
 /*  Pel_Log=tmp;  */
 free_Gen_list(g);
 return IDND("");      
 }                     


/* 
** System Command                     (tested)
*/
Gen_node G_System(Gen_node g) { 
  int i,order=0;
  Gmatrix M;
  /*   Gen_node SYSND(); IN gennode.h */
  Gen_node T;

if (Can_Be_Vector(Gen_elt(g,1),Ply_T)<0){    


return Rerror("System: Usage System(<Ply>)",g);
  }
 


 M=Gmatrix_copy(Gen_Mtx(g));
 
  free_Gen_list(g);
  while (order==0){
     order=1;
     for(i=1;i<GMcols(M);i++){


     if (orderPP(Gen_poly(*GMref(M,1,i)),
                 Gen_poly(*GMref(M,1,i+1)))<0){
           order=0;
           T=*GMref(M,1,i+1);
           *GMref(M,1,i+1)=*GMref(M,1,i);
           *GMref(M,1,i)=T;
           
  }
  
     }
 }
return SYSND(M);
}

/* 
** GenPoly Command         (tested)
*/
psys aset_to_psys(aset,Ivector,int);
Gen_node G_Gen_Poly(Gen_node g){
  aset A;
  Ivector I;
  int seed,l;
  psys P;
  l=Gen_length(g);
  if (
      (l<2) ||
      (l>=2 && Can_Be_Aset(Gen_elt(g,1))!=TRUE
            && Can_Be_Vector(Gen_elt(g,2),Int_T)<1) ||
      (l==3 && Can_Be_Int(Gen_elt(g,3))!=TRUE) ||
      (l>3))
      {
  return Rerror("Usage: GenPoly(Aset,<Int>,[Int]);",g);
  }

   A=Gen_aset(Gen_elt(g,1));
   I=Gen_to_Imatrix(Gen_elt(g,2));
   if (l==3) seed=Gen_To_Int(Gen_elt(g,3));
   else seed=3;
   P=aset_to_psys(A,I,seed);
   free_Gen_list(g);
   g=Gen_from_psys(P);
   psys_free(P);
   Imatrix_free(I);
   return g;
}

/*
** Atype command                        (tested)
*/
Gen_node G_AType(Gen_node g){
  Ivector I;
  psys P;
  if (Gen_length(g)!=1 || Can_Be_Vector(Gen_elt(g,1),Ply_T)<1)
      {
  return Rerror("Usage: AType(<Ply>);",g);
  }
  P=Gen_to_psys(g);
  /* 
 free_Gen_list(g);
 */  
I=psys_type(P);
  g=Imatrix_to_Gen(I);
  Imatrix_free(I);
  psys_free(P);
  return g;
}

/* 
** Continuation Command    (tested)
*/
Gen_node G_Cont(Gen_node g, int tweak){
   psys P;
   node Sl;
   if ( Gen_length(g)!=2||
        Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0||
        Can_Be_List(Gen_elt(g,2))!=TRUE)
        return Rerror("Usage: Cont(PSys,<Dbl>)",g);

   P=Gen_to_psys(Gen_elt(g,1));
   Sl=Gen_to_Dvector_list(Gen_lval(Gen_elt(g,2)));
   time0=set_mark();
   Sl=psys_hom(P,Sl,tweak);
   /*
#ifdef LOG_PRINT 
  fprintf(stdout // was Pel_Out 
,"time used %d,\n",read_mark(time0))
#endif
;
*/  
 free_Gen_list(g);
   psys_free(P);
   return Xpl_to_Gen(Sl);
 }

/*
** Solve Command             (tested)
*/
Gen_node G_Solve(Gen_node g, int tweak){
   psys P;
   node Sl=0,Nl=0;
   /*   char *tmp; UNUSED */
   LOCS(2);
   PUSH_LOC(Sl);
   PUSH_LOC(Nl);
   if ( Gen_length(g)!=2||
        Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0||
        Can_Be_List(Gen_elt(g,2))!=TRUE)
        return Rerror("Usage: Solve(PSys,{<Int>})",g);
   
   P=Gen_to_psys(Gen_elt(g,1));
   Nl=Gen_to_Ivector_list(Gen_lval(Gen_elt(g,2)));
   time0=set_mark();
   while (Nl!=0){
     Sl=list_cat(psys_solve(P,(Imatrix)Car(Car(Nl)),tweak),Sl);
     Nl=Cdr(Nl);
   }
   /*   Pel_New_Log(strcat(FilePrefix,".start")); */
#ifdef G_SOLVE_PRINT 
  fprintf(stdout /* was Pel_Log */,"%% Pelican Output File: Generic System and Solutions\n");

   fprintf(stdout /* was Pel_Log */,"G=");
   psys_fprint(stdout /* was Pel_Log */,P);
   fprintf(stdout /* was Pel_Log */,";\n");
   fprintf(stdout /* was Pel_Log */,"S=\n");
   xpl_fprint(stdout /* was Pel_Log */,Sl);
   /*   Pel_Open_Log(Pel_LogName);  */
   
  
#endif
;
   /*  SUSPICIOUS
 free_Gen_list(g);
 */
  psys_free(P);
   POP_LOCS();
   return Xpl_to_Gen(Sl);
 }

/*
** ParamSet Command                      (tested)
*/

Gen_node G_ParamSet(Gen_node g){
 Gen_node ptr;
 if (g==0) return Rerror("NULL Arg in SetParam",g);
 ptr=g;
  while (ptr!=0){
   if (ptr->type!=Idf_T)
      return Rerror("Expecting Identifier in SetParam",g);
   SET_D_PARAM(Hom_tol)
 /*  SET_I_PARAM(Hom_use_proj) */
   SET_D_PARAM(PN_dt0)
   SET_D_PARAM(PN_maxdt)
   SET_D_PARAM(PN_mindt)
   SET_D_PARAM(PN_scaledt)
   SET_D_PARAM(PN_cfac)
   SET_D_PARAM(PN_NYtol)
   SET_D_PARAM(PN_NDtol)
   SET_D_PARAM(PN_Nratio)
   SET_D_PARAM(PN_tfinal)
   SET_D_PARAM(PN_FYtol)
   SET_D_PARAM(PN_FDtol)
   SET_D_PARAM(PN_Fratio)
   SET_D_PARAM(PN_Nratio)
   SET_I_PARAM(PN_maxsteps)
   SET_B_PARAM(Show_Sys)
   SET_B_PARAM(Show_Xpl)
   SET_S_PARAM(FilePrefix)
   else if (strcmp(ptr->Genval.idval,"Use_Hompack")==0){
    Cont_Alg=USE_HOMPACK;
    ptr=ptr->next;
   }
   else if (strcmp(ptr->Genval.idval,"Use_PNewton")==0){
    Cont_Alg=USE_PNEWTON;
    ptr=ptr->next;
   }
   else return Rerror("Unrecognized Parameter",g);
  }
  free_Gen_list(g);
  return IDND("");
}

#undef SET_D_PARAM
#undef SET_I_PARAM
#undef SET_B_PARAM

/*
** ParamShow Command
*/
#define SHOW_PARAM(Svar,T)\
    else if (strcmp(ptr->Genval.idval,#Svar)==0)\
         fprintf(stdout /* was Pel_Out */,#Svar T,Svar);
#define SHOW_I_PARAM(Svar) SHOW_PARAM(Svar,"=%d")
#define SHOW_D_PARAM(Svar) SHOW_PARAM(Svar,"=%g")
#define SHOW_S_PARAM(Svar) SHOW_PARAM(Svar,"=%s")
#define SHOW_B_PARAM(Svar)\
    else if (strcmp(ptr->Genval.idval,#Svar)==0){\
        if (Svar==TRUE) fprintf(stdout /* was Pel_Out */,#Svar "=TRUE");\
        else fprintf(stdout /* was Pel_Out */,#Svar "=FALSE");\
    }
#define DIS_PARAM(Svar,T) fprintf(stdout /* was Pel_Out */,#Svar T,Svar);


Gen_node G_ParamShow(Gen_node g){
 Gen_node ptr;
 if (g==0) return Rerror("NULL Arg in ShowParam",g);
 ptr=g;
 while (ptr!=0){
   if (ptr->type!=Idf_T)
         return Rerror("Expecting Identifier ShowParam",g);
   SHOW_D_PARAM(Hom_tol)
   SHOW_D_PARAM(PN_dt0)
   SHOW_D_PARAM(PN_maxdt)
   SHOW_D_PARAM(PN_mindt)
   SHOW_D_PARAM(PN_scaledt)
   SHOW_D_PARAM(PN_cfac)
   SHOW_D_PARAM(PN_tfinal)
   SHOW_D_PARAM(PN_NYtol)
   SHOW_D_PARAM(PN_NDtol)
   SHOW_D_PARAM(PN_Nratio)
   SHOW_D_PARAM(PN_FYtol)
   SHOW_D_PARAM(PN_FDtol)
   SHOW_D_PARAM(PN_Fratio)
   SHOW_I_PARAM(PN_maxsteps)
   SHOW_B_PARAM(Show_Sys)
   SHOW_B_PARAM(Show_Xpl)
   SHOW_S_PARAM(FilePrefix)
/*   SHOW_I_PARAM(Hom_use_proj) */
   else if (strcmp(ptr->Genval.idval,"Cont_Alg")==0){
      if (Cont_Alg==USE_HOMPACK)
#ifdef LOG_PRINT
fprintf(stdout /* was Pel_Out */,"Using Hompack")
#endif
;
      else if (Cont_Alg==USE_PNEWTON)
#ifdef LOG_PRINT
fprintf(stdout /* was Pel_Out */,"Using PNewton")
#endif

;
   }
   else if (strcmp(ptr->Genval.idval,"Hom_Params")==0)
      print_Hom_params(stdout /* was Pel_Out */);
   else if (strcmp(ptr->Genval.idval,"PN_Params")==0){
     DIS_PARAM(PN_dt0,"= %g,   ")
     DIS_PARAM(PN_scaledt,"=%g, \n")
     DIS_PARAM(PN_maxdt,"= %g,  ")
     DIS_PARAM(PN_mindt,"= %g\n")
     DIS_PARAM(PN_cfac, "= %g,  ")
     DIS_PARAM(PN_tfinal," = %g,  ")
     DIS_PARAM(PN_maxsteps,"=%d\n")
     DIS_PARAM(PN_NYtol,"= %g,  ")
     DIS_PARAM(PN_NDtol,"= %g,  ")
     DIS_PARAM(PN_Nratio,"= %g\n")
     DIS_PARAM(PN_FYtol,"= %g,  ")
     DIS_PARAM(PN_FDtol,"= %g,  ")
     DIS_PARAM(PN_Fratio,"= %g\n")
   }
   else return Rerror("Unrecognized Parameter",g);
   ptr=ptr->next;
 }
 free_Gen_list(g);
 return IDND("");
}
#undef SHOW_PARAM
#undef SHOW_I_PARAM
#undef SHOW_D_PARAM
#undef SHOW_B_PARAM
#undef DIS_PARAM


/*
** NormSub Command (tested)
*/
Gen_node G_NormSub(Gen_node g){
  psys P;
  Imatrix Nrm;
  if (Gen_length(g)!=2 ||
     (Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0)||
     (Can_Be_Vector(Gen_elt(g,2),Int_T)<=0))
      return Rerror("Usage: NormSub(<Ply>,<Int>)",g);
  P=Gen_to_psys(Gen_elt(g,1));
  Nrm=Gen_to_Imatrix(Gen_elt(g,2));
  P=psys_norm_sub(P,Nrm);
  free_Gen_list(g);
  g=Gen_from_psys(P);
  psys_free(P);
  Imatrix_free(Nrm);
  return g;
}

/*
** Lead Command (tested)
*/
Gen_node G_Lead(Gen_node g){                                 
  psys PS1,PS2;
  if (Gen_length(g)!=1 ||
     (Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0))
      return Rerror("Usage: <Ply> Lead(<Ply>)",g);
  PS1=Gen_to_psys(g);             
  free_Gen_list(g);                 
  PS2=psys_lead(PS1);
  g=Gen_from_psys(PS2);
  psys_free(PS2);
  psys_free(PS1);
  return g;
}

/*
** Verify Command (tested)
*/
Gen_node G_Verify(Gen_node g){
  Gen_node ptr,res,ptc;
  psys PS;
  Dmatrix D;

  if (Gen_length(g)!=2|| 
      Can_Be_Vector(Gen_elt(g,1),Ply_T)<0||
      Can_Be_List(Gen_elt(g,2))!=TRUE)
  return Rerror("Usage: Verify(<Ply>,{<Dbl>}",g);
  PS=Gen_to_psys(Gen_elt(g,1));
  ptr=Gen_lval(Gen_elt(g,2));
  ptc=(res=gen_node());
  while(ptr!=0){
    if (Can_Be_Vector(ptr,Dbl_T)==2*N+3){
       D=Gen_to_Dmatrix(ptr);
       Gen_set_next(ptc,Dbl_To_Gen(psys_abs(PS,D)));
       ptc=Gen_next(ptc);
       Dmatrix_free(D);
    }
    ptr=Gen_next(ptr);
  }
  psys_free(PS);
  /*
  free_Gen_list(g);
  */ 
 g=List(Gen_next(res));
  free_Gen_node(res);
  return g;
}

/*
** Eval Command
*/
Gen_node G_Eval(Gen_node g){
  Gen_node ptr,res,ptc;
  psys PS;
  Dmatrix X=0,Y=0;
  Gmatrix V=0;
  int i,xp;

  if (Gen_length(g)!=2||
      Can_Be_Vector(Gen_elt(g,1),Ply_T)<0||
         ( ((xp=Can_Be_Xpnt(Gen_elt(g,2)))==FALSE) &&
           (Can_Be_List_Of(Gen_elt(g,2),*Can_Be_Xpnt)==FALSE)))
  return Rerror("Usage: Eval(<Ply>,{<Dbl>}",g);
  PS=Gen_to_psys(Gen_elt(g,1));
  if (xp==TRUE) ptr=Gen_elt(g,2);
  else ptr=Gen_lval(Gen_elt(g,2));
  ptc=(res=gen_node());
  while(ptr!=0){
    if (Can_Be_Vector(ptr,Dbl_T)==2*N+3){
       X=Gen_to_Dmatrix(ptr);
       V=Gmatrix_new(1,N);
       Y= psys_eval(PS,X,Y);
       for(i=1;i<=N;i++){
         *GMref(V,1,i)=Cpx_To_Gen(Complex(DVref(Y,2*i-1),DVref(Y,2*i)));
       }
       Gen_set_next(ptc,GMND(V));
       ptc=Gen_next(ptc);
       Dmatrix_free(X);
    }
    ptr=Gen_next(ptr);
  }
  psys_free(PS);
  free_Gen_list(g);
  Dmatrix_free(Y);
  if (xp==TRUE) g=Gen_next(res);
  else  g=List(Gen_next(res));
  free_Gen_node(res);
  return g;
}



/*
** BinSolve Command:  (tested)
*/
Gen_node G_BinSolve(Gen_node g){
   psys P;
   node Sl;
   if ( Gen_length(g)!=1|| Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0)
      return Rerror("Usage: BinSolve(<Ply>)",g);
   P=Gen_to_psys(Gen_elt(g,1));
   time0=set_mark();
   Sl=psys_binsolve(P);
   free_Gen_list(g);
   psys_free(P);
   return Xpl_to_Gen(Sl);
 }

/*
** Scale Command       (tested)
*/
Gen_node G_Scale(Gen_node g){
 psys PS;
 Dmatrix S;
 int l;
 if ( 
    ((l=Gen_length(g))<1)||
    ((l>=1)&&(Can_Be_Vector(Gen_elt(g,1),Ply_T)<=0))||
    ((l>=2)&&(Gen_type(Gen_elt(g,2))!=Idf_T))||
    (l>2))
     return Rerror("Usage: Scale(<Ply>,[Idf])",g);
 PS=Gen_to_psys(g);
 S=psys_scale(PS);
 if (l==2) install(Gen_idval(Gen_elt(g,2)),Dmatrix_to_Gen(S));
 /*
 free_Gen_list(g);
 */ 
g=Gen_from_psys(PS);
 Dmatrix_free(S);
 psys_free(PS);
return g;
}

/* 
** UnScale Command         (tested)
*/
Gen_node G_UnScale(Gen_node g){
 Gen_node ptr, res,rptr;
 Dmatrix scl;
 Dmatrix root = NULL;  /* Initialized to get rid of C++ warning */

 if (g==0 || 
     Gen_length(g)!=2 || 
     Can_Be_Vector(Gen_elt(g,2),Dbl_T)!=N ||
     Can_Be_List(g)!=TRUE)
    
  return Rerror("Usage: UnScale({<Dbl>},<Dbl>)version 1",g);
 
 rptr=(res=gen_node());
 ptr=Gen_lval(g);
 scl=Gen_to_Dmatrix(Gen_elt(g,2));
 while(ptr!=0){
   if (Can_Be_Vector(ptr,Dbl_T)!=2*N+3){
      Dmatrix_free(scl);
      free_Gen_list(Gen_next(res));
      free_Gen_node(res);
       return
        Rerror("Usage: UnScale({<Dbl>},<Dbl>) version 2",g);
     }

  root=Gen_to_Dmatrix(ptr);
  xpnt_unscale(root,scl);
  Gen_set_next(rptr,Dmatrix_to_Gen(root));
  rptr=Gen_next(rptr);
  ptr=Gen_next(ptr);
 }
 /*
 free_Gen_list(g);
 */ 
 g=XPLND(Gen_next(res));
 free_Gen_node(res);
 Dmatrix_free(scl);
 Dmatrix_free(root);
 return g;             
}

/*
** ScaleXPL Command         (tested)
*/
Gen_node G_ScaleXPL(Gen_node g){
 Gen_node ptr, res,rptr;
 Dmatrix scl;
 Dmatrix root = NULL; /* Initialized to get rid of C++ warning. */
 int i;
   
 if (g==0 ||
     Gen_length(g)!=2 ||
     Can_Be_Vector(Gen_elt(g,2),Dbl_T)!=N ||
     Can_Be_List(g)!=TRUE)
     return Rerror("Usage: XScale({<Dbl>},<Dbl>)",g);
    
 rptr=(res=gen_node());
 ptr=Gen_lval(g);
 scl=Gen_to_Dmatrix(Gen_elt(g,2));
 while(ptr!=0){
   if (Can_Be_Vector(ptr,Dbl_T)!=2*N+3){
      Dmatrix_free(scl);
      free_Gen_list(Gen_next(res));
      free_Gen_node(res);
       return
        Rerror("Usage: UnScale({<Dbl>},<Dbl>)",g);
     }
  for(i=1;i<=N;i++){ if (DVref(scl,i)!=0.0) DVref(scl,i)=1.0/DVref(scl,i);}
  root=Gen_to_Dmatrix(ptr);
  xpnt_unscale(root,scl);
  Gen_set_next(rptr,Dmatrix_to_Gen(root));
  rptr=Gen_next(rptr);
  ptr=Gen_next(ptr);
 } 
 /* 
free_Gen_list(g);
*/ 
g=XPLND(Gen_next(res));
 free_Gen_node(res);
 Dmatrix_free(scl);
 Dmatrix_free(root);
 return g;
}



/*
** Affine Command
*/ 
Gen_node G_Affine(Gen_node g){
 Gen_node ptr, res,rptr;
 Dmatrix root;

 
 if (g==0 ||
     Gen_length(g)!=1 ||
     Can_Be_List(g)!=TRUE)
     return Rerror("Usage: Affine({<Dbl>})",g);

 rptr=(res=gen_node());
 ptr=Gen_lval(g);
 while(ptr!=0){
   if (Can_Be_Vector(ptr,Dbl_T)!=2*N+3){
      free_Gen_list(Gen_next(res));
      free_Gen_node(res);
       return
        Rerror("Usage: Affine({<Dbl>})",g);
   }
  root=Gen_to_Dmatrix(ptr);
  xpnt_affine(root);
  Gen_set_next(rptr,Dmatrix_to_Gen(root));
  rptr=Gen_next(rptr);
  ptr=Gen_next(ptr);
 }
 /*
 free_Gen_list(g);
 */ 
g=XPLND(Gen_next(res));
 free_Gen_node(res);
 return g;
}

/*
** Normalize Command
*/
Gen_node G_Normalize(Gen_node g){
 Gen_node ptr, res,rptr;
 Dmatrix root;

 if (g==0 ||
     Gen_length(g)!=1 ||
     Can_Be_List(g)!=TRUE)
     return Rerror("Usage: Normalize({<Dbl>})",g);

 rptr=(res=gen_node());
 ptr=Gen_lval(g);
 while(ptr!=0){
   if (Can_Be_Vector(ptr,Dbl_T)!=2*N+3){
      free_Gen_list(Gen_next(res));
      free_Gen_node(res);
       return
        Rerror("Usage: Normalize({<Dbl>})",g);
   }
  root=Gen_to_Dmatrix(ptr);
  xpnt_normalize(root);
  Gen_set_next(rptr,Dmatrix_to_Gen(root));
  rptr=Gen_next(rptr);
  ptr=Gen_next(ptr);
 }
 free_Gen_list(g);
 g=List(Gen_next(res));
 free_Gen_node(res);
 return g;
}



/*
** Set_T Command                (tested)
*/
Gen_node G_Set_T(Gen_node g){
  Gen_node ptr;
  double t0;
   if ( Gen_length(g)!=2||
        Can_Be_List(Gen_elt(g,1))!=TRUE ||
        Can_Be_Number(Gen_elt(g,2),Dbl_T)==FALSE)
        return Rerror("Usage: SetT({<Dbl>},Dbl)",g);

   ptr=Gen_lval(Gen_elt(g,1));
   t0=Gen_To_Dbl(Gen_elt(g,2));
   free_Gen_list(Gen_next(g));
   while(ptr!=0){
     if (Can_Be_Vector(ptr,Dbl_T)<1){
       return Rerror("Usage: SetT({<Dbl>},Dbl)",g);
     }
     free_Gen_node(*GMref(Gen_Mtx(ptr),1,GMcols(Gen_Mtx(ptr))));
     *GMref(Gen_Mtx(ptr),1,GMcols(Gen_Mtx(ptr)))=DBLND(t0);
     ptr=Gen_next(ptr);
   }
   return g;
}

Gen_node G_Re(Gen_node g){
   fcomplex c;
   if ( Gen_length(g)!=1|| Can_Be_Cpx(Gen_elt(g,1))!=TRUE)
        return Rerror("Usage: Re(Cpx)",g);
   c=Gen_To_Cpx(g);
   free_Gen_list(g);
   return DBLND(Real(c));
}
 

Gen_node G_Im(Gen_node g){ 
   fcomplex c; 
   if ( Gen_length(g)!=1|| Can_Be_Cpx(Gen_elt(g,1))!=TRUE)
        return Rerror("Usage: Re(Cpx)",g); 
   c=Gen_To_Cpx(g); 
   free_Gen_list(g); 
   return DBLND(Imag(c)); 
} 



Generated by  Doxygen 1.6.0   Back to index