Add constrained random number generator

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)))))))))))