131 lines
4.5 KiB
Racket
131 lines
4.5 KiB
Racket
#lang racket/base
|
|
|
|
(provide
|
|
make-distribution
|
|
distribution-pick-from
|
|
distribution-add-to!
|
|
distribution-contains?
|
|
distribution-check-only
|
|
distribution-linear-combination
|
|
distribution-items
|
|
distribution->jsexpr
|
|
jsexpr->distribution)
|
|
|
|
; Distribution structure
|
|
; Distributions are list of items associated to a number indicating its frequency.
|
|
; When an element is picked from the list, the frequency of the items is taken into account.
|
|
(struct distribution
|
|
([total #:mutable] ; total number of elements in the distribution
|
|
[lst-items #:mutable] ; same as items, but in a assoc-list
|
|
items)) ; hash item -> number of occurences
|
|
|
|
; Add an item to the distribution, with its number of occurences
|
|
(define (distribution-add-to! d itm [additionnal-occurences 1])
|
|
(let ((occurences (hash-ref (distribution-items d) itm 0)))
|
|
(hash-set! (distribution-items d) itm (+ occurences additionnal-occurences))
|
|
(set-distribution-lst-items! d (hash->list (distribution-items d)))
|
|
(set-distribution-total! d (+ (distribution-total d) additionnal-occurences))
|
|
))
|
|
|
|
; Syntax to build a distribution from the items and theirs occurences
|
|
; Note: the item is quoted
|
|
(define-syntax make-distribution
|
|
(syntax-rules (*)
|
|
; No arguments - default constructor
|
|
((make-distribution)
|
|
(distribution 0 (list) (make-hash)))
|
|
; default syntax
|
|
((make-distribution (id val) ...)
|
|
(let ((dist (make-distribution)))
|
|
(begin
|
|
(distribution-add-to! dist (quote id) val) ...)
|
|
dist))
|
|
; From a list and default values
|
|
((make-distribution lst (* default-val))
|
|
(let ((dist (make-distribution)))
|
|
(for-each
|
|
(lambda (x) (distribution-add-to! dist x default-val))
|
|
lst)
|
|
dist))
|
|
; From a list, default values and values overriding the defaults
|
|
((make-distribution lst (* default-val) (id val) ...)
|
|
(let ((h (make-hash))
|
|
(dist (make-distribution)))
|
|
(for-each
|
|
(lambda (x) (hash-set! h x default-val))
|
|
lst)
|
|
(begin
|
|
(hash-set! h (quote id) val) ...)
|
|
(hash-for-each h (lambda (k v) (distribution-add-to! dist k v)))
|
|
dist))
|
|
; With a useless list
|
|
((make-distribution lst (id val) ...)
|
|
(let ((dist (make-distribution)))
|
|
(begin
|
|
(distribution-add-to! dist (quote id) val) ...)
|
|
dist))
|
|
))
|
|
|
|
; Pick from a distribution
|
|
(define (distribution-pick-from d)
|
|
(letrec ((search
|
|
(lambda (lst subtotal roll)
|
|
(let ((new-subtotal (+ subtotal (cdar lst))))
|
|
(if (< roll new-subtotal)
|
|
(caar lst)
|
|
(search (cdr lst) new-subtotal roll)))
|
|
)))
|
|
(search (distribution-lst-items d) 0 (random (distribution-total d)))
|
|
))
|
|
|
|
; Check if an item is in the distribution
|
|
(define (distribution-contains? d itm)
|
|
(hash-has-key? (distribution-items d) itm))
|
|
|
|
; Check if there are unkown items in the distribution
|
|
; Raise an error if an unkown item is present
|
|
(define (distribution-check-only d known-items)
|
|
(hash-for-each
|
|
(distribution-items d)
|
|
(lambda (k v)
|
|
(when (not (member k known-items))
|
|
(error "Distribution contains an unknown item: " k)))))
|
|
|
|
; Linear combination of distributions
|
|
; Make a new distribution from a dotted list of distributions and their weight
|
|
(define (distribution-linear-combination dists)
|
|
(let ((d (make-distribution)))
|
|
(for-each
|
|
(lambda (x)
|
|
(let ((itms
|
|
(hash-map
|
|
(distribution-items (car x))
|
|
(lambda (k v)
|
|
(cons k (/ v (distribution-total (car x))))))))
|
|
(for-each
|
|
(lambda (itm)
|
|
(distribution-add-to! d (car itm) (truncate (* (cdr x) (cdr itm) 100)))) ; * 100 and truncate because (cdr itm) is reduced
|
|
itms)))
|
|
dists)
|
|
d))
|
|
|
|
; Serialisation to a json-compatible structure
|
|
; It is possible to pass a translator function for converting values that are not compatible to json
|
|
(define (distribution->jsexpr dist #:translator [tr (lambda (x) x)])
|
|
(hash-map
|
|
(distribution-items dist)
|
|
(lambda (k v)
|
|
(make-immutable-hash
|
|
`((value . ,(tr k))
|
|
(count . ,v))))))
|
|
|
|
; Deserialisation from a json-compatible structure
|
|
; It is possible to pass a translator function for converting values that are not compatible to json
|
|
(define (jsexpr->distribution js #:translator [tr (lambda (x) x)])
|
|
(define dist (make-distribution))
|
|
(for-each
|
|
(lambda (x)
|
|
(distribution-add-to! dist (tr (hash-ref x 'value)) (hash-ref x 'count)))
|
|
js)
|
|
dist)
|