88 lines
2.9 KiB
Racket
88 lines
2.9 KiB
Racket
#lang racket
|
|
;;; returns a probabalistic choice from the sequence choices
|
|
;;; choices generates two values -- the chosen value and a
|
|
;;; probability (weight) of the choice.
|
|
;;;
|
|
;;; Note that a hash where keys are choices and values are probabilities
|
|
;;; is such a sequence.
|
|
;;;
|
|
;;; if the total probability < 1 then choice could return #f
|
|
;;; if the total probability > 1 then some choices may be impossible
|
|
(define (probabalistic-choice choices)
|
|
(let-values
|
|
(((_ choice) ;; the fold provides two values, we only need the second
|
|
;; the first will always be a negative number showing that
|
|
;; I've run out of random steam
|
|
(for/fold
|
|
((rnd (random))
|
|
(choice #f))
|
|
(((v p) choices)
|
|
#:break (<= rnd 0))
|
|
(values (- rnd p) v))))
|
|
choice))
|
|
|
|
;;; ditto, but all probabilities must be exact rationals
|
|
;;; the optional lcd
|
|
;;;
|
|
;;; not the most efficient, since it provides a wrapper (and demo)
|
|
;;; for p-c/i-w below
|
|
(define (probabalistic-choice/exact
|
|
choices
|
|
#:gcd (GCD (/ (apply gcd (hash-values choices)))))
|
|
(probabalistic-choice/integer-weights
|
|
(for/hash (((k v) choices))
|
|
(values k (* v GCD)))
|
|
#:sum-of-weights GCD))
|
|
|
|
;;; this proves useful in Rock-Paper-Scissors
|
|
(define (probabalistic-choice/integer-weights
|
|
choices
|
|
#:sum-of-weights (sum-of-weights (apply + (hash-values choices))))
|
|
(let-values
|
|
(((_ choice)
|
|
(for/fold
|
|
((rnd (random sum-of-weights))
|
|
(choice #f))
|
|
(((v p) choices)
|
|
#:break (< rnd 0))
|
|
(values (- rnd p) v))))
|
|
choice))
|
|
|
|
(module+ test
|
|
(define test-samples (make-parameter 1000000))
|
|
|
|
(define (test-p-c-function f w)
|
|
(define test-selection (make-hash))
|
|
(for* ((i (in-range 0 (test-samples)))
|
|
(c (in-value (f w))))
|
|
(when (zero? (modulo i 100000)) (eprintf "~a," (quotient i 100000)))
|
|
(hash-update! test-selection c add1 0))
|
|
(printf "~a~%choice\tcount\texpected\tratio\terror~%" f)
|
|
(for* (((k v) (in-hash test-selection))
|
|
(e (in-value (* (test-samples) (hash-ref w k)))))
|
|
(printf "~a\t~a\t~a\t~a\t~a%~%"
|
|
k v e
|
|
(/ v (test-samples))
|
|
(real->decimal-string
|
|
(exact->inexact (* 100 (/ (- v e) e)))))))
|
|
|
|
(define test-weightings/rosetta
|
|
(hash
|
|
'aleph 1/5
|
|
'beth 1/6
|
|
'gimel 1/7
|
|
'daleth 1/8
|
|
'he 1/9
|
|
'waw 1/10
|
|
'zayin 1/11
|
|
'heth 1759/27720; adjusted so that probabilities add to 1
|
|
))
|
|
|
|
(define test-weightings/50:50 (hash 'woo 1/2 'yay 1/2))
|
|
(define test-weightings/1:2:3 (hash 'woo 1 'yay 2 'foo 3))
|
|
|
|
(test-p-c-function probabalistic-choice test-weightings/50:50)
|
|
(test-p-c-function probabalistic-choice/exact test-weightings/50:50)
|
|
(test-p-c-function probabalistic-choice test-weightings/rosetta)
|
|
(test-p-c-function probabalistic-choice/exact test-weightings/rosetta))
|