random: faster random-bits, make some things private.
parent
ede21dfb56
commit
c02fc27afc
|
@ -3,19 +3,18 @@ IN: random
|
||||||
|
|
||||||
HELP: seed-random
|
HELP: seed-random
|
||||||
{ $values
|
{ $values
|
||||||
{ "tuple" "a random number generator" }
|
{ "obj" "a random number generator" }
|
||||||
{ "seed" "a seed specific to the random number generator" }
|
{ "seed" "a seed specific to the random number generator" }
|
||||||
{ "tuple'" "a random number generator" }
|
|
||||||
}
|
}
|
||||||
{ $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." }
|
{ $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." }
|
||||||
{ $notes "Not supported on all random number generators." } ;
|
{ $notes "Not supported on all random number generators." } ;
|
||||||
|
|
||||||
HELP: random-32*
|
HELP: random-32*
|
||||||
{ $values { "tuple" "a random number generator" } { "r" "an integer between 0 and 2^32-1" } }
|
{ $values { "obj" "a random number generator" } { "r" "an integer between 0 and 2^32-1" } }
|
||||||
{ $description "Generates a random 32-bit unsigned integer." } ;
|
{ $description "Generates a random 32-bit unsigned integer." } ;
|
||||||
|
|
||||||
HELP: random-bytes*
|
HELP: random-bytes*
|
||||||
{ $values { "n" "an integer" } { "tuple" "a random number generator" } { "byte-array" "a sequence of random bytes" } }
|
{ $values { "n" "an integer" } { "obj" "a random number generator" } { "byte-array" "a sequence of random bytes" } }
|
||||||
{ $description "Generates a byte-array of random bytes." } ;
|
{ $description "Generates a byte-array of random bytes." } ;
|
||||||
|
|
||||||
HELP: random
|
HELP: random
|
||||||
|
@ -83,23 +82,20 @@ HELP: random-bits
|
||||||
{ $description "Outputs an random integer n bits in length." } ;
|
{ $description "Outputs an random integer n bits in length." } ;
|
||||||
|
|
||||||
HELP: random-bits*
|
HELP: random-bits*
|
||||||
{ $values
|
{ $values { "numbits" integer } { "r" "a random integer" } }
|
||||||
{ "numbits" integer }
|
|
||||||
{ "n" integer }
|
|
||||||
}
|
|
||||||
{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
|
{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
|
||||||
|
|
||||||
HELP: with-random
|
HELP: with-random
|
||||||
{ $values { "tuple" "a random generator" } { "quot" "a quotation" } }
|
{ $values { "obj" "a random number generator" } { "quot" "a quotation" } }
|
||||||
{ $description "Calls the quotation with the random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
|
{ $description "Calls the quotation with the random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ;
|
||||||
|
|
||||||
HELP: with-secure-random
|
HELP: with-secure-random
|
||||||
{ $values { "quot" "a quotation" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Calls the quotation with the secure random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
|
{ $description "Calls the quotation with the secure random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ;
|
||||||
|
|
||||||
HELP: with-system-random
|
HELP: with-system-random
|
||||||
{ $values { "quot" "a quotation" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Calls the quotation with the system's random generator in a dynamic variable. All random numbers will be generated using this random generator." } ;
|
{ $description "Calls the quotation with the system's random number generator in a dynamic variable. All random numbers will be generated using this random number generator." } ;
|
||||||
|
|
||||||
{ with-random with-secure-random with-system-random } related-words
|
{ with-random with-secure-random with-system-random } related-words
|
||||||
|
|
||||||
|
|
|
@ -14,11 +14,11 @@ SYMBOL: system-random-generator
|
||||||
SYMBOL: secure-random-generator
|
SYMBOL: secure-random-generator
|
||||||
SYMBOL: random-generator
|
SYMBOL: random-generator
|
||||||
|
|
||||||
GENERIC# seed-random 1 ( tuple seed -- tuple' )
|
GENERIC# seed-random 1 ( obj seed -- obj )
|
||||||
GENERIC: random-32* ( tuple -- r )
|
GENERIC: random-32* ( obj -- r )
|
||||||
GENERIC: random-bytes* ( n tuple -- byte-array )
|
GENERIC: random-bytes* ( n obj -- byte-array )
|
||||||
|
|
||||||
M: object random-bytes* ( n tuple -- byte-array )
|
M: object random-bytes* ( n obj -- byte-array )
|
||||||
[ integer>fixnum-strict [ <byte-array> ] keep ] dip
|
[ integer>fixnum-strict [ <byte-array> ] keep ] dip
|
||||||
[ over 4 >= ] [
|
[ over 4 >= ] [
|
||||||
[ 4 - ] dip
|
[ 4 - ] dip
|
||||||
|
@ -27,7 +27,7 @@ M: object random-bytes* ( n tuple -- byte-array )
|
||||||
random-32* c:int <ref> swap head 0 pick copy-unsafe
|
random-32* c:int <ref> swap head 0 pick copy-unsafe
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: object random-32* ( tuple -- r )
|
M: object random-32* ( obj -- r )
|
||||||
4 swap random-bytes* c:uint deref ;
|
4 swap random-bytes* c:uint deref ;
|
||||||
|
|
||||||
ERROR: no-random-number-generator ;
|
ERROR: no-random-number-generator ;
|
||||||
|
@ -47,35 +47,48 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: #bits ( n -- bits )
|
:: (random-bits) ( numbits obj -- r )
|
||||||
dup 2 <= [ drop 1 ] [ 1 - log2 1 + ] if ; inline
|
numbits 32 > [
|
||||||
|
obj random-32* numbits 32 - [ dup 32 > ] [
|
||||||
:: (random-bits) ( n bits obj -- n' )
|
[ 32 shift obj random-32* + ] [ 32 - ] bi*
|
||||||
obj random-32* 32 bits 32 - [ dup 0 > ] [
|
] while [
|
||||||
[ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri*
|
[ shift ] keep obj random-32* swap bits +
|
||||||
] while drop [ n * ] [ neg shift ] bi* ; inline
|
] unless-zero
|
||||||
|
] [
|
||||||
: ((random-integer)) ( n obj -- n' )
|
obj random-32* numbits bits
|
||||||
[ dup #bits ] dip (random-bits) ; inline
|
] if ; inline
|
||||||
|
|
||||||
GENERIC# (random-integer) 1 ( n obj -- n )
|
|
||||||
M: fixnum (random-integer) ( n obj -- n' ) ((random-integer)) ;
|
|
||||||
M: bignum (random-integer) ( n obj -- n' ) ((random-integer)) ;
|
|
||||||
|
|
||||||
: random-integer ( n -- n' )
|
|
||||||
random-generator get (random-integer) ;
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: random-bits ( numbits -- r )
|
: random-bits ( numbits -- r )
|
||||||
[ 2^ ] keep random-generator get (random-bits) ;
|
random-generator get (random-bits) ;
|
||||||
|
|
||||||
: random-bits* ( numbits -- n )
|
: random-bits* ( numbits -- r )
|
||||||
1 - [ random-bits ] keep set-bit ;
|
1 - [ random-bits ] keep set-bit ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: next-power-of-2-bits ( n -- numbits )
|
||||||
|
dup 2 <= [ drop 1 ] [ 1 - log2 1 + ] if ; inline
|
||||||
|
|
||||||
|
:: ((random-integer)) ( n obj -- r )
|
||||||
|
obj random-32* 32 n next-power-of-2-bits 32 - [ dup 0 > ] [
|
||||||
|
[ 32 shift obj random-32* + ] [ 32 + ] [ 32 - ] tri*
|
||||||
|
] while drop [ n * ] [ neg shift ] bi* ; inline
|
||||||
|
|
||||||
|
GENERIC# (random-integer) 1 ( n obj -- r )
|
||||||
|
M: fixnum (random-integer) ( n obj -- r ) ((random-integer)) ;
|
||||||
|
M: bignum (random-integer) ( n obj -- r ) ((random-integer)) ;
|
||||||
|
|
||||||
|
: random-integer ( n -- r )
|
||||||
|
random-generator get (random-integer) ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
GENERIC: random ( obj -- elt )
|
GENERIC: random ( obj -- elt )
|
||||||
|
|
||||||
M: integer random [ f ] [ random-integer ] if-zero ;
|
M: integer random
|
||||||
|
[ f ] [ random-integer ] if-zero ;
|
||||||
|
|
||||||
M: sequence random
|
M: sequence random
|
||||||
[ f ] [
|
[ f ] [
|
||||||
|
@ -122,7 +135,7 @@ ERROR: too-many-samples seq n ;
|
||||||
[ length random-integer ] keep
|
[ length random-integer ] keep
|
||||||
[ nth ] 2keep remove-nth! drop ;
|
[ nth ] 2keep remove-nth! drop ;
|
||||||
|
|
||||||
: with-random ( tuple quot -- )
|
: with-random ( obj quot -- )
|
||||||
random-generator swap with-variable ; inline
|
random-generator swap with-variable ; inline
|
||||||
|
|
||||||
: with-system-random ( quot -- )
|
: with-system-random ( quot -- )
|
||||||
|
@ -162,12 +175,16 @@ PRIVATE>
|
||||||
: random-integers ( length n -- sequence )
|
: random-integers ( length n -- sequence )
|
||||||
random-generator get '[ _ _ (random-integer) ] replicate ;
|
random-generator get '[ _ _ (random-integer) ] replicate ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
: (cos-random-float) ( -- n )
|
: (cos-random-float) ( -- n )
|
||||||
0. 2pi uniform-random-float cos ;
|
0. 2pi uniform-random-float cos ;
|
||||||
|
|
||||||
: (log-sqrt-random-float) ( -- n )
|
: (log-sqrt-random-float) ( -- n )
|
||||||
random-unit log -2. * sqrt ;
|
random-unit log -2. * sqrt ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: normal-random-float ( mean sigma -- n )
|
: normal-random-float ( mean sigma -- n )
|
||||||
(cos-random-float) (log-sqrt-random-float) * * + ;
|
(cos-random-float) (log-sqrt-random-float) * * + ;
|
||||||
|
|
||||||
|
@ -186,6 +203,8 @@ PRIVATE>
|
||||||
: pareto-random-float ( k alpha -- n )
|
: pareto-random-float ( k alpha -- n )
|
||||||
[ random-unit ] dip recip ^ /f ;
|
[ random-unit ] dip recip ^ /f ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
:: (gamma-random-float>1) ( alpha beta -- n )
|
:: (gamma-random-float>1) ( alpha beta -- n )
|
||||||
! Uses R.C.H. Cheng, "The generation of Gamma
|
! Uses R.C.H. Cheng, "The generation of Gamma
|
||||||
! variables with non-integral shape parameters",
|
! variables with non-integral shape parameters",
|
||||||
|
@ -237,6 +256,8 @@ PRIVATE>
|
||||||
] if x!
|
] if x!
|
||||||
] do while x beta * ;
|
] do while x beta * ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: gamma-random-float ( alpha beta -- n )
|
: gamma-random-float ( alpha beta -- n )
|
||||||
{
|
{
|
||||||
{ [ over 1 > ] [ (gamma-random-float>1) ] }
|
{ [ over 1 > ] [ (gamma-random-float>1) ] }
|
||||||
|
@ -275,6 +296,8 @@ PRIVATE>
|
||||||
rnd (random-unit) 0.5 > [ + ] [ - ] if
|
rnd (random-unit) 0.5 > [ + ] [ - ] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
:: (triangular-random-float) ( low high mode -- n )
|
:: (triangular-random-float) ( low high mode -- n )
|
||||||
mode low - high low - / :> c!
|
mode low - high low - / :> c!
|
||||||
random-unit :> u!
|
random-unit :> u!
|
||||||
|
@ -282,6 +305,8 @@ PRIVATE>
|
||||||
u c > [ 1. u - u! 1. c - c! swap ] when
|
u c > [ 1. u - u! 1. c - c! swap ] when
|
||||||
[ - u c * sqrt * ] keep + ;
|
[ - u c * sqrt * ] keep + ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
: triangular-random-float ( low high -- n )
|
: triangular-random-float ( low high -- n )
|
||||||
2dup + 2 /f (triangular-random-float) ;
|
2dup + 2 /f (triangular-random-float) ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue