1 (define (attach-tag type-tag contents)
2 (cons type-tag contents))
3 (define (type-tag datum)
6 (error "error -- invalid datum" datum)))
7 (define (contents 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)))
15 (apply proc (map contents args))
16 (error "error -- procedure not found" (list op args)))))
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))
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
37 (define (install-rational-package)
41 (gcd b (remainder a b))))
42 (define (numer x) (car x))
43 (define (denom x) (cdr x))
44 (define (make-rat n d)
46 (cons (/ n g) (/ d g))))
48 (make-rat (+ (* (numer x) (denom y))
49 (* (numer y) (denom x)))
50 (* (denom x) (denom y))))
52 (make-rat (- (* (numer x) (denom y))
53 (* (numer y) (denom x)))
54 (* (denom x) (denom y))))
56 (make-rat (* (numer x) (numer y))
57 (* (denom x) (denom 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))))
71 (lambda (n d) (tag (make-rat n d))))
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))
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))
85 ;; rectangular and polar representations...
87 (define (install-complex-rectangular)
88 (define (make-from-real-imag-rectangular 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))
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))))
108 (define (install-complex-polar)
109 (define (make-from-real-imag-polar x y)
110 (cons (sqrt (+ (square x) (square y)))
112 (define (make-from-mag-ang-polar 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))))
129 ;; end rectangular and polar representations
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))))
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))))
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))
168 ;; Exercise 2.77. Louis Reasoner tries to evaluate the expression (magnitude z) where z is the object shown in figure 2.24. To his surprise, instead of the answer 5 he gets an error message from apply-generic, saying there is no method for the operation magnitude on the types (complex). He shows this interaction to Alyssa P. Hacker, who says ``The problem is that the complex-number selectors were never defined for complex numbers, just for polar and rectangular numbers. All you have to do to make this work is add the following to the complex package:''
170 (put 'real-part '(complex) real-part)
171 (put 'imag-part '(complex) imag-part)
172 (put 'magnitude '(complex) magnitude)
173 (put 'angle '(complex) angle)
175 ;; We are exporting the selectors which are inside the complex package and putting them in the operation-and-type-table so that the generic procedures dispatch on type. These selectors are themselves generic procedures which depend upon selectors implemented in the rectangular/polar procedures which were exported to the operation-and-type-table.
177 What happens is that we have a datum z. Since it is a complex number, it is dispatched to the complex package after being stripped of its tag. This datum is then identified as a rectangular number, stripped of its tag, and dispatched to the rectangular package.
179 (define (real-part z) (apply-generic 'real-part z))
180 (define (imag-part z) (apply-generic 'imag-part z))
181 (define (magnitude z) (apply-generic 'magnitude z))
182 (define (angle z) (apply-generic 'angle z))
184 ;; Describe in detail why this works. As an example, trace through all the procedures called in evaluating the expression (magnitude z) where z is the object shown in figure 2.24. In particular, how many times is apply-generic invoked? What procedure is dispatched to in each case?
186 A single call to (magnitude z) from outside the packages ends up as follows:
187 The tag identifies that z is a complex number. The appropriate procedure of operation 'magnitude and type '(complex) is called on the contents of z (which is a datum typed as 'rectangular). This procedure is itself a generic selector, so the datum it receives is identified as type 'rectangular. The rectangular procedure is then called on the contents of z.
189 Apply-generic is invoked twice.
