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