/* printing arrays [code adapted from jdl functions by John Davis] */
static int
pop_matrix (SLang_Array_Type **at_ptr, unsigned int *nr, unsigned int *nc) /*{{{*/
{
SLang_Array_Type *at;
if (-1 == SLang_pop_array (&at, 0))
return -1;
switch (at->num_dims)
{
case 0:
*nr = *nc = 0;
break;
case 1:
*nr = (unsigned int)at->dims[0];
*nc = 1;
break;
case 2:
*nr = (unsigned int)at->dims[0];
*nc = (unsigned int)at->dims[1];
break;
default:
SLang_verror (SL_TYPE_MISMATCH, "operation limited to 2-d arrays");
SLang_free_array (at);
*at_ptr = NULL;
return -1;
}
*at_ptr = at;
return 0;
}
/* Here nx corresponds to the fastest varying dimension and ny the slowest */
static SLang_Array_Type *pop_2d_float_array (float **data, unsigned int *ny, unsigned int *nx)
{
SLang_Array_Type *at;
*data = NULL;
*nx = *ny = 0;
if (-1 == SLclass_typecast (SLANG_FLOAT_TYPE, 1, 1))
return NULL;
if (-1 == SLang_pop_array (&at, 1))
return NULL;
if (at->num_dims > 2)
{
SLang_verror (SL_TYPE_MISMATCH,
"A 2d numeric array is expected");
SLang_free_array (at);
return NULL;
}
*data = (float *)at->data;
*ny = at->dims[0];
if (at->num_dims == 1)
*nx = 1;
else
*nx = at->dims[1];
return at;
}
/* These are some utility routines that convert double arrays to float */
static int pop_float_vector (SLang_Array_Type **at)
{
*at = NULL;
if (-1 == SLclass_typecast (SLANG_FLOAT_TYPE, 1, 1))
return -1;
if (-1 == SLang_pop_array (at, 1))
return -1;
return 0;
}
static int pop_writable_array (SLang_Array_Type **atp)
{
SLang_Array_Type *at;
if (-1 == SLang_pop_array (&at, 0))
return -1;
if (at->flags & SLARR_DATA_VALUE_IS_READ_ONLY)
{
SLang_set_error (SL_ReadOnly_Error);
SLang_free_array (at);
return -1;
}
*atp = at;
return 0;
}
static void write_image (int flip)
{
char *file;
SLang_Array_Type *at;
int with_alpha = 0;
int has_with_alpha = 0;
int color_type;
void (*write_fun) (png_struct *, png_byte *, SLindex_Type, png_byte *);
if (SLang_Num_Function_Args == 3)
{
if (-1 == SLang_pop_int (&with_alpha))
return;
has_with_alpha = 1;
}
if (-1 == SLang_pop_array (&at, 0))
return;
if (at->num_dims != 2)
{
SLang_verror (SL_InvalidParm_Error, "Expecting a 2-d array");
SLang_free_array (at);
return;
}
switch (SLang_get_int_size (at->data_type))
{
case -8:
case 8:
if (with_alpha)
{
write_fun = write_gray_to_gray_alpha;
color_type = PNG_COLOR_TYPE_GRAY_ALPHA;
}
else
{
write_fun = write_gray_to_gray;
color_type = PNG_COLOR_TYPE_GRAY;
}
break;
case -16:
case 16:
if (has_with_alpha && (with_alpha == 0))
{
write_fun = write_gray_alpha_to_gray;
color_type = PNG_COLOR_TYPE_GRAY;
}
else
{
write_fun = write_gray_alpha_to_gray_alpha;
color_type = PNG_COLOR_TYPE_GRAY_ALPHA;
}
break;
case -32:
case 32:
if (with_alpha)
{
write_fun = write_rgb_alpha_to_rgb_alpha;
color_type = PNG_COLOR_TYPE_RGBA;
}
else
{
write_fun = write_rgb_to_rgb;
color_type = PNG_COLOR_TYPE_RGB;
}
break;
default:
SLang_verror (SL_InvalidParm_Error, "Expecting an 8, 16, or 32 bit integer array");
SLang_free_array (at);
return;
}
if (-1 == SLang_pop_slstring (&file))
{
SLang_free_array (at);
return;
}
(void) write_image_internal (file, at, color_type, write_fun, flip);
SLang_free_slstring (file);
SLang_free_array (at);
}
static int map_or_contract_array (SLCONST SLarray_Map_Type *c, int use_contraction,
int dim_specified, int *use_this_dim,
VOID_STAR clientdata)
{
int k, use_all_dims;
SLang_Array_Type *at, *new_at;
SLindex_Type *old_dims;
SLindex_Type old_dims_buf[SLARRAY_MAX_DIMS];
SLindex_Type sub_dims[SLARRAY_MAX_DIMS];
SLindex_Type tmp_dims[SLARRAY_MAX_DIMS];
unsigned int i, j, old_num_dims, sub_num_dims;
SLtype new_data_type, old_data_type;
char *old_data, *new_data;
SLindex_Type w[SLARRAY_MAX_DIMS], wk;
size_t old_sizeof_type, new_sizeof_type;
SLuindex_Type dims_k;
int from_type;
SLCONST SLarray_Map_Type *csave;
SLarray_Map_Fun_Type *fmap;
SLarray_Contract_Fun_Type *fcon;
use_all_dims = 1;
k = 0;
if (dim_specified)
{
if (use_this_dim != NULL)
{
k = *use_this_dim;
use_all_dims = 0;
}
}
else if (SLang_Num_Function_Args == 2)
{
if (-1 == SLang_pop_integer (&k))
return -1;
use_all_dims = 0;
}
if (-1 == (from_type = SLang_peek_at_stack1 ()))
return -1;
csave = c;
while (c->f != NULL)
{
if (c->from_type == (SLtype) from_type)
break;
c++;
}
/* Look for a more generic version */
if (c->f != NULL)
{
if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
else
{
/* Look for a wildcard match */
c = csave;
while (c->f != NULL)
{
if (c->from_type == SLANG_VOID_TYPE)
break;
c++;
}
if (c->f == NULL)
{
_pSLang_verror (SL_TYPE_MISMATCH, "%s is not supported by this function", SLclass_get_datatype_name (from_type));
return -1;
}
/* Found it. So, typecast it to appropriate type */
if (c->typecast_to_type == SLANG_VOID_TYPE)
{
if (-1 == SLang_pop_array (&at, 1))
return -1;
}
else if (-1 == SLang_pop_array_of_type (&at, c->typecast_to_type))
return -1;
}
old_data_type = at->data_type;
if (SLANG_VOID_TYPE == (new_data_type = c->result_type))
new_data_type = old_data_type;
old_num_dims = at->num_dims;
if (use_all_dims == 0)
{
if (k < 0)
k += old_num_dims;
if ((k < 0) || (k >= (int)old_num_dims))
{
_pSLang_verror (SL_INVALID_PARM, "Dimension %d is invalid for a %d-d array",
k, old_num_dims);
SLang_free_array (at);
return -1;
}
old_dims = at->dims;
}
else
{
old_dims = old_dims_buf;
old_dims[0] = (SLindex_Type)at->num_elements;
old_num_dims = 1;
}
fcon = (SLarray_Contract_Fun_Type *) c->f;
fmap = c->f;
if (use_contraction
&& (use_all_dims || (old_num_dims == 1)))
{
SLang_Class_Type *cl;
VOID_STAR buf;
int status = 0;
cl = _pSLclass_get_class (new_data_type);
buf = cl->cl_transfer_buf;
if (at->num_elements == 0)
{
/* If there are no elements, the fcon may or may not
* compute a value. So, clear the buffer
*/
memset ((char *)buf, 0, cl->cl_sizeof_type);
}
if ((-1 == (*fcon) (at->data, 1, at->num_elements, buf))
|| (-1 == SLang_push_value (new_data_type, buf)))
status = -1;
SLang_free_array (at);
return status;
}
/* The offset for the index i_0,i_1,...i_{N-1} is
* i_0*W_0 + i_1*W_1 + ... i_{N-1}*W{N-1}
* where W_j = d_{j+1}d_{j+2}...d_{N-1}
* and d_k is the number of elements of the kth dimension.
*
* For a specified value of k, we
* So, summing over all elements in the kth dimension of the array
* means using the set of offsets given by
*
* i_k*W_k + sum(j!=k) i_j*W_j.
*
* So, we want to loop of all dimensions except for the kth using an
* offset given by sum(j!=k)i_jW_j, and an increment W_k between elements.
*/
wk = 1;
i = old_num_dims;
while (i != 0)
{
i--;
w[i] = wk;
wk *= old_dims[i];
}
wk = w[k];
/* Now set up the sub array */
j = 0;
for (i = 0; i < old_num_dims; i++)
{
if (i == (unsigned int) k)
continue;
sub_dims[j] = old_dims[i];
w[j] = w[i];
tmp_dims[j] = 0;
j++;
}
sub_num_dims = old_num_dims - 1;
if (use_contraction)
new_at = SLang_create_array1 (new_data_type, 0, NULL, sub_dims, sub_num_dims, 1);
else
new_at = SLang_create_array1 (new_data_type, 0, NULL, old_dims, old_num_dims, 1);
if (new_at == NULL)
{
SLang_free_array (at);
return -1;
}
new_data = (char *)new_at->data;
old_data = (char *)at->data;
old_sizeof_type = at->sizeof_type;
new_sizeof_type = new_at->sizeof_type;
dims_k = old_dims[k] * wk;
/* Skip this for cases such as sum(Double_Type[0,0], 1). Otherwise,
* (*fcon) will write to new_data, which has no length
*/
if (new_at->num_elements) do
{
size_t offset = 0;
int status;
for (i = 0; i < sub_num_dims; i++)
offset += w[i] * tmp_dims[i];
if (use_contraction)
{
status = (*fcon) ((VOID_STAR)(old_data + offset*old_sizeof_type), wk,
dims_k, (VOID_STAR) new_data);
new_data += new_sizeof_type;
}
else
{
status = (*fmap) (old_data_type, (VOID_STAR) (old_data + offset*old_sizeof_type),
wk, dims_k,
new_data_type, (VOID_STAR) (new_data + offset*new_sizeof_type),
clientdata);
}
if (status == -1)
{
SLang_free_array (new_at);
SLang_free_array (at);
return -1;
}
}
while (-1 != _pSLarray_next_index (tmp_dims, sub_dims, sub_num_dims));
SLang_free_array (at);
return SLang_push_array (new_at, 1);
}
