/* Array manipulation routines for S-Lang */
/* 

   Copyright (C) 1993 John E. Davis (davis@amy.tch.harvard.edu)
   All rights reserved.

   This file is part of S-Lang.

   S-Lang is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY.  No author or distributor accepts responsibility to
   anyone for the consequences of using it or for whether it serves any
   particular purpose or works at all, unless he says so in writing.
   Refer to the S-Lang General Public License for full details.

   Everyone is granted permission to copy, modify and redistribute
   S-Lang, but only under the conditions described in the S-Lang General
   Public License.  A copy of this license is supposed to have been given
   to you along with S-Lang so you can know your rights and
   responsibilities.  It should be in a file named COPYING.  Among other
   things, the copyright notice and this notice must be preserved on all
   copies.

*/

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


/* Array Stuff */

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

   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 (NULL);
     }

   n = d0;
   n = n * d1;
   n = n * d2;

   if (NULL == (at = (Array_Type *) MALLOC(sizeof(Array_Type))))
     {
	return NULL;
     }

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

void SLcreate_array(void)
{
   int dim, d0, d1, d2, t;
   long ptr;
   SLang_Object_Type obj;
   Array_Type *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;

   ptr = (long) NULL;
   at = lang_create_array((long *) &ptr, dim, d0, d1, d2, t);

   if (at == NULL)
     {
	SLang_doerror("Unable to create array.");
	return;
     }

   obj.type = LANG_DATA | (ARRAY_TYPE << 8);
   obj.value = (long) at;
   SLang_push(&obj);
}

void SLfree_array(void)
{
   SLang_Object_Type obj;
   Array_Type *at;

   if (SLang_pop(&obj)) return;

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

   /* Before freeing it, lets muck with the space */
   at = (Array_Type *) obj.value;
   at->dim = 0;
   at->type = 0;
   at->x = 0;
   FREE( at->ptr );
   FREE(at);
}

/* returns array.  If *stype is non-zero, array is really a string and should
   be freed if *stype = 1 */
Array_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;
     }
   else *sflag = 0;
   return (Array_Type *) obj.value;
}
static char *Bound_err = "Array dims out of bounds";
static unsigned int compute_array_offset(Array_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(-1);
	  }
	elem[d] = el;
     }

   off = 0;
   d = 0;
#if 0
   while (d < dim)
     {
	off += off * x[d] + elem[d];
	d++;
     }
#endif
   off = (elem[0] * x[1] + elem[1]) * x[2] + elem[2];
   
   return(off);
}


static void str_get_elem(char *s, int dat)
{
   int n, nmax, ch;
   if (SLang_pop_integer(&n)) goto done;
   nmax = strlen(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()
{
   Array_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;

   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) 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(Array_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: SLang_push_string((char *) *(((char **)p) + off)); 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()
{
   Array_Type *at;
   unsigned int off;
   int sdat = 1;

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

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

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

   /* This is not really true since if addr is not (long) NULL, the space is
      set aside by the compiler.  Here we assume it is dynamic.  The upshot
      is that the user might pass it to free_array which will cause problems. */

   addr = (long *) lang_create_array((long *) &a, dim, d0, d1, d2, t);
   type = LANG_IVARIABLE | (ARRAY_TYPE << 8);
   SLadd_name(name, (long) addr, type);
   return((long *) a);
}


void SLarray_sort(char *f)
{
   Array_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;
   long ptr;
   
   
   if ((NULL == (entry = SLang_locate_name(f))) || (*entry->name == 0))
     {
	SLang_doerror("Sort function undefined.");
	return;
     }
   
   type = entry->obj.type & 0xFF;
   if (type != LANG_FUNCTION)
     {
	SLang_doerror("Invalid sort function.");
	return;
     }
   
   sdat = 0;
   if (NULL == (at_str = SLang_pop_array(&sdat))) return;
   
   n = at_str->x;
   
   if (at_str->dim != 1)
     {
	SLang_doerror("Sort requires 1 dim arrays.");
	return;
     }
   
   ptr = (long) NULL;
   if (NULL == (at_int = lang_create_array(&ptr, 1, n, 1, 1, 'i')))
     {
	SLang_doerror("Error Creating index array.");
	return;
     }
   
   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.value = (long) at_int;
		  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(at_int->ptr);
   FREE(at_int);
}


void SLinit_char_array()
{
   int dat, sdat;
   Array_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) FREE(s);
}

   
