extra/random/cmwc/cmwc.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays fry kernel locals math math.bitwise
   4 random sequences ;
   5 IN: random.cmwc
   6
   7 ! Multiply-with-carry RNG
   8
   9 TUPLE: cmwc Q a b c i r mod ;
  10
  11 TUPLE: cmwc-seed Q c ;
  12
  13 : <cmwc> ( length a b c -- cmwc )
  14     cmwc new
  15         swap >>c
  16         swap >>b
  17         swap >>a
  18         swap [ 1 - >>i ] [ 0 <array> >>Q ] bi
  19         dup b>> 1 - >>r
  20         dup Q>> length 1 - >>mod ;
  21
  22 M: cmwc seed-random
  23     [ >>Q ]
  24     [ length 1 - >>i ] bi ;
  25
  26 M:: cmwc random-32* ( cmwc -- n )
  27     cmwc dup mod>> '[ 1 + _ bitand ] change-i
  28     [ a>> ]
  29     [ [ i>> ] [ Q>> ] bi nth * ]
  30     [ c>> + ] tri :> t!
  31
  32     t -32 shift cmwc (>>c)
  33
  34     t cmwc [ b>> bitand ] [ c>> + ] bi 64 bits t!
  35     t cmwc r>> > [
  36         cmwc [ 1 + ] change-c drop
  37         t cmwc b>> - 64 bits t!
  38     ] when
  39
  40     cmwc [ r>> t - 32 bits dup ] [ i>> ] [ Q>> ] tri set-nth ;
  41
  42 : cmwc-4096 ( -- cmwc )
  43     4096
  44     [ 18782 4294967295 362436 <cmwc> ]
  45     [ '[ [ random-32 ] replicate ] with-system-random seed-random ] bi ;