src/sicp/ch2_3.clj

   1 (ns sicp.ch2_3
   2   (:use [sicp.utils :only (error)]
   3         [sicp.ex2_54 :only (equal?)]))
   4
   5 (defn memq [item x]
   6   (cond
   7     (empty? x) false
   8     (= (first x) item) x
   9     :else (memq item (rest x))))
  10
  11 ;; differentiation
  12
  13 ;; take it for granted the following primitives.
  14 (declare variable? same-variable? sum? addend augend make-sum product? make-product multiplier multiplicand)
  15
  16 (defn deriv [exp var]
  17   (cond (number? exp) 0
  18         (variable? exp) (if (same-variable? exp var) 1 0)
  19         (sum? exp) (make-sum (deriv (addend exp) var)
  20                              (deriv (augend exp) var))
  21         (product? exp) (make-sum (make-product (multiplier exp)
  22                                                (deriv (multiplicand exp) var))
  23                                  (make-product (deriv (multiplier exp) var)
  24                                                (multiplicand exp)))
  25         :else (error "unknown expression type -- derive")))
  26
  27 (defn variable? [x]
  28   (symbol? x))
  29
  30 (defn same-variable? [v1 v2]
  31   (and (variable? v1)
  32        (variable? v2)
  33        (= v1 v2)))
  34
  35 (defn =number? [exp num]
  36   (and (number? exp) (= exp num)))
  37
  38 (defn make-sum [a1 a2]
  39   (cond (=number? a1 0) a2
  40         (=number? a2 0) a1
  41         (and (number? a1) (number? a2)) (+ a1 a2)
  42         :else (list '+ a1 a2)))
  43
  44 (defn make-product [m1 m2]
  45   (cond (or (=number? m1 0) (=number? m2 0)) 0
  46         (=number? m1 1) m2
  47         (=number? m2 1) m1
  48         (and (number? m1) (number? m2)) (* m1 m2)
  49         :else (list '* m1 m2)))
  50
  51 (defn sum? [x]
  52   (and (list? x) (= (first x) '+)))
  53
  54 (defn addend [s]
  55   (second s))
  56
  57 (defn augend [s]
  58   (second (rest s)))
  59
  60 (defn product? [x]
  61   (and (list? x) (= (first x) '*)))
  62
  63 (defn multiplier [p]
  64   (second p))
  65
  66 (defn multiplicand [p]
  67   (second (rest p)))
  68
  69 ;;;; 2.3.3 sets
  70 (defn element-of-set? [x set]
  71   (cond (empty? set) false
  72         (equal? x (first set)) true
  73         :else (element-of-set? x (rest set))))
  74
  75 ;; add an element to the set, if not already part of the set and return the set. If
  76 ;; already part of the set, then return the set
  77 (defn adjoin-set [x set]
  78   (if (element-of-set? x set)
  79     set
  80     (cons x set)))
  81
  82 ;; intersection of two sets (i.e. elements of the set which are present in both the
  83 ;; sets)
  84 (defn intersection-set [set1 set2]
  85   (cond (or (empty? set1) (empty? set2)) ()
  86         (element-of-set? (first set1) set2) (cons (first set1)
  87                                                   (intersection-set (rest set1) set2))
  88         :else (intersection-set (rest set1) set2)))
  89
  90
  91 ;;; sets as ordered list
  92 (defn element-of-set? [x set]
  93   (cond (empty? set) false
  94         (= (first set) x) true
  95         (< x (first set)) false
  96         :else (element-of-set? x (rest set))))
  97
  98 (defn intersection-set [set1 set2]
  99   (if (or (empty? set1) (empty? set2))
 100     ()
 101     (let [x1 (first set1)
 102           x2 (first set2)]
 103       (cond (= x1 x2) (cons x1 (intersection-set (rest set1)
 104                                                  (rest set2)))
 105             (< x1 x2) (intersection-set (rest set1) set2)
 106             (< x2 x1) (intersection-set (rest set2) set1)))))
 107
 108 ;;; sets as trees
 109 ;;; trees using lists
 110 ;;;  every node is a list of 3 elements: entry, left tree and right tree
 111 (defn entry [tree]
 112   (first tree))
 113
 114 (defn left-branch [tree]
 115   (second tree))
 116
 117 (defn right-branch [tree]
 118   (second (rest tree)))
 119
 120 (defn make-tree [entry left right]
 121   (list entry left right))
 122
 123 (defn element-of-set? [x set]
 124   (cond (empty? set) false
 125         (= (entry set) x) true
 126         (< x (entry set)) (element-of-set? x (left-branch set))
 127         (> x (entry set)) (element-of-set? x (right-branch set))))
 128
 129 (defn adjoin-set [x set]
 130   (cond (empty? set) (make-tree x '() '())
 131         (= x (entry set)) set
 132         (< x (entry set)) (make-tree (entry set)
 133                                      (adjoin-set x (left-branch set))
 134                                      (right-branch set))
 135         (> x (entry set)) (make-tree (entry set)
 136                                      (left-branch set)
 137                                      (adjoin-set x (right-branch set)))))
 138
 139
 140 ;;; key lookup
 141 (defn lookup [given-key set-of-records]
 142   (cond (empty? set-of-records) false
 143         (equal? given-key (key (first set-of-records))) (first set-of-records)
 144         :else (lookup given-key (rest set-of-records))))