/*
 *  gretl -- Gnu Regression, Econometrics and Time-series Library
 *  Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
 *
 *  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 3 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, see <http://www.gnu.org/licenses/>.
 *
 */

#define FULL_XML_HEADERS 1

#include "libgretl.h"
#include "uservar.h"
#include "gretl_func.h"
#include "gretl_xml.h"
#include "gretl_typemap.h"
#include "matrix_extra.h"
#include "gretl_cmatrix.h"
#include "gretl_array.h"

/**
 * gretl_array:
 *
 * An opaque type; use the relevant accessor functions.
 */

struct gretl_array_ {
    GretlType type;  /* type of data */
    int n;           /* number of elements */
    void **data;     /* actual data array */
};

static void gretl_array_destroy_data (gretl_array *A)
{
    int i;

    if (A->data != NULL) {
	if (A->type == GRETL_TYPE_STRINGS ||
	    A->type == GRETL_TYPE_LISTS) {
	    /* a simple "free" will do */
	    for (i=0; i<A->n; i++) {
		free(A->data[i]);
	    }
	} else if (A->type == GRETL_TYPE_MATRICES) {
	    for (i=0; i<A->n; i++) {
		gretl_matrix_free(A->data[i]);
	    }
	} else if (A->type == GRETL_TYPE_BUNDLES) {
	    for (i=0; i<A->n; i++) {
		gretl_bundle_destroy(A->data[i]);
	    }
	} else if (A->type == GRETL_TYPE_ARRAYS) {
	    for (i=0; i<A->n; i++) {
		gretl_array_destroy(A->data[i]);
	    }
	}
	free(A->data);
	A->data = NULL;
    }
}

/* Destroy the whole array, including freeing its
   contents.
*/

void gretl_array_destroy (gretl_array *A)
{
    if (A != NULL) {
	gretl_array_destroy_data(A);
	free(A);
    }
}

/* Reduce the array to empty status, freeing the
   contents but not the array structure itself.
*/

void gretl_array_void_content (gretl_array *A)
{
    if (A != NULL) {
	gretl_array_destroy_data(A);
	A->n = 0;
    }
}

/* Set the array's element pointers to NULL, without
   freeing them. Makes sense only if the element
   pointers are actually "owned" by something else
   (have not been copied into the array).
*/

void gretl_array_nullify_elements (gretl_array *A)
{
    if (A != NULL && A->data != NULL) {
	int i;

	for (i=0; i<A->n; i++) {
	    A->data[i] = NULL;
	}
    }
}

static int array_allocate_storage (gretl_array *A)
{
    int i, err = 0;

    A->data = malloc(A->n * sizeof *A->data);

    if (A->data == NULL) {
	err = E_ALLOC;
    } else {
	for (i=0; i<A->n; i++) {
	    A->data[i] = NULL;
	}
    }

    return err;
}

static int array_extend_content (gretl_array *A, int plus)
{
    if (plus == 0) {
	return 0; /* no-op */
    } else if (plus < 0) {
	return E_DATA;
    } else {
	void **data;
	int n = A->n + plus;
	int i, err = 0;

	data = realloc(A->data, n * sizeof *A->data);

	if (data == NULL) {
	    err = E_ALLOC;
	} else {
	    for (i=A->n; i<n-1; i++) {
		data[i] = NULL;
	    }
	    A->data = data;
	    A->n = n;
	}

	return err;
    }
}

/* Create a new array of type @type. The idea is that it's OK
   to have n = 0: in that case the array starts empty but can
   be extended by the += operator. Or it can be sized in
   advance.
*/

gretl_array *gretl_array_new (GretlType type, int n, int *err)
{
    gretl_array *A;

    if (type != GRETL_TYPE_STRINGS &&
	type != GRETL_TYPE_MATRICES &&
	type != GRETL_TYPE_BUNDLES &&
	type != GRETL_TYPE_LISTS &&
	type != GRETL_TYPE_ARRAYS &&
	type != GRETL_TYPE_ANY) {
	*err = E_TYPES;
	return NULL;
    } else if (n < 0) {
	*err = E_DATA;
	return NULL;
    } else if (type == GRETL_TYPE_ANY && n > 0) {
	/* an array of unspecified type must be
	   empty in the first instance
	*/
	*err = E_TYPES;
	return NULL;
    }

    A = malloc(sizeof *A);

    if (A == NULL) {
	*err = E_ALLOC;
    } else {
	A->type = type;
	A->n = n;
	A->data = NULL;
	if (n > 0) {
	    *err = array_allocate_storage(A);
	    if (*err) {
		gretl_array_destroy(A);
		A = NULL;
	    }
	}
    }

    return A;
}

gretl_array *gretl_array_from_strings (char **S, int n,
				       int copy, int *err)
{
    gretl_array *A;

    A = gretl_array_new(GRETL_TYPE_STRINGS, 0, err);

    if (A != NULL && n > 0) {
	if (copy) {
	    A->data = (void **) strings_array_dup(S, n);
	    if (A->data == NULL) {
		*err = E_ALLOC;
	    }
	} else {
	    A->data = (void **) S;
	}
	if (!*err) {
	    A->n = n;
	}
    }

    return A;
}

/* When we're returning an array of strings, ensure
   that any NULL elements are converted to empty
   strings.
*/

static int strings_array_null_check (gretl_array *A)
{
    int i;

    for (i=0; i<A->n; i++) {
	if (A->data[i] == NULL) {
	    A->data[i] = gretl_strdup("");
	    if (A->data[i] == NULL) {
		return E_ALLOC;
	    }
	}
    }

    return 0;
}

/* note: don't modify the returned value */

char **gretl_array_get_strings (gretl_array *A, int *ns)
{
    char **AS = NULL;

    *ns = 0;

    if (A != NULL && A->type == GRETL_TYPE_STRINGS) {
	int err = strings_array_null_check(A);

	if (!err) {
	    *ns = A->n;
	    AS = (char **) A->data;
	}
    }

    return AS;
}

char **gretl_array_get_stringify_strings (gretl_array *A,
					  int nreq, int *pns,
					  int *err)
{
    char **S = NULL;

    *pns = 0;

    if (A == NULL) {
	*err = E_DATA;
    } else if (A->type != GRETL_TYPE_STRINGS) {
	*err = E_TYPES;
    } else if (A->n < nreq) {
	gretl_errmsg_sprintf("Too few strings: %d given but %d needed",
			     A->n, nreq);
	*err = E_DATA;
    }

    if (!*err) {
	char **AS = (char **) A->data;

	S = strings_array_new(A->n);
	if (S == NULL) {
	    *err = E_ALLOC;
	} else {
	    int myerr = 0;
	    int ndone = 0;
	    int i, j;

	    for (i=0; i<A->n && !myerr; i++) {
		if (AS[i] == NULL || AS[i][0] == '\0') {
		    myerr = E_DATA;
		} else {
		    S[i] = gretl_strdup(AS[i]);
		    if (i > 0) {
			for (j=0; j<i; j++) {
			    if (!strcmp(AS[j], S[i])) {
				gretl_errmsg_sprintf("Duplicated string '%s'", S[i]);
				myerr = E_DATA;
			    }
			}
		    }
		}
		if (!myerr) {
		    ndone++;
		}
	    }
	    if (myerr && ndone < nreq) {
		*err = myerr;
		strings_array_free(S, A->n);
		S = NULL;
	    } else {
		*pns = ndone;
	    }
	}
    }

    return S;
}

/* note: the return value is newly allocated, and owned by the caller */

char *gretl_strings_array_flatten (gretl_array *A, int space, int *err)
{
    const char *sep = space ? " " : "\n";
    char *s = NULL;

    if (A == NULL) {
	*err = E_DATA;
    } else if (A->type != GRETL_TYPE_STRINGS) {
	*err = E_TYPES;
    } else {
	int i, len = 0;

	for (i=0; i<A->n; i++) {
	    if (A->data[i] == NULL) {
		*err = E_MISSDATA;
		break;
	    } else {
		len += strlen(A->data[i]) + 1;
	    }
	}

	if (!*err) {
	    s = calloc(len, 1);
	    if (s == NULL) {
		*err = E_ALLOC;
	    } else {
		for (i=0; i<A->n; i++) {
		    strcat(s, A->data[i]);
		    if (i < A->n - 1) {
			strcat(s, sep);
		    }
		}
	    }
	}
    }

    return s;
}

void *gretl_array_get_element (gretl_array *A, int i,
			       GretlType *type,
			       int *err)
{
    void *ret = NULL;

    /* Note that the data returned here are not "deep copied",
       we just pass the pointer. It's up to the caller to
       decide if a copy has to be made, given that the
       pointer from here should not be modified.
    */

    if (A == NULL) {
	*err = E_UNKVAR;
    } else if (i < 0 || i >= A->n) {
	*err = E_INVARG;
    } else {
	if (type != NULL) {
	    *type = gretl_type_get_singular(A->type);
	}
	if (A->type == GRETL_TYPE_STRINGS) {
	    if (A->data[i] == NULL) {
		A->data[i] = gretl_strdup("");
	    }
	} else if (A->type == GRETL_TYPE_MATRICES) {
	    if (A->data[i] == NULL) {
		A->data[i] = gretl_null_matrix_new();
	    }
	} else if (A->type == GRETL_TYPE_BUNDLES) {
	    if (A->data[i] == NULL) {
		A->data[i] = gretl_bundle_new();
	    }
	} else if (A->type == GRETL_TYPE_ARRAYS) {
	    if (A->data[i] == NULL) {
		A->data[i] = gretl_array_new(GRETL_TYPE_ANY, 0, err);
	    }
	} else {
	    if (A->data[i] == NULL) {
		A->data[i] = gretl_list_new(0);
	    }
	}
	ret = A->data[i];
	if (ret == NULL) {
	    *err = E_ALLOC;
	}
    }

    return ret;
}

void *gretl_array_get_data (gretl_array *A, int i)
{
    if (A == NULL || i < 0 || i >= A->n) {
	return NULL;
    } else {
	return A->data[i];
    }
}

int gretl_array_set_data (gretl_array *A, int i, void *ptr)
{
    if (A == NULL || i < 0 || i >= A->n) {
	return E_DATA;
    } else {
	A->data[i] = ptr;
	return 0;
    }
}

gretl_array *gretl_array_copy_range (gretl_array *A,
				     int r1, int r2,
				     int *err)
{
    gretl_array *C = NULL;

    if (A == NULL) {
	*err = E_DATA;
    } else if (r1 < 0 || r1 >= A->n || r2 < r1 || r2 >= A->n) {
	*err = E_INVARG;
    } else {
	C = gretl_array_new(A->type, r2 - r1 + 1, err);
	if (!*err) {
	    int i, j = 0;

	    for (i=r1; i<=r2 && !*err; i++) {
		if (A->data[i] != NULL) {
		    if (A->type == GRETL_TYPE_STRINGS) {
			C->data[j] = gretl_strdup(A->data[i]);
		    } else if (A->type == GRETL_TYPE_MATRICES) {
			C->data[j] = gretl_matrix_copy(A->data[i]);
		    } else if (A->type == GRETL_TYPE_BUNDLES) {
			C->data[j] = gretl_bundle_copy(A->data[i], err);
		    } else if (A->type == GRETL_TYPE_ARRAYS) {
			C->data[j] = gretl_array_copy(A->data[i], err);
		    } else {
			C->data[j] = gretl_list_copy(A->data[i]);
		    }
		    if (!*err && C->data[j] == NULL) {
			*err = E_ALLOC;
		    }
		}
		j++;
	    }
	}
    }

    return C;
}

gretl_bundle *gretl_array_get_bundle (gretl_array *A, int i)
{
    gretl_bundle *b = NULL;

    /* The bundle returned here is not "deep copied",
       we just pass the pointer. It's up to the caller to
       decide if a copy has to be made, given that the
       pointer from here should not be modified.
    */

    if (A != NULL && i >= 0 && i < A->n &&
	A->type == GRETL_TYPE_BUNDLES) {
	b = A->data[i];
    }

    return b;
}

/* "flatten" an array of matrices, yielding a single matrix,
   by either horizontal or vertical concatenation. By
   default the concatenation is horizontal but if @vcat is
   non-zero it's vertical. An error is flagged if the
   matrices are not conformable for the operation.
*/

gretl_matrix *gretl_matrix_array_flatten (gretl_array *A,
					  int vcat,
					  int *err)
{
    gretl_matrix *ret = NULL;
    gretl_matrix *m;
    int common_r = 1;
    int common_c = 1;
    int sum_r = 0;
    int sum_c = 0;
    int r0 = 0, c0 = 0;
    int cmplx = 0;
    int real = 0;
    int i;

    if (A->type != GRETL_TYPE_MATRICES) {
	*err = E_TYPES;
	return NULL;
    }

    for (i=0; i<A->n; i++) {
	m = A->data[i];
	if (!gretl_is_null_matrix(m)) {
	    if (m->is_complex) {
		cmplx = 1;
	    } else {
		real = 1;
	    }
	}
    }

    for (i=0; i<A->n; i++) {
	m = A->data[i];
	if (!gretl_is_null_matrix(m)) {
	    if (c0 == 0) {
		r0 = m->rows;
		c0 = m->cols;
	    } else {
		if (m->rows != r0) {
		    common_r = 0;
		}
		if (m->cols != c0) {
		    common_c = 0;
		}
		if (!common_r && !common_c) {
		    *err = E_NONCONF;
		    break;
		}
	    }
	    sum_r += m->rows;
	    sum_c += m->cols;
	}
    }

    if (!*err) {
	if ((vcat && !common_c) || (!vcat && !common_r)) {
	    *err = E_NONCONF;
	}
    }

    if (!*err && sum_r == 0) {
	ret = gretl_null_matrix_new();
	if (ret == NULL) {
	    *err = E_ALLOC;
	}
    }

    if (*err || ret != NULL) {
	return ret;
    }

    if (vcat) {
	if (cmplx) {
	    ret = gretl_cmatrix_new(sum_r, c0);
	} else {
	    ret = gretl_matrix_alloc(sum_r, c0);
	}
    } else {
	if (cmplx) {
	    ret = gretl_cmatrix_new(r0, sum_c);
	} else {
	    ret = gretl_matrix_alloc(r0, sum_c);
	}
    }

    if (ret == NULL) {
	*err = E_ALLOC;
    } else if (vcat) {
	/* vertical concatenation */
	int ii, j, k, rpos = 0;
	double complex z;
	double x;

	for (k=0; k<A->n; k++) {
	    m = A->data[k];
	    if (!gretl_is_null_matrix(m)) {
		for (j=0; j<c0; j++) {
		    for (i=0, ii=rpos; i<m->rows; i++, ii++) {
			if (cmplx && !m->is_complex) {
			    z = gretl_matrix_get(m, i, j);
			    gretl_cmatrix_set(ret, ii, j, z);
			} else if (cmplx) {
			    z = gretl_cmatrix_get(m, i, j);
			    gretl_cmatrix_set(ret, ii, j, z);
			} else {
			    x = gretl_matrix_get(m, i, j);
			    gretl_matrix_set(ret, ii, j, x);
			}
		    }
		}
		rpos += m->rows;
	    }
	}
    } else if (cmplx && real) {
	/* horizontal concatenation: mixed matrices */
	double complex *dest = ret->z;
	int n, k = 0;

	for (i=0; i<A->n; i++) {
	    m = A->data[i];
	    if (!gretl_is_null_matrix(m)) {
		n = m->rows * m->cols;
		if (m->is_complex) {
		    memcpy(dest, m->z, n * sizeof *dest);
		} else {
		    real_to_complex_fill(ret, m, 0, k);
		}
		dest += n;
		k += m->cols;
	    }
	}
    } else {
	/* horizontal concatenation: the easy case */
	double *dest = ret->val;
	int n, p = cmplx ? 2 : 1;

	for (i=0; i<A->n; i++) {
	    m = A->data[i];
	    if (!gretl_is_null_matrix(m)) {
		n = p * m->rows * m->cols;
		memcpy(dest, m->val, n * sizeof *dest);
		dest += n;
	    }
	}
    }

    return ret;
}

gretl_array *gretl_matrix_split_by (const gretl_matrix *X,
				    const gretl_matrix *v,
				    int *err)
{
    gretl_array *ret = NULL;
    int i, j, k, l, n = 1;
    gretl_matrix *tmp = NULL;
    gretl_matrix *vals = NULL;
    const double *sel;
    int *nrows = NULL;
    double x;

    if (gretl_vector_get_length(v) != X->rows) {
	*err = E_INVARG;
	return ret;
    }

    /* only positive integers allowed */
    for (i=0; i<X->rows; i++) {
	x = v->val[i];
	if (x != floor(x) || x <= 0 || x >= INT_MAX) {
	    *err = E_INVARG;
	    return ret;
	}
    }

    sel = v->val;
    vals = gretl_matrix_values(sel, X->rows, OPT_NONE, err);
    if (*err) {
	return ret;
    }

    /* get the maximum index value */
    for (i=0; i<vals->rows; i++) {
	n = vals->val[i] > n ? vals->val[i] : n;
    }

    ret = gretl_array_new(GRETL_TYPE_MATRICES, n, err);
    if (*err) {
	return NULL;
    }

    /* count how many rows we have for each array element and
       allocate accordingly */
    nrows = calloc(n, sizeof *nrows);
    if (nrows == NULL) {
	*err = E_ALLOC;
    } else {
	for (i=0; i<X->rows; i++) {
	    j = sel[i] - 1;
	    nrows[j] += 1;
	}
    }
    for (i=0; i<n && !*err; i++) {
	if (nrows[i] > 0) {
	    tmp = gretl_matrix_alloc(nrows[i], X->cols);
	    if (tmp == NULL) {
		*err = E_ALLOC;
	    } else {
		gretl_array_set_element(ret, i, tmp, GRETL_TYPE_MATRIX, 0);
		/* @nrows serves as an array of counters below */
		nrows[i] = 0;
	    }
	}
    }

    /* fill the individual matrices */
    for (i=0; i<X->rows; i++) {
	k = sel[i] - 1;
	l = 0;
	for (j=0; j<X->cols; j++) {
	    x = gretl_matrix_get(X, i, j);
	    tmp = ret->data[k];
	    gretl_matrix_set(tmp, nrows[k], l++, x);
	}
	/* advance the write position */
	nrows[k] += 1;
    }

    free(nrows);
    gretl_matrix_free(vals);

    if (*err && ret != NULL) {
	gretl_array_destroy(ret);
	ret = NULL;
    }

    return ret;
}

int gretl_array_set_type (gretl_array *A, GretlType type)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (type != GRETL_TYPE_STRINGS &&
	       type != GRETL_TYPE_MATRICES &&
	       type != GRETL_TYPE_BUNDLES &&
	       type != GRETL_TYPE_LISTS &&
	       type != GRETL_TYPE_ARRAYS) {
	err = E_TYPES;
    } else if (A->n > 0) {
	/* we can (re-)set the type only if no data have
	   been entered already */
	int i;

	for (i=0; i<A->n; i++) {
	    if (A->data[i] != NULL) {
		err = E_DATA;
		break;
	    }
	}
    }

    if (!err) {
	A->type = type;
    }

    return err;
}

GretlType gretl_array_get_type (gretl_array *A)
{
    return (A != NULL)? A->type : GRETL_TYPE_NONE;
}

GretlType gretl_array_get_content_type (gretl_array *A)
{
    return (A != NULL)? gretl_type_get_singular(A->type) : GRETL_TYPE_NONE;
}

int gretl_array_get_length (gretl_array *A)
{
    return (A != NULL)? A->n : 0;
}

static int set_string (gretl_array *A, int i,
		       char *s, int copy)
{
    int err = 0;

    if (copy) {
	A->data[i] = gretl_strdup(s);
	if (A->data[i] == NULL) {
	    err = E_ALLOC;
	}
    } else {
	A->data[i] = s;
    }

    return err;
}

static int set_matrix (gretl_array *A, int i,
		       gretl_matrix *m, int copy)
{
    int err = 0;

    if (copy) {
	A->data[i] = gretl_matrix_copy(m);
	if (A->data[i] == NULL) {
	    err = E_ALLOC;
	}
    } else {
	A->data[i] = m;
    }

    return err;
}

static int set_bundle (gretl_array *A, int i,
		       gretl_bundle *b, int copy)
{
    int err = 0;

    if (copy) {
	A->data[i] = gretl_bundle_copy(b, &err);
    } else {
	A->data[i] = b;
    }

    return err;
}

static int set_array (gretl_array *A, int i,
		      gretl_array *a, int copy)
{
    int err = 0;

    if (copy) {
	A->data[i] = gretl_array_copy(a, &err);
    } else {
	A->data[i] = a;
    }

    return err;
}

static int set_list (gretl_array *A, int i,
		     int *L, int copy)
{
    int err = 0;

    if (copy) {
	A->data[i] = gretl_list_copy(L);
	if (A->data[i] == NULL) {
	    err = E_ALLOC;
	}
    } else {
	A->data[i] = L;
    }

    return err;
}

/* In the functions below we assume the @copy parameter
   will be set appropriately by "genr": if the incoming
   object is a named variable in its own right it should
   be copied, but if it's on on-the-fly thing there's
   no need to copy it, just "donate" it to the array.
*/

/* respond to A[i] = s */

int gretl_array_set_string (gretl_array *A, int i,
			    char *s, int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_STRINGS) {
	err = E_TYPES;
    } else if (i < 0 || i >= A->n) {
	gretl_errmsg_sprintf(_("Index value %d is out of bounds"), i+1);
	err = E_DATA;
    } else if (s != A->data[i]) {
	free(A->data[i]);
	err = set_string(A, i, s, copy);
    }

    return err;
}

/* respond to A += s */

int gretl_array_append_string (gretl_array *A,
			       char *s,
			       int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_STRINGS) {
	err = E_TYPES;
    } else {
	err = array_extend_content(A, 1);
	if (!err) {
	    err = set_string(A, A->n - 1, s, copy);
	}
    }

    return err;
}

/* respond to A[i] = m */

int gretl_array_set_matrix (gretl_array *A, int i,
			    gretl_matrix *m,
			    int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_MATRICES) {
	err = E_TYPES;
    } else if (i < 0 || i >= A->n) {
	gretl_errmsg_sprintf(_("Index value %d is out of bounds"), i+1);
	err = E_DATA;
    } else if (m != A->data[i]) {
	gretl_matrix_free(A->data[i]);
	err = set_matrix(A, i, m, copy);
    }

    return err;
}

/* respond to A += m */

int gretl_array_append_matrix (gretl_array *A,
			       gretl_matrix *m,
			       int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_MATRICES) {
	err = E_TYPES;
    } else {
	err = array_extend_content(A, 1);
	if (!err) {
	    err = set_matrix(A, A->n - 1, m, copy);
	}
    }

    return err;
}

/* respond to A[i] = b */

int gretl_array_set_bundle (gretl_array *A, int i,
			    gretl_bundle *b,
			    int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_BUNDLES) {
	err = E_TYPES;
    } else if (i < 0 || i >= A->n) {
	gretl_errmsg_sprintf(_("Index value %d is out of bounds"), i+1);
	err = E_DATA;
    } else if (b != A->data[i]) {
	gretl_bundle_destroy(A->data[i]);
	err = set_bundle(A, i, b, copy);
    }

    return err;
}

int gretl_array_set_array (gretl_array *A, int i,
			   gretl_array *ai,
			   int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_ARRAYS) {
	err = E_TYPES;
    } else if (i < 0 || i >= A->n) {
	gretl_errmsg_sprintf(_("Index value %d is out of bounds"), i+1);
	err = E_DATA;
    } else if (ai != A->data[i]) {
	gretl_array_destroy(A->data[i]);
	err = set_array(A, i, ai, copy);
    }

    return err;
}

/* respond to A += b */

int gretl_array_append_bundle (gretl_array *A,
			       gretl_bundle *b,
			       int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_BUNDLES) {
	err = E_TYPES;
    } else {
	err = array_extend_content(A, 1);
	if (!err) {
	    err = set_bundle(A, A->n - 1, b, copy);
	}
    }

    return err;
}

int gretl_array_append_array (gretl_array *A,
			      gretl_array *a,
			      int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_ARRAYS) {
	err = E_TYPES;
    } else {
	err = array_extend_content(A, 1);
	if (!err) {
	    err = set_array(A, A->n - 1, a, copy);
	}
    }

    return err;
}

/* respond to A[i] = L */

int gretl_array_set_list (gretl_array *A, int i,
			  int *L, int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_LISTS) {
	err = E_TYPES;
    } else if (i < 0 || i >= A->n) {
	gretl_errmsg_sprintf(_("Index value %d is out of bounds"), i+1);
	err = E_DATA;
    } else if (L != A->data[i]) {
	free(A->data[i]);
	err = set_list(A, i, L, copy);
    }

    return err;
}

/* respond to A += L */

int gretl_array_append_list (gretl_array *A,
			     int *L, int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type != GRETL_TYPE_LISTS) {
	err = E_TYPES;

    } else {
	err = array_extend_content(A, 1);
	if (!err) {
	    err = set_list(A, A->n - 1, L, copy);
	}
    }

    return err;
}

int gretl_array_set_element (gretl_array *A, int i,
			     void *ptr, GretlType type,
			     int copy)
{
    int err = 0;

    if (type == GRETL_TYPE_MATRIX) {
	err = gretl_array_set_matrix(A, i, ptr, copy);
    } else if (type == GRETL_TYPE_STRING) {
	err = gretl_array_set_string(A, i, ptr, copy);
    } else if (type == GRETL_TYPE_BUNDLE) {
	err = gretl_array_set_bundle(A, i, ptr, copy);
    } else if (type == GRETL_TYPE_LIST) {
	err = gretl_array_set_list(A, i, ptr, copy);
    } else if (type == GRETL_TYPE_ARRAY) {
	err = gretl_array_set_array(A, i, ptr, copy);
    }

    return err;
}

/* @ptr must be pre-checked as matching the array type */

int gretl_array_append_object (gretl_array *A,
			       void *ptr,
			       int copy)
{
    int err = 0;

    if (A == NULL) {
	err = E_DATA;
    } else if (A->type == GRETL_TYPE_MATRICES) {
	gretl_array_append_matrix(A, ptr, copy);
    } else if (A->type == GRETL_TYPE_STRINGS) {
	gretl_array_append_string(A, ptr, copy);
    } else if (A->type == GRETL_TYPE_BUNDLES) {
	gretl_array_append_bundle(A, ptr, copy);
    } else if (A->type == GRETL_TYPE_LISTS) {
	gretl_array_append_list(A, ptr, copy);
    } else if (A->type == GRETL_TYPE_ARRAYS) {
	gretl_array_append_array(A, ptr, copy);
    }

    return err;
}

static int
gretl_array_copy_content (gretl_array *Acpy, const gretl_array *A,
			  int write_offset)
{
    int i, j, err = 0;

    for (i=0; i<A->n && !err; i++) {
	if (A->data[i] != NULL) {
	    j = i + write_offset;
	    if (A->type == GRETL_TYPE_STRINGS) {
		Acpy->data[j] = gretl_strdup(A->data[i]);
	    } else if (A->type == GRETL_TYPE_MATRICES) {
		Acpy->data[j] = gretl_matrix_copy(A->data[i]);
	    } else if (A->type == GRETL_TYPE_BUNDLES) {
		Acpy->data[j] = gretl_bundle_copy(A->data[i], &err);
	    } else if (A->type == GRETL_TYPE_ARRAYS) {
		Acpy->data[j] = gretl_array_copy(A->data[i], &err);
	    } else {
		Acpy->data[j] = gretl_list_copy(A->data[i]);
	    }
	    if (Acpy->data[j] == NULL) {
		err = E_ALLOC;
	    }
	}
    }

    return err;
}

gretl_array *gretl_array_copy (const gretl_array *A,
			       int *err)
{
    gretl_array *Acpy = NULL;

    if (A != NULL) {
	Acpy = gretl_array_new(A->type, A->n, err);
	if (!*err) {
	    *err = gretl_array_copy_content(Acpy, A, 0);
	}
    }

    return Acpy;
}

static int compare_strings (const void *a, const void *b)
{
    const char **sa = (const char **) a;
    const char **sb = (const char **) b;

    return g_strcmp0(*sa, *sb);
}

static int inverse_compare_strings (const void *a, const void *b)
{
    const char **sa = (const char **) a;
    const char **sb = (const char **) b;

    return -g_strcmp0(*sa, *sb);
}

gretl_array *gretl_strings_sort (const gretl_array *A,
				 int descending,
				 int *err)
{
    gretl_array *Asrt = NULL;

    if (A != NULL) {
	if (A->type != GRETL_TYPE_STRINGS) {
	    *err = E_TYPES;
	} else {
	    Asrt = gretl_array_new(A->type, A->n, err);
	}
	if (!*err) {
	    *err = gretl_array_copy_content(Asrt, A, 0);
	}
	if (!*err) {
	    qsort(Asrt->data, Asrt->n, sizeof *Asrt->data,
		  descending ? inverse_compare_strings : compare_strings);
	}
    }

    return Asrt;
}

/* respond to A1 += A2 */

int gretl_array_copy_into (gretl_array *A1,
			   const gretl_array *A2)
{
    int old_n = 0, err = 0;

    if (A1 == NULL || A2 == NULL) {
	err = E_DATA;
    } else if (A1->type != A2->type) {
	err = E_TYPES;
    } else {
	old_n = A1->n;
	err = array_extend_content(A1, A2->n);
    }

    if (!err) {
	err = gretl_array_copy_content(A1, A2, old_n);
    }

    return err;
}

/* respond to C = A + B */

gretl_array *gretl_arrays_join (gretl_array *A,
				gretl_array *B,
				int *err)
{
    gretl_array *C = NULL;

    if (A == NULL || B == NULL) {
	*err = E_DATA;
    } else if (A->type != B->type) {
	*err = E_TYPES;
    } else {
	int n = A->n + B->n;

	C = gretl_array_new(A->type, n, err);
    }

    if (!*err) {
	*err = gretl_array_copy_content(C, A, 0);
    }

    if (!*err) {
	*err = gretl_array_copy_content(C, B, A->n);
    }

    if (*err && C != NULL) {
	gretl_array_destroy(C);
	C = NULL;
    }

    return C;
}

/**
 * gretl_array_copy_as:
 * @name: name of source array.
 * @copyname: name for copy.
 * @copytpe: the type specified for the copied array, or 0.
 *
 * Look for a saved array specified by @name, and if found,
 * make a full copy and save it under @copyname. This is
 * called from geneval.c on completion of assignment to a
 * array named @copyname, where the returned value on the
 * right-hand side is a pre-existing array.
 *
 * Returns: 0 on success, non-zero code on error.
 */

int gretl_array_copy_as (const char *name, const char *copyname,
			 GretlType copytype)
{
    gretl_array *A0, *A1 = NULL;
    user_var *u;
    int err = 0;

    u = get_user_var_of_type_by_name(name, GRETL_TYPE_ARRAY);
    if (u == NULL) {
	return E_DATA;
    } else {
	A0 = user_var_get_value(u);
    }

    if (copytype > 0 && A0->type != copytype) {
	return E_TYPES;
    }

    /* is there a pre-existing array named @copyname? */
    u = get_user_var_of_type_by_name(copyname, GRETL_TYPE_ARRAY);
    if (u != NULL) {
	A1 = user_var_get_value(u);
    }

    if (A1 != NULL) {
	if (A1->type != A0->type) {
	    err = E_TYPES;
	} else {
	    gretl_array_void_content(A1);
	    A1->n = A0->n;
	    err = array_allocate_storage(A1);
	    if (!err) {
		err = gretl_array_copy_content(A1, A0, 0);
	    }
	}
    } else {
	A1 = gretl_array_copy(A0, &err);
	if (!err) {
	    err = user_var_add(copyname, A1->type, A1);
	}
    }

    return err;
}

/**
 * get_array_by_name:
 * @name: the name to look up.
 *
 * Returns: pointer to a saved array, if found, else NULL.
 */

gretl_array *get_array_by_name (const char *name)
{
    gretl_array *a = NULL;

    if (name != NULL && *name != '\0') {
	user_var *u =
	    get_user_var_of_type_by_name(name, GRETL_TYPE_ARRAY);

	if (u != NULL) {
	    a = user_var_get_value(u);
	}
    }

    return a;
}

/**
 * get_strings_array_by_name:
 * @name: the name to look up.
 *
 * Returns: pointer to a saved array of strings, if found, else NULL.
 */

gretl_array *get_strings_array_by_name (const char *name)
{
    gretl_array *ret = NULL;

    if (name != NULL && *name != '\0') {
	user_var *u =
	    get_user_var_of_type_by_name(name, GRETL_TYPE_ARRAY);

	if (u != NULL) {
	    ret = user_var_get_value(u);
	    if (ret->type != GRETL_TYPE_STRINGS) {
		ret = NULL;
	    }
	}
    }

    return ret;
}

gretl_array *gretl_array_pull_from_stack (const char *name,
					  int *err)
{
    gretl_array *a = NULL;
    user_var *u;

    u = get_user_var_of_type_by_name(name, GRETL_TYPE_ARRAY);

    if (u != NULL) {
	a = user_var_unstack_value(u);
    }

    if (a == NULL) {
	*err = E_DATA;
    }

    return a;
}

static void print_array_string (const char *s, PRN *prn)
{
    int n = strcspn(s, "\r\n");
    int m = strlen(s);

    if (n > 72) {
	pprintf(prn, "\"%.69s...\"\n", s);
    } else if (n < m) {
	pprintf(prn, "\"%.*s...\"\n", n, s);
    } else {
	pprintf(prn, "\"%s\"\n", s);
    }
}

static void print_array_elements (gretl_array *A,
				  int imin, int imax,
				  PRN *prn)
{
    int i;

    for (i=imin; i<imax; i++) {
	pprintf(prn, "[%d] ", i+1);
	if (A->data[i] == NULL) {
	    pputs(prn, "null\n");
	} else if (A->type == GRETL_TYPE_STRINGS) {
	    const char *s = A->data[i];

	    print_array_string(s, prn);
	} else if (A->type == GRETL_TYPE_MATRICES) {
	    const gretl_matrix *m = A->data[i];

	    pprintf(prn, "%d x %d\n", m->rows, m->cols);
	} else if (A->type == GRETL_TYPE_LISTS) {
	    const int *list = A->data[i];

	    gretl_list_print(list, NULL, prn);
	}
    }

    pputc(prn, '\n');
}

int gretl_array_print (gretl_array *A, PRN *prn)
{
    if (A != NULL) {
	const char *s = gretl_type_get_name(A->type);

	pprintf(prn, _("Array of %s, length %d\n"), s, A->n);

	if (A->n > 0 && A->n < 10 &&
	    A->type != GRETL_TYPE_BUNDLES && A->type != GRETL_TYPE_ARRAYS) {
	    print_array_elements(A, 0, A->n, prn);
	}
    }

    return 0;
}

int gretl_array_print_range (gretl_array *A, int imin, int imax, PRN *prn)
{
    if (A != NULL) {
	const char *s = gretl_type_get_name(A->type);

	pprintf(prn, _("Array of %s, length %d\n"), s, A->n);

	if (A->type != GRETL_TYPE_BUNDLES && A->type != GRETL_TYPE_ARRAYS) {
	    print_array_elements(A, imin, imax, prn);
	}
    }

    return 0;
}


/* Called from gretl_bundle.c when serializing a bundle
   which contains one or more arrays.
*/

void gretl_array_serialize (gretl_array *A, PRN *prn)
{
    GretlType type;
    const char *subname;
    void *ptr;
    int i;

    type = gretl_type_get_singular(A->type);
    subname = gretl_type_get_name(type);

    pprintf(prn, "<gretl-array type=\"%s\" length=\"%d\">\n",
	    gretl_type_get_name(A->type), A->n);

    for (i=0; i<A->n; i++) {
	ptr = A->data[i];
	if (ptr == NULL) {
	    pprintf(prn, "<%s placeholder=\"true\"/>\n", subname);
	} else if (type == GRETL_TYPE_STRING) {
	    gretl_xml_put_tagged_string("string", ptr, prn);
	} else if (type == GRETL_TYPE_MATRIX) {
	    gretl_matrix_serialize(ptr, NULL, prn);
	} else if (type == GRETL_TYPE_BUNDLE) {
	    gretl_bundle_serialize(ptr, NULL, prn);
	} else if (type == GRETL_TYPE_ARRAY) {
	    gretl_array_serialize(ptr, prn);
	} else if (type == GRETL_TYPE_LIST) {
	    gretl_xml_put_tagged_list("list", ptr, prn);
	}
    }

    pputs(prn, "</gretl-array>\n");
}

static int name_matches_array_type (char *s, GretlType type)
{
    if (!strncmp(s, "gretl-", 6)) {
	/* we're expecting "short-form" type strings */
	s += 6;
    }

    return (gretl_type_from_string(s) == type);
}

static int deserialize_array_elements (gretl_array *A,
				       xmlNodePtr cur,
				       xmlDocPtr doc)
{
    GretlType type = gretl_type_get_singular(A->type);
    int i = 0, err = 0;

    while (cur != NULL && !err && i < A->n) {
	if (!name_matches_array_type((char *) cur->name, type)) {
	    fprintf(stderr, "deserialize array: mismatched element '%s'\n",
		    (char *) cur->name);
	    err = E_DATA;
	} else if (gretl_xml_get_prop_as_bool(cur, "placeholder")) {
	    ; /* null array element: no-op */
	} else if (A->type == GRETL_TYPE_STRINGS) {
	    A->data[i] = gretl_xml_get_string(cur, doc);
	} else if (A->type == GRETL_TYPE_MATRICES) {
	    A->data[i] = gretl_xml_get_matrix(cur, doc, &err);
	} else if (A->type == GRETL_TYPE_BUNDLES) {
	    A->data[i] = gretl_bundle_deserialize(cur, doc, &err);
	} else if (A->type == GRETL_TYPE_ARRAYS) {
	    A->data[i] = gretl_array_deserialize(cur, doc, &err);
	} else if (A->type == GRETL_TYPE_LISTS) {
	    A->data[i] = gretl_xml_get_list(cur, doc, &err);
	}
	i++;
	cur = cur->next;
    }

    if (!err && i != A->n) {
	fprintf(stderr, "deserialize array: array is corrupted\n");
	err = E_DATA;
    }

    return err;
}

/* For internal use only: @p1 should be of type xmlNodePtr and @p2
   should be an xmlDocPtr. We suppress the actual pointer types in the
   prototype so that it's possible for a module to include
   gretl_array.h without including the full libxml headers.
*/

gretl_array *gretl_array_deserialize (void *p1, void *p2,
				      int *err)
{
    xmlNodePtr node = p1;
    xmlDocPtr doc = p2;
    GretlType type = 0;
    int n = 0;
    gretl_array *A = NULL;

    if (xmlStrcmp(node->name, (XUC) "gretl-array")) {
	fprintf(stderr, "deserialize array: node is not gretl-array!\n");
	*err = E_DATA;
    } else {
	type = gretl_xml_get_type_property(node);
	if (type == 0) {
	    fprintf(stderr, "deserialize array: couldn't get array type\n");
	    *err = E_DATA;
	}
    }

    if (!*err && !gretl_xml_get_prop_as_int(node, "length", &n)) {
	fprintf(stderr, "deserialize array: couldn't get length\n");
	*err = E_DATA;
    }

    if (!*err) {
	A = gretl_array_new(type, n, err);
    }

    if (A != NULL && n > 0) {
	*err = deserialize_array_elements(A, node->xmlChildrenNode, doc);
	if (*err) {
	    gretl_array_destroy(A);
	    A = NULL;
	}
    }

    return A;
}

/* In case a matrix is too wide for comfortable printing, split it by
   column. If there are one or more "leading" columns that should be
   displayed with each chunk of the matrix this should be signalled
   via a non-zero value for @leadcols. The maximum number of columns
   per chunk (including the leading columns, if any) is set by the
   @maxcols argument.

   The return value is an array of suitably sized matrices. If @m
   has column names attached these are distributed to the matrices
   in the array.
*/

gretl_array *gretl_matrix_col_split (const gretl_matrix *m,
				     int leadcols, int maxcols,
				     int *err)
{
    gretl_array *a = NULL;
    int maincols, nm, rem;

    if (gretl_is_null_matrix(m)) {
	*err = E_INVARG;
    } else {
	maincols = m->cols - leadcols;
	if (maincols <= 0) {
	    *err = E_INVARG;
	}
    }

    if (!*err) {
	/* how many matrices will we need? */
	nm = maincols / (maxcols - leadcols);
	rem = maincols % (maxcols - leadcols);
	nm += rem > 0;
	if (nm == 1) {
	    /* nothing to be done */
	    *err = E_INVARG;
	}
    }

    if (!*err) {
	a = gretl_array_new(GRETL_TYPE_MATRICES, nm, err);
    }

    if (!*err) {
	const char **S0 = gretl_matrix_get_colnames(m);
	char **Si = NULL;
	size_t rsize = m->rows * sizeof(double);
	const double *src;
	double *targ;
	gretl_matrix *ai;
	int i, j, cols, spos;

	/* initial read position for "main" columns */
	src = m->val + leadcols * m->rows;
	spos = leadcols;

	for (i=0; i<nm && !*err; i++) {
	    cols = (i == nm-1 && rem > 0)? rem + leadcols : maxcols;
	    ai = gretl_zero_matrix_new(m->rows, cols);
	    if (ai == NULL) {
		*err = E_ALLOC;
	    } else {
		Si = S0 == NULL ? NULL : strings_array_new(cols);
		/* initial write position */
		targ = ai->val;
		if (leadcols > 0) {
		    memcpy(targ, m->val, leadcols * rsize);
		    targ += leadcols * m->rows;
		    if (Si != NULL) {
			/* transcribe column names */
			for (j=0; j<leadcols; j++) {
			    Si[j] = gretl_strdup(S0[j]);
			}
		    }
		}
		/* now handle the "main" columns */
		cols -= leadcols;
		memcpy(targ, src, cols * rsize);
		/* advance the read position */
		src += cols * m->rows;
		if (Si != NULL) {
		    for (j=0; j<cols; j++) {
			Si[leadcols+j] = gretl_strdup(S0[spos++]);
		    }
		    gretl_matrix_set_colnames(ai, Si);
		}
		/* stick matrix @i into the array */
		gretl_array_set_matrix(a, i, ai, 0);
	    }
	}
    }

    if (*err && a != NULL) {
	gretl_array_destroy(a);
	a = NULL;
    }

    return a;
}
