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