version 1.5, 2000/02/22 18:19:02
|
version 1.13, 2000/12/13 17:15:54
|
Line 1
|
Line 1
|
|
/* 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 */ |
/* 45678901234567890123456789012345678901234567890123456789012345678901234567 */ |
/* copyrighted by Isaac Tsai, 1996, 1997, 1998, 1999, 2000 */ |
/* by Isaac Tsai, 1996, 1997, 1998, 1999, 2000 */ |
/* =||>>================================================================<<||= */ |
/* =||>>================================================================<<||= */ |
|
|
#include <stdlib.h> |
#include <stdlib.h> |
Line 32 extern int Current_line[MAX_OPEN
|
Line 55 extern int Current_line[MAX_OPEN
|
extern int Func_idx; |
extern int Func_idx; |
extern Symbol FuncStack[MAX_FUNC_NEST]; |
extern Symbol FuncStack[MAX_FUNC_NEST]; |
|
|
|
#ifdef TTH |
|
extern int textohtmldyn(char*,char**,char**,int); |
|
char *tth_err; |
|
#endif |
|
|
/* --------------------------------------------------------------------------- */ |
/* --------------------------------------------------------------------------- */ |
int |
int |
match_function(func, argc) char *func; int argc; |
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") ) return (((argc==2 || argc==3)? RANDOM_F : MIS_ARG_COUNT)); |
if( !strcmp(func,"random_normal") ) return ((argc==5)? RANDOM_NORMAL_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_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_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_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_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_chi") ) return ((argc==4)? RANDOM_CHI_F : MIS_ARG_COUNT); |
if( !strcmp(func,"random_noncentral_chi") ) return ((argc==4)? RANDOM_NONCENTRAL_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,"choose") ) return (CHOOSE_F); |
if( !strcmp(func,"tex") ) return (((argc==2)? TEX_F: MIS_ARG_COUNT)); |
if( !strcmp(func,"tex") ) return (((argc==2)? TEX_F: MIS_ARG_COUNT)); |
if( !strcmp(func,"var_in_tex") ) return (VAR_IN_TEX_F); |
if( !strcmp(func,"var_in_tex") ) return (VAR_IN_TEX_F); |
Line 755 ArgNode_t *argp;
|
Line 784 ArgNode_t *argp;
|
resultp->s_int = 0; |
resultp->s_int = 0; |
} break; |
} break; |
/* generate random numbers according to a pre-defined distributions and a seed */ |
/* 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("<<LAST ARG. OF THIS FUNCTION MUST BE AN ARRAY NAME>>"); |
|
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("<<LAST ARG. OF THIS FUNCTION MUST BE AN ARRAY WITH DATA>>"); |
|
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("<<THE FIFTH ARG. OF THIS FUNCTION MUST BE AN ARRAY NAME>>"); |
|
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("<<THE FIFTH ARG. OF THIS FUNCTION MUST BE AN ARRAY WITH DATA>>"); |
|
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("<<THE FOURTH ARG. OF THIS FUNCTION MUST BE A NUMBER>>"); |
|
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("<<THIRD ARG. OF THIS FUNCTION MUST BE A NUMBER OR STRING>>"); |
|
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("<<SECOND ARG. OF THIS FUNCTION MUST BE A NUMBER>>"); |
|
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("<<FIRST ARG. OF THIS FUNCTION MUST BE AN ARRAY NAME>>"); |
|
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_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_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_GAMMA_F: /* random_gamma(return_array,item_cnt,seed,a,r) */ |
Line 784 ArgNode_t *argp;
|
Line 967 ArgNode_t *argp;
|
case RANDOM_NORMAL_F: |
case RANDOM_NORMAL_F: |
case RANDOM_BETA_F: |
case RANDOM_BETA_F: |
case RANDOM_GAMMA_F: /* two-parameter functions */ |
case RANDOM_GAMMA_F: /* two-parameter functions */ |
|
case RANDOM_NONCENTRAL_CHI_F: |
{ errCode = 0; |
{ errCode = 0; |
switch( FIRST_ARGTYPE(argp) ) { /* parameter two */ |
switch( FIRST_ARGTYPE(argp) ) { /* parameter two */ |
case I_VAR: case I_CONSTANT: |
case I_VAR: case I_CONSTANT: |
Line 875 ArgNode_t *argp;
|
Line 1059 ArgNode_t *argp;
|
break; |
break; |
case IDENTIFIER: |
case IDENTIFIER: |
tmp_int = free_array(FIFTH_ARGNAME(argp)); |
tmp_int = free_array(FIFTH_ARGNAME(argp)); |
r_p = gen_random_by_selector(FIFTH_ARGSTR(argp),sel,tmp_str,item_cnt,para1,para2); |
r_p = gen_random_by_selector(FIFTH_ARGNAME(argp),sel,tmp_str,item_cnt,para1,para2); |
capa_mfree((char *)resultp); |
capa_mfree((char *)resultp); |
resultp = r_p; |
resultp = r_p; |
break; |
break; |
Line 889 ArgNode_t *argp;
|
Line 1073 ArgNode_t *argp;
|
break; |
break; |
case RANDOM_POISSON_F: |
case RANDOM_POISSON_F: |
case RANDOM_EXPONENTIAL_F: |
case RANDOM_EXPONENTIAL_F: |
case RANDOM_CHI_F: |
case RANDOM_CHI_F: /* one parameter functions */ |
case RANDOM_NONCENTRAL_CHI_F: /* one parameter functions */ |
|
{ errCode = 0; |
{ errCode = 0; |
switch( FIRST_ARGTYPE(argp) ) { /* parameter one */ |
switch( FIRST_ARGTYPE(argp) ) { /* parameter one */ |
case I_VAR: case I_CONSTANT: |
case I_VAR: case I_CONSTANT: |
para2 = (float)FIRST_ARGINT(argp); |
para1 = (float)FIRST_ARGINT(argp); |
break; |
break; |
case R_VAR: case R_CONSTANT: |
case R_VAR: case R_CONSTANT: |
para2 = (float)FIRST_ARGREAL(argp); |
para1 = (float)FIRST_ARGREAL(argp); |
break; |
break; |
case S_VAR: case S_CONSTANT: |
case S_VAR: case S_CONSTANT: |
case IDENTIFIER: |
case IDENTIFIER: |
Line 965 ArgNode_t *argp;
|
Line 1148 ArgNode_t *argp;
|
break; |
break; |
case IDENTIFIER: |
case IDENTIFIER: |
tmp_int = free_array(FOURTH_ARGNAME(argp)); |
tmp_int = free_array(FOURTH_ARGNAME(argp)); |
r_p = gen_random_by_selector(FOURTH_ARGSTR(argp),sel,tmp_str,item_cnt,para1,para2); |
r_p = gen_random_by_selector(FOURTH_ARGNAME(argp),sel,tmp_str,item_cnt,para1,para2); |
capa_mfree((char *)resultp); |
capa_mfree((char *)resultp); |
resultp = r_p; |
resultp = r_p; |
break; |
break; |
Line 978 ArgNode_t *argp;
|
Line 1161 ArgNode_t *argp;
|
break; |
break; |
} /* end second switch */ |
} /* end second switch */ |
} break; |
} break; |
case ARRAY_MOMENTS_F: /* */ |
case ARRAY_MOMENTS_F: /* array_moments(output,input) */ |
{ |
{ |
char *tmp_input; |
char *tmp_input; |
Symbol *r_p; |
Symbol *r_p; |
Line 1269 ArgNode_t *argp;
|
Line 1452 ArgNode_t *argp;
|
} |
} |
break; |
break; |
case TEX_F: { if (Parsemode_f != TeX_MODE) { |
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); |
resultp->s_type = FIRST_ARGTYPE(argp); |
switch(FIRST_ARGTYPE(argp)) { |
switch(FIRST_ARGTYPE(argp)) { |
case I_VAR: |
case I_VAR: |
Line 1405 ArgNode_t *argp;
|
Line 1611 ArgNode_t *argp;
|
sprintf(tmpS,"%s()'s arg. cannot be less than zero.\n",FuncStack[Func_idx].s_name); |
sprintf(tmpS,"%s()'s arg. cannot be less than zero.\n",FuncStack[Func_idx].s_name); |
capa_msg(MESSAGE_ERROR,tmpS); |
capa_msg(MESSAGE_ERROR,tmpS); |
} else { |
} else { |
if( FIRST_ARGINT(argp) <= 20 ) { |
if( FIRST_ARGINT(argp) <= 13 ) { |
resultp->s_type = I_CONSTANT; |
resultp->s_type = I_CONSTANT; |
l_fac = 1; |
l_fac = 1; |
for(ii=2; ii <= FIRST_ARGINT(argp); ii++) { l_fac *= ii; } |
for(ii=2; ii <= FIRST_ARGINT(argp); ii++) { l_fac *= ii; } |
Line 1428 ArgNode_t *argp;
|
Line 1634 ArgNode_t *argp;
|
sprintf(tmpS,"%s()'s arg. cannot be less than zero.\n", FuncStack[Func_idx].s_name); |
sprintf(tmpS,"%s()'s arg. cannot be less than zero.\n", FuncStack[Func_idx].s_name); |
capa_msg(MESSAGE_ERROR,tmpS); |
capa_msg(MESSAGE_ERROR,tmpS); |
} else { |
} else { |
if( FIRST_ARGREAL(argp) <= 20.0 ) { |
if( FIRST_ARGREAL(argp) <= 13.0 ) { |
resultp->s_type = I_CONSTANT; |
resultp->s_type = I_CONSTANT; |
l_fac = 1; |
l_fac = 1; |
for(ii=2; ii <= FIRST_ARGREAL(argp); ii++) { l_fac *= ii; } |
for(ii=2; ii <= FIRST_ARGREAL(argp); ii++) { l_fac *= ii; } |