module/srfi/srfi-27.scm

   1 ;;; srfi-27.scm --- Sources of Random Bits
   2
   3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
   4
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library. If not, see
  17 ;; <http://www.gnu.org/licenses/>.
  18
  19 ;;; Commentary:
  20
  21 ;; This module is fully documented in the Guile Reference Manual.
  22
  23 ;;; Code:
  24
  25 (define-module (srfi srfi-27)
  26   #:export (random-integer
  27             random-real
  28             default-random-source
  29             make-random-source
  30             random-source?
  31             random-source-state-ref
  32             random-source-state-set!
  33             random-source-randomize!
  34             random-source-pseudo-randomize!
  35             random-source-make-integers
  36             random-source-make-reals)
  37   #:use-module (srfi srfi-9))
  38
  39 (cond-expand-provide (current-module) '(srfi-27))
  40
  41 (define-record-type :random-source
  42   (%make-random-source state)
  43   random-source?
  44   (state random-source-state set-random-source-state!))
  45
  46 (define (make-random-source)
  47   (%make-random-source (seed->random-state 0)))
  48
  49 (define (random-source-state-ref s)
  50   (random-state->datum (random-source-state s)))
  51
  52 (define (random-source-state-set! s state)
  53   (set-random-source-state! s (datum->random-state state)))
  54
  55 (define (random-source-randomize! s)
  56   (let ((time (gettimeofday)))
  57     (set-random-source-state! s (seed->random-state
  58                                  (+ (* (car time) 1e6) (cdr time))))))
  59
  60 (define (random-source-pseudo-randomize! s i j)
  61   (set-random-source-state! s (seed->random-state (i+j->seed i j))))
  62
  63 (define (i+j->seed i j)
  64   (logior (ash (spread i 2) 1)
  65           (spread j 2)))
  66
  67 (define (spread n amount)
  68   (let loop ((result 0) (n n) (shift 0))
  69     (if (zero? n)
  70         result
  71         (loop (logior result
  72                       (ash (logand n 1) shift))
  73               (ash n -1)
  74               (+ shift amount)))))
  75
  76 (define (random-source-make-integers s)
  77   (lambda (n)
  78     (random n (random-source-state s))))
  79
  80 (define random-source-make-reals
  81   (case-lambda
  82     ((s)
  83      (lambda ()
  84        (let loop ()
  85          (let ((x (random:uniform (random-source-state s))))
  86            (if (zero? x)
  87                (loop)
  88                x)))))
  89     ((s unit)
  90      (or (and (real? unit) (< 0 unit 1))
  91          (error "unit must be real between 0 and 1" unit))
  92      (random-source-make-reals s))))
  93
  94 (define default-random-source (make-random-source))
  95 (define random-integer (random-source-make-integers default-random-source))
  96 (define random-real (random-source-make-reals default-random-source))