1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data fry kernel literals
4 locals math random sequences specialized-arrays namespaces
6 SPECIALIZED-ARRAY: double
7 IN: random.lagged-fibonacci
9 TUPLE: lagged-fibonacci { u double-array } { pt0 fixnum } { pt1 fixnum } ;
16 CONSTANT: lagged-fibonacci 899999963
17 CONSTANT: lagged-fibonacci-max-seed 900000000
18 CONSTANT: lagged-fibonacci-sig-bits 24
20 : normalize-seed ( seed -- seed' )
21 abs lagged-fibonacci-max-seed mod ; inline
23 : adjust-ptr ( ptr -- ptr' )
24 1 - dup 0 < [ drop p-r ] when ; inline
28 M:: lagged-fibonacci seed-random ( lagged-fibonacci seed! -- lagged-fibonacci )
29 seed normalize-seed seed!
31 seed 30082 ij * - :> kl
32 ij 177 /i 177 mod 2 + :> i!
34 kl 169 /i 178 mod 1 + :> k!
37 lagged-fibonacci u>> [
42 lagged-fibonacci-sig-bits [
43 i j * 179 mod k * 179 mod m!
48 l m * 64 mod 31 > [ s t + s! ] when
53 lagged-fibonacci p-r >>pt0
56 : <lagged-fibonacci> ( seed -- lagged-fibonacci )
58 p-r 1 + double <c-array> >>u
59 swap seed-random ; inline
61 GENERIC: random-float* ( tuple -- r )
63 : random-float ( -- n ) random-generator get random-float* ; inline
65 M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
66 lagged-fibonacci [ pt0>> ] [ u>> ] bi nth-unsafe
67 lagged-fibonacci [ pt1>> ] [ u>> ] bi nth-unsafe -
68 dup 0.0 < [ 1.0 + ] when
70 lagged-fibonacci [ pt0>> ] [ u>> ] bi set-nth-unsafe
71 lagged-fibonacci [ adjust-ptr ] change-pt0 drop
72 lagged-fibonacci [ adjust-ptr ] change-pt1 drop
75 : default-lagged-fibonacci ( -- obj )
76 [ random-32 ] with-system-random <lagged-fibonacci> ; inline