SICP 問題 2.73

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

;; a 元のプログラムと違うのはelseの行．
operatorの型に合わせたderivが呼ばれ残りの要素を処理する．
numberとvariableはリストでないので型を持たないため，データ主導の振り分けに吸収できない．

;; b

(define (install-deriv-sum-package)
  (define (deriv-sum exp var)
    (make-sum (deriv (addend exp) var)
              (deriv (augend exp) var)))

  (define (make-sum a1 a2)
    (cond ((= a1 0) a2)
          ((= a2 0) a1)
          ((and (number? a1) (number? a2)) (+ a1 a2))
          (else (list '+ a1 a2))))

  (define (addend x) (cadr x))

  (define (augend x) (caddr x)
    (if (null? (cdddr x))
        (caddr x)
        (cons '+ (cddr x))))

  (put 'deriv '+ deriv-sum)
  (put 'make '+ make-sum)
  'done)

(define (install-deriv-product-package)
  (define (deriv-product exp var)
    ((get 'make-sum '+)
     (make-product (multiplier exp)
                   (deriv (multiplicand exp) var))
     (make-product (multiplicand exp)
                   (deriv (multiplier exp) var))))

  (define (make-product m1 m2)
    (cond ((or (= m1 0) (= m2 0)) 0)
          ((= m1 1) m2)
          ((= m2 1) m1)
          ((and (number? m1) (number? m2)) (* m1 m2))
          (else (list '* m1 m2))))

  (define (multiplier x) (cadr x))

  (define (multiplicand x)
    (if (null? (cdddr x))
        (caddr x)
        (cons '* (cddr x))))

  (put 'deriv '* deriv-product)
  (put 'make '* make-product)

  'done)

;; c

(define (install-exponent-package)
  (define (deriv-exponent exp var)
    (let ((make-product (get make '*)))
      (make-product
       (make-product (exponent x)
                     (make-exponentiation (base x)
                                          (- (exponent x) 1)))
       (deriv (base x) var))))

  (define (exponent x) (cadr x))

  (define (base x) (caddr x))

  (define (make-exponent b e)
    (cond ((= e 0) 1)
          ((= e 1) b)
          ((= b 0) 0)
          (else (list '** b e))))

  (put 'deriv '** deriv-exponent)
  (put 'make '** make-exponent)
  'done)

;; d putの演算と型を入れ替える