pelprgen.cc

Gambit 是一个游戏库理论软件

/*
**  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);
   /*