1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types fry kernel literals locals math
4 random sequences specialized-arrays namespaces ;
5 SPECIALIZED-ARRAY: double
6 IN: random.lagged-fibonacci
8 TUPLE: lagged-fibonacci u pt0 pt1 ;
15 CONSTANT: lagged-fibonacci 899999963
16 CONSTANT: lagged-fibonacci-max-seed 900000000
17 CONSTANT: lagged-fibonacci-sig-bits 24
19 : normalize-seed ( seed -- seed' )
20 abs lagged-fibonacci-max-seed mod ;
22 : adjust-ptr ( ptr -- ptr' )
23 1 - dup 0 < [ drop p-r ] when ;
27 M:: lagged-fibonacci seed-random ( lagged-fibonacci seed! -- lagged-fibonacci )
28 seed normalize-seed seed!
30 seed 30082 ij * - :> kl
31 ij 177 /i 177 mod 2 + :> i!
33 kl 169 /i 178 mod 1 + :> k!
36 lagged-fibonacci u>> [
41 lagged-fibonacci-sig-bits [
42 i j * 179 mod k * 179 mod m!
47 l m * 64 mod 31 > [ s t + s! ] when
52 lagged-fibonacci p-r >>pt0
55 : <lagged-fibonacci> ( seed -- lagged-fibonacci )
57 p-r 1 + <double-array> >>u
60 GENERIC: random-float* ( tuple -- r )
62 : random-float ( -- n ) random-generator get random-float* ;
64 M:: lagged-fibonacci random-float* ( lagged-fibonacci -- x )
65 lagged-fibonacci [ pt0>> ] [ u>> ] bi nth
66 lagged-fibonacci [ pt1>> ] [ u>> ] bi nth - :> uni!
67 uni 0.0 < [ uni 1.0 + uni! ] when
68 uni lagged-fibonacci [ pt0>> ] [ u>> ] bi set-nth
69 lagged-fibonacci [ adjust-ptr ] change-pt0 drop
70 lagged-fibonacci [ adjust-ptr ] change-pt1 drop