;;;; entropy-source.scm
;;;; Kon Lovett, Apr '26
;;;; Kon Lovett, Sep '23
;;;; Kon Lovett, Oct '09

(module entropy-source

(;export
  *make-entropy-source
  entropy-source? check-entropy-source error-entropy-source
  *entropy-source-name
  *entropy-source-documentation
  @entropy-source-constructor
  @entropy-source-u8
  @entropy-source-f64
  @entropy-source-u8vector
  @entropy-source-f64vector
  ;
  entropy-source-integer
  entropy-source-f64-integer
  ;
  registered-entropy-sources
  registered-entropy-source
  unregister-entropy-source
  register-entropy-source!)

(import
  scheme
  (chicken base)
  (chicken type)
  (only (srfi 1) alist-cons alist-delete!)
  (only type-checks-basic define-check+error-type)
  (only type-checks-structured check-procedure)
  (only type-checks-atoms check-symbol)
  source-registration)

;;;

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

(: *make-entropy-source ((-> entropy-source) entropy-source-name string
                          (-> fixnum) (-> float)
                          (fixnum #!optional u8vector -> u8vector) (fixnum #!optional f64vector -> f64vector)
                          -> entropy-source))
(: entropy-source? (* -> boolean : entropy-source))
(: check-entropy-source ((or false symbol string) * #!optional (or symbol string) -> entropy-source))
(: error-entropy-source ((or false symbol string) * #!optional (or symbol string) -> void))
(: @entropy-source-constructor (entropy-source -> (-> entropy-source)))
(: *entropy-source-name (entropy-source -> entropy-source-name))
(: *entropy-source-documentation (entropy-source -> string))
(: @entropy-source-u8 (entropy-source -> (-> fixnum)))
(: @entropy-source-f64 (entropy-source -> (-> float)))
(: @entropy-source-u8vector (entropy-source -> (fixnum #!optional u8vector -> u8vector)))
(: @entropy-source-f64vector (entropy-source -> (fixnum #!optional f64vector -> f64vector)))

(: entropy-source-integer (entropy-source -> integer))
(: entropy-source-f64-integer (entropy-source -> float))

(: registered-entropy-sources (-> (list-of entropy-source)))
(: registered-entropy-source (entropy-source-name -> (or false entropy-source)))
(: unregister-entropy-source (entropy-source-name -> void))
(: register-entropy-source! (entropy-source-name (-> entropy-source) -> void))

;;;

;;

(define-record-type entropy-source
  (*make-entropy-source ctor name docu u8 f64 u8vec f64vec)
  entropy-source?
  (ctor       @entropy-source-constructor)
  (name       *entropy-source-name)
  (docu       *entropy-source-documentation)
  (u8         @entropy-source-u8)
  (f64        @entropy-source-f64)
  (u8vec      @entropy-source-u8vector)
  (f64vec     @entropy-source-f64vector) )

(define-check+error-type entropy-source)

;;

(define (entropy-source-f64-integer es)
  ;FIXME nondeterministic - P(integer(float)) ?
  (let ((genf64 (@entropy-source-f64 es)))
    (let loop ((x (genf64)))
      (if (integer? x) x
          (loop (genf64)) ) ) ) )

(define (entropy-source-integer es) (inexact->exact (entropy-source-f64-integer es)))

;; Entropy Source Constructor Registry


(define registered-entropy-sources)
(define registered-entropy-source)
(define unregister-entropy-source)
(define register-entropy-source!)
(let ((+reg+ (make-source-registration 'entropy-source '())))

  (set! registered-entropy-sources
    (lambda ()
      ((@source-registration-key +reg+))))

  (set! registered-entropy-source
    (lambda (name)
      ((@source-registration-ref +reg+) name)))

  (set! unregister-entropy-source
    (lambda (name)
      ((@source-registration-deref! +reg+) name)))

  (set! register-entropy-source!
    (lambda (name ctor)
      ((@source-registration-register! +reg+) name ctor))) )

) ;entropy-source