#include "apricot.h"
#include "guts.h"
#ifdef __cplusplus
extern "C" {
#endif
SV *
prima_array_new( size_t size)
{
SV * sv;
if ( size == 0 ) return newSVpv("", 0);
sv = newSV( size );
SvPOK_only(sv);
SvCUR_set(sv, size );
return sv;
}
void
prima_array_truncate( SV * array, size_t length )
{
SvCUR_set(array, length );
SvPOK_only(array);
}
SV *
prima_array_tie( SV * array, size_t size_of_entry, char * letter)
{
SV * tie;
AV * av1, * av2;
av1 = newAV();
av_push(av1, array);
av_push(av1, newSViv(size_of_entry));
av_push(av1, newSVpv(letter, 1));
tie = newRV_noinc((SV*) av1);
sv_bless(tie, gv_stashpv("Prima::array", GV_ADD));
av2 = newAV();
hv_magic(av2, (GV*)tie, PERL_MAGIC_tied);
SvREFCNT(tie)--;
return newRV_noinc((SV*) av2);
}
Bool
prima_array_parse( SV * sv, void ** ref, size_t * length, char ** letter)
{
SV * tied;
const MAGIC * mg;
SV ** ssv;
AV * av;
int cur;
if ( !sv || !SvOK(sv) || !SvROK(sv) || SvTYPE( SvRV( sv)) != SVt_PVAV)
return false;
av = (AV *) SvRV(sv);
if (( mg = SvTIED_mg(( SV*) av, PERL_MAGIC_tied )) == NULL)
return false;
tied = SvTIED_obj(( SV* ) av, mg );
if ( !tied || !SvROK(tied) || !sv_isa( tied, "Prima::array" ))
return false;
av = (AV*) SvRV(tied);
if ( SvTYPE((SV*) av) != SVt_PVAV)
croak("panic: corrupted array");
ssv = av_fetch( av, 0, 0);
if ( ssv == NULL ) croak("panic: corrupted array");
if( ref) *ref = SvPVX(*ssv);
cur = SvCUR(*ssv);
ssv = av_fetch( av, 1, 0);
if ( ssv == NULL || SvIV(*ssv) <= 0 ) croak("panic: corrupted array");
if( length) *length = cur / SvIV(*ssv);
ssv = av_fetch( av, 2, 0);
if ( ssv == NULL ) croak("panic: corrupted array");
if( letter) *letter = SvPV(*ssv, PL_na);
return true;
}
Bool
prima_read_point( SV *rv_av, int * pt, int number, char * error)
{
SV ** holder;
int i;
AV *av;
Bool result = true;
if ( !rv_av || !SvROK( rv_av) || ( SvTYPE( SvRV( rv_av)) != SVt_PVAV)) {
result = false;
if ( error) croak( "%s", error);
} else {
av = (AV*)SvRV(rv_av);
for ( i = 0; i < number; i++) {
holder = av_fetch( av, i, 0);
if ( holder)
pt[i] = SvIV( *holder);
else {
pt[i] = 0;
result = false;
if ( error) croak( "%s", error);
}
}
}
return result;
}
#define xmovi(src_t,dst_t) { \
register int i; \
register src_t* s = (src_t*)src; \
register dst_t* d = (dst_t*)dst; \
for ( i = 0; i < n_points; i++) \
*(d++) = *(s++); \
} \
break \
#define xmovd(src_t,dst_t) { \
register int i; \
register src_t* s = (src_t*)src; \
register dst_t* d = (dst_t*)dst; \
for ( i = 0; i < n_points; i++) { \
register src_t x = *(s++); \
*(d++) = floor(x + .5); \
}} \
break \
static int
typesize(char type)
{
switch(type) {
case 'S': return sizeof(uint16_t);
case 's': return sizeof(int16_t);
case 'i': return sizeof(int);
case 'd': return sizeof(double);
default: croak("Bad type %c", type);
}
}
void *
prima_array_convert( int n_points, void * src, char src_type, void * _dst, char dst_type )
{
int sz, * dst;
(void) typesize(src_type); /* assert */
sz = typesize(dst_type);
if ( _dst != NULL )
dst = _dst;
else if ( !( dst = malloc( n_points * sz))) {
warn("Not enough memory");
return NULL;
}
if ( src_type == dst_type ) {
memcpy( dst, src, sz * n_points);
}
else switch ( src_type ) {
case 'i':
switch (dst_type) {
case 'd': xmovi(int,double);
case 's': xmovi(int,int16_t);
case 'S': xmovi(int,uint16_t);
}
break;
case 'S':
switch (dst_type) {
case 'd': xmovi(uint16_t,double);
case 'i': xmovi(uint16_t,int);
case 's': xmovi(uint16_t,int16_t);
}
break;
case 's':
switch (dst_type) {
case 'd': xmovi(int16_t,double);
case 'i': xmovi(int16_t,int);
case 'S': xmovi(int16_t,uint16_t);
}
break;
case 'd':
switch (dst_type) {
case 'i': xmovd(double,int);
case 's': xmovd(double,int16_t);
case 'S': xmovd(double,uint16_t);
}
break;
}
return dst;
}
void *
prima_read_array( SV * points, char * procName, char type, int div, int min, int max, int * n_points, Bool * do_free)
{
AV * av;
int i, count, psize;
void * p;
if ( do_free )
*do_free = false;
psize = typesize(type);
if ( !SvROK( points) || ( SvTYPE( SvRV( points)) != SVt_PVAV)) {
warn("Invalid array reference passed to %s", procName);
return NULL;
}
av = ( AV *) SvRV( points);
count = av_len( av) + 1;
if ( min == max && count != min * div ) {
warn("%s: array must contain %d elements", procName, min * div);
return NULL;
}
if ( count < min * div ) {
warn("%s: array must contain at least %d elements", procName, min * div);
return NULL;
}
if ( max >= 0 && count > max * div ) {
warn("%s: array must contain maximum %d elements", procName, max * div);
return NULL;
}
if ( count % div != 0 ) {
warn("%s: number of elements in an array must be a multiple of %d", procName, div);
return NULL;
}
if ( n_points)
*n_points = count / div;
if ( count == 0)
return NULL;
{
void * ref;
char * pack;
if ( prima_array_parse( points, &ref, NULL, &pack )) {
if (*pack == type && do_free) {
*do_free = false;
return ref;
}
if (do_free) *do_free = true;
return prima_array_convert( count, ref, *pack, NULL, type);
}
}
if (!( p = malloc( psize * count))) {
warn("not enough memory");
return NULL;
}
for ( i = 0; i < count; i++)
{
SV** psv = av_fetch( av, i, 0);
if ( psv == NULL) {
free( p);
warn("Array panic on item %d on %s", i, procName);
return NULL;
}
switch (type) {
case 'i':
*(((int*)p) + i) = floor( SvNV( *psv) + .5 );
break;
case 'd':
*(((double*)p) + i) = SvNV( *psv);
break;
case 's':
*(((int16_t*)p) + i) = floor( SvIV( *psv) + .5 );
break;
case 'S':
*(((uint16_t*)p) + i) = SvUV( *psv);
break;
}
}
if ( do_free )
*do_free = true;
return p;
}
XS(Prima_array_deduplicate_FROMPERL)
{
dXSARGS;
void *ref, *cmp;
char * letter;
size_t i, new_size, length, orig_length, item_size, cmp_length, min_length;
if ( items != 3)
croak ("Invalid usage of ::deduplicate");
if ( !prima_array_parse( ST(0), &ref, &length, &letter)) {
warn("invalid array passed to %s", "Prima::array::deduplicate");
goto EXIT;
}
orig_length = length;
cmp_length = SvIV(ST(1));
if ( cmp_length < 1 )
goto EXIT;
if ( length < 2 * cmp_length )
goto EXIT;
min_length = SvIV(ST(2));
if ( min_length >= length )
goto EXIT;
min_length += cmp_length;
switch (*letter) {
case 'i':
item_size = sizeof(int);
break;
case 'd':
item_size = sizeof(double);
break;
case 's':
item_size = sizeof(int16_t);
break;
case 'S':
item_size = sizeof(uint16_t);
break;
default:
warn("invalid array passed to %s", "Prima::array::deduplicate");
goto EXIT;
}
for (
i = cmp_length, cmp = ref, new_size = cmp_length;
i <= length - cmp_length;
i += cmp_length )
{
void *new_ref = ((Byte*)ref) + i * item_size;
if ( memcmp( cmp, new_ref, cmp_length * item_size ) != 0 ) {
new_size += cmp_length;
cmp = new_ref;
} else if ( length >= min_length ) {
memmove( cmp, new_ref, (length - i) * item_size);
length -= cmp_length;
i -= cmp_length;
} else {
new_size = min_length - cmp_length;
break;
}
}
if ( length != orig_length ) {
SV * tied;
const MAGIC * mg;
SV ** ssv;
AV * av;
av = (AV *) SvRV(ST(0));
mg = SvTIED_mg(( SV*) av, PERL_MAGIC_tied );
tied = SvTIED_obj(( SV* ) av, mg );
av = (AV*) SvRV(tied);
ssv = av_fetch( av, 0, 0);
prima_array_truncate( *ssv, new_size * item_size);
}
EXIT:
XSRETURN_EMPTY;
}
#ifdef __cplusplus
}
#endif