basis/random/sfmt/sfmt.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data kernel locals math
   4 math.ranges math.bitwise math.vectors math.vectors.simd random
   5 sequences specialized-arrays sequences.private classes.struct
   6 combinators.short-circuit fry ;
   7 SPECIALIZED-ARRAY: uint
   8 SPECIALIZED-ARRAY: uint-4
   9 IN: random.sfmt
  10
  11 <PRIVATE
  12
  13 CONSTANT: state-multiplier 1812433253
  14
  15 STRUCT: sfmt-state
  16     { seed uint }
  17     { n uint }
  18     { m uint }
  19     { index uint }
  20     { mask uint-4 }
  21     { parity uint-4 }
  22     { r1 uint-4 }
  23     { r2 uint-4 } ;
  24
  25 TUPLE: sfmt
  26     { state sfmt-state }
  27     { uint-array uint-array }
  28     { uint-4-array uint-4-array } ;
  29
  30 : endian-shuffle ( v -- w )
  31     little-endian? [
  32         uchar-16{ 3 2 1 0 7 6 5 4 11 10 9 8 15 14 13 12 } vshuffle
  33     ] unless ; inline
  34
  35 : hlshift* ( v n -- w )
  36     [ endian-shuffle ] dip hlshift endian-shuffle ; inline
  37
  38 : hrshift* ( v n -- w )
  39     [ endian-shuffle ] dip hrshift endian-shuffle ; inline
  40
  41 : wA ( w -- wA )
  42    dup 1 hlshift* vbitxor ; inline
  43
  44 : wB ( w mask -- wB )
  45    [ 11 vrshift ] dip vbitand ; inline
  46
  47 : wC ( w -- wC )
  48    1 hrshift* ; inline
  49
  50 : wD ( w -- wD )
  51    18 vlshift ; inline
  52
  53 : formula ( a b mask c d -- r )
  54     [ wC ] dip wD vbitxor
  55     [ wB ] dip vbitxor
  56     [ wA ] dip vbitxor ; inline
  57
  58 GENERIC: generate ( sfmt -- )
  59
  60 M:: sfmt generate ( sfmt -- )
  61     sfmt state>> :> state
  62     sfmt uint-4-array>> :> array
  63     state n>> 2 - array nth state r1<<
  64     state n>> 1 - array nth state r2<<
  65     state m>> :> m
  66     state n>> :> n
  67     state mask>> :> mask
  68
  69     n m - >fixnum <iota> [| i |
  70         i array nth-unsafe
  71         i m + array nth-unsafe
  72         mask state r1>> state r2>> formula :> r
  73
  74         r i array set-nth-unsafe
  75         state r2>> state r1<<
  76         r state r2<<
  77     ] each
  78
  79     ! n m - 1 + n [a..b) [
  80     m 1 - <iota> [
  81         n m - 1 + + >fixnum :> i
  82         i array nth-unsafe
  83         m n - i + array nth-unsafe
  84         mask state r1>> state r2>> formula :> r
  85
  86         r i array set-nth-unsafe
  87         state r2>> state r1<<
  88         r state r2<<
  89     ] each
  90
  91     0 state index<< ;
  92
  93 : period-certified? ( sfmt -- ? )
  94     [ uint-4-array>> first ]
  95     [ state>> parity>> ] bi vbitand odd-parity? ;
  96
  97 : first-set-bit ( x -- n )
  98     0 swap [
  99         dup { [ 0 > ] [ 1 bitand 0 = ] } 1&&
 100     ] [
 101         [ 1 + ] [ -1 shift ] bi*
 102     ] while drop ;
 103
 104 : correct-period ( sfmt -- )
 105     [ drop 0 ]
 106     [ state>> parity>> first first-set-bit ]
 107     [ uint-array>> swap '[ _ toggle-bit ] change-nth ] tri ;
 108
 109 : certify-period ( sfmt -- sfmt )
 110     dup period-certified? [ dup correct-period ] unless ;
 111
 112 : <sfmt-array> ( sfmt -- uint-array uint-4-array )
 113     state>>
 114     [ n>> 4 * [1..b] uint >c-array ] [ seed>> ] bi
 115     [
 116         [
 117             [ -30 shift ] [ ] bi bitxor
 118             state-multiplier w*
 119         ] dip w+
 120     ] uint-array{ } accumulate-as nip
 121     dup uint-4 cast-array ;
 122
 123 : <sfmt-state> ( seed n m mask parity -- sfmt )
 124     sfmt-state <struct>
 125         swap >>parity
 126         swap >>mask
 127         swap >>m
 128         swap >>n
 129         swap >>seed
 130         0 >>index ;
 131
 132 : init-sfmt ( sfmt -- sfmt' )
 133     dup <sfmt-array> [ >>uint-array ] [ >>uint-4-array ] bi*
 134     certify-period [ generate ] keep ; inline
 135
 136 : <sfmt> ( seed n m mask parity -- sfmt )
 137     <sfmt-state>
 138     sfmt new
 139         swap >>state
 140         init-sfmt ; inline
 141
 142 : refill-sfmt? ( sfmt -- ? )
 143     state>> [ index>> ] [ n>> 4 * ] bi >= ; inline
 144
 145 : next-index ( sfmt -- index )
 146     state>> [ dup 1 + ] change-index drop ; inline
 147
 148 : next ( sfmt -- n )
 149     [ next-index ] [ uint-array>> ] bi nth-unsafe ; inline
 150
 151 PRIVATE>
 152
 153 M: sfmt random-32*
 154     dup refill-sfmt? [ dup generate ] when next ; inline
 155
 156 M: sfmt seed-random
 157     [ [ state>> ] dip >>seed drop ]
 158     [ drop init-sfmt ] 2bi ;
 159
 160 : <sfmt-19937> ( seed -- sfmt )
 161     156 122
 162     uint-4{ 0xdfffffef 0xddfecb7f 0xbffaffff 0xbffffff6 }
 163     uint-4{ 0x1 0x0 0x0 0x13c9e684 }
 164     <sfmt> ; inline
 165
 166 : default-sfmt ( -- sfmt )
 167     [ random-32 ] with-secure-random <sfmt-19937> ;