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