;;;; random-system.scm
;;;; Kon Lovett, Oct '21

(module random-system

(;export
  make-random-source-system)

(import scheme
  (chicken base)
  (chicken foreign)
  (only (chicken flonum) maximum-flonum)
  (chicken random)
  (only (srfi 4)
    make-u8vector u8vector? u8vector-length
    u8vector->blob blob->u8vector
    u8vector->blob/shared blob->u8vector/shared)
  (type-checks-numbers integer)
  random-source
  entropy-source)

;;;

#; ;UNUSED
(define (blob-copy old)
  (import (only (chicken blob) make-blob blob-size))
  (import (only (chicken memory) move-memory!))
  (let ((new (make-blob (blob-size old))))
    (move-memory! old new )
    new ) )

#; ;UNUSED
(define (entropy-source-blob es n blb)
  (u8vector->blob/shared (entropy-source-u8vector es n (blob->u8vector/shared blb))) )

(define (u8vector-copy vec)
  (blob->u8vector/shared (u8vector->blob vec)) )

(define (entropy-source-u8vector es n vec)
  ((@entropy-source-u8vector es) n vec) )

;;;

(define fpMAX maximum-flonum)
(define-constant LOG2-PERIOD 512)

#; ;UNUSED
(define eMAX (inexact->exact fpMAX)) ;Create a "bignum" if necessary

(define STATE-LENGTH (foreign-value "C_RANDOM_STATE_SIZE" unsigned-int))

(define-constant INTERNAL-ID 'system)
(define-constant EXTERNAL-ID 'system)

;;;

(define (set-seed! state)
  (set-pseudo-random-seed! (u8vector->blob/shared state))
  state )

(define (init-state state) (random-bytes (u8vector->blob/shared state)))

(define (make-state) (make-u8vector STATE-LENGTH))

(define (system-initial-state)
  (let ((state (make-state)))
    (init-state state)
    state ) )

#; ;internal state unavailable
(define (external-state? obj)
  (and (pair? obj)
       (eq? EXTERNAL-ID (car obj))
       (u8vector? (cdr obj))
       ;lenient input
       (<= STATE-LENGTH (u8vector-length (cdr obj))) ) )

#; ;internal state unavailable
(define (system-unpack-state state)
  (cons EXTERNAL-ID (u8vector-copy state)) )

#; ;internal state unavailable
(define (system-pack-state external-state)
  (unless (external-state? external-state)
    (error 'system-pack-state "malformed state" external-state) )
  (u8vector-copy (cdr external-state)) )

(define (system-randomize-state state entropy-source)
  (entropy-source-u8vector entropy-source STATE-LENGTH state) )

(define (system-pseudo-randomize-state i j)
  (system-initial-state)
  #; ;FIXME incorporate pseudo-randomize
  (let ((state (make-state)))
    (init-state state (+ i j))
    state ) )

;;;

(define (make-random-source-system)
  (let ((state (set-seed! (system-initial-state))))
    (*make-random-source
      ;
      make-random-source-system
      ;
      EXTERNAL-ID
      ;
      "Random from system"
      ;
      LOG2-PERIOD
      ;
      fpMAX
      ;
      #f
      ;
      #; ;internal state unavailable
      (lambda () (system-unpack-state state))
      #f
      ;
      #; ;internal state unavailable
      (lambda (new-state) (set! state (set-seed! (system-pack-state new-state))))
      #f
      ;
      (lambda (entropy-source)
        (set! state (set-seed! (system-randomize-state state entropy-source))) )
      ;
      (lambda (i j)
        (set! state (set-seed! (system-pseudo-randomize-state i j))) )
      ;
      (lambda ()
        (lambda (n)
          (pseudo-random-integer (check-positive-integer INTERNAL-ID  n 'range)) ) )
      ;
      (lambda (prec)
        #; ;always true, eMAX = integer(fpMAX)
        (assert (native-real-precision? prec eMAX))
        pseudo-random-real ) ) ) )

;;;
;;; Module Init
;;;

(register-random-source! INTERNAL-ID make-random-source-system)

) ;module random-system