summaryrefslogtreecommitdiff
path: root/libguile/sort.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/sort.c')
-rw-r--r--libguile/sort.c652
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");
+}