1: ;;;
    2: ;;; srfi-27.scm - Sources of Random Bits
    3: ;;;  
    4: ;;;   Copyright (c) 2000-2007  Shiro Kawai  <shiro@acm.org>
    5: ;;;   
    6: ;;;   Redistribution and use in source and binary forms, with or without
    7: ;;;   modification, are permitted provided that the following conditions
    8: ;;;   are met:
    9: ;;;   
   10: ;;;   1. Redistributions of source code must retain the above copyright
   11: ;;;      notice, this list of conditions and the following disclaimer.
   12: ;;;  
   13: ;;;   2. Redistributions in binary form must reproduce the above copyright
   14: ;;;      notice, this list of conditions and the following disclaimer in the
   15: ;;;      documentation and/or other materials provided with the distribution.
   16: ;;;  
   17: ;;;   3. Neither the name of the authors nor the names of its contributors
   18: ;;;      may be used to endorse or promote products derived from this
   19: ;;;      software without specific prior written permission.
   20: ;;;  
   21: ;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22: ;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23: ;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
   24: ;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
   25: ;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
   26: ;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
   27: ;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
   28: ;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
   29: ;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
   30: ;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
   31: ;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   32: ;;;  
   33: ;;;  $Id: srfi-27.scm,v 1.5 2007/09/15 12:30:49 shirok Exp $
   34: ;;;
   35: 
   36: ;; Implements SRFI-27 interface on top of math.mt-random module.
   37: 
   38: (define-module srfi-27
   39:   (use math.mt-random)
   40:   (use srfi-4)
   41:   (export random-integer random-real default-random-source
   42:           make-random-source random-source?
   43:           random-source-state-ref random-source-state-set!
   44:           random-source-randomize! random-source-pseudo-randomize!
   45:           random-source-make-integers random-source-make-reals
   46:           ))
   47: (select-module srfi-27)
   48: 
   49: ;; Assumes random source is <mersenne-twister> random object for now.
   50: ;; It is possible that I extend the implementation so that users can
   51: ;; specify the class of random source in future.
   52: (define-constant random-source <mersenne-twister>)
   53: 
   54: ;; Operations on random source
   55: (define (make-random-source) (make random-source))
   56: (define (random-source? obj) (is-a? obj random-source))
   57: (define default-random-source (make-random-source))
   58: 
   59: (define (random-source-state-ref source)
   60:   (mt-random-get-state source))
   61: (define (random-source-state-set! source state)
   62:   (mt-random-set-state! source state))
   63: 
   64: ;; Randomize
   65: (define (random-source-randomize! source)
   66:   (unless (random-source? source)
   67:     (error "random source required, but got" source))
   68:   (mt-random-set-seed! source
   69:                        (let1 s (* (inexact->exact (sys-time)) (sys-getpid))
   70:                          (logior s (ash s -16)))))
   71: 
   72: (define (random-source-pseudo-randomize! source i j)
   73:   ;; This procedure is effectively required to map integers (i,j) into
   74:   ;; a seed value in a deterministic way.  Talking advantage of the fact
   75:   ;; that Mersenne Twister can take vector of numbers.
   76: 
   77:   ;; interleave-i and interleave-j creates a list of integers, each
   78:   ;; is less than 2^32, consisted by interleaving each 32-bit chunk of i and j.
   79:   (define (interleave-i i j lis)
   80:     (if (zero? i)
   81:         (if (zero? j) lis (interleave-j 0 j (cons 0 lis)))
   82:         (receive (q r) (quotient&remainder i #x100000000)
   83:           (interleave-j q j (cons r lis)))))
   84: 
   85:   (define (interleave-j i j lis)
   86:     (if (zero? j)
   87:         (if (zero? i) lis (interleave-i i 0 (cons 0 lis)))
   88:         (receive (q r) (quotient&remainder j #x100000000)
   89:           (interleave-i i q (cons r lis)))))
   90: 
   91:   ;; main body
   92:   (unless (random-source? source)
   93:     (error "random source required, but got" source))
   94:   (when (or (not (integer? i)) (not (integer? j))
   95:             (negative? i) (negative? j))
   96:     (errorf "indices must be non-negative integers: ~s, ~s" i j))
   97:   (mt-random-set-seed! source
   98:                        (list->u32vector (interleave-i i j '(#xffffffff))))
   99:   )
  100: 
  101: ;; Obtain generators from random source.
  102: (define (random-source-make-integers source)
  103:   (unless (random-source? source)
  104:     (error "random source required, but got" source))
  105:   (lambda (n) (mt-random-integer source n)))
  106: 
  107: (define (random-source-make-reals source . maybe-unit)
  108:   (unless (random-source? source)
  109:     (error "random source required, but got" source))
  110:   (if (null? maybe-unit)
  111:       (lambda () (mt-random-real source))
  112:       (let1 unit (car maybe-unit)
  113:         (unless (< 0 unit 1)
  114:           (error "unit must be between 0.0 and 1.0 (exclusive), but got" unit))
  115:         (let* ((1/unit (/ unit))
  116:                (range (inexact->exact (ceiling 1/unit))))
  117:           (lambda ()
  118:             (/ (make-random-integer range) 1/unit))))))
  119: 
  120: ;; Default random generators.
  121: (define-values (random-integer random-real)
  122:   (let1 src default-random-source
  123:     (values (lambda (n) (mt-random-integer src n))
  124:             (lambda ()  (mt-random-real src)))))
  125: 
  126: (provide "srfi-27")