/* farray.c zilla - c/foreign arrays for elk
 *
    Portions of this file are Copyright (C) 1991 John Lewis,
    adapted from Elk2.0 by Oliver Laumann.

    This file 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.

    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, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

 ****NOTE THE ELK COPYING GC: ALL Object REFERENCES MUST BE GC_LINKED
 ****ACROSS CALLS WHICH MAY ALLOCATE STORAGE.  ALL C VARIABLES WHICH 
 ****ARE ASSIGNED FROM THE ADDRESS OF AN OBJECT MUST BE REASSIGNED
 ****AFTER A GC.
 *
 * todo:        add pointer subtype, list->farray&c
 *              make reading know about array shape
 * note:        considered adding a 'boolean(bit) subtype, decided no:
 *              What would this provide over a 'string array whose
 *              elements are used as bits?  Only storage.
 *              Need some way to set bits and then retrieve the byte
 *              as an integer.  This could be added to a 'boolean subtype,
 *              but it is just as easy to make a (bit-compress <stringarr>)
 *              function.
 * modified
 * 12nov
 * 17oct        elk2
 * 7jul		farray_make_like, farray_copyshape
 * 24jun	bugfix in farray2double
 * 4jun         farray-string conversion
 * 11may        GC CORRECTED; shape reversed so shape[0] is minor.
 * 27apr        farray-of can take bignum as well as fixnum
 * 13apr        -flt, -int conversions now allow string farrays.
 * 12apr        farray clength changed
 * 6apr         farray->shape,ndim
 * 30jan        farray-int,farray-flt
 * 20jan        (farray-of <args>). CHECK- is gc ok on this!?
 *              Also change print syntax to (% ... )
 * 2jan         farray2double
 * 15oct        added magic field to farray.
 * 8oct         decided that 'string' arrays should appear as
 *              byte integers 0..255 rather than as scheme #\chars-
 *              more convenient for parsing byte image files.
 *              Initialize arrays to zero only in farray-make, not
 *              in arrays created by e.g. v-*.
 * 11sep        bug-needed gc protection in several places!
 *              ALSO needed object 'tag' in first element of structure!!
 */


#include <theusual.h>
#include <constants.h>
#include <scheme.h>
#include <assert.h>
#include <zelk.h>

#ifdef CONTAINS
#define FARRAY(o) ((Farray *)POINTER(o))

typedef struct farray {
  Object tag;  /* needed by elk gc system */
  int type;
  int len;
  int shape[FARRAY_MAXDIM];      /* used by vector code, minor dim is [0] */
  int ndim;             /* used by vector code */
/* the magic field allows array code to be written for use inside or
   outside of scheme : given an array, test the previous word for magic.
   If so, call scheme to find the length.  If not, obtain length
   from some global or assumption (vec library will work this way).
 */
    /* magic must be immediately before start of data! */
  int4 magic;
  Zbyte data[1];
} Farray;
#endif

global int T_Farray;

/* Return size in bytes of an farray.  1 is for checkbyte */
#define FARRAYWHOLESIZE(type,len) \
  (sizeof(Farray) + ((type)==T_String ? (len) : (len)*4) + 1)

/* size in bytes of just the data */
#define FARRAYDATASIZE(type,len) \
  ((type)==T_String ? (len) : (len)*4)

/* change VR.c if this changes !! */
#define FARRAY_MAGIC    77

#define Sym_integer     Intern("integer")
#define Sym_real        Intern("real")
#define Sym_string      Intern("string")

static char *ENotFarray = "argument is not farray";

/**************** make &c ****/

Object farray_make(type,len)
  int type;
  int len;
{
  Object F;
  Farray *a;
  char *alias;
  int i;
  Ztrace(("farray_make type=%d len=%d\n",type,len));

  if ((type==T_String) || (type==T_Fixnum) || (type==T_Flonum)) /*nothing*/ ;
  else Panic("farray_make: bad type");

  F = Alloc_Object(FARRAYWHOLESIZE(type,len),T_Farray,0);
  a = FARRAY(F);

  a->tag = Null; /* used by the elk gc system */
  a->type = type;
  a->len = len;
  a->shape[0]=len;
  for( i=1; i < FARRAY_MAXDIM; i++ ) a->shape[i]=0;
  a->ndim=1;
  a->magic = FARRAY_MAGIC;

  /* DO NOT zero the array here.  this routine gets called by both
   * the (farray-make) user-level function, and by the various vector
   * functions e.g. v-*.  For the latter, the array is a return value
   * and will always be written into, so it is inefficient to
   * initialize it.  Initialize in (farray-make) only.
   */

  alias = (char *)a;
  alias[FARRAYWHOLESIZE(type,len)-1] = FARRAY_MAGIC;

  return F;
} /*make*/


/* make an farray with same type and shape as A
   used often by fvector.c */
Object farray_make_like(A)
  Object A;
{
  Farray *a,*f;
  Object F;
  int i;
  int type,len;
  GC_Node;

  a = FARRAY(A);
  type = a->type;
  len = a->len;

  GC_Link(A);
  F = farray_make(type,len);
  GC_Unlink;

  a = FARRAY(A);
  f = FARRAY(F);
  f->ndim = a->ndim;
  for( i=0; i < a->ndim; i++ ) f->shape[i] = a->shape[i];

  return F;
} /*make_like*/


/* copy shape of A to B.  used by vector code */
void farray_copyshape(A,B)
  Object A,B;
{
  register int i;
  register Farray *a,*b;
  Ztrace(("farray_copyshape\n"));

  a = FARRAY(A); b = FARRAY(B);
  if (b->len != a->len) Panic("farray_copyshape");
  b->ndim = a->ndim;
  for( i=0; i < a->ndim; i++ ) b->shape[i] = a->shape[i];

  Ztrace(("--farray_copyshape\n"));
} /*copyshape*/


Object P_farray_make(ptype,len)
  Object ptype,len;
{
  int type;
  Object F;
  Farray *f;
  Error_Tag = "farray";
#ifdef ztrace
  Print_Object(ptype,Standard_Output_Port,0,2,10);
#endif

  if (ptype == Sym_real)                type = T_Flonum;
  else if (ptype == Sym_integer)        type = T_Fixnum;
  else if (ptype == Sym_string)         type = T_String;
  else Primitive_Error("bad type");

  F = farray_make(type,Get_Integer(len));
  f = FARRAY(F);

  /* Initialize arrays created with this (farray-make) primitive */
  Zbzero((char *)f->data,((f->type)==T_String ? (f->len) : ((f->len)*4)));

  return F;
} /*P_make*/


void farray_check(f)
  Object f;
{
  Farray *a;
  char *alias;

  Error_Tag = "farray-check";
  if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);

  a = FARRAY(f);
  alias = (char *)a;

  if ((a->magic != FARRAY_MAGIC) ||
      (alias[FARRAYWHOLESIZE(a->type,a->len)-1] != FARRAY_MAGIC))
    Primitive_Error("array is corrupted?");
} /*_check*/


Object P_farray_check(f)
  Object f;
{
  farray_check(f);
  return Null;  
} /*_check*/


Object P_farray_length(f)
  Object f;
{
  Object rval;
  Error_Tag = "farray-length";

  Check_Type(f,T_Farray);

  rval = Make_Integer(FARRAY(f)->len);

  return rval;
} /*P_length*/


Object P_farrayp(f)
  Object f;
{
  return (TYPE(f)==T_Farray) ? True : False;
} /*P_p*/


Object P_farray_type(f)
  Object f;
{
  Farray *a;

  Error_Tag = "farray-type";
  if (TYPE(f) != T_Farray) Primitive_Error(ENotFarray);

  a = FARRAY(f);
  switch(a->type) {
  case T_Fixnum:        return(Sym_integer); break;
  case T_Flonum:        return(Sym_real); break;
  case T_String:        return(Sym_string); break;
  default:              Panic("farray_type");
  }
  return Null; /*for lint*/
} /*P_type*/


Object P_farray_copy(f)
  Object f;
{
  Farray *a,*b;
  int i;
  Object f2;
  GC_Node;
  Error_Tag = "farray-copy";

  Check_Type(f,T_Farray);

  GC_Link(f);
  a = FARRAY(f);
  f2 = farray_make(a->type,a->len);
  GC_Unlink;

  a = FARRAY(f);
  b = FARRAY(f2);

  Zbcopy(a->data,b->data,FARRAYDATASIZE(a->type,a->len));

  /* shape is mainly used by vector code currently */
  for( i=0; i < FARRAY_MAXDIM; i++ )  b->shape[i] = a->shape[i];
  b->ndim = a->ndim;

  return f2;
} /*copy*/


/* make an farray from the provided arguments, e.g.,
 * (farray-of 2. 3.) => [ 2. 3. ]
 * Decided to NOT make this a special syntax for now-
 * Getting the reader to read the closing ] will require changes...
 * Instead, this is bound to the procedure %, and farrays are
 * also printed as (% .... ), so we have read-print equivalence.
 */

/* WARNING- not sure if this routine is properly GC protected */

Object P_farray_of (argc, argv)
  Object *argv; 
{
  Object F;
  Farray *f;
  int i,type;
  Error_Tag = "farray";

  if (argc < 1) Primitive_Error("no items in array");

  type = TYPE(argv[0]);

  if (type == T_Character)
    F = farray_make(T_String,argc);
  else if (type == T_String)
    F = farray_make(T_String,STRING(argv[0])->size);
  else if (type == T_Bignum)
    F = farray_make(T_Fixnum,argc);
  else
    F = farray_make(type,argc);
  f = FARRAY(F);

  switch(type) {

  case T_Flonum:
  for( i=0; i < argc; i++ ) {
    Check_Type(argv[i],T_Flonum);
    ((float *)f->data)[i] = FLONUM(argv[i])->val;
  }
  break;

  case T_Bignum:
  case T_Fixnum:
  for( i=0; i < argc; i++ ) {
    if ((TYPE(argv[i])!=T_Bignum) && (TYPE(argv[i]!=T_Fixnum)))
      Primitive_Error("mixed types in farray");
    ((int4 *)f->data)[i] = Get_Integer(argv[i]);
  }
  break;

  case T_Character:
  for( i=0; i < argc; i++ ) {
    Check_Type(argv[i],T_Character);
    ((char *)f->data)[i] = CHAR(argv[i]);
  }
  break;

  case T_String:
  for( i=0; i < STRING(argv[0])->size; i++ ) {
    ((char *)f->data)[i] = STRING(argv[0])->data[i];
  }
  break;

  } /*switch(type)*/

  return F;
} /*farray-of */



/**************** set and ref ****/

Object P_farray_set(f,pidx,pobj)
  Object f,pidx,pobj;
{
  int4 idx;
  Farray *a;
  long *L; float *F; unsigned char *C;

  Error_Tag = "farray-set!";
  Check_Type(f,T_Farray);

  a = FARRAY(f);
  C = (unsigned char *)a->data;
  F = (float *)a->data;
  L = (long *)a->data;
  idx = Get_Integer(pidx);
  if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");

  switch(a->type) {
  case T_Fixnum:
    L[idx] = Get_Integer(pobj); 
    break;
  case T_Flonum: 
    if (TYPE(pobj) != T_Flonum)  Primitive_Error("bad type");
    F[idx] = (double)FLONUM(pobj)->val;
    break;
  case T_String:
/*    if (TYPE(pobj) != T_Character)  Primitive_Error("bad type"); 
    C[idx] = (char)CHAR(pobj); */
    C[idx] = (unsigned char)Get_Integer(pobj);
    break;
  default: Panic("farray_set");
  }

  return pobj;
} /*P_set*/



Object P_farray_ref(f,pidx)
  Object f,pidx;
{
  int4 idx;
  Farray *a;
  long *L; float *F; unsigned char *C;
  Object val;
  Error_Tag = "farray-ref";

  Check_Type(f,T_Farray);

  a = FARRAY(f);
  C = (unsigned char *)a->data;
  F = (float *)a->data;
  L = (long *)a->data;

  idx = Get_Integer(pidx);
  if ((idx < 0) || (idx >= a->len)) Primitive_Error("index out of array");

  switch(a->type) {
  case T_Fixnum:
    val = Make_Integer((int4)L[idx]);
    break;
  case T_Flonum:
    val = Make_Reduced_Flonum(F[idx]);
    break;
  case T_String:
/*  val = Make_Char(C[idx]); */
    val = Make_Integer((int4)C[idx]);
    break;
  default: Panic("farray_ref");
  }

  return val;
} /*P_ref*/

/**************** routines called from c programs! ****
 **** when a c program is passed an array but no size,
 **** call these to get the size/type.
 */


/* given the start of the array data, back up to get the array header. 
 * This does not work, probably because of structure alignment. 
 *    ((Farray *)((char *)a - (sizeof(Farray)-sizeof(char))))
 * This is wierd, but it will work regardless of changes in Farray struct:
 */
static Farray _Junk;
#define FARRAYHDR(a) \
    ((Farray *)((char *)a - ((char *)&_Junk.data[0] - (char *)&_Junk.tag)))


int farray_clength(a)
  long *a;
{
  Farray *o;
  
  o = FARRAYHDR(a);
  if (o->magic == FARRAY_MAGIC)
    return(o->len);
  else
    return -1;
}


int farray_ctype(a)
  long *a;
{
  Farray *o;

  o = FARRAYHDR(a);
  if (o->magic == FARRAY_MAGIC)
    return(o->type);
  else
    Panic("farray_ctype");
}

/*%%%%%%%%%%%%%%%% routines used by elk type creation system %%%%*/

static int4 farray_size(f)
  Object f;
{
  Farray *a;
  if (TYPE(f) != T_Farray) Panic("farray_size");
  a = FARRAY(f);
  return( FARRAYWHOLESIZE(a->type,a->len) );
}


bool farray_equal(a,b)
  Object a,b;
{
  return 0;
}


void farray_print(f,port,raw,pdepth,plen)
  Object f;
  Object port;
  bool raw;     /* does what? */
  int pdepth, plen;
{
  Farray *a;
  int type,len;
  int4 *L;
  float *F;
  char *format;

  if (TYPE(f) != T_Farray) Panic("farray_print");
  a = FARRAY(f);
  type = a->type;
  len = a->len;
  
  switch (type) {
  case T_Fixnum:	format = "%d ";   break;
  case T_Flonum:	format = "%.3f ";   break;
  case T_String:        break;
  default:              Panic ("farray:print");
  } /*switch*/

  F = (float *)a->data;
  /* since floats are converted to doubles whenever passed,
   * floats,int4s cannot both be handled with a long *.
   */
  L = (int4 *)a->data;

  if (type == T_String) {
    register int i;
    register char *c,*d;

    c = (char *)a->data;
    d = Ctmpbuf;
    if (len >= Ctmpbuflen) Panic("farray_print: string too long");

    for( i=0; i < len; i++ ) {
      /* do not print null characters */
      if (*c != (char)0)  *d++ = *c;
      c++;
    }
    *d = (char)0;

    Printf(port,"[%s]",Ctmpbuf);
  } /*string*/

  else if (a->ndim == 2) {	/* print as matrix */
    register int i,j;
    for (i = 0; i < a->shape[1]; i++) {
      Printf(port, "[ ");
      for (j = 0; j < a->shape[0]; j++) {
        if (type == T_Flonum)
          (void)sprintf (Ctmpbuf, format, *F++);
        else
          (void)sprintf (Ctmpbuf, format, *L++);
        Printf(port, Ctmpbuf);
      }
      Printf(port, "]\n");
    }
  } /*matrix*/


  else {
    register int i;
    Printf(port, "(%% ");

    for (i = 0; i < len; i++) {

      if (i > plen) {                   /* too big, stop printing */
        Printf(port,"...");
        break;
      }
      if (type == T_Flonum)
        (void)sprintf (Ctmpbuf, format, *F++);
      else
        (void)sprintf (Ctmpbuf, format, *L++);
      Printf(port, Ctmpbuf);
    }
    Printf(port, ")");
  } /*print as array */

} /*_print*/


/**************** type conversion ****************/

/* convert float or string array to int */
#define FARRAY_INT    P_farray_int, "farray-int", 1,1,EVAL,
Object 
P_farray_int(A)
  Object A;
{
  register int i,len;
  Object B;
  Farray *a;
  register int4 *ib;
  GC_Node;
  Error_Tag = "farray-int";

  Check_Type(A,T_Farray);

  a = FARRAY(A);
  /* already integer. return a copy to stay functional- caller may
     be expecting that result is a distinct array */
  if (a->type == T_Fixnum) return P_farray_copy(A);  
  len = a->len;

  GC_Link(A);
  B = farray_make(T_Fixnum,len);
  GC_Unlink;
  a = FARRAY(A);        /* reassign after gc */
  ib = (int4 *)FARRAY(B)->data;

  if (a->type == T_Flonum) {
    register float *ia = (float *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
  }
  else if (a->type == T_String) {
    register unsigned char *ia = (unsigned char *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (int4)*ia++;
  }
  else Panic("farray-int");

  return B;
} /*int*/



/* convert float or int array to string(byte) */
#define FARRAY_STRING    P_farray_string, "farray-string", 1,1,EVAL,
Object 
P_farray_string(A)
  Object A;
{
  register int i,len;
  Object B;
  Farray *a;
  register unsigned char *ib;
  GC_Node;
  Error_Tag = "farray-string";

  Check_Type(A,T_Farray);

  a = FARRAY(A);
  /* already string. return a copy to stay functional- caller may
     be expecting that result is a distinct array */
  if (a->type == T_String) return P_farray_copy(A);  
  len = a->len;

  GC_Link(A);
  B = farray_make(T_String,len);
  GC_Unlink;
  a = FARRAY(A);        /* reassign after gc */
  ib = (unsigned char *)FARRAY(B)->data;

  if (a->type == T_Flonum) {
    register float *ia = (float *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (unsigned char)(int)*ia++;
  }
  else if (a->type == T_Fixnum) {
    register int *ia = (int *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (unsigned char)*ia++;
  }
  else Panic("farray-string");

  return B;
} /*string*/


/* convert int or string farray to float */
#define FARRAY_FLT    P_farray_flt, "farray-flt", 1,1,EVAL,
Object P_farray_flt(A)
  Object A;
{
  register int i,len;
  Object B;
  Farray *a;
  register float *ib;
  GC_Node;
  Error_Tag = "farray-flt";

  Check_Type(A,T_Farray);

  a = FARRAY(A);
  /* already float. return a copy to stay functional- caller may
     be expecting that result is a distinct array */
  if (a->type == T_Flonum) return P_farray_copy(A);  /* already float */
  len = a->len;

  GC_Link(A);
  B = farray_make(T_Flonum,len);
  GC_Unlink;
  a = FARRAY(A); /* reassign after gc! */
  ib = (float *)FARRAY(B)->data;

  if (a->type == T_Fixnum) {
    register int4 *ia = (int4 *)a->data;
    for( i=0; i < len; i++ ) *ib++ = (float)*ia++;
  }
  else if (a->type == T_String) {
    register unsigned char *ia = (unsigned char *)a->data;
    register int j;
    /* some c compiler could not cast from char to float directly */
    for( i=0; i < len; i++ ) {
      j = *ia++;
      *ib++ = (float)j;
    }
  }
  else Panic("farray-flt");

  return B;
} /*flt*/


/* convert a float farray to the same, of 2x length, containing doubles */
Object P_farray2double(F)
  Object F;
{
  Object D;
  Farray *f,*d;
  float *fp; double *dp;
  int i,len;
  GC_Node;
  Error_Tag = "farray2double";

  if (FARRAY(F)->type != T_Flonum)
    Primitive_Error("array is not float");

  GC_Link(F);
  D = farray_make(T_Flonum,FARRAY(F)->len*2);
  GC_Unlink;

  f = FARRAY(F);
  d = FARRAY(D);
  fp = (float *)f->data;
  dp = (double *)d->data;
  len = f->len;

  for( i=0; i < len; i++ ) {
    *dp++ = (double)*fp++;
  }
  
  return D;
} /*P_double*/


/**************** link ****************/

static struct primdef Prims[] = {
  FARRAY_INT
  FARRAY_STRING
  FARRAY_FLT

  (Object (*)())0, (char *)0, 0,0,EVAL
};


void Init_farray()
{
  T_Farray = Define_Type(0,"farray",farray_size,0,
                         farray_equal,farray_equal,
                         farray_print, NOFUNC);
  /* printf("[Init_farray type %d]\n",T_Farray); */

  Define_Primitive(P_farray_make,"farray",2,2,EVAL);
  Define_Primitive(P_farrayp,"farray?",1,1,EVAL);
  Define_Primitive(P_farray_check,"farray-check",1,1,EVAL);

  Define_Primitive(P_farray_length,"farray-length",1,1,EVAL);
  Define_Primitive(P_farray_type,"farray-type",1,1,EVAL);
  Define_Primitive(P_farray_copy,"farray-copy",1,1,EVAL);

  Define_Primitive(P_farray_of,"farray-of",0,MANY,VARARGS);
  Define_Primitive(P_farray_of,"%",0,MANY,VARARGS); /*synonym*/

  Define_Primitive(P_farray_set,"farray-set!",3,3,EVAL);
  Define_Primitive(P_farray_ref,"farray-ref",2,2,EVAL);

  Define_Primitive(P_farray2double,"farray2double",1,1,EVAL);

  ZLprimdeftab(Prims);

  P_Provide(Intern("farray.o"));
} /*init*/
