1 | (use srfi-1 srfi-13 coops srfi-27-distributions) |
---|
2 | |
---|
3 | ;; Named (has a name) "concept" |
---|
4 | (define-generic (name obj)) |
---|
5 | (define-class <named> () ( |
---|
6 | (namsym reader: name) ) ) |
---|
7 | |
---|
8 | ;; Parameterized extension "concept" |
---|
9 | (define-class <parameterized> () (ctor params src)) |
---|
10 | |
---|
11 | ;; Moves forward thru a set of values "concept" |
---|
12 | (define-generic (next-value obj)) |
---|
13 | (define-class <stepper> () (nxtval)) |
---|
14 | (define-method (next-value (obj <stepper>)) |
---|
15 | ((slot-value obj 'nxtval))) |
---|
16 | (define-generic (reset obj)) |
---|
17 | (define-method (reset (obj <stepper>)) |
---|
18 | (let-values ( |
---|
19 | ((gen _) |
---|
20 | (apply |
---|
21 | (slot-value obj 'ctor) |
---|
22 | `(,@(slot-value obj 'params) ,(slot-value obj 'src))) ) ) |
---|
23 | (set! (slot-value obj 'nxtval) gen) ) ) |
---|
24 | |
---|
25 | ;; Parameterized generative set of random values "concept" |
---|
26 | (define-class <random-distribution> (<named> <parameterized> <stepper>) ( |
---|
27 | ;holds any value, temporarily |
---|
28 | tmpval ) ) |
---|
29 | |
---|
30 | ;; Create an instance of <random-distribution> where the arguments are |
---|
31 | ;; the same as the documented procedural distribution API. |
---|
32 | ;; |
---|
33 | ;; SRFI 27 API: ({some distribution constructor} arg...) |
---|
34 | ;; OO API: (make-random-distribution {some distribution constructor} arg...) |
---|
35 | (define-syntax make-random-distribution |
---|
36 | (syntax-rules () |
---|
37 | ((_ ?ctor ?arg0 ...) |
---|
38 | ;use tmpval to hold the ctor call form |
---|
39 | (make <random-distribution> 'tmpval (list ?ctor ?arg0 ...)) ) ) ) |
---|
40 | |
---|
41 | (define-method (initialize-instance (obj <random-distribution>)) |
---|
42 | ; The 'ctor' must be a globally defined procedure compiled with |
---|
43 | ; procedure-information. So if following nomenclature then the last |
---|
44 | ; procedure name element will be the kind of distribution: |
---|
45 | ; make-random-<distribution>. And the <random-source> will be the |
---|
46 | ; last argument. |
---|
47 | ; |
---|
48 | ; (I do not endorse this kind of "auto-magic". For example only.) |
---|
49 | (let* ( |
---|
50 | (tmpval |
---|
51 | (or |
---|
52 | (slot-value obj 'tmpval) |
---|
53 | `(,make-random-normals)) ) |
---|
54 | (ctor |
---|
55 | (car tmpval) ) |
---|
56 | (procinfo |
---|
57 | (procedure-information ctor) ) |
---|
58 | (procname |
---|
59 | (and procinfo (pair? procinfo) (symbol->string (car procinfo)))) |
---|
60 | (procname |
---|
61 | (and |
---|
62 | procname |
---|
63 | (and-let* ((kndpos (string-index-right procname #\-))) |
---|
64 | (substring/shared procname (add1 kndpos)) ) ) ) |
---|
65 | (dstr-vals |
---|
66 | (receive (apply ctor (cdr tmpval))) ) |
---|
67 | (params |
---|
68 | (and |
---|
69 | (<= 2 (length dstr-vals)) |
---|
70 | (receive ((second dstr-vals)))) ) ) |
---|
71 | ;"free" the temp slot |
---|
72 | (set! (slot-value obj 'tmpval) #f) |
---|
73 | ;initialize state |
---|
74 | (set! (slot-value obj 'namsym) (string->symbol procname)) |
---|
75 | (set! (slot-value obj 'nxtval) (first dstr-vals)) |
---|
76 | (set! (slot-value obj 'ctor) ctor) |
---|
77 | (set! (slot-value obj 'params) (and params (drop-right params 1))) |
---|
78 | (set! (slot-value obj 'src) (and params (last params))) ) ) |
---|
79 | |
---|
80 | #| |
---|
81 | (use test) |
---|
82 | |
---|
83 | (let ((expn-rd (make-random-distribution make-random-exponentials mu: 0.5))) |
---|
84 | (test <random-distribution> (class-of expn-rd)) |
---|
85 | (test-assert (number? (next-value expn-rd))) |
---|
86 | ) |
---|
87 | |# |
---|
88 | |
---|
89 | #| |
---|
90 | ;; Use it |
---|
91 | (use coops-extras) |
---|
92 | |
---|
93 | (define expn-rd (make-random-distribution make-random-exponentials mu: 0.5)) |
---|
94 | (describe-object expn-rd) |
---|
95 | ;coops instance of class `<random-distribution>': |
---|
96 | ;tmpval: #f |
---|
97 | ;namsym: exponentials |
---|
98 | ; ctor: #<procedure (srfi-27-distributions#make-random-exponentials . tmp302303)> |
---|
99 | ;params: (0.5) |
---|
100 | ; src: #<procedure> |
---|
101 | ;nxtval: #<procedure (f_1191)> |
---|
102 | |
---|
103 | (next-value expn-rd) ;=> ... |
---|
104 | |# |
---|