add sample word to random vocab

basis/random/random-docs.factor

@@ -72,6 +72,18 @@ HELP: randomize
 }
 { $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
 
+HELP: sample
+{ $values
+    { "seq" sequence } { "n" integer }
+    { "seq'" sequence }
+}
+{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
+{ $examples
+    { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
+        "{ 3 2 }"
+    }
+} ;
+
 HELP: delete-random
 { $values
      { "seq" sequence }

basis/random/random-tests.factor

@@ -25,3 +25,8 @@ IN: random.tests
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
 
 [ 49 ] [ 50 random-bits* log2 ] unit-test
+
+[ { 1 2 } 3 sample ] [ too-many-samples?  ] must-fail-with
+
+[ 3 ] [ { 1 2 3 4 } 3 sample prune length ] unit-test
+[ 99 ] [ 100 99 sample prune length ] unit-test

basis/random/random.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math namespaces sequences
+USING: accessors alien.c-types assocs byte-arrays byte-vectors
-io.backend io.binary combinators system vocabs.loader
+combinators fry io.backend io.binary kernel locals math
-summary math.bitwise byte-vectors fry byte-arrays
+math.bitwise math.constants math.functions math.ranges
-math.ranges math.constants math.functions accessors ;
+namespaces sequences sets summary system vocabs.loader ;
 IN: random
 
 SYMBOL: system-random-generator
@@ -60,6 +60,25 @@ PRIVATE>
     [ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
     while drop ;
 
+ERROR: too-many-samples seq n ;
+
+<PRIVATE
+
+:: next-sample ( length n seq hashtable -- elt )
+    n hashtable key? [
+        length n 1 + length mod seq hashtable next-sample
+    ] [
+        n hashtable conjoin
+        n seq nth
+    ] if ;
+
+PRIVATE>
+
+: sample ( seq n -- seq' )
+    2dup [ length ] dip < [ too-many-samples ] when
+    swap [ length ] [ ] bi H{ } clone 
+    '[ _ dup random _ _ next-sample ] replicate ;
+
 : delete-random ( seq -- elt )
     [ length random-integer ] keep [ nth ] 2keep delete-nth ;