]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ch2_3.clj
rewrite `quote->cons' using `match'.
[sicp.git] / 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))))