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 "invalid datum -- TYPE-TAG" 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 "invalid datum -- TYPE-TAG" 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 "procedure not found -- APPLY-GENERIC" (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)
 25 665c255d 2023-08-04 jrmu     (attach-tag 'scheme-number x))
 26 665c255d 2023-08-04 jrmu   (put 'add '(scheme-number scheme-number)
 27 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (+ x y))))
 28 665c255d 2023-08-04 jrmu   (put 'sub '(scheme-number scheme-number)
 29 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (- x y))))
 30 665c255d 2023-08-04 jrmu   (put 'mul '(scheme-number scheme-number)
 31 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (* x y))))
 32 665c255d 2023-08-04 jrmu   (put 'div '(scheme-number scheme-number)
 33 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (/ x y))))
 34 665c255d 2023-08-04 jrmu   (put 'make 'scheme-number
 35 665c255d 2023-08-04 jrmu        (lambda (x) (tag x)))
 36 665c255d 2023-08-04 jrmu   'done)
 37 665c255d 2023-08-04 jrmu 
 38 665c255d 2023-08-04 jrmu (define (make-scheme-number n)
 39 665c255d 2023-08-04 jrmu   ((get 'make 'scheme-number) n))
 40 665c255d 2023-08-04 jrmu 
 41 665c255d 2023-08-04 jrmu (define (install-rational-package)
 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) (lambda (x y) (tag (add-rat x y))))
 63 665c255d 2023-08-04 jrmu   (put 'sub '(rational rational) (lambda (x y) (tag (sub-rat x y))))
 64 665c255d 2023-08-04 jrmu   (put 'mul '(rational rational) (lambda (x y) (tag (mul-rat x y))))
 65 665c255d 2023-08-04 jrmu   (put 'div '(rational rational) (lambda (x y) (tag (div-rat x y))))
 66 665c255d 2023-08-04 jrmu   (put 'make 'rational (lambda (n d) (tag (make-rat n d))))
 67 665c255d 2023-08-04 jrmu   'done)
 68 665c255d 2023-08-04 jrmu 
 69 665c255d 2023-08-04 jrmu (define (make-rational n d)
 70 665c255d 2023-08-04 jrmu   ((get 'make 'rational) n d))
 71 665c255d 2023-08-04 jrmu 
 72 665c255d 2023-08-04 jrmu (define (install-complex-package)
 73 665c255d 2023-08-04 jrmu   (define (make-from-real-imag x y)
 74 665c255d 2023-08-04 jrmu     ((get 'make-from-real-imag 'rectangular) x y))
 75 665c255d 2023-08-04 jrmu   (define (make-from-mag-ang r a)
 76 665c255d 2023-08-04 jrmu     ((get 'make-from-mag-ang 'polar) r a))
 77 665c255d 2023-08-04 jrmu   (define (add-complex z1 z2)
 78 665c255d 2023-08-04 jrmu     (make-from-real-imag (+ (real-part z1) (real-part z2))
 79 665c255d 2023-08-04 jrmu 			 (+ (imag-part z1) (imag-part z2))))
 80 665c255d 2023-08-04 jrmu   (define (sub-complez x1 x2)
 81 665c255d 2023-08-04 jrmu     (make-from-real-imag (- (real-part z1) (real-part z2))
 82 665c255d 2023-08-04 jrmu 			 (- (imag-part z1) (imag-part z2))))
 83 665c255d 2023-08-04 jrmu   (define (mul-complex z1 z2)
 84 665c255d 2023-08-04 jrmu     (make-from-mag-ang (* (magnitude z1) (magnitude z2))
 85 665c255d 2023-08-04 jrmu 		       (+ (angle z1) (angle z2))))
 86 665c255d 2023-08-04 jrmu   (define (div-complex z1 z2)
 87 665c255d 2023-08-04 jrmu     (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
 88 665c255d 2023-08-04 jrmu 		       (- (angle z1) (angle z2))))
 89 665c255d 2023-08-04 jrmu   (define (tag z) (attach-tag 'complex z))
 90 665c255d 2023-08-04 jrmu   (put 'add '(complex complex) 
 91 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (add-complex z1 z2))))
 92 665c255d 2023-08-04 jrmu   (put 'sub '(complex complex) 
 93 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (sub-complex z1 z2))))
 94 665c255d 2023-08-04 jrmu   (put 'mul '(complex complex) 
 95 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (mul-complex z1 z2))))
 96 665c255d 2023-08-04 jrmu   (put 'div '(complex complex) 
 97 665c255d 2023-08-04 jrmu        (lambda (z1 z2) (tag (div-complex z1 z2))))
 98 665c255d 2023-08-04 jrmu   (put 'make-from-real-imag 'complex 
 99 665c255d 2023-08-04 jrmu        (lambda (x y) (tag (make-from-real-imag x y))))
100 665c255d 2023-08-04 jrmu   (put 'make-from-mag-ang 'complex 
101 665c255d 2023-08-04 jrmu        (lambda (r a) (tag (make-from-mag-ang r a))))
102 665c255d 2023-08-04 jrmu   'done)
103 665c255d 2023-08-04 jrmu 
104 665c255d 2023-08-04 jrmu (define (make-from-real-imag x y)
105 665c255d 2023-08-04 jrmu   ((get 'make-from-real-imag 'complex) x y))
106 665c255d 2023-08-04 jrmu (define (make-from-mag-ang r a)
107 665c255d 2023-08-04 jrmu   ((get 'make-from-mag-ang 'complex) r a))