diff --git a/embddr/random.scm b/embddr/random.scm new file mode 100644 index 0000000..d16f3be --- /dev/null +++ b/embddr/random.scm @@ -0,0 +1,83 @@ +(define-module (embddr random)) + +(import (srfi srfi-1) + (srfi srfi-27)) + +(export clean-constraints + constrained-random-generator) + +;;; +;;; Remove redundant (zero range) constraints. +;;; Limit weight in range (0..1] +;;; +(define (clean-constraints constrs) + (remove (lambda (c) + (let ((from (car c)) + (to (cadr c)) + (w (caddr c))) + (or (= from to) + (zero? w)))) + (map (lambda (c) + (let ((from (inexact->exact (round (car c)))) + (to (inexact->exact (round (cadr c)))) + (w (caddr c))) + (let ((w (cond + ((< w 0) 0) + ((> w 1) 1) + (else w)))) + (if (> from to) + (list to from w) + (list from to w))))) + constrs))) +;;; +;;; Make constrained random number generator. +;;; Constraints is list of '(from to weight) +;;; +(define (constrained-random-generator constrs) + (let ((constrs (clean-constraints constrs))) + (let* (;; Max weight / min weight ration + (weight-scale + (let ((weights (map caddr constrs))) + (/ (apply max weights) (apply min weights)))) + + ;; Place constraints to uniform linear axis + (constrs + (let loop ((constrs constrs) + (position 0) + (result '())) + (if (null? constrs) + (reverse result) + (let* ((c (car constrs)) + (from (car c)) + (to (cadr c)) + (w (caddr c)) + (l-range (* w weight-scale + (- to from)))) + (loop (cdr constrs) + (+ position l-range) + (cons (list position (+ position l-range) + from to w) + result)))))) + + ;; Linear range of required random number + (range + (apply max (map cadr constrs)))) + + ;; Make generator + (lambda () + (let* (;; Generate random from linear space + (rand-lin (random-integer range)) + + ;; Find corresponding constraint + (c + (find (lambda (c) + (and (>= rand-lin (car c)) + (< rand-lin (cadr c)))) + constrs))) + + ;; Scale random + (inexact->exact + (floor + (+ (caddr c) + (/ (- rand-lin (car c)) + (* weight-scale (list-ref c 4)))))))))))