diff options
| author | Leah Neukirchen <leah@vuxu.org> | 2022-11-28 20:25:09 +0100 |
|---|---|---|
| committer | Leah Neukirchen <leah@vuxu.org> | 2022-11-28 20:25:09 +0100 |
| commit | 73b23b27998906ec479a995434ca5b664f0c0912 (patch) | |
| tree | 8a594b6d3e243760aa8767a7b0d3111d7a490972 | |
| parent | 81f524c408894e57e29da8f72552200b92565adc (diff) | |
| download | mew-73b23b27998906ec479a995434ca5b664f0c0912.tar.gz mew-73b23b27998906ec479a995434ca5b664f0c0912.tar.xz mew-73b23b27998906ec479a995434ca5b664f0c0912.zip | |
sample: just shuffle if fewer elements are requested than available
| -rw-r--r-- | mew.scm | 12 | ||||
| -rw-r--r-- | mew.svnwiki | 8 | ||||
| -rw-r--r-- | tests/test.mew | 2 |
3 files changed, 15 insertions, 7 deletions
diff --git a/mew.scm b/mew.scm index 8507634..7f491b9 100644 --- a/mew.scm +++ b/mew.scm @@ -450,8 +450,14 @@ ((o) ((gen-get o) (rand (len o)))) ((o k) - (if (or (<= k 0) (< (len o) k)) - #() + (cond + ((= k 0) (empty o)) + ((<= (len o) k) (let ((r (into #() o))) + (shuffle! r) + (if (vector? o) + r + (into (empty o) r)))) + (else ;; Algorithm L with additional shuffle at the end. ;; https://dl.acm.org/doi/pdf/10.1145/198429.198435 (let ((geto (gen-get o)) @@ -472,7 +478,7 @@ (if (vector? o) r (into (empty o) r))))) - ))) + )))) (define range (case-lambda diff --git a/mew.svnwiki b/mew.svnwiki index 60db721..6de85b1 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -541,11 +541,11 @@ Returns a random key/value pair of the hash-table {{<obj>}}. <procedure>(sample <obj> <N>)</procedure> -Returns a random list/vector/string consisting of {{<N>}} elements of -the list/vector/string {{<obj>}}, without replacement. +Returns a random list/vector/string consisting of up to {{<N>}} +elements of the list/vector/string {{<obj>}}, without replacement. -Returns a random hash-table consisting of {{<N>}} key/value pairs of -the hash-table {{<obj>}}, without replacement. +Returns a random hash-table consisting of up to {{<N>}} key/value +pairs of the hash-table {{<obj>}}, without replacement. == Special syntax diff --git a/tests/test.mew b/tests/test.mew index e3a527a..4bcce7f 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -47,6 +47,8 @@ (test #t ((one-of '(1 . 2) '(3 . 4)) (sample (tbl 1 2 3 4)))) (test #t (string? (sample "foobar" 3))) (test 3 (len (sample "foobar" 3))) + (test 2 (len (sample "fb" 3))) + (test "" (sample "foobar" 0)) (test "ooo" (sample "ooooo" 3)) (test #(1 2 3) (sort (sample #(1 2 3) 3) <))) |