sicp-ex-2.73

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

masquue

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...