#!/usr/local/bin/perl

# Perl utility to generate pdlconv.c automatically
# for many different datatypes

require 'Dev.pm'; PDL::Core::Dev->import;

# $date = `date`; chop $date;

##### HEADER ######

print <<EOD;


/***************************************************************

   pdlconv.c

****************************************************************/

#define PDL_CORE      /* For certain ifdefs */
#include "pdl.h"      /* Data structure declarations */
#include "pdlcore.h"  /* Core declarations */

EOD

for([readdata_vaffine, "*ap = *pp"],
    [writebackdata_vaffine, "*pp = *ap"]) {

print <<EOD;

void pdl_$_->[0](pdl *a) {
	PDL_Long *inds ;
	int i,j;
	int intype = a->datatype;
	if(!PDL_VAFFOK(a)) {
		die("Pdl_make_phys_from_vaffine without vaffine");
	}
	inds = malloc(sizeof(PDL_Long) * a->ndims);
	for(i=0; i<a->ndims; i++) {
		inds[i] = 0;
	}
	PDL_ENSURE_ALLOCATED(a);
	if(0) {

EOD

##### Generate code for each data type #####

for $in ( keys %PDL_DATATYPES ) {

    $intype = $PDL_DATATYPES{$in};
    print <<EOD;

    } else if (intype == $in)  {
       { $intype *ap = ($intype *) a->data;
       	 $intype *pp = ($intype *) a->vafftrans->from->data;
	 pp += a->vafftrans->offs;
       	 for(i=0; i<a->nvals; i++) {
	 	$_->[1];
		for(j=0; j<a->ndims; j++) {
			pp += a->vafftrans->incs[j];
			if((j < a->ndims - 1 &&
			   (i+1) % a->dimincs[j+1]) ||
			   j == a->ndims - 1)
			      break;
			pp -= a->vafftrans->incs[j] *
				a->dims[j];
		}
		ap ++;
	 }
       }

EOD

} #### End of perl loop ####

print <<'EOD';

	}

	free(inds);
}

EOD

} # End of outer perl loop

print <<'EOD';



/* Various conversion utilities for pdl data types */


/* Swap pdls */

void pdl_swap(pdl** a, pdl** b) {
   pdl* tmp;
   tmp = *b; *b=*a; *a=tmp;
}

/* Change the type of all the data in a pdl struct, either changing the
   original perl structure or making a temporary copy  */

void pdl_converttype( pdl** aa, int targtype, Logical changePerl ) {
    pdl* a=*aa;  /* Point to cache */
    int intype;
    void* b;     /* Scratch data ptr */
    SV*   bar;
    HV*   hash;
    int   nbytes;
    int   diffsize;
#if (PERL_VERSION >= 5) && (PERL_SUBVERSION >= 57)
    dXSARGS;
#endif


    PDLDEBUG_f(printf("pdl_converttype %d, %d, %d, %d\n", a, a->datatype,
    	targtype, changePerl);)

    intype = a->datatype;

    if (intype == targtype)
       return;

    diffsize = pdl_howbig(targtype) != pdl_howbig(a->datatype);

    nbytes = a->nvals * pdl_howbig(targtype); /* Size of converted data */

    if (changePerl) {   /* Grow data */

      if(a->state & PDL_DONTTOUCHDATA) {
	croak("Trying to convert of magical (mmaped?) pdl");
      }

      if (diffsize) {
         b = a->data;                      /* pointer to old data */
         a->data     = pdl_malloc(nbytes); /* Space for changed data */
      }
      else{
         b = a->data; /* In place */
      }

    }else{

       b = a->data;          /* Ptr to old data */
       a = pdl_tmp();        /* Brand new scratch pdl */
/*       pdl_clone(*aa,  a);  */ /* Copy old pdl entries */
       a->data     = pdl_malloc(nbytes); /* Space for changed data */
       *aa = a;              /* Change passed value to new address */

       die("Sorry, temporary type casting is not allowed now");
    }

    /* Do the conversion */

    if (0) {
        /* Nothing */

EOD

##### Generate code for each pair of data types #####

for $in ( keys %PDL_DATATYPES ) { for $targ ( keys %PDL_DATATYPES ) {

    next if $in eq $targ; # Skip duplicates

    $intype = $PDL_DATATYPES{$in}; $targtype = $PDL_DATATYPES{$targ};
    print <<EOD;

    } else if (intype == $in && targtype == $targ)  {
       { $intype *bb = ($intype *) b;
         $targtype *aa = ($targtype *) a->data;
         int i = a->nvals;
         aa += i-1; bb += i-1;
         while (i--)
                *aa-- = ($targtype) *bb--;
       }

EOD

}} #### End of perl loop ####

#### Trailer ####

print <<'EOD';

    } else {
      croak("Don't know how to convert datatype %d to %d", intype, targtype);
    }

    if (changePerl) {   /* Tidy up */

      /* Store new data */

      if (diffsize) {
        STRLEN n_a;
         bar = a->datasv;
         sv_setpvn( bar, (char*) a->data, nbytes );
         a->data = (void*) SvPV(bar, n_a);
      }

    }

    a->datatype = targtype;
}


/* Ensure 'a' and 'b' are the same data types of high enough precision,
   using a reasonable set of rules.
*/

void pdl_coercetypes( pdl** aa, pdl** bb, Logical changePerl ) {

     pdl* a = *aa;  /* Double ptr passed as value of ptr may be changed to */
     pdl* b = *bb;  /* point at a temporary copy of the cached pdl */
     Logical oneisscalar;
     pdl *scalar,*vector;
     int targtype;

     if (a->datatype == b->datatype) /* Nothing to be done */
        return;

     /* Detect the vector & scalar case */

     oneisscalar = (a->nvals==1 || b->nvals==1) && !(a->nvals==1 && b->nvals==1);

     /* Rules for deciding what the target data type is */

     if (oneisscalar) {  /* Vector x Scalar case */

        scalar  = a; vector = b;
        if (b->nvals==1) {
           scalar = b;
           vector = a;
        }

        if (vector->datatype >= scalar->datatype) /* Vector more complex - easy */

           targtype = vector->datatype;

        else { /* Scalar more complex than vector- special rules to avoid
                  overzealous promotion of vector  */

           if (vector->datatype == PDL_F)  /* FxD is OK as F */
              targtype = vector->datatype;

           else if (vector->datatype <= PDL_L && scalar->datatype <= PDL_L)
              targtype = vector->datatype; /* two ints is OK as input int */

           else if (vector->datatype <= PDL_F && scalar->datatype==PDL_D)
              targtype = PDL_F; /* Only promote FOOxD as far as F */

           else
              targtype = scalar->datatype;

        }


     }else{ /* Vector x Vector - easy */

        targtype = a->datatype;
        if (b->datatype > a->datatype)
           targtype = b->datatype;

     }

     /* Do the conversion */

     pdl_converttype(aa, targtype, changePerl);
     pdl_converttype(bb, targtype, changePerl);
}

/* Given PDL return an allocated **ptr to 2D data thus allowing a[j][i] syntax */

void ** pdl_twod( pdl* x ) {

   int i,nx,ny,size;
   long *p;
   char *xx;

   if (x->ndims>2)
      croak("Data must be 1 or 2-dimensional for this routine");

   xx = (char*) x->data;

   nx = *(x->dims); ny = x->ndims==2 ? *(x->dims+1) : 1;

   size=pdl_howbig(x->datatype);

   p = (long*) pdl_malloc( ny*sizeof(long) ); /* 1D array of ptrs p[i] */
   for (i=0;i<ny;i++)
       p[i] = (long) &xx[i*nx*size];

   return (void**) p;
}


EOD