/*
 *  Copyright (C) Martin Maechler, 1994, 1998
 *  Copyright (C) 2001-2005 the R Development Core Team
 *
 *  This program 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.
 *
 *  This program 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 this program; if not, write to the Free Software
 *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301  USA
 *
 *  I want you to preserve the copyright of the original author(s),
 *  and encourage you to send me any improvements by e-mail. (MM).
 *
 *  Originally from Bill Dunlap
 *  bill@stat.washington.edu
 *  Wed Feb 21, 1990
 *
 *  Much improved by Martin Maechler, including the "fg" format.
 *
 *  Patched by Friedrich.Leisch@ci.tuwien.ac.at
 *  Fri Nov 22, 1996
 *
 *  Some fixes by Ross Ihaka
 *  ihaka@stat.auckland.ac.nz
 *  Sat Dec 21, 1996
 *  Integer arguments changed from "long" to "int"
 *  Bus error due to non-writable strings fixed
 *
 *  BDR 2001-10-30 use R_alloc not Calloc as memory was not
 *  reclaimed on error (and there are many error exits).
 *
 *	type	"double" or "integer" (R - numeric 'mode').
 *
 *	width	The total field width; width < 0 means to left justify
 *		the number in this field (equivalent to flag = "-").
 *		It is possible that the result will be longer than this,
 *		but that should only happen in reasonable cases.
 *
 *	digits	The desired number of digits after the decimal point.
 *		digits < 0 uses the default for C, namely 6 digits.
 *
 *	format	"d" (for integers) or "f", "e","E", "g", "G" (for 'real')
 *		"f" gives numbers in the usual "xxx.xxx" format;
 *		"e" and "E" give n.ddde<nn> or n.dddE<nn> (scientific format);
 *		"g" and "G" puts them into scientific format if it saves
 *		space to do so.
 *	    NEW: "fg" gives numbers in "xxx.xxx" format as "f",
 *		  ~~  however, digits are *significant* digits and no
 *		      trailing zeros are produced, as in "g".
 *
 *	flag	Format modifier as in K&R "C", 2nd ed., p.243;
 *		e.g., "0" pads leading zeros; "-" does left adjustment
 *		the other possible flags are  "+", " ", and "#".
 *	  New (Feb.98): if flag has more than one character, all are passed..
 */

/* <UTF8> char here is either ASCII or handled as a whole */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <stdio.h>
#include <string.h>
#include <math.h>

#include <R_ext/Error.h>	/* error */
#include <R_ext/Memory.h>	/* R_alloc */
#include <R_ext/Applic.h>
#include <Rmath.h>		/* fround */

#ifdef ENABLE_NLS
#include <libintl.h>
#define _(String) gettext (String)
#else
#define _(String) (String)
#endif

/*
   The declaration for x is unusual for a .C() but is managed by
   casting in the code itself.  However, it does mean that we cannot
   use the argument type matching
 */
void str_signif(char *x, int *n, char **type, int *width, int *digits,
		char **format, char **flag, char **result)
{
    int wid = *width;
    int dig = *digits;
    int i, nn = *n;
    int short do_fg = !strcmp("fg",*format);/* == 1  iff  format == "fg" */
    double xx;
    int iex, j, jL, len_flag = strlen(*flag);

    char *f0  =	 R_alloc(do_fg ? 1+len_flag+3 : 1, sizeof(char));
    char *form = R_alloc(len_flag+4 + strlen(*format), sizeof(char));

    if (wid == 0)
	error(_(".C(..): Width cannot be zero"));

    if (strcmp("d", *format) == 0) {
	if (len_flag == 0)
	    strcpy(form, "%*d");
	else {
	    strcpy(form, "%");
	    strcat(form, *flag);
	    strcat(form, "*d");
	}
	if (strcmp("integer", *type) == 0)
	    for (i=0; i < nn; i++)
		sprintf(result[i], form, wid, ((int *)x)[i]);
	else
	    error(_(".C(..): 'type' must be \"integer\" for  \"d\"-format"));
    }
    else { /* --- floating point --- */
	if (len_flag == 0)
	    strcpy(form, "%*.*");
	else {
	    strcpy(form, "%");
	    strcat(form, *flag);
	    strcat(form, "*.*");
	}

	if(do_fg) {
	    strcpy(f0, "%");
	    strcat(f0, *flag);
	    strcat(f0, ".*f");
	    strcat(form, "g");
	}
	else
	    strcat(form, *format);
#ifdef DEBUG
	fprintf(stderr, "strsignif.c: form='%s', wid=%d, dig=%d\n",
		form, wid, dig);
	if(do_fg) fprintf(stderr, "\t\"fg\": f0='%s'.", f0);
#endif
	if (strcmp("double", *type) == 0) {
	    if(do_fg) /* do smart "f" : */
		for (i=0; i < nn; i++) {
		    xx = ((double *)x)[i];
		    if(xx == 0.)
			strcpy(result[i], "0");
		    else {
			/* This was iex= (int)floor(log10(fabs(xx)))
			   That's wrong, as xx might get rounded up,
			   and we do need some fuzz or 99.5 is correct.
			*/
			double xxx = fabs(xx), X;
			iex= (int)floor(log10(xxx) + 1e-12);
			X = fround(xxx/pow(10.0, (double)iex)+ 1e-12, 
				   (double)(dig-1));
			if(iex > 0 &&  X >= 10) {
			    xx = X * pow(10.0, (double)iex);
			    iex++;
			}
			if(iex == -4 && fabs(xx)< 1e-4) {/* VERY rare case */
			    iex = -5;
			}
			if(iex < -4) {
				/* "g" would result in 'e-' representation:*/
			    sprintf(result[i], f0, dig-1 + -iex, xx);
#ifdef DEBUG
			    fprintf(stderr, " x[%d]=%g, iex%d\n", i, xx, iex);
			    fprintf(stderr, "\tres. = '%s'; ", result[i]);
#endif
				/* Remove trailing  "0"s : */
			    jL = j = strlen(result[i])-1;
			    while(result[i][j] == '0') j--;
			    result[i][j+1] = '\0';
#ifdef DEBUG
			    fprintf(stderr, "\t>>> jL=%d, j=%d; new res= '%s'\n",
				    jL, j, result[i]);
#endif
			} else { /* iex >= -4:	NOT "e-" */
				/* if iex >= dig, would have "e+" representation */
#ifdef DEBUG
			    fprintf(stderr, "\t  iex >= -4; using %d for 'dig'\n",
				    (iex >= dig) ? (iex+1) : dig);
#endif
			    sprintf(result[i], form, wid,
				    (iex >= dig) ? (iex+1) : dig, xx);
			}
		    } /* xx != 0 */
		} /* if(do_fg) for(i..) */
	    else
		for (i=0; i < nn; i++) {
		    sprintf(result[i], form, wid, dig, ((double *)x)[i]);
		}
	} else
	    error(_(".C(..): 'type' must be \"real\" for this format"));
    }
}