]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex2_58b.rkt
Solution to 4.44. A bit too verbose. Can be improved by better
[sicp.git] / 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)