]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ex2_58b.clj
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ex2_58b.clj
1 (ns sicp.ex2_58b
2   (:refer-clojure :exclude (number?))
3   (:use [clojure.test]
4         [sicp.utils]))
5
6 ;;; differentiation of infix expressions
7 ;;    part b. Assume standard algebraic form.
8 ;;
9 (defn third [x]
10   (if (= (count x) 3)
11     (second (rest x))
12     (rest (rest x))))
13
14 (defn same-op? [op x]
15   (= op x))
16
17 (defn peek-op [expr]
18   (second expr))
19
20 (defn- first-expr* [expr op]
21   (cond (and (nil? (peek-op expr)) (empty? expr)) nil
22         (and (same-op? op (peek-op expr))
23              (= op '*)) (cons (first expr) (cons (second expr) (first-expr* (rest (rest expr)) op)))
24         :else (list (first expr))))
25
26 (defn first-expr [expr]
27   (let [op (second expr)]
28     (when (not (nil? op))
29       (first-expr* expr op))))
30
31 (defn- rest-expr* [expr op]
32   (cond (empty? expr) nil
33         (and (same-op? op (peek-op expr)) (= op '*)) (rest-expr* (rest (rest expr)) op)
34         :else (rest (rest expr))))
35
36 (defn rest-expr [expr]
37   (let [op (second expr)]
38     (when (not (nil? op))
39       (rest-expr* expr op))))
40
41 (defn- op-expr* [expr op]
42   (cond (empty? expr) nil
43         (same-op? op (peek-op expr)) (op-expr* (rest (rest expr)) op)
44         :else (if (= op '*) (peek-op expr) op)))
45
46 (defn op-expr [expr]
47   (let [op (second expr)]
48     (when (not (nil? op))
49       (op-expr* expr op))))
50
51 (defn exponentiation? [exp]
52   (= (second exp) '**))
53
54 (defn base [exp]
55   (first exp))
56
57 (defn exponent [exp]
58   (third exp))
59
60 (defn variable? [x]
61   (if (and (list? x)
62            (= (count x) 1))
63     (symbol? (first x))
64     (symbol? x)))
65
66 (defn same-variable? [v1 v2]
67   (cond (list? v1) (and (variable? v1)
68                         (variable? v2)
69                         (= (first v1) v2))
70         (list? v2) (and (variable? v1)
71                         (variable? v2)
72                         (= v1 (first v2)))        
73         :else (and (variable? v1)
74                    (variable? v2)
75                    (= v1 v2))))
76
77 (defn number? [exp]
78   (if (and (list? exp)
79            (= (count exp) 1))
80     (clojure.core/number? (first exp))
81     (clojure.core/number? exp)))
82
83 (defn =number? [exp num]
84   (and (number? exp)
85        (= exp num)))
86
87 (defn make-sum [a1 a2]
88   (cond (=number? a1 0) a2
89         (=number? a2 0) a1
90         (and (number? a1) (number? a2)) (+ a1 a2)
91         :else (list a1 '+ a2)))
92
93 (defn make-product [m1 m2]
94   (cond (or (=number? m1 0) (=number? m2 0)) 0
95         (=number? m1 1) m2
96         (=number? m2 1) m1
97         (and (number? m1) (number? m2)) (* m1 m2)
98         :else (list m1 '* m2)))
99
100 (defn sum? [x]
101   (and (list? x) (= (op-expr x) '+)))
102
103 (defn addend [s]
104   (let [a (first-expr s)]
105     (if (and (list? a)
106              (= (count a) 1))
107       (first a)
108       a)))
109
110 (defn augend [s]
111   (let [a (rest-expr s)]
112     (if (and (list? a)
113              (= (count a) 1))
114       (first a)
115       a)))
116
117 (defn product? [x]
118   (= (second x) '*))
119
120 (defn multiplier [p]
121   (let [m (first p)]
122     (if (and (list? m)
123              (= (count m) 1))
124       (first m)
125       m)))
126
127 (defn multiplicand [p]
128   (let [m (rest (rest p))]
129     (if (and (list? m)
130              (= (count m) 1))
131       (first m)
132       m)))
133
134 (defn make-exponentiation [b n]
135   (cond (=number? b 1) 1
136         (=number? b 0) 0        
137         (=number? n 1) b
138         (=number? n 0) 1
139         (and (number? b) (number? n)) (Math/pow b n)
140         :else (list b '** n)))
141
142 (defn deriv [exp var]
143   (cond (number? exp) 0
144         (variable? exp) (if (same-variable? exp var) 1 0)
145         (sum? exp) (make-sum (deriv (addend exp) var)
146                              (deriv (augend exp) var))
147         (product? exp) (make-sum (make-product (multiplier exp)
148                                                (deriv (multiplicand exp) var))
149                                  (make-product (deriv (multiplier exp) var)
150                                                (multiplicand exp)))
151         (exponentiation? exp) (make-product (exponent exp)
152                                             (make-product (make-exponentiation (base exp)
153                                                                                (- (exponent exp) 1))
154                                                           (deriv (base exp) var)))
155         :else (str "unknown expression type -- deriv " exp)))
156
157
158 (deftest test-deriv-and-helpers
159   (let [e1 1
160         e2 '(x)
161         e3 '(x + 1)
162         e4 '(x * y)
163         e5 '(x * x)
164         e6 'x
165         e7 '(x + 2 * x + 2)
166         e8 '(x * y + 1)]
167     (are [p q] [= p q]
168          (first-expr e3) '(x)
169          (op-expr e3)    '+
170          (rest-expr e3)  '(1)
171          (first-expr e4) '(x * y)
172          (op-expr e4)    nil
173          (rest-expr e4)  ()
174          (first-expr e7) '(x)
175          (op-expr e7) '+
176          (rest-expr e7) '(2 * x + 2)
177          (first-expr e8) '(x * y)
178          (op-expr e8) '+
179          (rest-expr e8) '(1))))
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196