source: project/release/4/srfi-27/trunk/srfi-27.scm @ 17246

;;;; srfi-27.scm
;;;; Kon Lovett, Oct '09

(module srfi-27

  (;export
    ; SRFI 27
    default-random-source
    random-integer
    random-real
    make-random-source
    random-source?
    random-source-state-ref
    random-source-state-set!
    random-source-randomize!
    random-source-pseudo-randomize!
    random-source-make-integers
    random-source-make-reals
    ; Extensions
    current-random-source
    random-source-kind
    random-source-documentation
    random-source-log2-period
    random-source-maximum-range
    random-source-maximum-modulus
    current-entropy-source
    new-entropy-source
    make-entropy-source
    entropy-source?
    entropy-source-kind
    entropy-source-documentation
    entropy-source-u8
    entropy-source-f64
    entropy-source-u8vector
    entropy-source-f64vector
    ;
    check-real-unit)

  (import scheme
          chicken
          (only data-structures alist-ref alist-update!)
          (only miscmacros define-parameter)
          random-source
          entropy-source
          type-checks
          srfi-4-checks
          (only type-errors error-argument-type)
          mrg32k3a
          entropy-clock)

  (require-library
    data-structures
    miscmacros
    random-source entropy-source
    mrg32k3a entropy-clock
    type-checks type-errors srfi-4-checks )

;;;

(define (check-real-unit loc obj #!optional argnam)
  (check-inexact loc obj argnam)
  (check-real loc obj argnam)
  (check-open-interval loc obj 0.0 1.0 argnam) )

;;;

(define-parameter current-entropy-source (new-entropy-source #:entropy-system-clock)
  (lambda (x)
    (cond ((*entropy-source? x) x)
          (else
            (warning-argument-type 'current-entropy-source x 'entropy-source)
            (current-entropy-source) ) ) ) )

(define (checked-entropy-argument loc obj)
  (cond ((symbol? obj)          obj) ;keyword is-a symbol
        ((*entropy-source? obj) (*entropy-source-kind obj))
        (else
          (error-argument-type loc obj "symbol or entropy-source" 'source))) )

(define (new-entropy-source s)
  (let ((kind (checked-entropy-argument 'new-entropy-source s)))
    (cond ((registered-entropy-source kind) => (cut <> kind))
          (else
            (error-argument-type 'new-entropy-source kind "registered entropy-source") ) ) ) )

(define make-entropy-source
  (let ((ess '()))
    (lambda (#!optional (s (current-entropy-source)))
      (let* ((kind (checked-entropy-argument 'make-entropy-source s))
             (es (alist-ref kind ess eq?)) )
        (or es
            (let ((es (new-entropy-source s)))
              (set! ess (alist-update! kind es ess eq?))
              es ) ) ) ) ) )

(define (entropy-source-kind e)
  (check-entropy-source 'entropy-source-kind e)
  (*entropy-source-kind e) )

(define (entropy-source-documentation e)
  (check-entropy-source 'entropy-source-documentation e)
  (*entropy-source-documentation e) )

(define (entropy-source-u8vector e n #!optional vec)
  (check-entropy-source 'entropy-source-u8vector e)
  (check-positive-fixnum 'entropy-source-u8vector n)
  (when vec (check-u8vector 'entropy-source-u8vector vec))
  ((@entropy-source-u8vector e) n vec) )

(define (entropy-source-f64vector e n #!optional vec)
  (check-entropy-source 'entropy-source-f64vector e)
  (check-positive-fixnum 'entropy-source-f64vector n)
  (when vec (check-f64vector 'entropy-source-f64vector vec))
  ((@entropy-source-f64vector e) n vec) )

(define (entropy-source-u8 e)
  (check-entropy-source 'entropy-source-u8 e)
  (@entropy-source-u8 e) )

(define (entropy-source-f64 e)
  (check-entropy-source 'entropy-source-f64 e)
  (@entropy-source-f64 e) )

;;;

(define-parameter current-random-source (make-random-source #:MRG32k3a)
  (lambda (x)
    (cond ((random-source? x) x)
          (else
            (warning-argument-type 'current-random-source x 'random-source)
            (current-random-source) ) ) ) )

;;

(define default-random-source (current-random-source))

(define random-integer ((@random-source-make-integers default-random-source)))

(define random-real ((@random-source-make-reals default-random-source)))

;;

(define (make-random-source #!optional (s (current-random-source)))
  (let ((kind (cond ((symbol? s)        s) ;keyword is-a symbol
                    ((random-source?   s) (*random-source-kind s))
                    (else
                      (error-argument-type 'make-random-source
                                           s "symbol or random-source" 'source)))))
    (cond ((registered-random-source kind) => (cut <> kind))
          (else
            (error-argument-type 'make-random-source kind "registered random-source") ) ) ) )

(define (random-source-kind s)
  (check-random-source 'random-source-kind s)
  (*random-source-kind s) )

(define (random-source-documentation s)
  (check-random-source 'random-source-documentation s)
  (*random-source-documentation s) )

(define (random-source-log2-period s)
  (check-random-source 'random-source-log2-period s)
  (*random-source-log2-period s) )

(define (random-source-maximum-range s)
  (check-random-source 'random-source-maximum-range s)
  (*random-source-maximum-range s) )

(define (random-source-maximum-modulus s)
  (check-random-source 'random-source-maximum-modulus s)
  (*random-source-maximum-modulus s) )

(define (random-source-state-ref s)
  (check-random-source 'random-source-state-ref s)
  ((@random-source-state-ref s)) )

(define (random-source-state-set! s state)
  (check-random-source 'random-source-state-set! s)
  ((@random-source-state-set! s) state) )

(define (random-source-randomize! s #!optional (e (current-entropy-source)))
  (check-random-source 'random-source-randomize! s)
  (check-entropy-source 'random-source-randomize! e)
  ((@random-source-randomize! s) e) )

(define (random-source-pseudo-randomize! s i j)
  (check-random-source 'random-source-pseudo-randomize! s)
  (check-cardinal-integer 'random-source-pseudo-randomize! i)
  (check-cardinal-integer 'random-source-pseudo-randomize! j)
  ((@random-source-pseudo-randomize! s) i j) )

(define (random-source-make-integers s)
  (check-random-source 'random-source-make-integers s)
  ((@random-source-make-integers s)) )

(define (random-source-make-reals s #!optional u)
  (check-random-source 'random-source-make-reals s)
  (when u (check-real-unit 'random-source-make-reals u 'unit))
  ((@random-source-make-reals s) u) )

) ;module srfi-27