/* Array manipulation routines for S-Lang */
/* 
 * Copyright (c) 1992, 1994 John E. Davis 
 * All rights reserved.
 *
 * Permission is hereby granted, without written agreement and without
 * license or royalty fees, to use, copy, and distribute this
 * software and its documentation for any purpose, provided that the
 * above copyright notice and the following two paragraphs appear in
 * all copies of this software.   Permission is not granted to modify this
 * software for any purpose without written agreement from John E. Davis.
 *
 * IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT,
 * INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF
 * THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS
 * HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 * JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
 * PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
 * BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE,
 * SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 */


#include <stdio.h>
#include <string.h>
#include "slang.h"
#include "_slang.h"
#include "slarray.h"

/* Array Stuff */
#define MAX_ARRAYS 256

static SLArray_Type *Array_Table[MAX_ARRAYS];

static void free_array_handle (int hand)
{
   SLArray_Type *a = Array_Table[hand];
   
   if (a == NULL)
     {
	SLang_doerror ("Array is not allocated.");
	return;
     }

   if (a->flags) 
     {
	SLang_doerror ("Freeing an intrinsic array is illegal.");
	return;
     }
   Array_Table[hand] = NULL;
   FREE( a->ptr );
   FREE(a);
}

/* This routine may be called by application to free array handle created by 
 * the application.  Returns 0 upon success, -1 if the handle is invalid and
 * -2 if the handle is not associated with a C array.
 */
int SLang_free_array_handle (int hand)
{
   SLArray_Type *a = Array_Table[hand];
   
   if (a == NULL) return -1;
   if (a->flags == 0) return -2;
   Array_Table[hand] = NULL;
   FREE(a);
   return 0;
}

static int alloc_array_handle (void)
{
   SLArray_Type **a, **amax;
   a = Array_Table;
   amax = a + MAX_ARRAYS;
   while (a < amax)
     {
	if (*a == NULL) return ((int) (a - Array_Table));
	a++;
     }
   SLang_doerror ("Array limit exceeded.");
   return -1;
}

	
/* if ptr == NULL then malloc space.  Otherwise assume space is at ptr */
int SLcreate_array(long *ptr, int dim, int d0, int d1, int d2,
		      unsigned char t, unsigned char flags)
{
   unsigned long n, size;
   unsigned char type;
   SLArray_Type *at;
   int hand;

   
   switch (t)
     {
      case 'i': type = INT_TYPE; size = sizeof(int); break;
      case 's': type = STRING_TYPE; size = sizeof(char *); break;
      case 'c': type = CHAR_TYPE; size = sizeof(char); break;
#ifdef FLOAT_TYPE
      case 'f': type = FLOAT_TYPE; size = sizeof(FLOAT); break;
#endif
      default: return (-1);
     }

   /* This must be since indices go from 0 to d - 1 */
   if (d1 < 1) d1 = 1;
   if (d2 < 1) d2 = 1;
   
   n = d0;
   n = n * d1;
   n = n * d2;
   
   if (-1 == (hand = alloc_array_handle ())) return hand;

   if (NULL == (at = (SLArray_Type *) MALLOC(sizeof(SLArray_Type))))
     {
	return -1;
     }

   if (ptr == NULL)
     {
	if (size == 1) ptr = (long *) MALLOC(n); else ptr = (long *) CALLOC(n, size);
	if (ptr == NULL) return (-1);
     }
   
   Array_Table [hand] = at;
   
   at->ptr = (long) ptr;
   at->dim = dim;
   at->x = d0; at->y = d1; at->z = d2;
   at->type = type;
   at->flags = flags;
   return(hand);
}

void SLpush_array (int at)
{
   SLang_Object_Type obj;
   
   obj.type = LANG_DATA | (ARRAY_TYPE << 8);
   obj.v.i_val =  at;
   SLang_push(&obj);
}


void SLang_create_array(void)
{
   int dim, d0, d1, d2, t;
   int at;

   if (SLang_pop_integer(&dim)) return;

   if (dim > 3)
     {
	SLang_doerror("Array size not supported.");
	return;
     }

   d1 = d0 = d2 = 1;
   switch(dim)
     {
      case 3: SLang_pop_integer(&d2);
      case 2: SLang_pop_integer(&d1);
      case 1: SLang_pop_integer(&d0);
     }

   if (SLang_pop_integer(&t)) return;

   at = SLcreate_array(NULL, dim, d0, d1, d2, t, 0);
   
   if (at == -1)
     {
	SLang_doerror("Unable to create array.");
	return;
     }
   
   SLpush_array (at);
}

void SLfree_array(void)
{
   SLang_Object_Type obj;
   
   if (SLang_pop(&obj)) return;

   if ((obj.type >> 8) != ARRAY_TYPE)
     {
	SLang_Error = TYPE_MISMATCH;
	return;
     }
   
   free_array_handle (obj.v.i_val);
}

/* returns the array referenced by handle h */
SLArray_Type *SLarray_from_handle (int h)
{
   return Array_Table[h];
}


/* returns array.  If *stype is non-zero, a string is accepted as an array.
   If an actual array is popped, *stype will be zero upon return.  However,
   if *stype is such that a string is permitted, *stype will be 1 if the
   string that is returned (through the cast) should be freed.  */

SLArray_Type *SLang_pop_array(int *sflag)
{
   SLang_Object_Type obj;
   unsigned short t;
   
   if (SLang_pop(&obj)) return(NULL);

   t = obj.type;
   if ((t >> 8) != ARRAY_TYPE)
     {
	if ((*sflag == 0) || ((t >> 8) != STRING_TYPE))
	  {
	     SLang_Error = TYPE_MISMATCH;
	     return(NULL);
	  }
	if ((t & 0xFF) == LANG_DATA) *sflag = 1; else *sflag = -1;
	return (SLArray_Type *) obj.v.s_val;
     }
   *sflag = 0;
   return SLarray_from_handle (obj.v.i_val);
}

static char *Bound_err = "Array dims out of bounds";
static unsigned int compute_array_offset(SLArray_Type *at)
{
   int elem[3], el, x[3], d, dim;
   unsigned int off;

   if (SLang_Error) return(0);
   dim = at->dim;
   x[0] = at->x; x[1] = at->y; x[2] = at->z;
   elem[0] = elem[1] = elem[2] = 0;
   d = dim;

   while (d--)
     {
	if (SLang_pop_integer(&el)) return(0);
	if ((el >= x[d]) || (el < 0))
	  {
	     SLang_doerror(Bound_err);
	     return(0);
	  }
	elem[d] = el;
     }

   off = 0;
   d = 0;

   off = (elem[0] * x[1] + elem[1]) * x[2] + elem[2];
   
   return(off);
}


static void str_get_elem(unsigned char *s, int dat)
{
   int n, nmax, ch;
   if (SLang_pop_integer(&n)) goto done;
   nmax = strlen((char *) s);
   if (nmax < n)
     {
	SLang_doerror(Bound_err);
	goto done;
     }
   ch = s[n];
   SLang_push_integer(ch);

   done:
   if (dat == 1) FREE(s);
}

   

void SLarray_putelem()
{
   SLArray_Type *at;
   unsigned int off;
   int sdat, i, *ip;
   char *str, *newstr, **sp;
   unsigned char *p, *ic;
#ifdef FLOAT_TYPE
   FLOAT f, *fp;
   int ix;
   int convert;
#endif

   sdat = 0; if (NULL == (at = SLang_pop_array(&sdat))) return;

   if (at->flags == LANG_RVARIABLE)
     {
	SLang_Error = READONLY_ERROR;
	return;
     }
   
   off = compute_array_offset(at);
   if (SLang_Error) return;

   p = (unsigned char *) at->ptr;
   switch(at->type)
     {
	case INT_TYPE:
	  if (SLang_pop_integer(&i)) return;
	  ip = (int *) (off + (int *) p);
	  *ip = i; break;

	case STRING_TYPE:
	  if (SLang_pop_string(&str, &sdat)) return;
	  newstr = (char *) SLmake_string(str);
	  if (sdat == 1) FREE(str);
	  sp = (char **)(off + (char **) p);

	  if (NULL != *sp) FREE(*sp);
	  *sp = newstr;
	  break;
	
      case CHAR_TYPE: 
	if (SLang_pop_integer(&i)) return;
	ic = (unsigned char *)(off + (unsigned char *) p);
	*ic = (unsigned char) i;
	break;

#ifdef FLOAT_TYPE
      case FLOAT_TYPE: 
	if (SLang_pop_float(&f, &convert, &ix)) return;
	(void) convert;  (void) ix;
	fp = off + (FLOAT *) p;
	*fp = f;
	break;
#endif
	default: SLang_doerror("Corrupted Array.");
     }
   return;
}

static void array_push_element(SLArray_Type *at, int off)
{
   unsigned char *p;
   p = (unsigned char *) at->ptr;
   switch(at->type)
     {
      case INT_TYPE:  SLang_push_integer((int) *(((int *) p) + off)); break;
      case CHAR_TYPE: SLang_push_integer((int) *(((unsigned char *) p) + off)); break;
      case STRING_TYPE: 
	if (NULL == (p = (unsigned char *) *(((char **) p) + off)))
	  {
	     SLang_doerror("Array Element uninitialized.");
	  }
	else SLang_push_string((char *) p);
	break;
#ifdef FLOAT_TYPE
	case FLOAT_TYPE: SLang_push_float((FLOAT) *(((FLOAT *)p) + off)); break;
#endif
	default: SLang_doerror("Internal Error in array element.");
     }
}

void SLarray_getelem()
{
   SLArray_Type *at;
   unsigned int off;
   int sdat = 1;

   if (NULL == (at = SLang_pop_array(&sdat))) return;
   if (sdat) 
     {
	str_get_elem((unsigned char *) (long) at, sdat);
	return;
     }

   off = compute_array_offset(at);
   if (SLang_Error) return;
   array_push_element(at, off);
}

void SLcopy_array (void)
{
   SLArray_Type *a, *b;
   int sa = 0, sb = 0;
   unsigned int size;
   
   if ((NULL == (b = SLang_pop_array (&sb)))
       || (NULL == (a = SLang_pop_array (&sa))))
     {
	return;
     }
   /* array a must be writable and a and b must be identical */
   if (a->flags == LANG_RVARIABLE)
     {
     	SLang_Error = READONLY_ERROR;
	return;
     }
   if ((a->dim != b->dim)
       || (a->x != b->x)
       || (a->y != b->y)
       || (a->z != b->z)
       || (a->type != b->type))
     {
	SLang_Error = TYPE_MISMATCH;
	return;
     }
   
   switch (a->type)
     {
      case INT_TYPE: size = sizeof(int); break;
      case STRING_TYPE: size = sizeof(char *); break;
      case CHAR_TYPE: size = sizeof(char); break;
#ifdef FLOAT_TYPE
      case FLOAT_TYPE: size = sizeof(FLOAT); break;
#endif
      default: return;
     }
   /* I might want to loosen the restriction about the actual dimensions and
    * simply demand that the size be the same */
   size = size * a->x * a->y * a->z;
   MEMCPY ((char *)a->ptr, (char *)b->ptr, size);
}


   
   
int SLang_add_array(char *name, long* addr, int dim, int d0, int d1, int d2, 
		    unsigned char t, unsigned char flags)
{
   unsigned short type;
   int hand;

   if (-1 != (hand = SLcreate_array(addr, dim, d0, d1, d2, t, flags)))
     {
	type = LANG_IVARIABLE | (ARRAY_TYPE << 8);
	SLadd_name(name, (long) hand, type);
     }
   return hand;
}


void SLarray_sort(char *f)
{
   SLArray_Type *at_str, *at_int;
   unsigned char type;
   SLang_Name_Type *entry;
   SLang_Object_Type obj;
   int sdat;
   int l, j, ir, i, rra, n, cmp;
   int *ra;
   int hand;
   
   
   if ((NULL == (entry = SLang_locate_name(f))) || (*entry->name == 0))
     {
	SLang_doerror("Sort function undefined.");
	return;
     }
   
   type = entry->type & 0xFF;
   if (type != LANG_FUNCTION)
     {
	SLang_doerror("Invalid sort function.");
	return;
     }
   
   sdat = 0;
   if (NULL == (at_str = SLang_pop_array(&sdat))) return;
   
   if (at_str->flags == LANG_RVARIABLE)
     {
	SLang_Error = READONLY_ERROR;
	return;
     }
   
   n = at_str->x;
   
   if (at_str->dim != 1)
     {
	SLang_doerror("Sort requires 1 dim arrays.");
	return;
     }
   
   if (-1 == (hand = SLcreate_array(NULL, 1, n, 1, 1, 'i', 0)))
     {
	SLang_doerror("Error Creating index array.");
	return;
     }
   
   at_int = Array_Table[hand];
   
   ra = (int *) at_int->ptr;
   ra--;
   for (i = 1; i <= n; i++) ra[i] = i;
   
   /* heap sort from adapted from numerical recipes */
   
   l = 1 + n / 2;
   ir = n;
   
   while(1)
     {
	if (l > 1) rra = ra[--l];
	else
	  {
	     rra = ra[ir];
	     ra[ir] = ra[1];
	     if (--ir <= 1)
	       {
		  ra[1] = rra;
		  for (i = 1; i <= n; i++) ra[i] -= 1;
		  obj.type = LANG_DATA | (ARRAY_TYPE << 8);
		  obj.v.i_val= hand;
		  SLang_push(&obj);
		  return;
	       }
	  }
	i = l;
	j = 2 * l;
	while(j <= ir)
	  {
	     if (j < ir)
	       {
		  array_push_element(at_str, ra[j] - 1);
		  array_push_element(at_str, ra[j + 1] - 1);
		  SLexecute_function(entry);
		  if (SLang_pop_integer(&cmp)) goto return_err;
		  if (cmp) j++;
	       }
	     array_push_element(at_str, rra - 1);
	     array_push_element(at_str, ra[j] - 1);
	     SLexecute_function(entry);
	     if (SLang_pop_integer(&cmp)) goto return_err;
	     
	     if (cmp) 
	       {
		  ra[i] = ra[j];
		  i = j;
		  j += j;
	       }
	     else j = ir + 1;
	  }
	ra[i] = rra;
     }
   return_err:
   
   free_array_handle (hand);
}


void SLinit_char_array()
{
   int dat, sdat;
   SLArray_Type *at;
   unsigned char *s;
   unsigned int n, ndim;
   
   if (SLang_pop_string((char **) &s, &dat)) return;
   sdat = 0;
   if (NULL == (at = SLang_pop_array(&sdat))) goto free_and_return;
   if (at->type != CHAR_TYPE)
     {
	SLang_doerror("Operation requires character array.");
	goto free_and_return;
     }
   n = (unsigned int) strlen((char *)s);
   ndim = at->x * at->y * at->z;
   if (n > ndim)
     {
	SLang_doerror("String too big to init Array.");
	goto free_and_return;
     }
   
   strncpy((char *) at->ptr, (char *) s, (int) ndim);
   
   free_and_return:  if (dat == 1) FREE(s);
}