1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
|
;; FILE "bank-example.oak"
;; IMPLEMNETS Bank account example from YASOS article
;; AUTHOR Ken Dickey
;; DATE 5 aUGUST 2004
;; (define-predicate foo?)
;;-> (define-instance foo? operation)
;; (add-method (foo? (object) self) #f)
(define-local-syntax (define-predicate name)
`(block
(define-instance ,name operation)
(add-method (,name (object) self) #f)))
;; (add-predicate-true foo? type)
;;-> (add-method (foo? (type) self) #t)
(define-local-syntax (add-predicate-true name type)
`(add-method (,name (,type) self) #t))
;; (define-type name slots supers)
;; -> (define-instance name TYPE slots (list super...))
(define-local-syntax (define-object-type name slots . supers)
`(define-instance ,name type ',slots (list ,@supers)))
(define-local-syntax (define-operation name)
`(define-instance ,name operation))
(define-local-syntax (define-settable-operation name)
`(define-instance ,name settable-operation))
;; @@DEBUG
;; (define trace-expansion #t)
;; Test 'em out
;; <PERSON>
(define-predicate person?)
(define-object-type <person> (name age SSN password) object)
(add-predicate-true person? <person>)
(add-method (initialize (<person> name age SSN password)
self the-name the-age the-ssn the-password)
(set! name the-name)
(set! age the-age)
(set! SSN the-ssn)
(set! password the-password)
self)
(define-operation name)
(define-settable-operation age)
(define-operation SSN)
(define-operation bad-password)
(define-operation change-password)
(add-method (name (<person> name) self) name)
(add-method (age (<person> age) self) age)
(add-method ((setter age) (<person> age) self new-age)
(set! age new-age))
(add-method (SSN (<person> SSN password) self a-password)
(if (equal? password a-password)
SSN
(bad-password self a-password)))
(add-method (bad-password (<person>) self bogus-password)
(let ( (message
(format #f
"bad password \"~a\""
bogus-password))
)
(format #t "~%~a" message)
message))
(add-method (change-password (<person> password) self old-passwd new-passwd)
(if (equal? old-passwd password)
(block (set! password new-passwd) self)
(bad-password self old-passwd)))
;; <BANK-ACCOUNT-TRANSACTION-HISTORY>
;; Just a reverse list of balances (i.e. newest 1st, oldest last)
(define-object-type <bank-account-transaction-history> (reverse-history) object)
(add-method (initialize (<bank-account-transaction-history> reverse-history)
self initial-balance)
(set! reverse-history (list initial-balance))
self)
(define-instance history operation)
(define-instance add operation)
(add-method (history (<bank-account-transaction-history> reverse-history) self)
(reverse reverse-history))
(add-method (add (<bank-account-transaction-history> reverse-history) self new-balance)
(set! reverse-history (cons new-balance reverse-history))
new-balance)
;; <BANK-ACCOUNT>
(define-predicate bank-account?)
(define-object-type <bank-account> (master-password p-i-n balance)
<person> <bank-account-transaction-history>)
(add-predicate-true bank-account? <bank-account>)
(add-method (initialize (<bank-account> master-password p-i-n balance)
self master-passwd initial-balance name age SSN PIN)
(set! master-password master-passwd)
(set! p-i-n PIN)
(set! balance initial-balance)
(^super <bank-account-transaction-history> initialize self initial-balance)
(^super <person> initialize self name age SSN p-i-n)
self)
(define-operation current-balance)
;;(define-operation add operation) @@@ defined above
(define-operation withdraw)
(define-settable-operation PIN)
(add-method (current-balance (<bank-account> balance p-i-n master-password) self passwd)
(if (or (equal? passwd p-i-n)
(equal? passwd master-password))
balance
(bad-password self passwd)))
(add-method (pin (<bank-account> master-password p-i-n) self passwd)
(if (equal? passwd master-password)
p-i-n
(bad-password self passwd)))
(add-method ((setter pin) (<bank-account> master-password p-i-n) self passwd new-pin)
(if (equal? passwd master-password)
(block
(^super <person> change-password self p-i-n new-pin)
(set! p-i-n new-pin)
self)
(bad-password self passwd)))
(add-method (change-password (<bank-account> master-password p-i-n)
self old-passwd new-passwd)
(if (equal? old-passwd p-i-n)
((setter pin) self master-password new-passwd)
(bad-password self old-passwd)))
(add-method (bad-password (<bank-account>) self bogus-pssword)
(format #t "~%!!! CALL THE POLICE !!!")
(error "!!! CALL THE POLICE !!!"))
(add-method (history (<bank-account> master-password p-i-n) self passwd)
(if (or (equal? passwd p-i-n)
(equal? passwd master-password))
(^super <bank-account-transaction-history> self history)
(bad-password self passwd)))
(add-method (add (<bank-account> balance) self amount)
;; dumb checks elided (e.g. amount > 0)
(set! balance (+ balance amount))
(^super <bank-account-transaction-history> add self balance)
(format #t "~%new balance is ~a" balance)
self)
(add-method (withdraw (<bank-account> balance p-i-n) self amount passwd)
(cond
((not (equal? passwd p-i-n))
(bad-password self passwd))
((> amount balance)
(format #t "~%Error: can't withdraw more than you have!"))
(else
(set! balance (- balance amount))
(^super <bank-account-transaction-history> add self balance)
(format #t "~%new balance is ~a" balance))))
(add-method (SSN (<bank-account>) self passwd)
(^super <person> SSN self passwd))
;; --- E O F --- ;;
|
