[Guile-commits] 04/08: Fix sort, sort! for arrays with nonzero lower bound

[Daniel Llorens]

lloda pushed a commit to branch wip-exception-truncate
in repository guile.

commit dbf4a2f9426450977cdc32b7e1a807320830eea5
Author: Daniel Llorens <address@hidden>
Date:   Mon Feb 13 12:58:34 2017 +0100

    Fix sort, sort! for arrays with nonzero lower bound
    
    * module/ice-9/arrays.scm (array-copy, typed-array-copy): New
      functions. 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!.
---
 doc/ref/api-data.texi      |  38 +++++++++----
 libguile/quicksort.i.c     |  48 ++++++++--------
 libguile/sort.c            |  43 ++++++++++-----
 module/Makefile.am         |   1 +
 module/ice-9/arrays.scm    |  53 +++++++++++-------
 test-suite/tests/sort.test | 133 ++++++++++++++++++++++++++++-----------------
 6 files changed, 194 insertions(+), 122 deletions(-)

diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index f5c8798..bb4b9f7 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -7495,10 +7495,6 @@ same type, and have corresponding elements which are 
either
 @code{equal?} (@pxref{Equality}) in that all arguments must be arrays.
 @end deffn
 
address@hidden  FIXME: array-map! accepts no source arrays at all, and in that
address@hidden  case makes calls "(proc)".  Is that meant to be a documented
address@hidden  feature?
address@hidden
 @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
@@ -7506,14 +7502,15 @@ same type, and have corresponding elements which are 
either
 @c  documented feature?
 
 @deffn {Scheme Procedure} array-map! dst proc src @dots{}
address@hidden {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN
address@hidden {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
address@hidden  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
address@hidden is from the corresponding @var{src} array, at the
address@hidden 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
@@ -7565,6 +7562,27 @@ $\left(\matrix{%
 @end example
 @end deffn
 
+A few additional array functions are available in the module
address@hidden(ice-9 arrays)}. They can be used with:
+
address@hidden
+(use-modules (ice-9 arrays))
address@hidden example
+
address@hidden {Scheme Procedure} array-copy src
+Return a new array with the same elements, type and shape as
address@hidden However, the array increments may not be the same as those of
address@hidden In the current implementation, the returned array will be in
+row-major order, but that might change in the future. Use
address@hidden on an array of known order if that is a concern.
address@hidden deffn
+
address@hidden {Scheme Procedure} typed-array-copy type src
+Return a new array with the same elements and shape as @var{src}, but
+with the type given. This operation may fail if @var{type} is not
+compatible with the values in @var{src}.
address@hidden deffn
+
 @node Shared Arrays
 @subsubsection Shared Arrays
 
diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c
index cf1742e..5982672 100644
--- a/libguile/quicksort.i.c
+++ b/libguile/quicksort.i.c
@@ -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));
diff --git a/libguile/sort.c b/libguile/sort.c
index 8c20d34..ad7b8b8 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -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,26 @@ 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 +187,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;
@@ -418,10 +418,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
diff --git a/module/Makefile.am b/module/Makefile.am
index 67f041d..7b621cc 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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                             \
diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm
index f7f9e5e..5d5276c 100644
--- a/module/ice-9/arrays.scm
+++ b/module/ice-9/arrays.scm
@@ -1,22 +1,35 @@
-;;; 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 typed-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 (typed-array-copy t a)
+  (let ((b (apply make-typed-array t *unspecified* (array-shape a))))
+    (array-copy! a b)
+    b))
+
+(define (array-copy a)
+  (typed-array-copy (array-type a) a))
 
-(define (array-shape a)
-  (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
-       (array-dimensions a)))
diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test
index 249f890..c04c2f0 100644
--- a/test-suite/tests/sort.test
+++ b/test-suite/tests/sort.test
@@ -1,5 +1,6 @@
 ;;;; 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
@@ -15,11 +16,42 @@
 ;;;; 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,66 +64,65 @@
     (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))))
-
-  (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 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 <) <)))
-
-  (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 <) <)))
+    (test-sort! (make-vector 100)))
+
+  (pass-if "sort of typed vector"
+    (test-sort! (make-f64vector 100))))
+
+
+(with-test-prefix "sort!"
+
+  (pass-if "sort of vector"
+    (test-sort-inplace! (make-vector 100)))
+  
+  (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 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 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 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 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 <) <))))
+  (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!)))
 
 ;;;
 ;;; stable-sort