mfcalc.y

Linux/windows 环境下跨平台开发程序

// more functions
static double sign(double v)
{
	if(v > 0.0) return 1.0;
	if(v < 0.0) return -1.0;
	return 0.0;
}

static long idum=0;

static double rand(double v)
{
	return ran2(&idum);
}

static double srand(double v)
{
	idum = (long)v;
	return v;
}

static double factorial(double v)
{
	return factrl((int)v);
}

static void close_arr_func(YYSTYPE *sr)
{
	if(sr->a_data) free(sr->a_data);
	sr->a_data = 0L;		sr->a_count = 0;
}

static double _strlen(YYSTYPE *sr, YYSTYPE *dst)
{
	if(!sr || !sr->text) return 0.0;
	return (double)strlen(sr->text);
}

#undef min
static double min(YYSTYPE *sr) 
{
	int i;

	if(!sr || !sr->a_count) return 0.0;
	if(sr->a_data && sr->a_data){
		for(i = 1, sr->val = sr->a_data[0]; i < sr->a_count; i++) 
			if(sr->a_data[i] < sr->val) sr->val = sr->a_data[i];
		close_arr_func(sr);
		}
	return sr->val;
}

#undef max
static double max(YYSTYPE *sr) 
{
	int i;

	if(!sr || !sr->a_count) return 0.0;
	if(sr->a_data){
		for(i = 1, sr->val = sr->a_data[0]; i < sr->a_count; i++) 
			if(sr->a_data[i] > sr->val) sr->val = sr->a_data[i];
		close_arr_func(sr);
		}
	return sr->val;
}

static double count(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	if(sr->a_data){
		sr->val = (double)sr->a_count;
		close_arr_func(sr);
		}
	else sr->val = 0.0;
	return sr->val;
}

static double sum(YYSTYPE *sr) 
{
	int i;

	if(!sr) return 0.0;
	if(sr->a_data){
		for(i = 0, sr->val = 0.0; i < sr->a_count; i++) sr->val += sr->a_data[i];
		close_arr_func(sr);
		}
	else sr->val = 0.0;
	return sr->val;
}

static double calc_variance(double *values, int n)
{
	int i;
	double ss, d, mean = d_amean(n, values);

	for(i=0, ss=0.0; i < n; i++) ss += ((d=values[i]-mean)*d);
	return (ss/(n-1));
}

static double mean(YYSTYPE *sr) 
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = d_amean(sr->a_count, sr->a_data );
		close_arr_func(sr);
		}
	return sr->val;
}

static double gmean(YYSTYPE *sr) 
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = d_gmean(sr->a_count, sr->a_data );
		close_arr_func(sr);
		}
	return sr->val;
}

static double hmean(YYSTYPE *sr) 
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = d_hmean(sr->a_count, sr->a_data );
		close_arr_func(sr);
		}
	return sr->val;
}

static double quartile1(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		d_quartile(sr->a_count, sr->a_data, &sr->val, 0L, 0L);
		close_arr_func(sr);
		}
	return sr->val;
}

static double quartile2(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		d_quartile(sr->a_count, sr->a_data, 0L, &sr->val, 0L);
		close_arr_func(sr);
		}
	return sr->val;
}

static double quartile3(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	if(sr->a_data && sr->a_count){
		d_quartile(sr->a_count, sr->a_data, 0L, 0L, &sr->val);
		close_arr_func(sr);
		}
	return sr->val;
}

static double variance(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = calc_variance(sr->a_data, sr->a_count);
		close_arr_func(sr);
		}
	return sr->val;
}

static double stdev(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = sqrt(calc_variance(sr->a_data, sr->a_count));
		close_arr_func(sr);
		}
	return sr->val;
}

static double sterr(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count){
		sr->val = sqrt(calc_variance(sr->a_data, sr->a_count))/sqrt(sr->a_count);
		close_arr_func(sr);
		}
	return sr->val;
}

static double beta(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2){
		sr->val = betaf(sr->a_data[0], sr->a_data[1]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  beta(u, v).");
	return sr->val;
}

static double _gammp(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2){
		sr->val = gammp(sr->a_data[0], sr->a_data[1]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  gammp(a, x).");
	return sr->val;
}

static double _gammq(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2){
		sr->val = gammq(sr->a_data[0], sr->a_data[1]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  gammq(a, x).");
	return sr->val;
}

static double _betai(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 3){
		sr->val = betai(sr->a_data[0], sr->a_data[1], sr->a_data[2]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  betai(x, a, b).");
	return sr->val;
}

static double _bincof(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2){
		sr->val = bincof(sr->a_data[0], sr->a_data[1]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  bincof(n, k).");
	return sr->val;
}

static double binomdist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 3){
		sr->val = binomdistf(sr->a_data[0], sr->a_data[1], sr->a_data[2]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  binomdist(s, n, p).");
	return sr->val;
}

static double normdist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count == 3){
		sr->val = norm_dist(sr->a_data[0], sr->a_data[1], sr->a_data[2]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  normdist(x, mean, SD).");
	return sr->val;
}

static double norminv(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 3) {
		sr->val = distinv(norm_dist,sr->a_data[1], sr->a_data[2], sr->a_data[0], 2.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  norminv(p, mean, SD).");
	return sr->val;
}

static double chidist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count == 2){
		sr->val = chi_dist(sr->a_data[0], sr->a_data[1], 1.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  chidist(x, df).");
	return sr->val;
}

static double chiinv(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2) {
		sr->val = distinv(chi_dist,sr->a_data[1], 1.0, sr->a_data[0], 2.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  chiinv(p, df).");
	return sr->val;
}

static double tdist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count == 2){
		sr->val = t_dist(sr->a_data[0], sr->a_data[1], 1.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  tdist(x, df).");
	return sr->val;
}

static double tinv(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
        if(sr->a_data && sr->a_count == 2) {
		sr->val = distinv(t_dist,sr->a_data[1], 1.0, sr->a_data[0], 2.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  tinv(p, df).");
	return sr->val;
}

static double poisdist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0.0;
	if(sr->a_data && sr->a_count == 2){
		sr->val = pois_dist(sr->a_data[0], sr->a_data[1], 1.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  poisdist(x, mean).");
	return sr->val;
}

static double fdist(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0;
	if(sr->a_data && sr->a_count == 3){
		sr->val = f_dist(sr->a_data[0], sr->a_data[1], sr->a_data[2]);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  fdist(x, df1, df2).");
	return sr->val;
}

static double finv(YYSTYPE *sr)
{
	if(!sr) return 0.0;
	sr->val = 0;
	if(sr->a_data && sr->a_count == 3){
		sr->val = distinv(f_dist,sr->a_data[1], sr->a_data[2], sr->a_data[0], 2.0);
		close_arr_func(sr);
		}
	else yyargserr("Wrong number of arguments\nin call to  finv(p, df1, df2).");
	return sr->val;
}

static double pearson(YYSTYPE *sr1, YYSTYPE *sr2, char *dest)
{
	if(!sr1 || !sr2) return 0.0;
	sr1->val = 0.0;
        if(sr1->a_data && sr1->a_count > 1 && sr2->a_data && sr1->a_count == sr2->a_count){
		sr1->val = sr2->val = d_pearson(sr1->a_data, sr2->a_data, sr1->a_count, dest, curr_data);
		close_arr_func(sr1);		close_arr_func(sr2);
		}
	else yyargserr("Bad arguments in call to function\npearson(range1; range2 [;\"dest\"]).");
	return sr1->val;
}

static double spearman(YYSTYPE *sr1, YYSTYPE *sr2, char *dest)
{
	if(!sr1 || !sr2) return 0.0;
	sr1->val = 0.0;
        if(sr1->a_data && sr1->a_count > 1 && sr2->a_data && sr1->a_count == sr2->a_count){
		sr1->val = sr2->val = d_spearman(sr1->a_data, sr2->a_data, sr1->a_count, dest, curr_data);
		close_arr_func(sr1);		close_arr_func(sr2);
		}
	else yyargserr("Bad arguments in call to function\nspearman(range1; range2 [;\"dest\"]).");
	return sr1->val;
}

static double regression(YYSTYPE *sr1, YYSTYPE *sr2, char *dest)
{
	if(!sr1 || !sr2) return 0.0;
	sr1->val = 0.0;
	if(!(dest)) yyargserr("No destination range in call to function\nregression(range1; range2; \"dest\").");
        if(sr1->a_data && sr1->a_count > 1 && sr2->a_data && sr1->a_count == sr2->a_count){
		sr1->val = sr2->val = d_regression(sr1->a_data, sr2->a_data, sr1->a_count, dest, curr_data);
		close_arr_func(sr1);		close_arr_func(sr2);
		}
	else yyargserr("Bad arguments in call to function\nregression(range1; range2; \"dest\").");
	return sr1->val;
}

static double ttest(YYSTYPE *sr1, YYSTYPE *sr2, char *dest)
{
	if(!sr1 || !sr2) return 0.0;
	sr1->val = 0.0;
        if(sr1->a_data && sr1->a_count > 1 && sr2->a_data && sr2->a_count > 1){
		sr1->val = sr2->val = d_ttest(sr1->a_data, sr2->a_data, sr1->a_count, sr2->a_count, dest, curr_data);
		close_arr_func(sr1);		close_arr_func(sr2);
		}
	else yyargserr("Bad arguments in call to function\nttest(range1; range2[;\"dest\"]).");
	return sr1->val;
}

static double ftest(YYSTYPE *sr1, YYSTYPE *sr2, char *dest)
{
	if(!sr1 || !sr2) return 0.0;
	sr1->val = 0.0;
        if(sr1->a_data && sr1->a_count > 1 && sr2->a_data && sr1->a_count > 1){
		sr1->val = sr2->val = d_ftest(sr1->a_data, sr2->a_data, sr1->a_count, sr2->a_count, dest, curr_data);
		close_arr_func(sr1);		close_arr_func(sr2);
		}
	else yyargserr("Bad arguments in call to function\nftest(range1; range2[;\"dest\"]).");
	return sr1->val;
}

struct init
{
	int f_type;
	unsigned int h_name;
	double (*fnct)(double);
};

static struct init arith_fncts[] = {
	{FUNC2, HashValue((unsigned char*)"pearson"), (double(*)(double))&pearson},
	{FUNC2, HashValue((unsigned char*)"spearman"), (double(*)(double))&spearman},
	{FUNC2, HashValue((unsigned char*)"regression"), (double(*)(double))&regression},
	{FUNC2, HashValue((unsigned char*)"ttest"), (double(*)(double))&ttest},
	{FUNC2, HashValue((unsigned char*)"ftest"), (double(*)(double))&ftest},
	{AFNCT, HashValue((unsigned char*)"variance"), (double(*)(double))&variance},
	{AFNCT, HashValue((unsigned char*)"stdev"), (double(*)(double))&stdev},
	{AFNCT, HashValue((unsigned char*)"sterr"), (double(*)(double))&sterr},
	{AFNCT, HashValue((unsigned char*)"min"), (double(*)(double))&min},
	{AFNCT, HashValue((unsigned char*)"max"), (double(*)(double))&max},
	{AFNCT, HashValue((unsigned char*)"count"), (double(*)(double))&count},
	{AFNCT, HashValue((unsigned char*)"sum"), (double(*)(double))&sum},
	{AFNCT, HashValue((unsigned char*)"mean"), (double(*)(double))&mean},
	{AFNCT, HashValue((unsigned char*)"median"), (double(*)(double))&quartile2},
	{AFNCT, HashValue((unsigned char*)"quartile1"), (double(*)(double))&quartile1},
	{AFNCT, HashValue((unsigned char*)"quartile2"), (double(*)(double))&quartile2},
	{AFNCT, HashValue((unsigned char*)"quartile3"), (double(*)(double))&quartile3},
	{AFNCT, HashValue((unsigned char*)"gmean"), (double(*)(double))&gmean},
	{AFNCT, HashValue((unsigned char*)"hmean"), (double(*)(double))&hmean},
	{AFNCT, HashValue((unsigned char*)"tdist"), (double(*)(double))&tdist},
	{AFNCT, HashValue((unsigned char*)"tinv"), (double(*)(double))&tinv},
	{AFNCT, HashValue((unsigned char*)"poisdist"), (double(*)(double))&poisdist},
	{AFNCT, HashValue((unsigned char*)"fdist"), (double(*)(double))&fdist},
	{AFNCT, HashValue((unsigned char*)"finv"), (double(*)(double))&finv},
	{AFNCT, HashValue((unsigned char*)"gammp"), (double(*)(double))&_gammp},
	{AFNCT, HashValue((unsigned char*)"gammq"), (double(*)(double))&_gammq},
	{AFNCT, HashValue((unsigned char*)"beta"), (double(*)(double))&beta},
	{AFNCT, HashValue((unsigned char*)"betai"), (double(*)(double))&_betai},
	{AFNCT, HashValue((unsigned char*)"bincof"), (double(*)(double))&_bincof},