1 (define (attach-tag type-tag contents)
2   (cons type-tag contents))
3 (define (type-tag datum)
4   (if (pair? datum)
5       (car datum)
6       (error "error -- invalid datum" datum)))
7 (define (contents datum)
8   (if (pair? datum)
9       (cdr datum)
10       (error "error -- invalid datum" datum)))
11 (define (apply-generic op . args)
12   (let* ((type-tags (map type-tag args))
13 	 (proc (get op type-tags)))
14     (if proc
15 	(apply proc (map contents args))
16 	(error "error -- procedure not found" (list op args)))))
17 
18 (define (add x y) (apply-generic 'add x y))
19 (define (sub x y) (apply-generic 'sub x y))
20 (define (mul x y) (apply-generic 'mul x y))
21 (define (div x y) (apply-generic 'div x y))
22 
23 (define (install-scheme-number-package)
24   (define (tag x) (attach-tag 'scheme-number x))
25   (put 'add '(scheme-number scheme-number)
26        (lambda (x y) (tag (+ x y))))
27   (put 'sub '(scheme-number scheme-number) 
28        (lambda (x y) (tag (- x y))))
29   (put 'mul '(scheme-number scheme-number)
30        (lambda (x y) (tag (* x y))))
31   (put 'div '(scheme-number scheme-number)
32        (lambda (x y) (tag (/ x y))))
33   (put 'make 'scheme-number
34        (lambda (n) (tag n)))
35   'done))
36 
37 (define (install-rational-package)
38   (define (gcd a b)
39     (if (= b 0)
40 	a
41 	(gcd b (remainder a b))))
42   (define (numer x) (car x))
43   (define (denom x) (cdr x))
44   (define (make-rat n d)
45     (let ((g (gcd n d)))
46       (cons (/ n g) (/ d g))))
47   (define (add-rat x y)
48     (make-rat (+ (* (numer x) (denom y))
49 		 (* (numer y) (denom x)))
50 	      (* (denom x) (denom y))))
51   (define (sub-rat x y)
52     (make-rat (- (* (numer x) (denom y))
53 		 (* (numer y) (denom x)))
54 	      (* (denom x) (denom y))))
55   (define (mul-rat x y)
56     (make-rat (* (numer x) (numer y))
57 	      (* (denom x) (denom y))))
58   (define (div-rat x y)
59     (make-rat (* (numer x) (denom y))
60 	      (* (denom x) (numer y))))
61   (define (tag x) (attach-tag 'rational x))
62   (put 'add '(rational rational) 
63        (lambda (x y) (tag (add-rat x y))))
64   (put 'sub '(rational rational) 
65        (lambda (x y) (tag (sub-rat x y))))
66   (put 'mul '(rational rational) 
67        (lambda (x y) (tag (mul-rat x y))))
68   (put 'div '(rational rational) 
69        (lambda (x y) (tag (div-rat x y))))
70   (put 'make 'rational
71        (lambda (n d) (tag (make-rat n d))))
72   'done)
73 
74 (define (install-complex-package)
75   (define (make-from-real-imag x y)
76     ((get 'make-from-real-imag 'rectangular) x y))
77   (define (make-from-mag-ang r a)
78     ((get 'make-from-mag-ang 'polar) r a))
79 
80   (define (real-part z) (apply-generic 'real-part z))
81   (define (imag-part z) (apply-generic 'imag-part z))
82   (define (magnitude z) (apply-generic 'magnitude z))
83   (define (angle z) (apply-generic 'angle z))
84 
85   ;; rectangular and polar representations...
86 
87   (define (install-complex-rectangular)
88     (define (make-from-real-imag-rectangular x y)
89       (cons x y))
90     (define (make-from-mag-ang-rectangular r a)
91       (cons (* r (cos a)) (* r (sin a))))
92     (define (real-part z) (car z))
93     (define (imag-part z) (cdr z))
94     (define (magnitude z)
95       (sqrt (+ (square (real-part z)) 
96 	       (square (imag-part z)))))
97     (define (angle z) (atan (imag-part z) (real-part z)))
98     (define (tag x) (attach-tag 'rectangular x))
99     (put 'real-part '(rectangular) real-part)
100     (put 'imag-part '(rectangular) imag-part)
101     (put 'magnitude '(rectangular) magnitude)
102     (put 'angle '(rectangular) angle)
103     (put 'make-from-real-imag 'rectangular
104 	 (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
105     (put 'make-from-mag-ang 'rectangular
106 	 (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
107     'done)
108   (define (install-complex-polar)
109     (define (make-from-real-imag-polar x y)
110       (cons (sqrt (+ (square x) (square y)))
111 	    (atan y x)))
112     (define (make-from-mag-ang-polar r a)
113       (cons r a))
114     (define (real-part z) (* (magnitude z) (cos (angle z))))
115     (define (imag-part z) (* (magnitude z) (sin (angle z))))
116     (define (magnitude z) (car z))
117     (define (angle z) (cdr z))
118     (define (tag x) (attach-tag 'polar x))
119     (put 'real-part '(polar) real-part)
120     (put 'imag-part '(polar) imag-part)
121     (put 'magnitude '(polar) magnitude)
122     (put 'angle '(polar) angle)
123     (put 'make-from-real-imag 'polar
124 	 (lambda (x y) (tag (make-from-real-imag-polar x y))))
125     (put 'make-from-mag-ang 'polar
126 	 (lambda (r a) (tag (make-from-mag-ang-polar r a))))
127     'done)  
128 
129   ;; end rectangular and polar representations
130 
131   (define (add-complex z1 z2)
132     (make-from-real-imag (+ (real-part z1) (real-part z2))
133 			 (+ (imag-part z1) (imag-part z2))))
134   (define (sub-complex z1 z2)
135     (make-from-real-imag (- (real-part z1) (real-part z2))
136 			 (- (imag-part z1) (imag-part z2))))
137   (define (mul-complex z1 z2)
138     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
139 		       (+ (angle z1) (angle z2))))
140   (define (div-complex z1 z2)
141     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
142 		       (- (angle z1) (angle z2))))
143 
144   (define (tag x) (attach-tag 'complex x))
145   (put 'add '(complex complex) 
146        (lambda (z1 z2) (tag (add-complex z1 z2))))
147   (put 'sub '(complex complex) 
148        (lambda (z1 z2) (tag (sub-complex z1 z2))))
149   (put 'mul '(complex complex) 
150        (lambda (z1 z2) (tag (mul-complex z1 z2))))
151   (put 'div '(complex complex) 
152        (lambda (z1 z2) (tag (div-complex z1 z2))))
153   (put 'make-from-real-imag 'complex 
154        (lambda (x y) (tag (make-from-real-imag x y))))
155   (put 'make-from-mag-ang 'complex 
156        (lambda (r a) (tag (make-from-mag-ang r a))))
157   'done)
158 
159 (define (make-scheme-number n)
160   ((get 'make 'scheme-number) n))
161 (define (make-rational n d)
162   ((get 'make 'rational) n d))
163 (define (make-complex-from-real-imag x y) 
164   ((get 'make-from-real-imag 'complex) x y))
165 (define (make-complex-from-mag-ang r a) 
166   ((get 'make-from-mag-ang 'complex) r a))
167 
168 ;; 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. 
169 
170 (define (attach-tag type-tag contents)
171   (if (eq? type-tag 'scheme-number)
172       contents
173       (cons type-tag contents)))
174 (define (type-tag datum)
175   (cond ((number? datum) 'scheme-number)
176 	((pair? datum) (car datum))
177 	((error "error -- invalid datum" datum))))
178 (define (contents datum)
179   (cond ((number? datum) datum)
180 	((pair? datum) (cdr datum))
181 	((error "error -- invalid datum" datum))))
182 
183 (define (test-case actual expected)
184   (newline)
185   (display "Actual:   ")
186   (display actual)
187   (newline)
188   (display "Expected: ")
189   (display expected)
190   (newline))
191 
192 (test-case (make-scheme-number 5) 5)
193 (test-case (make-