#!/usr/bin/perl -w
# -----------------------------------------------------------------------------

use strict;
$| = 1;

sub distribution;

my %funcs = ();
my %argoverride = ();

{
    my $of = "of the distribution";
    my @common = ('give_log' =>
		  "if true, log of the result will be returned instead",
	      
		  'lower_tail' =>
		  "if true (the default), the lower tail of the distribution is considered",

		  'log_p' => "if true, log of the probability is used",

		  'x' => 'observation',
		  'p' => 'probability',

		  'shape' => "the shape parameter $of",
		  'scale' => "the scale parameter $of",
		  );

    $funcs{'dnorm'} = $funcs{'pnorm'} = $funcs{'qnorm'} =
	[\&distribution,
	 'normal',
	 ({ 'mu' => "mean $of",
	    'sigma' => "standard deviation $of",
	    @common })];

    $funcs{'dlnorm'} = $funcs{'plnorm'} = $funcs{'qlnorm'} =
	[\&distribution,
	 'log-normal',
	 ({ 'logmean' => "mean of the underlying normal distribution",
	    'logsd' => "standard deviation of the underlying normal distribution",
	    @common })];

    $funcs{'dgamma'} = $funcs{'pgamma'} = $funcs{'qgamma'} =
	[\&distribution,
	 'gamma',
	 ({ @common })];
    $argoverride{"pgamma:p"} = "shape";
    $argoverride{"qgamma:alpha"} = "shape";

    $funcs{'dbeta'} = $funcs{'pbeta'} = $funcs{'qbeta'} =
	[\&distribution,
	 'beta',
	 ({ 'a' => "the first shape parameter $of",
	    'b' => "the second scale parameter $of",
	    @common })];
    $argoverride{"pbeta:pin"} = "a";
    $argoverride{"pbeta:qin"} = "b";
    $argoverride{"qbeta:alpha"} = "p";
    $argoverride{"qbeta:p"} = "a";
    $argoverride{"qbeta:q"} = "b";

    $funcs{'dt'} = $funcs{'pt'} = $funcs{'qt'} =
	[\&distribution,
	 'Student t',
	 ({ 'n' => "the number of degrees of freedom $of",
	    @common })];
    $argoverride{"qt:ndf"} = "n";

    $funcs{'df'} = $funcs{'pf'} = $funcs{'qf'} =
	[\&distribution,
	 'F',
	 ({ 'n1' => "the first number of degrees of freedom $of",
	    'n2' => "the second number of degrees of freedom $of",
	    @common })];
    $argoverride{"df:m"} = "n1";
    $argoverride{"df:n"} = "n2";

    $funcs{'dchisq'} = $funcs{'pchisq'} = $funcs{'qchisq'} =
	[\&distribution,
	 'chi-square',
	 ({ 'df' => "the number of degrees of freedom $of",
	    @common })];

    $funcs{'dweibull'} = $funcs{'pweibull'} = $funcs{'qweibull'} =
	[\&distribution,
	 'Weibull',
	 ({ @common })];

    $funcs{'dpois'} = $funcs{'ppois'} = $funcs{'qpois'} =
	[\&distribution,
	 'Poisson',
	 ({ 'lambda' => "the mean $of",
	    @common })];

    $funcs{'dexp'} = $funcs{'pexp'} = $funcs{'qexp'} =
	[\&distribution,
	 'exponential',
	 ({ @common })];

    $funcs{'dbinom'} = $funcs{'pbinom'} = $funcs{'qbinom'} =
	[\&distribution,
	 'binomial',
	 ({ 'n' => 'the number of trials',
	    'psuc' => "the probability of success in each trial",
	    @common })];
    $argoverride{"dbinom:p"} = $argoverride{"pbinom:p"} = $argoverride{"qbinom:p"} =
	"psuc";

    $funcs{'dnbinom'} = $funcs{'pnbinom'} = $funcs{'qnbinom'} =
	[\&distribution,
	 'negative binomial',
	 ({ 'n' => 'the number of trials',
	    'psuc' => "the probability of success in each trial",
	    @common })];
    $argoverride{"dnbinom:p"} = $argoverride{"pnbinom:p"} = $argoverride{"qnbinom:pr"} =
	"psuc";

    $funcs{'dhyper'} = $funcs{'phyper'} = $funcs{'qhyper'} =
	[\&distribution,
	 'hypergeometric',
	 ({ 'r' => "the number of red balls",
	    'b' => "the number of black balls",
	    'n' => "the number of balls drawn",	    
	    @common })];
    $argoverride{"phyper:NR"} = $argoverride{"qhyper:NR"} = 'r';
    $argoverride{"phyper:NB"} = $argoverride{"qhyper:NB"} = 'b';

    $funcs{'dcauchy'} = $funcs{'pcauchy'} = $funcs{'qcauchy'} =
	[\&distribution,
	 'Cauchy',
	 ({ 'location' => "the center $of",
	    @common })];

    $funcs{'dgeom'} = $funcs{'pgeom'} = $funcs{'qgeom'} =
	[\&distribution,
	 'geometric',
	 ({ 'psuc' => "the probability of success in each trial",
	    @common })];
    $argoverride{"dgeom:p"} = $argoverride{"pgeom:p"} = $argoverride{"qgeom:prob"} =
	"psuc";

    $funcs{'dsnorm'} =  $funcs{'psnorm'} =  
#$funcs{'qsnorm'} =
	[\&distribution,
	 'skew-normal',
	 ({ 'location' => "the location parameter $of",
	    @common })];

    $funcs{'dst'} = 
#$funcs{'pst'} = $funcs{'qst'} =
	[\&distribution,
	 'skew-t',
	 ({ 'n' => "the number of degrees of freedom $of",
	    @common })];
}


my %odf_note =
    ('qchisq' => 'A two argument invocation R.QCHISQ(@{p},@{df}) is exported to OpenFormula as CHISQINV(@{p},@{df}).',
     'pchisq' => 'A two argument invocation R.PCHISQ(@{x},@{df}) is exported to OpenFormula as CHISQDIST(@{x},@{df}).',
     'dchisq' => 'A two argument invocation R.DCHISQ(@{x},@{df}) is exported to OpenFormula as CHISQDIST(@{x},@{df},FALSE()).',
    );

my %type_getter =
    ('gnm_float' => 'value_get_as_float',
     'gboolean' => 'value_get_as_checked_bool',
     );

my %type_spec =
    ('gnm_float' => 'f',
     'gboolean' => 'b',
     );

my %type_setter =
    ('gnm_float' => 'value_new_float',
     'int' => 'value_new_int',
     'gboolean' => 'value_new_bool',
     );

# -----------------------------------------------------------------------------

my $mathfunch = $0;
$mathfunch =~ s|[^/]+$|../../src/mathfunc.h|;

my $funcdefs = "";
my @funcnames = ();

my $emitted = "";

&emit ("/* This code was generated by $0.  Do not edit. */\n\n" .
       "#include <gnumeric-config.h>\n" .
       "#include <gnumeric.h>\n" .
       "#include <goffice/goffice.h>\n" .
       "#include <gnm-plugin.h>\n" .
       "#include <func.h>\n" .
       "#include <gnm-i18n.h>\n" .
       "#include <value.h>\n" .
       "#include <mathfunc.h>\n" .
       "#include \"extra.h\"\n\n" .
       "GNM_PLUGIN_MODULE_HEADER;\n\n");

foreach my $header ($mathfunch, "extra.h") {
    local (*HEADER);
    open (HEADER, "<$header") or die "$0: Cannot read $header: $!\n";
    while (<HEADER>) {
	chomp;

	if (/^(gnm_float)\s+([a-zA-Z_][a-zA-Z0-9_]*)\s*\(.*\)/) {
	    my $restype = $1;
	    my $func = $2;
	    next unless exists $funcs{$func};
	    my ($handler,@args) = @{ $funcs{$func} };

	    &$handler ($func, $restype, $_, @args);
	    push @funcnames, "r.$func";
	}
    }
    close (HEADER);
}

&emit_line ();

&emit ("G_MODULE_EXPORT void\n" .
       "go_plugin_init (GOPlugin *plugin, GOCmdContext *cc)\n" .
       "{\n" .
       "}\n\n");

&emit ("G_MODULE_EXPORT void\n" .
       "go_plugin_shutdown (GOPlugin *plugin, GOCmdContext *cc)\n" .
       "{\n" .
       "}\n\n");

&emit_line ();

&emit ("GnmFuncDescriptor const stat_functions[] = {\n" .
       $funcdefs .
       "\t{ NULL }\n" .
       "};\n");
&emit_dump ("functions.c");

&create_plugin_xml_in (@funcnames);

# -----------------------------------------------------------------------------

sub distribution {
    my ($func,$restype,$proto,$distname,$argdescs) = @_;

    my $args = $proto;
    $args =~ s/^.*\((.*)\)\s*;$/$1/;

    my @args = ();
    foreach (split (/\s*,\s*/, $args)) {
	my ($type,$name) = split (' ');
	$name = $argoverride{"$func:$name"} || $argoverride{$name} || $name;
	push @args, [$type,$name];
    }

    # ----------------------------------------
    # Output help description.

    &emit_line ();
    &emit ("\nstatic GnmFuncHelp const help_r_$func\[\] = {\n");

    my $short_what = ($func =~ /^d/
		      ? "probability density function"
		      : ($func =~ /^p/
			 ? "cumulative distribution function"
			 : "probability quantile function")) .
			 " of the $distname distribution";
    &emit ("\t{ GNM_FUNC_HELP_NAME, F_(\"" . uc ("r.$func") . ":$short_what\") },\n");

    foreach (@args) {
	my ($type,$name) = @{ $_ };

	my $desc = $argdescs->{$name};
	if (!defined $desc) {
	    $desc = "";
	    warn "$0: Argument $name of r.$func has no description\n";
	}
	&emit ("\t{ GNM_FUNC_HELP_ARG, F_(\"$name:$desc\") },\n");
    }

    my $what = "This function returns the " .
	($func =~ /^d/
	 ? "probability density function"
	 : ($func =~ /^p/
	    ? "cumulative distribution function"
	    : "probability quantile function, i.e., the inverse of the cumulative distribution function,")) .
	    " of the $distname distribution.";
    &emit ("\t{ GNM_FUNC_HELP_DESCRIPTION, F_(\"$what\") },\n");

    my $odf = $odf_note{$func};
    if ($odf) {
	&emit ("\t{ GNM_FUNC_HELP_ODF, F_(\"$odf\") },\n");
    }

    my $seealso = "";
    my $f1 = substr ($func, 1);
    my $F1 = uc ($f1);
    $seealso .= ",R.D$F1" if ($func !~ /^d/) && exists $funcs{"d$f1"};
    $seealso .= ",R.P$F1" if $func !~ /^p/ && exists $funcs{"p$f1"};
    $seealso .= ",R.Q$F1" if $func !~ /^q/ && exists $funcs{"q$f1"};
    $seealso =~ s/^,\s*//;
    &emit ("\t{ GNM_FUNC_HELP_SEEALSO, \"$seealso\" },\n");

    &emit ("\t{ GNM_FUNC_HELP_END }\n" .
	   "};\n\n");

    # ----------------------------------------
    # Output the function body.

    &emit ("static GnmValue *\n" .
	   "gnumeric_r_$func (GnmFuncEvalInfo *ei, GnmValue const * const *args)\n" .
	   "{\n");

    my $typespec = "";
    my $n = 0;
    foreach (@args) {
	my ($type,$name) = @{ $_ };
	my $def = undef;
	$def = 'TRUE' if $name eq 'lower_tail';
	$def = 'FALSE' if $name eq 'give_log' || $name eq 'log_p';

	&emit ("\t$type $name = " .
	       (defined ($def) ? "args[$n] ? " : "") .
	       $type_getter{$type} . " (args[$n])" .
	       (defined ($def) ? " : $def" : "") .
	       ";\n");

	if (defined ($def) && $typespec !~ /\|/) {
	    $typespec .= "|" ;
	}
	$typespec .= $type_spec{$type};
	$n++;
    }

    &emit ("\n" .
	   "\treturn " . $type_setter{$restype} . " (" .
	   "$func (" . join (", ", map { $_->[1] } @args) . "));\n" .
	   "}\n\n");

    my $arglist = join (",", map { $_->[1] } @args);

    $funcdefs .= ("\t{\n" .
		  "\t\t\"r.$func\",\n" .
		  "\t\t\"$typespec\",\n" .
		  "\t\thelp_r_$func,\n" .
		  "\t\tgnumeric_r_$func, NULL, NULL, NULL, NULL,\n" .
		  "\t\tGNM_FUNC_SIMPLE, GNM_FUNC_IMPL_STATUS_UNIQUE_TO_GNUMERIC, GNM_FUNC_TEST_STATUS_NO_TESTSUITE,\n" .
		  "\t},\n");
}

# -----------------------------------------------------------------------------

sub emit {
    my ($code) = @_;
    $emitted .= $code;
}

sub emit_line {
    &emit ("/* " . ('-' x 73) . " */\n\n");
}

sub emit_dump {
    my ($filename) = @_;

    my $tmpfilename = "$filename.new";
    print STDERR "Creating $filename";
    local (*FIL);
    open (FIL, ">$tmpfilename") or die "Cannot write to $tmpfilename: $!\n";
    print FIL $emitted;
    close (*FIL);

    &update_file ($filename);

    $emitted = "";
}

# -----------------------------------------------------------------------------

sub update_file {
    my ($old) = @_;
    my ($new) = "$old.new";

    if (!-r $old) {
	rename $new, $old or
	    die "$0: Cannot rename $new to $old: $!\n";
	print STDERR " -- done.\n";
    } else {
	system ("cmp '$old' '$new' >/dev/null");
	if ($? == 0) {
	    print STDERR " -- unchanged.\n";
	    unlink $new;
	} else {
	    rename $new, $old or
		die "$0: Cannot rename $new to $old: $!\n";
	    print STDERR " -- done.\n";
	}
    }
}

# -----------------------------------------------------------------------------

sub create_plugin_xml_in {
    my (@funcnames) = @_;

    &emit ("<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" .
	   "<plugin id=\"Gnumeric_r\">\n" .
	   "\t<information>\n" .
	   "\t\t<_name>Statistical Functions</_name>\n" .
	   "\t\t<_description>Statistical Functions with naming and calling conventions from The R Project</_description>\n" .
	   "\t</information>\n" .
	   "\t<loader type=\"Gnumeric_Builtin:module\">\n" .
	   "\t\t<attribute name=\"module_file\" value=\"rstat\"/>\n" .
	   "\t</loader>\n" .
	   "\t<services>\n" .
	   "\t\t<service type=\"function_group\" id=\"stat\">\n" .
	   "\t\t\t<_category>Statistics</_category>\n" .
	   "\t\t\t<functions textdomain=\"gnumeric-functions\">\n");

    foreach my $rfunc (sort @funcnames) {
	&emit ("\t\t\t\t<function name=\"$rfunc\"/>\n");
    }

    &emit ("\t\t\t</functions>\n" .
	   "\t\t</service>\n" .
	   "\t</services>\n" .
	   "</plugin>\n");

    &emit_dump ("plugin.xml.in");
}

# -----------------------------------------------------------------------------
