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.
! 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
[ ] [
@ -24,18 +25,18 @@ IN: random.cmwc.tests
}
] [
cmwc-4096
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] unit-test
[ t ] [
cmwc-4096 [
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] [
4096 iota >array 362436 <cmwc-seed> seed-random [
4096 iota >uint-array 362436 <cmwc-seed> seed-random [
10 [ random-32 ] replicate
] with-random
] bi =

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

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