sicp-ex-2.73



<< Previous exercise (2.72) | Index | Next exercise (2.74) >>


 ;; ----------------------------------------------- 
 ;; EXERCISE 2.73 
 ;; ----------------------------------------------- 
  
 ;; b 
 (define (install-sum-package) 
   (define (make-sum a1 a2) (cons a1 a2)) 
   (define (addend s) (cadr s)) 
   (define (augend s) (caddr s)) 
   (define (deriv-sum s) 
     (make-sum (deriv (addend s)) (deriv (augend s)))) 
  
   (define (tag x) (attach-tag '+ x)) 
   (put 'deriv '(+) deriv-sum) 
   (put 'make-sum '+ 
        (lambda (x y) (tag (make-sum x y)))) 
   'done) 
  
 (define (make-sum x y) 
   ((get 'make-sum '+) x y)) 
  
 (define (install-product-package) 
   (define (make-product m1 m2) (cons m1 m2)) 
   (define (multiplier p) (cadr p)) 
   (define (multiplicand p) (caddr p)) 
   (define (deriv-product p) 
     (make-sum 
      (make-product (multiplier exp) 
                    (deriv (multiplicand exp) var)) 
      (make-product (deriv (multiplier exp) var) 
                    (multiplicand exp)))) 
  
   (define (tag x) (attach-tag '* x)) 
   (put 'deriv '(*) deriv-product) 
   (put 'make-product '* 
        (lambda (x y) (tag (make-product x y)))) 
   'done) 
  
 (define (make-product x y) 
   ((get 'make-product '*) x y)) 
  
 (define (deriv x) (apply-generic 'deriv x)) 

BE

Here is my solution which can be tested in DrRacket.

  
 #lang racket 
 (define *the-table* (make-hash));make THE table 
 (define (put key1 key2 value) (hash-set! *the-table* (list key1 key2) value));put 
 (define (get key1 key2) (hash-ref *the-table* (list key1 key2) #f));get 
  
 (define (install-symbolic-differentiation-package) 
    
   (define (addend s) (car s)) 
  
   (define (augend s) 
     (let ((cs (cdr s))) 
       (if (null? (cdr cs)) 
           (car cs) 
           (cons '+ cs)))) 
    
   (define (make-sum a1 a2) 
     (cond ((=number? a1 0) a2) 
           ((=number? a2 0) a1) 
           ((and (number? a1) (number? a2))  
            (+ a1 a2)) 
           (else (list '+ a1 a2)))) 
    
   (put 'deriv '+ (lambda (operands var) 
                    (make-sum (deriv (addend operands) var) 
                               (deriv (augend operands) var)))) 
  
   (define (multiplier p) (car p)) 
   
   (define (multiplicand p) 
     (let ((cs (cdr p))) 
       (if (null? (cdr cs)) 
           (car cs) 
           (cons '* cs)))) 
  
   (define (make-product m1 m2) 
     (cond ((or (=number? m1 0)  
                (=number? m2 0))  
            0) 
           ((=number? m1 1) m2) 
           ((=number? m2 1) m1) 
           ((and (number? m1) (number? m2))  
            (* m1 m2)) 
           (else (list '* m1 m2)))) 
    
   (put 'deriv '* (lambda (operands var) 
                    (make-sum 
                     (make-product  
                      (multiplier operands) 
                      (deriv (multiplicand operands) var)) 
                     (make-product  
                      (deriv (multiplier operands) var) 
                      (multiplicand operands))))) 
    
   (define base car) 
   (define exponent cadr) 
    
   (define (make-exponentiation base exponent) 
     (cond ((=number? base 0) 0) 
           ((=number? exponent 1) base) 
           ((=number? exponent 0) 1) 
           ((and (number? base) (number? exponent))  
            (expt base exponent)) 
           (else (list '** base exponent)))) 
    
   (put 'deriv '** (lambda (operands var) 
                    (make-product (exponent operands) 
                                  (make-product (make-exponentiation (base operands) 
                                                                     (- (exponent operands) 1)) 
                                                (deriv (base operands) var))))) 
    
   'done) 
  
 (define (variable? x) (symbol? x)) 
  
 (define (same-variable? v1 v2) 
   (and (variable? v1) 
        (variable? v2) 
        (eq? v1 v2))) 
  
 (define (=number? exp num) 
   (and (number? exp) (= exp num))) 
  
 (define (deriv exp var) 
    (cond ((number? exp) 0) 
          ((variable? exp)  
            (if (same-variable? exp var)  
                1  
                0)) 
          (else ((get 'deriv (operator exp))  
                 (operands exp)  
                 var)))) 
  
 (define (operator exp) (car exp)) 
 (define (operands exp) (cdr exp)) 
  
 (install-symbolic-differentiation-package) 
 (deriv '(+ x x x) 'x) 
 (deriv '(* x x x) 'x) 
 (deriv '(+ x (* x  (+ x (+ y 2)))) 'x) 
 (deriv '(** x 3) 'x) 

meteorgan

Here is my answer.

  
 ;;a 
 number?, same-variable? are predicates. there's nothing to dispatch. 
  
 ;; b 
 (define (install-sum-package) 
   (define (sum-deriv expr var) 
         (make-sum (deriv (addend expr) var) 
                   (deriv (augend expr) var))) 
   (define (addend expr) (car expr)) 
   (define (augend expr) (cadr expr)) 
   (define (make-sum x1 x2) 
         (cond ((and (number? x1) (number? x2)) (+ x1 x2)) 
               ((=number? x1 0) x2) 
               ((=number? x2 0) x1) 
               (else (list '+ x1 x2)))) 
  (define (mul-deriv expr var) 
    (make-sum (make-product (multiplier expr) 
                            (deriv (multiplicand expr) var)) 
              (make-product (multiplicand expr) 
                            (deriv (multiplier expr) var)))) 
  (define (multiplier expr) (car expr)) 
  (define (multiplicand expr) (cadr expr)) 
  (define (make-product x1 x2) 
    (cond ((and (number? x1) (number? x2)) (* x1 x2)) 
          ((=number? x1 1) x2) 
          ((=number? x2 1) x2) 
          ((or (=number? x1 0) (=number? x2 0)) 0) 
          (else (list '* x1 x2)))) 
  
  (put 'deriv '+ sum-deriv) 
  (put 'deriv '* mul-deriv)) 
  
  ;; c 
  (define (exponentation-deriv expr var) 
    (make-product (exponent expr) 
                  (make-product  
                    (make-exponentiation (base expr) 
                                         (make-sum (exponent expr) -1)) 
                    (deriv (base expr) var)))) 
  (define (exponent expr) 
    (cadr expr)) 
  (define (base expr) 
    (car expr)) 
  (define (make-exponentiation base exponent) 
    (cond ((=number? exponent 0) 1) 
          ((=number? exponent 1) base) 
          ((=number? base 1) 1) 
          (else (list '** base exponent)))) 
  
  (put 'deriv '** exponentiation-deriv) 
  
 ;;d 
 The only thing to do is changing the order of arguments in procedure "put". 

brave one

I don't see the need for tags inside - operation itself is enough - and separation of functions'.

 (load "deriv.scm") 
  
  
 (define (install-deriv-package) 
   ;; internal procedures 
   (define (deriv-sum pair var) ; pair as list 
     (match pair 
       [(list a b) ; a + b, yeah sorry do addend / augend 
        (make-sum (deriv a var) 
                  (deriv b var))])) 
   (define (deriv-product pair var) 
     (match pair 
       [(list a b) ; a * b 
        (make-sum (make-product a 
                                (deriv b var)) 
                  (make-product b 
                                (deriv a var)))])) 
   (define (deriv-exponentiation pair var) 
     (match pair 
       [(list a b) ; a ^ b 
        (make-product b 
                      (make-product 
                       (make-exponentiation a 
                                            (make-sum b -1)) 
                       (deriv a var)))])) 
   ;; interface to the rest of the system 
   (put 'deriv '+ deriv-sum) 
   (put 'deriv '* deriv-sum) 
   (put 'deriv '** deriv-exponentiation) 
   'done) 
  
 ; just copy as is 
 (define (deriv exp var) 
    (cond ((number? exp) 0) 
          ((variable? exp) (if (same-variable? exp var) 1 0)) 
          (else ((get 'deriv (operator exp)) (operands exp) 
                                             var)))) 
 (define (operator exp) (car exp)) 
 (define (operands exp) (cdr exp)) 
  

a0_0x

I'd like code can run. Below is my codes. Seperated my codes into 3 files, run 2_73.scm to test the code

 ==> 2_73_b.scm <== 
 (define (install-sum-package) 
  (define (addend s) (car s)) 
  (define (augend s) (cadr s)) 
  (define (make-sum a b) 
   (cond 
    ((eq? a 0) b) 
    ((eq? b 0) a) 
    ((and (number? a) (number? b)) (+ a b)) 
    (else (list '+ a b)) 
   ) 
  ) 
  (define (deriv-sum s v) 
   (make-sum (deriv (addend s) v) (deriv (augend s) v)) 
  ) 
  (put 'deriv '+ deriv-sum) 
 'done) 
 (define (install-product-package) 
  (define (multiplier s) (car s)) 
  (define (multiplicand s) (cadr s)) 
  (define (make-product a b) 
   (cond 
    ((or (eq? a 0) (eq? b 0)) 0) 
    ((eq? a 1) b) 
    ((eq? b 1) a) 
    ((and (number? a) (number? b)) (* a b)) 
    (else '(* a b)) 
   ) 
  ) 
  (define (make-sum a b) 
   (cond 
    ((eq? a 0) b) 
    ((eq? b 0) a) 
    ((and (number? a) (number? b)) (+ a b)) 
    (else (list '+ a b)) 
   ) 
  ) 
  (define (deriv-product s v) 
   (make-sum 
    (make-product (deriv (multiplier s) v) (multiplicand s) ) 
    (make-product (multiplier s) (deriv (multiplicand s) v)) 
   ) 
  ) 
  (put 'deriv '* deriv-product) 
 'done) 
  
 ==> 2_73.scm <== 
 (load "2_73_sys.scm") 
 (define (variable? x) (symbol? x)) 
 (define (same-variable? x y) (and (variable? x) (variable? y) (eq? x y))) 
 (define (apply-generic op . args) 
  (let ((type-tags (map type-tag args))) 
   (let ((proc (get op type-tags))) 
    (if proc 
     (apply proc (map contents args)) 
     (error "No method for these types -- APPLY-GENERIC" 
      (list op type-tags) 
     ) 
    ) 
   ) 
  ) 
 ) 
 (define (deriv exp var) 
  (cond ((number? exp) 0) 
   ((variable? exp) (if (same-variable? exp var) 1 0)) 
   (else ((get 'deriv (operator exp)) (operands exp) var)) 
  ) 
  ) 
 (define (operator exp) (car exp)) 
 (define (operands exp) (cdr exp)) 
                 ;test 
 (load "2_73_b.scm") 
 (install-sum-package) 
 (install-product-package) 
 (deriv 'y 'x) 
 table 
 (get 'deriv '+) 
 (deriv '(+ (* x 3) (* y x)) 'x) 
 (deriv '(* 3 x) 'x) 
  
 ==> 2_73_sys.scm <== 
 (define table (list )) 
 (define (put op type proc) 
  (set! table (append table (list (list op type proc)))) 
  ) 
 (define (get op type) 
  (define (search op type t) 
   (cond ((null? t) #f) 
    ((and (eqv? (caar t) op) (eqv? (cadar t) type)) 
         (caddar t) 
    ) 
    (else (search op type (cdr t))) 
   ) 
  ) 
  (search op type table) 
  ) 
 (define (attach-tag type-tag contents) 
  (cons type-tag contents) 
  ) 
 (define (type-tag datum) 
  (if (pair? datum) 
   (car datum) 
   (error "Bad tagged datum -- TYPE-TAG" datum) 
  ) 
  ) 
 (define (content datum) 
  (if (pair? datum) 
   (cdr datum) 
   (error "Bad tagged datum -- CONTENTS" datum) 
  ) 
  ) 
 ;(install-sum-package) 
 ;(install-product-package) 
 ;table 
  

I have found a deadly bug in almost every answer posted here before. It's about name conflict. For example in sum-package, in function deriv-sum, we are going to use make-sum again to producing the derivative. This make-sum, which we may intended to refer to the outer global make-sum defined by extracting from the table, is actually referring the inner local make-sum. This leads to the result derivative no longer a valid expression, which is just a pair without the type-tag. And the same problem appears in other packages too. My solution is to change the inner make-sum to make-sum-inner to avoid name conflict. Then we only have to change the make-sum to make-sum-inner in the (put 'make-sum '+ ...) and the program becomes correct. And I wonder if there are better solutions...


@masquue We don't need tag here.

To find the operation to applied, we need to know the operation & the type.

Here the operation is the deriv, and the type is the operator (+/*), which is easily extracted from the exp.

For the complex package example, the operation is provided, but the type is not, and there is no easy way to find the type of a complex number (hence the need to use tag).