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))
