1 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
2 665c255d 2023-08-04 jrmu (cons type-tag contents))
3 665c255d 2023-08-04 jrmu (define (type-tag datum)
4 665c255d 2023-08-04 jrmu (if (pair? datum)
6 665c255d 2023-08-04 jrmu (error "error -- invalid datum" datum)))
7 665c255d 2023-08-04 jrmu (define (contents datum)
8 665c255d 2023-08-04 jrmu (if (pair? datum)
10 665c255d 2023-08-04 jrmu (error "error -- invalid datum" datum)))
11 665c255d 2023-08-04 jrmu (define (apply-generic op . args)
12 665c255d 2023-08-04 jrmu (let* ((type-tags (map type-tag args))
13 665c255d 2023-08-04 jrmu (proc (get op type-tags)))
15 665c255d 2023-08-04 jrmu (apply proc (map contents args))
16 665c255d 2023-08-04 jrmu (error "error -- procedure not found" (list op args)))))
18 665c255d 2023-08-04 jrmu (define (add x y) (apply-generic 'add x y))
19 665c255d 2023-08-04 jrmu (define (sub x y) (apply-generic 'sub x y))
20 665c255d 2023-08-04 jrmu (define (mul x y) (apply-generic 'mul x y))
21 665c255d 2023-08-04 jrmu (define (div x y) (apply-generic 'div x y))
23 665c255d 2023-08-04 jrmu (define (install-scheme-number-package)
24 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'scheme-number x))
25 665c255d 2023-08-04 jrmu (put 'add '(scheme-number scheme-number)
26 665c255d 2023-08-04 jrmu (lambda (x y) (tag (+ x y))))
27 665c255d 2023-08-04 jrmu (put 'sub '(scheme-number scheme-number)
28 665c255d 2023-08-04 jrmu (lambda (x y) (tag (- x y))))
29 665c255d 2023-08-04 jrmu (put 'mul '(scheme-number scheme-number)
30 665c255d 2023-08-04 jrmu (lambda (x y) (tag (* x y))))
31 665c255d 2023-08-04 jrmu (put 'div '(scheme-number scheme-number)
32 665c255d 2023-08-04 jrmu (lambda (x y) (tag (/ x y))))
33 665c255d 2023-08-04 jrmu (put 'make 'scheme-number
34 665c255d 2023-08-04 jrmu (lambda (n) (tag n)))
37 665c255d 2023-08-04 jrmu (define (install-rational-package)
38 665c255d 2023-08-04 jrmu (define (gcd a b)
41 665c255d 2023-08-04 jrmu (gcd b (remainder a b))))
42 665c255d 2023-08-04 jrmu (define (numer x) (car x))
43 665c255d 2023-08-04 jrmu (define (denom x) (cdr x))
44 665c255d 2023-08-04 jrmu (define (make-rat n d)
45 665c255d 2023-08-04 jrmu (let ((g (gcd n d)))
46 665c255d 2023-08-04 jrmu (cons (/ n g) (/ d g))))
47 665c255d 2023-08-04 jrmu (define (add-rat x y)
48 665c255d 2023-08-04 jrmu (make-rat (+ (* (numer x) (denom y))
49 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
50 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
51 665c255d 2023-08-04 jrmu (define (sub-rat x y)
52 665c255d 2023-08-04 jrmu (make-rat (- (* (numer x) (denom y))
53 665c255d 2023-08-04 jrmu (* (numer y) (denom x)))
54 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
55 665c255d 2023-08-04 jrmu (define (mul-rat x y)
56 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (numer y))
57 665c255d 2023-08-04 jrmu (* (denom x) (denom y))))
58 665c255d 2023-08-04 jrmu (define (div-rat x y)
59 665c255d 2023-08-04 jrmu (make-rat (* (numer x) (denom y))
60 665c255d 2023-08-04 jrmu (* (denom x) (numer y))))
61 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rational x))
62 665c255d 2023-08-04 jrmu (put 'add '(rational rational)
63 665c255d 2023-08-04 jrmu (lambda (x y) (tag (add-rat x y))))
64 665c255d 2023-08-04 jrmu (put 'sub '(rational rational)
65 665c255d 2023-08-04 jrmu (lambda (x y) (tag (sub-rat x y))))
66 665c255d 2023-08-04 jrmu (put 'mul '(rational rational)
67 665c255d 2023-08-04 jrmu (lambda (x y) (tag (mul-rat x y))))
68 665c255d 2023-08-04 jrmu (put 'div '(rational rational)
69 665c255d 2023-08-04 jrmu (lambda (x y) (tag (div-rat x y))))
70 665c255d 2023-08-04 jrmu (put 'make 'rational
71 665c255d 2023-08-04 jrmu (lambda (n d) (tag (make-rat n d))))
74 665c255d 2023-08-04 jrmu (define (install-complex-package)
75 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
76 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'rectangular) x y))
77 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
78 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'polar) r a))
80 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
81 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
82 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
83 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
85 665c255d 2023-08-04 jrmu ;; rectangular and polar representations...
87 665c255d 2023-08-04 jrmu (define (install-complex-rectangular)
88 665c255d 2023-08-04 jrmu (define (make-from-real-imag-rectangular x y)
90 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-rectangular r a)
91 665c255d 2023-08-04 jrmu (cons (* r (cos a)) (* r (sin a))))
92 665c255d 2023-08-04 jrmu (define (real-part z) (car z))
93 665c255d 2023-08-04 jrmu (define (imag-part z) (cdr z))
94 665c255d 2023-08-04 jrmu (define (magnitude z)
95 665c255d 2023-08-04 jrmu (sqrt (+ (square (real-part z))
96 665c255d 2023-08-04 jrmu (square (imag-part z)))))
97 665c255d 2023-08-04 jrmu (define (angle z) (atan (imag-part z) (real-part z)))
98 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'rectangular x))
99 665c255d 2023-08-04 jrmu (put 'real-part '(rectangular) real-part)
100 665c255d 2023-08-04 jrmu (put 'imag-part '(rectangular) imag-part)
101 665c255d 2023-08-04 jrmu (put 'magnitude '(rectangular) magnitude)
102 665c255d 2023-08-04 jrmu (put 'angle '(rectangular) angle)
103 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'rectangular
104 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-rectangular x y))))
105 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'rectangular
106 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-rectangular r a))))
108 665c255d 2023-08-04 jrmu (define (install-complex-polar)
109 665c255d 2023-08-04 jrmu (define (make-from-real-imag-polar x y)
110 665c255d 2023-08-04 jrmu (cons (sqrt (+ (square x) (square y)))
111 665c255d 2023-08-04 jrmu (atan y x)))
112 665c255d 2023-08-04 jrmu (define (make-from-mag-ang-polar r a)
113 665c255d 2023-08-04 jrmu (cons r a))
114 665c255d 2023-08-04 jrmu (define (real-part z) (* (magnitude z) (cos (angle z))))
115 665c255d 2023-08-04 jrmu (define (imag-part z) (* (magnitude z) (sin (angle z))))
116 665c255d 2023-08-04 jrmu (define (magnitude z) (car z))
117 665c255d 2023-08-04 jrmu (define (angle z) (cdr z))
118 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'polar x))
119 665c255d 2023-08-04 jrmu (put 'real-part '(polar) real-part)
120 665c255d 2023-08-04 jrmu (put 'imag-part '(polar) imag-part)
121 665c255d 2023-08-04 jrmu (put 'magnitude '(polar) magnitude)
122 665c255d 2023-08-04 jrmu (put 'angle '(polar) angle)
123 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'polar
124 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag-polar x y))))
125 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'polar
126 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang-polar r a))))
129 665c255d 2023-08-04 jrmu ;; end rectangular and polar representations
131 665c255d 2023-08-04 jrmu (define (add-complex z1 z2)
132 665c255d 2023-08-04 jrmu (make-from-real-imag (+ (real-part z1) (real-part z2))
133 665c255d 2023-08-04 jrmu (+ (imag-part z1) (imag-part z2))))
134 665c255d 2023-08-04 jrmu (define (sub-complex z1 z2)
135 665c255d 2023-08-04 jrmu (make-from-real-imag (- (real-part z1) (real-part z2))
136 665c255d 2023-08-04 jrmu (- (imag-part z1) (imag-part z2))))
137 665c255d 2023-08-04 jrmu (define (mul-complex z1 z2)
138 665c255d 2023-08-04 jrmu (make-from-mag-ang (* (magnitude z1) (magnitude z2))
139 665c255d 2023-08-04 jrmu (+ (angle z1) (angle z2))))
140 665c255d 2023-08-04 jrmu (define (div-complex z1 z2)
141 665c255d 2023-08-04 jrmu (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
142 665c255d 2023-08-04 jrmu (- (angle z1) (angle z2))))
144 665c255d 2023-08-04 jrmu (define (tag x) (attach-tag 'complex x))
145 665c255d 2023-08-04 jrmu (put 'add '(complex complex)
146 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (add-complex z1 z2))))
147 665c255d 2023-08-04 jrmu (put 'sub '(complex complex)
148 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (sub-complex z1 z2))))
149 665c255d 2023-08-04 jrmu (put 'mul '(complex complex)
150 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (mul-complex z1 z2))))
151 665c255d 2023-08-04 jrmu (put 'div '(complex complex)
152 665c255d 2023-08-04 jrmu (lambda (z1 z2) (tag (div-complex z1 z2))))
153 665c255d 2023-08-04 jrmu (put 'make-from-real-imag 'complex
154 665c255d 2023-08-04 jrmu (lambda (x y) (tag (make-from-real-imag x y))))
155 665c255d 2023-08-04 jrmu (put 'make-from-mag-ang 'complex
156 665c255d 2023-08-04 jrmu (lambda (r a) (tag (make-from-mag-ang r a))))
159 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
160 665c255d 2023-08-04 jrmu ((get 'make 'scheme-number) n))
161 665c255d 2023-08-04 jrmu (define (make-rational n d)
162 665c255d 2023-08-04 jrmu ((get 'make 'rational) n d))
163 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y)
164 665c255d 2023-08-04 jrmu ((get 'make-from-real-imag 'complex) x y))
165 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a)
166 665c255d 2023-08-04 jrmu ((get 'make-from-mag-ang 'complex) r a))
168 665c255d 2023-08-04 jrmu ;; 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 665c255d 2023-08-04 jrmu (put 'real-part '(complex) real-part)
171 665c255d 2023-08-04 jrmu (put 'imag-part '(complex) imag-part)
172 665c255d 2023-08-04 jrmu (put 'magnitude '(complex) magnitude)
173 665c255d 2023-08-04 jrmu (put 'angle '(complex) angle)
175 665c255d 2023-08-04 jrmu ;; 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 665c255d 2023-08-04 jrmu 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 665c255d 2023-08-04 jrmu (define (real-part z) (apply-generic 'real-part z))
180 665c255d 2023-08-04 jrmu (define (imag-part z) (apply-generic 'imag-part z))
181 665c255d 2023-08-04 jrmu (define (magnitude z) (apply-generic 'magnitude z))
182 665c255d 2023-08-04 jrmu (define (angle z) (apply-generic 'angle z))
184 665c255d 2023-08-04 jrmu ;; 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 665c255d 2023-08-04 jrmu A single call to (magnitude z) from outside the packages ends up as follows:
187 665c255d 2023-08-04 jrmu 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 665c255d 2023-08-04 jrmu Apply-generic is invoked twice.
