home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / RANDOM.SCM < prev    next >
Text File  |  1992-06-17  |  2KB  |  55 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Random number generator, extracted from T sources.  Original
  5. ; probably by Richard Kelsey,
  6.  
  7. (define half-log 14)
  8. (define full-log (* half-log 2))
  9. (define half-mask (- (arithmetic-shift 1 half-log) 1))
  10. (define full-mask (- (arithmetic-shift 1 full-log) 1))
  11. (define index-log 6)
  12. (define random-1 (bitwise-and 314159265 full-mask))
  13. (define random-2 (bitwise-and 271828189 full-mask))
  14.  
  15. ; (MAKE-RANDOM <seed>) takes an integer seed and returns a procedure of no
  16. ; arguments that returns a new pseudo-random number each time it is called.
  17.  
  18. (define (make-random seed)
  19.   (make-random-vector seed
  20.     (lambda (vec a b)
  21.       (lambda ()
  22.     (set! a (randomize a random-1 random-2))
  23.     (let* ((index (arithmetic-shift a (- index-log full-log)))
  24.            (c (vector-ref vec index)))
  25.       (vector-set! vec index (randomize b random-2 random-1))
  26.       (set! b c)
  27.       c)))))
  28.  
  29. (define (randomize x mult ad)
  30.   (bitwise-and (+ (low-bits-of-product x mult) ad)
  31.            full-mask))
  32.  
  33. (define (make-random-vector seed return)
  34.   (let* ((size (arithmetic-shift 1 index-log))
  35.      (vec (make-vector size 0)))
  36.     (do ((i 0 (+ i 1))
  37.          (b seed (randomize b random-2 random-1)))
  38.         ((>= i size)
  39.          (return vec seed b))
  40.       (vector-set! vec i b))))
  41.  
  42. ; Compute low bits of product of two fixnums using only fixnum arithmetic.
  43. ; [x1 x2] * [y1 y2] = [x1y1 (x1y2+x2y1) x2y2]
  44.  
  45. (define (low-bits-of-product x y)
  46.   (let ((x1 (arithmetic-shift x (- 0 half-log)))
  47.     (y1 (arithmetic-shift y (- 0 half-log)))
  48.     (x2 (bitwise-and x half-mask))
  49.     (y2 (bitwise-and y half-mask)))
  50.      (bitwise-and (+ (* x2 y2)
  51.              (arithmetic-shift (bitwise-and (+ (* x1 y2) (* x2 y1))
  52.                             half-mask)
  53.                        half-log))
  54.           full-mask)))
  55.