/* basics - Basic functions for manipulating compound data */
/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
#include "xlisp.h"
#include "xlstat.h"
/* forward declarations */
LOCAL int allfixargs P1H(void);
LOCAL VOID indices_from_rowmajor P3H(LVAL, int, LVAL);
LOCAL LVAL iseq P2H(int, int);
LOCAL LVAL lrepeat P2H(LVAL, int);
LOCAL int old_rowmajor_index P4H(int, LVAL, LVAL, LVAL);
LOCAL VOID permute_indices P4H(LVAL, LVAL, LVAL, int);
LOCAL VOID setcons P3H(LVAL, LVAL, LVAL);
LOCAL VOID setfixnum P2H(LVAL, FIXTYPE);
LOCAL LVAL makeargvec P2H(int, LVAL *);
LOCAL LVAL subarray P4H(LVAL, LVAL, int, LVAL);
LOCAL LVAL subsequence P4H(LVAL, LVAL, int, LVAL);
LOCAL int translate_index P7H(int, LVAL, LVAL, LVAL, LVAL, LVAL, LVAL);
/**************************************************************************/
/** **/
/** Sequence Predicate **/
/** **/
/**************************************************************************/
/* Built in SEQUENCEP */
LVAL xssequencep(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
return((seqp(x)) ? s_true : NIL);
}
/**************************************************************************/
/** **/
/** Copying Functions **/
/** **/
/**************************************************************************/
/* Built in COPY-VECTOR function */
LVAL xscopyvector(V)
{
LVAL v;
v = xlgetarg();
xllastarg();
return(copyvector(v));
}
/* internal array copying function */
LVAL copyarray P1C(LVAL, array)
{
LVAL dim, data, result;
switch (ntype(array)) {
case VECTOR:
case STRING:
case TVEC:
result = copyvector(array);
break;
case DARRAY:
/* protext some pointers */
xlstkcheck(2);
xlsave(dim);
xlsave(data);
dim = copyvector(getdarraydim(array));
data = copyvector(getdarraydata(array));
result = newdarray(dim, data);
/* restore the stack frame */
xlpopn(2);
break;
default:
xlerror("not an array", array);
result = NIL; /* not reached */
}
return(result);
}
LVAL xscopyarray(V)
{
LVAL array;
array = xlgetarg();
xllastarg();
return(copyarray(array));
}
/**************************************************************************/
/** **/
/** Compound Data Decomposition Functions **/
/** **/
/**************************************************************************/
/* Built in SPLIT-LIST function */
LVAL xssplitlist(V)
{
LVAL data;
int n;
data = xlgalist();
n = getfixnum(xlgafixnum());
xllastarg();
return(split_list(data, n));
}
/**************************************************************************/
/** **/
/** WHICH Function **/
/** **/
/**************************************************************************/
/* Built in WHICH function. Generates indices in the data sequence of */
/* a compound data item where argument elements are not nil. Should do */
/* something more reasonable for non sequence compound data. */
LVAL xswhich(V)
{
LVAL x, result, data, index, tail = NIL;
int i, n;
/* protect the result pointer */
xlstkcheck(3);
xlsave(result);
xlsave(index);
xlsave(data);
x = xlgetarg();
xllastarg();
if (compoundp(x)) {
data = compounddataseq(x);
n = compounddatalen(x);
for (i = 0; i < n; i++)
if (getnextelement(&x, i) != NIL) {
index = cvfixnum((FIXTYPE) i);
if (result == NIL) {
result = consa(index);
tail = result;
}
else {
rplacd(tail, consa(index));
tail = cdr(tail);
}
}
}
else xlbadtype(x);
/* restore the stack frame */
xlpopn(3);
return(result);
}
/**************************************************************************/
/** **/
/** List Construction Functions **/
/** **/
/**************************************************************************/
/* internal version of ISEQ function */
LOCAL LVAL iseq P2C(int, m, int, n)
{
int length, i;
LVAL result, next;
/* protect the result pointer */
xlsave1(result);
length = abs(n - m) + 1;
result = mklist(length, NIL);
for (next = result, i = m; consp(next); next = cdr(next),
(m <= n) ? i++ : i--)
rplaca(next, cvfixnum((FIXTYPE) i));
/* restore the stack frame */
xlpop();
return(result);
}
/* Built in ISEQ function. Generates a list of consecutive integers */
LVAL xsiseq(V)
{
int n, m;
m = getfixnum(xlgafixnum());
if (moreargs()) n = getfixnum(xlgafixnum());
else if (m > 0) {
n = m - 1;
m = 0;
}
else if (m < 0) {
m = m + 1;
n = 0;
}
else return(NIL);
xllastarg();
return(iseq(m, n));
}
/* Built in REPEAT function */
LOCAL LVAL lrepeat P2C(LVAL, arg, int, n)
{
LVAL data, nextd, nextr, result;
/* protect some pointers */
xlstkcheck(2);
xlsave(data);
xlsave(result);
if (compoundp(arg))
data = coerce_to_list(arg);
else
data = consa(arg);
/* make new data list */
result = mklist(n * llength(data), NIL);
/* insert values from data into list */
for (nextr = result, nextd = data; consp(nextr);
nextr = cdr(nextr), nextd = cdr(nextd)) {
if (nextd == NIL) nextd = data; /* cycle through the data */
rplaca(nextr, car(nextd));
}
/* restore the stack frame */
xlpopn(2);
return(result);
}
LVAL xsrepeat(V)
{
LVAL data, result;
int reps;
if (xlargc != 2) xlfail("wrong number of arguments");
else if (compoundp(xlargv[1])) {
xlsave1(result);
result = subr_map_elements(xsrepeat);
result = coerce_to_list(result);
result = nested_list_to_list(result, 2);
xlpop();
}
else {
data = xlgetarg();
reps = getfixnum(checknonnegint(xlgetarg()));
xllastarg();
result = lrepeat(data, reps);
}
return(result);
}
/**************************************************************************/
/** **/
/** Subset Selection and Mutation Functions **/
/** **/
/**************************************************************************/
/* select or set the subsequence corresponding to the specified indices */
LOCAL LVAL subsequence P4C(LVAL, x,
LVAL, indices,
int, set_values,
LVAL, values)
{
int rlen, dlen, i, j, idx;
LVAL result, nextx, nextr, index, elem;
/* Check the input data */
if (! seqp(x))
xlbadtype(x);
if (! seqp(indices) && indices != s_true)
xlbadtype(indices);
/* protect some pointers */
xlsave1(result);
dlen = seqlen(x);
rlen = (indices == s_true) ? dlen : seqlen(indices);
/* set up the result/value sequence */
if (set_values) {
if (! compoundp(values)) /**** could be more efficient */
result = values = mklist(rlen, values);
else {
if (seqlen(values) != rlen)
xlfail("value and index sequences do not match");
result = values;
}
}
else if listp(x)
result = mklist(rlen, NIL);
else
result = mktvec(rlen, gettvecetype(x));
/* get or set the sequence elements */
if (indices == s_true) /* do all indices */
if (set_values)
for (i = 0; i < dlen; i++)
setnextelement(&x, i, getnextelement(&values, i));
else
result = x;
else {
if (set_values) {
for (nextx = x, nextr = result, i = 0, j = 0; i < rlen; i++) {
index = getnextelement(&indices, i);
if (! fixp(index)) xlerror("not an integer", index);
idx = getfixnum(index);
if (idx < 0 || dlen <= idx)
xlerror("index out of range", index);
elem = getnextelement(&result, i);
if (listp(x)) {
if (j > idx) {
j = 0;
nextx = x;
}
for (; j < idx && consp(nextx); j++, nextx = cdr(nextx));
rplaca(nextx, elem);
}
else
settvecelement(x, idx, elem);
}
}
else {
for (nextx = x, nextr = result, i = 0, j = 0; i < rlen; i++) {
index = getnextelement(&indices, i);
if (! fixp(index)) xlerror("not an integer", index);
idx = getfixnum(index);
if (idx < 0 || dlen <= idx)
xlerror("index out of range", index);
if (listp(x)) {
if (j > idx) {
j = 0;
nextx = x;
}
for (; j < idx && consp(nextx); j++, nextx = cdr(nextx));
elem = car(nextx);
}
else
elem = gettvecelement(x, idx);
setnextelement(&nextr, i, elem);
}
}
}
/* restore the stack frame */
xlpop();
return(result);
}
/* translate row major index in resulting submatrix to row major index in */
/* the original matrix */
LOCAL int old_rowmajor_index P4C(int, index,
LVAL, indices,
LVAL, dim,
LVAL, olddim)
{
int face, oldface, rank, i, oldindex;
rank = getsize(dim);
for (face = 1, oldface = 1, i = 0; i < rank; i++) {
face *= getfixnum(getelement(dim, i));
oldface *= getfixnum(getelement(olddim, i));
}
for (oldindex = 0, i = 0; i < rank; i++) {
face /= getfixnum(getelement(dim, i));
oldface /= getfixnum(getelement(olddim, i));
oldindex +=
oldface *
getfixnum(getelement(getelement(indices, i), index / face));
index = index % face;
}
return(oldindex);
}
/* make arguments into vector */
LOCAL LVAL makeargvec P2C(int, argc, LVAL *, argv)
{
LVAL val;
int i;
val = newvector(argc);
for (i = 0; i < argc; i++)
setelement(val, i, argv[i]);
return val;
}
/* extract or set subarray for the indices from a displaced array */
LOCAL LVAL subarray P4C(LVAL, a,
LVAL, indices,
int, set_values,
LVAL, values)
{
LVAL index, dim, vdim, data, result_data, olddim, result;
int rank, m, n, i, j, k;
/* protect some pointers */
xlstkcheck(2);
xlsave(dim);
xlsave(result);
if (! darrayp(a)) xlbadtype(a);
if (getsize(indices) != getdarrayrank(a))
xlfail("wrong number of indices");
olddim = getdarraydim(a);
/* compute the result dimension vector and fix up the indices */
rank = getdarrayrank(a);
dim = newvector(rank);
for (i = 0; i < rank; i++) {
index = getelement(indices, i);
n = getfixnum(getelement(olddim, i));
if (index == s_true) {
index = newvector(n);
setelement(indices, i, index);
for (j = 0; j < n; j++)
setelement(index, j, cvfixnum((FIXTYPE) j));
}
else {
index = coerce_to_tvec(index, s_true);
k = gettvecsize(index);
for (j = 0; j < k; j++)
if (n <= getfixnum(checknonnegint(gettvecelement(index, j))))
xlerror("index out of bounds", gettvecelement(index, j));
setelement(indices, i, index);
}
setelement(dim, i, cvfixnum((FIXTYPE) gettvecsize(index)));
}
/* set up the result or check the values*/
if (set_values) {
if (! compoundp(values)) /**** could be more efficient */
result = mkarray(dim, k_initelem, values, s_true);
else {
if (! darrayp(values) || rank != getdarrayrank(values))
xlbadtype(values);
vdim = getdarraydim(values);
for (i = 0; i < rank; i++)
if (getfixnum(getelement(vdim, i)) != getfixnum(getelement(dim, i)))
xlbadtype(values);
result = values;
}
}
else
result = mkarray(dim, NIL, NIL, s_true);
/* compute the result or set the values */
data = getdarraydata(a);
result_data = getdarraydata(result);
m = gettvecsize(data);
n = gettvecsize(result_data);
for (i = 0; i < n; i++) {
k = old_rowmajor_index(i, indices, dim, olddim);
if (0 > k || k >= m)
xlfail("index out of range");
if (set_values)
settvecelement(data, k, gettvecelement(result_data, i));
else
settvecelement(result_data, i, gettvecelement(data, k));
}
/* restore the stack frame */
xlpopn(2);
return(result);
}
/* are all arguments beyond the first fixnums? */
LOCAL int allfixargs(V)
{
int i;
for (i = 1; i < xlargc; i++)
if (! fixp(xlargv[i])) return(FALSE);
return(TRUE);
}
/* Built in SELECT function */
LVAL xsselect(V)
{
LVAL x, indices, result = NIL;
if (allfixargs()) {
if (darrayp(peekarg(0))) result = xaref();
else result = xelt();
}
else if (seqp(peekarg(0))) {
x = xlgetarg();
indices = xlgetarg();
result = subsequence(x, indices, FALSE, NIL);
}
else if (darrayp(peekarg(0))) {
xlsave1(indices);
x = xlgetarg();
indices = makeargvec(xlargc, xlargv);
result = subarray(x, indices, FALSE, NIL);
xlpop();
}
else xlbadtype(xlgetarg());
return(result);
}
/**** this could be dangerous */
LOCAL VOID setcons P3C(LVAL, x, LVAL, first, LVAL, rest)
{
setntype(x, CONS);
#ifdef NEWGC
Rplaca(x, first);
Rplacd(x, rest);
#else
rplaca(x, first);
rplacd(x, rest);
#endif
}
/* Built in SET-SELECT (SETF method for SELECT) */
/* This function uses node data to avoid creating garbage nodes. */
/* This use of nodes *should* be safe, since there *should* be */
/* no chance of a garbage collection during this operation. */
LVAL xssetselect(V)
{
LVAL x, indices, values;
struct node index_node, value_node;
LVAL i_list = &index_node, v_list = &value_node;
xlsave1(indices);
xlsave1(values);
x = xlgetarg();
if (xlargc < 1) xltoofew();
indices = makeargvec(xlargc - 1, xlargv);
values = xlargv[xlargc - 1];
if (seqp(x)) {
if (getsize(indices) != 1)
xlerror("bad indices", indices);
indices = getelement(indices, 0);
if (fixp(indices)) {
setcons(i_list, indices, NIL);
setcons(v_list, values, NIL);
subsequence(x, i_list, TRUE, v_list);
}
else
subsequence(x, indices, TRUE, values);
}
else if (darrayp(x))
subarray(x, indices, TRUE, values);
else xlbadtype(x);
xlpopn(2);
return(values);
}
/**************************************************************************/
/** **/
/** Array Permutation Function **/
/** **/
/**************************************************************************/
/* permute x into y using perm; all should be vectors; If check is TRUE */
/* the routine will check to make sure no indices are reused, but x */
/* will be destroyed. */
LOCAL VOID permute_indices P4C(LVAL, x, LVAL, y, LVAL, perm, int, check)
{
LVAL index;
int rank, i, k;
rank = getsize(x);
for (i = 0; i < rank; i++) {
index = getelement(perm, i);
if (! fixp(index)) xlerror("bad permutation sequence", perm);
k = getfixnum(index);
if (k < 0 || k >= rank) xlerror("bad permutation sequence", perm);
setelement(y, i, getelement(x, k));
if (check)
setelement(x, k, NIL); /* to insure dimensions are not re-used */
}
}
/* compute indices in a from rowmajor index k, put in vector result */
/* The indices are stored in cons cells, which are treated locally */
/* fixnums. This SEEMS to be safe since it is entirely local, but */
/* it may be dangerous...... */
/**** this could be dangerous */
/* set a fixnum node */
LOCAL VOID setfixnum P2C(LVAL, node, FIXTYPE, val)
{
node->n_fixnum = val;
setntype(node, FIXNUM);
}
LOCAL VOID indices_from_rowmajor P3C(LVAL, a, int, k, LVAL, result)
{
LVAL next, dim;
int face, i, rank;
if (0 > k || k >= gettvecsize(getdarraydata(a)))
xlfail("index out of range");
dim = getdarraydim(a);
rank = getdarrayrank(a);
for (i = 0, face = 1, next = dim; i < rank; i++)
face *= getfixnum(getnextelement(&next, i));
for (i = 0, next = dim; i < rank; i++) {
face /= getfixnum(getnextelement(&next, i));
setfixnum(gettvecelement(result, i),(FIXTYPE) k / face);
k = k % face;
}
}
/* Translate row major index in original array to row major index in new */
/* array. Use indices vectors and ilist for temporary storage. */
LOCAL int translate_index P7C(int, i, LVAL, result, LVAL, x, LVAL, perm, LVAL, indices,
LVAL, oldindices, LVAL, ilist)
{
LVAL next;
int rank, k;
rank = getdarrayrank(x);
indices_from_rowmajor(x, i, oldindices);
permute_indices(oldindices, indices, perm, FALSE);
for (next = ilist, k = 0; k < rank && consp(next); k++, next = cdr(next))
rplaca(next, getelement(indices, k));
return(rowmajorindex(result, ilist, FALSE));
}
/* Built in PERMUTE-ARRAY function */
LVAL xspermutearray(V)
{
LVAL x, perm, result, data, result_data, dim, olddim, indices;
LVAL oldindices, ilist;
int rank, i, k, n;
/* protect some pointers */
xlstkcheck(7);
xlsave(result);
xlsave(dim);
xlsave(olddim);
xlsave(indices);
xlsave(oldindices);
xlsave(perm);
xlsave(ilist);
/* Get and check the arguments */
x = xlgadarray();
perm = xlgaseq();
perm = coerce_to_tvec(perm, s_true);
if (gettvecsize(perm) != getdarrayrank(x))
xlerror("bad permutation sequence", perm);
xllastarg();
/* get old dimension vector */
olddim = getdarraydim(x);
rank = getdarrayrank(x);
/* construct new dimension vector */
dim = newvector(rank);
olddim = copyvector(olddim); /* since permute_indices will destroy this */
permute_indices(olddim, dim, perm, TRUE);
/* make result array and the index vectors and lists */
data = getdarraydata(x);
n = gettvecsize(data);
result = mktvec(gettvecsize(data), gettvecetype(data));
result = newdarray(dim, result);
indices = newvector(rank);
oldindices = newvector(rank);
for (i = 0; i < rank; i++)
setelement(oldindices, i, consa(NIL));
ilist = mklist(rank, NIL);
/* fill in the result */
result_data = getdarraydata(result);
for (i = 0; i < n; i++) {
k = translate_index(i, result, x, perm, indices, oldindices, ilist);
settvecelement(result_data, k, gettvecelement(data, i));
}
/* restore stack */
xlpopn(7);
return(result);
}
syntax highlighted by Code2HTML, v. 0.9.1