src/sicp/ex2_58b.rkt

   1 #lang racket
   2
   3 (define (deriv exp var)
   4   (cond ((number? exp) 0)
   5         ((variable? exp) (if (same-variable? exp var) 1 0))
   6         ((sum? exp) (make-sum (deriv (addend exp) var)
   7                               (deriv (augend exp) var)))
   8         ((product? exp) (make-sum (make-product (multiplier exp)
   9                                                 (deriv (multiplicant exp) var))
  10                                   (make-product (multiplicant exp)
  11                                                 (deriv (multiplier exp) var))))
  12         (else (error "unknown type of expression - deriv" exp))))
  13
  14 (define (variable? x) (symbol? x))
  15
  16 (define (same-variable? x y)
  17   (and (variable? x)
  18        (variable? y)
  19        (eq? x y)))
  20
  21 ;; sum
  22 (define (make-sum x y)
  23   (cond ((equal? x 0) y)
  24         ((equal? y 0) x)
  25         ((and (number? x) (number? y)) (+ x y))
  26         ((equal? x y) (make-product 2 x))
  27         (else (list x '+ y))))
  28
  29 (define (make-product x y)
  30   (cond ((equal? x 1) y)
  31         ((equal? y 1) x)
  32         ((equal? x 0) 0)
  33         ((equal? y 0) 0)
  34         (else (list x '* y))))
  35
  36 (define (sum? exp)
  37   (and (pair? exp)
  38        (eq? (first-op exp) '+)))
  39
  40 (define (product? exp)
  41   (and (pair? exp)
  42        (eq? (first-op exp) '*)))
  43
  44 (define (addend exp) (car exp))
  45
  46 (define (augend exp)
  47   (let ((aug (cdr (cdr exp))))
  48     (cond ((= 1 (length aug)) (car aug))
  49           ((pair? (car aug))  (car aug))
  50           (else aug))))
  51
  52 (define (multiplicant exp) (car exp))
  53
  54 (define (multiplier exp)
  55   (let ((mul (cdr (cdr exp))))
  56     (cond ((= 1 (length mul)) (car mul))
  57           ((pair? (car mul)) (car mul))
  58           (else mul))))
  59
  60 (define (first-op exp) (car (cdr exp)))
  61 (define (second-op exp) (car (cdr (cdr (cdr exp)))))
  62
  63 ;; test
  64 (deriv '(x + 3 * (x + (y + 2))) 'x)
  65 (deriv '(x + (3 * (x + (y + 2)))) 'x)
  66 (deriv '(x + 3 * (x + (y + 2))) 'y)
  67 (deriv '(x + (3 * (x + (y + 2)))) 'y)
  68 (deriv '(x + x) 'x)
  69 (deriv '(x + 2 * x + 2) 'x)