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