static void material_grid_array_release(const material_grid *g)
{
#ifdef HAVE_SCM_ARRAY_GET_HANDLE
(void) g;
scm_array_handle_release(&cur_material_grid_array_handle);
#else
(void) g;
#endif
}
static int
rafill (SCM dst, SCM fill)
{
scm_t_array_handle h;
size_t n, i;
ssize_t inc;
scm_array_get_handle (SCM_I_ARRAY_V (dst), &h);
i = SCM_I_ARRAY_BASE (dst);
inc = SCM_I_ARRAY_DIMS (dst)->inc;
n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1);
dst = SCM_I_ARRAY_V (dst);
for (; n-- > 0; i += inc)
h.vset (h.vector, i, fill);
scm_array_handle_release (&h);
return 1;
}
SCM dijkstra(SCM scm_weights, SCM scm_start, SCM scm_cut_corners_p) {
int row = scm_to_int(SCM_CAR(scm_start));
int col = scm_to_int(SCM_CAR(SCM_CDR(scm_start)));
SCM dimensions = scm_array_dimensions(scm_weights);
int rows = scm_to_int(SCM_CAR(dimensions));
int cols = scm_to_int(SCM_CAR(SCM_CDR(dimensions)));
int cut_corners_p = scm_to_bool(scm_cut_corners_p);
int * weights = calloc(rows * cols, sizeof(int *));
WeightedPoint ** weighted_paths = calloc(rows, sizeof(WeightedPoint *));
scm_t_array_handle weights_handle;
scm_array_get_handle(scm_weights, &weights_handle);
int i_row, i_col;
for(i_row = 0; i_row < rows; i_row++) {
weighted_paths[i_row] = calloc(cols, sizeof(WeightedPoint));
for(i_col = 0; i_col < cols; i_col++) {
ssize_t pos = scm_array_handle_pos(&weights_handle, scm_list_2(scm_from_int(i_row), scm_from_int(i_col)));
weights[i_row * cols + i_col] = scm_to_int(scm_array_handle_ref(&weights_handle, pos));
}
}
scm_array_handle_release(&weights_handle);
find_paths(weighted_paths, (Point){col, row}, cut_corners_p, weights, rows, cols);
SCM scm_paths = scm_make_array(scm_from_int(0), dimensions);
for(i_row = 0; i_row < rows; i_row++) {
for(i_col = 0; i_col < cols; i_col++) {
scm_array_set_x(scm_paths,
scm_list_2(scm_from_int(weighted_paths[i_row][i_col].prev.y), scm_from_int(weighted_paths[i_row][i_col] .prev.x)),
scm_list_2(scm_from_int(i_row), scm_from_int(i_col)));
}
free(weighted_paths[i_row]);
}
free(weighted_paths);
free(weights);
return scm_paths;
}
const SCM *
scm_vector_elements (SCM vec, scm_t_array_handle *h,
size_t *lenp, ssize_t *incp)
{
/* it's unsafe to access the memory of a weak vector */
if (SCM_I_WVECTP (vec))
scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector");
scm_array_get_handle (vec, h);
if (1 != scm_array_handle_rank (h))
{
scm_array_handle_release (h);
scm_wrong_type_arg_msg (NULL, 0, vec, "rank 1 array of Scheme values");
}
if (lenp)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
*lenp = dim->ubnd - dim->lbnd + 1;
*incp = dim->inc;
}
return scm_array_handle_elements (h);
}
SCM
scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
{
register long i;
long count = 0;
SCM l, fl, applicable = SCM_EOL;
SCM save = args;
SCM buffer[BUFFSIZE];
SCM const *types;
SCM *p;
SCM tmp = SCM_EOL;
scm_t_array_handle handle;
scm_c_issue_deprecation_warning
("scm_compute_applicable_methods is deprecated. Use "
"`compute-applicable-methods' from Scheme instead.");
/* Build the list of arguments types */
if (len >= BUFFSIZE)
{
tmp = scm_c_make_vector (len, SCM_UNDEFINED);
types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
/*
note that we don't have to work to reset the generation
count. TMP is a new vector anyway, and it is found
conservatively.
*/
}
else
types = p = buffer;
for ( ; !scm_is_null (args); args = SCM_CDR (args))
*p++ = scm_class_of (SCM_CAR (args));
/* Build a list of all applicable methods */
for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
{
fl = SPEC_OF (SCM_CAR (l));
for (i = 0; ; i++, fl = SCM_CDR (fl))
{
if (SCM_INSTANCEP (fl)
/* We have a dotted argument list */
|| (i >= len && scm_is_null (fl)))
{ /* both list exhausted */
applicable = scm_cons (SCM_CAR (l), applicable);
count += 1;
break;
}
if (i >= len
|| scm_is_null (fl)
|| !applicablep (types[i], SCM_CAR (fl)))
break;
}
}
if (len >= BUFFSIZE)
scm_array_handle_release (&handle);
if (count == 0)
{
if (find_method_p)
return SCM_BOOL_F;
scm_call_2 (scm_no_applicable_method, gf, save);
/* if we are here, it's because no-applicable-method hasn't signaled an error */
return SCM_BOOL_F;
}
return (count == 1
? applicable
: sort_applicable_methods (applicable, count, types));
}
static SCM
sort_applicable_methods (SCM method_list, long size, SCM const *targs)
{
long i, j, incr;
SCM *v, vector = SCM_EOL;
SCM buffer[BUFFSIZE];
SCM save = method_list;
scm_t_array_handle handle;
/* For reasonably sized method_lists we can try to avoid all the
* consing and reorder the list in place...
* This idea is due to David McClain <*****@*****.**>
*/
if (size <= BUFFSIZE)
{
for (i = 0; i < size; i++)
{
buffer[i] = SCM_CAR (method_list);
method_list = SCM_CDR (method_list);
}
v = buffer;
}
else
{
/* Too many elements in method_list to keep everything locally */
vector = scm_i_vector2list (save, size);
v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
}
/* Use a simple shell sort since it is generally faster than qsort on
* small vectors (which is probably mostly the case when we have to
* sort a list of applicable methods).
*/
for (incr = size / 2; incr; incr /= 2)
{
for (i = incr; i < size; i++)
{
for (j = i - incr; j >= 0; j -= incr)
{
if (more_specificp (v[j], v[j+incr], targs))
break;
else
{
SCM tmp = v[j + incr];
v[j + incr] = v[j];
v[j] = tmp;
}
}
}
}
if (size <= BUFFSIZE)
{
/* We did it in locally, so restore the original list (reordered) in-place */
for (i = 0, method_list = save; i < size; i++, v++)
{
SCM_SETCAR (method_list, *v);
method_list = SCM_CDR (method_list);
}
return save;
}
/* If we are here, that's that we did it the hard way... */
scm_array_handle_release (&handle);
return scm_vector_to_list (vector);
}
