Better implementation of sample, fix docs formatting

db4
Doug Coleman 2010-01-30 00:58:29 -06:00
parent 0d939f731a
commit f15ec31559
2 changed files with 10 additions and 18 deletions

View File

@ -86,8 +86,9 @@ HELP: sample
}
{ $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 }"
{ $unchecked-example "USING: random prettyprint ;"
"{ 1 2 3 } 2 sample ."
"{ 3 2 }"
}
} ;

View File

@ -61,29 +61,20 @@ M: sequence random
: random-32 ( -- n ) random-generator get random-32* ;
: randomize ( seq -- seq )
dup length [ dup 1 > ]
: randomize-n-last ( seq n -- seq )
[ dup length dup ] dip - 1 max '[ dup _ > ]
[ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
: randomize ( seq -- seq )
dup length randomize-n-last ;
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 ;
[ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ]
[ drop ] 2bi nths ;
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep remove-nth! drop ;