source: project/wiki/yasos @ 8682

Last change on this file since 8682 was 8682, 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  ;;;===============
40  ;;;file yasos-examples.scm
41  ;;;===============
42 
43  (declare (unit yasos-examples))
44  (require-extension syntax-case yasos format)
45 
46  ;;----------------------------
47  ;; general operations
48  ;;----------------------------
49 
50  (define-operation (print-obj obj port)
51    (format port
52      ;; if an instance does not have a print-obj operation..
53      (if (instance? obj) "#<INSTANCE>~%" "#<NOT-AN-INSTANCE: ~s>~%") obj))
54 
55  (define-operation (size-obj obj)
56    ;; default behavior
57    (cond
58      ((vector? obj) (vector-length obj))
59      ((list? obj) (length obj))
60      ((pair? obj) 2)
61      ((string? obj) (string-length obj))
62      ((char? obj) 1)
63      (else
64        (error "Operation not supported: size-obj" obj))))
65 
66  ;;----------------------
67  ;; point interface
68  ;;----------------------
69 
70  (define-predicate point?) ;; answers #f  by default
71  (define-operation (x obj))
72  (define-operation (y obj))
73  (define-operation (set-x! obj new-x))
74  (define-operation (set-y! obj new-y))
75 
76  ;;--------------------------------
77  ;; point implementation
78  ;;--------------------------------
79 
80  (define (make-point the-x the-y)
81    (object
82      ((point? self) #t) ;; yes, this is a point object
83      ((x self) the-x)
84      ((y self) the-y)
85      ((set-x! self val)
86        (set! the-x val)
87        the-x)
88      ((set-y! self val)
89        (set! the-y val)
90        the-y)
91      ((size-obj self) 2)
92      ((print-obj self port)
93        (format port "#<point: ~a ~a>~%" (x self) (y self)))))
94 
95  ;;-----------------------------------------
96  ;; 3D point interface additions
97  ;;-----------------------------------------
98 
99  (define-predicate point-3d?) ;; #f by defualt
100  (define-operation (z obj))
101  (define-operation (set-z! obj new-z))
102 
103  ;;------------------------------------
104  ;; 3D point implementation
105  ;;------------------------------------
106 
107  (define (make-point-3d the-x the-y the-z)
108    (object-with-ancestors ( (a-point (make-point the-x the-y)) )
109      ((point-3d? self) #t)
110      ((z self) the-z)
111      ((set-z! self val) (set! the-z val) the-z)
112      ;; override inherited size-obj and print-obj operations
113      ((size-obj self) 3)
114      ((print-obj self port)
115        (format port "#<3d-point: ~a ~a ~a>~%" (x self) (y self) (z self)))))
116 
117  ;;;-----------------------
118  ;; person interface
119  ;;------------------------
120 
121  (define-predicate person?)
122  (define-operation (name obj))
123  (define-operation (age obj))
124  (define-operation (set-age! obj new-age))
125  (define-operation (ssn obj password)) ;; Social Security # is protected
126  (define-operation (new-password obj old-passwd new-passwd))
127  (define-operation (bad-password obj bogus-passwd)
128    ;; assume internal (design) error
129    (error (format #f "Bad Password: ~s given to ~a~%"
130            bogus-passwd
131            (print-obj obj #f))))
132 
133  ;;----------------------------------
134  ;; person implementation
135  ;;----------------------------------
136 
137  (define (make-person a-name an-age a-ssn the-password)
138    (object
139      ((person? self) #t)
140      ((name self) a-name)
141      ((age self) an-age)
142      ((set-age! self val) (set! an-age val) an-age)
143      ((ssn self password)
144        (if (equal? password the-password)
145          a-ssn
146          (bad-password self password)))
147      ((new-password self old-passwd new-passwd)
148        (cond
149          ((equal? old-passwd the-password) (set! the-password new-passwd) self)
150          (else (bad-password self old-passwd))))
151      ((bad-password self bogus-passwd)
152        (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover
153      ((print-obj self port)
154        (format port "#<Person: ~a age: ~a>~%" (name self) (age self)))))
155 
156  ;;;---------------------------------------------------------------
157  ;; account-history and bank-account interfaces
158  ;;----------------------------------------------------------------
159   
160  (define-predicate bank-account?)
161  (define-operation (current-balance obj pin))
162  (define-operation (add obj amount))
163  (define-operation (withdraw obj amount pin))
164  (define-operation (get-pin obj master-password))
165  (define-operation (get-account-history obj master-password))
166 
167  ;;----------------------------------------------
168  ;; account-history implementation
169  ;;----------------------------------------------
170 
171  ;; put access to bank database and report generation here
172  (define (make-account-history initial-balance a-pin master-password)
173    ;; history is a simple list of balances -- no transaction times
174    (letrec
175      ((history (list initial-balance))
176       (balance (lambda () (car history))) ; balance is a function
177       (remember
178         (lambda (datum) (set! history (cons datum history)))))
179      (object
180        ((bank-account? self) #t)
181        ((add self amount) ;; bank will accept money without a password
182          (remember (+ amount (balance)))
183          ;; print new balance
184          (format #t "New balance: $~a~%" (balance)))
185        ((withdraw self amount pin)
186          (cond
187            ((not (equal? pin a-pin)) (bad-password self pin))
188            ((< (- (balance) amount) 0)
189              (format
190                #t
191                "No overdraft~% Can't withdraw more than you have: $~a~%"
192                (balance)))
193            (else
194              (remember (- (balance) amount))
195              (format #t "New balance: $~a~%" (balance)))))
196        ((current-balance self password)
197          (if (or (eq? password master-password) (equal? password a-pin))
198            (format #t "Your Balance is $~a~%" (balance))
199            (bad-password self password)))
200        ;; only bank has access to account history
201        ((get-account-history self password)
202          (if (eq? password master-password)
203            history
204            (bad-password self password))))))
205 
206  ;;;------------------------------------------
207  ;; bank-account implementation
208  ;;-------------------------------------------
209 
210  (define (make-account a-name an-age a-ssn a-pin initial-balance master-password)
211    (object-with-ancestors
212      ((customer (make-person a-name an-age a-ssn a-pin))
213       (account (make-account-history initial-balance a-pin master-password)))
214      ((get-pin self password)
215        (if (eq? password master-password)
216          a-pin
217          (bad-password self password)))
218      ((get-account-history self password)
219        (operate-as account get-account-history self password))
220      ;; our bank is very conservative...
221      ((bad-password self bogus-passwd)
222        (format #t "~%CALL THE POLICE!!~%"))
223      ;; protect the customer as well
224      ((ssn self password)
225        (operate-as customer ssn self password))
226      ((print-obj self port)
227        (format port "#<Bank-Customer ~a>~%" (name self)))))
228 
229  ;;; eof yasos-examples.scm
230 
231  ;;;============
232  ;;; file: yasos-test.scm
233  ;;;============
234 
235  (declare (uses yasos-examples))
236  (define main
237    (lambda ()
238      (let
239        ((p2 (make-point 1 2))
240         (p3 (make-point-3d 4 5 6))
241         (fred  (make-person  "Fred"  19 "573-19-4279" 'FadeCafe))
242         (sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password)))
243        (printf "(size-obj p2) => ~a (size-obj p3) => ~a~%" (size-obj p2) (size-obj p3))
244        (print-obj 'mist #t)
245        (print-obj p2 #t)
246        (printf "(point? p2) => ~A (point-3d? p2) => ~A~%" (point? p2) (point-3d? p2))
247        (print-obj p3 #t)
248        (printf "(point? p3) => ~A (point-3d? p3) => ~A~%" (point? p3) (point-3d? p3))
249        (print-obj fred #t)
250        (printf "Fred's ssn: ~a~%" (ssn fred 'FadeCafe))
251        (printf "Fred: person? ~a bank-account? ~a~%" (person? fred) (bank-account? fred))
252        (print-obj sally #t)
253        (printf "Sally's  ssn: ~a~%" (ssn sally 'FeedBabe))
254        (printf "Sally: person? ~a bank-account? ~a~%" (person? sally) (bank-account? sally))
255        (current-balance sally 'FeedBabe)
256        (add sally 200)
257        (add sally 300)
258        (withdraw sally 400 'FeedBabe)
259        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
260        (withdraw sally 150 (get-pin sally 'bank-password))
261        (printf "Account history of Sally: ~a~%" (get-account-history sally 'bank-password))
262        (printf "Bad password for Fred:~%")
263        (ssn fred 'bogus)
264        (printf "Bad password for Sally:")
265        (ssn sally 'bogus)
266        (void)
267  ) ) )   
268  (main)
269 
270  ;;; eof yasos-test.scm
271
272License:
273
274COPYRIGHT (c) 1992,2008 by Kenneth A Dickey, All rights reserved.
275
276Permission 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:
277
278The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
279
280THE 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.