guile-examples/randomness/random-number-generator.scm

(library (random-number-generator)
  (export make-random-integer-generator
          make-random-floats-generator
          generate-n-unique-integers
          generate-random-list
          generate-n-integers
          generate-n-floats)
  (import (except (rnrs base) error map)
          (only (guile)
                lambda* λ
                ;; output
                simple-format
                ;; error "handling"
                error
                ;; control flow
                when
                unless)
          ;; SRFI 1: list procedures
          (srfi srfi-1)
          ;; SRFI-27 for random number utilities
          (srfi srfi-27)
          ;; SRFI 43: vectors
          (srfi srfi-43)
          ;; SRFI 69: hash tables
          (srfi srfi-69)

          (ice-9 pretty-print)
          (ice-9 match)

          ;; purely functional data structures
          (pfds sets)
          ;; for fisher-yates-shuffle
          (only (shuffling) fisher-yates-shuffle))


  (define make-random-integer-generator
    (lambda* (#:key (seed #f))
      "Get a procedure for generating uniformly distributed
random integers from 0 up to a not included bound, which is
seeded by the keyword argument seed, which must be a
positive integer."
      (cond
       [seed
        (let ([rand-src (make-random-source)])
          ;; Set the given seed to guarantee same results for
          ;; same invokations.
          (random-source-pseudo-randomize! rand-src 0 seed)
          ;; Obtain a procedure, which gives uniformly
          ;; distributed integers.
          (random-source-make-integers rand-src))]
       [else
        (let ([rand-src (make-random-source)])
          ;; Try to make the random source truly random. How
          ;; this works depends on the specific implementation
          ;; of SRFI-27.
          (random-source-randomize! rand-src)
          (random-source-make-integers rand-src))])))


  (define make-random-floats-generator
    (lambda* (#:key (seed #f))
      "Get a procedure for generating uniformly distributed
random floats from 0 up to a not included bound, which is
seeded by the keyword argument seed, which must be a
positive integer."
      (cond
       [seed
        (let ([rand-src (make-random-source)])
          ;; Set the given seed to guarantee same results for
          ;; same invokations.
          (random-source-pseudo-randomize! rand-src 0 seed)
          ;; Obtain a procedure, which gives uniformly
          ;; distributed integers.
          (random-source-make-reals rand-src))]
       [else
        (let ([rand-src (make-random-source)])
          ;; Try to make the random source truly random. How
          ;; this works depends on the specific implementation
          ;; of SRFI-27.
          (random-source-randomize! rand-src)
          (random-source-make-reals rand-src))])))


  (define generate-n-unique-integers
    (lambda* (n
              minimum
              maximum
              #:key (rng (make-random-integer-generator #:seed 12345)))
      (when (> n (- maximum minimum))
        (error
         (simple-format
          #f "range from ~a to ~a is too small for generating ~a unique integers"
          minimum maximum n)))
      (let ([gen-range (- maximum minimum)])
        ;; Need to shuffle, because set->list gives same result for
        ;; all sets which have the same entries, no matter in which
        ;; order the keys were added.
        (fisher-yates-shuffle
         (set->list
          (let iter ([gen-count° 0] [numbers° (make-set <)])
            (cond
             [(>= gen-count° n) numbers°]
             [else
              (let ([generated-num (rng gen-range)])
                (cond
                 [(set-member? numbers° generated-num)
                  (iter gen-count°
                        numbers°)]
                 [else
                  (iter (+ gen-count° 1)
                        (set-insert numbers° generated-num))]))])))
         #:rng rng))))


  (define generate-n-integers
    (lambda* (n
              minimum
              maximum
              #:key (rng (make-random-integer-generator #:seed 12345)))
      (let ([gen-range (- maximum minimum)])
        (let iter ([gen-count° 0] [numbers° '()])
          (cond
           [(>= gen-count° n) numbers°]
           [else
            (let ([generated-num (+ (rng gen-range) minimum)])
              (iter (+ gen-count° 1)
                    (cons generated-num numbers°)))])))))


  (define scale-float
    (λ (num mininum maximum)
      (let ([scaling-factor (- maximum mininum)])
        (+ (* num scaling-factor) mininum))))


  (define generate-n-floats
    (lambda* (n
              minimum
              maximum
              #:key (rng (make-random-floats-generator #:seed 12345)))
      (let iter ([gen-count° 0] [numbers° '()])
        (cond
         [(>= gen-count° n) numbers°]
         [else
          (let ([generated-num (scale-float (rng) minimum maximum)])
            (iter (+ gen-count° 1)
                  (cons generated-num numbers°)))]))))


  (define generate-random-list
    (lambda* (length
              event-limit-table
              #:key
              (rng (make-random-integer-generator #:seed 12345)))
      "Create a list of length LENGTH of randomly selected events
from the given hash table EVENT-COUNTS."

      (when (> length (apply + (hash-table-values event-limit-table)))
        (error "invalid arguments: length too high"))

      (let* ([result-vector (make-vector length)]
             [count-events (hash-table-fold event-limit-table
                                            (λ (key val previous)
                                              (+ previous val))
                                            0)]
             [random-indices (generate-n-unique-integers count-events
                                                         0
                                                         count-events
                                                         #:rng rng)])
        ;; Fill result vector for all events
        (let iter ([random-indices° random-indices]
                   [event-limit-alist° (hash-table->alist event-limit-table)])
          (cond
           [(null? event-limit-alist°)
            (vector->list result-vector)]
           [else
            (let* ([event (car (first event-limit-alist°))]
                   [count (cdr (first event-limit-alist°))])
              ;; (simple-format #t "filling result vector with event ~a count ~a\n" event count)
              ;; Fill result vector for a specific event.
              (let iter-single-event ([indices° (take random-indices° count)])
                ;; (simple-format #t "setting event ~a at indices ~a\n" event indices°)
                (unless (null? indices°)
                  (vector-set! result-vector
                               (first indices°)
                               event)
                  (iter-single-event (drop indices° 1))))
              (iter (drop random-indices° count)
                    (drop event-limit-alist° 1)))])))))


  #;(define make-random-uniform-sum-distribution-generator
    (λ (#:key (seed 12345))
      "Uniform sum distribution, also known as Irwin–Hall distribution."
      (let ([rng (make-random-integer-generator #:seed seed)])
        (λ ()
          ))))

  #;(define make-random-normal-distribution-generator
    (λ (#:key seed)
      ...
      ))
  )