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 
129 665c255d 2023-08-04 jrmu   ;; end rectangular and polar representations
130 665c255d 2023-08-04 jrmu 
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))))
143 665c255d 2023-08-04 jrmu 
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))))
157 665c255d 2023-08-04 jrmu   'done)
158 665c255d 2023-08-04 jrmu 
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))
167 665c255d 2023-08-04 jrmu 
168 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. 
169 665c255d 2023-08-04 jrmu 
170 665c255d 2023-08-04 jrmu (define (attach-tag type-tag contents)
171 665c255d 2023-08-04 jrmu   (if (eq? type-tag 'scheme-number)
172 665c255d 2023-08-04 jrmu       contents
173 665c255d 2023-08-04 jrmu       (cons type-tag contents)))
174 665c255d 2023-08-04 jrmu (define (type-tag datum)
175 665c255d 2023-08-04 jrmu   (cond ((number? datum) 'scheme-number)
176 665c255d 2023-08-04 jrmu 	((pair? datum) (car datum))
177 665c255d 2023-08-04 jrmu 	((error "error -- invalid datum" datum))))
178 665c255d 2023-08-04 jrmu (define (contents datum)
179 665c255d 2023-08-04 jrmu   (cond ((number? datum) datum)
180 665c255d 2023-08-04 jrmu 	((pair? datum) (cdr datum))
181 665c255d 2023-08-04 jrmu 	((error "error -- invalid datum" datum))))
182 665c255d 2023-08-04 jrmu 
183 665c255d 2023-08-04 jrmu (define (test-case actual expected)
184 665c255d 2023-08-04 jrmu   (newline)
185 665c255d 2023-08-04 jrmu   (display "Actual:   ")
186 665c255d 2023-08-04 jrmu   (display actual)
187 665c255d 2023-08-04 jrmu   (newline)
188 665c255d 2023-08-04 jrmu   (display "Expected: ")
189 665c255d 2023-08-04 jrmu   (display expected)
190 665c255d 2023-08-04 jrmu   (newline))
191 665c255d 2023-08-04 jrmu 
192 665c255d 2023-08-04 jrmu (test-case (make-scheme-number 5) 5)
193 665c255d 2023-08-04 jrmu (test-case (make-