/*
 *  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.
 */

#include "Defn.h"

/* functions to perform analogues of the standard C string library */
/* most will be vectorized */

SEXP do_nchar(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP d, s, x;
	int i, len;

	checkArity(op, args);
	PROTECT(x = coerceVector(CAR(args), STRSXP));
	if (!isString(x))
		error("invalid type, nchar requires a character vector\n");
	len = LENGTH(x);
	PROTECT(s = allocVector(INTSXP, len));
	for (i = 0; i < len; i++)
		INTEGER(s)[i] = strlen(CHAR(STRING(x)[i]));
	if((d = getAttrib(x, R_DimSymbol)) != R_NilValue)
		setAttrib(s, R_DimSymbol, d);
	if((d = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
		setAttrib(s, R_DimNamesSymbol, d);
	UNPROTECT(2);
	return s;
}
static void substr(char *buf, char *str, int sa, int so)
{
	int i;

	str += (sa - 1);
	for (i = 0; i <= (so - sa); i++)
		*buf++ = *str++;
	*buf = '\0';
}

SEXP do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP s, x, sa, so;
	int i, len, start, stop, slen, k, l;
	char buff[MAXELTSIZE];

	checkArity(op, args);
	x = CAR(args);
	sa = CADR(args);
	so = CAR(CDDR(args));

	if (!isString(x) || !isInteger(sa) || !isInteger(so))
		error("invalid type to substr\n");

	len = LENGTH(x);
	k = LENGTH(sa);
	l = LENGTH(so);
	PROTECT(s = allocVector(STRSXP, len));
	for (i = 0; i < len; i++) {
		start = INTEGER(sa)[i % k];
		stop = INTEGER(so)[i % l];
		if (stop > 1000000) 
			slen=10;
		slen = strlen(CHAR(STRING(x)[i]));
		if ( start < 1 )
			start = 1;
		if (start > stop || start > slen) {
			buff[0]='\0';
			STRING(s)[i] = mkChar(buff);
		}
		else {
			if (stop > slen)
				stop = slen;
			if( slen > MAXELTSIZE ) {
				stop = MAXELTSIZE;
				warning("character string truncated in strsplit\n");
			}
			substr(buff, CHAR(STRING(x)[i]), start, stop);
			STRING(s)[i] = mkChar(buff);
		}
	}
	UNPROTECT(1);
	return s;
}

/* strsplit is going to split the strings in the first argument
   into tokens depending on the second argument. The characters
   of the second argument are used to split the first argument.
   A list of vectors is returned of length equal to the input vector x,
   each element of the list is the collection of splits for the corresponding
   element of x.
 */
SEXP do_strsplit(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP s, t, x, tok, w;
	int i, j, len, tlen, ntok;
	char buff[MAXELTSIZE], *pt, *split = "";

	checkArity(op, args);
	x = CAR(args);
	tok = CADR(args);

	if (!isString(x) || !isString(tok))
		error("invalid type to strsplit\n");

	len = LENGTH(x);
	tlen = LENGTH(tok);
	PROTECT(s = allocList(len));
	w = s;
	for (i = 0; i < len; i++) {
		/* first find out how many splits there will be */
		strcpy(buff, CHAR(STRING(x)[i]));
		if( tlen > 0 ) {
			split = CHAR(STRING(tok)[i % tlen]);
			ntok = 0;
			if(strtok(buff, split) != NULL)
				 do {
					ntok++;
				 } while (strtok(NULL, split) != NULL);
		}
		else
			ntok=strlen(buff);

		PROTECT(t = allocVector(STRSXP, ntok));
		if( tlen > 0 ) {
			strcpy(buff, CHAR(STRING(x)[i]));
			pt = strtok(buff, split);
			for (j = 0; j < ntok; j++) {
				STRING(t)[j] = mkChar(pt);
				pt = strtok(NULL, split);
			}
		}
		else {
			char bf[2];
			bf[1]='\0';
			for (j = 0; j < ntok; j++) {
				bf[0]=buff[j];
				STRING(t)[j] = mkChar(bf);
			}
		}
		CAR(w) = t;
		UNPROTECT(1);
		w = CDR(w);
	}
	UNPROTECT(1);
	return s;
}
/* abbreviate long names in the S-designated fashion; first spaces then
   lower case vowels; then lower case consonants; then upper case letters
   special characters
   letters are dropped from the end of words and at least one letter is
   retained from each word
   if use.classes is FALSE then the only differentiation is between white
   space and letters
   if unique abbreviations are not produced letters are added until the
   results are unique (duplicated names are removed prior to entry).
   names, minlength, use.classes, dot
*/

static SEXP stripchars(SEXP inchar, int minlen)
{
	int i, j, nspace=0, upper;
	char buff1[MAXELTSIZE];

	strcpy(buff1, CHAR(inchar));
	upper=strlen(buff1)-1;

	/*remove beginning blanks */
	j=0;
	for(i=0 ; i<upper ; i++ )
		if(isspace(buff1[i]))
			j++;
		else
			break;

	strcpy(buff1,&buff1[j]);
	upper=strlen(buff1)-1;

	if(strlen(buff1)<minlen)
		goto donesc;

	for (i=upper; i>0; i--) {
		if( isspace(buff1[i]))
			nspace++;
			/*strcpy(buff1[i],buff1[i+1]);*/
		if(strlen(buff1)-nspace <= minlen)
			goto donesc;
	}

	upper=strlen(buff1)-1;

	for (i=upper; i>=0; i--) {
		if( (buff1[i]=='a' || buff1[i]=='e' || buff1[i]=='i' ||
			buff1[i]=='o' || buff1[i]=='u') ) {
			if (i>0) {
				if(!(isspace(buff1[i-1]) && isspace(buff1[i+1])) )
					strcpy(&buff1[i],&buff1[i+1]);
			}
			else if(!isspace(buff1[i+1]))
				strcpy(&buff1[i],&buff1[i+1]);
		}
		if(strlen(buff1)-nspace <= minlen)
			goto donesc;
	}

	upper=strlen(buff1)-1;

	for (i=upper; i>=0; i--) {
		if ( islower(buff1[i]) ){
			if(i>0) {
				if(!(isspace(buff1[i-1]) &&isspace(buff1[i+1])) )
					strcpy(&buff1[i],&buff1[i+1]);
			}
			else if(!isspace(buff1[i+1]))
				strcpy(&buff1[i],&buff1[i+1]);
		}
		if(strlen(buff1)-nspace <= minlen)
			goto donesc;
	}

	/* all else has failed so we use brute force */

	upper=strlen(buff1);
	for (i=upper; i>0; i--) {
		if( !(isspace(buff1[i-1]) && isspace(buff1[i+1])) )
			strcpy(&buff1[i],&buff1[i+1]);
		if(strlen(buff1)-nspace <= minlen)
			goto donesc;
	}

donesc:
	upper=strlen(buff1);
	if(upper > minlen )
		for (i=upper-1; i>0; i--)
			if(isspace(buff1[i]))
				strcpy(&buff1[i],&buff1[i+1]);

	return(mkChar(buff1));
}

SEXP do_abbrev(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP ans;
	int i, len, minlen, uclass;

	checkArity(op,args);

	if(!isString(CAR(args)))
		errorcall(call,"the first argument must be a string\n");

	len=length(CAR(args));
	PROTECT(ans=allocVector(STRSXP,len));
	minlen=asInteger(CADR(args));
	uclass=asLogical(CAR(CDDR(args)));

	for(i=0 ; i<len ; i++)
		STRING(ans)[i]=stripchars(STRING(CAR(args))[i],minlen);
	UNPROTECT(1);
	return(ans);
}

SEXP do_makenames(SEXP call, SEXP op, SEXP args, SEXP env)
{
	SEXP arg, ans;
	int i, l, n;
	char *p;

	checkArity(op ,args);
	arg = CAR(args);
	if(!isString(arg))
		errorcall(call, "non-character names\n");
	n = length(arg);
	PROTECT(ans = allocVector(STRSXP, n));
	for(i=0 ; i<n ; i++) {
		l = strlen(CHAR(STRING(arg)[i]));
		if (isalpha(CHAR(STRING(arg)[i])[0])) {
			STRING(ans)[i] = allocString(l);
			strcpy(CHAR(STRING(ans)[i]), CHAR(STRING(arg)[i]));
		}
		else {
			STRING(ans)[i] = allocString(l+1);
			strcpy(CHAR(STRING(ans)[i]), "X");
			strcat(CHAR(STRING(ans)[i]), CHAR(STRING(arg)[i]));
		}
		p = CHAR(STRING(ans)[i]);
		while(*p) {
			if(!isalnum(*p) && *p != '.')
				*p = '.';
			p++;
		}
	}
	UNPROTECT(1);
	return ans;
}

#ifdef HAVE_REGCOMP
#include <sys/types.h>
#include <regex.h>
#endif

SEXP do_grep(SEXP call, SEXP op, SEXP args, SEXP env)
{
#ifdef HAVE_REGCOMP
	SEXP pat, vec, ind, ans;
	regex_t reg;
	int i, j, n, nmatches;
	int igcase_opt, extended_opt, value_opt, eflags;

	checkArity(op, args);
	pat = CAR(args); args = CDR(args);
	vec = CAR(args); args = CDR(args);
	igcase_opt = asLogical(CAR(args)); args = CDR(args);
	extended_opt = asLogical(CAR(args)); args = CDR(args);
	value_opt = asLogical(CAR(args)); args = CDR(args);
	if(igcase_opt == NA_INTEGER) igcase_opt = 0;
	if(extended_opt == NA_INTEGER) extended_opt = 1;
	if(value_opt == NA_INTEGER) value_opt = 0;

	if(!isString(pat) || length(pat) < 1 || !isString(vec))
		errorcall(call, "invalid argument\n");

	eflags = 0;

	if(extended_opt) eflags = eflags | REG_EXTENDED;
	if(igcase_opt) eflags = eflags | REG_ICASE;

	if(regcomp(&reg, CHAR(STRING(pat)[0]), eflags))
		errorcall(call, "invalid regular expression\n");

	n = length(vec);
	ind = allocVector(LGLSXP, n);
	nmatches = 0;
	for(i=0 ; i<n ; i++) {
		if(regexec(&reg, CHAR(STRING(vec)[i]), 0, NULL, 0) == 0) {
			INTEGER(ind)[i] = 1;
			nmatches++;
		}
		else INTEGER(ind)[i] = 0;
	}
	regfree(&reg);
	PROTECT(ind);
	if(value_opt) {
		ans = allocVector(STRSXP, nmatches);
		j = 0;
		for(i=0 ; i<n ; i++)
			if(INTEGER(ind)[i])
				STRING(ans)[j++] = STRING(vec)[i];
	}
	else {
		ans = allocVector(INTSXP, nmatches);
		j = 0;
		for(i=0 ; i<n ; i++)
			if(INTEGER(ind)[i]) INTEGER(ans)[j++] = i+1;
	}
	UNPROTECT(1);
	return ans;
#else
	errorcall(call, "POSIX regular expressions not available\n");
#endif
}

#ifdef HAVE_REGCOMP

	/*  The following R functions do substitution for     */
	/*  regular expressions, either once or globally.     */
	/*  The functions are loosely patterned on the "sub"  */
	/*  and "gsub" in "nawk".			      */

static int length_adj(char *repl, regmatch_t *regmatch, int nsubexpr)
{
	int k, n;
	char *p = repl;
	n = strlen(repl) - (regmatch[0].rm_eo - regmatch[0].rm_so);
	while(*p) {
		if(*p == '\\') {
			if('1' <= p[1] && p[1] <= '9') {
				k = p[1] - '0';
				if(k > nsubexpr)
					error("invalid backreference in regular expression\n");
				n += (regmatch[k].rm_eo - regmatch[k].rm_so) - 2;
				p++;
			}
			else if(p[1] == 0) {
				/* can't escape the final '\0' */
				n -= 1;
			}
			else {
				n -= 1;
				p++;
			}
		}
		p++;
	}
	return n;
}

static char *string_adj(char *target, char *orig, char *repl,
	regmatch_t *regmatch, int nsubexpr)
{
	int i, k;
	char *p = repl, *t = target;
	while(*p) {
		if(*p == '\\') {
			if('1' <= p[1] && p[1] <= '9') {
				k = p[1] - '0';
				for(i=regmatch[k].rm_so ; i<regmatch[k].rm_eo ; i++)
					*t++ = orig[i];
				p += 2;
			}
			else if(p[1] == 0) {
				p += 1;
			}
			else {
				p += 1;
				*t++ = *p++;
			}
		}
		else *t++ = *p++;
	}
	return t;
}

#endif

SEXP do_gsub(SEXP call, SEXP op, SEXP args, SEXP env)
{
#ifdef HAVE_REGCOMP
	SEXP pat, rep, vec, ans;
	regex_t reg;
	regmatch_t regmatch[10];
	int i, j, n, ns, nmatch, offset;
	int global, igcase_opt, extended_opt, eflags;
	char *s, *t, *u;

	checkArity(op, args);

	global = PRIMVAL(op);

	pat = CAR(args); args = CDR(args);
	rep = CAR(args); args = CDR(args);
	vec = CAR(args); args = CDR(args);
	igcase_opt = asLogical(CAR(args)); args = CDR(args);
	extended_opt = asLogical(CAR(args)); args = CDR(args);
	if(igcase_opt == NA_INTEGER) igcase_opt = 0;
	if(extended_opt == NA_INTEGER) extended_opt = 1;

	if(!isString(pat) || length(pat) < 1 ||
	   !isString(rep) || length(rep) < 1 ||
	   !isString(vec))
		errorcall(call, "invalid argument\n");

	eflags = 0;
	if(extended_opt) eflags = eflags | REG_EXTENDED;
	if(igcase_opt) eflags = eflags | REG_ICASE;

	if(regcomp(&reg, CHAR(STRING(pat)[0]), eflags))
		errorcall(call, "invalid regular expression\n");

	n = length(vec);
	PROTECT(ans = allocVector(STRSXP, n));

	for(i=0 ; i<n ; i++) {
		offset = 0;
		nmatch = 0;
		s = CHAR(STRING(vec)[i]);
		t = CHAR(STRING(rep)[0]);
		ns = strlen(s);
		while(regexec(&reg, &s[offset], 10, regmatch, 0) == 0) {
			nmatch += 1;
			ns += length_adj(t, regmatch, reg.re_nsub);
			offset += regmatch[0].rm_eo;
			if(s[offset] == '\0' || !global) break;
		}
		if(nmatch == 0) STRING(ans)[i] = STRING(vec)[i];
		else {
			STRING(ans)[i] = allocString(ns);
			offset = 0;
			nmatch = 0;
			s = CHAR(STRING(vec)[i]);
			t = CHAR(STRING(rep)[0]);
			u = CHAR(STRING(ans)[i]);
			ns = strlen(s);
			while(regexec(&reg, &s[offset], 10, regmatch, 0) == 0) {
				for(j=0; j<regmatch[0].rm_so ; j++)
					*u++ = s[offset+j];
				u = string_adj(u, &s[offset], t, regmatch, reg.re_nsub);
				offset += regmatch[0].rm_eo;
				if(s[offset] == '\0' || !global) break;
			}
			for(j=offset ; s[j] ; j++)
				*u++ = s[j];
			*u = '\0';
		}
	}
	regfree(&reg);
	UNPROTECT(1);
	return ans;
#else
	errorcall(call, "POSIX regular expressions not available\n");
#endif
}
