1 #lang sicp
   2 (#%require srfi/60)
   3 
   4 (define rand
   5   (let (
   6         (state-index 0)
   7         (state-array '())
   8         (uint32_max (expt 2 32))
   9         (n 624)
  10         (m 397)
  11         (w 32)
  12         (r 31)
  13         (UMASK 9223372034707292160)
  14         (LMASK 2147483647)
  15         (a #b10011001000010001011000011011111)
  16         (u 11)
  17         (s 7)
  18         (t 15)
  19         (l 18)
  20         (b #b10011101001011000101011010000000)
  21         (c #b11101111110001100000000000000000)
  22         (f 1812433253))
  23 
  24     (lambda (op . seed)
  25       (define (init x)
  26         (set! state-array (cons x '()))
  27         (set! state-index 0)
  28         (define (init-iter seed i)
  29           (let ((seed (modulo (+ (* f (logxor seed (ash seed (-(- w 2))))) i) uint32_max)))
  30             (set! state-array (cons seed state-array))
  31             (if (< i (- n 1))
  32               (init-iter seed (+ i 1))
  33               (set! state-array (reverse state-array))))) ;; this is so the consing is clean
  34         (init-iter x 1))
  35 
  36       (define (gen)
  37         (let ((j 0)
  38               (k 0)
  39               (x 0)
  40               (xA 0)
  41               (y 0)
  42               (z 0))
  43           (set! k state-index)
  44           (set! j (- k (- n 1)))
  45           (if (< j 0)
  46             (set! j (+ j n))
  47             (values))
  48 
  49           (set! x (logior (logand (list-ref state-array k) UMASK) (logand (list-ref state-array j) LMASK)))
  50           (set! xA (ash x -1))
  51           (if (> (logand x 1) 0)
  52             (set! xA (logxor xA a))
  53             (values))
  54 
  55           (set! j (- k (- n m)))
  56           (if (< j 0)
  57             (set! j (+ j n))
  58             (values))
  59 
  60           (set! x (logxor (list-ref state-array j) xA))
  61 
  62           (set-car! (list-tail state-array k) x)
  63           (set! k (+ k 1))
  64 
  65           (if (>= k n)
  66             (set! k 0)
  67             (values))
  68 
  69           (set! state-index k)
  70 
  71           (set! y (logxor x (ash x (- u))))
  72           (set! y (logxor y (logand (ash y s) b)))
  73           (set! y (logxor y (logand (ash y t) c)))
  74           (set! z (logxor y (ash y (- l))))
  75           z))
  76 
  77       (cond
  78         ((eq? op 'reset) init)
  79         ((eq? op 'generate) (gen))
  80         (else "op must be 'reset or 'generate")))))
  81 
  82 ((rand 'reset) 19650218)
  83 (rand 'generate)
  84 (rand 'generate)
  85 (rand 'generate)
  86 (newline)
  87 ((rand 'reset) 19650218)
  88 (rand 'generate)
  89 (rand 'generate)
  90 (rand 'generate)