1 665c255d 2023-08-04 jrmu (define (assoc key records)
2 665c255d 2023-08-04 jrmu (cond ((null? records) false)
3 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
4 665c255d 2023-08-04 jrmu (else (assoc key (cdr records)))))
6 665c255d 2023-08-04 jrmu (define (make-table)
7 665c255d 2023-08-04 jrmu (let ((local-table (list '*table*)))
8 665c255d 2023-08-04 jrmu (define (lookup key-1 key-2)
9 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
10 665c255d 2023-08-04 jrmu (if subtable
11 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
13 665c255d 2023-08-04 jrmu (cdr record)
16 665c255d 2023-08-04 jrmu (define (insert! key-1 key-2 value)
17 665c255d 2023-08-04 jrmu (let ((subtable (assoc key-1 (cdr local-table))))
18 665c255d 2023-08-04 jrmu (if subtable
19 665c255d 2023-08-04 jrmu (let ((record (assoc key-2 (cdr subtable))))
21 665c255d 2023-08-04 jrmu (set-cdr! record value)
22 665c255d 2023-08-04 jrmu (set-cdr! subtable
23 665c255d 2023-08-04 jrmu (cons (cons key-2 value)
24 665c255d 2023-08-04 jrmu (cdr subtable)))))
25 665c255d 2023-08-04 jrmu (set-cdr! local-table
26 665c255d 2023-08-04 jrmu (cons (list key-1
27 665c255d 2023-08-04 jrmu (cons key-2 value))
28 665c255d 2023-08-04 jrmu (cdr local-table)))))
30 665c255d 2023-08-04 jrmu (define (dispatch m)
31 665c255d 2023-08-04 jrmu (cond ((eq? m 'lookup-proc) lookup)
32 665c255d 2023-08-04 jrmu ((eq? m 'insert-proc!) insert!)
33 665c255d 2023-08-04 jrmu (else (error "Unknown operation -- Table" m))))
36 665c255d 2023-08-04 jrmu (define operation-table (make-table))
37 665c255d 2023-08-04 jrmu (define get (operation-table 'lookup-proc))
38 665c255d 2023-08-04 jrmu (define put (operation-table 'insert-proc!))
41 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
42 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
43 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
45 665c255d 2023-08-04 jrmu (apply proc (map contents args))
46 665c255d 2023-08-04 jrmu (error "error -- procedure not found" (list op args)))))
48 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
49 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
50 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
51 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
53 665c255d 2023-08-04 jrmu (define (install-scheme-number-package)
54 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'scheme-number x))
55 665c255d 2023-08-04 jrmu (display "tag installed")
56 665c255d 2023-08-04 jrmu (put 'add '(scheme-number scheme-number)
57 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
58 665c255d 2023-08-04 jrmu (display "add installed")
59 665c255d 2023-08-04 jrmu (put 'sub '(scheme-number scheme-number)
60 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
61 665c255d 2023-08-04 jrmu (put 'mul '(scheme-number scheme-number)
62 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
63 665c255d 2023-08-04 jrmu (put 'div '(scheme-number scheme-number)
64 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
65 665c255d 2023-08-04 jrmu (put 'make 'scheme-number
66 665c255d 2023-08-04 jrmu (lambda (n) (tag n)))
67 665c255d 2023-08-04 jrmu (display "grabbing procedure")
68 665c255d 2023-08-04 jrmu (test-case ((get 'add '(scheme-number scheme-number)) 3 4) 7)
69 665c255d 2023-08-04 jrmu (display "procedure grabbed")
72 665c255d 2023-08-04 jrmu (define (install-rational-package)
73 665c255d 2023-08-04 jrmu (define (gcd a b)
76 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
77 665c255d 2023-08-04 jrmu (define (numer x) (car x))
78 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
79 665c255d 2023-08-04 jrmu (define (make-rat n d)
80 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
81 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g))))
82 665c255d 2023-08-04 jrmu (define (add-rat x y)
83 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
84 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
85 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
86 665c255d 2023-08-04 jrmu (define (sub-rat x y)
87 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
88 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
89 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
90 665c255d 2023-08-04 jrmu (define (mul-rat x y)
91 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
92 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
93 665c255d 2023-08-04 jrmu (define (div-rat x y)
94 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
95 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
96 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
97 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
98 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
99 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
100 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
101 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
102 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
103 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
104 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
105 665c255d 2023-08-04 jrmu (put 'make 'rational
106 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
109 665c255d 2023-08-04 jrmu (define (install-complex-package)
110 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
111 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
112 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
113 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
115 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
116 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
117 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
118 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
120 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
122 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
123 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
124 665c255d 2023-08-04 jrmu (cons x y))
125 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
126 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
127 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
128 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
129 665c255d 2023-08-04 jrmu (define (magnitude z)
130 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
131 665c255d 2023-08-04 jrmu (square (imag-part z)))))
132 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
133 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
134 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
135 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
136 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
137 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
138 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
139 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
140 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
141 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
143 665c255d 2023-08-04 jrmu (define (install-complex-polar)
144 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
145 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
146 665c255d 2023-08-04 jrmu (atan y x)))
147 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
148 665c255d 2023-08-04 jrmu (cons r a))
149 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
150 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
151 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
152 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
153 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
154 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
155 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
156 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
157 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
158 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
159 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
160 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
161 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
163 665c255d 2023-08-04 jrmu (install-complex-rectangular)
164 665c255d 2023-08-04 jrmu (install-complex-polar)
165 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
167 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
168 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
169 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
170 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
171 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
172 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
173 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
174 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
175 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
176 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
177 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
178 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
180 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
181 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
182 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
183 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
184 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
185 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
186 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
187 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
188 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
189 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
190 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
191 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
192 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
195 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
196 665c255d 2023-08-04 jrmu ((get 'make 'scheme-number) n))
197 665c255d 2023-08-04 jrmu (define (make-rational n d)
198 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
199 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
200 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
201 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
202 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
205 665c255d 2023-08-04 jrmu ;; install number packages
207 665c255d 2023-08-04 jrmu (install-scheme-number-package)
208 665c255d 2023-08-04 jrmu (install-rational-package)
209 665c255d 2023-08-04 jrmu (install-complex-package)
212 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.
214 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
215 665c255d 2023-08-04 jrmu (if (eq? type-tag 'scheme-number)
217 665c255d 2023-08-04 jrmu (cons type-tag contents)))
218 665c255d 2023-08-04 jrmu (define (type-tag datum)
219 665c255d 2023-08-04 jrmu (cond ((number? datum) 'scheme-number)
220 665c255d 2023-08-04 jrmu ((pair? datum) (car datum))
221 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
222 665c255d 2023-08-04 jrmu (define (contents datum)
223 665c255d 2023-08-04 jrmu (cond ((number? datum) datum)
224 665c255d 2023-08-04 jrmu ((pair? datum) (cdr datum))
225 665c255d 2023-08-04 jrmu ((error "error -- invalid datum" datum))))
227 665c255d 2023-08-04 jrmu (define (test-case actual expected)
229 665c255d 2023-08-04 jrmu (display "Actual: ")
230 665c255d 2023-08-04 jrmu (display actual)
232 665c255d 2023-08-04 jrmu (display "Expected: ")
233 665c255d 2023-08-04 jrmu (display expected)
236 665c255d 2023-08-04 jrmu (test-case (make-scheme-number 5) 5)
237 665c255d 2023-08-04 jrmu (test-case (add (make-scheme-number 5)
238 665c255d 2023-08-04 jrmu (make-scheme-number 5))
241 665c255d 2023-08-04 jrmu (div (make-scheme-number -12)
242 665c255d 2023-08-04 jrmu (subtract (make-scheme-number 4)
243 665c255d 2023-08-04 jrmu (mul (make-scheme-number 3)
244 665c255d 2023-08-04 jrmu (make-scheme-number 2))))
