From c5d3b30866dff0bbe3a2891ea4fcc3cd2d075d74 Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Sat, 26 Nov 2022 22:49:20 +0100
Subject: add shuffle!, make shuffle copy the vector

---
 mew.scm        | 15 +++++++++++++--
 mew.svnwiki    |  4 ++++
 tests/test.mew |  6 ++++++
 3 files changed, 23 insertions(+), 2 deletions(-)

diff --git a/mew.scm b/mew.scm
index 695568b..22a8752 100644
--- a/mew.scm
+++ b/mew.scm
@@ -17,7 +17,8 @@
      odometer one-of op op*
      per prn proj puts
      rand range rep
-     sample scan scan-right sing? search seq set set-at shuffle str slurp
+     sample scan scan-right sing? search seq set set-at
+     shuffle shuffle! str slurp
      tally-accumulator tbl time
      while
      uniq-accumulator unlist until
@@ -404,7 +405,7 @@
       ((n)   (pseudo-random-integer n))
       ((n m) (+ n (pseudo-random-integer (- m n))))))
 
-  (define (shuffle v)
+  (define (shuffle! v)
     (let loop ((i (- (vector-length v) 1)))
       (when (positive? i)
         (let* ((j (rand (+ i 1)))
@@ -415,6 +416,16 @@
           (loop (dec i)))))
     v)
 
+  (define (shuffle v)
+    (let ((l (vector-length v)))
+      (do ((res (make-vector l))
+           (i 0 (+ i 1)))
+          ((= i l) res)
+        (let ((j (rand (+ i 1))))
+          (unless (= j i)
+            (vector-set! res i (vector-ref res j)))
+          (vector-set! res j (vector-ref v i))))))
+
   (define (sample o)
     (if (hash-table? o)
       (esc ret
diff --git a/mew.svnwiki b/mew.svnwiki
index 6509423..7d5dce7 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -525,6 +525,10 @@ Returns a random integer such that N <= {{(rand <M>)}} < {{<M>}}.
 
 <procedure>(shuffle <vector>)</procedure>
 
+Returns a copy of the vector {{<vector>}} with the entries in randomized order.
+
+<procedure>(shuffle! <vector>)</procedure>
+
 Shuffles the vector {{<vector>}} randomly in-place using a Fisher-Yates shuffle.
 
 <procedure>(sample <obj>)</procedure>
diff --git a/tests/test.mew b/tests/test.mew
index e697751..50cb6bd 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -35,6 +35,12 @@
   (test #f (=? (shuffle #(1 2 3 4 5 6 7 8 9 0))
                (shuffle #(1 2 3 4 5 6 7 8 9 0)))))
 
+(test-group "shuffle!"
+  (test #t (loc (v #(1 2 3)) (eq? v (shuffle! v))))
+  (test #(1 2 3) (sort (shuffle! #(3 2 1)) <))
+  (test #f (=? (shuffle! #(1 2 3 4 5 6 7 8 9 0))
+               (shuffle! #(1 2 3 4 5 6 7 8 9 0)))))
+
 (test-group "sample"
   (test #t ((one-of 1 2 3) (sample '(1 2 3))))
   (test #t ((one-of 1 2 3) (sample #(1 2 3))))
-- 
cgit 1.4.1