From 9c93990b2146680761ae1471edb299c2dafd66ba Mon Sep 17 00:00:00 2001 From: Feufochmar Date: Mon, 4 Nov 2019 17:22:49 +0100 Subject: [PATCH] Add distrbution & markov --- distribution.rkt | 130 +++++++++++++++++++++++++++++++++++++++++++++++ markov.rkt | 108 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 238 insertions(+) create mode 100644 distribution.rkt create mode 100644 markov.rkt diff --git a/distribution.rkt b/distribution.rkt new file mode 100644 index 0000000..fc7bf40 --- /dev/null +++ b/distribution.rkt @@ -0,0 +1,130 @@ +#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) diff --git a/markov.rkt b/markov.rkt new file mode 100644 index 0000000..aeacbdf --- /dev/null +++ b/markov.rkt @@ -0,0 +1,108 @@ +#lang racket/base + +(require + racket/list + "distribution.rkt") +(provide make-markov + markov-add-example! + markov-add-next-item! + markov-generate + markov->jsexpr + jsexpr->markov) + +; Markov chain structure +(struct markov + (order ; order of the chain + next-items)) ; table of given sequence -> distributions of next possible items + +; Constructor +(define (make-markov [order 1]) + (markov order (make-hash))) + +; Add a example to the generator. The example is a sequence of values in a list. +(define (markov-add-example! mrk example) + (letrec + ((fill + (lambda (lst prev) + (let ((distro (hash-ref (markov-next-items mrk) prev #f)) + (next (if (null? lst) #f (car lst)))) + (if distro + (distribution-add-to! distro next) + (let ((new-distro (make-distribution))) + (distribution-add-to! new-distro next) + (hash-set! (markov-next-items mrk) prev new-distro))) + (when next (fill (cdr lst) (append (cdr prev) (list next)))) + )))) + (fill example (make-list (markov-order mrk) #f)) + )) + +; Add a possible next item from a sequence +; Use this to regenerate a markov chain from a serialized version (ie not from examples) +(define (markov-add-next-item! mrk seq next [occurences 1]) + (let ((distro (hash-ref (markov-next-items mrk) seq #f))) + (if distro + (distribution-add-to! distro next occurences) + (let ((new-distro (make-distribution))) + (distribution-add-to! new-distro next occurences) + (hash-set! (markov-next-items mrk) seq new-distro))))) + +; Generate a list with the given initial sequence +(define (generate-list next-items result previous) + (let ((next (distribution-pick-from (hash-ref next-items previous)))) + (if (not next) + (reverse result) + (generate-list next-items (cons next result) (append (cdr previous) (list next)))))) + +; Get a suitable starting sequence from the given list +(define (find-starting-sequence next-items initial) + ; If the given sequence is a suitable sequence, return it + (if (hash-has-key? next-items initial) + initial + (letrec + ; rating function to compare two sequences + ((rate + (lambda (result a b) + (if (or (null? a) (null? b)) + result + (rate (+ result (if (equal? (car a) (car b)) 1 0)) (cdr a) (cdr b)))))) + ; the suitable starting sequence is the one that get the best result with the rate function when compared to the initial sequence + (caar + (sort + (map + (lambda (lst) (cons lst (rate 0 (reverse lst) (reverse initial)))) ; The starting sequence is more suitable is we start from the last elements + (shuffle + (hash-keys next-items))) + (lambda (a b) (> (cdr a) (cdr b)))))))) + +; Generate a list from the chain +(define (markov-generate mrk [initial #f]) + (if initial + (let ((prev (find-starting-sequence (markov-next-items mrk) initial))) + (generate-list (markov-next-items mrk) (reverse initial) prev)) + (generate-list (markov-next-items mrk) (list) (make-list (markov-order mrk) #f)))) + +; Serialisation to a json-compatible structure +; It is possible to pass a translator function for converting values that are not compatible to json +(define (markov->jsexpr mrk #:translator [tr (lambda (x) x)]) + (make-immutable-hash + `((order . ,(markov-order mrk)) + (next . ,(hash-map + (markov-next-items mrk) + (lambda (k v) + (make-immutable-hash + `((sequence . ,(map tr k)) + (distribution . ,(distribution->jsexpr v #:translator tr))))))) + ))) + +; 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->markov js #:translator [tr (lambda (x) x)]) + (define mrk (make-markov (hash-ref js 'order))) + (for-each + (lambda (x) + (hash-set! + (markov-next-items mrk) + (map tr (hash-ref x 'sequence)) + (jsexpr->distribution (hash-ref x 'distribution) #:translator tr))) + (hash-ref js 'next)) + mrk)