sicp-ex-2.85



<< Previous exercise (2.84) | Index | Next exercise (2.86) >>


meteorgan

 ;; add into rational package 
 (put 'project 'rational 
      (lambda (x) (make-scheme-number (round (/ (numer x) (denom x)))))) 
  
 ;; add into real package 
 (put 'project 'real 
      (lambda (x)  
        (let ((rat (rationalize  
                     (inexact->exact x) 1/100))) 
          (make-rational 
            (numerator rat) 
            (denominator rat))))) 
  
 ;; add into complex package 
 (put 'project 'complex 
      (lambda (x) (make-real (real-part x)))) 
  
 (define (drop x) 
   (let ((project-proc (get 'project (type-tag x)))) 
     (if project-proc 
       (let ((project-number (project-proc (contents x)))) 
         (if (equ? project-number (raise project-number)) 
           (drop project-number) 
           x)) 
       x))) 
  
 ;; apply-generic 
 ;; the only change is to apply drop to the (apply proc (map contents args))  
 (drop (apply proc (map contents args))) 

Rptx

The previous solution did not work for me. Because I define raise in terms of apply-generic, so if I add drop to the result, it will enter an infinite loop. This also fails for equ? function, becuase you can't drop #t or #f.

  
 ; First, project, the procject package and drop. 
  
 (define (project arg) 
   (apply-generic 'project arg)) 
  
 (define (install-project-package) 
   ;; internal procedures 
   (define (complex->real x) 
     (make-real (real-part x))) 
   (define (real->integer x) 
     (round x)) 
   (define (rational->integer x) 
     (round (/ (car x) (cdr x)))) 
   ;; interface with system 
   (put 'project '(complex) 
        (lambda (x) (complex->real x))) 
   (put 'project '(real) 
        (lambda (x) (real->integer x))) 
   (put 'project '(rational) 
        (lambda (x) (rational->integer x))) 
   'done) 
  
 (install-project-package) 
  
 (define (drop arg) 
   (cond ((eq? (type-tag arg) 'scheme-number) arg) 
         ((equ? arg (raise (project arg))) 
          (drop (project arg))) 
         (else arg))) 
  
 ;; Here is my complete apply generic function. The change is the If statement 
 ;; after proc. It tests to see if it is a 'raise operation, or an 'equ?  
 ;; operation. If it is, is keeps the result as is, else it "drop"s it.  
  
  (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                  
            (let ((res (apply proc (map contents args)))) 
              (if (or (eq? op 'raise) (eq? op 'equ?)) res (drop res))) 
            (if (not-all-same-type? type-tags) 
                (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 solution from Rptx looks like if there is a bug in his hierarchy. Hierarchy should be : integer -> rational -> real -> complex.
The solution looks like:

  • integer -> rational
  • integer -> real -> complex
    A complex number cant be dropped to a rational number.


Kaucher

I think there is a bug in meteorgans solution. The line

 (if (equ? project-number (raise project-number))) 

Example: Drop the rational number 7/2.

 (put 'raise 'integer (lambda (x) (make-rational x 1))) 

Applying equ? on '4' and '4/1' returns #t, where '4/1' is definetly not equal to '7/2'. The raised object should be compared to the original object to check if the result of raising the dropped object equals the original. In Scheme:

 (if (equ? (raise project-number) x)) 

Also: integers are ordinary numbers. So... a rational number can only be dropped to an integer if the denom is 1. For example: 7/1 can be dropped. 5/1 can be dropped. 1/3 can't be dropped. So you dont have to calculate the rounded value. Instead, just create an ordinary number with (numer x) and check if its raised value is the same as the original.

 ;;; rational package 
 (put 'project 'rational (lambda (x) (make-integer (numer x)))) 

Example:


Sphinxsky

First, not all results can be simplified.The results of arithmetic process can be simplified, but the results like raise and project can not be simplified, otherwise the results will be wrong.Therefore, in apply-generic, we should distinguish op parameters, which can be simplified by drop, and those can not.


Liskov

I was stuck in this exercise for a while, and I thought in a few possiblities to solve the problem, like using conditionals for raise and project, but know which op can be dropped shouldn't be responsibility of apply-generic. Another idea is to record in a table whether the result of the operation can be "dropped" or not.

I think that the best option is to abstract from apply-generic the procedure that really apply the op, to be used later by raise and project. Here is my try:

 (define (apply-generic op . args) 
  
   (define (handle-coercion types) 
     (if (null? types) 
         (error "No methods were found: APPLY_GENERIC" op args) 
         (try-to-apply op (raise-args (car types)) handle-coercion (cdr types)))) 
  
   (define (raise-args type) 
     (map 
      (lambda (arg) 
        (let ((raised-arg (raise-up-to arg type))) 
          (if raised-arg raised-arg arg))) 
      args)) 
  
   (define (raise-up-to obj type) 
     (if (or (not obj) (equal? (type-tag obj) type)) 
         obj 
         (raise-up-to 
          (try-to-apply 'raise (list obj) identity false) 
          type))) 
  
   (let ((result 
          (try-to-apply op args handle-coercion (map type-tag args)))) 
     (if (pair? result) (drop result) result))) 
  
 (define (try-to-apply op args . callback) 
   (let ((proc (get op (map type-tag args)))) 
     (cond (proc (apply proc (map contents args))) 
           ((null? callback) '()) 
           (else (apply (car callback) (cdr callback)))))) 
  
 (define (drop obj) 
   (let ((projected-obj 
          (try-to-apply 'project (list obj) identity false))) 
     (if (and projected-obj (equ? projected-obj obj)) 
         (drop projected-obj) 
         obj))) 
  
 ;; raise and project can be rewritten as 
  
 (define (raise x) 
   (try-to-apply 'raise (list x) error "No methods were found: RAISE" x)) 
  
 (define (project x) 
   (try-to-apply 'project (list x) error "No methods were found: PROJECT" x))