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

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

uses test

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