source: project/release/4/srfi-27/OO-example.scm @ 34715

Last change on this file since 34715 was 34715, checked in by Kon Lovett, 3 years ago

use recv when 1 let-vals

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