home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / random < prev    next >
Text File  |  1994-05-25  |  4KB  |  102 lines
  1. ;;;; "random.scm" Pseudo-Random number generator for scheme.
  2. ;;; Copyright (C) 1991, 1993 Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'logical)
  21.  
  22. (define random:tap 24)
  23. (define random:size 55)
  24.  
  25. (define (random:size-int l)
  26.   (let ((trial (string->number (make-string l #\f) 16)))
  27.   (if (and (exact? trial) (>= most-positive-fixnum trial))
  28.       l
  29.       (random:size-int (- l 1)))))
  30. (define random:chunk-size (* 4 (random:size-int 8)))
  31.  
  32. (define random:MASK
  33.   (string->number (make-string (quotient random:chunk-size 4) #\f) 16))
  34.  
  35. (define *random-state*
  36.   '#(
  37.  "d909ef3e" "fd330ab3" "e33f7843" "76783fbd" "f3675fb3"
  38.  "b54ef879" "0be45590" "a6794679" "0bcd56d3" "fabcdef8"
  39.  "9cbd3efd" "3fd3efcd" "e064ef27" "dddecc08" "34444292"
  40.  "85444454" "4c519210" "c0366273" "54734567" "70abcddc"
  41.  "1bbdac53" "616c5a86" "a982efa9" "105996a0" "5f0cccba"
  42.  "1ea055e1" "fe2acd8d" "1891c1d4" "e6690270" "6912bccc"
  43.  "2678e141" "61222224" "907abcbb" "4ad6829b" "9cdd1404"
  44.  "57798841" "5b892496" "871c9cd1" "d1e67bda" "8b0a3233"
  45.  "578ef23f" "28274ef6" "823ef5ef" "845678c5" "e67890a5"
  46.  "5890abcb" "851fa9ab" "13efa13a" "b12278d6" "daf805ab"
  47.  "a0befc36" "0068a7b5" "e024fd90" "a7b690e2" "27f3571a"
  48.  0))
  49.  
  50. (let ((random-strings *random-state*))
  51.   (set! *random-state* (make-vector (+ random:size 1) 0))
  52.   (let ((nibbles (quotient random:chunk-size 4)))
  53.     (do ((i 0 (+ i 1)))
  54.     ((= i random:size))
  55.       (vector-set!
  56.        *random-state* i
  57.        (string->number (substring (vector-ref random-strings i)
  58.                   0 nibbles)
  59.                16)))))
  60.  
  61. ;;; random:chunk returns an integer in the range of
  62. ;;; 0 to (- (expt 2 random:chunk-size) 1)
  63. (define (random:chunk v)
  64.   (let* ((p (vector-ref v random:size))
  65.      (ans (logical:logxor
  66.            (vector-ref v (modulo (- p random:tap) random:size))
  67.            (vector-ref v p))))
  68.     (vector-set! v p ans)
  69.     (vector-set! v random:size (modulo (- p 1) random:size))
  70.     ans))
  71.  
  72. (define (random:random modu . args)
  73.   (let ((state (if (null? args) *random-state* (car args))))
  74.     (if (exact? modu)
  75.     (do ((ilen 0 (+ 1 ilen))
  76.          (s random:MASK
  77.         (+ random:MASK (* (+ 1 random:MASK) s))))
  78.         ((>= s (- modu 1))
  79.          (let ((slop (modulo (+ s (- 1 modu)) modu)))
  80.            (let loop ((n ilen)
  81.               (r (random:chunk state)))
  82.          (cond ((not (zero? n))
  83.             (loop (+ -1 n)
  84.                   (+ (* r (+ 1 random:MASK))
  85.                  (random:chunk state))))
  86.                ((>= r slop) (modulo r modu))
  87.                (else (loop ilen (random:chunk state))))))))
  88.  
  89.     (* (random:uniform state) modu))))
  90. ;;;random:uniform is in randinex.scm.  It is needed only if inexact is
  91. ;;;supported.
  92.  
  93. (define (random:make-random-state . args)
  94.   (let ((state (if (null? args) *random-state* (car args))))
  95.     (list->vector (vector->list state))))
  96.  
  97. (define random random:random)
  98. (define make-random-state random:make-random-state)
  99.  
  100. (provide 'random)            ;to prevent loops
  101. (if (provided? 'inexact) (require 'random-inexact))
  102.