#lang scheme/base
;;; PLT Scheme Science Collection
;;; random-source.ss
;;; Copyright (c) 2004-2008 M. Douglas Williams
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
;;; License as published by the Free Software Foundation; either
;;; version 2.1 of the License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this library; if not, write to the Free
;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;; 02111-1307 USA.
;;;
;;; -------------------------------------------------------------------
;;;
;;; This code adds some additional functionality to the PLT Scheme
;;; implementation of SRFI 27 provided with PLT Scheme V207 (and
;;; presumably later versions).
;;;
;;; The main additional functionality is to define a parameter,
;;; current-random-source, that provides a separate random stream
;;; reference for each thread.  The default value for this random
;;; stream reference is default-random-stream as provided by SRFI 27.
;;; A guard procedure ensures that the value of current-random-source
;;; is indeed a random-source, otherwise a type error is raised.
;;;
;;; As of V371.1, there is a new implementation of SRFI 27 in PLT
;;; Scheme.  The underlying PLT Scheme random source rountines were
;;; modified at some point to use the same algorithms as SRFI 27.
;;; The new SRFI 27 implemtation wrappers this functionality.  There
;;; are a few differences between the old implementation and the new
;;; that required changes in this module.  In particular, some of the
;;; SRFI 27 procedures are now macros.
;;;
;;; Instead of the set-random-source-state! procedure just being an
;;; alias for random-source-state-set!, it now calls it directly.
;;; This was done because the latter is now a macro and the aliasing
;;; does not work.  However, this also breaks the ability to set the
;;; state of the default-random-source.
;;;
;;; Version  Date      Description
;;; 0.9.0    08/05/04  This is the initial release of the random
;;;                    source module to augment SRFI 27. (Doug
;;;                    Williams)
;;; 1.0.0    09/20/04  Marked as ready for Release 1.0.  (Doug
;;;                    Williams)
;;; 1.0.1    07/13/05  Added make-random-source-vector.  (Doug
;;;                    Williams)
;;; 1.0.2    10/18/05  Added optional second argument to
;;;                    make-random-source-vector. (Doug Williams)
;;; 1.0.3    08/24/07  Updated to be compatible with the new
;;;                    SRFI 27 implementation.  (Doug Williams)
;;; 1.0.4    09/12/07  The SRFI 27 implementation is changing
;;;                    back to the same interface as before, i.e.,
;;;                    no macros for the standard functionality.
;;;                    (Doug Williams)
;;; 2.0.0    11/17/07  Added unchecked version of functions and
;;;                    getting ready for PLT Scheme V4.0.  (Doug
;;;                    Williams)
;;; 2.1.0    06/07/08  More V4.0 changes.  (Doug Williams)

(require (lib "contract.ss"))

(require (lib "27.ss" "srfi"))

(provide
 (all-from-out (lib "27.ss" "srfi"))
 current-random-source
 with-random-source
 with-new-random-source
 (rename-out (random-uniform-int unchecked-random-uniform-int)
             (random-uniform unchecked-random-uniform)
             (random-source-state unchecked-random-source-state)
             (set-random-source-state! unchecked-set-random-source-state!)
             (make-random-source-vector unchecked-make-random-source-vector)))

(provide/contract
 (random-uniform-int
  (case-> (-> random-source? (and/c integer? (>=/c 1))
              natural-number/c)
          (-> (and/c integer? (>=/c 1))
              natural-number/c)))
 (random-uniform
  (case-> (-> random-source? (real-in 0.0 1.0))
          (-> (real-in 0.0 1.0))))
 (random-source-state
  (-> random-source? any))
 (set-random-source-state!
  (-> random-source? any/c any))
 (make-random-source-vector
  (case-> (-> natural-number/c natural-number/c (vectorof random-source?))
          (-> natural-number/c (vectorof random-source?)))))

;;; Provide a parameter for the current random source - See PLT
;;; MzScheme: Language Manual, Section 7.7 Parameters.

(define current-random-source
  (make-parameter default-random-source
                  (lambda (x)
                    (when (not (random-source? x))
                      (raise-type-error 'current-random-source
                                        "random-source" x))
                    x)))

;;; The macros with-random-source and with-new-random-source provide
;;; a convenient method for executing a body of code with a given
;;; random stream.  The body is executed with current-random-source
;;; set to the specified random-source.

(define-syntax with-random-source
  (syntax-rules ()
    ((with-random-source random-source
                         body ...)
     (parameterize ((current-random-source random-source))
       body ...))))

(define-syntax with-new-random-source
  (syntax-rules ()
    ((with-new-random-source
      body ...)
     (parameterize ((current-random-source
                     (make-random-source)))
       body ...))))

;;; The procedure random-uniform-int returns an integer in the range
;;; 0 ... n-1 using the specified random-source or (current-random-
;;; source) is none is specified.  Note that the random-integer and
;;; random-real functions from SRFI 27 DO NOT understand (current-
;;; random-source) and always use default random-source.

(define random-uniform-int
  (case-lambda
    ((r n)
     ;; Note that random-source-make-integers returns a procedure
     ;; that must be applied to get the random integer.  Thus the
     ;; extra set of parentheses.
     ((random-source-make-integers r) n))
    ((n)
     (random-uniform-int (current-random-source) n))))

;;; The procedure random-uniform returns a double precision real in
;;; the range (0.0, 1.0) (non-inclusive) using the specified
;;; random-source or (current-random-source) if none is specified.
;;; Note that the random-integer and random-real functions from SRFI
;;; 27 DO NOT understand (current-random-source) and always use
;;; default-random-source.

(define random-uniform
  (case-lambda
    ((r)
     ;; Note that random-source-make-reals returns a procedure that
     ;; must be applied to get the random number. Thus the extra
     ;; set of parentheses.
     ((random-source-make-reals r)))
    (()
     (random-uniform (current-random-source)))))

;;; Also provide alternatives to random-source-state-ref and
;;; random-source-state-set! from SRFI 27.

(define random-source-state random-source-state-ref)

(define set-random-source-state! random-source-state-set!)
;The following was needed at a point during the V371 timeframe when the
;SRFI 27 implementation was in flux.  Basically, random-source-state-set!
; was implemented as a macro and was not a first-class object.
;(define (set-random-source-state! s state)
;  (random-source-state-set! s state))

;;; make-random-source-vector: natural x natural -> (vectorof random-source?)
;;; make-random-source-vector: natural -> (vectorof random-source?)

(define make-random-source-vector
  (case-lambda
    ((n i)
     (let ((random-vector (make-vector n)))
       (do ((j 0 (+ j 1)))
           ((= j n) random-vector)
         (let ((random-stream (make-random-source)))
           (random-source-pseudo-randomize! random-stream i j)
           (vector-set! random-vector j random-stream)))))
    ((n)
     (let ((random-vector (make-vector n)))
       (do ((i 0 (+ i 1)))
           ((= i n) random-vector)
         (let ((random-stream (make-random-source)))
           (random-source-pseudo-randomize! random-stream i 0)
           (vector-set! random-vector i random-stream)))))))