mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Fix sort, sort! for arrays with nonzero lower bound
* 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
parent
ffcdb7bddf
commit
3bfd4aaa6e
6 changed files with 202 additions and 134 deletions
|
|
@ -7498,10 +7498,6 @@ same type, and have corresponding elements which are either
|
|||
@code{equal?} (@pxref{Equality}) in that all arguments must be arrays.
|
||||
@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 different index ranges. The code currently iterates over the
|
||||
@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?
|
||||
|
||||
@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)
|
||||
Set each element of the @var{dst} array to values obtained from calls
|
||||
to @var{proc}. The value returned is unspecified.
|
||||
Set each element of the @var{dst} array to values obtained from calls to
|
||||
@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})},
|
||||
where each @var{elem} is from the corresponding @var{src} array, at
|
||||
the @var{dst} index. @code{array-map-in-order!} makes the calls in
|
||||
Each call is @code{(@var{proc} @var{elem} @dots{})}, where each
|
||||
@var{elem} is from the corresponding @var{src} array, at the
|
||||
@var{dst} index. @code{array-map-in-order!} makes the calls in
|
||||
row-major order, @code{array-map!} makes them in an unspecified order.
|
||||
|
||||
The @var{src} arrays must have the same number of dimensions as
|
||||
|
|
@ -7568,6 +7565,21 @@ $\left(\matrix{%
|
|||
@end example
|
||||
@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
|
||||
@subsubsection Shared Arrays
|
||||
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
reduces the probability of selecting a bad pivot value and eliminates
|
||||
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,
|
||||
since insertion sort is faster for small, mostly sorted array segments.
|
||||
|
||||
|
|
@ -54,33 +54,29 @@
|
|||
#define STACK_NOT_EMPTY (stack < top)
|
||||
|
||||
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. */
|
||||
typedef struct {
|
||||
size_t lo;
|
||||
size_t hi;
|
||||
ssize_t lo;
|
||||
ssize_t hi;
|
||||
} stack_node;
|
||||
|
||||
static const char s_buggy_less[] = "buggy less predicate used when sorting";
|
||||
|
||||
if (nr_elems == 0)
|
||||
/* Avoid lossage with unsigned arithmetic below. */
|
||||
return;
|
||||
|
||||
if (nr_elems > MAX_THRESH)
|
||||
if (ubnd-lbnd+1 > MAX_THRESH)
|
||||
{
|
||||
size_t lo = 0;
|
||||
size_t hi = nr_elems-1;
|
||||
ssize_t lo = lbnd;
|
||||
ssize_t hi = ubnd;
|
||||
|
||||
stack_node stack[STACK_SIZE];
|
||||
stack_node *top = stack + 1;
|
||||
|
||||
while (STACK_NOT_EMPTY)
|
||||
{
|
||||
size_t left;
|
||||
size_t right;
|
||||
size_t mid = lo + (hi - lo) / 2;
|
||||
ssize_t left;
|
||||
ssize_t right;
|
||||
ssize_t mid = lo + (hi - lo) / 2;
|
||||
SCM pivot;
|
||||
|
||||
/* 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
|
||||
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. */
|
||||
POP (lo, hi);
|
||||
else
|
||||
/* Ignore small left partition. */
|
||||
lo = left;
|
||||
}
|
||||
else if ((size_t) (hi - left) <= MAX_THRESH)
|
||||
else if ((hi - left) <= MAX_THRESH)
|
||||
/* Ignore small right partition. */
|
||||
hi = right;
|
||||
else if ((right - lo) > (hi - left))
|
||||
|
|
@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
one beyond it!). */
|
||||
|
||||
{
|
||||
size_t tmp = 0;
|
||||
size_t end = nr_elems-1;
|
||||
size_t thresh = min (end, MAX_THRESH);
|
||||
size_t run;
|
||||
ssize_t tmp = lbnd;
|
||||
ssize_t end = ubnd;
|
||||
ssize_t thresh = min (end, MAX_THRESH);
|
||||
ssize_t run;
|
||||
|
||||
/* Find smallest element in first threshold and place it at the
|
||||
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))))
|
||||
tmp = run;
|
||||
|
||||
if (tmp != 0)
|
||||
SWAP (tmp, 0);
|
||||
if (tmp != lbnd)
|
||||
SWAP (tmp, lbnd);
|
||||
|
||||
/* Insertion sort, running from left-hand-side up to right-hand-side. */
|
||||
|
||||
run = 1;
|
||||
run = lbnd + 1;
|
||||
while (++run <= end)
|
||||
{
|
||||
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))))
|
||||
{
|
||||
/* The comparison predicate may be buggy */
|
||||
if (tmp == 0)
|
||||
if (tmp == lbnd)
|
||||
scm_misc_error (NULL, s_buggy_less, SCM_EOL);
|
||||
|
||||
tmp -= 1;
|
||||
|
|
@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
|
|||
if (tmp != run)
|
||||
{
|
||||
SCM to_insert = GET(run);
|
||||
size_t hi, lo;
|
||||
ssize_t hi, lo;
|
||||
|
||||
for (hi = lo = run; --lo >= tmp; hi = lo)
|
||||
SET(hi, GET(lo));
|
||||
|
|
|
|||
|
|
@ -69,7 +69,7 @@
|
|||
#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val)
|
||||
#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),
|
||||
"Sort the vector @var{vec}, using @var{less} for comparing\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
|
||||
{
|
||||
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_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)
|
||||
{
|
||||
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)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range",
|
||||
vec, scm_list_1(startpos));
|
||||
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+1)
|
||||
if (epos > dims[0].ubnd)
|
||||
{
|
||||
scm_array_handle_release (&handle);
|
||||
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range",
|
||||
vec, scm_list_1(endpos));
|
||||
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) + (spos-dims[0].lbnd) * dims[0].inc,
|
||||
epos-spos, dims[0].inc, less);
|
||||
quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
|
||||
spos, epos, dims[0].inc, less);
|
||||
else
|
||||
quicksorta (&handle, epos-spos, less);
|
||||
quicksorta (&handle, spos, epos, less);
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
return SCM_UNSPECIFIED;
|
||||
|
|
@ -187,11 +186,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
|
|||
}
|
||||
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,
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)),
|
||||
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1)))))
|
||||
scm_array_handle_ref (&handle, i*dims[0].inc),
|
||||
scm_array_handle_ref (&handle, (i-1)*dims[0].inc))))
|
||||
{
|
||||
result = SCM_BOOL_F;
|
||||
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
|
||||
interleaved so that (sorted? (merge a b less?) less?).
|
||||
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),
|
||||
"Merge two already sorted lists into one.\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
|
||||
|
||||
|
||||
static SCM
|
||||
static SCM
|
||||
scm_merge_list_x (SCM alist, SCM blist,
|
||||
long alen, long blen,
|
||||
SCM less)
|
||||
|
|
@ -327,7 +326,7 @@ scm_merge_list_x (SCM alist, SCM blist,
|
|||
} /* 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),
|
||||
"Takes two lists @var{alist} and @var{blist} such that\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
|
||||
though it claimed to be.
|
||||
*/
|
||||
static SCM
|
||||
static SCM
|
||||
scm_merge_list_step (SCM * seq, SCM less, long n)
|
||||
{
|
||||
SCM a, b;
|
||||
|
|
@ -406,7 +405,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n)
|
|||
} while (0)
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 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"
|
||||
|
|
@ -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)
|
||||
{
|
||||
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_int (0),
|
||||
scm_array_length (items));
|
||||
scm_from_ssize_t (dims[0].lbnd),
|
||||
scm_from_ssize_t (dims[0].ubnd+1));
|
||||
|
||||
scm_array_handle_release (&handle);
|
||||
return items;
|
||||
}
|
||||
else
|
||||
|
|
@ -439,7 +451,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort, "sort", 2, 0, 0,
|
||||
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"
|
||||
|
|
@ -525,7 +537,7 @@ scm_merge_vector_step (SCM *vec,
|
|||
} /* 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),
|
||||
"Sort the sequence @var{items}, which may be a list or a\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;
|
||||
size_t len;
|
||||
ssize_t inc;
|
||||
|
||||
|
||||
vec_elts = scm_vector_writable_elements (items, &vec_handle,
|
||||
&len, &inc);
|
||||
if (len == 0)
|
||||
|
|
@ -559,7 +571,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 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);
|
||||
|
|
@ -577,7 +589,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0,
|
|||
#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),
|
||||
"Sort the sequence @var{items}, which may be a list or a\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
|
||||
|
||||
|
||||
SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0,
|
||||
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.")
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
|
|||
|
||||
SOURCES = \
|
||||
ice-9/and-let-star.scm \
|
||||
ice-9/arrays.scm \
|
||||
ice-9/atomic.scm \
|
||||
ice-9/binary-ports.scm \
|
||||
ice-9/boot-9.scm \
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
;;;;
|
||||
;;;; 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
|
||||
;;;;
|
||||
(define-module (ice-9 arrays)
|
||||
#:export (array-copy))
|
||||
|
||||
; This is actually defined in boot-9.scm, apparently for b.c.
|
||||
;; (define (array-shape a)
|
||||
;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
|
||||
;; (array-dimensions a)))
|
||||
|
||||
; FIXME writes over the array twice if (array-type) is #t
|
||||
(define (array-copy a)
|
||||
(let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
|
||||
(array-copy! a b)
|
||||
b))
|
||||
|
||||
(define (array-shape a)
|
||||
(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
|
||||
(array-dimensions a)))
|
||||
|
|
|
|||
|
|
@ -1,25 +1,57 @@
|
|||
;;;; 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
|
||||
;;;; 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
|
||||
|
||||
(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"
|
||||
|
||||
|
|
@ -32,67 +64,72 @@
|
|||
(sort '(1 2) (lambda (x y z) z)))
|
||||
|
||||
(pass-if "sort of vector"
|
||||
(let* ((v (randomize-vector! (make-vector 1000) 1000))
|
||||
(w (vector-copy v)))
|
||||
(and (sorted? (sort v <) <)
|
||||
(equal? w v))))
|
||||
(test-sort! (make-vector 100)))
|
||||
|
||||
(pass-if "sort of typed array"
|
||||
(let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))
|
||||
(w (make-typed-array 'f64 *unspecified* 99)))
|
||||
(array-copy! v w)
|
||||
(and (sorted? (sort v <) <)
|
||||
(equal? w v))))
|
||||
(pass-if "sort of typed vector"
|
||||
(test-sort! (make-f64vector 100))))
|
||||
|
||||
(pass-if "sort! of vector"
|
||||
(let ((v (randomize-vector! (make-vector 1000) 1000)))
|
||||
(sorted? (sort! v <) <)))
|
||||
|
||||
(pass-if "sort! of typed array"
|
||||
(let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
|
||||
(sorted? (sort! v <) <)))
|
||||
(with-test-prefix "sort!"
|
||||
|
||||
(pass-if "sort! of non-contigous vector"
|
||||
(let* ((a (make-array 0 1000 3))
|
||||
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
|
||||
(randomize-vector! v 1000)
|
||||
(sorted? (sort! v <) <)))
|
||||
(pass-if "sort of empty vector"
|
||||
(test-sort-inplace! (vector)))
|
||||
|
||||
(pass-if "sort of vector"
|
||||
(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"
|
||||
(let* ((a (make-typed-array 'f64 0 99 3))
|
||||
(v (make-shared-array a (lambda (i) (list i 0)) 99)))
|
||||
(randomize-vector! v 99)
|
||||
(sorted? (sort! v <) <)))
|
||||
(test-sort-inplace! v)))
|
||||
|
||||
(pass-if "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? (sort! v <) <)))
|
||||
(pass-if "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)))
|
||||
|
||||
(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"
|
||||
(let* ((a (make-typed-array 'f64 0 99 3))
|
||||
(v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
|
||||
(randomize-vector! v 99)
|
||||
(sorted? (sort! v <) <))))
|
||||
(test-sort-inplace! v))))
|
||||
|
||||
|
||||
(with-test-prefix "stable-sort!"
|
||||
|
||||
(pass-if "stable-sort!"
|
||||
(let ((v (randomize-vector! (make-vector 1000) 1000)))
|
||||
(sorted? (stable-sort! v <) <)))
|
||||
(let ((v (make-vector 100)))
|
||||
(test-sort-inplace! v stable-sort!)))
|
||||
|
||||
(pass-if "stable-sort! of non-contigous vector"
|
||||
(let* ((a (make-array 0 1000 3))
|
||||
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
|
||||
(randomize-vector! v 1000)
|
||||
(sorted? (stable-sort! v <) <)))
|
||||
(pass-if "stable-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 stable-sort!)))
|
||||
|
||||
(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"
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue