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   (first-expr s))
 105
 106 (defn augend [s]
 107   (rest-expr s))
 108
 109 (defn product? [x]
 110   (= (second x) '*))
 111
 112 (defn multiplier [p]
 113   (first p))
 114
 115 (defn multiplicand [p]
 116   (rest (rest p)))
 117
 118 (defn make-exponentiation [b n]
 119   (cond (=number? b 1) 1
 120         (=number? b 0) 0
 121         (=number? n 1) b
 122         (=number? n 0) 1
 123         (and (number? b) (number? n)) (Math/pow b n)
 124         :else (list b '** n)))
 125
 126 (defn deriv [exp var]
 127   (cond (number? exp) 0
 128         (variable? exp) (if (same-variable? exp var) 1 0)
 129         (sum? exp) (make-sum (deriv (addend exp) var)
 130                              (deriv (augend exp) var))
 131         (product? exp) (make-sum (make-product (multiplier exp)
 132                                                (deriv (multiplicand exp) var))
 133                                  (make-product (deriv (multiplier exp) var)
 134                                                (multiplicand exp)))
 135         (exponentiation? exp) (make-product (exponent exp)
 136                                             (make-product (make-exponentiation (base exp)
 137                                                                                (- (exponent exp) 1))
 138                                                           (deriv (base exp) var)))
 139         :else (str "unknown expression type -- deriv " exp)))
 140
 141
 142 (deftest test-deriv-and-helpers
 143   (let [e1 1
 144         e2 '(x)
 145         e3 '(x + 1)
 146         e4 '(x * y)
 147         e5 '(x * x)
 148         e6 'x
 149         e7 '(x + 2 * x + 2)
 150         e8 '(x * y + 1)]
 151     (are [p q] [= p q]
 152          (first-expr e3) '(x)
 153          (op-expr e3)    '+
 154          (rest-expr e3)  '(1)
 155          (first-expr e4) '(x * y)
 156          (op-expr e4)    nil
 157          (rest-expr e4)  ()
 158          (first-expr e7) '(x)
 159          (op-expr e7) '+
 160          (rest-expr e7) '(2 * x + 2)
 161          (first-expr e8) '(x * y)
 162          (op-expr e8) '+
 163          (rest-expr e8) '(1))))
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180