sicp-ex-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.)

Answer:

  
 ;;iter returns the list of coerced argument or gives an error on failing to find a method. 
  
 (define (apply-generic op . args) 
 (define (iter type-tags args) 
     (if (null? type-tags) 
         (error "No method for these types-ITER") 
         (let ((type1 (car type-tags))) 
           (let ((filtered-args (true-map (lambda (x) 
                                            (let ((type2 (type-tag x))) 
                                              (if (eq? type1 type2) 
                                                  x 
                                                  (let ((t2->t1 (get-coercion type2 type1))) 
                                                    (if (null? t2->t1) #f (t2->t1 x)))))) 
                                          args))) 
             (or filtered-args 
                 (iter (cdr type-tags) args)))))) 
   (let ((type-tags (map type-tag args))) 
     (let ((proc (get op type-tags))) 
       (if (not (null? proc)) 
           (apply proc (map contents args)) 
           (apply apply-generic (cons op (iter type-tags args))))))) 
  
 ;;; true-map function applies proc to each item on the sequence and returns false if any of  
 ;;;;those results was false otherwise returns the list of each results.  
 (define (true-map proc sequence) 
   (define (true-map-iter proc sequence result) 
     (if (null? sequence) 
         (reverse result) 
         (let ((item (proc (car sequence)))) 
           (if item 
               (true-map-iter proc (cdr sequence) (cons item result)) 
               #f)))) 
 (true-map-iter proc sequence '())) 
  
 ;; The following code may be used to try out the solution and see it working. Also you will  
 ;;;need the scheme-number, rational and complex packages and associated generic declarations  
 ;;;;which are not given here. 
  
  
 (define *coercion-table* (make-equal-hash-table)) 
  
 (define (put-coercion type1 type2 proc) 
   (hash-table/put! *coercion-table* (list type1 type2) proc)) 
  
 (define (get-coercion type1 type2) 
   (hash-table/get *coercion-table* (list type1 type2) '())) 
  
 (define (install-coercion-package) 
 (define (scheme-number->complex n) 
   (make-complex-from-real-imag (contents n) 0)) 
 (define (scheme-number->rational n) 
   (make-rational (contents n) 1)) 
 (put-coercion 'scheme-number 'rational scheme-number->rational) 
 (put-coercion 'scheme-number 'complex scheme-number->complex) 
 'done) 
  
 (install-coercion-package) 
  
 ;;The following are some example evaluations 
  
 ;;RESULT 
 ;; 1 ]=> (add (make-scheme-number 1) (make-scheme-number 4)) 
  
 ;; ;Value: 5 
  
 ;; 1 ]=> (add (make-complex-from-real-imag 1 1) (make-complex-from-real-imag 3 2)) 
  
 ;; ;Value 14: (complex rectangular 4 . 3) 
  
 ;; 1 ]=> (add (make-scheme-number 1) (make-complex-from-real-imag 1 1)) 
  
 ;; ;Value 15: (complex rectangular 2 . 1) 
  
 ;; 1 ]=> (add (make-scheme-number 2) (make-rational 3 4)) 
  
 ;; ;Value 16: (rational 11 . 4) 
  
 ;; 1 ]=>  
  

 (define (apply-generic op . arg) 
   ;; if all types can coerced into target-type 
   (define (can-coerced-into? types target-type) 
         (andmap 
           (lambda (type) 
                 (or (equal? type target-type) 
                     (get-coercion type target-type))) 
           types)) 
   ;; find one type that all other types can coerced into 
   (define (find-coerced-type types) 
         (ormap 
           (lambda (target-type) 
                 (if (can-coerced-into? types target-type) 
                   target-type 
                   #f)) 
           types)) 
   ;; coerced args into target-type 
   (define (coerced-all target-type) 
         (map  
           (lamdba (arg) 
                   (let ((arg-type (type-tag arg))) 
                      (if (equal? arg-type target-type) 
                        arg 
                        ((get-coercion arg-type target-type) arg)))) 
           args)) 
   (let ((type-tags (map type-tag args))) 
         (let ((proc (get op type-tags))) 
           (if proc 
             (apply proc (map contents args)) 
               (let ((target-type (find-coerced-type type-tags))) 
                 (if target-type 
                   (apply apply-generic  
                          (append (list op) (coerced-all target-type))) 
                   (error "no method for these types" (list op type-args)))))))) 

In general it coerces argument list to the types in order from first to last and then tries to find a procedure to apply on these arguments. If coercion for pair of types is not found I just put non-coerced element in the coerced list which allows for defining mixed-type procedures. This way I avoid some logic and make things work by convention.

What needs to be done in the rest of the system is to define generic methods to be applicatble on arbitrary number of arguments, since in this point our arithmetic operations work only on 1 or 2 args.

 (define (apply-generic op . args) 
   ; coercing list to a type 
   (define (coerce-list-to-type lst type) 
     (if (null? lst)  
       '() 
       (let ((t1->t2 (get-coercion (type-tag (car lst)) type))) 
         (if t1->t2 
           (cons (t1->t2 (car lst)) (coerce-list-to-type (cdr lst) type)) 
           (cons (car lst) (coerce-list-to-type (cdr lst) type)))))) 
  
   ; applying to a list of multiple arguments 
   (define (apply-coerced lst) 
     (if (null? lst) 
       (error "No method for given arguments") 
       (let ((coerced-list (coerce-list-to-type args (type-tag (car lst))))) 
         (let ((proc (get op (map type-tag coerced-list)))) 
           (if proc 
             (apply proc (map content coerced-list)) 
             (apply-coerced (cdr lst))))))) 
  
   ; logic to prevent always coercing if there is already direct input entry 
   (let ((type-tags (map type-tag args))) 
     (let ((proc (get op type-tags))) 
       (if proc 
         (apply proc (map content args)) 
         (apply-coerced args)))))