#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include "libguile/_scm.h"
#include "libguile/eval.h"
#include "libguile/arrays.h"
#include "libguile/array-map.h"
#include "libguile/feature.h"
#include "libguile/vectors.h"
#include "libguile/async.h"
#include "libguile/dynwind.h"
#include "libguile/validate.h"
#include "libguile/sort.h"
#define NAME quicksort1
#define INC_PARAM
#define INC 1
#include "libguile/quicksort.i.c"
#define NAME quicksort
#define INC_PARAM ssize_t inc,
#define INC inc
#include "libguile/quicksort.i.c"
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos),
"Sort the vector @var{vec}, using @var{less} for comparing\n"
"the vector elements. @var{startpos} (inclusively) and\n"
"@var{endpos} (exclusively) delimit\n"
"the range of the vector which gets sorted. The return value\n"
"is not specified.")
#define FUNC_NAME s_scm_restricted_vector_sort_x
{
size_t vlen, spos, len;
ssize_t vinc;
scm_t_array_handle handle;
SCM *velts;
velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc);
spos = scm_to_unsigned_integer (startpos, 0, vlen);
len = scm_to_unsigned_integer (endpos, spos, vlen) - spos;
if (vinc == 1)
quicksort1 (velts + spos*vinc, len, less);
else
quicksort (velts + spos*vinc, len, vinc, less);
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
(SCM items, SCM less),
"Return @code{#t} iff @var{items} is a list or vector such that, "
"for each element @var{x} and the next element @var{y} of "
"@var{items}, @code{(@var{less} @var{y} @var{x})} returns "
"@code{#f}.")
#define FUNC_NAME s_scm_sorted_p
{
long len, j;
SCM item, rest;
if (SCM_NULL_OR_NIL_P (items))
return SCM_BOOL_T;
if (scm_is_pair (items))
{
len = scm_ilength (items);
SCM_ASSERT_RANGE (1, items, len >= 0);
if (len <= 1)
return SCM_BOOL_T;
item = SCM_CAR (items);
rest = SCM_CDR (items);
j = len - 1;
while (j > 0)
{
if (scm_is_true (scm_call_2 (less, SCM_CAR (rest), item)))
return SCM_BOOL_F;
else
{
item = SCM_CAR (rest);
rest = SCM_CDR (rest);
j--;
}
}
return SCM_BOOL_T;
}
else
{
scm_t_array_handle handle;
size_t i, len;
ssize_t inc;
const SCM *elts;
SCM result = SCM_BOOL_T;
elts = scm_vector_elements (items, &handle, &len, &inc);
for (i = 1; i < len; i++, elts += inc)
{
if (scm_is_true (scm_call_2 (less, elts[inc], elts[0])))
{
result = SCM_BOOL_F;
break;
}
}
scm_array_handle_release (&handle);
return result;
}
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Merge two already sorted lists into one.\n"
"Given two lists @var{alist} and @var{blist}, such that\n"
"@code{(sorted? alist less?)} and @code{(sorted? blist less?)},\n"
"return a new list in which the elements of @var{alist} and\n"
"@var{blist} have been stably interleaved so that\n"
"@code{(sorted? (merge alist blist less?) less?)}.\n"
"Note: this does _not_ accept vectors.")
#define FUNC_NAME s_scm_merge
{
SCM build;
if (SCM_NULL_OR_NIL_P (alist))
return blist;
else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
long alen, blen;
SCM last;
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
build = scm_cons (SCM_CAR (blist), SCM_EOL);
blist = SCM_CDR (blist);
blen--;
}
else
{
build = scm_cons (SCM_CAR (alist), SCM_EOL);
alist = SCM_CDR (alist);
alen--;
}
last = build;
while ((alen > 0) && (blen > 0))
{
SCM_TICK;
if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
SCM_SETCDR (last, scm_cons (SCM_CAR (blist), SCM_EOL));
blist = SCM_CDR (blist);
blen--;
}
else
{
SCM_SETCDR (last, scm_cons (SCM_CAR (alist), SCM_EOL));
alist = SCM_CDR (alist);
alen--;
}
last = SCM_CDR (last);
}
if ((alen > 0) && (blen == 0))
SCM_SETCDR (last, alist);
else if ((alen == 0) && (blen > 0))
SCM_SETCDR (last, blist);
}
return build;
}
#undef FUNC_NAME
static SCM
scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen,
SCM less)
{
SCM build, last;
if (SCM_NULL_OR_NIL_P (alist))
return blist;
else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
build = blist;
blist = SCM_CDR (blist);
blen--;
}
else
{
build = alist;
alist = SCM_CDR (alist);
alen--;
}
last = build;
while ((alen > 0) && (blen > 0))
{
SCM_TICK;
if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist))))
{
SCM_SETCDR (last, blist);
blist = SCM_CDR (blist);
blen--;
}
else
{
SCM_SETCDR (last, alist);
alist = SCM_CDR (alist);
alen--;
}
last = SCM_CDR (last);
}
if ((alen > 0) && (blen == 0))
SCM_SETCDR (last, alist);
else if ((alen == 0) && (blen > 0))
SCM_SETCDR (last, blist);
}
return build;
}
SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
(SCM alist, SCM blist, SCM less),
"Takes two lists @var{alist} and @var{blist} such that\n"
"@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
"returns a new list in which the elements of @var{alist} and\n"
"@var{blist} have been stably interleaved so that\n"
" @code{(sorted? (merge alist blist less?) less?)}.\n"
"This is the destructive variant of @code{merge}\n"
"Note: this does _not_ accept vectors.")
#define FUNC_NAME s_scm_merge_x
{
if (SCM_NULL_OR_NIL_P (alist))
return blist;
else if (SCM_NULL_OR_NIL_P (blist))
return alist;
else
{
long alen, blen;
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (1, alist, alen);
SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, blist, blen);
return scm_merge_list_x (alist, blist, alen, blen, less);
}
}
#undef FUNC_NAME
static SCM
scm_merge_list_step (SCM * seq, SCM less, long n)
{
SCM a, b;
if (n > 2)
{
long mid = n / 2;
SCM_TICK;
a = scm_merge_list_step (seq, less, mid);
b = scm_merge_list_step (seq, less, n - mid);
return scm_merge_list_x (a, b, mid, n - mid, less);
}
else if (n == 2)
{
SCM p = *seq;
SCM rest = SCM_CDR (*seq);
SCM x = SCM_CAR (*seq);
SCM y = SCM_CAR (SCM_CDR (*seq));
*seq = SCM_CDR (rest);
SCM_SETCDR (rest, SCM_EOL);
if (scm_is_true (scm_call_2 (less, y, x)))
{
SCM_SETCAR (p, y);
SCM_SETCAR (rest, x);
}
return p;
}
else if (n == 1)
{
SCM p = *seq;
*seq = SCM_CDR (p);
SCM_SETCDR (p, SCM_EOL);
return p;
}
else
return SCM_EOL;
}
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
"elements. The sorting is destructive, that means that the\n"
"input sequence is modified to produce the sorted result.\n"
"This is not a stable sort.")
#define FUNC_NAME s_scm_sort_x
{
long len;
if (SCM_NULL_OR_NIL_P (items))
return items;
if (scm_is_pair (items))
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
else if (scm_is_simple_vector (items)
|| (scm_is_array (items) && scm_c_array_rank (items) == 1))
{
scm_restricted_vector_sort_x (items,
less,
scm_from_int (0),
scm_array_length (items));
return items;
}
else
SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n"
"elements. This is not a stable sort.")
#define FUNC_NAME s_scm_sort
{
if (SCM_NULL_OR_NIL_P (items))
return items;
if (scm_is_pair (items))
return scm_sort_x (scm_list_copy (items), less);
else if (scm_is_simple_vector (items)
|| (scm_is_array (items) && scm_c_array_rank (items) == 1))
return scm_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
static void
scm_merge_vector_x (SCM *vec,
SCM *temp,
SCM less,
size_t low,
size_t mid,
size_t high,
ssize_t inc)
{
size_t it;
size_t i1 = low;
size_t i2 = mid + 1;
#define VEC(i) vec[(i)*inc]
for (it = low; (i1 <= mid) && (i2 <= high); ++it)
{
if (scm_is_true (scm_call_2 (less, VEC(i2), VEC(i1))))
temp[it] = VEC(i2++);
else
temp[it] = VEC(i1++);
}
{
while (i1 <= mid)
temp[it++] = VEC(i1++);
while (i2 <= high)
temp[it++] = VEC(i2++);
for (it = low; it <= high; it++)
VEC(it) = temp[it];
}
}
static void
scm_merge_vector_step (SCM *vec,
SCM *temp,
SCM less,
size_t low,
size_t high,
ssize_t inc)
{
if (high > low)
{
size_t mid = (low + high) / 2;
SCM_TICK;
scm_merge_vector_step (vec, temp, less, low, mid, inc);
scm_merge_vector_step (vec, temp, less, mid+1, high, inc);
scm_merge_vector_x (vec, temp, less, low, mid, high, inc);
}
}
SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
"The sorting is destructive, that means that the input sequence\n"
"is modified to produce the sorted result.\n"
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort_x
{
long len;
if (SCM_NULL_OR_NIL_P (items))
return items;
if (scm_is_pair (items))
{
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
else if (scm_is_simple_vector (items)
|| (scm_is_array (items) && scm_c_array_rank (items) == 1))
{
scm_t_array_handle temp_handle, vec_handle;
SCM temp, *temp_elts, *vec_elts;
size_t len;
ssize_t inc;
vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc);
if (len == 0) {
scm_array_handle_release (&vec_handle);
return items;
}
temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL);
scm_merge_vector_step (vec_elts, temp_elts, less, 0, len-1, inc);
scm_array_handle_release (&temp_handle);
scm_array_handle_release (&vec_handle);
return items;
}
else
SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n"
"This is a stable sort.")
#define FUNC_NAME s_scm_stable_sort
{
if (SCM_NULL_OR_NIL_P (items))
return SCM_EOL;
if (scm_is_pair (items))
return scm_stable_sort_x (scm_list_copy (items), less);
else if (scm_is_simple_vector (items)
|| (scm_is_array (items) && scm_c_array_rank (items) == 1))
return scm_stable_sort_x (scm_vector_copy (items), less);
else
SCM_WRONG_TYPE_ARG (1, items);
}
#undef FUNC_NAME
SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. The sorting is destructive, that means that the\n"
"input list is modified to produce the sorted result.\n"
"This is a stable sort.")
#define FUNC_NAME s_scm_sort_list_x
{
long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
return scm_merge_list_step (&items, less, len);
}
#undef FUNC_NAME
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
(SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. This is a stable sort.")
#define FUNC_NAME s_scm_sort_list
{
long len;
SCM_VALIDATE_LIST_COPYLEN (1, items, len);
items = scm_list_copy (items);
return scm_merge_list_step (&items, less, len);
}
#undef FUNC_NAME
void
scm_init_sort ()
{
#include "libguile/sort.x"
scm_add_feature ("sort");
}