;;;; 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? check-random-source error-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-entropy-source random-source-entropy-source-set!
    random-source-make-u8vectors
    random-source-make-f64vectors
    random-u8vector
    random-f64vector
    ;
    current-entropy-source
    make-entropy-source
    entropy-source? check-entropy-source error-entropy-source
    entropy-source-kind
    entropy-source-documentation
    entropy-source-u8
    entropy-source-f64
    entropy-source-u8vector
    entropy-source-f64vector)

  (import
    scheme
    chicken
    (only data-structures alist-ref alist-update!)
    (only srfi-4 make-u8vector make-f64vector)
    (only miscmacros define-parameter)
    type-checks
    srfi-4-checks
    (only type-errors error-argument-type warning-argument-type)
    random-source
    entropy-source
    entropy-clock
    mrg32k3a
    (only srfi-27-numbers check-real-precision)
    (only srfi-27-vector-support u8vector-filled! f64vector-filled!))

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

;;; Entropy Source

;;

(define default-entropy-source (make-entropy-source-system-clock))

;;

(define-parameter current-entropy-source default-entropy-source
  (lambda (x)
    (cond ((entropy-source? x) x)
          (else
            (warning-argument-type 'current-entropy-source x 'entropy-source)
            (current-entropy-source) ) ) ) )

(define (make-entropy-source #!optional (es (current-entropy-source)))
  (let ((kind (if (entropy-source? es) (*entropy-source-kind es) es)))
    (let ((maker (registered-entropy-source kind)))
      (if maker (maker)
          (error-argument-type 'make-entropy-source kind "registered entropy-source") ) ) ) )

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

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

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

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

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

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

;;; Random Source

(define (*random-source-make-u8vectors rs)
  (let ((rndint ((@random-source-make-integers rs))))
    (lambda (n)
      (check-cardinal-integer 'make-u8vector n 'length)
      (u8vector-filled! (make-u8vector n) (lambda () (modulo (rndint) 256))) ) ) )

(define (*random-source-make-f64vectors rs prec)
  (let ((rnd ((@random-source-make-reals rs) prec)))
    (lambda (n)
      (check-cardinal-integer 'make-f64vector n 'length)
      (f64vector-filled! (make-f64vector n) rnd) ) ) )

;;

(define default-random-source (make-random-source-mrg32k3a))

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

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

(define random-u8vector
  (let ((mkv (*random-source-make-u8vectors default-random-source)))
    (lambda (n) (mkv n) ) ) )

(define random-f64vector
  (let ((mkv (*random-source-make-f64vectors default-random-source #f)))
    (lambda (n) (mkv n) ) ) )

;;

(define-parameter current-random-source default-random-source
  (lambda (x)
    (cond ((random-source? x) x)
          (else
            (warning-argument-type 'current-random-source x 'random-source)
            (current-random-source) ) ) ) )

(define (make-random-source #!optional (rs (current-random-source)))
  (let ((kind (if (random-source? rs) (*random-source-kind rs) rs)))
    (let ((maker (registered-random-source kind)))
      (if maker (maker)
          (error-argument-type 'make-random-source kind "registered random-source") ) ) ) )

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

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

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

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

(define (random-source-entropy-source rs)
  (check-random-source 'random-source-entropy-source rs)
  (*random-source-entropy-source rs) )

(define (random-source-entropy-source-set! rs es)
  (check-random-source 'random-source-entropy-source-set! rs)
  (check-entropy-source 'random-source-entropy-source-set! es)
  (*random-source-entropy-source-set! rs es) )

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

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

(define (random-source-randomize! rs #!optional es)
  (check-random-source 'random-source-randomize! rs)
  (when es (check-entropy-source 'random-source-randomize! es))
  ((@random-source-randomize! rs)
    (or es (*random-source-entropy-source rs) (current-entropy-source))) )

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

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

(define (random-source-make-reals rs #!optional prec)
  (check-random-source 'random-source-make-reals rs)
  (when prec (check-real-precision 'random-source-make-reals prec 'precision))
  ((@random-source-make-reals rs) prec) )

(define (random-source-make-u8vectors rs)
  (check-random-source 'random-source-make-u8vectors rs)
  (*random-source-make-u8vectors rs) )

(define (random-source-make-f64vectors rs #!optional prec)
  (check-random-source 'random-source-make-f64vectors rs)
  (when prec (check-real-precision 'random-source-make-f64vectors prec 'precision))
  (*random-source-make-f64vectors rs prec) )

) ;module srfi-27