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

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

mv chk bfr 1st use , re-flow

File size: 3.3 KB
Line 
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|#
Note: See TracBrowser for help on using the repository browser.