source: project/wiki/yasos @ 8687

Last change on this file since 8687 was 8687, checked in by svnwiki, 12 years ago

Changes applied for Anonymous (71.38.23.88) through svnwiki:

File size: 10.1 KB
Line 
1[[tags: egg]]
2
3== yasos
4
5[[toc:]]
6
7=== Description
8
9"Yet another Scheme Object System"
10
11A very simple OOP system with multiple inheritance, that allows mixing of styles and separates interface from implementation. There are no classes, no meta-anything, simply closures.
12
13=== Author
14
15Kenneth Dickey
16
17ported to CHICKEN by Juergen Lorenz
18
19=== Version
20
21 1.0
22
23=== Usage
24
25(require-extension syntax-case yasos)
26
27=== Download
28
29[[http://www.call-with-current-continuation.org/eggs/yasos.egg|yasos.egg]]
30=== Documentation
31
32 (define-operation (opname self arg ...) default-body)
33 (define-predicate opname)
34 (object ((name self arg ...) body) ...)
35 (object-with-ancestors ((ancestor1 init1) ...) operation ...)
36 (operate-as component operation self arg ...)
37
38=== Examples
39
40  ;;;===============
41  ;;;file yasos-examples.scm
42  ;;;===============
43 
44  (declare (unit yasos-examples))
45  (require-extension syntax-case yasos format)
46 
47  ;;----------------------------
48  ;; general operations
49  ;;----------------------------
50 
51  (define-operation (print-obj obj port)
52    (format port
53      ;; if an instance does not have a print-obj operation..
54      (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
55 
56  (define-operation (size-obj obj)
57    ;; default behavior
58    (cond
59      ((vector? obj) (vector-length obj))
60      ((list? obj) (length obj))
61      ((pair? obj) 2)
62      ((string? obj) (string-length obj))
63      ((char? obj) 1)
64      (else
65        (error "Operation not supported: size-obj" obj))))
66 
67  ;;----------------------
68  ;; point interface
69  ;;----------------------
70 
71  (define-predicate point?) ;; answers #f  by default
72  (define-operation (x obj))
73  (define-operation (y obj))
74  (define-operation (set-x! obj new-x))
75  (define-operation (set-y! obj new-y))
76 
77  ;;--------------------------------
78  ;; point implementation
79  ;;--------------------------------
80 
81  (define (make-point the-x the-y)
82    (object
83      ((point? self) #t) ;; yes, this is a point object
84      ((x self) the-x)
85      ((y self) the-y)
86      ((set-x! self val)
87        (set! the-x val)
88        the-x)
89      ((set-y! self val)
90        (set! the-y val)
91        the-y)
92      ((size-obj self) 2)
93      ((print-obj self port)
94        (format port "#<point: ~a ~a>~%" (x self) (y self)))))
95 
96  ;;-----------------------------------------
97  ;; 3D point interface additions
98  ;;-----------------------------------------
99 
100  (define-predicate point-3d?) ;; #f by defualt
101  (define-operation (z obj))
102  (define-operation (set-z! obj new-z))
103 
104  ;;------------------------------------
105  ;; 3D point implementation
106  ;;------------------------------------
107 
108  (define (make-point-3d the-x the-y the-z)
109    (object-with-ancestors ( (a-point (make-point the-x the-y)) )
110      ((point-3d? self) #t)
111      ((z self) the-z)
112      ((set-z! self val) (set! the-z val) the-z)
113      ;; override inherited size-obj and print-obj operations
114      ((size-obj self) 3)
115      ((print-obj self port)
116        (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
117 
118  ;;;-----------------------
119  ;; person interface
120  ;;------------------------
121 
122  (define-predicate person?)
123  (define-operation (name obj))
124  (define-operation (age obj))
125  (define-operation (set-age! obj new-age))
126  (define-operation (ssn obj password)) ;; Social Security # is protected
127  (define-operation (new-password obj old-passwd new-passwd))
128  (define-operation (bad-password obj bogus-passwd)
129    ;; assume internal (design) error
130    (error (format #f "Bad Password: ~s given to ~a~%"
131            bogus-passwd
132            (print-obj obj #f))))
133 
134  ;;----------------------------------
135  ;; person implementation
136  ;;----------------------------------
137 
138  (define (make-person a-name an-age a-ssn the-password)
139    (object
140      ((person? self) #t)
141      ((name self) a-name)
142      ((age self) an-age)
143      ((set-age! self val) (set! an-age val) an-age)
144      ((ssn self password)
145        (if (equal? password the-password)
146          a-ssn
147          (bad-password self password)))
148      ((new-password self old-passwd new-passwd)
149        (cond
150          ((equal? old-passwd the-password) (set! the-password new-passwd) self)
151          (else (bad-password self old-passwd))))
152      ((bad-password self bogus-passwd)
153        (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
154      ((print-obj self port)
155        (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
156 
157  ;;;---------------------------------------------------------------
158  ;; account-history and bank-account interfaces
159  ;;----------------------------------------------------------------
160   
161  (define-predicate bank-account?)
162  (define-operation (current-balance obj pin))
163  (define-operation (add obj amount))
164  (define-operation (withdraw obj amount pin))
165  (define-operation (get-pin obj master-password))
166  (define-operation (get-account-history obj master-password))
167 
168  ;;----------------------------------------------
169  ;; account-history implementation
170  ;;----------------------------------------------
171 
172  ;; put access to bank database and report generation here
173  (define (make-account-history initial-balance a-pin master-password)
174    ;; history is a simple list of balances -- no transaction times
175    (letrec
176      ((history (list initial-balance))
177       (balance (lambda () (car history))) ; balance is a function
178       (remember
179         (lambda (datum) (set! history (cons datum history)))))
180      (object
181        ((bank-account? self) #t)
182        ((add self amount) ;; bank will accept money without a password
183          (remember (+ amount (balance)))
184          ;; print new balance
185          (format #t "New balance: $~a~%" (balance)))
186        ((withdraw self amount pin)
187          (cond
188            ((not (equal? pin a-pin)) (bad-password self pin))
189            ((< (- (balance) amount) 0)
190              (format
191                #t
192                "No overdraft~% Can't withdraw more than you have: $~a~%"
193                (balance)))
194            (else
195              (remember (- (balance) amount))
196              (format #t "New balance: $~a~%" (balance)))))
197        ((current-balance self password)
198          (if (or (eq? password master-password) (equal? password a-pin))
199            (format #t "Your Balance is $~a~%" (balance))
200            (bad-password self password)))
201        ;; only bank has access to account history
202        ((get-account-history self password)
203          (if (eq? password master-password)
204            history
205            (bad-password self password))))))
206 
207  ;;;------------------------------------------
208  ;; bank-account implementation
209  ;;-------------------------------------------
210 
211  (define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
212    (object-with-ancestors
213      ((customer (make-person a-name an-age a-ssn a-pin))
214       (account (make-account-history initial-balance a-pin master-password)))
215      ((get-pin self password)
216        (if (eq? password master-password)
217          a-pin
218          (bad-password self password)))
219      ((get-account-history self password)
220        (operate-as account get-account-history self password))
221      ;; our bank is very conservative...
222      ((bad-password self bogus-passwd)
223        (format #t "~%CALL THE POLICE!!~%"))
224      ;; protect the customer as well
225      ((ssn self password)
226        (operate-as customer ssn self password))
227      ((print-obj self port)
228        (format port "#<Bank-Customer ~a>~%" (name self)))))
229 
230  ;;; eof yasos-examples.scm
231 
232  ;;;============
233  ;;; file: yasos-test.scm
234  ;;;============
235 
236  (declare (uses yasos-examples))
237  (define main
238    (lambda ()
239      (let
240        ((p2 (make-point 1 2))
241         (p3 (make-point-3d 4 5 6))
242         (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
243         (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password)))
244        (printf "(size-obj p2) => ~a (size-obj p3) => ~a~%" (size-obj p2) (size-obj p3))
245        (print-obj 'mist #t)
246        (print-obj p2 #t)
247        (printf "(point? p2) => ~A (point-3d? p2) => ~A~%" (point? p2) (point-3d? p2))
248        (print-obj p3 #t)
249        (printf "(point? p3) => ~A (point-3d? p3) => ~A~%" (point? p3) (point-3d? p3))
250        (print-obj fred #t)
251        (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
252        (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
253        (print-obj sally #t)
254        (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
255        (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
256        (current-balance sally 'FeedBabe)
257        (add sally 200)
258        (add sally 300)
259        (withdraw sally 400 'FeedBabe)
260        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
261        (withdraw sally 150 (get-pin sally 'bank-password))
262        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
263        (printf "Bad password for Fred:~%")
264        (ssn fred 'bogus)
265        (printf "Bad password for Sally:")
266        (ssn sally 'bogus)
267        (void)
268  ) ) )   
269  (main)
270 
271  ;;; eof yasos-test.scm
272
273=== Changelog
274
275* 1.0
276
277=== License
278
279  COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
280 
281  Permission is hereby granted, free of charge, to any person obtaining
282  a copy of this software and associated documentation files (the
283  "Software"), to deal in the Software without restriction, including
284  without limitation the rights to use, copy, modify, merge, publish,
285  distribute, sublicense, and/or sell copies of the Software, and to
286  permit persons to whom the Software is furnished to do so, subject to
287  the following conditions:
288 
289  The above copyright notice and this permission notice shall be
290  included in all copies or substantial portions of the Software.
291 
292  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
293  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
294  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
295  NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
296  LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,WHETHER IN AN ACTION
297  OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
298  WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
299
Note: See TracBrowser for help on using the repository browser.