Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #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))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement