From 9376d7131a9f2a8df55a556110304bd9a2e39c40 Mon Sep 17 00:00:00 2001
From: Leah Neukirchen <leah@vuxu.org>
Date: Sat, 26 Nov 2022 18:16:38 +0100
Subject: add sample

---
 mew.scm        | 14 +++++++++++++-
 mew.svnwiki    |  5 +++++
 tests/test.mew |  5 +++++
 3 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/mew.scm b/mew.scm
index c5f1f31..caed21a 100644
--- a/mew.scm
+++ b/mew.scm
@@ -17,7 +17,7 @@
      odometer one-of op op*
      per prn proj puts
      rand range rep
-     scan scan-right sing? search seq set set-at shuffle str slurp
+     sample scan scan-right sing? search seq set set-at shuffle str slurp
      tally-accumulator tbl time
      while
      uniq-accumulator unlist until
@@ -412,6 +412,18 @@
           (loop (dec i)))))
     v)
 
+  (define (sample o)
+    (if (hash-table? o)
+      (esc ret
+        (let ((n (rand (hash-table-size o)))
+              (i 0))
+          (hash-table-for-each o
+                               (lambda (k v)
+                                 (if (= i n)
+                                   (ret (cons k v))
+                                   (set! i (inc i)))))))
+      (get o (rand (len o)))))
+
   (define range
     (case-lambda
       (()               (make-range-generator 0 +inf.0 1))
diff --git a/mew.svnwiki b/mew.svnwiki
index 6898888..6509423 100644
--- a/mew.svnwiki
+++ b/mew.svnwiki
@@ -527,6 +527,11 @@ Returns a random integer such that N <= {{(rand <M>)}} < {{<M>}}.
 
 Shuffles the vector {{<vector>}} randomly in-place using a Fisher-Yates shuffle.
 
+<procedure>(sample <obj>)</procedure>
+
+Returns a random element of the list/vector/string {{<obj>}}.
+Returns a random key/value pair of the hash-table {{<obj>}}.
+
 
 == Special syntax
 
diff --git a/tests/test.mew b/tests/test.mew
index cf84c97..e697751 100644
--- a/tests/test.mew
+++ b/tests/test.mew
@@ -35,6 +35,11 @@
   (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))))
+  (test #t ((one-of '(1 . 2) '(3 . 4)) (sample (tbl 1 2 3 4)))))
+
 (test-group "range"
   (test '(1 2 3) (into '() (range 1 4)))
   (test '() (into '() (range 4 1)))
-- 
cgit 1.4.1