diff options
Diffstat (limited to 'libguile/sort.c')
-rw-r--r-- | libguile/sort.c | 652 |
1 files changed, 652 insertions, 0 deletions
diff --git a/libguile/sort.c b/libguile/sort.c new file mode 100644 index 000000000..05ecee577 --- /dev/null +++ b/libguile/sort.c @@ -0,0 +1,652 @@ +/* Copyright 1999-2002,2004,2006-2012,2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + Guile is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public + License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + +/* Written in December 1998 by Roland Orre <orre@nada.kth.se> + * This implements the same sort interface as slib/sort.scm + * for lists and vectors where slib defines: + * sorted?, merge, merge!, sort, sort! + * For scsh compatibility sort-list and sort-list! are also defined. + * In cases where a stable-sort is required use stable-sort or + * stable-sort!. An additional feature is + * (restricted-vector-sort! vector less? startpos endpos) + * which allows you to sort part of a vector. + * Thanks to Aubrey Jaffer for the slib/sort.scm library. + * Thanks to Richard A. O'Keefe (based on Prolog code by D.H.D.Warren) + * for the merge sort inspiration. + * Thanks to Douglas C. Schmidt (schmidt@ics.uci.edu) for the + * quicksort code. + */ + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include "array-map.h" +#include "arrays.h" +#include "async.h" +#include "boolean.h" +#include "dynwind.h" +#include "eval.h" +#include "feature.h" +#include "generalized-arrays.h" +#include "gsubr.h" +#include "list.h" +#include "pairs.h" +#include "vectors.h" + +#include "sort.h" + +/* We have two quicksort variants: one for SCM (#t) arrays and one for + typed arrays. +*/ + +#define NAME quicksort +#define INC_PARAM ssize_t inc, +#define VEC_PARAM SCM * ra, +#define GET(i) ra[(i)*inc] +#define SET(i, val) ra[(i)*inc] = val +#include "quicksort.i.c" + +#define NAME quicksorta +#define INC_PARAM +#define VEC_PARAM scm_t_array_handle * const ra, +#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i)) +#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val) +#include "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 +{ + ssize_t spos = scm_to_ssize_t (startpos); + ssize_t epos = scm_to_ssize_t (endpos)-1; + + scm_t_array_handle handle; + scm_t_array_dim const * dims; + scm_array_get_handle (vec, &handle); + dims = scm_array_handle_dims (&handle); + + if (scm_array_handle_rank(&handle) != 1) + { + scm_array_handle_release (&handle); + scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (vec)); + } + if (spos < dims[0].lbnd) + { + scm_array_handle_release (&handle); + scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s", + scm_list_2 (startpos, vec), scm_list_1 (startpos)); + } + if (epos > dims[0].ubnd) + { + scm_array_handle_release (&handle); + scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s", + scm_list_2 (endpos, vec), scm_list_1 (endpos)); + } + if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) + quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc, + spos, epos, dims[0].inc, less); + else + quicksorta (&handle, spos, epos, less); + + scm_array_handle_release (&handle); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* (sorted? sequence less?) + * is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm) + * such that for all 1 <= i <= m, + * (not (less? (list-ref list i) (list-ref list (- i 1)))). */ +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; /* list/vector length, temp j */ + SCM item, rest; /* rest of items loop variable */ + + if (SCM_NULL_OR_NIL_P (items)) + return SCM_BOOL_T; + + if (scm_is_pair (items)) + { + len = scm_ilength (items); /* also checks that it's a pure list */ + 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 result = SCM_BOOL_T; + ssize_t i, end; + scm_t_array_handle handle; + scm_t_array_dim const * dims; + scm_array_get_handle (items, &handle); + dims = scm_array_handle_dims (&handle); + + if (scm_array_handle_rank(&handle) != 1) + { + scm_array_handle_release (&handle); + scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL); + } + + if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) + { + ssize_t inc = dims[0].inc; + const SCM *elts = scm_array_handle_elements (&handle); + for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc) + { + if (scm_is_true (scm_call_2 (less, elts[inc], elts[0]))) + { + result = SCM_BOOL_F; + break; + } + } + } + else + { + for (i = 1, end = dims[0].ubnd-dims[0].lbnd+1; i < end; ++i) + { + if (scm_is_true (scm_call_2 (less, + scm_array_handle_ref (&handle, i*dims[0].inc), + scm_array_handle_ref (&handle, (i-1)*dims[0].inc)))) + { + result = SCM_BOOL_F; + break; + } + } + } + + scm_array_handle_release (&handle); + return result; + } +} +#undef FUNC_NAME + + +/* (merge a b less?) + takes two lists a and b such that (sorted? a less?) and (sorted? b less?) + and returns a new list in which the elements of a and b have been stably + interleaved so that (sorted? (merge a b less?) less?). + Note: this does _not_ accept vectors. */ +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; /* list lengths */ + 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_set_cdr_x (last, blist); + blist = SCM_CDR (blist); + blen--; + } + else + { + scm_set_cdr_x (last, alist); + alist = SCM_CDR (alist); + alen--; + } + last = SCM_CDR (last); + } + if ((alen > 0) && (blen == 0)) + scm_set_cdr_x (last, alist); + else if ((alen == 0) && (blen > 0)) + scm_set_cdr_x (last, blist); + } + return build; +} /* scm_merge_list_x */ + + +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; /* list lengths */ + 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 + + +/* This merge sort algorithm is same as slib's by Richard A. O'Keefe. + The algorithm is stable. We also tried to use the algorithm used by + scsh's merge-sort but that algorithm showed to not be stable, even + though it claimed to be. +*/ +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_merge_list_step */ + + +#define SCM_VALIDATE_MUTABLE_LIST(pos, lst) \ + do { \ + SCM walk; \ + for (walk = lst; !scm_is_null_or_nil (walk); walk = SCM_CDR (walk)) \ + SCM_VALIDATE_MUTABLE_PAIR (pos, walk); \ + } while (0) + + +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; /* list/vector length */ + if (SCM_NULL_OR_NIL_P (items)) + return items; + + if (scm_is_pair (items)) + { + SCM_VALIDATE_LIST_COPYLEN (1, items, len); + SCM_VALIDATE_MUTABLE_LIST (1, items); + return scm_merge_list_step (&items, less, len); + } + else if (scm_is_array (items) && scm_c_array_rank (items) == 1) + { + scm_t_array_handle handle; + scm_t_array_dim const * dims; + scm_array_get_handle (items, &handle); + dims = scm_array_handle_dims (&handle); + + if (scm_array_handle_rank (&handle) != 1) + { + scm_array_handle_release (&handle); + scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (items)); + } + + scm_restricted_vector_sort_x (items, + less, + scm_from_ssize_t (dims[0].lbnd), + scm_from_ssize_t (dims[0].ubnd+1)); + + scm_array_handle_release (&handle); + 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_array (items) && scm_c_array_rank (items) == 1) + { + SCM copy; + if (scm_c_array_rank (items) != 1) + scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL); + copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items)); + scm_array_copy_x (items, copy); + return scm_sort_x (copy, 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; /* Index for temp vector */ + size_t i1 = low; /* Index for lower vector segment */ + size_t i2 = mid + 1; /* Index for upper vector segment */ + +#define VEC(i) vec[(i)*inc] + + /* Copy while both segments contain more characters */ + 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++); + } + + { + /* Copy while first segment contains more characters */ + while (i1 <= mid) + temp[it++] = VEC(i1++); + + /* Copy while second segment contains more characters */ + while (i2 <= high) + temp[it++] = VEC(i2++); + + /* Copy back from temp to vp */ + for (it = low; it <= high; it++) + VEC(it) = temp[it]; + } +} /* scm_merge_vector_x */ + + +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_merge_vector_step */ + + +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; /* list/vector length */ + + if (SCM_NULL_OR_NIL_P (items)) + return items; + + if (scm_is_pair (items)) + { + SCM_VALIDATE_LIST_COPYLEN (1, items, len); + SCM_VALIDATE_MUTABLE_LIST (1, items); + return scm_merge_list_step (&items, less, len); + } + else if (scm_is_array (items) && 1 == scm_c_array_rank (items)) + { + 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 + return scm_stable_sort_x (scm_vector_copy (items), less); +} +#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); + SCM_VALIDATE_MUTABLE_LIST (1, items); + + 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 "sort.x" + + scm_add_feature ("sort"); +} |