sicp-ex-2.86

 (define (sine x) (apply-generic 'sine x)) 
 (define (cosine x) (apply-generic 'cosine x)) 
  
 ;; add into scheme-number package 
 (put 'sine 'scheme-number 
      (lambda (x) (tag (sin x)))) 
 (put 'cosine 'scheme-number 
      (lambda (x) (tag (cos x)))) 
  
 ;; add into rational package 
 (put 'sine 'rational 
      (lambda (x) (tag (sin x)))) 
 (put 'cosine 'rational 
      (lambda (x) (tag (cos x)))) 
  
 ;; To accomodate generic number in the complex package,  
 ;; we should replace operators such as + , * with theirs 
 ;; generic counterparts add, mul. 
 (define (add-complex z1 z2) 
   (make-from-real-imag (add (real-part z1) (real-part z2)) 
                        (add (imag-part z1) (imag-part z2)))) 
 (define (sub-complex z1 z2) 
   (make-from-real-imag (sub (real-part z1) (real-part z2)) 
                        (sub (imag-part z1) (imag-part z2)))) 
 (define (mul-complex z1 z2) 
   (make-from-mag-ang (mul (magnitude z1) (magnitude z2)) 
                      (add (angle z1) (angle z2)))) 
 (define (div-complex z1 z2) 
   (make-from-mag-ang (div (magnitude z1) (magnitude z2)) 
                      (sub (angle z1) (angle z2)))) 
  

 ;;; add into scheme-number package  
 (put 'sine 'rational (lambda (x) (sine (/ (numer x) (denom x)))))  
 (put 'cosine 'rational (lambda (x) (cosine (/ (numer x) (denom x))))) 

 ;; in scheme-number package, will raise first to rational, then to real 
 (put 'sine 'scheme-number 
      (lambda (x) (sine (raise (tag x))))) 
 ;; in rational package, will raise to real 
 (put 'sine 'rational 
      (lambda (x) (sine (raise (tag x))))) 
 ;; in real package, apply `sin` primitive 
 (put 'sine 'real 
      (lambda (x) (tag (sin x)))) 

methods sine and cosine can only be defined on the scheme-number type, lower types have coercion int apply-generic. other methods like atan and expt(for the sqrt) should also be included, because the polar complex package need them.

 ;;; add into global 
 (define (sine x) (apply-generic 'sine x)) 
 (define (cosine x) (apply-generic 'cosine x)) 
 (define (arctan x) (apply-generic 'arctan x)) 
 (define (exp x y) (apply-generic 'exp x y)) 
  
 ;;; add into rational package  
   (put 'sine '(number) (lambda (x) (tag (sin x)))) 
   (put 'cosine '(number) (lambda (x) (tag (cos x)))) 
   (put 'arctan '(number) (lambda (x) (tag (atan x)))) 
   (put 'exp '(number number) (lambda (x y) (tag (expt x y)))) 
  
 ;;; complex-rect package  
   (define (square x) (mul x x)) 
   (define (sqrt x) (exp x 0.5)) 
   (define (make-from-mag-ang r a) (cons (mul r (cosine a)) (mul r (sine a)))) 
   (define (magnitude z) (sqrt (add (square (real-part z)) (square (imag-part z))))) 
   (define (angle z) (arctan (div (imag-part z) (real-part z)))) 
  
 ;;; complex-polar package  
   (define (real-part z) (mul (magnitude z) (cosine (angle z)))) 
   (define (imag-part z) (mul (magnitude z) (sine (angle z)))) 
  
 ;;; complex package  
 (define (add-complex z1 z2) 
   (make-from-real-imag (add (real-part z1) (real-part z2)) 
                        (add (imag-part z1) (imag-part z2)))) 
 (define (sub-complex z1 z2) 
   (make-from-real-imag (sub (real-part z1) (real-part z2)) 
                        (sub (imag-part z1) (imag-part z2)))) 
 (define (mul-complex z1 z2) 
   (make-from-mag-ang (mul (magnitude z1) (magnitude z2)) 
                      (add (angle z1) (angle z2)))) 
 (define (div-complex z1 z2) 
   (make-from-mag-ang (div (magnitude z1) (magnitude z2)) 
                      (sub (angle z1) (angle z2)))) 
  

My idea is to rewrite all basic operators to type operators through decorator, and to unify the input and output of all computing processes into scheme-number .

 ;; Converting data types to scheme-number 
 (define (install-type->scheme-number-package) 
     ;; real -> scheme-number 
     (put 'get-scheme-number '(real) 
         (lambda (x) (make-scheme-number x))) 
      
     ;; rational -> scheme-number 
     (put 'get-scheme-number '(rational) 
         (lambda (r) 
             (make-scheme-number 
                 (contents (div (numer r) (denom r)))))) 
      
     ;; scheme-number -> scheme-number 
     (put 'get-scheme-number '(scheme-number) 
         (lambda (x) (make-scheme-number x))) 
      
     'done) 
  
 ;; Conversion interface 
 (define (get-scheme-number x) 
     (apply-generic 'get-scheme-number x)) 
  
 ;; To rewrite basic operations into a form that can handle combined data 
 ;; Return the result as scheme-number 
 (define (decorator f) 
     ;; Unified input 
     (define (transform args) 
         (map 
             (lambda (arg) 
                 (if (number? arg) 
                     (make-scheme-number arg) 
                     (get-scheme-number arg))) 
             args)) 
      
     ;; Unified output 
     (lambda (first . other) 
         (make-scheme-number 
             (let ((args (map 
                             contents 
                             (transform (cons first other))))) 
                 (apply f args))))) 
  
 ;; To rewrite basic operations with decorator 
 ;; You can also write like this: 
 ;;     (set! + (decorator +)) 
 ;; So you don't have to change the code of complex package. 
 ;; But once you do that, the other packages will suffer. 
 (define new-square (decorator square)) 
 (define new-sqrt (decorator sqrt)) 
 (define new-add (decorator +)) 
 (define new-sub (decorator -)) 
 (define new-mul (decorator *)) 
 (define new-div (decorator /)) 
 (define sine (decorator sin)) 
 (define cosine (decorator cos)) 
 (define new-atan (decorator atan)) 
  

  
  
  
  
 (define (decorator f) 
     (define (transform args) 
         (map 
             (lambda (arg) 
                 (if (number? arg) 
                     (make-scheme-number arg) 
                     (get-scheme-number arg))) 
             args)) 
      
     (lambda (first . other) 
         (let ((arg-seg (cons first other))) 
             (if (apply and (map number? arg-seg)) 
                 (apply f arg-seg) 
                 (make-scheme-number 
                     (apply f (map contents (transform arg-seg)))))))) 
  
 (define (operator-overload!) 
     (map 
         (lambda (f) 
             (set! f (decorator f))) 
         (list square sqrt + - * / sin cos atan))) 

This exercise introduces the possibility that the various parts of a complex number (real, imaginary, magnitude, angle) might be data objects of various number types (ordinary scheme numbers, rational numbers, etc.).

This means that the various procedures of the complex number package that manipulate these parts will need to be generic over the supported number types. For example, in the procedure that gets the magnitude of a complex number in rectangular form, the procedures square, + and sqrt need to be generic:

 (define (magnitude z) 
     (sqrt (+ (square (real-part z)) 
              (square (imag-part z))))) 

Below are the changes required in the system:

1. change the helper procedure definitions

 (define (square x) (mul x x)) ; redirect to the generic procedure mul 
 (define (sqroot x) (apply-geneirc 'sqroot x)) 
 (define (sine x) (apply-generic 'sine x)) 
 (define (cosine x) (apply-generic 'cosine x)) 
 (define (arctan y x) (apply-generic 'arctan y x)) 

2. implement the generic procedures for the various types

 add to scheme-number package 
 (put 'sqroot 'scheme-number (lambda (x) 
                               (tag (sqrt x)))) 
 (put 'sine 'scheme-number (lambda (x) 
                             (tag (sin x)))) 
 (put 'cosine 'scheme-number (lambda (x) 
                               (tag (cosine x)))) 
 (put 'arctan '(scheme-number scheme-number) (lambda (y x) 
                                               (tag (atan y x)))) 
 ; add to rational package 
 (put 'sqroot 'rational (lambda (x) 
                          (make-rational (sqroot (numer x)) 
                                         (sqroot (denom x))))) 
 ; convert to ordinary numbers for the other procedures 
 (define (rational->scheme-number x) 
   (make-scheme-number (/ (numer x) (denom x)))) 
 (put 'sine 'rational (lambda (x) 
                        (sine (rational->scheme-number x)))) 
 (put 'cosine 'rational (lambda (x) 
                        (cosine (rational->scheme-number x)))) 
 (put 'arctan '(rational rational) (lambda (y x) 
                        (arctan (rational->scheme-number y) 
                                (rational->scheme-number x)))) 

3. replace the primitive procedures +, -, *, / by the generic procedures add, sub, mul, div in the rectangular, polar and the complex-number packages. e.g. in the polar package,

 (define (real-part z) (mul (magnitude z) (cos (angle z)))) 
 (define (imag-part z) (mul (magnitude z) (sin (angle z)))) 
 (define (make-from-real-imag x y) 
     (cons (sqroot (add (square x) (square y))) 
           (arctan y x))) 

partj's solution only considers the complex numbers whose real parts and imaginary parts are of the same type when doing add and sub, and the complex numbers whose magnitudes and angles are of the same type when doing mul and div.

For example, if z1's real parts and imaginary parts are ordinary numbers, z2's real parts and imaginary parts are rational numbers. Then (add z1 z2) will result an error.

So wee need to add coercion.

 (define (rational->scheme-number x) 
   (let ((numer (car (contents x))) 
         (denom (cdr (contents x)))) 
     (make-scheme-number (/ (* numer 1.0) denom)))) 
  
 (put-coercion 'rational 'scheme-number rational->scheme-number) 
  

Here is the full code, already tested in Racket.

 #lang racket 
  
 ;;; 
 ;;; put-coersion & get-coersion 
 ;;; from https://gist.github.com/kinoshita-lab/b76a55759a0d0968cd97 
 ;;; 
  
 (define coercion-list '()) 
  
 (define (clear-coercion-list) 
   (set! coercion-list '())) 
  
 (define (put-coercion type1 type2 item) 
   (if (get-coercion type1 type2) coercion-list 
       (set! coercion-list 
             (cons (list type1 type2 item) 
                   coercion-list)))) 
  
 (define (get-coercion type1 type2) 
   (define (get-type1 listItem) 
     (car listItem)) 
   (define (get-type2 listItem) 
     (cadr listItem)) 
   (define (get-item listItem) 
     (caddr listItem)) 
   (define (get-coercion-iter list type1 type2) 
     (if (null? list) #f 
         (let ((top (car list))) 
           (if (and (equal? type1 (get-type1 top)) 
                    (equal? type2 (get-type2 top))) 
               (get-item top) 
               (get-coercion-iter (cdr list) type1 type2))))) 
   (get-coercion-iter coercion-list type1 type2)) 
  
 ;;; 
 ;;; Put & Get, from https://stackoverflow.com/a/19114031 
 ;;; 
  
 (define *op-table* (make-hash)) 
 (define (put op type proc) 
   (hash-set! *op-table* (list op type) proc)) 
 (define (get op type) 
   (hash-ref *op-table* (list op type) #f)) 
  
 ;;; 
 ;;; Tags from 2.4.2 
 ;;; 
  
 (define (attach-tag type-tag z) 
   (cons type-tag z)) 
  
 (define (type-tag datum) 
   (if (pair? datum) 
       (car datum) 
       (error "Not a pair: TYPE-TAG" datum))) 
 (define (contents datum) 
   (if (pair? datum) 
       (cdr datum) 
       (error "Not a pair: CONTENT" datum))) 
  
 ;;; 
 ;;; 2.4.3 Data-Directed Programming and Additivity 
 ;;; 
  
 (define (install-rectangular-package) 
   ;; internal procedures 
   (define (real-part z) (car z)) 
   (define (imag-part z) (cdr z)) 
   (define (make-from-real-imag x y) 
     (cons x y)) 
  
   ;; change sqrt, +, square, atan, *, cos, sin to generic procedures 
   (define (magnitude z) 
     (sqrt-generic (add (square-generic (real-part z)) 
                        (square-generic (imag-part z))))) 
   (define (angle z) 
     (atan-generic (imag-part z) (real-part z))) 
   (define (make-from-mag-ang r a) 
     (cons (mul r (cosine a)) (mul r (sine a)))) 
  
   ;; interface to the rest of the system 
   (define (tag x) 
     (attach-tag 'rectangular x)) 
   (put 'real-part '(rectangular) real-part) 
   (put 'imag-part '(rectangular) imag-part) 
   (put 'magnitude '(rectangular) magnitude) 
   (put 'angle '(rectangular) angle) 
   (put 'make-from-real-imag 'rectangular 
        (lambda (x y) 
          (tag (make-from-real-imag x y)))) 
   (put 'make-from-mag-ang 'rectangular 
        (lambda (r a) 
          (tag (make-from-mag-ang r a)))) 
   'done) 
  
 (define (install-polar-package) 
   ;; internal procedures 
   (define (magnitude z) (car z)) 
   (define (angle z) (cdr z)) 
   (define (make-from-mag-ang r a) (cons r a)) 
  
   ;; change *, cos, sin, sqrt, +, square, atan to generic procedures 
   (define (real-part z) 
     (mul (magnitude z) (cosine (angle z)))) 
   (define (imag-part z) 
     (mul (magnitude z) (sine (angle z)))) 
   (define (make-from-real-imag x y) 
     (cons (sqrt-generic (add (square-generic x) (square-generic y))) 
           (atan-generic y x))) 
  
   ;; interface to the rest of the system 
   (define (tag x) (attach-tag 'polar x)) 
   (put 'real-part '(polar) real-part) 
   (put 'imag-part '(polar) imag-part) 
   (put 'magnitude '(polar) magnitude) 
   (put 'angle '(polar) angle) 
   (put 'make-from-real-imag 'polar 
        (lambda (x y) 
          (tag (make-from-real-imag x y)))) 
   (put 'make-from-mag-ang 'polar 
        (lambda (r a) 
          (tag (make-from-mag-ang r a)))) 
   'done) 
  
  
 (define (real-part z) 
   (apply-generic 'real-part z)) 
 (define (imag-part z) 
   (apply-generic 'imag-part z)) 
 (define (magnitude z) 
   (apply-generic 'magnitude z)) 
 (define (angle z) 
   (apply-generic 'angle z)) 
  
 ;;; 
 ;;; APPLY-GENERIC 
 ;;; From 2.5.2 Combining Data of Different Types -> Coercion 
 ;;; 
  
 (define (apply-generic op . args) 
   (let ((type-tags (map type-tag args))) 
     (let ((proc (get op type-tags))) 
       (if proc 
           (apply proc (map contents args)) 
           (if (= (length args) 2) 
               (let ((type1 (car type-tags)) 
                     (type2 (cadr type-tags)) 
                     (a1 (car args)) 
                     (a2 (cadr args))) 
                 (let ((t1->t2 (get-coercion type1 type2)) 
                       (t2->t1 (get-coercion type2 type1))) 
                   (cond (t1->t2 
                          (apply-generic op (t1->t2 a1) a2)) 
                         (t2->t1 
                          (apply-generic op a1 (t2->t1 a2))) 
                         (else (error "No method for these types: 
                                       APPLY-GENERIC" 
                                      (list op type-tags)))))) 
               (error "No method for these types: APPLY-GENERIC" 
                      (list op type-tags))))))) 
  
 ;;; 
 ;;; Added 
 ;;; Coerce rational to scheme-number 
 ;;; 
  
 (define (rational->scheme-number x) 
   (let ((numer (car (contents x))) 
         (denom (cdr (contents x)))) 
     (make-scheme-number (/ (* numer 1.0) denom)))) 
  
 (put-coercion 'rational 'scheme-number rational->scheme-number) 
  
 ;;; 
 ;;; 2.5.1 Generic Arithmetic Operations 
 ;;; 
  
 (define (add x y) (apply-generic 'add x y)) 
 (define (sub x y) (apply-generic 'sub x y)) 
 (define (mul x y) (apply-generic 'mul x y)) 
 (define (div x y) (apply-generic 'div x y)) 
  
 ;; Add definitons of generic procedures 
 (define (sine x) (apply-generic 'sine x)) 
 (define (cosine x) (apply-generic 'cosine x)) 
 (define (sqrt-generic x) (apply-generic 'sqrt-generic x)) 
 (define (atan-generic y x) (apply-generic 'atan-generic y x)) 
 (define (square-generic x) (mul x x)) 
  
 (define (install-scheme-number-package) 
   (define (tag x) 
     (attach-tag 'scheme-number x)) 
   (put 'add '(scheme-number scheme-number) 
        (lambda (x y) (tag (+ x y)))) 
   (put 'sub '(scheme-number scheme-number) 
        (lambda (x y) (tag (- x y)))) 
   (put 'mul '(scheme-number scheme-number) 
        (lambda (x y) (tag (* x y)))) 
   (put 'div '(scheme-number scheme-number) 
        (lambda (x y) (tag (/ x y)))) 
   (put 'make 'scheme-number 
        (lambda (x) (tag x))) 
  
   ;; added 
   (put 'sine '(scheme-number) (lambda (x) (tag (sin x)))) 
   (put 'cosine '(scheme-number) (lambda (x) (tag (cos x)))) 
   (put 'sqrt-generic '(scheme-number) (lambda (x) (tag (sqrt x)))) 
   (put 'atan-generic '(scheme-number scheme-number) (lambda (y x) (tag (atan y x)))) 
  
   'done) 
  
 (define (make-scheme-number n) 
   ((get 'make 'scheme-number) n)) 
  
 (define (install-rational-package) 
   ;; internal procedures 
   (define (numer x) (car x)) 
   (define (denom x) (cdr x)) 
   (define (make-rat n d) 
     (let ((g (gcd n d))) 
       (cons (/ n g) (/ d g)))) 
   (define (add-rat x y) 
     (make-rat (+ (* (numer x) (denom y)) 
                  (* (numer y) (denom x))) 
               (* (denom x) (denom y)))) 
   (define (sub-rat x y) 
     (make-rat (- (* (numer x) (denom y)) 
                  (* (numer y) (denom x))) 
               (* (denom x) (denom y)))) 
   (define (mul-rat x y) 
     (make-rat (* (numer x) (numer y)) 
               (* (denom x) (denom y)))) 
   (define (div-rat x y) 
     (make-rat (* (numer x) (denom y)) 
               (* (denom x) (numer y)))) 
   ;; interface to rest of the system 
   (define (tag x) (attach-tag 'rational x)) 
   (put 'add '(rational rational) 
        (lambda (x y) (tag (add-rat x y)))) 
   (put 'sub '(rational rational) 
        (lambda (x y) (tag (sub-rat x y)))) 
   (put 'mul '(rational rational) 
        (lambda (x y) (tag (mul-rat x y)))) 
   (put 'div '(rational rational) 
        (lambda (x y) (tag (div-rat x y)))) 
   (put 'make 'rational 
        (lambda (n d) (tag (make-rat n d)))) 
  
   ;; added 
   (define (tag-schemenumber x) 
     (attach-tag 'scheme-number x)) 
   (put 'sine '(rational) 
        (lambda (x) 
          (tag-schemenumber (sin (/ (numer x) (denom x)))))) 
   (put 'cosine '(rational) 
        (lambda (x) 
          (tag-schemenumber (cos (/ (numer x) (denom x)))))) 
   (put 'sqrt-generic '(rational) 
        (lambda (x) 
          (tag-schemenumber (sqrt (/ (* 1.0 (numer x)) (denom x)))))) 
   (put 'atan-generic '(rational rational) 
        (lambda (y x) 
          (tag-schemenumber (atan (/ (numer y) (denom y)) 
                                  (/ (numer x) (denom x)))))) 
  
   'done) 
  
 (define (make-rational n d) 
   ((get 'make 'rational) n d)) 
  
 (define (install-complex-package) 
   ;; imported procedures from rectangular 
   ;; and polar packages 
   (define (make-from-real-imag x y) 
     ((get 'make-from-real-imag 
           'rectangular) 
      x y)) 
   (define (make-from-mag-ang r a) 
     ((get 'make-from-mag-ang 'polar) 
      r a)) 
   ;; internal procedures 
  
   ;; change +, -, *, / to generic procedures 
   (define (add-complex z1 z2) 
     (make-from-real-imag 
      (add (real-part z1) (real-part z2)) 
      (add (imag-part z1) (imag-part z2)))) 
   (define (sub-complex z1 z2) 
     (make-from-real-imag 
      (sub (real-part z1) (real-part z2)) 
      (sub (imag-part z1) (imag-part z2)))) 
   (define (mul-complex z1 z2) 
     (make-from-mag-ang 
      (mul (magnitude z1) (magnitude z2)) 
      (add (angle z1) (angle z2)))) 
   (define (div-complex z1 z2) 
     (make-from-mag-ang 
      (div (magnitude z1) (magnitude z2)) 
      (sub (angle z1) (angle z2)))) 
  
   ;; interface to rest of the system 
   (define (tag z) (attach-tag 'complex z)) 
   (put 'add '(complex complex) 
        (lambda (z1 z2) 
          (tag (add-complex z1 z2)))) 
   (put 'sub '(complex complex) 
        (lambda (z1 z2) 
          (tag (sub-complex z1 z2)))) 
   (put 'mul '(complex complex) 
        (lambda (z1 z2) 
          (tag (mul-complex z1 z2)))) 
   (put 'div '(complex complex) 
        (lambda (z1 z2) 
          (tag (div-complex z1 z2)))) 
   (put 'make-from-real-imag 'complex 
        (lambda (x y) 
          (tag (make-from-real-imag x y)))) 
   (put 'make-from-mag-ang 'complex 
        (lambda (r a) 
          (tag (make-from-mag-ang r a)))) 
   'done) 
  
 (define (make-complex-from-real-imag x y) 
   ((get 'make-from-real-imag 'complex) x y)) 
 (define (make-complex-from-mag-ang r a) 
   ((get 'make-from-mag-ang 'complex) r a)) 
  
  
 ;;; 
 ;;; Test 
 ;;; 
  
 (install-scheme-number-package) 
 (install-rational-package) 
 (install-rectangular-package) 
 (install-polar-package) 
 (install-complex-package) 
  
 (define x1 (make-scheme-number 1)) 
 (define x2 (make-scheme-number 2)) 
  
 (define y1 (make-rational 2 3)) 
 (define y2 (make-rational 2 5)) 
  
 (define z1 (make-complex-from-mag-ang x1 x2)) 
 (define z2 (make-complex-from-mag-ang x1 y1)) 
 (define z3 (make-complex-from-real-imag y1 y2)) 
  
 (add z1 z2) 
 (add z1 z3) 
 (sub z1 z2) 
 (sub z1 z3) 
 (mul z1 z2) 
 (mul z1 z3) 
 (div z1 z2) 
 (div z1 z3)