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)
  5 665c255d 2023-08-04 jrmu       (car 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)
  9 665c255d 2023-08-04 jrmu       (cdr 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)))
 14 665c255d 2023-08-04 jrmu     (if proc
 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)))))
 17 665c255d 2023-08-04 jrmu 
 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))
 22 665c255d 2023-08-04 jrmu 
 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)))
 35 665c255d 2023-08-04 jrmu   'done))
 36 665c255d 2023-08-04 jrmu 
 37 665c255d 2023-08-04 jrmu (define (install-rational-package)
 38 665c255d 2023-08-04 jrmu   (define (gcd a b)
 39 665c255d 2023-08-04 jrmu     (if (= b 0)
 40 665c255d 2023-08-04 jrmu 	a
 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))))
 72 665c255d 2023-08-04 jrmu   'done)
 73 665c255d 2023-08-04 jrmu 
 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))
 79 665c255d 2023-08-04 jrmu 
 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))
 84 665c255d 2023-08-04 jrmu 
 85 665c255d 2023-08-04 jrmu   ;; rectangular and polar representations...
 86 665c255d 2023-08-04 jrmu 
 87 665c255d 2023-08-04 jrmu   (define (install-complex-rectangular)
 88 665c255d 2023-08-04 jrmu     (define (make-from-real-imag-rectangular x y)
 89 665c255d 2023-08-04 jrmu       (cons 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))))
107 665c255d 2023-08-04 jrmu     'done)
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))))
127 665c255d 2023-08-04 jrmu     'done)  
128 665c255d 2023-08-04 jrmu   (install-complex-rectangular)
129 665c255d 2023-08-04 jrmu   (install-complex-polar)
130 665c255d 2023-08-04 jrmu   ;; end rectangular and polar representations
131 665c255d 2023-08-04 jrmu 
132 665c255d 2023-08-04 jrmu   (define (add-complex z1 z2)
133 665c255d 2023-08-04 jrmu     (make-from-real-imag (+ (real-part z1) (real-part z2))
134 665c255d 2023-08-04 jrmu 			 (+ (imag-part z1) (imag-part z2))))
135 665c255d 2023-08-04 jrmu   (define (sub-complex z1 z2)
136 665c255d 2023-08-04 jrmu     (make-from-real-imag (- (real-part z1) (real-part z2))
137 665c255d 2023-08-04 jrmu 			 (- (imag-part z1) (imag-part z2))))
138 665c255d 2023-08-04 jrmu   (define (mul-complex z1 z2)
139 665c255d 2023-08-04 jrmu     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
140 665c255d 2023-08-04 jrmu 		       (+ (angle z1) (angle z2))))
141 665c255d 2023-08-04 jrmu   (define (div-complex z1 z2)
142 665c255d 2023-08-04 jrmu     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
143 665c255d 2023-08-04 jrmu 		       (- (angle z1) (angle z2))))
144 665c255d 2023-08-04 jrmu 
145 665c255d 2023-08-04 jrmu   (define (tag x) (attach-tag 'complex x))
146 665c255d 2023-08-04 jrmu   (put 'add '(complex complex) 
147 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (add-complex z1 z2))))
148 665c255d 2023-08-04 jrmu   (put 'sub '(complex complex) 
149 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (sub-complex z1 z2))))
150 665c255d 2023-08-04 jrmu   (put 'mul '(complex complex) 
151 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (mul-complex z1 z2))))
152 665c255d 2023-08-04 jrmu   (put 'div '(complex complex) 
153 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (div-complex z1 z2))))
154 665c255d 2023-08-04 jrmu   (put 'make-from-real-imag 'complex 
155 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (make-from-real-imag x y))))
156 665c255d 2023-08-04 jrmu   (put 'make-from-mag-ang 'complex 
157 665c255d 2023-08-04 jrmu        (lambda (r a) (tag (make-from-mag-ang r a))))
158 665c255d 2023-08-04 jrmu   'done)
159 665c255d 2023-08-04 jrmu 
160 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
161 665c255d 2023-08-04 jrmu   ((get 'make 'scheme-number) n))
162 665c255d 2023-08-04 jrmu (define (make-rational n d)
163 665c255d 2023-08-04 jrmu   ((get 'make 'rational) n d))
164 665c255d 2023-08-04 jrmu (define (make-complex-from-real-imag x y) 
165 665c255d 2023-08-04 jrmu   ((get 'make-from-real-imag 'complex) x y))
166 665c255d 2023-08-04 jrmu (define (make-complex-from-mag-ang r a) 
167 665c255d 2023-08-04 jrmu   ((get 'make-from-mag-ang 'complex) r a))
168 665c255d 2023-08-04 jrmu 
169 665c255d 2023-08-04 jrmu ;; 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. 
170 665c255d 2023-08-04 jrmu 
171 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
172 665c255d 2023-08-04 jrmu   (if (eq? type-tag 'scheme-number)
173 665c255d 2023-08-04 jrmu       contents
174 665c255d 2023-08-04 jrmu       (cons type-tag contents)))
175 665c255d 2023-08-04 jrmu (define (type-tag datum)
176 665c255d 2023-08-04 jrmu   (cond ((number? datum) 'scheme-number)
177 665c255d 2023-08-04 jrmu 	((pair? datum) (car datum))
178 665c255d 2023-08-04 jrmu 	((error "error -- invalid datum" datum))))
179 665c255d 2023-08-04 jrmu (define (contents datum)
180 665c255d 2023-08-04 jrmu   (cond ((number? datum) datum)
181 665c255d 2023-08-04 jrmu 	((pair? datum) (cdr datum))
182 665c255d 2023-08-04 jrmu 	((error "error -- invalid datum" datum))))
183 665c255d 2023-08-04 jrmu 
184 665c255d 2023-08-04 jrmu (define get 2d-get)
185 665c255d 2023-08-04 jrmu (define put 2d-put!)
186 665c255d 2023-08-04 jrmu 
187 665c255d 2023-08-04 jrmu (define (install-scheme-number-package)
188 665c255d 2023-08-04 jrmu (define (install-rational-package)
189 665c255d 2023-08-04 jrmu (define (install-complex-package)
190 665c255d 2023-08-04 jrmu 
191 665c255d 2023-08-04 jrmu 
192 665c255d 2023-08-04 jrmu (define (test-case actual expected)
193 665c255d 2023-08-04 jrmu   (newline)
194 665c255d 2023-08-04 jrmu   (display "Actual:   ")
195 665c255d 2023-08-04 jrmu   (display actual)
196 665c255d 2023-08-04 jrmu   (newline)
197 665c255d 2023-08-04 jrmu   (display "Expected: ")
198 665c255d 2023-08-04 jrmu   (display expected)
199 665c255d 2023-08-04 jrmu   (newline))
200 665c255d 2023-08-04 jrmu 
201 665c255d 2023-08-04 jrmu 
202 665c255d 2023-08-04 jrmu 
203 665c255d 2023-08-04 jrmu (test-case (make-scheme-number 5) 5)
204 665c255d 2023-08-04 jrmu (test-case (make-