sicp exercise 2.87

;; Exercise 2.87.  Install =zero? for polynomials in the generic arithmetic package. This will allow adjoin-term to work for polynomials with coefficients that are themselves polynomials.



(define (square x) (mul x x))
(define *op-table* (make-hash-table 10))
(define (put op type proc)
  (hash-set! *op-table* (list op type) proc))
(define (get op type)
  (hash-ref *op-table* (list op type) '()))

(define (get-highest-type args)
  (define (higher-type? num1-raised num2 num1)
    (let ((type1 (type num1-raised))
          (type2 (type num2)))
      (if (eq? type1 type2)
          num2
          (let ((raise-proc (get 'raise (list type1))))
            (if (null? raise-proc)
                num1
                (higher-type? (raise-proc (contents num1-raised)) num2 num1))))))
  (define (iter num rest-num)
    (cond ((null? rest-num) num)
          (else (iter (higher-type? num (car rest-num) num)
                      (cdr rest-num)))))
  (cond ((null? args) (error "ERROR"))
        ((null? (cdr args)) (car args))
        (else (type (iter (car args) (cdr args))))))

(define (raise-args highest-type args)
  (define (raise-to-type num)
    (if (eq? (type num) highest-type)
        num
        (raise-to-type (raise num))))
  (map raise-to-type args))

(define (apply-generic op . param)
  (define (apply-generic-raised)
    (let ((highest-type (get-highest-type param)))
      (let ((highest-type-args (map (lambda(x) highest-type) param)))
        (let ((proc (get op highest-type-args)))
          (if (null? proc) (error "no matching operation" op  "for types"
                                   highest-type-args)
              (apply proc (map contents (raise-args highest-type param))))))))
  (let ((type-tags (map type param)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc)) (apply proc (map contents param))
          (apply-generic-raised)))))


(define (drop num)
  (let ((project-proc (get 'project (list (type num)))))
    (if (null? project-proc) num
        (let ((projected-num (project-proc (contents num))))
          (if (equ? (raise projected-num) num)
              (drop projected-num)
              num)))))


;;
;;  number-system
;;

(define (is_integer? x)
  (and (integer? x) (exact? x)))

(define (is_real? x)
  (and (real? x) (inexact? x)))

(define (attach-tag tag oper)
  (cond ((is_integer? oper) oper)
        ((is_real? oper) oper)
        (else (list tag oper))))

(define (type data)
  (cond ((is_integer? data) 'integer)
        ((is_real? data) 'real-number)
        (else (car data))))

(define (contents data)
  (cond ((is_integer? data) data)
        ((is_real? data) data)
        (else (cadr data))))

(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))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (sqrt* x) (apply-generic 'sqrt x))
(define (sin* x) (apply-generic 'sin x))
(define (cos* x) (apply-generic 'cos x))
(define (atan* x y) (apply-generic 'atan x y))


(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))  
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer)
       (lambda(x y)(= x y)))
  (put '=zero? '(integer)
       (lambda(x)(= x 0)))
  (put 'raise '(integer)
       (lambda(x)(make-rational x 1)))
  (put 'sqrt '(integer) sqrt)
  (put 'sin '(integer) sin)
  (put 'cos '(integer) cos)
  (put 'atan '(integer integer) atan)
  'done)

(define (make-integer n)
  ((get 'make 'integer) (drop 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))))
  (define (eq? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (raise x)
    (make-real-number (exact->inexact (/ (numer x) (denom x)))))
  (define (project x)
    (numer x))

  ;; 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 'equ? '(rational rational) eq?)
  (put '=zero? '(rational) =zero?)
  (put 'raise  '(rational) raise)
  (put 'project  '(rational) project)
  (put 'sqrt '(rational) (lambda(x)(sqrt (raise x))))
  (put 'sin '(rational) (lambda(x)(sin (raise x))))
  (put 'cos '(rational) (lambda(x)(cos (raise x))))
  (put 'atan '(rational rational) (lambda(x y)(atan (raise x) (raise y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) (drop n) (drop d)))

(define (install-real-number-package)
  (define (tag x)
    (attach-tag 'real-number x))   
  (put 'add '(real-number real-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real-number real-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real-number real-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real-number real-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real-number
       (lambda (x) (tag (* 1.0 x))))
  (put 'equ? '(real-number real-number)
       (lambda(x y)(= x y)))
  (put '=zero? '(real-number)
       (lambda(x)(= x 0)))
  (put 'raise '(real-number)
       (lambda(x)(make-complex-from-real-imag x 0)))
  (put 'project '(real-number)
       (lambda(x)(make-rational (numerator (rationalize (inexact->exact x) 1/100))
                                (denominator (rationalize (inexact->exact x) 1/100)))))
  (put 'sqrt '(real-number) sqrt)
  (put 'sin '(real-number) sin)
  (put 'cos '(real-number) cos)
  (put 'atan '(real-number real-number) atan)
  'done)

(define (make-real-number n)
  ((get 'make 'real-number) n))


(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))
  (define (magnitude z)
    (sqrt* (add (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan* (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (mul r (cos* a)) (mul r (sin* a))))
  (define (eq? z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (equ? (real-part z) 0)
         (equ? (imag-part z) 0)))
  ;; 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))))
  (put 'equ?    '(rectangular rectangular) eq?)
  (put 'equ?    '(rectangular polar) eq?)
  (put '=zero? '(rectangular) =zero?)
  'done)

(define (real-part z)
  (apply-generic 'real-part z))
(define (imag-part z)
  (apply-generic 'imag-part z))

(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))
  (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 (sqrt* (add (square x) (square y)))
          (atan* y x)))
  (define (eq? z1 z2)
    (and (equ? (magnitude z1) (magnitude z2))
         (equ? (angle z1) (angle z2))))
  (define (=zero? z)
    (equ? (magnitude z) 0))
  ;; 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))))
  (put 'equ?   '(polar polar) eq?)
  (put 'equ?   '(polar rectangular) eq?)
  (put '=zero? '(polar) =zero?)
  'done)
(define (magnitude z)
  (apply-generic 'magnitude z))
(define (angle z)
  (apply-generic 'angle z))


(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 x y)
    ((get 'make-from-mag-ang 'polar) x y))
  ;; internal 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 'equ? '(complex complex) equ?)
  (put '=zero? '(complex) =zero?)

  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'project '(complex)
        (lambda(z)(make-real-number (real-part z))))

  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))


(define (install-polynomial-package)
  ;; internal procedures
  ;; representation of poly

  (define (make-poly variable term-list)
    (cons variable term-list))
  (define (variable p) (car p))
  (define (term-list p) (cdr p))
  (define (variable? x) (symbol? x))
  (define (same-variable? v1 v2)
    (and (variable? v1) (variable? v2) (eq? v1 v2)))

  ;; representation of terms and term lists
  (define (adjoin-term term term-list)
    (if (=zero? (coeff term))
        term-list
        (cons term term-list)))
  (define (the-empty-termlist) '())
  (define (first-term term-list) (car term-list))
  (define (rest-terms term-list) (cdr term-list))
  (define (empty-termlist? term-list) (null? term-list))
  (define (make-term order coeff) (list order coeff))
  (define (order term) (car term))
  (define (coeff term) (cadr term))

  (define (add-terms L1 L2)
    (cond ((empty-termlist? L1) L2)
          ((empty-termlist? L2) L1)
          (else
           (let ((t1 (first-term L1)) (t2 (first-term L2)))
             (cond ((> (order t1) (order t2))
                    (adjoin-term
                     t1 (add-terms (rest-terms L1) L2)))
                   ((< (order t1) (order t2))
                    (adjoin-term
                     t2 (add-terms L1 (rest-terms L2))))
                   (else
                    (adjoin-term
                     (make-term (order t1)
                                (add (coeff t1) (coeff t2)))
                     (add-terms (rest-terms L1)
                                (rest-terms L2)))))))))
  (define (mul-terms L1 L2)
    (if (empty-termlist? L1)
        (the-empty-termlist)
        (add-terms (mul-term-by-all-terms (first-term L1) L2)
                   (mul-terms (rest-terms L1) L2))))
  (define (mul-term-by-all-terms t1 L)
    (if (empty-termlist? L)
        (the-empty-termlist)
        (let ((t2 (first-term L)))
          (adjoin-term
           (make-term (+ (order t1) (order t2))
                      (mul (coeff t1) (coeff t2)))
           (mul-term-by-all-terms t1 (rest-terms L))))))
  (define (add-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (add-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- ADD-POLY"
               (list p1 p2))))
  (define (mul-poly p1 p2)
    (if (same-variable? (variable p1) (variable p2))
        (make-poly (variable p1)
                   (mul-terms (term-list p1)
                              (term-list p2)))
        (error "Polys not in same var -- MUL-POLY"
               (list p1 p2))))

  (define (=zerop? p)
    (empty-termlist? (coeff p)))

  ;; interface to rest of the system
  (define (tag p) (attach-tag 'polynomial p))
  (put 'add '(polynomial polynomial)
       (lambda (p1 p2) (tag (add-poly p1 p2))))
  (put 'mul '(polynomial polynomial)
       (lambda (p1 p2) (tag (mul-poly p1 p2))))
  (put '=zero? '(polynomial) =zerop? )
  (put 'make 'polynomial
       (lambda (var terms) (tag (make-poly var terms))))
  'done)

(define (make-poly variable . terms)
  ((get 'make 'polynomial) variable terms))
(define (make-term order coeff) (list order coeff))


(install-integer-package)
(install-rational-package)
(install-real-number-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)
(install-polynomial-package)


;;
;;  testing
;;

(define mypoly1 (make-poly 'x (make-term 3 4) (make-term 2 9)))
(display mypoly1) (newline)
(define mypoly2 (make-poly 'x (make-term 7 3) (make-term 3 8)))
(display mypoly2) (newline)

(display (add mypoly1 mypoly2)) (newline)
(display (mul mypoly1 mypoly2)) (newline)

(define mypoly_advanced (make-poly 'y (make-term 5 mypoly1) (make-term 3 mypoly2)))
(display mypoly_advanced) (newline)


(display (add mypoly_advanced mypoly_advanced)) (newline)

sicp exercise 2.86

;; Exercise 2.86.  Suppose we want to handle complex numbers whose real parts, imaginary parts, magnitudes, and angles can be either ordinary numbers, rational numbers, or other numbers we might wish to add to the system. Describe and implement the changes to the system needed to accommodate this. You will have to define operations such as sine and cosine that are generic over ordinary numbers and rational numbers.

;; Answer:

;; 1. the individual packages need to use add,sub,mul,div instead of +,-,*,/ except of integer and real package.
;; 2. the procedures sin,cos,atan,square,sqrt need to be redefined to take advantage of apply-generic.
;; 3. since the generic procedures add, sub, mul, div are used at each package level, these procedures cannot use "drop". So "drop" can be used at a higher level, which "drop"s the result of generic procedure add/sub/mul/div.




(define (square x) (mul x x))
(define *op-table* (make-hash-table 10))
(define (put op type proc)
  (hash-set! *op-table* (list op type) proc))
(define (get op type)
  (hash-ref *op-table* (list op type) '()))

(define (get-highest-type args)
  (define (higher-type? num1-raised num2 num1)
    (let ((type1 (type num1-raised))
          (type2 (type num2)))
      (if (eq? type1 type2)
          num2
          (let ((raise-proc (get 'raise (list type1))))
            (if (null? raise-proc)
                num1
                (higher-type? (raise-proc (contents num1-raised)) num2 num1))))))
  (define (iter num rest-num)
    (cond ((null? rest-num) num)
          (else (iter (higher-type? num (car rest-num) num)
                      (cdr rest-num)))))
  (cond ((null? args) (error "ERROR"))
        ((null? (cdr args)) (car args))
        (else (type (iter (car args) (cdr args))))))

(define (raise-args highest-type args)
  (define (raise-to-type num)
    (if (eq? (type num) highest-type)
        num
        (raise-to-type (raise num))))
  (map raise-to-type args))

(define (apply-generic op . param)
  (define (apply-generic-raised)
    (let ((highest-type (get-highest-type param)))
      (let ((highest-type-args (map (lambda(x) highest-type) param)))
        (let ((proc (get op highest-type-args)))
          (if (null? proc) (error "no matching operation" op  "for types"
                                   highest-type-args)
              (apply proc (map contents (raise-args highest-type param))))))))
  (let ((type-tags (map type param)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc)) (apply proc (map contents param))
          (apply-generic-raised)))))


(define (drop num)
  (let ((project-proc (get 'project (list (type num)))))
    (if (null? project-proc) num
        (let ((projected-num (project-proc (contents num))))
          (if (equ? (raise projected-num) num)
              (drop projected-num)
              num)))))


;;
;;  number-system
;;

(define (is_integer? x)
  (and (integer? x) (exact? x)))

(define (is_real? x)
  (and (real? x) (inexact? x)))

(define (attach-tag tag oper)
  (cond ((is_integer? oper) oper)
        ((is_real? oper) oper)
        (else (list tag oper))))

(define (type data)
  (cond ((is_integer? data) 'integer)
        ((is_real? data) 'real-number)
        (else (car data))))

(define (contents data)
  (cond ((is_integer? data) data)
        ((is_real? data) data)
        (else (cadr data))))

(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))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (raise x) (apply-generic 'raise x))
(define (project x) (apply-generic 'project x))
(define (sqrt* x) (apply-generic 'sqrt x))
(define (sin* x) (apply-generic 'sin x))
(define (cos* x) (apply-generic 'cos x))
(define (atan* x y) (apply-generic 'atan x y))


(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))  
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer)
       (lambda(x y)(= x y)))
  (put '=zero? '(integer)
       (lambda(x)(= x 0)))
  (put 'raise '(integer)
       (lambda(x)(make-rational x 1)))
  (put 'sqrt '(integer) sqrt)
  (put 'sin '(integer) sin)
  (put 'cos '(integer) cos)
  (put 'atan '(integer integer) atan)
  'done)

(define (make-integer n)
  ((get 'make 'integer) (drop 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))))
  (define (eq? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (raise x)
    (make-real-number (exact->inexact (/ (numer x) (denom x)))))
  (define (project x)
    (numer x))

  ;; 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 'equ? '(rational rational) eq?)
  (put '=zero? '(rational) =zero?)
  (put 'raise  '(rational) raise)
  (put 'project  '(rational) project)
  (put 'sqrt '(rational) (lambda(x)(sqrt (raise x))))
  (put 'sin '(rational) (lambda(x)(sin (raise x))))
  (put 'cos '(rational) (lambda(x)(cos (raise x))))
  (put 'atan '(rational rational) (lambda(x y)(atan (raise x) (raise y))))
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) (drop n) (drop d)))

(define (install-real-number-package)
  (define (tag x)
    (attach-tag 'real-number x))   
  (put 'add '(real-number real-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real-number real-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real-number real-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real-number real-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real-number
       (lambda (x) (tag (* 1.0 x))))
  (put 'equ? '(real-number real-number)
       (lambda(x y)(= x y)))
  (put '=zero? '(real-number)
       (lambda(x)(= x 0)))
  (put 'raise '(real-number)
       (lambda(x)(make-complex-from-real-imag x 0)))
  (put 'project '(real-number)
       (lambda(x)(make-rational (numerator (rationalize (inexact->exact x) 1/100))
                                (denominator (rationalize (inexact->exact x) 1/100)))))
  (put 'sqrt '(real-number) sqrt)
  (put 'sin '(real-number) sin)
  (put 'cos '(real-number) cos)
  (put 'atan '(real-number real-number) atan)
  'done)

(define (make-real-number n)
  ((get 'make 'real-number) n))


(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))
  (define (magnitude z)
    (sqrt* (add (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan* (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (mul r (cos* a)) (mul r (sin* a))))
  (define (eq? z1 z2)
    (and (equ? (real-part z1) (real-part z2))
         (equ? (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (equ? (real-part z) 0)
         (equ? (imag-part z) 0)))
  ;; 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))))
  (put 'equ?    '(rectangular rectangular) eq?)
  (put 'equ?    '(rectangular polar) eq?)
  (put '=zero? '(rectangular) =zero?)
  'done)

(define (real-part z)
  (apply-generic 'real-part z))
(define (imag-part z)
  (apply-generic 'imag-part z))

(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))
  (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 (sqrt* (add (square x) (square y)))
          (atan* y x)))
  (define (eq? z1 z2)
    (and (equ? (magnitude z1) (magnitude z2))
         (equ? (angle z1) (angle z2))))
  (define (=zero? z)
    (equ? (magnitude z) 0))
  ;; 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))))
  (put 'equ?   '(polar polar) eq?)
  (put 'equ?   '(polar rectangular) eq?)
  (put '=zero? '(polar) =zero?)
  'done)
(define (magnitude z)
  (apply-generic 'magnitude z))
(define (angle z)
  (apply-generic 'angle z))


(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 x y)
    ((get 'make-from-mag-ang 'polar) x y))
  ;; internal 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 'equ? '(complex complex) equ?)
  (put '=zero? '(complex) =zero?)

  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'project '(complex)
        (lambda(z)(make-real-number (real-part z))))

  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))


(install-integer-package)
(install-rational-package)
(install-real-number-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)


;;
;;  testing
;;



(define x (make-complex-from-real-imag 1 2))
(define y (make-complex-from-real-imag 1 -2))
(display "------------") (newline)
(display (drop (add x x))) (newline)
(display (drop (add x y))) (newline)
(display (drop (mul x x))) (newline)
(display (drop (mul x y))) (newline)
(display (drop (div x x))) (newline)
(display (drop (div y y))) (newline)
(display (drop (sub x y))) (newline)

(define rat-1 (make-rational 1 2))
(define rat-2 (make-rational 3 4))
(define cmplx (make-complex-from-real-imag rat-1 rat-2))


(display rat-1) (newline)
(display rat-2) (newline)
(display cmplx) (newline)

(display (add cmplx rat-1)) (newline)
(display (drop (add cmplx rat-1))) (newline)

(display (sub cmplx rat-1)) (newline)
(display (drop (sub cmplx rat-1))) (newline)

(display (mul cmplx rat-1)) (newline)
(display (drop (mul cmplx rat-1))) (newline)

(display (div cmplx rat-1)) (newline)
(display (drop (div cmplx rat-1))) (newline)

sicp exercise 2.85

;; Exercise 2.85.  This section mentioned a method for ``simplifying'' a data object by lowering it in the tower of types as far as possible. Design a procedure drop that accomplishes this for the tower described in exercise 2.83. The key is to decide, in some general way, whether an object can be lowered. For example, the complex number 1.5 + 0i can be lowered as far as real, the complex number 1 + 0i can be lowered as far as integer, and the complex number 2 + 3i cannot be lowered at all. Here is a plan for determining whether an object can be lowered: Begin by defining a generic operation project that ``pushes'' an object down in the tower. For example, projecting a complex number would involve throwing away the imaginary part. Then a number can be dropped if, when we project it and raise the result back to the type we started with, we end up with something equal to what we started with. Show how to implement this idea in detail, by writing a drop procedure that drops an object as far as possible. You will need to design the various projection operations53 and install project as a generic operation in the system. You will also need to make use of a generic equality predicate, such as described in exercise 2.79. Finally, use drop to rewrite apply-generic from exercise 2.84 so that it ``simplifies'' its answers.



(define (square x) (* x x))
(define *op-table* (make-hash-table 10))
(define (put op type proc)
  (hash-set! *op-table* (list op type) proc))
(define (get op type)
  (hash-ref *op-table* (list op type) '()))

(define (get-highest-type args)
  (define (higher-type? num1-raised num2 num1)
    (let ((type1 (type num1-raised))
          (type2 (type num2)))
      (if (eq? type1 type2)
          num2
          (let ((raise-proc (get 'raise (list type1))))
            (if (null? raise-proc)
                num1
                (higher-type? (raise-proc (contents num1-raised)) num2 num1))))))
  (define (iter num rest-num)
    (cond ((null? rest-num) num)
          (else (iter (higher-type? num (car rest-num) num)
                      (cdr rest-num)))))
  (cond ((null? args) (error "ERROR"))
        ((null? (cdr args)) (car args))
        (else (type (iter (car args) (cdr args))))))

(define (raise-args highest-type args)
  (define (raise-to-type num)
    (if (eq? (type num) highest-type)
        num
        (raise-to-type (raise num))))
  (map raise-to-type args))

(define (apply-generic op . param)
  (define (apply-generic-raised)
    (let ((highest-type (get-highest-type param)))
      (let ((highest-type-args (map (lambda(x) highest-type) param)))
        (let ((proc (get op highest-type-args)))
          (if (null? proc) (error "no matching operation" op  "for types"
                                   highest-type-args)
              (apply proc (map contents (raise-args highest-type param))))))))
  (let ((type-tags (map type param)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc)) (apply proc (map contents param))
          (apply-generic-raised)))))


(define (drop num)
  (let ((project-proc (get 'project (list (type num)))))
    (if (null? project-proc) num
        (let ((projected-num (project-proc (contents num))))
          (if (equ? (raise projected-num) num)
              (drop projected-num)
              num)))))


;;
;;  number-system
;;

(define (is_integer? x)
  (and (integer? x) (exact? x)))

(define (is_real? x)
  (and (real? x) (inexact? x)))

(define (attach-tag tag oper)
  (cond ((is_integer? oper) oper)
        ((is_real? oper) oper)
        (else (list tag oper))))

(define (type data)
  (cond ((is_integer? data) 'integer)
        ((is_real? data) 'real-number)
        (else (car data))))

(define (contents data)
  (cond ((is_integer? data) data)
        ((is_real? data) data)
        (else (cadr data))))

(define (add x y) (drop (apply-generic 'add x y)))
(define (sub x y) (drop (apply-generic 'sub x y)))
(define (mul x y) (drop (apply-generic 'mul x y)))
(define (div x y) (drop (apply-generic 'div x y)))
(define (equ? x y) (apply-generic 'equ? x y))
(define (=zero? x) (apply-generic '=zero? x))
(define (raise x) (apply-generic 'raise x))

(define (install-integer-package)
  (define (tag x)
    (attach-tag 'integer x))  
  (put 'add '(integer integer)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(integer integer)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(integer integer)
       (lambda (x y) (tag (* x y))))
  (put 'div '(integer integer)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'integer
       (lambda (x) (tag x)))
  (put 'equ? '(integer integer)
       (lambda(x y)(= x y)))
  (put '=zero? '(integer)
       (lambda(x)(= x 0)))
  (put 'raise '(integer)
       (lambda(x)(make-rational x 1)))
  'done)

(define (make-integer n)
  ((get 'make 'integer) 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))))
  (define (eq? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (raise x)
    (make-real-number (exact->inexact (/ (numer x) (denom x)))))
  (define (project x)
    (numer x))

  ;; 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 'equ? '(rational rational) eq?)
  (put '=zero? '(rational) =zero?)
  (put 'raise  '(rational) raise)
  (put 'project  '(rational) project)
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) n d))

(define (install-real-number-package)
  (define (tag x)
    (attach-tag 'real-number x))   
  (put 'add '(real-number real-number)
       (lambda (x y) (tag (+ x y))))
  (put 'sub '(real-number real-number)
       (lambda (x y) (tag (- x y))))
  (put 'mul '(real-number real-number)
       (lambda (x y) (tag (* x y))))
  (put 'div '(real-number real-number)
       (lambda (x y) (tag (/ x y))))
  (put 'make 'real-number
       (lambda (x) (tag (* 1.0 x))))
  (put 'equ? '(real-number real-number)
       (lambda(x y)(= x y)))
  (put '=zero? '(real-number)
       (lambda(x)(= x 0)))
  (put 'raise '(real-number)
       (lambda(x)(make-complex-from-real-imag x 0)))
  (put 'project '(real-number)
       (lambda(x)(make-rational (numerator (rationalize (inexact->exact x) 1/100))
                                (denominator (rationalize (inexact->exact x) 1/100)))))
  (put 'sqrt '(real-number) sqrt)
  'done)

(define (make-real-number n)
  ((get 'make 'real-number) n))


(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))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  (define (eq? z1 z2)
    (and (= (real-part z1) (real-part z2))
         (= (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (= (real-part z) 0)
         (= (imag-part z) 0)))
  ;; 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))))
  (put 'equ?    '(rectangular rectangular) eq?)
  (put 'equ?    '(rectangular polar) eq?)
  (put '=zero? '(rectangular) =zero?)
  'done)

(define (real-part z)
  (apply-generic 'real-part z))
(define (imag-part z)
  (apply-generic 'imag-part z))

(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))
  (define (real-part z)
    (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))
  (define (eq? z1 z2)
    (and (= (magnitude z1) (magnitude z2))
         (= (angle z1) (angle z2))))
  (define (=zero? z)
    (= (magnitude z) 0))
  ;; 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))))
  (put 'equ?   '(polar polar) eq?)
  (put 'equ?   '(polar rectangular) eq?)
  (put '=zero? '(polar) =zero?)
  'done)
(define (magnitude z)
  (apply-generic 'magnitude z))
(define (angle z)
  (apply-generic 'angle z))


(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 x y)
    ((get 'make-from-mag-ang 'polar) x y))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (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 'equ? '(complex complex) equ?)
  (put '=zero? '(complex) =zero?)

  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)
  (put 'project '(complex)
        (lambda(z)(make-real-number (real-part z))))

  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))


(install-integer-package)
(install-rational-package)
(install-real-number-package)
(install-rectangular-package)
(install-polar-package)
(install-complex-package)


;;
;;  testing
;;



(define x (make-complex-from-real-imag 1 2))
(define y (make-complex-from-real-imag 1 -2))
(display "------------") (newline)
(display (add x x)) (newline)
(display (add x y)) (newline)
(display (mul x x)) (newline)
(display (mul x y)) (newline)
(display (div x x)) (newline)
(display (div y y)) (newline)
(display (sub x y)) (newline)

sicp exercise 2.84

;; Exercise 2.84.  Using the raise operation of exercise 2.83, modify the apply-generic procedure so that it coerces its arguments to have the same type by the method of successive raising, as discussed in this section. You will need to devise a way to test which of two types is higher in the tower. Do this in a manner that is ``compatible'' with the rest of the system and will not lead to problems in adding new levels to the tower.

;; 1. get the highest type from the list of data types
;; 2. make a list of the highest type
;; 3. find the operation for that list of types
;; 4. if operation is found, prepare list of raised arguments
;; 5. apply the operation


(define (get-highest-type args)
  (define (higher-type? num1 num2)
    (let ((type1 (type num1))
          (type2 (type num2)))
      (if (eq? type1 type2)
          num2
          (let ((raise-proc (get 'raise (list type1))))
            (if (null? raise-proc)
                num1
                (higher-type? (raise-proc (contents num1)) num2))))))
  (define (iter num rest-num)
    (cond ((null? rest-num) num)
          (else (iter (higher-type? num (car rest-num))
                      (cdr rest-num)))))
  (cond ((null? args) (error "ERROR"))
        ((null? (cdr args)) (car args))
        (else (type (iter (car args) (cdr args))))))

(define (raise-args highest-type args)
  (define (raise-to-type num)
    (if (eq? (type num) highest-type)
        num
        (raise-to-type (raise num))))
  (map raise-to-type args))

(define (apply-generic op . param)
  (define (apply-generic-raised)
    (let ((highest-type (get-highest-type param)))
      (let ((highest-type-args (map (lambda(x) highest-type) param)))
        (let ((proc (get op highest-type-args)))
          (if (null? proc) (error "no matching operation for types"
                                   highest-type-args)
              (apply proc (map contents (raise-args highest-type param))))))))
  (let ((type-tags (map type param)))
    (let ((proc (get op type-tags)))
      (if (not (null? proc)) (apply proc (map contents param))
          (apply-generic-raised)))))


;;
;; testing
;;


(define (square x) (* x x))
(define *op-table* (make-hash-table 10))
(define (put op type proc)
  (hash-set! *op-table* (list op type) proc))
(define (get op type)
  (hash-ref *op-table* (list op type) '()))


(define (attach-tag tag oper)
  (if (number? oper) oper
      (list tag oper)))

(define (type data)
  (if (number? data) 'scheme-number
      (car data)))

(define (contents data)
  (if (number? data) data
      (cadr data)))

(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))
(define (=zero? x) (apply-generic '=zero? x))
(define (raise x) (apply-generic 'raise 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)))
  (put 'eq? '(scheme-number scheme-number)
       (lambda(x y)(= x y)))
  (put '=zero? '(scheme-number)
       (lambda(x)(= x 0)))
  (put 'raise '(scheme-number)
       (lambda(x)(make-rational x 1)))
  '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))))
  (define (eq? x y)
    (and (= (numer x) (numer y))
         (= (denom x) (denom y))))
  (define (=zero? x)
    (= (numer x) 0))
  (define (raise x)
    (make-complex-from-real-imag (/ (numer x) (denom x)) 0))
  ;; 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 'eq? '(rational rational) eq?)
  (put '=zero? '(rational) =zero?)
  (put 'raise  '(rational) raise)
  (put 'make 'rational
       (lambda (n d) (tag (make-rat n d))))
  'done)

(define (make-rational n d)
  ((get 'make 'rational) n d))

(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))
  (define (magnitude z)
    (sqrt (+ (square (real-part z))
             (square (imag-part z)))))
  (define (angle z)
    (atan (imag-part z) (real-part z)))
  (define (make-from-mag-ang r a)
    (cons (* r (cos a)) (* r (sin a))))
  (define (eq? z1 z2)
    (and (= (real-part z1) (real-part z2))
         (= (imag-part z1) (imag-part z2))))
  (define (=zero? z)
    (and (= (real-part z) 0)
         (= (imag-part z) 0)))
  ;; 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))))
  (put 'eq?    '(rectangular rectangular) eq?)
  (put '=zero? '(rectangular) =zero?)
  'done)

(define (real-part z)
  (apply-generic 'real-part z))
(define (imag-part z)
  (apply-generic 'imag-part z))

(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))
  (define (real-part z)
    (* (magnitude z) (cos (angle z))))
  (define (imag-part z)
    (* (magnitude z) (sin (angle z))))
  (define (make-from-real-imag x y)
    (cons (sqrt (+ (square x) (square y)))
          (atan y x)))
  (define (eq? z1 z2)
    (and (= (magnitude z1) (magnitude z2))
         (= (angle z1) (angle z2))))
  (define (=zero? z)
    (= (magnitude z) 0))
  ;; 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))))
  (put 'eq?   '(polar polar) eq?)
  (put '=zero? '(polar) =zero?)
  'done)
(define (magnitude z)
  (apply-generic 'magnitude z))

(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))
  ;; internal procedures
  (define (add-complex z1 z2)
    (make-from-real-imag (+ (real-part z1) (real-part z2))
                         (+ (imag-part z1) (imag-part z2))))
  (define (sub-complex z1 z2)
    (make-from-real-imag (- (real-part z1) (real-part z2))
                         (- (imag-part z1) (imag-part z2))))
  (define (mul-complex z1 z2)
    (make-from-mag-ang (* (magnitude z1) (magnitude z2))
                       (+ (angle z1) (angle z2))))
  (define (div-complex z1 z2)
    (make-from-mag-ang (/ (magnitude z1) (magnitude z2))
                       (- (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 'eq? '(complex complex) eq?)
  (put '=zero? '(complex) =zero?)

  (put 'real-part '(complex) real-part)
  (put 'imag-part '(complex) imag-part)
  (put 'magnitude '(complex) magnitude)
  (put 'angle '(complex) angle)

  'done)

(define (make-complex-from-real-imag x y)
  ((get 'make-from-real-imag 'complex) x y))


(install-scheme-number-package)
(install-rational-package)
(install-rectangular-package)
(install-complex-package)

(define num (make-scheme-number 23))
(define rat-num (raise 34))
(define cmplx-num (raise rat-num))

(define c1 (make-complex-from-real-imag 2 3))
(define c2 (make-complex-from-real-imag 6 7))

(display (add c1 c2)) (newline)
(display (add c1 num)) (newline)
(display (add num c1)) (newline)
(display (add c1 rat-num)) (newline)

sicp exercise 2.83

;; Exercise 2.83.  Suppose you are designing a generic arithmetic system for dealing with the tower of types shown in figure 2.25: integer, rational, real, complex. For each type (except complex), design a procedure that raises objects of that type one level in the tower. Show how to install a generic raise operation that will work for each type (except complex).

(define (install-rational-number-package)
  ;;...
  (define (raise rat-num)
    (make-complex-from-real-imag rat-num 0))
  (put 'raise '(rational) raise)
  'done)

(define (install-scheme-number-package)
  ;;...
  (define (raise number)
    (make-rat number 1))
  (put 'raise '(scheme-number) raise)
  'done)

(define (raise num)
  (apply-generic 'raise num))

sicp exercise 2.82

;; Exercise 2.82.  Show how to generalize apply-generic to handle coercion in the general case of multiple arguments. One strategy is to attempt to coerce all the arguments to the type of the first argument, then to the type of the second argument, and so on. Give an example of a situation where this strategy (and likewise the two-argument version given above) is not sufficiently general. (Hint: Consider the case where there are some suitable mixed-type operations present in the table that will not be tried.)


(define (apply-generic op . args)
  (define (find-coercions atype other-types)
    (cond ((null? other-types) (list))
          ((eq? atype (car other-types)) (lambda(x)(x)))
          (else (let ((coerce-func (get-coercion atype (car other-types))))
                  (if (null? coerce-func) (list)
                      (cons coerce-func
                            (find-coercions atype (cdr other-types))))))))
  (let ((type-tags (map type args)))
    (let ((proc (get op type-tags)))
        (define (iter remaining-types)
          (if (null? remaining-types) (error "no more types")
            (let ((coerced-type (car remianing-types)))
              (let ((coerced-funcs (find-coercions coerced-type type-tags))
                    (length-types (length type-tags)))
                (if (not (= (length coerced-funcs) length-types)) (iter (cdr remaining-types))
                    (let ((new-types (map (lambda(x)(coerced-type)) type-tags)))
                      (let ((new-proc (get op new-types)))
                        (if new-proc (apply op (map contents (map-multi coerced-funcs args)))
                                     (iter (cdr remaining-types))))))))))
      (if proc (apply op (map contents args))
          (iter type-tags)))))

sicp exercise 2.81

;; Exercise 2.81.  Louis Reasoner has noticed that apply-generic may try to coerce the arguments to each other's type even if they already have the same type. Therefore, he reasons, we need to put procedures in the coercion table to "coerce" arguments of each type to their own type. For example, in addition to the scheme-number->complex coercion shown above, he would do:

;; (define (scheme-number->scheme-number n) n)
;; (define (complex->complex z) z)
;; (put-coercion 'scheme-number 'scheme-number
;;               scheme-number->scheme-number)
;; (put-coercion 'complex 'complex complex->complex)

;; a. With Louis's coercion procedures installed, what happens if apply-generic is called with two arguments of type scheme-number or two arguments of type complex for an operation that is not found in the table for those types? For example, assume that we've defined a generic exponentiation operation:

;; (define (exp x y) (apply-generic 'exp x y))

;; and have put a procedure for exponentiation in the Scheme-number package but not in any other package:

;; following added to Scheme-number package
;; (put 'exp '(scheme-number scheme-number)
;;      (lambda (x y) (tag (expt x y)))) ; using primitive expt

;; What happens if we call exp with two complex numbers as arguments?

;; b. Is Louis correct that something had to be done about coercion with arguments of the same type, or does apply-generic work correctly as is?

;; c. Modify apply-generic so that it doesn't try coercion if the two arguments have the same type.

;; Answer
;; a. this will lead to an infinite recursion of coercions.

;; b. apply-generic works correctly.

;; c.

(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 ((eq? type1 type2) (error "same type - no coercion"))
                        (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"
                                (list op type-tags))))))
              (error "No method for these types"
                     (list op type-tags)))))))