diff options
| -rw-r--r-- | mew.scm | 15 | ||||
| -rw-r--r-- | mew.svnwiki | 4 | ||||
| -rw-r--r-- | 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)))) |