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

Last change on this file since 34967 was 34938, checked in by Kon Lovett, 2 years ago

updt ex ; has a name don' it

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