Ticket #32: tiny-examples.scm

File tiny-examples.scm, 10.2 KB (added by Tony Sidaway, 13 years ago)

diff for tiny-examplesscm as downloaded from Xeroc Parc website--hacks to make it work for modern MIT Scheme

Line 
1; Mode: Scheme
2;
3;
4; **********************************************************************
5; Copyright (c) 1992 Xerox Corporation. 
6; All Rights Reserved. 
7;
8; Use, reproduction, and preparation of derivative works are permitted.
9; Any copy of this software or of any derivative work must include the
10; above copyright notice of Xerox Corporation, this paragraph and the
11; one after it.  Any distribution of this software or derivative works
12; must comply with all applicable United States export control laws.
13;
14; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
15; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
16; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
17; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
18; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
19; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
20; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
21; OF THE POSSIBILITY OF SUCH DAMAGES.
22; **********************************************************************
23;
24; Some simple examples of using Tiny CLOS and its MOP.
25;
26; Much of this stuff corresponds to stuff in AMOP (The Art of the
27; Metaobject Protocol).
28;
29
30(define-syntax test-pp
31  (syntax-rules()
32    ((_ x) (begin (newline)(pp 'x)(pp x)))))
33
34;***
35;
36; This is a useful sort of helper function.  Note how it uses the
37; introspective part of the MOP.  The first few pages of chapter
38; two of the AMOP discuss this.
39;
40; Note that this introspective MOP doesn't support back-links from
41; the classes to methods and generic functions.  Is that worth adding?
42;
43;
44(define initialize-slots
45    (lambda (object initargs)
46      (let ((not-there (list 'shes-not-there)))
47        (for-each (lambda (slot)
48                    (let ((name (car slot)))
49                      (let ((value  (getl initargs name not-there)))
50                        (if (eq? value not-there)
51                            'do-nothing
52                            (slot-set! object name value)))))
53                  (class-slots (class-of object))))))
54
55
56
57;***
58;
59; A simple class, just an instance of <class>.  Note that we are using
60; make and <class> rather than make-class to make it.  See Section 2.4
61; of AMOP for more on this.
62;
63;
64
65(define <pos> (make <class>                          ;[make-class
66                    'direct-supers (list <object>)   ;  (list <object>)
67                    'direct-slots  (list 'x 'y)))    ;  (list 'x 'y)]
68
69(add-method initialize
70    (make-method (list <pos>)
71      (lambda (call-next-method pos initargs)
72        (call-next-method)
73        (initialize-slots pos initargs))))
74
75(define p1 (make <pos> 'x 1 'y 2))
76(define p2 (make <pos> 'x 3 'y 5))
77
78(test-pp p1)
79(test-pp (slot-ref p1 'x))
80(test-pp (slot-ref p1 'y))
81
82
83(test-pp p2)
84(test-pp (slot-ref p2 'x))
85(test-pp (slot-ref p2 'y))
86
87
88;***
89;
90; Another way of writing that class definition, that achives better
91; `encapsulation' by using slot names that are unique keys, rather
92; than symbols.
93;
94;
95
96(define <pos>)
97(define pos-x (make-generic))
98(define pos-y (make-generic))
99(define move  (make-generic))
100
101(let ((x (vector 'x))
102      (y (vector 'y)))
103 
104  (set! <pos> (make <class>
105                    'direct-supers (list <object>)
106                    'direct-slots  (list x y)))
107
108  (add-method pos-x
109      (make-method (list <pos>)
110        (lambda (call-next-method pos) (slot-ref pos x))))
111  (add-method pos-y
112      (make-method (list <pos>)
113        (lambda (call-next-method pos) (slot-ref pos y))))
114
115  (add-method move
116      (make-method (list <pos>)
117        (lambda (call-next-method pos new-x new-y)
118          (slot-set! pos x new-x)
119          (slot-set! pos y new-y))))
120
121  (add-method initialize
122      (make-method (list <pos>)
123        (lambda (call-next-method pos initargs)
124          (move pos (getl initargs 'x 0) (getl initargs 'y 0)))))
125  )
126
127
128(define p3 (make <pos> 'x 1 'y 2))
129(define p4 (make <pos> 'x 3 'y 5))
130
131
132(test-pp p3)
133(test-pp (pos-x p3))
134(test-pp (pos-y p3))
135
136(test-pp p4)
137(test-pp (pos-x p4))
138(test-pp (pos-y p4))
139
140(move p4 10 11)
141
142(test-pp p4)
143(test-pp (pos-x p4))
144(test-pp (pos-y p4))
145
146
147;***
148;
149; Class allocated slots.
150;
151; In Scheme, this extension isn't worth a whole lot, but what the hell.
152;
153;
154
155(define <class-slots-class>
156    (make-class (list <class>)
157                (list)))
158
159(add-method compute-getter-and-setter
160    (make-method (list <class-slots-class>)
161      (lambda (call-next-method class slot allocator)
162        (if (not (memq ':class-allocation slot))
163            (call-next-method)
164            (let ((cell '()))
165              (list (lambda (o) cell)
166                    (lambda (o new) (set! cell new) new)))))))
167
168
169;
170; Here's a silly program that uses class allocated slots.
171;
172;
173(define <ship>
174    (make <class-slots-class>
175          'direct-supers (list <object>)
176          'direct-slots  (list 'name
177                               '(all-ships :class-allocation))))
178
179(add-method initialize
180    (make-method (list <ship>)
181      (lambda (call-next-method ship initargs)
182        (call-next-method)
183        (initialize-slots ship initargs)
184        (slot-set! ship
185                   'all-ships
186                   (cons ship (slot-ref ship 'all-ships))))))
187
188(define siblings (make-generic))
189(add-method siblings
190    (make-method (list <ship>)
191      (lambda (call-next-method ship)
192        (remove ship (slot-ref ship 'all-ships)))))
193
194(define s1 (make <ship> 'name 's1))
195(define s2 (make <ship> 'name 's2))
196(test-pp s2)
197(test-pp (slot-ref s2 'name))
198(define s3 (make <ship> 'name 's3))
199
200(test-pp s1)
201(test-pp (slot-ref s1 'name))
202
203(test-pp s2)
204(test-pp (slot-ref s2 'name))
205
206(test-pp s3)
207(test-pp (slot-ref s3 'name))
208
209(test-pp <ship>)
210(test-pp (class-direct-slots <ship>))
211
212(test-pp (map (lambda(x) (cons x (slot-ref x 'name))) (siblings s1)))
213
214
215;***
216;
217; Here's a class of class that allocates some slots dynamically.
218;
219; It has a layered protocol (dynamic-slot?) that decides whether a given
220; slot should be dynamically allocated.  This makes it easy to define a
221; subclass that allocates all its slots dynamically.
222;
223;
224(define <dynamic-class>
225    (make-class (list <class>)
226                (list 'alist-g-n-s)))
227
228
229(define dynamic-slot? (make-generic))
230
231(add-method dynamic-slot?
232    (make-method (list <dynamic-class>)
233      (lambda (call-next-method class slot)
234        (memq :dynamic-allocation (cdr slot)))))
235
236
237
238(define alist-getter-and-setter
239    (lambda (dynamic-class allocator)
240      (let ((old (slot-ref dynamic-class 'alist-g-n-s)))
241        (if (null? old)
242            (let ((new (allocator (lambda () '()))))
243              (slot-set! dynamic-class 'alist-g-n-s new)
244              new)
245            old))))
246
247
248(add-method compute-getter-and-setter
249    (make-method (list <dynamic-class>)
250      (lambda (call-next-method class slot allocator)
251        (if (null? (dynamic-slot? class slot))
252            (call-next-method)
253            (let* ((name (car slot))
254                   (g-n-s (alist-getter-and-setter class allocator))
255                   (alist-getter (car g-n-s))
256                   (alist-setter (cadr g-n-s)))
257              (list (lambda (o)
258                      (let ((entry (assq name  (alist-getter o))))
259                        (if (not entry)
260                            '()
261                            (cdr entry))))
262                    (lambda (o new)
263                      (let* ((alist (alist-getter o))
264                             (entry (assq name alist)))
265                        (if (not entry)
266                            (alist-setter o
267                                          (cons (cons name new) alist))
268                            (set-cdr! entry new))
269                        new))))))))
270
271
272(define <all-dynamic-class>
273    (make-class (list <dynamic-class>)
274                (list)))
275
276(add-method dynamic-slot?
277    (make-method (list <all-dynamic-class>)
278      (lambda (call-next-method class slot) #t)))
279           
280
281
282;
283; A silly program that uses this.
284;
285;
286(define <person> (make <all-dynamic-class>
287                       'direct-supers (list <object>)
288                       'direct-slots  (list 'name 'age 'address)))
289
290(add-method initialize
291    (make-method (list <person>)
292      (lambda (call-next-method person initargs)
293        (initialize-slots person initargs))))
294
295
296(define person1 (make <person> 'name 'sally))
297(define person2 (make <person> 'name 'betty))
298(define person3 (make <person> 'name 'sue))
299
300(test-pp (slot-ref person1 'name))
301
302(slot-set! person1 'age 20)
303(test-pp (slot-ref person1 'age))
304
305
306;***
307;
308; A ``database'' class that stores slots externally.
309;
310;
311
312(define <db-class>
313  (make-class (list <class>)
314              (list 'id-g-n-s)))
315
316(define id-getter-and-setter
317    (lambda (db-class allocator)
318      (let ((old (slot-ref db-class 'id-g-n-s)))
319        (if (null? old)
320            (let ((new (allocator db-allocate-id)))
321              (slot-set! class 'id-g-n-s new)
322              new)
323            old))))
324
325(add-method compute-getter-and-setter
326    (make-method (list <db-class>)
327      (lambda (call-next-method class slot allocator)
328        (let* ((id-g-n-s (id-getter-and-setter class allocator))
329               (id-getter (car id-g-n-s))
330               (id-setter (cadr id-g-n-s))
331               (slot-name (car slot)))
332          (list (lambda (o)
333                  (db-lookup (id-getter o) slot-name)) 
334                (lambda (o new)
335                  (db-store  (id-getter o) slot-name new)))))))
336
337
338;***
339;
340; A kind of generic that supports around methods.
341;
342;
343(define make-around-generic
344    (lambda () (make <around-generic>)))
345
346(define make-around-method
347    (lambda (specializers procedure)
348      (make <around-method>
349            'specializers specializers
350            'procedure procedure)))
351
352
353(define <around-generic> (make <entity-class>
354                               'direct-supers (list <generic>)))
355(define <around-method>  (make <class>
356                               'direct-supers (list <method>)))
357
358
359(define around-method?   (make-generic))
360
361(add-method around-method?
362    (make-method (list <method>)
363      (lambda (call-next-method x) #f)))
364(add-method around-method?
365    (make-method (list <around-method>)
366      (lambda (call-next-method x) #t)))
367
368
369(add-method compute-methods
370    (make-method (list <around-generic>)
371      (lambda (call-next-method generic)
372        (let ((normal-compute-methods (call-next-method)))
373          (lambda (args)
374            (let ((normal-methods (normal-compute-methods args)))
375              (append
376                (filter-in around-method?
377                           normal-methods)
378                (filter-in (lambda (m) (not (around-method? m)))
379                           normal-methods))))))))
380
381
382;
383; And a simple example of using it.
384;
385;
386(define <baz> (make-class (list <object>) (list)))
387(define <bar> (make-class (list <baz>)    (list)))
388(define <foo> (make-class (list <bar>)    (list)))
389
390
391(define test-around
392    (lambda (generic)
393      (add-method generic
394          (make-method        (list <foo>)
395                              (lambda (cnm x) (cons 'foo (cnm)))))
396
397      (add-method generic
398          (make-around-method (list <bar>)
399                              (lambda (cnm x) (cons 'bar (cnm)))))
400
401      (add-method generic
402          (make-method        (list <baz>)
403                              (lambda (cnm x) '(baz))))
404
405      (generic (make <foo>))))
406
407(test-pp (equal? (test-around (make-generic))        '(foo bar baz)))
408
409(test-pp (equal? (test-around (make-around-generic)) '(bar foo baz)))
410
411'examples_all_done