/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/*== see ./printutils.c	 for general remarks on Printing and the Encode.. utils.
 *   see ./format.c	 for the  format_Foo_  functions.
 */
#include "Defn.h"
#include "Print.h"

SEXP mkChar(char *);

/*  .Internal(paste(args, sep, collapse)) */

/* do_paste uses two passes to paste the arguments (in CAR(args)) together.
 * The first pass calculates the width of the paste buffer,
 * then it is alloc-ed and the second pass stuffs the information in.
 */
SEXP do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP ans, collapse, sep, px, x, tmpchar;
	int i, k, maxlen, nx, pwidth, sepw;
	char *s, *buf;

	checkArity(op, args);

		/* We use formatting and so we */
		/* must initialize printing. */

	PrintDefaults(env);

		/* Check the arguments */

	x = CAR(args);
	if (!isList(x))
		errorcall(call, "invalid first argument\n");

	sep = CADR(args);
	if (!isString(sep) || LENGTH(sep) <= 0)
		errorcall(call, "invalid separator\n");
	sep = STRING(sep)[0];
	sepw = LENGTH(sep);

	collapse = CADDR(args);
	if (!isNull(collapse))
		if(!isString(collapse) || LENGTH(collapse) <= 0)
			errorcall(call, "invalid collapse argument\n");

		/* Maximum argument length and */
		/* check for arguments of list type */

	nx = length(x);
	maxlen = 0;
	for (px = x; px != R_NilValue; px = CDR(px)) {
		if (!isString(CAR(px)))
			error("non-string argument to Internal paste\n");
		if(length(CAR(px)) > maxlen)
			maxlen = length(CAR(px));
	}
	if(maxlen == 0) return mkString("");

	PROTECT(ans = allocVector(STRSXP, maxlen));

	for (i = 0; i < maxlen; i++) {
		pwidth = 0;
		for (px = x; px != R_NilValue; px = CDR(px)) {
			k = length(CAR(px));
			if (k > 0)
				pwidth += LENGTH(STRING(CAR(px))[i%k]);
		}
		pwidth += (nx - 1) * sepw;
		tmpchar = allocString(pwidth);
		buf = CHAR(tmpchar);
		for (px=x; px != R_NilValue; px = CDR(px)) {
			k = length(CAR(px));
			if (k > 0) {
				s = CHAR(STRING(CAR(px))[i%k]);
				sprintf(buf, "%s", s);
				buf += LENGTH(STRING(CAR(px))[i%k]);
			}
			if (CDR(px) != R_NilValue && sepw != 0) {
				sprintf(buf, "%s", CHAR(sep));
				buf += sepw;
			}
		}
		STRING(ans)[i] = tmpchar;
	}

		/* Now collapse, if required. */

	if(collapse != R_NilValue && (nx=LENGTH(ans)) != 0) {
		sep = STRING(collapse)[0];
		sepw = LENGTH(sep);
		pwidth = 0;
		for (i = 0; i < nx; i++)
			pwidth += LENGTH(STRING(ans)[i]);
		pwidth += (nx - 1) * sepw;
		tmpchar = allocString(pwidth);
		buf = CHAR(tmpchar);
		for (i = 0; i < nx; i++) {
			if(i > 0) {
				sprintf(buf, "%s", CHAR(sep));
				buf += sepw;
			}
			s = CHAR(STRING(ans)[i]);
			sprintf(buf, "%s", s);
			buf += LENGTH(STRING(ans)[i]);
		}
		PROTECT(tmpchar);
		ans = allocVector(STRSXP, 1);
		UNPROTECT(1);
		STRING(ans)[0] = tmpchar;
	}
	UNPROTECT(1);
	return ans;
}

SEXP do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP l, x, y;
	int i, n, trim;
	int w, d, e;
	int wi, di, ei;
	char *strp;

	PrintDefaults(env);

	switch (length(args)) {
	case 1:
		trim = 0;
		break;
	case 2:
		trim = asLogical(CADR(args));
		if (trim == NA_INTEGER)
			errorcall(call, "invalid \"trim\" argument\n");
		break;
	default:
		errorcall(call, "incorrect number of arguments\n");
	}

	if (!isVector(x = CAR(args)))
		errorcall(call, "first argument must be atomic\n");

	if ((n = LENGTH(x)) <= 0)
		return allocVector(STRSXP, 0);

	switch (TYPEOF(x)) {
	case LGLSXP:
		PROTECT(y = allocVector(STRSXP, n));
		if (trim)
			w = 0;
		else
			formatLogical(LOGICAL(x), n, &w);
		for (i = 0; i < n; i++) {
			strp = EncodeLogical(LOGICAL(x)[i], w);
			STRING(y)[i] = mkChar(strp);
		}
		UNPROTECT(1);
		break;
	case INTSXP:
		PROTECT(y = allocVector(STRSXP, n));
		if (trim) w = 0;
		else formatInteger(INTEGER(x), n, &w);
		for (i = 0; i < n; i++) {
			strp = EncodeInteger(INTEGER(x)[i], w);
			STRING(y)[i] = mkChar(strp);
		}
		UNPROTECT(1);
		break;
	case REALSXP:
		formatReal(REAL(x), n, &w, &d, &e);
		if (trim) w = 0;
		PROTECT(y = allocVector(STRSXP, n));
		for (i = 0; i < n; i++) {
			strp = EncodeReal(REAL(x)[i], w, d, e);
			STRING(y)[i] = mkChar(strp);
		}
		UNPROTECT(1);
		break;
	case CPLXSXP:
		formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei);
		if (trim) wi = w = 0;
		PROTECT(y = allocVector(STRSXP, n));
		for (i = 0; i < n; i++) {
			strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei);
			STRING(y)[i] = mkChar(strp);
		}
		UNPROTECT(1);
		break;
	case STRSXP:
		formatString(STRING(x), n, &w, 0);
		if (trim) w = 0;
		PROTECT(y = allocVector(STRSXP, n));
		for (i = 0; i < n; i++) {
			strp = EncodeString(CHAR(STRING(x)[i]), w, 0, adj_left);
			STRING(y)[i] = mkChar(strp);
		}
		UNPROTECT(1);
		break;
	}
	PROTECT(y);
	if((l = getAttrib(x, R_DimSymbol)) != R_NilValue)
		setAttrib(y, R_DimSymbol, l);
	if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
		setAttrib(y, R_DimNamesSymbol, l);
	UNPROTECT(1);
	return y;
}

/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
 *			w = total width (#{chars}) per item
 *			d = #{digits} to RIGHT of "."
 *			e = {0:2}.   0: Fixpoint;
 *				   1,2: exponential with 2/3 digit expon.
 */
SEXP do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP x;
	int n, w, d, e;
	int wi, di, ei;
	checkArity(op, args);
	x = CAR(args);
	n = LENGTH(x);
	w = 0;
	d = 0;
	e = 0;
	switch(TYPEOF(x))
	{
		case LGLSXP:
			formatLogical(LOGICAL(x), n, &w);
			break;
		case INTSXP:
			formatInteger(INTEGER(x), n, &w);
			break;
		case REALSXP:
			formatReal(REAL(x), n, &w, &d, &e);
			break;
		case CPLXSXP:
			wi = di = ei = 0;
			formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei);
			n = -1;/* complex 'code' */
			break;
		case STRSXP:
			formatString(STRING(x), n, &w, 0);
			break;
		default:
			errorcall(call, "vector arguments only\n");
	}
	x = allocVector(INTSXP, (n>=0)?3:6);
	INTEGER(x)[0] = w;
	INTEGER(x)[1] = d;
	INTEGER(x)[2] = e;
	if(n<0) { /*- complex -*/
		INTEGER(x)[3] = wi;
		INTEGER(x)[4] = di;
		INTEGER(x)[5] = ei;
	}
	return x;
}
