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

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

misc add

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