mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Fix sort, sort! for arrays with nonzero lower bound

Browse source 
* module/ice-9/arrays.scm (array-copy): New function, export.
* module/Makefile.am: Install (ice-9 arrays).
* doc/ref/api-data.texi: Add documentation for (ice-9 arrays).
* libguile/quicksort.i.c: Use signed bounds throughout.
* libguile/sort.c (scm_restricted_vector_sort_x): Fix error calls. Fix
  calls to quicksort.
* test-suite/tests/sort.test: Actually test that the sorted results
  match the original data. Test cases for non-zero base index arrays for
  sort, sort!, and stable-sort!.
This commit is contained in:
Daniel Llorens 2017-02-13 12:58:34 +01:00
parent ffcdb7bddf
commit 3bfd4aaa6e
6 changed files with 202 additions and 134 deletions
Download patch file Download diff file Expand all files Collapse all files

32
doc/ref/api-data.texi
View file

@ -7498,10 +7498,6 @@ same type, and have corresponding elements which are either
@code{equal?} (@pxref{Equality}) in that all arguments must be arrays. @code{equal?} (@pxref{Equality}) in that all arguments must be arrays.
@end deffn @end deffn
@c FIXME: array-map! accepts no source arrays at all, and in that
@c case makes calls "(proc)". Is that meant to be a documented
@c feature?
@c
@c FIXME: array-for-each doesn't say what happens if the sources have @c FIXME: array-for-each doesn't say what happens if the sources have
@c different index ranges. The code currently iterates over the @c different index ranges. The code currently iterates over the
@c indices of the first and expects the others to cover those. That @c indices of the first and expects the others to cover those. That
@ -7509,14 +7505,15 @@ same type, and have corresponding elements which are either
@c documented feature? @c documented feature?
@deffn {Scheme Procedure} array-map! dst proc src @dots{} @deffn {Scheme Procedure} array-map! dst proc src @dots{}
@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN @deffnx {Scheme Procedure} array-map-in-order! dst proc src @dots{}
@deffnx {C Function} scm_array_map_x (dst, proc, srclist) @deffnx {C Function} scm_array_map_x (dst, proc, srclist)
Set each element of the @var{dst} array to values obtained from calls Set each element of the @var{dst} array to values obtained from calls to
to @var{proc}. The value returned is unspecified. @var{proc}. The list of @var{src} arguments may be empty. The value
returned is unspecified.
Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})}, Each call is @code{(@var{proc} @var{elem} @dots{})}, where each
where each @var{elem} is from the corresponding @var{src} array, at @var{elem} is from the corresponding @var{src} array, at the
the @var{dst} index. @code{array-map-in-order!} makes the calls in @var{dst} index. @code{array-map-in-order!} makes the calls in
row-major order, @code{array-map!} makes them in an unspecified order. row-major order, @code{array-map!} makes them in an unspecified order.
The @var{src} arrays must have the same number of dimensions as The @var{src} arrays must have the same number of dimensions as
@ -7568,6 +7565,21 @@ $\left(\matrix{%
@end example @end example
@end deffn @end deffn
An additional array function is available in the module
@code{(ice-9 arrays)}. It can be used with:
@example
(use-modules (ice-9 arrays))
@end example
@deffn {Scheme Procedure} array-copy src
Return a new array with the same elements, type and shape as
@var{src}. However, the array increments may not be the same as those of
@var{src}. In the current implementation, the returned array will be in
row-major order, but that might change in the future. Use
@code{array-copy!} on an array of known order if that is a concern.
@end deffn
@node Shared Arrays @node Shared Arrays
@subsubsection Shared Arrays @subsubsection Shared Arrays

48
libguile/quicksort.i.c
View file

@ -27,7 +27,7 @@
reduces the probability of selecting a bad pivot value and eliminates reduces the probability of selecting a bad pivot value and eliminates
certain extraneous comparisons. certain extraneous comparisons.
3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort 3. Only quicksorts (UBND-LBND+1) / MAX_THRESH partitions, leaving insertion sort
to order the MAX_THRESH items within each partition. This is a big win, to order the MAX_THRESH items within each partition. This is a big win,
since insertion sort is faster for small, mostly sorted array segments. since insertion sort is faster for small, mostly sorted array segments.
@ -54,33 +54,29 @@
#define STACK_NOT_EMPTY (stack < top) #define STACK_NOT_EMPTY (stack < top)
static void static void
NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less) NAME (VEC_PARAM ssize_t lbnd, ssize_t ubnd, INC_PARAM SCM less)
{ {
/* Stack node declarations used to store unfulfilled partition obligations. */ /* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct { typedef struct {
size_t lo; ssize_t lo;
size_t hi; ssize_t hi;
} stack_node; } stack_node;
static const char s_buggy_less[] = "buggy less predicate used when sorting"; static const char s_buggy_less[] = "buggy less predicate used when sorting";
if (nr_elems == 0) if (ubnd-lbnd+1 > MAX_THRESH)
/* Avoid lossage with unsigned arithmetic below. */
return;
if (nr_elems > MAX_THRESH)
{ {
size_t lo = 0; ssize_t lo = lbnd;
size_t hi = nr_elems-1; ssize_t hi = ubnd;
stack_node stack[STACK_SIZE]; stack_node stack[STACK_SIZE];
stack_node *top = stack + 1; stack_node *top = stack + 1;
while (STACK_NOT_EMPTY) while (STACK_NOT_EMPTY)
{ {
size_t left; ssize_t left;
size_t right; ssize_t right;
size_t mid = lo + (hi - lo) / 2; ssize_t mid = lo + (hi - lo) / 2;
SCM pivot; SCM pivot;
/* Select median value from among LO, MID, and HI. Rearrange /* Select median value from among LO, MID, and HI. Rearrange
@ -145,16 +141,16 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
ignore one or both. Otherwise, push the larger partition's ignore one or both. Otherwise, push the larger partition's
bounds on the stack and continue sorting the smaller one. */ bounds on the stack and continue sorting the smaller one. */
if ((size_t) (right - lo) <= MAX_THRESH) if ((right - lo) <= MAX_THRESH)
{ {
if ((size_t) (hi - left) <= MAX_THRESH) if ((hi - left) <= MAX_THRESH)
/* Ignore both small partitions. */ /* Ignore both small partitions. */
POP (lo, hi); POP (lo, hi);
else else
/* Ignore small left partition. */ /* Ignore small left partition. */
lo = left; lo = left;
} }
else if ((size_t) (hi - left) <= MAX_THRESH) else if ((hi - left) <= MAX_THRESH)
/* Ignore small right partition. */ /* Ignore small right partition. */
hi = right; hi = right;
else if ((right - lo) > (hi - left)) else if ((right - lo) > (hi - left))
@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
one beyond it!). */ one beyond it!). */
{ {
size_t tmp = 0; ssize_t tmp = lbnd;
size_t end = nr_elems-1; ssize_t end = ubnd;
size_t thresh = min (end, MAX_THRESH); ssize_t thresh = min (end, MAX_THRESH);
size_t run; ssize_t run;
/* Find smallest element in first threshold and place it at the /* Find smallest element in first threshold and place it at the
array's beginning. This is the smallest array element, array's beginning. This is the smallest array element,
@ -192,12 +188,12 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run; tmp = run;
if (tmp != 0) if (tmp != lbnd)
SWAP (tmp, 0); SWAP (tmp, lbnd);
/* Insertion sort, running from left-hand-side up to right-hand-side. */ /* Insertion sort, running from left-hand-side up to right-hand-side. */
run = 1; run = lbnd + 1;
while (++run <= end) while (++run <= end)
{ {
SCM_TICK; SCM_TICK;
@ -206,7 +202,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{ {
/* The comparison predicate may be buggy */ /* The comparison predicate may be buggy */
if (tmp == 0) if (tmp == lbnd)
scm_misc_error (NULL, s_buggy_less, SCM_EOL); scm_misc_error (NULL, s_buggy_less, SCM_EOL);
tmp -= 1; tmp -= 1;
@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (tmp != run) if (tmp != run)
{ {
SCM to_insert = GET(run); SCM to_insert = GET(run);
size_t hi, lo; ssize_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo) for (hi = lo = run; --lo >= tmp; hi = lo)
SET(hi, GET(lo)); SET(hi, GET(lo));

68
libguile/sort.c
View file

@ -69,7 +69,7 @@
#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val) #define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
#include "libguile/quicksort.i.c" #include "libguile/quicksort.i.c"
SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
(SCM vec, SCM less, SCM startpos, SCM endpos), (SCM vec, SCM less, SCM startpos, SCM endpos),
"Sort the vector @var{vec}, using @var{less} for comparing\n" "Sort the vector @var{vec}, using @var{less} for comparing\n"
"the vector elements. @var{startpos} (inclusively) and\n" "the vector elements. @var{startpos} (inclusively) and\n"
@ -79,7 +79,7 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x #define FUNC_NAME s_scm_restricted_vector_sort_x
{ {
ssize_t spos = scm_to_ssize_t (startpos); ssize_t spos = scm_to_ssize_t (startpos);
size_t epos = scm_to_ssize_t (endpos); ssize_t epos = scm_to_ssize_t (endpos)-1;
scm_t_array_handle handle; scm_t_array_handle handle;
scm_t_array_dim const * dims; scm_t_array_dim const * dims;
@ -89,26 +89,25 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
if (scm_array_handle_rank(&handle) != 1) if (scm_array_handle_rank(&handle) != 1)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL); scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (vec));
} }
if (spos < dims[0].lbnd) if (spos < dims[0].lbnd)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range", scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s",
vec, scm_list_1(startpos)); scm_list_2 (startpos, vec), scm_list_1 (startpos));
} }
if (epos > dims[0].ubnd+1) if (epos > dims[0].ubnd)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range", scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s",
vec, scm_list_1(endpos)); scm_list_2 (endpos, vec), scm_list_1 (endpos));
} }
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc, quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
epos-spos, dims[0].inc, less); spos, epos, dims[0].inc, less);
else else
quicksorta (&handle, epos-spos, less); quicksorta (&handle, spos, epos, less);
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -187,11 +186,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
} }
else else
{ {
for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i) for (i = 1, end = dims[0].ubnd-dims[0].lbnd+1; i < end; ++i)
{ {
if (scm_is_true (scm_call_2 (less, if (scm_is_true (scm_call_2 (less,
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)), scm_array_handle_ref (&handle, i*dims[0].inc),
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1))))) scm_array_handle_ref (&handle, (i-1)*dims[0].inc))))
{ {
result = SCM_BOOL_F; result = SCM_BOOL_F;
break; break;
@ -211,7 +210,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
and returns a new list in which the elements of a and b have been stably 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?). interleaved so that (sorted? (merge a b less?) less?).
Note: this does _not_ accept vectors. */ Note: this does _not_ accept vectors. */
SCM_DEFINE (scm_merge, "merge", 3, 0, 0, SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
(SCM alist, SCM blist, SCM less), (SCM alist, SCM blist, SCM less),
"Merge two already sorted lists into one.\n" "Merge two already sorted lists into one.\n"
"Given two lists @var{alist} and @var{blist}, such that\n" "Given two lists @var{alist} and @var{blist}, such that\n"
@ -275,7 +274,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
static SCM static SCM
scm_merge_list_x (SCM alist, SCM blist, scm_merge_list_x (SCM alist, SCM blist,
long alen, long blen, long alen, long blen,
SCM less) SCM less)
@ -327,7 +326,7 @@ scm_merge_list_x (SCM alist, SCM blist,
} /* scm_merge_list_x */ } /* scm_merge_list_x */
SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
(SCM alist, SCM blist, SCM less), (SCM alist, SCM blist, SCM less),
"Takes two lists @var{alist} and @var{blist} such that\n" "Takes two lists @var{alist} and @var{blist} such that\n"
"@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n" "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n"
@ -358,7 +357,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0,
scsh's merge-sort but that algorithm showed to not be stable, even scsh's merge-sort but that algorithm showed to not be stable, even
though it claimed to be. though it claimed to be.
*/ */
static SCM static SCM
scm_merge_list_step (SCM * seq, SCM less, long n) scm_merge_list_step (SCM * seq, SCM less, long n)
{ {
SCM a, b; SCM a, b;
@ -406,7 +405,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
} while (0) } while (0)
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
(SCM items, SCM less), (SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n" "Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n" "vector. @var{less} is used for comparing the sequence\n"
@ -427,10 +426,23 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
} }
else if (scm_is_array (items) && scm_c_array_rank (items) == 1) 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, scm_restricted_vector_sort_x (items,
less, less,
scm_from_int (0), scm_from_ssize_t (dims[0].lbnd),
scm_array_length (items)); scm_from_ssize_t (dims[0].ubnd+1));
scm_array_handle_release (&handle);
return items; return items;
} }
else else
@ -439,7 +451,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_sort, "sort", 2, 0, 0, SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
(SCM items, SCM less), (SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n" "Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence\n" "vector. @var{less} is used for comparing the sequence\n"
@ -525,7 +537,7 @@ scm_merge_vector_step (SCM *vec,
} /* scm_merge_vector_step */ } /* scm_merge_vector_step */
SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
(SCM items, SCM less), (SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n" "Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n" "vector. @var{less} is used for comparing the sequence elements.\n"
@ -551,7 +563,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
SCM temp, *temp_elts, *vec_elts; SCM temp, *temp_elts, *vec_elts;
size_t len; size_t len;
ssize_t inc; ssize_t inc;
vec_elts = scm_vector_writable_elements (items, &vec_handle, vec_elts = scm_vector_writable_elements (items, &vec_handle,
&len, &inc); &len, &inc);
if (len == 0) if (len == 0)
@ -559,7 +571,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
scm_array_handle_release (&vec_handle); scm_array_handle_release (&vec_handle);
return items; return items;
} }
temp = scm_c_make_vector (len, SCM_UNDEFINED); temp = scm_c_make_vector (len, SCM_UNDEFINED);
temp_elts = scm_vector_writable_elements (temp, &temp_handle, temp_elts = scm_vector_writable_elements (temp, &temp_handle,
NULL, NULL); NULL, NULL);
@ -577,7 +589,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0,
(SCM items, SCM less), (SCM items, SCM less),
"Sort the sequence @var{items}, which may be a list or a\n" "Sort the sequence @var{items}, which may be a list or a\n"
"vector. @var{less} is used for comparing the sequence elements.\n" "vector. @var{less} is used for comparing the sequence elements.\n"
@ -613,7 +625,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0,
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
(SCM items, SCM less), (SCM items, SCM less),
"Sort the list @var{items}, using @var{less} for comparing the\n" "Sort the list @var{items}, using @var{less} for comparing the\n"
"list elements. This is a stable sort.") "list elements. This is a stable sort.")

1
module/Makefile.am
View file

@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
SOURCES = \ SOURCES = \
ice-9/and-let-star.scm \ ice-9/and-let-star.scm \
ice-9/arrays.scm \
ice-9/atomic.scm \ ice-9/atomic.scm \
ice-9/binary-ports.scm \ ice-9/binary-ports.scm \
ice-9/boot-9.scm \ ice-9/boot-9.scm \

50
module/ice-9/arrays.scm
View file

@ -1,22 +1,32 @@
;;; installed-scm-file ;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 1999, 2001, 2004, 2006, 2017 Free Software Foundation, Inc.
;;;
;;; This library 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.
;;;
;;; This library 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 this library; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc. (define-module (ice-9 arrays)
;;;; #:export (array-copy))
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ; This is actually defined in boot-9.scm, apparently for b.c.
;;;; License as published by the Free Software Foundation; either ;; (define (array-shape a)
;;;; version 3 of the License, or (at your option) any later version. ;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
;;;; ;; (array-dimensions a)))
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ; FIXME writes over the array twice if (array-type) is #t
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU (define (array-copy a)
;;;; Lesser General Public License for more details. (let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
;;;; (array-copy! a b)
;;;; You should have received a copy of the GNU Lesser General Public b))
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define (array-shape a)
(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
(array-dimensions a)))

137
test-suite/tests/sort.test
View file

@ -1,25 +1,57 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*- ;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011 Free Software Foundation, Inc. ;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011, 2017
;;;; ;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either ;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version. ;;;; version 3 of the License, or (at your option) any later version.
;;;; ;;;;
;;;; This library is distributed in the hope that it will be useful, ;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details. ;;;; Lesser General Public License for more details.
;;;; ;;;;
;;;; You should have received a copy of the GNU Lesser General Public ;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib)) (use-modules (test-suite lib)
(ice-9 arrays))
(set! *random-state* (seed->random-state 2017))
; Randomly shuffle u in place, using Fisher-Yates algorithm.
(define (array-shuffle! v)
(unless (= 1 (array-rank v)) (throw 'bad-rank (array-rank v)))
(let* ((dims (car (array-shape v)))
(lo (car dims)))
(let loop ((i (cadr dims)))
(if (> i lo)
(let* ((j (+ lo (random (- (1+ i) lo))))
(t (array-ref v j)))
(array-set! v (array-ref v i) j)
(array-set! v t i)
(loop (- i 1)))
v))))
(define* (test-sort! v #:optional (sort sort))
(array-index-map! v (lambda (i) i))
(let ((before (array-copy v)))
(array-shuffle! v)
(let ((after (array-copy v)))
(and
(equal? before (sort v <))
(equal? after v)))))
(define* (test-sort-inplace! v #:optional (sort! sort!))
(array-index-map! v (lambda (i) i))
(let ((before (array-copy v)))
(array-shuffle! v)
(and (equal? before (sort! v <))
(equal? before v)
(sorted? v <))))
(define (randomize-vector! v n)
(array-index-map! v (lambda (i) (random n)))
v)
(with-test-prefix "sort" (with-test-prefix "sort"
@ -32,67 +64,72 @@
(sort '(1 2) (lambda (x y z) z))) (sort '(1 2) (lambda (x y z) z)))
(pass-if "sort of vector" (pass-if "sort of vector"
(let* ((v (randomize-vector! (make-vector 1000) 1000)) (test-sort! (make-vector 100)))
(w (vector-copy v)))
(and (sorted? (sort v <) <)
(equal? w v))))
(pass-if "sort of typed array" (pass-if "sort of typed vector"
(let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)) (test-sort! (make-f64vector 100))))
(w (make-typed-array 'f64 *unspecified* 99)))
(array-copy! v w)
(and (sorted? (sort v <) <)
(equal? w v))))
(pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
(pass-if "sort! of typed array" (with-test-prefix "sort!"
(let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
(sorted? (sort! v <) <)))
(pass-if "sort! of non-contigous vector" (pass-if "sort of empty vector"
(let* ((a (make-array 0 1000 3)) (test-sort-inplace! (vector)))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000) (pass-if "sort of vector"
(sorted? (sort! v <) <))) (test-sort-inplace! (make-vector 100)))
(pass-if "sort of empty typed vector"
(test-sort-inplace! (f64vector)))
(pass-if "sort! of typed vector"
(test-sort-inplace! (make-f64vector 100)))
(pass-if "sort! of non-contigous array"
(let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list i 0)) 100)))
(test-sort-inplace! v)))
(pass-if "sort! of non-contigous typed array" (pass-if "sort! of non-contigous typed array"
(let* ((a (make-typed-array 'f64 0 99 3)) (let* ((a (make-typed-array 'f64 0 99 3))
(v (make-shared-array a (lambda (i) (list i 0)) 99))) (v (make-shared-array a (lambda (i) (list i 0)) 99)))
(randomize-vector! v 99) (test-sort-inplace! v)))
(sorted? (sort! v <) <)))
(pass-if "sort! of negative-increment vector" (pass-if "sort! of negative-increment array"
(let* ((a (make-array 0 1000 3)) (let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
(randomize-vector! v 1000) (test-sort-inplace! v)))
(sorted? (sort! v <) <)))
(pass-if "sort! of non-zero base index array"
(test-sort-inplace! (make-array 0 '(-99 0))))
(pass-if "sort! of non-zero base index typed array"
(test-sort-inplace! (make-typed-array 'f64 0 '(-99 0))))
(pass-if "sort! of negative-increment typed array" (pass-if "sort! of negative-increment typed array"
(let* ((a (make-typed-array 'f64 0 99 3)) (let* ((a (make-typed-array 'f64 0 99 3))
(v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
(randomize-vector! v 99) (test-sort-inplace! v))))
(sorted? (sort! v <) <))))
(with-test-prefix "stable-sort!" (with-test-prefix "stable-sort!"
(pass-if "stable-sort!" (pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000))) (let ((v (make-vector 100)))
(sorted? (stable-sort! v <) <))) (test-sort-inplace! v stable-sort!)))
(pass-if "stable-sort! of non-contigous vector" (pass-if "stable-sort! of non-contigous array"
(let* ((a (make-array 0 1000 3)) (let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000))) (v (make-shared-array a (lambda (i) (list i 0)) 100)))
(randomize-vector! v 1000) (test-sort-inplace! v stable-sort!)))
(sorted? (stable-sort! v <) <)))
(pass-if "stable-sort! of negative-increment array"
(let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
(test-sort-inplace! v stable-sort!)))
(pass-if "stable-sort! of non-zero base index array"
(test-sort-inplace! (make-array 0 '(-99 0)) stable-sort!)))
(pass-if "stable-sort! of negative-increment vector"
(let* ((a (make-array 0 1000 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000)))
(randomize-vector! v 1000)
(sorted? (stable-sort! v <) <))))
(with-test-prefix "stable-sort" (with-test-prefix "stable-sort"