sicp-ex-2.84



<< Previous exercise (2.83) | Index | Next exercise (2.85) >>


meteorgan

  
  
  
 ;; assuming that the types are arranged in a simple tower shape. 
 (define (apply-generic op . args) 
   ;; raise s into t, if success, return s; else return #f 
   (define (raise-into s t) 
         (let ((s-type (type-tag s)) 
               (t-type (type-tag t))) 
           (cond ((equal? s-type t-type) s) 
                 ((get 'raise (list s-type))  
                  (raise-into ((get 'raise (list s-type)) (contents s)) t)) 
                 (else #f)))) 
  
   (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 ((a1 (car args)) 
                    (a2 (cadr args))) 
                 (cond  
                   ((raise-into a1 a2) 
                    (apply-generic op (raise-into a1 a2) a2)) 
                   ((raise-into a2 a1) 
                    (apply-generic op a1 (raise-into a2 a1))) 
                   (else (error "No method for these types" 
                         (list op type-tags))))) 
            (error "No method for these types" 
                   (list op type-tags))))))) 
  

gws

  
  
  
 ;; This solution is for an apply-generic that works with arbitrary arguments 
 ;; by raising all to the highest type. 
 ;; New types can be added to the tower easily. Only the procedure "level" has 
 ;; to be modified. 
  
 (define (level type) 
   (cond ((eq? type 'integer) 0) 
         ((eq? type 'rational) 1) 
         ((eq? type 'real) 2) 
         ((eq? type 'complex) 3) 
         (else (error "Invalid type: LEVEL" type)))) 
  
 (define (apply-generic op . args) 
   (let ((type-tags (map type-tag args))) 
     (define (no-method) 
       (error "No method for these types" (list op type-tags))) 
     (let ((proc (get op type-tags))) 
       (if proc 
           (apply proc (map contents args)) 
           (if (not (null? (cdr args))) ; length of args > 1 
               (let ((raised-args (raise-to-common args))) 
                 (if raised-args 
                     (let ((proc (get op (map type-tag raised-args)))) 
                       (if proc 
                           (apply proc (map contents raised-args)) 
                           (no-method))) 
                     (no-method))) 
               (no-method)))))) 
  
 (define (raise-to-common args) 
   (let ((raised-args 
          (map (lambda (x) (raise-to-type (highest-type args) x)) 
               args))) 
     (if (all-true? raised-args) 
         raised-args 
         false))) 
  
 (define (all-true? lst) 
   (cond ((null? lst) true) 
         ((car lst) (all-true? (cdr lst))) 
         (else false))) 
  
 (define (raise-to-type type item) 
   (let ((item-type (type-tag item))) 
     (if (eq? item-type type) 
         item 
         (let ((raise-fn (get 'raise item-type))) 
           (if raise-fn 
               (raise-to-type type (raise-fn item)) 
               false))))) 
  
 (define (highest-type args) 
   (if (null? (cdr args)) 
       (type-tag (car args)) 
       (let ((t1 (type-tag (car args))) 
             (t2 (highest-type (cdr args)))) 
         (let ((l1 (level t1)) (l2 (level t2))) 
           (if (> l1 l2) t1 t2))))) 
  

Rptx

  
 ; This is very similar to gws' answer, but, I have added the levels to the  
 ; table, so new levels can be added to the table in the new types' package 
 ; using "put" 
  
  (define (apply-generic op . args) 
  (define (higher-type types) 
   (define (iter x types) 
     (cond ((null? types) x) 
           ((> (level x) (level (car types))) 
            (iter x (cdr types))) 
           (else  
            (iter (car types) (cdr types))))) 
   (if (null? (cdr types)) (car types) (iter (car types) (cdr types)))) 
   (define (raise-args args level-high-type) 
     (define (iter-raise arg level-high-type) 
       (if (< (level (type-tag arg)) level-high-type) 
           (iter-raise (raise arg) level-high-type) 
           arg)) 
     (map (lambda (arg) (iter-raise arg level-high-type)) args)) 
 (define (not-all-same-type? lst) 
   (define (loop lst) 
     (cond ((null? lst) #f) 
           ((eq? #f (car lst)) #t) 
           (else (loop (cdr lst))))) 
   (loop (map (lambda (x) (eq? (car lst) x)) 
      (cdr lst)))) 
  
   (let ((type-tags (map type-tag args))) 
     (let ((proc (get op type-tags))) 
       (if proc                   
           (apply proc (map contents args)) 
           (if (not-all-same-type? type-tags)    ; only raise if the args are not 
 ;; all of the same type, if they are, then there is not "op" for them.  
               (let ((high-type (higher-type type-tags))) 
                 (let ((raised-args (raise-args args (level high-type)))) 
                   (apply apply-generic (cons op raised-args)))) 
               (error  
                "No Method for these types -- APPLY-GENERIC" 
                (list op type-tags))))))) 
  
  
 ; The level procedure. 
  
 (define (level type) 
   (get 'level type)) 
  
 ; The package of the levels. Each of these statements, can be placed in the  
 ; package of the number type it belongs to. I have done it here for the  
 ; exercise. Also I have a polar and rectangular level just in case level gets 
 ; called with a complex number without the 'complex tag.  
  
 (define (install-level-package) 
   (put 'level 'scheme-number 1) 
   (put 'level 'rational 2) 
   (put 'level 'real 3) 
   (put 'level 'complex 4) 
   (put 'level 'rectangular 4) 
   (put 'level 'polar 4) 
   'done) 
  
 (install-level-package)