src/sicp/ex2_57.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         ((exponentiation? exp) (let ((u (base exp))
  13                                      (n (exponent exp)))
  14                                  (make-product n
  15                                                (make-product (make-exponentiation u (make-sum n -1))
  16                                                              (deriv u var)))))
  17         (else (error "unknown type of expression - deriv" exp))))
  18
  19 (define (variable? x) (symbol? x))
  20
  21 (define (same-variable? x y)
  22   (and (variable? x) (variable? y) (eq? x y)))
  23
  24 ;; sum
  25 (define (make-sum x y)
  26   (cond ((equal? x 0) y)
  27         ((equal? y 0) x)
  28         ((and (number? x) (number? y)) (+ x y))
  29         ((equal? x y) (make-product 2 x))
  30         (else (list '+ x y))))
  31
  32 (define (make-product x y)
  33   (cond ((equal? x 1) y)
  34         ((equal? y 1) x)
  35         ((equal? x 0) 0)
  36         ((equal? y 0) 0)
  37         (else (list '* x y))))
  38
  39 (define (sum? exp)
  40   (and (pair? exp)
  41        (eq? (car exp) '+)))
  42
  43 (define (product? exp)
  44   (and (pair? exp)
  45        (eq? (car exp) '*)))
  46
  47 (define (addend exp) (car (cdr exp)))
  48
  49 (define (augend exp)
  50   (define (augend* e1 . en)
  51     (cond ((null? en) e1)
  52           (else (make-sum e1 (apply augend* (car en) (cdr en))))))
  53   (apply augend* (cdr (cdr exp))))
  54
  55 (define (multiplicant exp) (car (cdr exp)))
  56
  57 (define (multiplier exp)
  58   (define (multiplier* e1 . en)
  59     (cond ((null? en) e1)
  60           (else (make-product e1 (apply multiplier* (car en) (cdr en))))))
  61   (apply multiplier* (cdr (cdr exp))))
  62
  63 ;; exponentiation
  64 (define (exponentiation? exp) (eq? (car exp) '**))
  65 (define (base exp) (car (cdr exp)))
  66 (define (exponent exp) (car (cdr (cdr exp))))
  67 (define (make-exponentiation base exp)
  68   (cond ((and (number? exp) (zero? exp)) 1)
  69         ((and (number? exp) (= exp 1)) base)
  70         (else (list '** base exp))))