1 | |
---|
2 | (import scheme (chicken base) (chicken format) (chicken port) |
---|
3 | yasos (prefix yasos-stacks stack.) (prefix yasos-queues queue.) |
---|
4 | yasos-points yasos-collections test) |
---|
5 | |
---|
6 | ;;;----------------------- |
---|
7 | ;; person interface |
---|
8 | ;;------------------------ |
---|
9 | |
---|
10 | (define-predicate person?) |
---|
11 | (define-operation (name obj)) |
---|
12 | (define-operation (age obj)) |
---|
13 | (define-operation (set-age! obj new-age)) |
---|
14 | (define-operation (ssn obj password)) ;; Social Security # is protected |
---|
15 | (define-operation (new-password obj old-passwd new-passwd)) |
---|
16 | (define-operation (bad-password obj bogus-passwd) |
---|
17 | ;; assume internal (design) error |
---|
18 | (error (format #f "Bad Password: ~s given to ~a~%" |
---|
19 | bogus-passwd |
---|
20 | (show obj)))) |
---|
21 | |
---|
22 | ;;---------------------------------- |
---|
23 | ;; person implementation |
---|
24 | ;;---------------------------------- |
---|
25 | |
---|
26 | (define (make-person a-name an-age a-ssn the-password) |
---|
27 | (operations () |
---|
28 | ((person? self) #t) |
---|
29 | ((show self . optional-arg) |
---|
30 | (if (null? optional-arg) |
---|
31 | (show self #t) |
---|
32 | (format (car optional-arg) |
---|
33 | "#<Person: ~a age: ~a>~%" |
---|
34 | (name self) (age self)))) |
---|
35 | ((name self) a-name) |
---|
36 | ((age self) an-age) |
---|
37 | ((ssn self password) |
---|
38 | (if (equal? password the-password) |
---|
39 | a-ssn |
---|
40 | (bad-password self password))) |
---|
41 | ((new-password self old-passwd new-passwd) |
---|
42 | (cond |
---|
43 | ((equal? old-passwd the-password) (set! the-password new-passwd) self) |
---|
44 | (else (bad-password self old-passwd)))) |
---|
45 | ((bad-password self bogus-passwd) |
---|
46 | (format #t "Bad password: ~s~%" bogus-passwd)) ;; let user recover |
---|
47 | ((set-age! self val) (set! an-age val) an-age) |
---|
48 | )) |
---|
49 | |
---|
50 | ;;;--------------------------------------------------------------- |
---|
51 | ;; account-history and bank-account interfaces |
---|
52 | ;;---------------------------------------------------------------- |
---|
53 | |
---|
54 | (define-predicate bank-account?) |
---|
55 | (define-predicate account-history?) |
---|
56 | (define-operation (current-balance obj pin)) |
---|
57 | (define-operation (add obj amount)) |
---|
58 | (define-operation (withdraw obj amount pin)) |
---|
59 | (define-operation (get-pin obj master-password)) |
---|
60 | (define-operation (get-account-history obj master-password)) |
---|
61 | |
---|
62 | ;;---------------------------------------------- |
---|
63 | ;; account-history implementation |
---|
64 | ;;---------------------------------------------- |
---|
65 | |
---|
66 | ;; put access to bank database and report generation here |
---|
67 | (define (make-account-history initial-balance a-pin master-password) |
---|
68 | ;; history is a simple list of balances -- no transaction times |
---|
69 | (letrec |
---|
70 | ((history (list initial-balance)) |
---|
71 | (balance (lambda () (car history))) ; balance is a function |
---|
72 | (remember |
---|
73 | (lambda (datum) (set! history (cons datum history))))) |
---|
74 | (operations () |
---|
75 | ((account-history? self) #t) |
---|
76 | ((add self amount) ;; bank will accept money without a password |
---|
77 | (remember (+ amount (balance))) |
---|
78 | ;; print new balance |
---|
79 | (format #t "New balance: $~a~%" (balance))) |
---|
80 | ((withdraw self amount pin) |
---|
81 | (cond |
---|
82 | ((not (equal? pin a-pin)) (bad-password self pin)) |
---|
83 | ((< (- (balance) amount) 0) |
---|
84 | (format |
---|
85 | #t |
---|
86 | "No overdraft~% Can't withdraw more than you have: $~a~%" |
---|
87 | (balance))) |
---|
88 | (else |
---|
89 | (remember (- (balance) amount)) |
---|
90 | (format #t "New balance: $~a~%" (balance))))) |
---|
91 | ((current-balance self password) |
---|
92 | (if (or (eq? password master-password) (equal? password a-pin)) |
---|
93 | (format #t "Your Balance is $~a~%" (balance)) |
---|
94 | (bad-password self password))) |
---|
95 | ;; only bank has access to account history |
---|
96 | ((get-account-history self password) |
---|
97 | (if (eq? password master-password) |
---|
98 | history |
---|
99 | (bad-password self password)))))) |
---|
100 | |
---|
101 | ;;;------------------------------------------ |
---|
102 | ;; bank-account implementation |
---|
103 | ;;------------------------------------------- |
---|
104 | |
---|
105 | (define (make-account a-name an-age a-ssn a-pin initial-balance master-password) |
---|
106 | (operations ( |
---|
107 | (customer (make-person a-name an-age a-ssn a-pin)) |
---|
108 | (account (make-account-history initial-balance a-pin master-password)) |
---|
109 | ) |
---|
110 | ((bank-account? self) #t) |
---|
111 | ((show self . optional-arg) |
---|
112 | (if (null? optional-arg) |
---|
113 | (show self #t) |
---|
114 | (format (car optional-arg) |
---|
115 | "#<Bank-Customer ~a>~%" |
---|
116 | (name self)))) |
---|
117 | ((get-pin self password) |
---|
118 | (if (eq? password master-password) |
---|
119 | a-pin |
---|
120 | (bad-password self password))) |
---|
121 | ((get-account-history self password) |
---|
122 | ((operate-as account get-account-history) self password)) |
---|
123 | ;(operate-as account get-account-history self password)) |
---|
124 | ;; our bank is very conservative... |
---|
125 | ((bad-password self bogus-passwd) |
---|
126 | (format #t "~%CALL THE POLICE!!~%")) |
---|
127 | ;; protect the customer as well |
---|
128 | ((ssn self password) |
---|
129 | ((operate-as customer ssn) self password)) |
---|
130 | ;(operate-as customer ssn self password)) |
---|
131 | )) |
---|
132 | |
---|
133 | ;;; eof yasos-examples.scm |
---|
134 | (define fred (make-person "Fred" 19 "573-19-4279" 'FadeCafe)) |
---|
135 | (define sally (make-account "Sally" 26 "629-26-9742" 'FeedBabe 263 'bank-password)) |
---|
136 | |
---|
137 | (test-group "accounts" |
---|
138 | |
---|
139 | (test-assert (person? fred)) |
---|
140 | (test-assert (person? sally)) |
---|
141 | (test-assert (bank-account? sally)) |
---|
142 | (test-assert (not (bank-account? fred))) |
---|
143 | (test-assert (string=? (with-output-to-string (lambda () (show fred))) |
---|
144 | "#<Person: Fred age: 19>\n")) |
---|
145 | (test-assert (string=? (ssn fred 'FadeCafe) "573-19-4279")) |
---|
146 | (test-assert (string=? (with-output-to-string (lambda () (show sally))) |
---|
147 | "#<Bank-Customer Sally>\n")) |
---|
148 | (test-assert (string=? (with-output-to-string (lambda () (ssn sally 'bogus))) |
---|
149 | "\nCALL THE POLICE!!\n")) |
---|
150 | (test-assert (string=? (ssn sally 'FeedBabe) "629-26-9742")) |
---|
151 | (test-assert (string=? (with-output-to-string (lambda() (current-balance sally 'FeedBabe))) |
---|
152 | "Your Balance is $263\n")) |
---|
153 | (test-assert (string=? |
---|
154 | (begin (add sally 200) |
---|
155 | (add sally 300) |
---|
156 | (withdraw sally 400 'FeedBabe) |
---|
157 | (with-output-to-string (lambda() (current-balance sally 'FeedBabe)))) |
---|
158 | "Your Balance is $363\n")) |
---|
159 | (test-assert (equal? (get-account-history sally 'bank-password) |
---|
160 | '(363 763 463 263))) |
---|
161 | (test-assert (string=? (with-output-to-string |
---|
162 | (lambda () (withdraw sally 150 (get-pin sally 'bank-password)))) |
---|
163 | "New balance: $213\n")) |
---|
164 | (test-assert (equal? (get-account-history sally 'bank-password) |
---|
165 | '(213 363 763 463 263))) |
---|
166 | (test-assert (string=? (with-output-to-string (lambda () (ssn fred 'bogus))) |
---|
167 | "Bad password: bogus\n")) |
---|
168 | (test-assert (equal? (protocol sally) |
---|
169 | '(bank-account? show get-pin get-account-history |
---|
170 | bad-password ssn |
---|
171 | (person? show name age ssn new-password |
---|
172 | bad-password set-age!) |
---|
173 | (account-history? add withdraw |
---|
174 | current-balance |
---|
175 | get-account-history)))) |
---|
176 | (test-assert (equal? (protocol sally 'ssn) |
---|
177 | '(ssn self password))) |
---|
178 | ) |
---|
179 | |
---|
180 | (define eps 0.0001) |
---|
181 | (define cart (make-point-cartesian -1 0)) |
---|
182 | (define pol (make-point-polar 1 (acos -1))) |
---|
183 | |
---|
184 | (test-group "points" |
---|
185 | |
---|
186 | (test-assert (< (distance cart pol) eps)) |
---|
187 | (test-assert (= (rho cart) 1)) |
---|
188 | (scale! pol 5) |
---|
189 | (test-assert (< (abs (- (x pol) -5)) eps)) |
---|
190 | (translate! cart 1 1) |
---|
191 | (test-assert (= (x cart) 0)) |
---|
192 | (test-assert (= (y cart) 1)) |
---|
193 | (rotate! pol 3.14159) |
---|
194 | (test-assert (< (distance pol (make-point-cartesian 5 0)) eps)) |
---|
195 | (test-assert (= (size pol) 2)) |
---|
196 | ) |
---|
197 | |
---|
198 | (define st (stack.make-stack)) |
---|
199 | (define rst (stack.make-ra-stack)) |
---|
200 | |
---|
201 | (test-group "stacks" |
---|
202 | |
---|
203 | (test-assert (stack.stack? st)) |
---|
204 | (test-assert (not (stack.ra-stack? st))) |
---|
205 | (test-assert (stack.empty? st)) |
---|
206 | (stack.push! st 0) |
---|
207 | (stack.push! st 1) |
---|
208 | (stack.push! st 2) |
---|
209 | (test-assert (= (stack.size st) 3)) |
---|
210 | (test-assert (not (stack.empty? st))) |
---|
211 | (test-assert (= (stack.top st) 2)) |
---|
212 | (stack.pop! st) |
---|
213 | (test-assert (= (stack.top st) 1)) |
---|
214 | (stack.pop! st) |
---|
215 | (test-assert (= (stack.size st) 1)) |
---|
216 | (stack.clear! st) |
---|
217 | (test-assert (stack.empty? st)) |
---|
218 | |
---|
219 | (test-assert (stack.ra-stack? rst)) |
---|
220 | (test-assert (stack.stack? rst)) |
---|
221 | (stack.push! rst 0) |
---|
222 | (stack.push! rst 1) |
---|
223 | (stack.push! rst 2) |
---|
224 | (test-assert (= (stack.down rst 1) 1)) |
---|
225 | (test-assert (= (stack.top rst) 2)) |
---|
226 | (stack.pop! rst) |
---|
227 | (test-assert (= (stack.top rst) 1)) |
---|
228 | (test-assert (= (stack.down rst 1) 0)) |
---|
229 | (test-assert (equal? (protocol rst) |
---|
230 | '(ra-stack? show down (stack? empty? size show state top push! |
---|
231 | pop! clear!)))) |
---|
232 | (test-assert (equal? (protocol rst 'down) '(down self k))) |
---|
233 | ) |
---|
234 | |
---|
235 | (define qu (queue.make-queue)) |
---|
236 | |
---|
237 | (test-group "queues" |
---|
238 | |
---|
239 | (test-assert (queue.queue? qu)) |
---|
240 | (test-assert (not (queue.queue? #f))) |
---|
241 | (test-assert (queue.empty? qu)) |
---|
242 | (queue.enq! qu 0) |
---|
243 | (queue.enq! qu 1) |
---|
244 | (queue.enq! qu 2) |
---|
245 | (test-assert (= (queue.size qu) 3)) |
---|
246 | (test-assert (not (queue.empty? qu))) |
---|
247 | (test-assert (= (queue.front qu) 0)) |
---|
248 | (queue.deq! qu) |
---|
249 | (test-assert (= (queue.front qu) 1)) |
---|
250 | (queue.deq! qu) |
---|
251 | (test-assert (= (queue.size qu) 1)) |
---|
252 | (queue.clear! qu) |
---|
253 | (queue.empty? qu) |
---|
254 | (test-assert (equal? (protocol qu) |
---|
255 | '(queue? empty? size show state front enq! deq! clear!))) |
---|
256 | ) |
---|
257 | |
---|
258 | |
---|
259 | ;; sample collection -- simple-table .. also a table |
---|
260 | |
---|
261 | (define-predicate table?) |
---|
262 | (define-operation (lookup table key failure-object)) |
---|
263 | (define-operation (associate! table key value)) ;; returns key |
---|
264 | (define-operation (remove! table key)) ;; returns value |
---|
265 | |
---|
266 | (define (make-simple-table) |
---|
267 | (let ( (table (list)) ) |
---|
268 | (object |
---|
269 | ;; table behaviors |
---|
270 | ((table? self) #t) |
---|
271 | ((size self) (size table)) |
---|
272 | ((print self port) (format port "#<simple-table>")) |
---|
273 | ((lookup self key failure-object) |
---|
274 | (cond |
---|
275 | ((assq key table) => cdr) |
---|
276 | (else failure-object) |
---|
277 | )) |
---|
278 | ((associate! self key value) |
---|
279 | (cond |
---|
280 | ((assq key table) => (lambda (bucket) (set-cdr! bucket value) key)) |
---|
281 | (else |
---|
282 | (set! table (cons (cons key value) table)) |
---|
283 | key) |
---|
284 | )) |
---|
285 | ((remove! self key) ;; returns old value |
---|
286 | (cond |
---|
287 | ((null? table) (error "table:remove! key not found: " key)) |
---|
288 | ((eq? key (caar table)) |
---|
289 | (let ( (value (cdar table)) ) |
---|
290 | (set! table (cdr table)) |
---|
291 | value) |
---|
292 | ) |
---|
293 | (else |
---|
294 | (let loop ( (last table) (this (cdr table)) ) |
---|
295 | (cond |
---|
296 | ((null? this) (error "table:remove! key not found: " key)) |
---|
297 | ((eq? key (caar this)) |
---|
298 | (let ( (value (cdar this)) ) |
---|
299 | (set-cdr! last (cdr this)) |
---|
300 | value) |
---|
301 | ) |
---|
302 | (else |
---|
303 | (loop (cdr last) (cdr this))) |
---|
304 | ) ) ) |
---|
305 | )) |
---|
306 | ;; collection behaviors |
---|
307 | ((collection? self) #t) |
---|
308 | ((gen-keys self) (list->generator (map car table))) |
---|
309 | ((gen-elts self) (list->generator (map cdr table))) |
---|
310 | ((for-each-key self proc) |
---|
311 | (for-each (lambda (bucket) (proc (car bucket))) table) |
---|
312 | ) |
---|
313 | ((for-each-elt self proc) |
---|
314 | (for-each (lambda (bucket) (proc (cdr bucket))) table) |
---|
315 | ) |
---|
316 | ) ) ) |
---|
317 | |
---|
318 | (define t (make-simple-table)) |
---|
319 | |
---|
320 | (test-group "collections" |
---|
321 | |
---|
322 | (for-each-elt |
---|
323 | (lambda (item) |
---|
324 | (print "item: " item)) |
---|
325 | '(1 2 3)) |
---|
326 | (test-assert (collection? t)) |
---|
327 | (test-assert (empty? t)) |
---|
328 | (associate! t 'a 1) |
---|
329 | (associate! t 'b 2) |
---|
330 | (test 2 (size t)) |
---|
331 | (let ((g (gen-keys t))) |
---|
332 | (test "gen-keys" '(b a) (list (g) (g)))) |
---|
333 | (let ((g (gen-elts t))) |
---|
334 | (test "gen-elts" '(2 1) (list (g) (g)))) |
---|
335 | (test "map-keys" #(b a) (map-keys identity t)) |
---|
336 | (test "map-elts" #(2 1) (map-elts identity t)) |
---|
337 | (test "reduce" 3 (reduce + 0 t)) |
---|
338 | (test "reduce-items" 3 (reduce-items (lambda (item ax) |
---|
339 | (+ (cadr item) ax)) 0 t)) |
---|
340 | (test "reduce*" 1 (reduce* min '(1 2 3 4 10 5 6 8 7 9))) |
---|
341 | (test "sort!" #(1 2 3 4 5) (sort! (lambda (i vi j vj) (< vi vj)) |
---|
342 | #( 5 2 4 3 1))) |
---|
343 | (test "sort" #(7 8 9 10 11) (sort (lambda (i vi j vj) (< vi vj)) |
---|
344 | '( 11 8 10 7 9))) |
---|
345 | |
---|
346 | ) |
---|