/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1999--2018  The R Core Team.
 *  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, a copy is available at
 *  https://www.R-project.org/Licenses/
 */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include <Defn.h>
#include <Internal.h>
#include <R_ext/Itermacros.h>

/* interval at which to check interrupts, a guess */
// #define NINTERRUPT 10000000


static SEXP lunary(SEXP, SEXP, SEXP);
static SEXP lbinary(SEXP, SEXP, SEXP);
static SEXP binaryLogic(int code, SEXP s1, SEXP s2);
static SEXP binaryLogic2(int code, SEXP s1, SEXP s2);


/* & | ! */
SEXP attribute_hidden do_logic(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP arg1 = CAR(args); //, arg2 = CADR(args)
    Rboolean attr1 = ATTRIB(arg1) != R_NilValue;
    if (attr1 || ATTRIB(CADR(args)) != R_NilValue) {
	SEXP ans;
	if (DispatchGroup("Ops", call, op, args, env, &ans))
	    return ans;
    }
    /* The above did dispatch to valid S3/S4 methods, including those with
     * "wrong" number of arguments.
     * Now require binary calls to `&` and `|`  or unary calls to `!` : */
    checkArity(op, args);

    if (CDR(args) == R_NilValue) { // one argument  <==>  !(arg1)
	if (!attr1 && IS_SCALAR(arg1, LGLSXP)) {
	    /* directly handle '!' operator for simple logical scalars. */
	    int v = SCALAR_LVAL(arg1);
	    return ScalarLogical(v == NA_LOGICAL ? v : ! v);
	}
	return lunary(call, op, arg1);
    }
    // else : two arguments
    return lbinary(call, op, args);
}

#define isRaw(x) (TYPEOF(x) == RAWSXP)
static SEXP lbinary(SEXP call, SEXP op, SEXP args)
{
/* logical binary : "&" or "|" */
    SEXP
	x = CAR(args),
	y = CADR(args);

    if (isRaw(x) && isRaw(y)) {
    }
    else if ( !(isNull(x) || isNumber(x)) ||
	      !(isNull(y) || isNumber(y)) )
	errorcall(call,
		  _("operations are possible only for numeric, logical or complex types"));

    R_xlen_t
	nx = xlength(x),
	ny = xlength(y);
    Rboolean
	xarray = isArray(x),
	yarray = isArray(y),
	xts = isTs(x),
	yts = isTs(y);
    SEXP dims, xnames, ynames;
    if (xarray || yarray) {
	if (xarray && yarray) {
	    if (!conformable(x, y))
		errorcall(call, _("non-conformable arrays"));
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else if (xarray && (ny != 0 || nx == 0)) {
	    PROTECT(dims = getAttrib(x, R_DimSymbol));
	}
	else if (yarray && (nx != 0 || ny == 0)) {
	    PROTECT(dims = getAttrib(y, R_DimSymbol));
	} else
	    PROTECT(dims = R_NilValue);

	PROTECT(xnames = getAttrib(x, R_DimNamesSymbol));
	PROTECT(ynames = getAttrib(y, R_DimNamesSymbol));
    }
    else {
	PROTECT(dims = R_NilValue);
	PROTECT(xnames = getAttrib(x, R_NamesSymbol));
	PROTECT(ynames = getAttrib(y, R_NamesSymbol));
    }

    SEXP klass = NULL, tsp = NULL; // -Wall
    if (xts || yts) {
	if (xts && yts) {
	    /* could check ts conformance here */
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else if (xts) {
	    if (nx < ny)
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(x, R_TspSymbol));
	    PROTECT(klass = getAttrib(x, R_ClassSymbol));
	}
	else /*(yts)*/ {
	    if (ny < nx)
		ErrorMessage(call, ERROR_TSVEC_MISMATCH);
	    PROTECT(tsp = getAttrib(y, R_TspSymbol));
	    PROTECT(klass = getAttrib(y, R_ClassSymbol));
	}
    }
    if (nx > 0 && ny > 0) {
	if(((nx > ny) ? nx % ny : ny % nx) != 0) // mismatch
	    warningcall(call,
			_("longer object length is not a multiple of shorter object length"));

	if (isRaw(x) && isRaw(y)) {
	    x = binaryLogic2(PRIMVAL(op), x, y);
	}
	else {
	    if(isNull(x))
		x = SETCAR(args, allocVector(LGLSXP, 0));
	    else // isNumeric(x)
		x = SETCAR(args, coerceVector(x, LGLSXP));
	    if(isNull(y))
		y = SETCAR(args, allocVector(LGLSXP, 0));
	    else // isNumeric(y)
		y = SETCADR(args, coerceVector(y, LGLSXP));
	    x = binaryLogic(PRIMVAL(op), x, y);
	}
    } else { // nx == 0 || ny == 0
	x = allocVector((isRaw(x) && isRaw(y)) ? RAWSXP : LGLSXP, 0);
    }

    PROTECT(x);
    if (dims != R_NilValue) {
	setAttrib(x, R_DimSymbol, dims);
	if(xnames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, xnames);
	else if(ynames != R_NilValue)
	    setAttrib(x, R_DimNamesSymbol, ynames);
    }
    else {
	if(xnames != R_NilValue && XLENGTH(x) == XLENGTH(xnames))
	    setAttrib(x, R_NamesSymbol, xnames);
	else if(ynames != R_NilValue && XLENGTH(x) == XLENGTH(ynames))
	    setAttrib(x, R_NamesSymbol, ynames);
    }

    if (xts || yts) {
	setAttrib(x, R_TspSymbol, tsp);
	setAttrib(x, R_ClassSymbol, klass);
	UNPROTECT(2);
    }
    UNPROTECT(4);
    return x;
}

static SEXP lunary(SEXP call, SEXP op, SEXP arg)
{
    SEXP x, dim, dimnames, names;
    R_xlen_t i, len;

    len = XLENGTH(arg);
    if (!isLogical(arg) && !isNumber(arg) && !isRaw(arg)) {
	/* For back-compatibility */
	if (!len) return allocVector(LGLSXP, 0);
	errorcall(call, _("invalid argument type"));
    }
    if (isLogical(arg) || isRaw(arg))
	// copy all attributes in this case
	x = PROTECT(shallow_duplicate(arg));
    else {
	x = PROTECT(allocVector(isRaw(arg) ? RAWSXP : LGLSXP, len));
	PROTECT(names = getAttrib(arg, R_NamesSymbol));
	PROTECT(dim = getAttrib(arg, R_DimSymbol));
	PROTECT(dimnames = getAttrib(arg, R_DimNamesSymbol));
	if(names != R_NilValue) setAttrib(x, R_NamesSymbol, names);
	if(dim != R_NilValue) setAttrib(x, R_DimSymbol, dim);
	if(dimnames != R_NilValue) setAttrib(x, R_DimNamesSymbol, dimnames);
	UNPROTECT(3);
    }
    switch(TYPEOF(arg)) {
    case LGLSXP:
	{
	    int *px = LOGICAL(x);
	    const int *parg = LOGICAL_RO(arg);
	    for (i = 0; i < len; i++) {
//	        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		int v = parg[i];
		px[i] = (v == NA_LOGICAL) ? NA_LOGICAL : v == 0;
	    }
	}
	break;
    case INTSXP:
	{
	    int *px = LOGICAL(x);
	    const int *parg = INTEGER_RO(arg);
	    for (i = 0; i < len; i++) {
//	        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		int v = parg[i];
		px[i] = (v == NA_INTEGER) ? NA_LOGICAL : v == 0;
	    }
	}
	break;
    case REALSXP:
	{
	    int *px = LOGICAL(x);
	    const double *parg = REAL_RO(arg);
	    for (i = 0; i < len; i++){
//	        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		double v = parg[i];
		px[i] = ISNAN(v) ? NA_LOGICAL : v == 0;
	    }
	}
	break;
    case CPLXSXP:
	{
	    int *px = LOGICAL(x);
	    const Rcomplex *parg = COMPLEX_RO(arg);
	    for (i = 0; i < len; i++) {
//	        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		Rcomplex v = parg[i];
		px[i] = (ISNAN(v.r) || ISNAN(v.i))
		    ? NA_LOGICAL : (v.r == 0. && v.i == 0.);
	    }
	}
	break;
    case RAWSXP:
	{
	    Rbyte *px = RAW(x);
	    const Rbyte *parg = RAW_RO(arg);
	    for (i = 0; i < len; i++) {
//	        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
		px[i] = 0xFF ^ parg[i];
	    }
	}
	break;
    default:
	UNIMPLEMENTED_TYPE("lunary", arg);
    }
    UNPROTECT(1);
    return x;
}

/* && || */
SEXP attribute_hidden do_logic2(SEXP call, SEXP op, SEXP args, SEXP env)
{
/*  &&	and  ||	 */
    SEXP s1, s2;
    int x1, x2;
    int ans = FALSE;

    if (length(args) != 2)
	error(_("'%s' operator requires 2 arguments"),
	      PRIMVAL(op) == 1 ? "&&" : "||");

    s1 = CAR(args);
    s2 = CADR(args);
    PROTECT(s1 = eval(s1, env));
    if (!isNumber(s1))
	errorcall(call, _("invalid 'x' type in 'x %s y'"),
		  PRIMVAL(op) == 1 ? "&&" : "||");

    x1 = asLogical2(s1, /*checking*/ 1, call, env);
    UNPROTECT(1); /* s1 */

#define get_2nd							\
	PROTECT(s2 = eval(s2, env));				\
	if (!isNumber(s2))					\
	    errorcall(call, _("invalid 'y' type in 'x %s y'"),	\
		      PRIMVAL(op) == 1 ? "&&" : "||");		\
	x2 = asLogical2(s2, 1, call, env);			\
	UNPROTECT(1); /* s2 */

    switch (PRIMVAL(op)) {
    case 1: /* && */
	if (x1 == FALSE)
	    ans = FALSE;
	else {
	    get_2nd;
	    if (x1 == NA_LOGICAL)
		ans = (x2 == NA_LOGICAL || x2) ? NA_LOGICAL : x2;
	    else /* x1 == TRUE */
		ans = x2;
	}
	break;
    case 2: /* || */
	if (x1 == TRUE)
	    ans = TRUE;
	else {
	    get_2nd;
	    if (x1 == NA_LOGICAL)
		ans = (x2 == NA_LOGICAL || !x2) ? NA_LOGICAL : x2;
	    else /* x1 == FALSE */
		ans = x2;
	}
    }
    return ScalarLogical(ans);
}

static SEXP binaryLogic(int code, SEXP s1, SEXP s2)
{
    R_xlen_t i, n, n1, n2, i1, i2;
    int x1, x2;
    SEXP ans;

    n1 = XLENGTH(s1);
    n2 = XLENGTH(s2);
    n = (n1 > n2) ? n1 : n2;
    if (n1 == 0 || n2 == 0) {
	ans = allocVector(LGLSXP, 0);
	return ans;
    }
    ans = allocVector(LGLSXP, n);

    int *px1 = LOGICAL(s1);
    int *px2 = LOGICAL(s2);
    int *pa = LOGICAL(ans);

    switch (code) {
    case 1:		/* & : AND */
	MOD_ITERATE2(n, n1, n2, i, i1, i2, {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    x1 = px1[i1];
	    x2 = px2[i2];
	    if (x1 == 0 || x2 == 0)
		pa[i] = 0;
	    else if (x1 == NA_LOGICAL || x2 == NA_LOGICAL)
		pa[i] = NA_LOGICAL;
	    else
		pa[i] = 1;
	});
	break;
    case 2:		/* | : OR */
	MOD_ITERATE2(n, n1, n2, i, i1, i2, {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    x1 = px1[i1];
	    x2 = px2[i2];
	    if ((x1 != NA_LOGICAL && x1) || (x2 != NA_LOGICAL && x2))
		pa[i] = 1;
	    else if (x1 == 0 && x2 == 0)
		pa[i] = 0;
	    else
		pa[i] = NA_LOGICAL;
	});
	break;
    case 3:
	error(_("Unary operator `!' called with two arguments"));
	break;
    }
    return ans;
}

// called only when both  s1 and s2 are  RAWSXP
static SEXP binaryLogic2(int code, SEXP s1, SEXP s2)
{
    R_xlen_t i, n, n1, n2, i1, i2;
    Rbyte x1, x2;
    SEXP ans;

    n1 = XLENGTH(s1);
    n2 = XLENGTH(s2);
    n = (n1 > n2) ? n1 : n2;
    if (n1 == 0 || n2 == 0) {
	ans = allocVector(RAWSXP, 0);
	return ans;
    }
    ans = allocVector(RAWSXP, n);

    switch (code) {
    case 1:		/* & : AND */
	MOD_ITERATE2(n, n1, n2, i, i1, i2, {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    x1 = RAW(s1)[i1];
	    x2 = RAW(s2)[i2];
	    RAW(ans)[i] = x1 & x2;
	});
	break;
    case 2:		/* | : OR */
	MOD_ITERATE2(n, n1, n2, i, i1, i2, {
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	    x1 = RAW(s1)[i1];
	    x2 = RAW(s2)[i2];
	    RAW(ans)[i] = x1 | x2;
	});
	break;
    }
    return ans;
}

#define _OP_ALL 1
#define _OP_ANY 2

static int checkValues(int op, int na_rm, SEXP x, R_xlen_t n)
{
    R_xlen_t i;
    int has_na = 0;
    int *px = LOGICAL(x);
    for (i = 0; i < n; i++) {
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
	int xi = px[i];
	if (!na_rm && xi == NA_LOGICAL) has_na = 1;
	else {
	    if (xi == TRUE && op == _OP_ANY) return TRUE;
	    if (xi == FALSE && op == _OP_ALL) return FALSE;
	}
    }
    switch (op) {
    case _OP_ANY:
	return has_na ? NA_LOGICAL : FALSE;
    case _OP_ALL:
	return has_na ? NA_LOGICAL : TRUE;
    default:
	error("bad op value for do_logic3");
    }
    return NA_LOGICAL; /* -Wall */
}

/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, s, t, call2;
    int narm, has_na = 0;
    /* initialize for behavior on empty vector
       all(logical(0)) -> TRUE
       any(logical(0)) -> FALSE
     */
    Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;

    PROTECT(args = fixup_NaRm(args));
    PROTECT(call2 = shallow_duplicate(call));
    SETCDR(call2, args);

    if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
	UNPROTECT(2);
	return(ans);
    }

    ans = matchArgExact(R_NaRmSymbol, &args);
    narm = asLogical2(ans, /*warn_level*/ 1, call, env);

    for (s = args; s != R_NilValue; s = CDR(s)) {
	t = CAR(s);
	/* Avoid memory waste from coercing empty inputs, and also
	   avoid warnings with empty lists coming from sapply */
	if(xlength(t) == 0) continue;
	/* coerceVector protects its argument so this actually works
	   just fine */
	if (TYPEOF(t) != LGLSXP) {
	    /* Coercion of integers seems reasonably safe, but for
	       other types it is more often than not an error.
	       One exception is perhaps the result of lapply, but
	       then sapply was often what was intended. */
	    if(TYPEOF(t) != INTSXP)
		warningcall(call,
			    _("coercing argument of type '%s' to logical"),
			    type2char(TYPEOF(t)));
	    t = coerceVector(t, LGLSXP);
	}
	val = checkValues(PRIMVAL(op), narm, t, XLENGTH(t));
	if (val != NA_LOGICAL) {
	    if ((PRIMVAL(op) == _OP_ANY && val)
		|| (PRIMVAL(op) == _OP_ALL && !val)) {
		has_na = 0;
		break;
	    }
	} else has_na = 1;
    }
    UNPROTECT(2);
    return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
#undef _OP_ALL
#undef _OP_ANY