module/slib/random.scm

   1 ;;;; "random.scm" Pseudo-Random number generator for scheme.
   2 ;;; Copyright (C) 1991, 1993, 1998, 1999 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 'byte)
  21 (require 'logical)
  22
  23 ;;; random:chunk returns an integer in the range of 0 to 255.
  24 (define (random:chunk sta)
  25   (cond ((positive? (byte-ref sta 258))
  26          (byte-set! sta 258 0)
  27          (slib:error "random state called reentrantly")))
  28   (byte-set! sta 258 1)
  29   (let* ((idx (logand #xff (+ 1 (byte-ref sta 256))))
  30          (xtm (byte-ref sta idx))
  31          (idy (logand #xff (+ (byte-ref sta 257) xtm))))
  32     (byte-set! sta 256 idx)
  33     (byte-set! sta 257 idy)
  34     (let ((ytm (byte-ref sta idy)))
  35       (byte-set! sta idy xtm)
  36       (byte-set! sta idx ytm)
  37       (let ((ans (byte-ref sta (logand #xff (+ ytm xtm)))))
  38         (byte-set! sta 258 0)
  39         ans))))
  40
  41
  42 ;;@args n
  43 ;;@args n state
  44 ;;Accepts a positive integer or real @1 and returns a number of the
  45 ;;same type between zero (inclusive) and @1 (exclusive).  The values
  46 ;;returned by @0 are uniformly distributed from 0 to @1.
  47 ;;
  48 ;;The optional argument @var{state} must be of the type returned by
  49 ;;@code{(seed->random-state)} or @code{(make-random-state)}.  It defaults
  50 ;;to the value of the variable @code{*random-state*}.  This object is used
  51 ;;to maintain the state of the pseudo-random-number generator and is
  52 ;;altered as a side effect of calls to @code{random}.
  53 (define (random modu . args)
  54   (let ((state (if (null? args) *random-state* (car args))))
  55     (if (exact? modu)
  56         (letrec ((bitlen (integer-length (+ -1 modu)))
  57                  (rnd (lambda ()
  58                         (do ((bln bitlen (+ -8 bln))
  59                              (rbs 0 (+ (ash rbs 8) (random:chunk state))))
  60                             ((<= bln 7)
  61                              (set! rbs (+ (ash rbs bln)
  62                                           (bit-field (random:chunk state) 0 bln)))
  63                              (and (< rbs modu) rbs))))))
  64           (do ((ans (rnd) (rnd))) (ans ans)))
  65         (* (random:uniform1 state) modu))))
  66
  67 (define random:random random)
  68 ;;;random:uniform is in randinex.scm.  It is needed only if inexact is
  69 ;;;supported.
  70
  71
  72 ;;@defvar *random-state*
  73 ;;Holds a data structure that encodes the internal state of the
  74 ;;random-number generator that @code{random} uses by default.  The nature
  75 ;;of this data structure is implementation-dependent.  It may be printed
  76 ;;out and successfully read back in, but may or may not function correctly
  77 ;;as a random-number state object in another implementation.
  78 ;;@end defvar
  79
  80
  81 ;;@args state
  82 ;;Returns a new copy of argument @1.
  83 ;;
  84 ;;@args
  85 ;;Returns a new copy of @code{*random-state*}.
  86 (define (copy-random-state . sta)
  87   (copy-string (if (null? sta) *random-state* (car sta))))
  88
  89
  90 ;;@body
  91 ;;Returns a new object of type suitable for use as the value of the
  92 ;;variable @code{*random-state*} or as a second argument to @code{random}.
  93 ;;The number or string @1 is used to initialize the state.  If
  94 ;;@0 is called twice with arguments which are
  95 ;;@code{equal?}, then the returned data structures will be @code{equal?}.
  96 ;;Calling @0 with unequal arguments will nearly
  97 ;;always return unequal states.
  98 (define (seed->random-state seed)
  99   (define sta (make-bytes (+ 3 256) 0))
 100   (if (number? seed) (set! seed (number->string seed)))
 101                                         ; initialize state
 102   (do ((idx #xff (+ -1 idx)))
 103       ((negative? idx))
 104     (byte-set! sta idx idx))
 105                                         ; merge seed into state
 106   (do ((i 0 (+ 1 i))
 107        (j 0 (modulo (+ 1 j) seed-len))
 108        (seed-len (bytes-length seed))
 109        (k 0))
 110       ((>= i 256))
 111     (let ((swp (byte-ref sta i)))
 112       (set! k (logand #xff (+ k (byte-ref seed j) swp)))
 113       (byte-set! sta i (byte-ref sta k))
 114       (byte-set! sta k swp)))
 115   sta)
 116
 117
 118 ;;@args
 119 ;;@args obj
 120 ;;Returns a new object of type suitable for use as the value of the
 121 ;;variable @code{*random-state*} or as a second argument to @code{random}.
 122 ;;If the optional argument @var{obj} is given, it should be a printable
 123 ;;Scheme object; the first 50 characters of its printed representation
 124 ;;will be used as the seed.  Otherwise the value of @code{*random-state*}
 125 ;;is used as the seed.
 126 (define (make-random-state . args)
 127   (let ((seed (if (null? args) *random-state* (car args))))
 128     (cond ((string? seed))
 129           ((number? seed) (set! seed (number->string seed)))
 130           (else (let ()
 131                   (require 'object->string)
 132                   (set! seed (object->limited-string seed 50)))))
 133     (seed->random-state seed)))
 134
 135 (define *random-state*
 136   (make-random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
 137
 138 (provide 'random)                       ;to prevent loops
 139 (if (provided? 'inexact) (require 'random-inexact))