diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor index 222ecaf935..32641f5fc1 100755 --- a/basis/random/random-docs.factor +++ b/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 } diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor index 2b6ac9b1b8..da8d4a1844 100644 --- a/basis/random/random-tests.factor +++ b/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 diff --git a/basis/random/random.factor b/basis/random/random.factor index 4c94e87928..afdf0b43ba 100755 --- a/basis/random/random.factor +++ b/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 -io.backend io.binary combinators system vocabs.loader -summary math.bitwise byte-vectors fry byte-arrays -math.ranges math.constants math.functions accessors ; +USING: accessors alien.c-types assocs byte-arrays byte-vectors +combinators fry io.backend io.binary kernel locals math +math.bitwise math.constants math.functions math.ranges +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 ; + + + +: 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 ;