source: project/release/4/srfi-27/trunk/srfi-27-triangles.scm @ 35456

Last change on this file since 35456 was 35456, checked in by Kon Lovett, 17 months ago

begin typing, dep /

File size: 1.4 KB
Line 
1;;;; srfi-27-triangles.scm
2;;;; Kon Lovett, Dec '17
3;;;; Kon Lovett, Jun '17
4;;;; Kon Lovett, May '06
5
6; Chicken Generic Arithmetic! (could use fp routines)
7
8(module srfi-27-triangles
9
10(;export
11  *make-random-triangles
12  make-random-triangles)
13
14(import scheme chicken)
15
16(use
17  (only type-errors error-argument-type)
18  (only type-checks
19    define-check+error-type
20    check-procedure
21    check-cardinal-integer
22    check-real
23    check-open-interval
24    check-closed-interval)
25  srfi-27
26  srfi-27-distributions-support)
27
28;;; Triangle distribution
29
30;; s - smallest, m - most probable, l - largest
31
32(define (*make-random-triangles s m l randoms)
33  (let ((d1 (- m s))
34        (d2 (- l s))
35        (d3 (sqrt (- l m))))
36    (let (
37      (q1 (/ d1 d2) )
38      (p1 (sqrt (* d1 d2)) ) )
39      ;
40      (lambda ()
41        (let ((u (randoms)))
42          (if (<= u q1)
43            (+ s (* p1 (sqrt u)))
44            (- l (* d3 (sqrt (- (* d2 u) d1))))))))) )
45
46(define (make-random-triangles #!key (s 0.0) (m 0.5) (l 1.0) (randoms (current-random-real)))
47  (check-real 'make-random-triangles s 's)
48  (check-real 'make-random-triangles m 'm)
49  (check-real 'make-random-triangles l 'l)
50  (check-real-open-interval 'make-random-triangles l s +inf.0 'l)
51  (check-real-closed-interval 'make-random-triangles m s l 'm)
52  (check-procedure 'make-random-triangles randoms 'randoms)
53  (values
54    (*make-random-triangles s m l randoms)
55    (lambda () (values s m l randoms))) )
56
57) ;module srfi-27-triangles
Note: See TracBrowser for help on using the repository browser.