source: project/wiki/yasos @ 8680

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

Changes applied for Anonymous (71.38.23.88) through svnwiki:

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