--- capa/capa51/pProj/capaFunction.c 2000/02/09 22:10:24 1.4 +++ capa/capa51/pProj/capaFunction.c 2000/09/20 17:21:01 1.12 @@ -1,7 +1,30 @@ +/* definition of all capa functions + Copyright (C) 1992-2000 Michigan State University + + The CAPA system is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The CAPA system is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public + License along with the CAPA system; see the file COPYING. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. + + As a special exception, you have permission to link this program + with the TtH/TtM library and distribute executables, as long as you + follow the requirements of the GNU GPL in regard to all of the + software in the executable aside from TtH/TtM. +*/ /* =||>>================================================================<<||= */ /* 45678901234567890123456789012345678901234567890123456789012345678901234567 */ -/* copyrighted by Isaac Tsai, 1996, 1997, 1998, 1999, 2000 */ +/* by Isaac Tsai, 1996, 1997, 1998, 1999, 2000 */ /* =||>>================================================================<<||= */ #include @@ -32,14 +55,24 @@ extern int Current_line[MAX_OPEN extern int Func_idx; extern Symbol FuncStack[MAX_FUNC_NEST]; +#ifdef TTH +extern int textohtmldyn(char*,char**,char**,int); +char *tth_err; +#endif + /* --------------------------------------------------------------------------- */ int match_function(func, argc) char *func; int argc; { if( !strcmp(func,"random") ) return (((argc==2 || argc==3)? RANDOM_F : MIS_ARG_COUNT)); - if( !strcmp(func,"random_normal") ) return (((argc==2 || argc==3)? RANDOM_NORMAL_F : MIS_ARG_COUNT)); - if( !strcmp(func,"random_exponential") ) return (((argc==2 || argc==3)? RANDOM_EXPONENTIAL_F : MIS_ARG_COUNT)); - if( !strcmp(func,"random_beta") ) return (((argc==2 || argc==3)? RANDOM_BETA_F : MIS_ARG_COUNT)); + if( !strcmp(func,"random_normal") ) return ((argc==5)? RANDOM_NORMAL_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_multivariate_normal") ) return ((argc==6)? RANDOM_MULTIVARIATE_NORMAL_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_beta") ) return ((argc==5)? RANDOM_BETA_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_gamma") ) return ((argc==5)? RANDOM_GAMMA_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_poisson") ) return ((argc==4)? RANDOM_POISSON_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_exponential") ) return ((argc==4)? RANDOM_EXPONENTIAL_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_chi") ) return ((argc==4)? RANDOM_CHI_F : MIS_ARG_COUNT); + if( !strcmp(func,"random_noncentral_chi") ) return ((argc==5)? RANDOM_NONCENTRAL_CHI_F : MIS_ARG_COUNT); if( !strcmp(func,"choose") ) return (CHOOSE_F); if( !strcmp(func,"tex") ) return (((argc==2)? TEX_F: MIS_ARG_COUNT)); if( !strcmp(func,"var_in_tex") ) return (VAR_IN_TEX_F); @@ -62,7 +95,7 @@ match_function(func, argc) char *func; i if( !strcmp(func,"strlen") ) return (((argc==1)? STRLEN_F: MIS_ARG_COUNT)); if( !strcmp(func,"get_seed") ) return (((argc==0)? GET_SEED_F: MIS_ARG_COUNT)); if( !strcmp(func,"set_seed") ) return (((argc==1)? SET_SEED_F: MIS_ARG_COUNT)); - if( !strcmp(func,"init_array") ) return (((argc==1)? INIT_ARRAY_F: MIS_ARG_COUNT)); + if( !strcmp(func,"init_array") ) return (((argc==1)? INIT_ARRAY_F: MIS_ARG_COUNT)); if( !strcmp(func,"array_index") ) return (((argc==1)? ARRAY_INDEX_F: MIS_ARG_COUNT)); if( !strcmp(func,"array_sorted_index") ) return (((argc==2)? ARRAY_SORTED_INDEX_F: MIS_ARG_COUNT)); if( !strcmp(func,"array_max") ) return (((argc==1)? ARRAY_MAX_F: MIS_ARG_COUNT)); @@ -278,6 +311,7 @@ ArgNode_t *argp; capa_msg(MESSAGE_ERROR,tmpS); } } break; + case CHOOSE_F: { int ii, pick=1; ArgNode_t *tmpArgp; @@ -749,7 +783,385 @@ ArgNode_t *argp; resultp->s_type = I_CONSTANT; resultp->s_int = 0; } break; - case ARRAY_MOMENTS_F: /* it */ + /* generate random numbers according to a pre-defined distributions and a seed */ + case RANDOM_MULTIVARIATE_NORMAL_F: + /* random_multivariate_normal(return_array,item_cnt,seed,dimen,mean_vector,covariance_vector) */ + /* the dimension of both mean_vector and covariance_vector should be the same as item_cnt */ + /* It will return item_cnt numbers in standard normal deviate in return_array */ + /* item_cnt, seed, dimen, mean_vec, cov_vec + are all destroyed after this function !!!*/ + { char *mean_vec_str, *cov_vec_str, *seed_str, *out_vec_str; + int dimen, item_cnt, tmp_int; + long tmp_long; + Symbol *r_p; + + errCode = 0; + switch( FIRST_ARGTYPE(argp) ) { /* parameter one covariance_matrix of size dimen*dimen */ + case I_VAR: case I_CONSTANT: + case R_VAR: case R_CONSTANT: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s last arg. must be an array name.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + case S_VAR: case S_CONSTANT: + cov_vec_str = strsave( FIRST_ARGSTR(argp) ); + break; + case IDENTIFIER: + cov_vec_str = strsave( FIRST_ARGNAME(argp) ); + /* + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s last arg. must be an array with data (covariance array).\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + */ + break; + } + if(errCode == 0) { + switch( SECOND_ARGTYPE(argp) ) { /* parameter two mean_vector */ + case I_VAR: case I_CONSTANT: + case R_VAR: case R_CONSTANT: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s fifth arg. must be an array name.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + case S_VAR: case S_CONSTANT: + mean_vec_str = strsave( SECOND_ARGSTR(argp) ); + break; + case IDENTIFIER: + mean_vec_str = strsave( SECOND_ARGNAME(argp) ); + /* + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s fifth arg. must be an array with data (mean array).\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + */ + break; + } + if(errCode == 0 ) { + switch( THIRD_ARGTYPE(argp) ) { /* parameter three dimen */ + case I_VAR: case I_CONSTANT: + dimen = THIRD_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + dimen = (int)THIRD_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s fourth arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { /* parameter four seed */ + switch( FOURTH_ARGTYPE(argp) ) { /* seed */ + case I_VAR: case I_CONSTANT: + seed_str = (char *)capa_malloc(32,1); + sprintf(seed_str,"%ld",FOURTH_ARGINT(argp) ); + break; + case R_VAR: case R_CONSTANT: + tmp_long = (long)FOURTH_ARGREAL(argp); + seed_str = (char *)capa_malloc(32,1); + sprintf(seed_str,"%ld",tmp_long); + break; + case S_VAR: case S_CONSTANT: + seed_str = strsave(FOURTH_ARGSTR(argp)); + break; + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s third arg. must be a number or a string.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( FIFTH_ARGTYPE(argp) ) { /* parameter five item_cnt */ + case I_VAR: case I_CONSTANT: + item_cnt = FIFTH_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + item_cnt = (int)FIFTH_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s second arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { /* array_name, clear the content of this array first */ + switch( SIXTH_ARGTYPE(argp) ) { + case I_VAR: case I_CONSTANT: + case R_VAR: case R_CONSTANT: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s first arg. must be a name of an array.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + case S_VAR: case S_CONSTANT: + tmp_int = free_array(SIXTH_ARGSTR(argp)); + + out_vec_str= strsave(SIXTH_ARGSTR(argp)); + break; + case IDENTIFIER: + tmp_int = free_array(SIXTH_ARGNAME(argp)); + + out_vec_str= strsave(SIXTH_ARGNAME(argp)); + + break; + } /* send switch */ + } /* end if array_name check */ + } /* end if (item_cnt) check */ + } /* end if (seed) check */ + } /* end if (dimen) check */ + } /* end if (mean_vector) check */ + if(errCode == 0 ) { /* all the parameter checks OK */ + r_p = gen_multivariate_normal(out_vec_str,seed_str,item_cnt,dimen,mean_vec_str,cov_vec_str); + capa_mfree((char *)resultp); + resultp = r_p; + + } + if( out_vec_str != NULL ) capa_mfree((char *)out_vec_str); + if( seed_str != NULL ) capa_mfree((char *)seed_str); + if( mean_vec_str != NULL ) capa_mfree((char *)mean_vec_str); + if( cov_vec_str != NULL ) capa_mfree((char *)cov_vec_str); + + } break; + case RANDOM_NORMAL_F: /* random_normal(return_array,item_cnt,seed,av,std_dev) */ + case RANDOM_BETA_F: /* random_beta(return_array,item_cnt,seed,aa,bb) */ + case RANDOM_GAMMA_F: /* random_gamma(return_array,item_cnt,seed,a,r) */ + case RANDOM_POISSON_F: /* random_poisson(return_array,item_cnt,seed,mu) */ + case RANDOM_EXPONENTIAL_F: + /* random_exponential(return_array,item_cnt,seed,av) */ + case RANDOM_CHI_F: /* random_chi(return_array,item_cnt,seed,df) */ + case RANDOM_NONCENTRAL_CHI_F: + /* random_noncentral_chi(return_array,item_cnt,seed,df,xnonc) */ + /* gen_random_by_selector(output_p,sel,seed,item_cnt,p1,p2) */ + { int sel, item_cnt, tmp_int; + float para1, para2; + char *tmp_str; + long tmp_long; + Symbol *r_p; + + switch(func) { /* assigns the function selector */ + case RANDOM_NORMAL_F: sel = NORMAL_DIS; break; + case RANDOM_BETA_F: sel = BETA_DIS; break; + case RANDOM_GAMMA_F: sel = GAMMA_DIS; break; + case RANDOM_POISSON_F: sel = POISSON_DIS; break; + case RANDOM_EXPONENTIAL_F: sel = EXPONENTIAL_DIS; break; + case RANDOM_CHI_F: sel = CHI_DIS; break; + case RANDOM_NONCENTRAL_CHI_F: sel = NONCENTRAL_CHI_DIS; break; + } + switch(func) { + case RANDOM_NORMAL_F: + case RANDOM_BETA_F: + case RANDOM_GAMMA_F: /* two-parameter functions */ + case RANDOM_NONCENTRAL_CHI_F: + { errCode = 0; + switch( FIRST_ARGTYPE(argp) ) { /* parameter two */ + case I_VAR: case I_CONSTANT: + para2 = (float)FIRST_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + para2 = (float)FIRST_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s last arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( SECOND_ARGTYPE(argp) ) { /* parameter one */ + case I_VAR: case I_CONSTANT: + para1 = (float)SECOND_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + para1 = (float)SECOND_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s fourth arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( THIRD_ARGTYPE(argp) ) { /* seed */ + case I_VAR: case I_CONSTANT: + tmp_str = (char *)capa_malloc(32,1); + sprintf(tmp_str,"%ld",THIRD_ARGINT(argp) ); + break; + case R_VAR: case R_CONSTANT: + tmp_long = (long)THIRD_ARGREAL(argp); + tmp_str = (char *)capa_malloc(32,1); + sprintf(tmp_str,"%ld",tmp_long); + break; + case S_VAR: case S_CONSTANT: + tmp_str = strsave(THIRD_ARGSTR(argp)); + break; + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s third arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( FOURTH_ARGTYPE(argp) ) { /* item_cnt */ + case I_VAR: case I_CONSTANT: + item_cnt = FOURTH_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + item_cnt = (int)FOURTH_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s second arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( FIFTH_ARGTYPE(argp) ) { /* array_name, clear the content of this array first */ + case I_VAR: case I_CONSTANT: + case R_VAR: case R_CONSTANT: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s first arg. must be a name of an array.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + case S_VAR: case S_CONSTANT: + tmp_int = free_array(FIFTH_ARGSTR(argp)); + r_p = gen_random_by_selector(FIFTH_ARGSTR(argp),sel,tmp_str,item_cnt,para1,para2); + capa_mfree((char *)resultp); + resultp = r_p; + break; + case IDENTIFIER: + tmp_int = free_array(FIFTH_ARGNAME(argp)); + r_p = gen_random_by_selector(FIFTH_ARGNAME(argp),sel,tmp_str,item_cnt,para1,para2); + capa_mfree((char *)resultp); + resultp = r_p; + break; + } + } /* the fourth argument of this function (item_cnt) */ + } /* the third argument of this function (seed) */ + } /* the second argument of this function (paramenter one) */ + } /* the first argument of this function (parameter two) */ + + } + break; + case RANDOM_POISSON_F: + case RANDOM_EXPONENTIAL_F: + case RANDOM_CHI_F: /* one parameter functions */ + { errCode = 0; + switch( FIRST_ARGTYPE(argp) ) { /* parameter one */ + case I_VAR: case I_CONSTANT: + para1 = (float)FIRST_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + para1 = (float)FIRST_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s last arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( SECOND_ARGTYPE(argp) ) { /* seed */ + case I_VAR: case I_CONSTANT: + tmp_str = (char *)capa_malloc(32,1); + sprintf(tmp_str,"%ld",SECOND_ARGINT(argp) ); + break; + case R_VAR: case R_CONSTANT: + tmp_long = (long)SECOND_ARGREAL(argp); + tmp_str = (char *)capa_malloc(32,1); + sprintf(tmp_str,"%ld",tmp_long); + break; + case S_VAR: case S_CONSTANT: + tmp_str = strsave(SECOND_ARGSTR(argp)); + break; + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s third arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( THIRD_ARGTYPE(argp) ) { /* item_cnt */ + case I_VAR: case I_CONSTANT: + item_cnt = THIRD_ARGINT(argp); + break; + case R_VAR: case R_CONSTANT: + item_cnt = (int)THIRD_ARGREAL(argp); + break; + case S_VAR: case S_CONSTANT: + case IDENTIFIER: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s second arg. must be a number.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + } + if(errCode == 0 ) { + switch( FOURTH_ARGTYPE(argp) ) { /* array_name, clear the content of this array first */ + case I_VAR: case I_CONSTANT: + case R_VAR: case R_CONSTANT: + resultp->s_type = S_CONSTANT; + resultp->s_str = strsave("<>"); + sprintf(tmpS,"%s()'s first arg. must be a name of an array.\n",FuncStack[Func_idx].s_name); + capa_msg(MESSAGE_ERROR,tmpS); + errCode = 1; + break; + case S_VAR: case S_CONSTANT: + tmp_int = free_array(FOURTH_ARGSTR(argp)); + r_p = gen_random_by_selector(FOURTH_ARGSTR(argp),sel,tmp_str,item_cnt,para1,para2); + capa_mfree((char *)resultp); + resultp = r_p; + break; + case IDENTIFIER: + tmp_int = free_array(FOURTH_ARGNAME(argp)); + r_p = gen_random_by_selector(FOURTH_ARGNAME(argp),sel,tmp_str,item_cnt,para1,para2); + capa_mfree((char *)resultp); + resultp = r_p; + break; + } + + } /* the third argument of this function (seed) */ + } /* the second argument of this function (paramenter one) */ + } /* the first argument of this function (parameter two) */ + } + break; + } /* end second switch */ + } break; + case ARRAY_MOMENTS_F: /* array_moments(output,input) */ { char *tmp_input; Symbol *r_p; @@ -1040,6 +1452,29 @@ ArgNode_t *argp; } break; case TEX_F: { if (Parsemode_f != TeX_MODE) { +#ifdef TTH +#define CHARLEN 1024*1024 + { + char *html; + if ( (Parsemode_f==HTML_MODE) && + ((SECOND_ARGTYPE(argp) == S_VAR) || + (SECOND_ARGTYPE(argp) == S_CONSTANT)) + ) { + printf("Hi There %s\n",SECOND_ARGSTR(argp)); + resultp->s_type = SECOND_ARGTYPE(argp); + if(tth_err) { free(tth_err); tth_err=NULL; } + textohtmldyn(SECOND_ARGSTR(argp),&html,&tth_err,CHARLEN); + if(html) { + resultp->s_str=strsave(html); + capa_mfree(html); + } else { + resultp->s_str=strsave(""); + } + break; + } + } +#undef CHARLEN +#endif resultp->s_type = FIRST_ARGTYPE(argp); switch(FIRST_ARGTYPE(argp)) { case I_VAR: