;;;; composite-entropy-source.scm
;;;; Kon Lovett, Apr, '17

#|
=== Composite Entropy Source

==== Usage

<enscript language=scheme>
(import composite-entropy-source)
</enscript>

==== composite-entropy-source

<procedure>(composite-entropy-source-constructor [ENTROPY-SOURCE ...] [#:comb-int (COMB-INT INTEGER-COMBINE)] [#:comb-real (COMB-REAL REAL-COMBINE)]) => entropy-source</procedure>

Returns a new {{entropy-source}} that combines the behaviors of the supplied
{{ENTROPY-SOURCE ...}}.

{{INTEGER-COMBINE}} default is {{(lambda (ints bnd) (modulo (apply + ints) bnd))}}.

{{REAL-COMBINE}} default is {{(lambda (reals prec) (apply * reals))}}.

Does not register the constructed {{entropy-source}}.

Experimental at best.
|#

(module composite-entropy-source

(;export
  *composite-entropy-source-constructor
  composite-entropy-source-constructor)

(import scheme
  (chicken base)
  (chicken type)
  (chicken keyword)
  (chicken fixnum)
  (chicken flonum)
  (only (chicken string) conc reverse-string-append ->string)
  type-errors-basic
  (srfi 1)
  (srfi 4)
  entropy-source
  srfi-27-vector-support
  (srfi 27))

;;;

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

(: composite-entropy-source-constructor (#!rest -> procedure))
(: *composite-entropy-source-constructor (procedure procedure entropy-source-name string (list-of entropy-source) -> procedure))

;;

(define (pull-rest-argument rest0)
  (let loop ((irest rest0) (orest '()))
    (cond ((null? irest)
            (reverse! orest) )
          ((keyword? (car irest))
            (loop (cddr irest) orest) )
          (else
            (loop (cdr irest) (cons (car irest) orest)) ) ) ) )

;; composite-entropy-source-constructor
;;
;; returns the composite name & constructor

;FIXME - the combinators are suspect

(define (composite-entropy-source-constructor
          #!rest rest0
          #!key
          (comb-int (lambda (ints n) (modulo (reduce fx+ 0 ints) n)))
          (comb-real (lambda (reals unit) (reduce fp* 1.0 reals))))
  ;scrub keyword arguments
  (let* ((rest (pull-rest-argument rest0))
         (srcs0
           (if (null? rest)
               (error 'composite-entropy-source-constructor "no entropy-sources to combine")
               (map (cut check-entropy-source 'composite-entropy-source-constructor <>) rest))) )
    ;collect features
    (let loop ((srcs srcs0) (names '()) (docus '()))
      (if (null? srcs)
          ;then make composed entropy-source
          (*composite-entropy-source-constructor
            comb-int comb-real
            (string->symbol (reverse-string-append (intersperse names "+")))
            (reverse-string-append (intersperse docus " & "))
            srcs0)
          ;else collect info
          (let ((es (car srcs)))
            (loop
              (cdr srcs)
              (cons (->string (*entropy-source-name es)) names)
              (cons (*entropy-source-documentation es) docus)) ) ) ) ) )

;; *composite-entropy-source-constructor
;;
;; returns the composite constructor

(define (*composite-entropy-source-constructor comb-int comb-real def-name def-docu srcs)
  (let ((u8proc
          (lambda ()
            (comb-int
              (map (lambda (es) ((@entropy-source-u8 es))) srcs)
              255) ) )
        (f64proc
          (lambda ()
            (comb-real
              (map (lambda (es) ((@entropy-source-f64 es))) srcs)
              #f) ) ) )
    (letrec ((ctor
              (lambda (#!optional (name def-name) (docu def-docu))
                (*make-entropy-source
                  ;
                  ctor
                  ;
                  name
                  ;
                  docu
                  ;
                  u8proc
                  ;
                  f64proc
                  ;
                  (lambda (u8cnt u8vec)
                    (let ((u8vec (or u8vec (make-u8vector u8cnt))))
                      (u8vector-filled! u8vec u8proc 0 u8cnt)
                      u8vec ) )
                  ;
                  (lambda (f64cnt f64vec)
                    (let ((f64vec (or f64vec (make-f64vector f64cnt))))
                      (f64vector-filled! f64vec f64proc 0 f64cnt)
                      f64vec ) ) ) ) ) )
      ctor ) ) )

) ;module composite-entropy-source