/*ScianArrays.c
  Eric Pepke
  February 9, 1990
  Array handling stuff in scian
*/

#include "Scian.h"
#include "ScianTypes.h"
#include "ScianWindows.h"
#include "ScianArrays.h"
#include "ScianLists.h"
#include "ScianErrors.h"
#include "ScianIDs.h"
#include "ScianDatasets.h"
#include "ScianTimers.h"
#include "ScianNetObjects.h"

ObjPtr arrayClass, objectArrayClass;

#ifdef PROTO
long SearchReal(ObjPtr array, real value)
#else
long SearchReal(array, value)
ObjPtr array;
real value;
#endif
/*Assuming array is a sorted, 1-dimensional real array, finds the index to the
  lowest element which is larger than value, or the dims if the value is
  higher than all.  Returns -1 if the array is bad.*/
{
    long top, bottom, mid;
    real *elements;
    if ((!IsRealArray(array)) || (RANK(array) != 1))
    {
	ReportError("SearchReal",
		"This function requires a real array of rank 1");
	return -1;
    }

    bottom = 0;
    top = DIMS(array)[0] - 1;
    elements = ELEMENTS(array);
    if (value >= elements[top])
    {
	return top + 1;
    }

    while (top > bottom)
    {
	mid = (top + bottom) / 2;
	if (value >= elements[mid])
	{
	    bottom = mid + 1;
	}
	else
	{
	    top = mid;
	}
    }

    return bottom;
}

#ifdef PROTO
real SearchFuzzyReal(ObjPtr array, real value)
#else
real SearchFuzzyReal(array, value)
ObjPtr array;
real value;
#endif
/*Assuming array is a sorted, 1-dimensional real array, finds a fuzzy real index
  into the array.*/
{
    long found;
    real *elements;

    if ((!IsRealArray(array)) || (RANK(array) != 1))
    {
	ReportError("SearchFuzzyReal",
		"This function requires a real array of rank 1");
	return 0.0;
    }

    found = SearchReal(array, value);
    elements = ELEMENTS(array);

    if (DIMS(array)[0] == 1)
    {
	/*Degenerate case*/
	return 0;
    }

    if (found >= DIMS(array)[0])
    {
	/*This is bigger.  Extrapolate*/
	return (value - elements[DIMS(array)[0] - 1]) / 
		(elements[DIMS(array)[0] - 1] - elements[DIMS(array)[0] - 2])
		+ (real) (DIMS(array)[0] - 1);
    }
    else if (found <= 0)
    {
	/*This is smaller.  Extrapolate*/
	return (value - elements[0]) / (elements[1] - elements[0]);
    }
    else
    {
	/*It's in between*/
	return (value - elements[found - 1]) / (elements[found] - elements[found - 1])
		+ (real) (found - 1);
    }
}

#ifdef PROTO
real FuzzyRealIndex(ObjPtr array, real index)
#else
real FuzzyRealIndex(array, index)
ObjPtr array;
real index;
#endif
/*Assuming array is a sorted, 1-dimensional real array, indexes a fuzzy real index
  into the array.*/
{
    real *elements;
    long indexI;

    if ((!IsRealArray(array)) || (RANK(array) != 1))
    {
	ReportError("FuzzyRealIndex",
		"This function requires a real array of rank 1");
	return -1.0;
    }

    elements = ELEMENTS(array);

    /*Degenerate case*/
    if (DIMS(array)[0] == 1)
    {
	return elements[0];
    }

    indexI = index;
    if (indexI < 0)
    {
	/*Extrapolate*/
	return elements[0] +
		index * (elements[1] - elements[0]);
    }
    else if (indexI >= DIMS(array)[0] - 1)
    {
	/*Extrapolate*/
	return elements[DIMS(array)[0] - 1] +
		(index - (DIMS(array)[0] - 1)) * 
		    (elements[DIMS(array)[0] - 1] - elements[DIMS(array)[0] - 2]);
    }
    else
    {
	/*Interpolate*/
	return elements[indexI] +
		(index - (real) indexI) * (elements[indexI + 1] - elements[indexI]);
    }
}

static int globalVar;

#ifdef PROTO
int CompareStringVars(const void *a, const void *b)
#else
int CompareStringVars(a, b)
void *a, *b;
#endif
/*Compares two object's globalVar strings for qsort*/
{
    ObjPtr s1, s2;
    s1 = GetStringVar("CompareStringVars", *((ObjPtr *) a), NAME);
    s2 = GetStringVar("CompareStringVars", *((ObjPtr *) b), NAME);
    if (!s1 || !s2) return 0;
    return strcmp2(GetString(s1), GetString(s2));
}

ObjPtr SortArrayByStringVar(array, var)
ObjPtr array;
int var;
/*Sorts a 1-dimensional object array by var, which must be a string.
  Returns the sorted array or NULLOBJ*/
{
    ObjPtr retVal;
    long *newDims;
    ObjPtr *elements, *newElements;
    long k;

    if (!IsObjArray(array) || RANK(array) != 1)
    {
	ReportError("SortArrayByStringVar",
		"This function requires an object array of rank 1");
	return NULLOBJ;
    }

    /*Make the elements*/
    newElements = (ObjPtr *) malloc(sizeof(ObjPtr) * DIMS(array)[0]);
    if (!newElements)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Make the dimensions*/
    newDims = (long *) malloc(sizeof(long));
    if (!newDims)
    {
	free(newElements);
	OMErr();
	return NULLOBJ;
    }

    /*Make the array*/
    retVal = NewObject(objectArrayClass,
			      sizeof(Array) - sizeof(Obj));
    /*If can't, return NIL*/
    if (!retVal)
    {
	free(newElements);
	free(newDims);
	OMErr();
	return NULLOBJ;
    }

    /*Make elements and dims*/
    ELEMENTS(retVal) = newElements;
    DIMS(retVal) = newDims;
    newDims[0] = DIMS(array)[0];

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> flags, OBJTYPE(array -> flags));

    RANK(retVal) = 1;

    elements = ELEMENTS(array);
    for (k = 0; k < DIMS(array)[0]; ++k)
    {
	newElements[k] = elements[k];
    }
    globalVar = var;
    qsort(newElements,
	  DIMS(array)[0],
	  sizeof(ObjPtr),
	  CompareStringVars);
    return retVal;
}

#ifdef PROTO
static int ComparePointers(const void *a, const void *b)
#else
static int ComparePointers(a, b)
void *a, *b;
#endif
/*Compares two pointers*/
{
    return (*(ObjPtr *) a) - (*(ObjPtr *) b);
}

#ifdef PROTO
static int CR(const void *a, const void *b)
#else
static int CR(a, b)
void *a, *b;
#endif
/*Compares two reals*/
{
    return (*(real *) a) - (*(real *) b);
}

ObjPtr Uniq(array)
ObjPtr array;
/*Returns array with only unique elements of array.  Array must be 1-dimensional.
  Warning!  This will sort the array first*/
{
    long *newDims;
    ObjPtr retVal;
    int s, d;

    if ((!IsObjArray(array) && !IsRealArray(array)) || RANK(array) != 1)
    {
	ReportError("Uniq",
		"This function requires an array of rank 1");
	return NULLOBJ;
    }

    /*Make the new dims*/
    newDims = (long *) malloc(sizeof(long));
    if (!newDims)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Make the array*/
    retVal = NewObject(IsRealArray(array) ? arrayClass : objectArrayClass, sizeof(Array) - sizeof(Obj));

    /*If can't, return NIL*/
    if (!retVal)
    {
	free(newDims);
	OMErr();
	return NULLOBJ;
    }

    /*Set dims*/
    DIMS(retVal) = newDims;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> flags, OBJTYPE(array -> flags));

    RANK(retVal) = 1;

    if (IsRealArray(array))
    {
	real *elements;
	real *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (real *) malloc(sizeof(real) * DIMS(array)[0]);
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	for (s = 0; s < DIMS(array)[0]; ++s)
	{
	    newElements[s] = elements[s];
	}

	qsort(newElements,
	  DIMS(array)[0],
	  sizeof(real),
	  CR);

	s = d = 0;
	++s;
	while (s < DIMS(array)[0])
	{
	    if (newElements[s] != newElements[d])
	    {
		newElements[++d] = newElements[s];
	    }
	    ++s;
	}
	newElements = realloc(newElements, sizeof(ObjPtr) * (d + 1));
	ELEMENTS(retVal) = newElements;
    }
    else
    {
	ObjPtr *elements;
	ObjPtr *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (ObjPtr *) malloc(sizeof(ObjPtr) * DIMS(array)[0]);
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	for (s = 0; s < DIMS(array)[0]; ++s)
	{
	    newElements[s] = elements[s];
	}

	qsort(newElements,
	  DIMS(array)[0],
	  sizeof(real),
	  ComparePointers);

	s = d = 0;
	++s;
	while (s < DIMS(array)[0])
	{
	    if (newElements[s] != newElements[d])
	    {
		newElements[++d] = newElements[s];
	    }
	    ++s;
	}
	newElements = realloc(newElements, sizeof(ObjPtr) * (d + 1));
	ELEMENTS(retVal) = newElements;
    }

    DIMS(retVal)[0] = d + 1;

    return retVal;
}

ObjPtr SortArray(array)
ObjPtr array;
/*Returns array from array sorted by real value or object address.  
  Array must be 1-dimensional.*/
{
    long *newDims;
    ObjPtr retVal;
    long k;

    if ((!IsObjArray(array) && !IsRealArray(array)) || RANK(array) != 1)
    {
	ReportError("SortArray",
		"This function requires an array of rank 1");
	return NULLOBJ;
    }

    /*Make the new dims*/
    newDims = (long *) malloc(sizeof(long));
    if (!newDims)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Make the array*/
    retVal = NewObject(IsRealArray(array) ? arrayClass : objectArrayClass, sizeof(Array) - sizeof(Obj));

    /*If can't, return NIL*/
    if (!retVal)
    {
	free(newDims);
	OMErr();
	return NULLOBJ;
    }

    /*Set dims*/
    DIMS(retVal) = newDims;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> flags, OBJTYPE(array -> flags));

    RANK(retVal) = 1;

    if (IsRealArray(array))
    {
	real *elements;
	real *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (real *) malloc(sizeof(real) * DIMS(array)[0]);
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	for (k = 0; k < DIMS(array)[0]; ++k)
	{
	    newElements[k] = elements[k];
	}

	qsort(newElements,
	  DIMS(array)[0],
	  sizeof(real),
	  CR);

	ELEMENTS(retVal) = newElements;
    }
    else
    {
	ObjPtr *elements;
	ObjPtr *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (ObjPtr *) malloc(sizeof(ObjPtr) * DIMS(array)[0]);
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	for (k = 0; k < DIMS(array)[0]; ++k)
	{
	    newElements[k] = elements[k];
	}

	qsort(newElements,
	  DIMS(array)[0],
	  sizeof(real),
	  ComparePointers);

	ELEMENTS(retVal) = newElements;
    }

    DIMS(retVal)[0] = DIMS(array)[0];

    return retVal;
}

ObjPtr RealArrayDeltas(array)
ObjPtr array;
/*Takes a real array of rank one, dimension n.  If n is 1, returns an array
  of dimension 1 with a 0 in it.  If n > 1, returns an array of dimension
  n - 1 where each element is the difference between successive elements
  of array*/
{
    ObjPtr retVal;
    real *sElements, *dElements;
    long k;

    if ((!IsRealArray(array)) || RANK(array) != 1)
    {
	ReportError("Uniq",
		"This function requires a real array of rank 1");
	return NULLOBJ;
    }

    if (DIMS(array)[0] <= 1)
    {
	retVal = NewRealArray(1, 1L);
	*((real *) ELEMENTS(retVal)) = 0.0;
	return retVal;
    }

    /*Make new array*/
    retVal = NewRealArray(1, DIMS(array)[0] - 1);

    /*If can't, return NIL*/
    if (!retVal)
    {
	return NULLOBJ;
    }

    /*Fill in new array*/
    sElements = ELEMENTS(array);
    dElements = ELEMENTS(retVal);
    for (k = 0; k < DIMS(retVal)[0]; ++k)
    {
	dElements[k] = sElements[k + 1] - sElements[k];
    }

    return retVal;
}

ObjPtr InsertInArray(array, value, index)
ObjPtr array;
ObjPtr value;
long index;
/*Inserts value into a new array like array at index*/
{
    long *newDims;
    ObjPtr retVal;
    int s;

    if ((!IsObjArray(array) && !IsRealArray(array)) || RANK(array) != 1)
    {
	ReportError("InsertInArray",
		"This function requires an array of rank 1");
	return NULLOBJ;
    }

    if (IsRealArray(array) && !IsReal(value))
    {
	ReportError("InsertInArray",
		"You can only insert reals into real arrays");
    }

    /*Make the new dims*/
    newDims = (long *) malloc(sizeof(long));
    if (!newDims)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Make the array*/
    retVal = NewObject(IsRealArray(array) ? arrayClass : objectArrayClass, sizeof(Array) - sizeof(Obj));

    /*If can't, return NIL*/
    if (!retVal)
    {
	free(newDims);
	OMErr();
	return NULLOBJ;
    }

    /*Set dims*/
    DIMS(retVal) = newDims;
    DIMS(retVal)[0] = DIMS(array)[0] + 1;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> flags, OBJTYPE(array -> flags));

    RANK(retVal) = 1;

    if (IsRealArray(array))
    {
	real *elements;
	real *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (real *) malloc(sizeof(real) * (DIMS(array)[0] + 1));
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	/*Copy the elements*/
	for (s = 0; s < index; ++s)
	{
	    newElements[s] = elements[s];
	}
	newElements[index] = GetReal(value);
	for (s = index; s < DIMS(array)[0]; ++s)
	{
	    newElements[s + 1] = elements[s];
	}
	ELEMENTS(retVal) = newElements;
    }
    else
    {
	ObjPtr *elements;
	ObjPtr *newElements;

	elements = ELEMENTS(array);

	/*Make the new elements*/
	newElements = (ObjPtr *) malloc(sizeof(ObjPtr) * (DIMS(array)[0] + 1));
	if (!newElements)
	{
	    OMErr();
	    return NULLOBJ;
	}

	/*Copy the elements*/
	for (s = 0; s < index; ++s)
	{
	    newElements[s] = elements[s];
	}
	newElements[index] = value;
	for (s = index; s < DIMS(array)[0]; ++s)
	{
	    newElements[s + 1] = elements[s];
	}
	ELEMENTS(retVal) = newElements;
    }

    return retVal;
}

#ifdef PROTO
ObjPtr InterpArray(ObjPtr interp1, ObjPtr interp2, real weight)
#else
ObjPtr InterpArray(interp1, interp2, weight)
ObjPtr interp1, interp2;
real weight;
#endif
/*Makes a new array that linearly interpolates between interp1 and interp2.
  Weight is the amount, between 0.0 and 1.0, to favor interp2 over interp1.*/
{
    register long nels;			/*Number of elements in array*/
    register int k;			/*Random counter*/    
    long *dimPtr1, *dimPtr2, *dimPtr3;	/*Pointer to dimensions and then some*/
    register real *interpPtr1, *interpPtr2;
    register real *destPtr;
    APtr retVal;
    real *elements;			/*Pointer to the elements*/
    long *dims;				/*Pointer to dims*/

    if ((!IsRealArray(interp1)) || (!IsRealArray(interp2)))
    {
	ReportError("InterpArray","Can only interpolate between real arrays");
 	return NULLOBJ;
    }

    if (RANK(interp1) != RANK(interp2))
    {
	ReportError("InterpArray","Rank mismatch");
	return NULLOBJ;
    }

    nels = 1;
    dimPtr1 = DIMS(interp1);
    dimPtr2 = DIMS(interp2);

    for (k = 0; k < RANK(interp1); ++k)
    {
	if (*dimPtr1 != *dimPtr2)
	{
	    ReportError("InterpArray","Dimension mismatch\n");
	    return NULLOBJ;
	}
	nels *= *dimPtr1;
	++dimPtr1;
	++dimPtr2;
    } 

    /*Try to allocate the elements*/
    elements = (real *) malloc(nels * sizeof(real));

    /*If can't, return NIL*/
    if (!elements)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Try to allocate the dims*/
    dims = (long *) malloc(RANK(interp1) * sizeof(long));
    if (!dims)
    {
	free(elements);
	OMErr();
	return NULLOBJ;
    }
    
    /*Make the array*/
    retVal = (APtr) NewObject(arrayClass,
			      sizeof(Array) - sizeof(Obj));

    /*If can't, return NIL*/
    if (!retVal)
    {
	OMErr();
	free(elements);
	free(dims);
	return (ObjPtr) retVal;
    }

    /*Make elements and dims*/
    ELEMENTS(retVal) = elements;
    DIMS(retVal) = dims;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> thing . flags, REALARRAY);

    retVal -> rank = RANK(interp1);

    dimPtr1 = DIMS(interp1);
    dimPtr2 = DIMS(interp2);
    dimPtr3 = DIMS(retVal);

    for (k = 0; k < RANK(interp1); ++k)
    {
	DIMS(retVal)[k] = DIMS(interp1)[k];
	++dimPtr1;
	++dimPtr2;
	++dimPtr3;
    } 

    interpPtr1 = ELEMENTS(interp1);
    interpPtr2 = ELEMENTS(interp2);
    destPtr = ELEMENTS(retVal);

    while (nels)
    {
	*destPtr = *interpPtr2 * weight + *interpPtr1 * (1.0 - weight);
	if (*interpPtr1 == missingData || *interpPtr2 == missingData)
	{
	    *destPtr = missingData;
	}
	++destPtr;
	++interpPtr1;
	++interpPtr2;
	--nels;
    }
    return (ObjPtr) retVal;
}

#ifdef PROTO
ObjPtr MergeRealArrays(ObjPtr merge1, ObjPtr merge2)
#else
ObjPtr MergeRealArrays(merge1, merge2)
ObjPtr merge1, merge2;
#endif
/*Makes a new real array that merges values from merge1 and merge2.  Assumes
  that merge1 and merge2 are already sorted*/
{
    register long nels1, nels2;		/*Number of elements in array*/
    register int k;			/*Random counter*/  
    register long s1, s2, d;		/*Indices for copy*/ 
    register real *mergePtr1, *mergePtr2;
    register real *destPtr;
    APtr retVal;
    real *elements;			/*Pointer to the elements*/
    long *dims;				/*Pointer to dims*/

    if ((!IsRealArray(merge2)) || (!IsRealArray(merge1)))
    {
	ReportError("MergeRealArrays", "Can only merge real arrays");
 	return NULLOBJ;
    }

    if (RANK(merge1) != 1 || RANK(merge2) != 1)
    {
	ReportError("MergeRealArrays", "Can only merge arrays of rank 1");
	return NULLOBJ;
    }

    nels1 = DIMS(merge1)[0];
    nels2 = DIMS(merge2)[0];

    /*Try to allocate the elements*/
    elements = (real *) malloc((nels1 + nels2) * sizeof(real));

    /*If can't, return NIL*/
    if (!elements)
    {
	OMErr();
	return NULLOBJ;
    }

    /*Try to allocate the dims*/
    dims = (long *) malloc(sizeof(long));
    if (!dims)
    {
	free(elements);
	OMErr();
	return NULLOBJ;
    }
    dims[0] = nels1 + nels2;
    
    /*Make the array*/
    retVal = (APtr) NewObject(arrayClass, sizeof(Array) - sizeof(Obj));

    /*If can't, return NIL*/
    if (!retVal)
    {
	OMErr();
	free(elements);
	free(dims);
	return (ObjPtr) retVal;
    }

    /*Make elements and dims*/
    ELEMENTS(retVal) = elements;
    DIMS(retVal) = dims;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> thing . flags, REALARRAY);

    retVal -> rank = 1;

    mergePtr1 = ELEMENTS(merge1);
    mergePtr2 = ELEMENTS(merge2);
    destPtr = ELEMENTS(retVal);
    s1 = 0; s2 = 0; d = 0;
    while (s1 < nels1 || s2 < nels2)
    {
	if (s2 >= nels2)
	{
	    destPtr[d] = mergePtr1[s1];
	    ++s1;
	    ++d;
	}
	else if (s1 >= nels1)
	{
	    destPtr[d] = mergePtr2[s2];
	    ++s2;
	    ++d;
	}
	else if (mergePtr1[s1] < mergePtr2[s2])
	{
	    destPtr[d] = mergePtr1[s1];
	    ++s1;
	    ++d;
	}
	else
	{
	    destPtr[d] = mergePtr2[s2];
	    ++s2;
	    ++d;
	}
    }

    return (ObjPtr) retVal;
}

void CArray2Array(array, pointer)
ObjPtr array;
real *pointer;
/*Fills array with the data at pointer.  It better be right!*/
{
    long nels;				/*Number of elements in array*/
    int k;				/*Random counter*/    
    long *dimPtr;			/*Pointer to dimensions and then some*/
    real *destPtr;			/*Pointer to destination within array*/

    nels = 1;
    dimPtr = DIMS(array);
    for (k = 0; k < RANK(array); ++k)
    {
	nels *= *dimPtr;
	++dimPtr;
    } 
    destPtr = ELEMENTS(array);
    while (nels)
    {
	*destPtr = *pointer;
	++destPtr;
	++pointer;
	--nels;
    }
}

#ifdef PROTO
void MinMax(real *min, real *max, real *elements, long nels)
#else
void MinMax(min, max, elements, nels)
real *min;
real *max;
real *elements;
long nels;
#endif
/*Returns the min and max of nels reals at elements*/
{
    Bool firstTime = true;
    while (nels)
    {
	if (*elements != missingData)
	{
	    if (firstTime)
	    {
		firstTime = false;
		*min = *max = *elements;
	    }
	    else
	    {

		if (*elements > *max) *max = *elements;
		if (*elements < *min) *min = *elements;
	    }
	}
	++elements;
	--nels;
    }
}

void Array2CArray(pointer, array)
ObjPtr array;
real *pointer;
/*Fills data at pointer with array.  It better be right!*/
{
    int nels;				/*Number of elements in array*/
    int k;				/*Random counter*/    
    long *dimPtr;			/*Pointer to dimensions and then some*/
    real *srcPtr;			/*Pointer to source within array*/

    nels = 1;
    dimPtr = DIMS(array);
    for (k = 0; k < ((APtr) array) -> rank; ++k)
    {
	nels *= *dimPtr;
	++dimPtr;
    } 
    srcPtr = ELEMENTS(array);
    while (nels)
    {
	*pointer = *srcPtr;
	++srcPtr;
	++pointer;
	--nels;
    }
}

#ifdef PROTO
ObjPtr NewRealArray(int rank, ...)
#else
ObjPtr NewRealArray(rank)
int rank;
#endif
/*Makes a real array with rank rank and long dimensions starting after.  For 
  example, to make a 20 by 25 by 30 array, use NewRealArray(3, 20, 25, 30).
  An array of rank 0 has exactly one element.  Arrays of negative rank will
  return NIL, as will arrays too big to create in memory.  Sets every element
  of the array to zero*/
{
    long numEls;		/*Number of elements in array*/
    register int k;		/*Counter for random purposes*/
    long *dimPtr;		/*Pointer to the next dimension*/
    APtr retVal;		/*Value to return*/
    real *runner;		/*Runner for setting stuff to 0.0*/
    real *elements;		/*The elements of the array*/
    long *dims;			/*The dimensions of the array*/

    /*Check for valid rank*/
    if (rank < 0)
    {
	return (ObjPtr) NIL;
    }

    /*Calculate the number of elements*/
    dimPtr = (long *) (&rank + 1);
    numEls = 1;
    for (k = 0; k < rank; ++k)
    {
	numEls *= *dimPtr;
	++dimPtr;
    }

    /*Try to allocate the elements*/
    elements = (real *) malloc(numEls * sizeof(real));
    if (!elements)
    {
	OMErr();
	return NULLOBJ;
    }
    
    /*Try to allocate the dims*/
    dims = 0;
    if (rank)
    {
	dims = (long *) malloc(rank * sizeof(long));
	if (!dims)
	{
	    free(elements);
	    OMErr();
	    return NULLOBJ;
	}
    }
    
    /*Try to allocate the array*/
    retVal = (APtr) NewObject(arrayClass,
			      sizeof(Array) - sizeof(Obj));
    /*If can't, return NIL*/
    if (!retVal)
    {
	OMErr();
	free(elements);
	SAFEFREE(dims);
	return NULLOBJ;
    }

    /*Put in the elements and dims*/
    ELEMENTS(retVal) = elements;
    DIMS(retVal) = dims;

    /*Fill in values for flags and dimensions*/
    SETOBJTYPE(retVal -> thing . flags, REALARRAY);

    RANK(retVal) = rank;
    dimPtr = (long *) (&rank + 1);
    for (k = 0; k < rank; ++k)
    {
	DIMS(retVal)[k] = *dimPtr;
        ++dimPtr;
    }

    /*Zero the array*/
    runner = ArrayMeat((ObjPtr) retVal);
    while (numEls)
    {
	*runner = 0.0;
	++runner;
	--numEls;
    }

    return (ObjPtr) retVal;    
}

#ifdef PROTO
ObjPtr NewArray(int arrayType, int rank, long *dimensions)
#else
ObjPtr NewArray(arrayType, rank, dimensions)
int arrayType;
int rank;
long *dimensions;
#endif
/*Makes an array of arrayType with rank rank and dimensions in an array of longs
  pointed to by dimensions.  Arrays of negative rank will return NIL, as will 
  arrays too big to create in memory.  Sets every element of the array to zero
  or NIL or whatever*/
{
    long numEls;		/*Number of elements in array*/
    register int k;		/*Counter for random purposes*/
    APtr retVal;		/*Value to return*/
    long *dimPtr;		/*Running pointer to dimensions*/
    long *dims;			/*Pointer to dimensions*/

    /*Check for valid rank*/
    if (rank < 0)
    {
	return (ObjPtr) NIL;
    }

    /*Calculate the number of elements*/
    numEls = 1;
    dimPtr = dimensions;
    for (k = 0; k < rank; ++k)
    {
	numEls *= *dimPtr;
	++dimPtr;
    }

    /*Try to allocate the array*/
    retVal = (APtr) NewObject(arrayType == AT_REAL ? arrayClass : objectArrayClass,
			      sizeof(Array) - sizeof(Obj));
    /*If can't, return NIL*/
    if (!retVal)
    {
	OMErr();
	return (ObjPtr) retVal;
    }

    ELEMENTS(retVal) = 0;
    DIMS(retVal) = 0;

    /*Try to allocate the elements*/
    switch(arrayType)
    {
	case AT_REAL:
	    {
		real *elements;
		real *runner;
		elements = (void *) malloc(numEls * sizeof(real));

		/*If can't, return NIL*/
		if (!elements)
		{
		    OMErr();
		    return NULLOBJ;
		}

		/*Put in the elements*/
		ELEMENTS(retVal) = elements;

		/*Fill in values for flags*/
		SETOBJTYPE(retVal -> thing . flags, REALARRAY);

		/*Zero the array*/
		runner = elements;
		while (numEls)
		{
		    *runner = 0.0;
		    ++runner;
		    --numEls;
		}
	    }
	    break;
	case AT_OBJECT:
	    {
		ObjPtr *elements;
		ObjPtr *runner;
		elements = (void *) malloc(numEls * sizeof(ObjPtr));

		/*If can't, return NIL*/
		if (!elements)
		{
		    OMErr();
		    return NULLOBJ;
		}


		/*Put in the elements*/
		ELEMENTS(retVal) = elements;

		/*Fill in values for flags*/
		SETOBJTYPE(retVal -> thing . flags, OBJECTARRAY);

		/*Zero the array*/
		runner = elements;
		while (numEls)
		{
		    *runner = NULLOBJ;
		    ++runner;
		    --numEls;
		}
	    }
	    break;
	default:
	    ReportError("NewArray", "Bad array type");
	    return NULLOBJ;
    }

    /*Try to allocate the dims*/
    if (rank)
    {
	dims = (long *) malloc(rank * sizeof(long));
	if (!dims)
	{
	    OMErr();
	    return NULLOBJ;
	}
    }
    else
    {
	dims = 0;
    }
    DIMS(retVal) = dims;
    
    /*Fill in rank and dimensions*/
    retVal -> rank = rank;
    dimPtr = dimensions;
    for (k = 0; k < rank; ++k)
    {
	retVal -> dims[k] = *dimPtr;
        ++dimPtr;
    }

    return (ObjPtr) retVal;    
}

ObjPtr ListToArray(list)
ObjPtr list;
/*Converts a list to a 1-dimensional object array*/
{
    ObjPtr retVal;
    long size;
    ThingListPtr runner;
    ObjPtr *elements;
    long k;

    size = ListCount(list);
    retVal = NewArray(AT_OBJECT, 1, &size);

    elements = ELEMENTS(retVal);
    runner = LISTOF(list);
    k = 0;
    while (runner)
    {
	elements[k] = runner -> thing;
	++k;
	runner = runner -> next;
    }
    return retVal;
}

static ObjPtr MarkObjectArray(array)
ObjPtr array;
/*Marks an object array*/
{
    long nels;
    long *dimPtr;
    long k;
    ObjPtr *meat;
    if (!IsObjArray(array))
    {
	/*Needed to avoid marking class*/
	return ObjFalse;
    }

    nels = 1;
    dimPtr = DIMS(array);

    for (k = 0; k < RANK(array); ++k)
    {
	nels *= *dimPtr;
	++dimPtr;
    }
    meat = (ObjPtr *) ELEMENTS(array);
    while (nels)
    {
	if (*meat)
	{
	    MarkObject(*meat);
	}
	++meat;
	--nels;
    }
    return ObjTrue;
}

static ObjPtr CleanupArray(array)
ObjPtr array;
/*Cleans up an array by getting rid of its elements*/
{
    if ((!IsRealArray(array)) && (!IsObjArray(array)))
    {
	return ObjTrue;
    }
    if (ELEMENTS(array))
    {
	free(ELEMENTS(array));
	ELEMENTS(array) = 0;
    }
    if (DIMS(array))
    {
	free(DIMS(array));
	DIMS(array) = 0;
    }
    return ObjTrue;
}

static ObjPtr RegisterRealArray(field, whichField)
ObjPtr field;
int whichField;
/*Registers an array field in field slot whichField*/
{
    Component *component = 0;

    component = (Component *) malloc(sizeof(Component));
    if (!component)
    {
	OMErr();
	return ObjFalse;
    }

    component -> flags = 0;
    component -> indices = 0;
    component -> dimensions = 0;
    component -> steps = 0;

    curFields[whichField] . components = component;
    curFields[whichField] . nComponents = 1;
    return RegisterComponent(whichField, 0, field) ? ObjTrue : ObjFalse;
}

static ObjPtr RegisterObjectArray(field, whichField)
ObjPtr field;
int whichField;
/*Registers an object array field in field slot whichField*/
{
    int nComponents;
    int k;
    long dimension;
    Component *component = 0;
    ObjPtr retVal;

    if (RANK(field) != 1)
    {
	/*Only vectors allowed, bud.*/
	ReportError("RegisterObjectArray", "Only vector object arrays can be used in datasets.");
	return ObjFalse;
    }

    nComponents = DIMS(field)[0];

    component = (Component *) malloc(nComponents * sizeof(Component));
    if (!component)
    {
	OMErr();
	return ObjFalse;
    }

    for (k = 0; k < nComponents; ++k)
    {
	component[k] . flags = 0;
	component[k] . indices = 0;
	component[k] . dimensions = 0;
	component[k] . steps = 0;
    }

    retVal = ObjTrue;

    curFields[whichField] . components = component;
    curFields[whichField] . nComponents = nComponents;

    for (dimension = 0; dimension < nComponents; ++dimension)
    {
	ObjPtr temp;
	temp = GetObjectElement(field, &dimension);
	if (!RegisterComponent(whichField, dimension, temp))
	{
	    retVal = false;
	}
    }
    return retVal;
}

static ObjPtr RegisterRealComponent(field, whichField, whichComponent)
ObjPtr field;
int whichField, whichComponent;
/*Registers an array field in field slot whichField in component whichComponent*/
{
    Component *component;
    int *indices = 0;
    long *dimensions = 0;
    long *steps = 0;
    ObjPtr indicesVar;
    long dataSize;
    int k;

    /*A scalar array, the simplest type of field*/
    if (RANK(field))
    {
    
	indices = (int *) malloc(RANK(field) * sizeof(int));
	if (!indices)
	{
	    OMErr();
	    return ObjFalse;
	}
    
	steps = (long *) malloc(RANK(field) * sizeof(long));
	if (!steps)
	{
	    free(indices);
	    OMErr();
	    return ObjFalse;
	}

	dimensions = (long *) malloc(RANK(field) * sizeof(long));
	if (!dimensions)
	{
	    free(indices);
	    free(steps);
	    OMErr();
	    return ObjFalse;
	}
    }
    else
    {
	steps = 0;
	indices = 0;
	dimensions = 0;
    }

    indicesVar = GetVar(field, INDICES);
    if (indicesVar)
    {
	if (!IsRealArray(indicesVar) || RANK(indicesVar) != 1 || DIMS(indicesVar)[0] != RANK(field))
	{
	    ReportError("ReigsterRealComponent", "Bad INDICES variable");
	    indicesVar = 0;
	}
    } 

    component = &(curFields[whichField] . components[whichComponent]);

    /*Fill in dimensions, indices, and steps*/
    dataSize = 1;
    for (k = RANK(field) - 1; k >= 0; --k)
    {
	if (indicesVar)
	{
	    indices[k] = ((real *) ELEMENTS(indicesVar))[k];
	}
	else
	{
	    indices[k] = k;
	}
	dimensions[k] = DIMS(field)[k];
	dataSize *= DIMS(field)[k];
	steps[k] =
	    (k == RANK(field) - 1) ?
		1 :
		dimensions[k + 1] * steps[k + 1];
    }

    component -> data . unComp = ELEMENTS(field);
    component -> dataCompressed = false;
    component -> dataSize = dataSize;
    component -> nIndices = RANK(field);
    component -> indices = indices;
    component -> dimensions = dimensions;
    component -> steps = steps;

    return ObjTrue;
}


ObjPtr MakeArrayCurData(array)
ObjPtr array;
/*Makes array, setting CURDATA*/
{
    if (array != GetVar(array, CURDATA))
    {
	SetVar(array, CURDATA, array);
	return ObjTrue;
    }
    else
    {
	return ObjFalse;
    }
}


ObjPtr GetArrayTopDim(array)
ObjPtr array;
/*Gets the topological dimension of array*/
{
    return NewInt(RANK(array));
}

ObjPtr GetObjArrayTopDim(array)
ObjPtr array;
/*Gets the topological dimension of array*/
{
    FuncTyp method;
    ObjPtr firstElement;
    long dimension;

    dimension = 0;

    firstElement = GetObjectElement(array, &dimension);
    method = GetMethod(firstElement, GETTOPDIM);
    if (method)
    {
	return (*method)(firstElement);
    }
    else
    {
	return NewInt(0);
    }
}

#ifdef PROTO
ObjPtr GetObjectElement(ObjPtr array, long *dims)
#else
ObjPtr GetObjectElement(array, dims)
ObjPtr array;
long *dims;
#endif
/*Gets a element specified by dims within array, assuming that
  array is an object array.  There had better be enough dims.*/
{
    long offset;
    int k;
    ObjPtr *elements;

    if (!IsObjArray(array))
    {
	return NULLOBJ;
    }

    offset = 0;
    for (k = 0; k < RANK(array); ++k)
    {
	if (k)
	{
	    offset *= DIMS(array)[k];
	}
	offset += dims[k];
    }
    elements = (ObjPtr *) ELEMENTS(array);

    /*Hey, John!  Put your code in here!*/
    return elements[offset];
}

void InitArrays()
/*Initializes the array system*/
{
    arrayClass = NewObject(NULLOBJ, 0);
    AddToReferenceList(arrayClass);
    SetMethod(arrayClass, CLEANUP, CleanupArray);
    SetMethod(arrayClass, REGISTERFIELD, RegisterRealArray);
    SetMethod(arrayClass, REGISTERCOMP, RegisterRealComponent);
    SetMethod(arrayClass, GETTOPDIM, GetArrayTopDim);
    SetMethod(arrayClass, CURDATA, MakeArrayCurData);
#ifdef SOCKETS
#if MACHINE == IRIS4D
#ifdef FASTSOCKETS
fprintf(stderr, "Using fast, raw data sockets\n");
    SetMethod(arrayClass, TRANSMITEXTRA, TransmitExtraStuffRealArrayRaw);
    SetMethod(arrayClass, RECEIVEEXTRA, ReceiveExtraStuffRealArrayRaw);
#else
fprintf(stderr, "Using slow, ascii data sockets\n");
    SetMethod(arrayClass, TRANSMITEXTRA, TransmitExtraStuffRealArrayAscii);
    SetMethod(arrayClass, RECEIVEEXTRA, ReceiveExtraStuffRealArrayAscii);
#endif
#else
fprintf(stderr, "Using slow, ascii data sockets\n");
    SetMethod(arrayClass, TRANSMITEXTRA, TransmitExtraStuffRealArrayAscii);
    SetMethod(arrayClass, RECEIVEEXTRA, ReceiveExtraStuffRealArrayAscii);
#endif
#endif

    objectArrayClass = NewObject(arrayClass, 0);
    AddToReferenceList(objectArrayClass);
    SetMethod(objectArrayClass, MARK, MarkObjectArray);
    SetMethod(objectArrayClass, REGISTERCOMP, (FuncTyp) 0);
    SetMethod(objectArrayClass, REGISTERFIELD, RegisterObjectArray);
    SetMethod(objectArrayClass, GETTOPDIM, GetObjArrayTopDim);
#ifdef SOCKETS
    SetMethod(objectArrayClass, TRANSMITEXTRA, TransmitExtraStuffObjectArray);
    SetMethod(objectArrayClass, RECEIVEEXTRA, ReceiveExtraStuffObjectArray);
#endif
}

void KillArrays()
/*Kills the array system*/
{
    DeleteThing(objectArrayClass);
    DeleteThing(arrayClass);
}
