83 lines
2.7 KiB
Scheme
83 lines
2.7 KiB
Scheme
(define-module (embddr random))
|
|
|
|
(import (srfi srfi-1)
|
|
(srfi srfi-27))
|
|
|
|
(export clean-constraints
|
|
constrained-random-generator)
|
|
|
|
;;;
|
|
;;; Remove redundant (zero range) constraints.
|
|
;;; Limit the weight value in positive range
|
|
;;;
|
|
(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 (let ((w (caddr c)))
|
|
(if (< w 0) 0 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), where
|
|
;;; 'from' - inclusive bottom limit, 'to' - exclusive
|
|
;;; top limit or random range.
|
|
;;;
|
|
(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)))))))))))
|