/*************************************************************************
*									 *
*	 YapR Module for Yap Prolog 					 *
*									 *
*	YapR Prolog was developed at FEUP - Universidade do Porto	 *
*									 *
* Copyright Joao Azevedo and Universidade do Porto 2010-2011  		 *
*									 *
**************************************************************************
*									 *
* File:		YapR.c							 *
* Last rev:								 *
* mods:									 *
* comments:	C code to interface R-project software with Yap		 *
*									 *
*************************************************************************/

#include <YapR.h>

void init_R()
{
    int argc = 2;
    char * argv[] = {"R", "--silent"};

    Rf_initEmbeddedR(argc, argv);
}

void end_R()
{
    Rf_endEmbeddedR(0);
    R_dot_Last();
    R_RunExitFinalizers();
    R_gc();
}

static SEXP process_expression(char * expression)
{
    SEXP e, tmp, val;
    int hadError;
    ParseStatus status;

    PROTECT(tmp = mkString(expression));
    PROTECT(e = R_ParseVector(tmp, 1, &status, R_NilValue));
    val = R_tryEval(VECTOR_ELT(e, 0), R_GlobalEnv, &hadError);
    UNPROTECT(2);

    if (!hadError)
        return val;
    return NULL;
}

void send_command(char * expression)
{
    process_expression(expression);
}

double get_double(char * expression)
{
    double result;
    SEXP val = process_expression(expression);

    if (val != NULL)
    {
      PROTECT(val);
      result = REAL(val)[0];
      UNPROTECT(1);
    } else {
      return -1;
    }

    return result;
}

int get_int(char * expression)
{
    int result;
    SEXP val = process_expression(expression);

    if (val != NULL)
    {
        if (isInteger(val))
        {
            PROTECT(val);
            result = INTEGER(val)[0];
            UNPROTECT(1);
        }
        else
        {
            PROTECT(val);
            result = (int) REAL(val)[0];
            UNPROTECT(1);
        }
    } else {
      return -1;
    }

    return result;
}

static YAP_Term get_sexp(SEXP val);

static YAP_Term
mkarray(int *dimsp, int ndims, int i0, int im, SEXP val)
{
  YAP_Term *tp = (YAP_Term *) malloc(sizeof(YAP_Term)*dimsp[0]);
  YAP_Term to;

  if (!tp)
    return YAP_TermNil();
  // base case 
  if (ndims == 1) {
    PROTECT(val);
    if (IS_INTEGER(val))
      {
	int i, j=0;
	for (i=i0; i < im; i++) {
	  YAP_Int el = INTEGER(val)[i];
	  tp[j++] = YAP_MkIntTerm(el);
	}
      }
    else if (IS_NUMERIC(val))
      {
	int i, j=0;
	for (i=i0; i < im; i++) {
	  YAP_Float el = REAL(val)[i];
	  tp[j++] = YAP_MkFloatTerm(el);
	}
      }
    else if (IS_CHARACTER(val))
      {
	int i, j=0;
	for (i=i0; i < im; i++) {
	  const char *el = CHAR(STRING_ELT(val,i));
	  tp[j++] = YAP_BufferToString(el);
	}
      }
    else
      {
	int i, j=0;
	YAP_Term tn = YAP_TermNil();
	for (i=i0; i < im; i++) {
	  tp[j++] = tn;
	}
      }
    UNPROTECT(1);	  
  } else {
    int cdim = dimsp[0], i;
    int sz = (im-i0)/cdim;
    for (i = 0; i < cdim; i++) {
      //      fprintf(stderr,"%d %d--%d\n", sz, i0, i0+sz);
      tp[i] = mkarray(dimsp+1, ndims-1, i0, i0+sz, val);
      i0 += sz;
    }
  }
  to = YAP_MkListFromTerms(tp, dimsp[0]);
  free(tp);
  return to;
}

static YAP_Term
get_sexp(SEXP val)
{
  size_t size = 0, nDims;

  fprintf(stderr, "%d\n", IS_VECTOR(val));

  if (val == NULL)
    {
      return YAP_TermNil();
    }
  size = LENGTH(val);

  SEXP dims = getAttrib(val, R_DimSymbol);
  if (dims == R_NilValue)
    {
      int dimsv = size; 
      return mkarray(&dimsv, 1, 0, size, val);
    }
  else
    {
      int i;

      nDims = LENGTH(dims);
      int *dimsp = (int *)malloc(sizeof(int)*nDims);
      if (!dimsp)
	return YAP_TermNil();
      for (i = 0; i < nDims; i++)
	{
	  // copy dimensions;
	  PROTECT(dims);
	  dimsp[i] = INTEGER(dims)[i];
	  UNPROTECT(1);
	}
      return mkarray(dimsp, nDims, 0, size, val);
    }
}

YAP_Term
get_list(char * expression)
{
  SEXP val = process_expression(expression);

  return get_sexp(val);
}
