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

;Protions
;Copyright (C) Sebastian Egner (2002). All Rights Reserved.
;
;Permission is hereby granted, free of charge, to any person obtaining a copy
;of this software and associated documentation files (the "Software"), to deal
;in the Software without restriction, including without limitation the rights
;to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;copies of the Software, and to permit persons to whom the Software is
;furnished to do so, subject to the following conditions:
;
;The above copyright notice and this permission notice shall be included in all
;copies or substantial portions of the Software.
;
;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;SOFTWARE.

(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
  registered-random-sources registered-random-source ;re-export random-source
  current-random-source
  current-random-integer
  current-random-real
  new-random-source
  random-source-name 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
  ;
  default-entropy-source
  registered-entropy-sources registered-entropy-source ;re-export entropy-source
  current-entropy-source
  make-entropy-source new-entropy-source
  entropy-source? check-entropy-source error-entropy-source
  entropy-source-name entropy-source-kind
  entropy-source-documentation
  entropy-source-u8
  entropy-source-f64
  entropy-source-u8vector
  entropy-source-f64vector)

(import scheme
  (chicken base)
  (chicken platform)
  (chicken type)
  (only (srfi 4) make-u8vector make-f64vector)
  (only miscmacros define-parameter)
  (only type-checks-numbers check-natural-integer)
  (only type-errors error-argument-type warning-argument-type)
  (only srfi-27-numbers check-real-precision)
  (only srfi-27-vector-support u8vector-filled! f64vector-filled!)
  type-checks
  srfi-4-checks
  random-source
  entropy-source
  mrg32k3a
  entropy-clock)

(register-feature! 'srfi-27)

;;;

(include "srfi-27-common-types")

(: default-entropy-source entropy-source)
(: current-entropy-source (#!optional entropy-source -> entropy-source))
(: make-entropy-source (#!optional entropy-source -> entropy-source))
(: new-entropy-source (entropy-source -> entropy-source))
(: entropy-source-name (entropy-source --> entropy-source-name))
(: entropy-source-kind (entropy-source --> symbol))
(: entropy-source-u8vector (entropy-source fixnum #!optional u8vector -> u8vector))
(: entropy-source-f64vector (entropy-source fixnum #!optional f64vector -> f64vector))
(: entropy-source-u8 (entropy-source --> random-u8-function))
(: entropy-source-f64 (entropy-source --> random-f64-function))
(: default-random-source random-source)
(: random-integer random-integer-function)
(: random-real random-real-function)
(: random-u8vector (fixnum -> u8vector))
(: random-f64vector (fixnum -> f64vector))
(: current-random-source (#!optional random-source -> random-source))
(: current-random-integer (-> fixnum))
(: current-random-real (-> float))
(: make-random-source (#!optional random-source -> random-source))
(: new-random-source (#!optional random-source -> random-source))
(: random-source-name (random-source --> random-source-name))
(: random-source-documentation (random-source --> string))
(: random-source-log2-period (random-source --> float))
(: random-source-maximum-range (random-source --> float))
(: random-source-entropy-source (random-source -> random-source-entropy-source))
(: random-source-entropy-source-set! (random-source (or false entropy-source) -> void))
(: random-source-state-ref (random-source -> (or false random-source-state)))
(: random-source-state-set! (random-source (or false random-source-state) -> void))
(: random-source-randomize! (random-source #!optional entropy-source -> void))
(: random-source-pseudo-randomize! (random-source fixnum fixnum -> void))
(: random-source-make-integers (random-source --> random-integer-function))
(: random-source-make-reals (random-source #!optional fixnum --> random-real-function))
(: random-source-make-u8vectors (random-source -> random-u8vector-function))
(: random-source-make-u8vectors (random-source -> random-f64vector-function))

;;;

;;; 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 (
    (ctor
      (cond
        ((entropy-source? es)
          (@entropy-source-constructor es) )
        ((symbol? es)
          (registered-entropy-source es) )
        (else
          #f ) ) ) )
    (unless ctor
      (error-argument-type
        'make-entropy-source es
        "valid entropy-source or registered entropy-source name") )
    (ctor) ) )

(define (new-entropy-source es)
  ((@entropy-source-constructor (check-entropy-source 'new-entropy-source es))) )

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

(define (entropy-source-kind es) (entropy-source-name es))

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

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

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

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

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

;;; Random Source

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

(define (*random-source-make-f64vectors rs prec)
  (let (
    (*rnd* ((@random-source-make-reals rs) prec)) )
    (lambda (n)
      (f64vector-filled!
        (make-f64vector (check-natural-integer 'random-source-make-f64vector n 'length))
        *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 (current-random-integer)
  ((@random-source-make-integers (current-random-source))) )

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

(define (make-random-source #!optional (rs (current-random-source)))
  (let (
    (ctor
      (cond
        ((random-source? rs)
          (@random-source-constructor rs) )
        ((symbol? rs)
          (registered-random-source rs) )
        (else
          #f ) ) ) )
    (unless ctor
      (error-argument-type
        'make-random-source rs
        "valid random-source or registered random-source name") )
    (ctor) ) )

(define (new-random-source #!optional (rs (current-random-source)))
  ((@random-source-constructor (check-random-source 'new-random-source rs))) )

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

(define random-source-kind random-source-name)

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

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

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

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

(define (random-source-entropy-source-set! rs es)
  (*random-source-entropy-source-set!
    (check-random-source 'random-source-entropy-source-set! rs)
    ;#f indicates no set entropy-source
    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )

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

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

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

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

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

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

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

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

;;;

) ;module srfi-27