;;; PLT Scheme Science Collection
;;; random-source.ss
;;; Copyright (c) 2004 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.
;;;
;;; 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)

(module random-source mzscheme
  
  (require (lib "contract.ss"))

  (require (lib "27.ss" "srfi"))
  
  (provide
   (all-from (lib "27.ss" "srfi"))
   current-random-source
   with-random-source
   with-new-random-source)
  
  (provide/contract
   (random-uniform-int
    (case-> (-> random-source? (integer-in 1 +inf.0)
                natural-number/c)
            (-> (integer-in 1 +inf.0)
                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
  ;; MxScheme: Language Manual, Section 7.7 Parameters.
  
  (define current-random-source
    (make-parameter default-random-source
                    (lambda (x)
                      (if (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!)
  
  ;; 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)))))))

)