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

use strict;

my @files =
    ("dpq.h",
     "ftrunc.c",
     "dnorm.c",
     "pnorm.c",
     "qnorm.c",
     "plnorm.c",
     "qlnorm.c",
     "ppois.c",
     # "qpois.c",
     "stirlerr.c",
     "bd0.c",
     "dpois.c",
     "dgamma.c",
     "pgamma.c",
     # "qgamma.c", # Not good enough.
     "chebyshev.c",
     "lgammacor.c",
     "lbeta.c",
     "dt.c",
     "pt.c",
     "qt.c",
     # "pf.c",
     # "qf.c",
     "pchisq.c",
     "qchisq.c",
     "dweibull.c",
     "pweibull.c",
     "pbinom.c",
     "dbinom.c",
     "qbinom.c",
     "dnbinom.c",
     "pnbinom.c",
     "qnbinom.c",
     "dbeta.c",
     # "pbeta.c",
     # "qbeta.c",
     "dhyper.c",
     "phyper.c",
     "dexp.c",
     "pexp.c",
     "dgeom.c",
     "pgeom.c",
     "dcauchy.c",
     "pcauchy.c",
     "bessel.h",
     "bessel_i.c",
     "bessel_k.c",
     );

# These are for plugin fn-R.  They are so small it makes no sense to place
# them elsewhere.
push @files,
    (
     "dlnorm.c",
     "df.c",
     "dchisq.c",
     "qweibull.c",
     "qexp.c",
     "qgeom.c",
     );


my $mathfunc = $ARGV[0];
my $dir = $ARGV[1];
my $subdir = "src/nmath";

unless (defined ($mathfunc) && -r $mathfunc &&
	defined ($dir) && -d "$dir/$subdir") {
    print STDERR "Usage: $0 mathfunc.c R-directory\n";
    exit 1;
}


my ($prefix,$postfix) = &read_mathfunc ($mathfunc);

print $prefix;
print "\n";
print "/* The following source code was imported from the R project.  */\n";
print "/* It was automatically transformed by $0.  */\n";
print "\n";

foreach my $file (@files) {
    my $cleandefs = ($file =~ /\.c$/);
    print "/* Imported $subdir/$file from R.  */\n";
    &import_file ("$dir/$subdir/$file", $cleandefs);
}
print $postfix;

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

sub import_file {
    my ($filename,$cleandefs) = @_;

    my %defines = ();
    my $incomment = 0; # Stupid.

    local (*FIL);
    open (*FIL, "<$filename") or
	die "$0: Cannot read $filename: $!\n";
  LINE:
    while (<FIL>) {
	if (/^\s*\#\s*ifndef\s+GNUMERIC_VERSION\b/ ... /^\s*\#\s*endif\b.*\bGNUMERIC_VERSION\b/) {
	    next;
	}

	if (/^\s*\#\s*define\s+([a-zA-Z0-9_]+)/) {
	    $defines{$1} = 1;
	} elsif (/^\s*\#\s*undef\s+([a-zA-Z0-9_]+)/) {
	    delete $defines{$1};
	} elsif (/^\s*\#\s*include\s+/) {
	    # Ignore for now.
	    next LINE;
	}

 	$_ .= <FIL> if /^static\s+double\s*$/;

	s/\s+$//;
	if ($incomment) {
	    $incomment = 0 if m|\*/|;
	} else {
	    s/\bdouble\b/gnm_float/g;
	    s/\bRboolean\b/gboolean/g;

	    s/^(\s*)(const\s+gnm_float\s+([a-zA-Z_][a-zA-Z0-9_]*)\s*\[\s*\d+\s*\]\s*=)/$1static $2/;

	    # Improve precision of "log(1-x)".
	    s/\blog\s*\(\s*1\s*-\s*([a-zA-Z0-9_]+)\s*\)/gnm_log1p (-$1)/g;

	    # Improve precision of "log(1+x)".
	    s/\blog\s*\(\s*1\s*\+\s*/gnm_log1p \(/g;

	    s/\bISNAN\b/gnm_isnan/g;
	    s/\bR_(finite|FINITE)\b/gnm_finite/g;
	    s/\b(sqrt|exp|log|pow|log1p|expm1|floor|ceil|sin|sinh|tan)(\s|$|\()/gnm_$1$2/g;
	    s/\bfabs\b/gnm_abs/g;

	    s/\bgnm_floor\s*\(\s*([a-z]+)\s*\+\s*1e-7\s*\)/gnm_fake_floor($1)/;

	    # Constants.
	    s/\b(M_LN2|M_PI|M_PI_2|M_SQRT2|M_2PI)\b/$1gnum/g;
	    s/\bDBL_(EPSILON|MIN|MAX)/GNM_$1/g;
	    s/([-+]?\d*\.(\d{5,})([eE][-+]?\d+)?)/GNM_const\($1\)/g;
	    s@(\d)\s*/\s*(\d+\.\d*)@$1 / GNM_const\($2\)@g;

	    # Fix constant quotients.
	    s~([-+]?\d+\.\d*)(\s*/\s*)([-+e0-9.]+)~GNM_const\($1\)$2$3~;

	    # These are made static.
	    s/^gnm_float\s+(pbeta_both|stirlerr|bd0|dpois_raw|chebyshev_eval|lgammacor|lbeta|pbeta_raw|dbinom_raw)/static gnm_float $1/;
	    s/^int\s+(chebyshev_init)/static int $1/;

	    # Fix a bug...
	    s/\(\(-37\.5193 < x\) \|\| \(x < 8\.2924\)\)/((-37.5193 < x) && (x < 8.2924))/;

	    # Optimization given our stupid gammafn.
	    s|> 10|< 10| if /p and q are small: p <= q > 10/;
	    s|gnm_log\(gammafn\(p\) \* \(gammafn\(q\) / gammafn\(p \+ q\)\)\)|gnm_lgamma (p) + gnm_lgamma (q) - gnm_lgamma (p + q)|;

	    s/dnorm4/dnorm/g;
	    s/pnorm5/pnorm/g;
	    s/qnorm5/qnorm/g;

	    s/\b(trunc|ftrunc)\b/gnm_trunc/g;
	    s/\b(lgammafn|lgamma)\b/gnm_lgamma/g;
	    s/\bML_NAN\b/gnm_nan/g;
	    s/\bML_VALID\b/\!gnm_isnan/g;
	    s/\bML_NEGINF\b/gnm_ninf/g;
	    s/\bML_POSINF\b/gnm_pinf/g;

	    if ($filename !~ /\bpgamma\.c$/) {
		# Improve precision of "lgammagnum(x+1)".
		s/\bgnm_lgamma\s*\(([^()]+)\s*\+\s*1(\.0*)?\s*\)/lgamma1p ($1)/;
		s/\bgamma_cody\s*\(1\.\s*\+\s*([^()]+)\s*\)/gnm_exp(lgamma1p ($1))/;
	    }
	    s/\bR_Log1_Exp\b/swap_log_tail/g;

	    if ($filename =~ m|/bessel_i\.c$|) {
		s/\bgamma_cody\(empal\)/gnm_exp(lgamma1p(nu))/;
	    }

	    if (/^(static\s+)?(gnm_float|int)\s+(chebyshev_init)\s*\(/ .. /^\}/) {
		next unless s/^(static\s+)?(gnm_float|int)\s+([a-zA-Z0-9_]+)\s*\(.*//;
		$_ = "/* Definition of function $3 removed.  */";
	    }

	    # Somewhat risky.
	    s/\%([-0-9.]*)([efgEFG])/\%$1\" GNM_FORMAT_$2 \"/g;

	    s/int give_log/gboolean give_log/g;
	    s/int log_p/gboolean log_p/g;
	    s/int lower_tail/gboolean lower_tail/g;

	    # Fix pbinom
	    s/\bpbeta\s*\(1\s*-\s*([^,]*),\s*([^,]*),\s*([^,]*),\s*([^,]*),\s*([^,]*)\)/pbeta ($1, $3, $2, !$4, $5)/;

	    # Fix pt.
	    if ($filename =~ m|/pt\.c$|) {
		s/(n > 4e5)/0 && $1/;
		if (/(^.*\s*=\s*)pbeta\s*(\(.*\);)/) {
		    $_ = "$1 (n > x * x)\n" .
			"\t? pbeta (x * x / (n + x * x), 0.5, n / 2, /*lower_tail*/0, log_p)\n" .
			"\t: pbeta $2";
		}
	    }


	    if ($filename =~ m|/qbeta\.c$| && /xinbta = 0\.5;/) {
		s/0\.5/(xinbta < lower) ? gnm_sqrt (lower) : 1 - gnm_sqrt (lower)/;
	    }

	    $incomment = 1 if m|/\*$|;
	}

	print "$_\n";
    }
    close (*FIL);

    if ($cleandefs && keys %defines) {
	print "/* Cleaning up done by $0:  */\n";
	foreach my $def (sort keys %defines) {
	    print "#undef $def\n";
	}
    }

    print "\n";
    print "/* ", ('-' x 72), " */\n";
}

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

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

    my $prefix = '';
    my $postfix = '';

    local (*FIL);
    open (*FIL, "<$filename") or
	die "$0: Cannot read $filename: $!\n";
    my $state = 'pre';
    while (<FIL>) {
	if ($state eq 'pre') {
	    $prefix .= $_;
	    $state = 'mid' if m"--- BEGIN MAGIC R SOURCE MARKER ---";
	}
	if ($state eq 'mid') {
	    $state = 'post' if m"--- END MAGIC R SOURCE MARKER ---";
	}
	if ($state eq 'post') {
	    $postfix .= $_;
	}
    }
    close (*FIL);

    die "$0: wrong set of magic markers in $filename.\n" if $state ne 'post';

    return ($prefix,$postfix);
}

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