steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ricing random.cmwc

db4
Doug Coleman 2009-10-16 15:07:05 -05:00
parent 3db0ad12e8
commit 69f5381d34
2 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
extra/random/cmwc/cmwc-tests.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel random random.cmwc sequences tools.test ; USING: alien.c-types arrays kernel random random.cmwc sequences
specialized-arrays specialized-arrays.instances.uint tools.test ;
IN: random.cmwc.tests IN: random.cmwc.tests
[ ] [ [ ] [
@ -24,18 +25,18 @@ IN: random.cmwc.tests
} }
] [ ] [
cmwc-4096 cmwc-4096
4096 iota >array 362436 <cmwc-seed> seed-random [ 4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate 10 [ random-32 ] replicate
] with-random ] with-random
] unit-test ] unit-test
[ t ] [ [ t ] [
cmwc-4096 [ cmwc-4096 [
4096 iota >array 362436 <cmwc-seed> seed-random [ 4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate 10 [ random-32 ] replicate
] with-random ] with-random
] [ ] [
4096 iota >array 362436 <cmwc-seed> seed-random [ 4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate 10 [ random-32 ] replicate
] with-random ] with-random
] bi = ] bi =

26
extra/random/cmwc/cmwc.factor
View File

@ -1,28 +1,34 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel locals math math.bitwise USING: accessors alien.c-types arrays fry kernel locals math
random sequences ; math.bitwise random sequences specialized-arrays
specialized-arrays.instances.uint ;
IN: random.cmwc IN: random.cmwc
! Multiply-with-carry RNG ! Multiply-with-carry RNG
TUPLE: cmwc Q a b c i r mod ; TUPLE: cmwc
{ Q uint-array }
{ a fixnum }
{ b fixnum }
{ c fixnum }
{ i fixnum }
{ r fixnum }
{ mod fixnum } ;
TUPLE: cmwc-seed Q c ; TUPLE: cmwc-seed { Q uint-array read-only } { c read-only } ;
: <cmwc> ( length a b c -- cmwc ) : <cmwc> ( length a b c -- cmwc )
cmwc new cmwc new
swap >>c swap >>c
swap >>b swap >>b
swap >>a swap >>a
swap [ 1 - >>i ] [ 0 <array> >>Q ] bi swap [ 1 - >>i ] [ <uint-array> >>Q ] bi
dup b>> 1 - >>r dup b>> 1 - >>r
dup Q>> length 1 - >>mod ; dup Q>> length 1 - >>mod ;
: <cmwc-seed> ( Q c -- cmwc-seed ) : <cmwc-seed> ( Q c -- cmwc-seed )
cmwc-seed new cmwc-seed boa ; inline
swap >>c
swap >>Q ; inline
M: cmwc seed-random M: cmwc seed-random
[ Q>> >>Q ] [ Q>> >>Q ]
@ -49,6 +55,8 @@ M:: cmwc random-32* ( cmwc -- n )
4096 4096
[ 18782 4294967295 362436 <cmwc> ] [ 18782 4294967295 362436 <cmwc> ]
[ [
'[ [ random-32 ] replicate ] with-system-random '[ [ random-32 ] uint-array{ } replicate-as ] with-system-random
362436 <cmwc-seed> seed-random 362436 <cmwc-seed> seed-random
] bi ; ] bi ;
: default-cmwc ( -- cmwc ) cmwc-4096 ;