1 665c255d 2023-08-04 jrmu ;; Exercise 2.78. The internal procedures in the scheme-number package are essentially nothing more than calls to the primitive procedures +, -, etc. It was not possible to use the primitives of the language directly because our type-tag system requires that each data object have a type attached to it. In fact, however, all Lisp implementations do have a type system, which they use internally. Primitive predicates such as symbol? and number? determine whether data objects have particular types. Modify the definitions of type-tag, contents, and attach-tag from section 2.4.2 so that our generic system takes advantage of Scheme's internal type system. That is to say, the system should work as before except that ordinary numbers should be represented simply as Scheme numbers rather than as pairs whose car is the symbol scheme-number.
3 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
4 665c255d 2023-08-04 jrmu (if (eq? type-tag 'scheme-number)
6 665c255d 2023-08-04 jrmu (cons type-tag contents)))
7 665c255d 2023-08-04 jrmu (define (type-tag datum)
8 665c255d 2023-08-04 jrmu (cond ((number? datum) 'scheme-number)
9 665c255d 2023-08-04 jrmu ((pair? datum) (car datum))
10 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
11 665c255d 2023-08-04 jrmu (define (contents datum)
12 665c255d 2023-08-04 jrmu (cond ((number? datum) datum)
13 665c255d 2023-08-04 jrmu ((pair? datum) (cdr datum))
14 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
16 665c255d 2023-08-04 jrmu (define (make-table)
17 665c255d 2023-08-04 jrmu (define (assoc key records)
18 665c255d 2023-08-04 jrmu (cond ((null? records) false)
19 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
20 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
21 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
22 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
23 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
24 665c255d 2023-08-04 jrmu (if subtable
25 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
27 665c255d 2023-08-04 jrmu (cdr record)
30 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
31 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
32 665c255d 2023-08-04 jrmu (if subtable
33 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
35 665c255d 2023-08-04 jrmu (set-cdr! record value)
36 665c255d 2023-08-04 jrmu (set-cdr! subtable
37 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
38 665c255d 2023-08-04 jrmu (cdr subtable)))))
39 665c255d 2023-08-04 jrmu (set-cdr! local-table
40 665c255d 2023-08-04 jrmu (cons (list key-1
41 665c255d 2023-08-04 jrmu (cons key-2 value))
42 665c255d 2023-08-04 jrmu (cdr local-table)))))
44 665c255d 2023-08-04 jrmu (define (dispatch m)
45 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
46 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
47 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- TABLE" m))))
50 665c255d 2023-08-04 jrmu (define operation-table (make-table))
51 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
52 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
54 665c255d 2023-08-04 jrmu ;; (define get 2d-get)
55 665c255d 2023-08-04 jrmu ;; (define put 2d-put!)
57 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
58 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
59 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
61 665c255d 2023-08-04 jrmu (apply proc (map contents args))
62 665c255d 2023-08-04 jrmu (error "error -- procedure not found" (list op args)))))
64 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
65 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
66 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
67 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
69 665c255d 2023-08-04 jrmu (define (install-scheme-number-package)
70 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'scheme-number x))
71 665c255d 2023-08-04 jrmu (put 'add '(scheme-number scheme-number)
72 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
73 665c255d 2023-08-04 jrmu (put 'sub '(scheme-number scheme-number)
74 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
75 665c255d 2023-08-04 jrmu (put 'mul '(scheme-number scheme-number)
76 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
77 665c255d 2023-08-04 jrmu (put 'div '(scheme-number scheme-number)
78 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
79 665c255d 2023-08-04 jrmu (put 'make 'scheme-number
80 665c255d 2023-08-04 jrmu (lambda (n) (tag n)))
83 665c255d 2023-08-04 jrmu (define (install-rational-package)
84 665c255d 2023-08-04 jrmu (define (gcd a b)
87 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
88 665c255d 2023-08-04 jrmu (define (numer x) (car x))
89 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
90 665c255d 2023-08-04 jrmu (define (make-rat n d)
91 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
92 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g))))
93 665c255d 2023-08-04 jrmu (define (add-rat x y)
94 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
95 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
96 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
97 665c255d 2023-08-04 jrmu (define (sub-rat x y)
98 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
99 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
100 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
101 665c255d 2023-08-04 jrmu (define (mul-rat x y)
102 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
103 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
104 665c255d 2023-08-04 jrmu (define (div-rat x y)
105 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
106 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
107 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
108 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
109 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
110 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
111 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
112 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
113 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
114 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
115 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
116 665c255d 2023-08-04 jrmu (put 'make 'rational
117 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
120 665c255d 2023-08-04 jrmu (define (install-complex-package)
121 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
122 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
123 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
124 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
126 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
127 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
128 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
129 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
131 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
133 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
134 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
135 665c255d 2023-08-04 jrmu (cons x y))
136 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
137 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
138 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
139 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
140 665c255d 2023-08-04 jrmu (define (magnitude z)
141 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
142 665c255d 2023-08-04 jrmu (square (imag-part z)))))
143 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
144 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
145 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
146 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
147 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
148 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
149 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
150 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
151 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
152 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
154 665c255d 2023-08-04 jrmu (define (install-complex-polar)
155 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
156 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
157 665c255d 2023-08-04 jrmu (atan y x)))
158 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
159 665c255d 2023-08-04 jrmu (cons r a))
160 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
161 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
162 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
163 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
164 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
165 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
166 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
167 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
168 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
169 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
170 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
171 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
172 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
174 665c255d 2023-08-04 jrmu (install-complex-rectangular)
175 665c255d 2023-08-04 jrmu (install-complex-polar)
176 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
178 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
179 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
180 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
181 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
182 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
183 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
184 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
185 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
186 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
187 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
188 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
189 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
191 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
192 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
193 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
194 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
195 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
196 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
197 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
198 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
199 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
200 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
201 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
202 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
203 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
206 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
207 665c255d 2023-08-04 jrmu ((get 'make 'scheme-number) n))
208 665c255d 2023-08-04 jrmu (define (make-rational n d)
209 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
210 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
211 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
212 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
213 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
216 665c255d 2023-08-04 jrmu ;; install number packages
218 665c255d 2023-08-04 jrmu (install-scheme-number-package)
219 665c255d 2023-08-04 jrmu (install-rational-package)
220 665c255d 2023-08-04 jrmu (install-complex-package)
223 665c255d 2023-08-04 jrmu (define (test-case actual expected)
225 665c255d 2023-08-04 jrmu (display "Actual: ")
226 665c255d 2023-08-04 jrmu (display actual)
228 665c255d 2023-08-04 jrmu (display "Expected: ")
229 665c255d 2023-08-04 jrmu (display expected)
232 665c255d 2023-08-04 jrmu (test-case (make-scheme-number 5) 5)
233 665c255d 2023-08-04 jrmu (test-case (contents (make-scheme-number 4)) 4)
234 665c255d 2023-08-04 jrmu (test-case (type-tag 5) 'scheme-number)
235 665c255d 2023-08-04 jrmu (test-case (add (make-scheme-number 5)
236 665c255d 2023-08-04 jrmu (make-scheme-number 5))
239 665c255d 2023-08-04 jrmu (div (make-scheme-number -12)
240 665c255d 2023-08-04 jrmu (sub (make-scheme-number 4)
241 665c255d 2023-08-04 jrmu (mul (make-scheme-number 3)
242 665c255d 2023-08-04 jrmu (make-scheme-number 2))))
245 665c255d 2023-08-04 jrmu (test-case (type-tag (make-rational 5 6)) 'rational)
246 665c255d 2023-08-04 jrmu (test-case (contents (make-rational 5 6)) (cons 5 6))
247 665c255d 2023-08-04 jrmu (test-case (add (sub (add (make-rational 5 6)
248 665c255d 2023-08-04 jrmu (make-rational 3 4))
249 665c255d 2023-08-04 jrmu (mul (make-rational 2 4)
250 665c255d 2023-08-04 jrmu (make-rational 1 4)))
251 665c255d 2023-08-04 jrmu (div (make-rational 3 4)
252 665c255d 2023-08-04 jrmu (make-rational 1 2)))
253 665c255d 2023-08-04 jrmu (cons 'rational (cons 71 24)))
255 665c255d 2023-08-04 jrmu (test-case (add (sub (add (make-complex-from-real-imag 5 6)
256 665c255d 2023-08-04 jrmu (make-complex-from-mag-ang 3 4))
257 665c255d 2023-08-04 jrmu (mul (make-complex-from-mag-ang 2 4)
258 665c255d 2023-08-04 jrmu (make-complex-from-real-imag 1 4)))
259 665c255d 2023-08-04 jrmu (div (make-complex-from-real-imag 3 4)
260 665c255d 2023-08-04 jrmu (make-complex-from-mag-ang 1 2)))
261 665c255d 2023-08-04 jrmu (cons 'complex (cons 'rectangular (cons 0.68068565 6.07986688))))
