Pasted

#lang racket
 
;;;;;;;;;;
;; 2.81 ;;
;;;;;;;;;;
 
;; a.  We would get an infinite loop.  Calling apply-generic would check if proc
;; was defined, see that it's not, coerce each argument to its own type, and then
;; re-enter apply-generic without ever hitting the error statement.
 
;; b.  No, apply-generic works correctly as is.  It would needlessly look for
;; t1->t2 or t2->t1 in the coercion table before hitting the error statement, but
;; it would still correctly exit with an error.
 
;; c.  Modify apply-generic so it does not try to coerce arguments of the same type.
 
(define (apply-generic op . args)
  (define type-tags (map type-tag args))
  (define proc (get op type-tags))
  (cond [proc (apply proc (map contents args))]
        [(= (length args) 2)
         (define type1 (first type-tags))
         (define type2 (second type-tags))
         (cond [(not (eq? type1 type2))
                (define a1 (first args))
                (define a2 (second args))
                (define t1->t2 (get-coercion type1 type2))
                (define 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"
                                   (list op type-tags))])]
               [else (error "no method for these types"
                            (list op type-tags))])]
        [else (error "no method for these types"
                     (list op type-tags))]))
 
;;;;;;;;;;
;; 2.82 ;;
;;;;;;;;;;
 
(define (all-same? symbols)
  (or (< (length symbols) 2)
      (andmap (lambda (s) (eq? s (first symbols)))
              (rest symbols))))
 
(define (zip procs args)
  (if (zero? (length procs))
    empty
    (cons ((first procs) (first args))
          (zip (rest procs) (rest args)))))
 
;; Try to coerce all args to first type, then second type, etc.
;; If possible, return coerced args, else return #f.
 
(define (coerce args)
  (define type-tags (map type-tag args))
  (define (loop i) ; coerce all args to type of argument i
    (cond [(= i (length args)) #f]
          [else
            (define type (list-ref type-tags i))
            (define procs
              (map (lambda (t)
                     (if (eq? t type)
                       identity
                       (get-coercion t type)))
                   type-tags))
            (if (not (member #f procs))
              (zip procs args)
              (loop (add1 i)))]))
  (if (all-same? type-tags)
    args
    (loop 0)))
 
;; This strategy could fail if the types of the arguments can not be coerced to
;; each others' types, but there might be another type, not present among the
;; arguments, that all could be coerced to.
 
;;;;;;;;;;
;; 2.83 ;;
;;;;;;;;;;
 
;; inside the integer package
(define (raise-integer a) (make-rational a 1))
(put-raise 'integer raise-integer)
 
;; inside the rational numbers package
(define (raise-rational q)
  (make-real (/ (numer q) (denom q))))
(put-raise 'rational raise-rational)
 
;; inside the real numbers package
(define (raise-real x) (make-complex-from-real-imag x 0))
(put-raise 'real raise-real)
 
;;;;;;;;;;
;; 2.84 ;;
;;;;;;;;;;
 
;; only type-tower needs to change when adding more types
(define type-tower '(integer rational real complex))
 
(define (index-of s symbols)
  (define (loop i remaining)
    (cond [(empty? remaining) #f]
          [(eq? s (first remaining)) i]
          [else (loop (add1 i) (rest remaining))]))
  (loop 0 symbols))
 
(define (lower? type1 type2)
  (< (index-of type1 type-tower)
     (index-of type2 type-tower)))
 
(define (apply-generic op . args)
  (define type-tags (map type-tag args))
  (define proc (get op type-tags))
  (cond [proc (apply proc (map contents args))]
        [(= (length args) 2)
         (define type1 (first type-tags))
         (define type2 (second type-tags))
         (define a1 (first args))
         (define a2 (second args))
         (cond [(lower? type1 type2) (apply-generic op (raise a1) a2)]
               [(lower? type2 type1) (apply-generic op a1 (raise a2))]
               [else (error "no method for these types"
                            (list op type-tags))])]
        [else (error "no method for these types"
                     (list op type-tags))]))
 
;;;;;;;;;;
;; 2.85 ;;
;;;;;;;;;;
 
;; implementing project
 
;; inside the rational numbers package
(define (project-rational q)
  (make-integer (floor (/ (numer q) (denom q)))))
(put-project 'rational project-rational)
 
;; inside the real numbers package
(define (project-real x)
  (make-rational (floor (* x 1000000)) 1000000))
(put-project 'real project-real)
 
;; inside the complex numbers package
(define (project-complex z)
  (make-real (re-part z)))
(put-project 'complex project-complex)
 
(define (my-drop arg)
  (define type (type-tag arg))
  (define proc (get-project type))
  (cond [proc
          (define projected-arg (proc arg))
          (if (equ? arg (raise projected-arg))
            (my-drop projected-arg)
            arg)]
        [else arg]))
 
(define (apply-generic op . args)
  (define type-tags (map type-tag args))
  (define proc (get op type-tags))
  (cond [proc (my-drop (apply proc (map contents args)))]
        [(= (length args) 2)
         (define type1 (first type-tags))
         (define type2 (second type-tags))
         (define a1 (first args))
         (define a2 (second args))
         (cond [(lower? type1 type2) (my-drop (apply-generic op (raise a1) a2))]
               [(lower? type2 type1) (my-drop (apply-generic op a1 (raise a2)))]
               [else (error "no method for these types"
                            (list op type-tags))])]
        [else (error "no method for these types"
                     (list op type-tags))]))
 
;;;;;;;;;;
;; 2.86 ;;
;;;;;;;;;;
 
(define (sine x) (apply-generic 'sine x))
(define (cosine x) (apply-generic 'cosine x))
 
;; The procedures inside the complex rectangular and complex polar packages would
;; need to be made generic.  We could no longer assume the components of a
;; complex number were real numbers.
 
;; For example, the definition of make-from-mag-ang inside the complex rectangular
;; package would need to change from:
 
(define (make-from-mag-ang r a)
  (list (* r (cos a)) (* r (sin a))))
 
;; to:
 
(define (make-from-mag-ang r a)
  (list (mul r (cosine a)) (mul r (sine a))))