blob: 84714a3ab89679650992ba08a7b86837ddefdc57 (
plain)
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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
|
#lang racket
(provide
make-apply-with-raising-and-drop
make-apply-with-coercion
make-apply-pred
make-apply
make-dispatch-table
printer
getter
putter
attach-tag
type-tag
contents
find-type)
(require "./lists.rkt")
;; Type tagged data
(define (attach-tag type-tag contents)
(cond ((exact-integer? contents) contents)
((inexact-real? contents) contents)
((number? contents) contents)
((symbol? contents) contents)
(else (cons type-tag contents))))
(define (type-tag datum)
(cond
((pair? datum) (car datum))
((symbol? datum) 'symbol)
((exact-integer? datum) 'integer)
((inexact-real? datum) 'real)
((rational? datum) 'real)
((number? datum) 'scheme-number)
((boolean? datum) 'boolean)
(else (error "Bad tagged datum -- TYPE-TAG" datum))))
(define (contents datum)
(cond
((pair? datum) (cdr datum))
((number? datum) datum)
((symbol? datum) datum)
(else (error "Bad tagged datum -- CONTENTS" datum))))
(define (find-type type seq)
(define (rec items)
(cond ((null? items) false)
((equal? type (type-tag (car items))) (car items))
(else (rec (cdr items)))))
(rec seq))
;; dispatch table abstraction barrier/ encapsulation
;; ('op (list ('(types) item)))
(define (make-dispatch-table)
(define dispatch-table '())
(define (printer)
(newline)
(println dispatch-table))
(define (get op types)
; (display (list "GET -- " op types))
(let ((op-datum (find-type op dispatch-table)))
(if op-datum
(let ((proc-datum (find-type types (contents op-datum))))
(if (pair? proc-datum)
(contents proc-datum)
false))
false)))
(define (update-op-datum op-datum types proc)
(attach-tag (type-tag op-datum)
(if (find-type types (contents op-datum))
(map (lambda (proc-datum)
(if (not (eq? (type-tag proc-datum) types))
proc-datum
(attach-tag (type-tag proc-datum) proc)))
(contents op-datum))
(cons (attach-tag types proc) (contents op-datum)))))
(define (put op types item)
(if (find-type op dispatch-table)
(set! dispatch-table
(map (lambda (op-datum) ;;just copy the table for now, don't want to mutate yet
(if (not (equal? (type-tag op-datum) op))
op-datum
(update-op-datum op-datum types item)))
dispatch-table))
(set! dispatch-table (cons
(attach-tag op
(list (attach-tag types item)))
dispatch-table))))
(list dispatch-table get put printer))
(define (getter t)
(cadr t))
(define (putter t)
(caddr t))
(define (printer t)
(cadddr t))
(define (make-apply get)
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(error
"No method for these types -- APPLY-GENERIC"
(list op type-tags)))))))
(define (make-apply-pred get)
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
false)))))
(define (make-apply-pred-symbol get)
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
false)))))
(define (make-apply-with-coercion get get-coercion)
(define (make-apply get)
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
false)))))
(define apply-generic (make-apply get))
;; try to coerce all arguments to a type
(define (coerce-or-fail t args)
(define (iter coerced remaining-args)
(cond ((null? remaining-args) coerced)
((equal? t (type-tag (car remaining-args)))
(append coerced (car remaining-args)))
(else (let ((t->arg (get-coercion t (type-tag (car remaining-args)))))
(if t->arg
(append coerced (t->arg t))
false)))))
(iter '() args))
;; try to coerce all arguments to the type of one them
(define (try-coerce type-tags op args)
(define (iter havent-tried)
(if (null? havent-tried)
(error "no method for these types --" (list op type-tags))
(let ((coerced-args (coerce-or-fail (type-tag (car havent-tried)) args)))
(if coerced-args
(apply apply-generic (cons op coerced-args))
(iter (cdr havent-tried))))))
(iter type-tags))
(lambda (op . args)
(let ((type-tags (map type-tag args)))
(let ((proc (get op type-tags)))
(if proc
(apply proc (map contents args))
(try-coerce type-tags op args))))))
;; Generic apply that can raise and drop methods in a tower of types
(define (type-match? args)
(not (find-first (lambda (x)
(not (equal? (type-tag x)
(type-tag (car args)))))
args)))
(define (count-raises-until-top get datum)
(define (iter i raised)
(let ((proc (get 'raise (list (type-tag raised)))))
(if proc
(iter (+ i 1) (proc (contents raised)))
i)))
(iter 0 datum))
(define (highest-type get items)
(cdr
(foldl
(lambda (raises item result)
(cond ((< (car result) 0) (cons raises item))
((< raises (car result)) (cons raises item))
(else result)))
(cons -1 'nil)
(map (lambda (x)
(count-raises-until-top get x))
items)
(map type-tag items))))
(define (raise-until get type datum)
(cond ((equal? type (type-tag datum)) datum)
(else (let ((proc (get 'raise (list (type-tag datum)))))
(if proc
(raise-until get type (proc (contents datum)))
false)))))
(define (raise-until-type-match get type items)
(cond ((null? items) '())
(else (let ((result (raise-until get type (car items))))
(if result
(cons result (raise-until-type-match get type (cdr items)))
(error "Could not raise type --" (list type items)))))))
; (raise-until-type-match (make-apply-pred get)
; (highest-type (make-apply-pred get) (list 1 test-complex))
; (list 1 test-complex)))))))
(define (make-apply-with-raising apply-generic get)
(lambda (op . args)
(let ((result (apply apply-generic (cons op args))))
(if result
result
(let ((raised-args (raise-until-type-match get (highest-type get args) args)))
(let ((raised-result (apply apply-generic (cons op raised-args))))
(if raised-result
raised-result
(error "Could not apply --" (list op args raised-args)))))))))
(define (make-apply-with-raising-and-drop get)
(define local-apply (make-apply get))
(define (raisetower datum)
(local-apply 'raise datum))
(define (project datum)
(local-apply 'project datum))
(define (equ? d1 d2)
(local-apply 'equ? d1 d2))
(define (raisable? datum)
(get 'raise (list (type-tag datum))))
(define (can-drop? datum)
(let ((dropped (project datum)))
(if (raisable? dropped)
(let ((raised (raisetower dropped)))
(and (get 'equ? (list (type-tag raised) (type-tag datum)))
(equ? raised datum)))
false)))
(define (projectable? datum)
(get 'project (list (type-tag datum))))
(define (towerdrop datum)
(if (projectable? datum)
(cond ((can-drop? datum)
(towerdrop (project datum)))
(else datum))
datum))
(lambda (op . args)
; (display (list "APPLY -- " op args))
(let ((proc (get op (map type-tag args))))
(if proc
(towerdrop (apply proc (map contents args)))
(let ((raised-args (raise-until-type-match get (highest-type get args) args)))
(let ((raised-proc (get op (map type-tag raised-args))))
(if raised-proc
(towerdrop (apply raised-proc (map contents raised-args)))
(error "Could not apply --" (list op raised-args)))))))))
|
