;;;; composite-random-source.scm
;;;; Kon Lovett, Oct '09

#|
=== Composite Random Source

==== Usage

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

==== composite-random-source-constructor

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

Returns a new {{random-source}} that combines the behaviors of the supplied
{{RANDOM-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 {{random-source}}.

Experimental at best.
|#

(module composite-random-source

(;export
  *composite-random-source-constructor
  composite-random-source-constructor
  make-composite-random-state-predicate
  composite-random-state?
  composite-state-ref composite-state-set!)

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

;;;

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

(define-type composite-random-source-state (list-of *))

(: composite-random-source-constructor (#!rest -> procedure))
(: *composite-random-source-constructor (procedure procedure random-source-name string number number (list-of random-source) -> procedure))
(: make-composite-random-state-predicate (random-source-name #!optional (or fixnum (list-of random-source)) -> procedure))
(: composite-random-state? (* random-source-name (or fixnum (list-of random-source)) -> boolean))
(: composite-state-ref (random-source -> composite-random-source-state))
(: composite-state-set! (random-source composite-random-source-state -> void))

;;

(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-random-source-constructor
;;
;; returns the composite name & constructor
;;
;; ((list-of (integer exact (<= 0 _ _2))) (integer exact positive)
;;  -> (integer exact (<= 0 _ _2)))
;;
;; composite-random-real
;; ((list-of (real inexact (< 0.0 _ 1.0))) #!optional (real inexact (< 0.0 _2 1.0))
;;  -> (real inexact (< 0.0 _ 1.0)))

;FIXME - the combinators are suspect

(define (composite-random-source-constructor
          #!rest rest0
          #!key
          (comb-int (lambda (ints n) (modulo (reduce + 0 ints) n)))
          (comb-real (lambda (reals unit) (reduce * 1.0 reals))))
  ;scrub keyword arguments
  (let* (
      (rest (pull-rest-argument rest0) )
      (srcs0
        (if (null? rest)
          (error 'composite-random-source-constructor "empty random-sources")
          (map (cut check-random-source 'composite-random-source-constructor <>) rest) ) ) )
    ;collect features
    (let loop ((srcs srcs0) (names '()) (docus '()) (log2-periods '()) (maxrngs '()))
      (if (null? srcs)
        ;then make composed random-source
        (*composite-random-source-constructor
          comb-int comb-real
          (string->symbol (reverse-string-append (intersperse names "+")))
          (reverse-string-append (intersperse docus " & "))
          ;FIXME minimum? (if this is good then apply along the way)
          (apply min log2-periods)
          (apply min maxrngs)
          srcs0)
        ;else collect info
        (let ((rs (car srcs)))
          (loop
            (cdr srcs)
            (cons (->string (*random-source-name rs)) names)
            (cons (*random-source-documentation rs) docus)
            (cons (*random-source-log2-period rs) log2-periods)
            (cons (*random-source-maximum-range rs) maxrngs)) ) ) ) ) )

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

(define (*composite-random-source-constructor comb-int comb-real def-name def-docu log2-period maxrng srcs)
  (let (
    (srcs-cnt (length srcs))
    (composite-make-integers (map random-source-make-integers srcs)) )
    (letrec (
        (ctor
          (lambda (#!optional (name def-name) (docu def-docu))
            (let ((name-state-set!-id (string->symbol (conc name #\- 'state-set!))))
              (*make-random-source
                ;
                ctor
                ;
                name
                ;
                docu
                ;
                log2-period
                ;
                maxrng
                ;entropy-source
                #f
                ;state-ref
                (lambda ()
                  (cons name (map composite-state-ref srcs)))
                ;state-set!
                (lambda (state)
                  (if (composite-random-state? state name srcs-cnt)
                    (for-each composite-state-set! srcs (cdr state))
                    (error-argument-type name-state-set!-id state 'composite-random-state) ) )
                ;randomize!
                (lambda (es)
                  (for-each (lambda (rs) ((@random-source-randomize! rs) es)) srcs) )
                ;pseudo-randomize!
                (lambda (i j)
                  (for-each (lambda (rs) ((@random-source-pseudo-randomize! rs) i j)) srcs) )
                ;make-integers
                (lambda ()
                  (lambda (n)
                    (comb-int (map (cut <> n) composite-make-integers) n)))
                ;make-reals
                (lambda (unit)
                  (let (
                    (makrels (map (lambda (rs) ((@random-source-make-reals rs) unit)) srcs)) )
                    (lambda ()
                      (comb-real (map (cut <>) makrels) unit) ) ) ) ) ) ) ) )
      ctor ) ) )

;;

(define (make-composite-random-state-predicate name #!optional srcs)
  (let (
    (*n*
      (cond
        ((list? srcs)
          (length srcs))
        ((number? srcs)
          srcs)
        (else
          #f))) )
    (lambda (obj)
      (and
        (pair? obj)
        (eq? name (car obj))
        (or (not *n*) (fx= *n* (fx- (length (cdr obj)) 1)))) ) ) )

(define (composite-random-state? obj name srcs)
  ((make-composite-random-state-predicate name srcs) obj) )

(define (composite-state-ref rs)
  ((@random-source-state-ref rs)) )

(define (composite-state-set! rs state)
  ((@random-source-state-set! rs) state) )

) ;module composite-random-source