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


 ;; 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))) 
                   ((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))))))) 

There is a bug in meteorgan's solution. The bug arises for same reason as exercise 2.81. That is, for an 'op' not defined for identical types a1 & a2, there is infinite recursion.

 ;; 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)) 
 (define (raise-to-common args) 
   (let ((raised-args 
          (map (lambda (x) (raise-to-type (highest-type args) x)) 
     (if (all-true? raised-args) 
 (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) 
         (let ((raise-fn (get 'raise item-type))) 
           (if raise-fn 
               (raise-to-type type (raise-fn item)) 
 (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))))) 

 ; 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))) 
            (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) 
     (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)))) 
                "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) 


 ;Hello here I'd like to introduce my own view on this task. No additional level tags, everything done with respect to the additive style of system construction and inside the operation-and-type-table and coercion-table boundaries. Also pay attention to the type-tag selectors/constructors and keep in mind that type constructors are globally announced, also the numer/denom from now are generic operations since we would need them for reals also to push down real to rational. 
 ;operation-and-type table 
 (define mt (make-hash)) 
 ;put procedure 
 (define (put op type proc) (hash-set! mt (cons op type) proc)) 
 ;get procedure 
 (define (get op type) 
   (let ((pick-item (hash-ref mt (cons op type) '()))) 
       (if (null? pick-item) 
 ;type-tag operations 
 (define (contents datum) 
   (cond ((number? datum) datum) 
         ((pair? datum) (cdr datum)) 
         (else (error "Bad data")))) 
 (define (type-tag datum) 
   (cond ((number? datum) (if (exact? datum) 'integer 'real)) 
         ((pair? datum) (car datum)) 
         (else (error "Bad data")))) 
 (define (attach-tag type-tag contents) 
   (if (number? contents) 
       (cons type-tag contents))) 
 ;global numer denom selectors 
 (define (numer x) 
   (apply-generic 'numer x)) 
 (define (denom x) 
   (apply-generic 'denom x)) 
 ;coercion table 
 (define ct (make-hash)) 
 ;put-coercion procedure 
 (define (put-coercion type1 type2 proc) (hash-set! ct (cons type1 type2) proc)) 
 ;get-coercion procedure 
 (define (get-coercion type1 type2) 
   (let ((pick-item (hash-ref ct (cons type1 type2) '()))) 
       (if (null? pick-item) 
 ;basic coercions (global procedures). trick here is that rationals and reals have the "hidden" tag plus numer/denom are now generic and they will cut our rational in pieces and strip off the tag, so it's no more necessary to strip off the tag at the 'raising' step. 
   (define (integer->rational x) 
     (make-rational x 1)) 
   (define (rational->real x) 
     (make-real (/ (numer x) (denom x)))) 
   (define (real->complex x) 
     (make-complex-from-real-imag x 0)) 
 (define (install-coercions) 
   (put-coercion 'integer 'rational (lambda (x) (integer->rational x))) 
   (put-coercion 'rational 'real (lambda (x) (rational->real x))) 
   (put-coercion 'real 'complex (lambda (x) (real->complex x)))) 
 ;raising (basically it will return its input value in case the type is 'complex, at this point of the book, i found it more convenient to do it this way rather than just return false, reason was to simplify the level-test) 
 (define (raise obj) 
   (let ((type-tag (type-tag obj))) 
     (let ((supertype (get 'raise type-tag))) 
       (if supertype 
           ((get-coercion type-tag supertype) obj) 
 ;raising to the prespecified type (the issue is known that it will go into an infinite loop in case the type is lower than argument's. but still it works fine as a part of apply-generic procedure) 
 (define (raise-to arg type) 
   (let ((this-tag (type-tag arg))) 
     (if (eq? this-tag type) 
         (raise-to (raise arg) type)))) 
 ;testing 2 arguments which has the highest type 
 (define (pick-higher arg1 arg2) 
   (define (find-iter arg1 arg2 result) 
     (let ((tag1 (type-tag arg1)) 
           (tag2 (type-tag arg2)) 
           (move-a1 (raise arg1))) 
       (let ((next-tag1 (type-tag move-a1))) 
         (cond ((eq? tag1 tag2) arg2) 
               ((eq? tag1 next-tag1) result) 
               (else (find-iter move-a1 arg2 result)))))) 
     (find-iter arg1 arg2 arg1)) 
 ;picking the highest type argument from the list 
 (define (find-highest args) 
   (if (null? (cdr args)) 
       (car args) 
       (let ((this (car args)) 
             (next (cadr args)) 
             (rest (cddr args))) 
         (let ((t1 (type-tag this)) 
               (t2 (type-tag next))) 
           (if (eq? t1 t2) 
               (find-highest (cdr args)) 
               (find-highest (cons (pick-higher this next) 
 ;raising the entire argument list to the type 
 (define (raise-all-to-highest args type) 
   (if (null? args) 
       (let ((a1 (car args)) 
             (rest (cdr args))) 
         (cons (raise-to a1 type) 
               (raise-all-to-highest rest type))))) 
 ;special procedure to partition our argument list in pieces of two, since our packages arithmetic procedures were specified for maximum of 2 arguments, we'll do it this way: 
 (define (partition-and-apply op args) 
   (if (null? (cdr args)) 
       (car args) 
       (let ((a1 (car args)) 
             (a2 (cadr args)) 
             (rest-args (cddr args))) 
         (partition-and-apply op (cons (apply-generic op a1 a2) rest-args))))) 
 ;here we just construct the whole procedure. and it works properly for 1,2 or more arguments and thanks god returns "Bad data" error in case the argument list is null. i confess it could be written in a more 'generic' manner but if you find anything useful for yourself out here i would be glad. 
 (define (apply-generic1 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) 1) 
               (let ((t1 (car type-tags)) 
                     (t2 (cadr type-tags)) 
                     (rest-args (cddr args))) 
                 (if (and (null? rest-args) (eq? t1 t2)) 
                     (error "No procedure specified for these types" op) 
                     (let ((highest-type (type-tag (find-highest args)))) 
                       (let ((raised-args (raise-all-to-highest args highest-type))) 
                         (partition-and-apply op raised-args))))) 
               (error "No procedure specified for this type" op)))))) 


I think implementing a hierarchical management module alone simplifies the problem and can be easily applied to any number of parameters.

 ;; Making a Hierarchical Manager 
 (define (make-rank-manager) 
     ;; Type of hierarchical tower 
     ;; The higher the level, the larger the coding. 
     (define type-tower (list)) 
     ;; Create hierarchical objects 
     (define (make-floor type hierarchy) 
         (cons type hierarchy)) 
     ;; Get the hierarchy of hierarchical objects 
     (define (get-hierarchy f) (cdr f)) 
     ;; Get the type of hierarchical object 
     (define (get-type f) (car f)) 
     ;; Find the hierarchy of the type 
     (define (find-hierarchy type) 
         (let ((this (filter 
                         (lambda (f) 
                             (eq? type (get-type f))) 
             (if (null? this) 
                 (error "Non-existent type--" type) 
                 (get-hierarchy (car this))))) 
     ;; Find the hierarchy of the type 
     (define (find-type hierarchy) 
         (let ((this (filter 
                         (lambda (f) 
                             (eq? hierarchy (get-hierarchy f))) 
             (if (null? this) 
                 (error "Non-existent hierarchy --" hierarchy) 
                 (get-type (car this))))) 
     ;; Add level 
     (define (append-floor! type hierarchy) 
         (let ((same (filter 
                         (lambda (t) (eq? type t)) 
                         (map get-type type-tower)))) 
             (if (null? same) 
                     (cons (make-floor type hierarchy) type-tower)) 
                 (error "existent type--" type)))) 
     ;; selecting operation 
     (define (operation op) 
         (cond ((eq? op 'find-hierarchy) find-hierarchy) 
             ((eq? op 'find-type) find-type) 
             ((eq? op 'append-floor!) append-floor!) 
             (else (error "Non-existent operation--" op)))) 
 ;; Operation interface 
 (define rank-manager (make-rank-manager)) 
 (define get-rank (rank-manager 'find-hierarchy)) 
 (define get-type (rank-manager 'find-type)) 
 (define put-rank (rank-manager 'append-floor!)) 
 ;; Create a Set Type Tower 
 ;; Layer hierarchy is controlled by a basic numerical value 
 ;; The larger the value, the higher the level. 
 (define (make-number-tower) 
     (put-rank 'scheme-number 1) 
     (put-rank 'rational 3) 
     (put-rank 'real 5) 
     (put-rank 'complex 7) 
 ;; Promote data to a given type hierarchy 
 (define (raise-it data hierarchy) 
     (let ((rank (get-rank (type-tag data)))) 
         (if (= hierarchy rank) 
             (raise-it (raise data) hierarchy)))) 
 (define (apply-generic op . args) 
     (define (no-method-error tags) 
             "No method for these types" 
             (list op tags))) 
     (let ((type-tags (map type-tag args))) 
         (let ((proc (get op type-tags))) 
             (if proc 
                 (apply proc (map contents args)) 
                 (let ((type-top 
                             (apply max (map get-rank type-tags)))) 
                     (let ((new-args 
                                 (map (lambda (x) (raise-it x type-top)) args))) 
                         (let ((new-type-tags (map type-tag new-args))) 
                             (if (equal? new-type-tags type-tags) 
                                 (no-method-error type-tags) 
                                 (apply apply-generic (cons op new-args))))))))))