source: project/release/5/yasos/tags/1.7/tests/run.scm @ 36340

Last change on this file since 36340 was 36340, checked in by iraikov, 8 weeks ago

yasos release 1.7

File size: 11.7 KB
Line 
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-gen-elts (map car table)))
309      ((gen-elts self) (list-gen-elts (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    (test-assert (collection? t))
323    (test-assert (empty? t))
324    (associate! t 'a 1)
325    (associate! t 'b 2)
326    (test 2 (size t))
327    (let ((g (gen-keys t)))
328      (test "gen-keys" '(b a) (list (g) (g))))
329    (let ((g (gen-elts t)))
330      (test "gen-elts" '(2 1) (list (g) (g))))
331    (test "map-keys" #(b a) (map-keys identity t))
332    (test "map-elts" #(2 1) (map-elts identity t))
333    (test "reduce" 3 (reduce (lambda (ax item) (+ (cadr item) ax)) 0 t))
334
335    )
Note: See TracBrowser for help on using the repository browser.