]> git.rkrishnan.org Git - sicp.git/blob - src/sicp/ch2_2.clj
rewrite `quote->cons' using `match'.
[sicp.git] / src / sicp / ch2_2.clj
1 (ns sicp.ch2-2
2   (:refer-clojure :exclude (map remove))
3   (:use [sicp [ch1-2 :only (fib prime?)]
4               [ex2_23 :only (for-each)]
5               [ex2_44 :only (up-split)]
6               [ex2_50 :only (flip-horiz)]]
7         [clojure.test]))
8
9 (cons 1
10       (cons 2
11             (cons 3
12                   (cons 4 nil))))
13 ;;=> (1 2 3 4)
14 (list 1 2 3 4)
15
16 (def one-thru-four (list 1 2 3 4))
17 ;;=> #'user/one-thru-four
18 (first one-thru-four)
19 ;;=> 1
20 (rest one-thru-four)
21 ;;=> (2 3 4)
22 (cons 10 one-thru-four)
23 ;;=> (10 1 2 3 4)
24 (cons 5 one-thru-four)
25 ;;=> (5 1 2 3 4)
26
27 ;; get nth element of a list
28 (defn list-ref [items n]
29   (if (= n 0)
30     (first items)
31     (list-ref (rest items) (- n 1))))
32
33 (list-ref one-thru-four 3)
34 ;;=> 4
35 (list-ref one-thru-four 5)
36 ;;=> nil
37 (list-ref one-thru-four 1)
38 ;;=> 2
39 (list-ref one-thru-four 0)
40 ;;=> 1
41
42 (defn length [items]
43   (if (empty? items)
44     0
45     (+ 1 (length (rest items)))))
46
47 (length one-thru-four)
48 ;;=> 4
49
50 (defn- length-i [items n]
51   (if (empty? items)
52     n
53     (length-i (rest items) (+ 1 n))))
54
55 (defn length-iter [items]
56   (length-i items 0))
57
58 (length-iter one-thru-four)
59 ;;=> 4
60
61 (defn append [list1 list2]
62   (if (empty? list1)
63     list2
64     (cons (first list1)
65           (append (rest list1) list2))))
66
67 (append one-thru-four one-thru-four)
68 ;;=> (1 2 3 4 1 2 3 4)
69
70 ;; mapping over lists
71 (defn scale-list [items factor]
72   (if (empty? items)
73     nil
74     (cons (* factor (first items))
75           (scale-list (rest items) factor))))
76
77 (defn map [proc items]
78   (if (empty? items)
79     nil
80     (cons (proc (first items))
81           (map proc (rest items)))))
82
83 (defn scale-list-with-map [items factor]
84   (map (fn [item] (* item factor)) items))
85
86 ;; 2.2.2
87 (def x (cons (list 1 2) (list 3 4)))
88
89 (length x)
90 ;;=> 3
91
92 ;; count-leaves
93 (defn count-leaves [coll]
94   (cond (nil? coll)       0
95         (not (seq? coll)) 1
96         :else (+ (count-leaves (first coll))
97                  (count-leaves (next coll)))))
98
99 ;; mapping over trees
100 (defn scale-tree [tree factor]
101   (cond (nil? tree) nil
102         (not (seq? tree)) (* tree factor)
103         :else (cons (scale-tree (first tree) factor)
104                     (scale-tree (next tree) factor))))
105
106 ;; using map
107 (defn scale-tree-with-map [tree factor]
108   (map (fn [sub-tree]
109          (if (seq? sub-tree)
110            (scale-tree-with-map sub-tree factor)
111            (* sub-tree factor)))
112        tree))
113
114 ;;; 2.2.3
115 (defn sum-odd-squares [tree]
116   (cond (nil? tree) 0
117         (not (seq? tree)) (if (odd? tree)
118                             ((fn [x] (* x x)) tree)
119                             0)
120         :else (+ (sum-odd-squares (first tree))
121                  (sum-odd-squares (next tree)))))
122
123 (defn even-fibs [n]
124   (letfn [(next-fib [k]
125                     (if (> k n)
126                       nil
127                       (let [f (fib k)]
128                         (if (even? f)
129                           (cons f (next-fib (+ k 1)))
130                           (next-fib (+ k 1))))))]
131     (next-fib 0)))
132
133 (map #(* % %) (list 1 2 3 4 5))
134
135 (defn myfilter-1 [pred? xs]
136   (cond (nil? xs) nil
137         (not (seq? xs)) (if (pred? xs)
138                           (list xs)
139                           ())
140         :else (concat (myfilter-1 pred? (first xs))
141                       (myfilter-1 pred? (next xs)))))
142
143 (defn myfilter-2 [pred? xs]
144   (cond (nil? xs) nil
145         (pred? (first xs)) (cons (first xs)
146                                  (myfilter-2 pred? (next xs)))
147         :else (myfilter-1 pred? (next xs))))
148
149 ;; accumulate
150 (defn accumulate [op init xs]
151   (if (nil? xs)
152     init
153     (op (first xs)
154         (accumulate op init (next xs)))))
155
156 (defn enumerate-interval
157   ([high]
158      (enumerate-interval 0 high))
159   ([low high]
160      (if (> low high)
161        nil
162        (cons low (enumerate-interval (+ low 1) high)))))
163
164 ;; same as flatten/fringe
165 (defn enumerate-tree [tree]
166   (cond (nil? tree) nil
167         (not (seq? tree)) (list tree)
168         :else (concat (enumerate-tree (first tree))
169                       (enumerate-tree (next tree)))))
170
171 (defn square [x] (* x x))
172
173 ;; define sum of odd squares in terms of myfilter-2, enumerate, accumulate
174 (defn sum-of-odd-squares [tree]
175   (->> tree
176        (enumerate-tree)
177        (filter odd?)
178        (map square)
179        (accumulate + 0)))
180
181 (deftest test-sum-of-odd-squares
182   (is [= (sum-of-odd-squares '((1) (2) (3 4) ((5) (((6) (7)) (8)))))
183          (reduce + (map #(* % %) (filter odd? (range 1 9))))]))
184
185 (defn even-fibs-new [n]
186   (->> n
187        (enumerate-interval ,,,)
188        (map fib ,,,)
189        (filter even? ,,,)
190        (accumulate cons nil ,,,)))
191
192 (defn list-fib-squares [n]
193   (->> n
194        (enumerate-interval ,,,)
195        (map fib ,,,)
196        (map square ,,,)
197        (accumulate cons nil ,,,)))
198
199 (defn product-of-squares-of-odd-elements [sequence]
200   (accumulate *
201               1
202               (map square
203                    (filter odd? sequence))))
204
205 ;; note how beautiful and clear the clojure ->> macro is!
206 (defn product-of-squares-of-odd-elements [sequence]
207   (->> sequence
208        (filter odd? ,,,)
209        (map square ,,,)
210        (accumulate * 1 ,,,)))
211
212 ;; nested mapping
213 (accumulate append
214             nil
215             (map (fn [i]
216                    (map (fn [j] (list i j))
217                         (enumerate-interval 1 (- i 1))))
218                  (enumerate-interval 1 6)))
219
220 (defn flatmap [proc xs]
221   (accumulate append nil (map proc xs)))
222
223 (defn prime-sum? [pair]
224   (prime? (+ (first pair)
225              (first (rest pair)))))
226
227 ;;; create the triple (i,j,sum)
228 (defn make-pair-sum [pair]
229   (list (first pair)
230         (first (rest pair))
231         (+ (first pair)
232            (first (rest pair)))))
233
234 (defn prime-sum-pairs [n]
235   (map make-pair-sum 
236        (filter prime-sum?
237                (flatmap (fn [i]
238                           (map (fn [j] (list i j))
239                                (enumerate-interval 1 (- i 1))))
240                         (enumerate-interval 1 n)))))
241
242 ;;; permutations
243 (defn remove [item sequence]
244   (filter (fn [x] (not= item x)) sequence))
245
246 (defn permutations [s]
247   (if (empty? s)
248     (list nil)
249     (flatmap (fn [x]
250                (map (fn [p] (cons x p))
251                     (permutations (remove x s))))
252              s)))
253
254
255 ;;; 2.2.4 picture language
256 (declare beside flip-vert)
257
258 (defn flipped-pairs [painter]
259   (let [painter2 (beside painter (flip-vert painter))]
260     (below painter2 painter2)))
261
262 (defn right-split [painter n]
263   (if (= n 0)
264     painter
265     (let [smaller (right-split painter (- n 1))]
266       (beside painter (below smaller smaller)))))
267
268 (defn corner-split [painter n]
269   (if (= n 0)
270     painter
271     (let [up       (up-split painter (- n 1))
272           right    (right-split painter (- n 1))
273           top-left (beside up up)
274           bottom-right (below right right)
275           corner   (corner-split painter (- n 1))]
276       (beside (below painter top-left)
277               (below bottom-right corner)))))
278
279 (defn square-limit [painter n]
280   (let [quarter (corner-split painter n)
281         half    (beside (flip-horiz quarter) quarter)]
282     (below (flip-vert half) half)))
283
284 (defn frame-coord-map [frame]
285   (fn [v]
286     (add-vect
287      (origin-frame frame)
288      (add-vect (scale-vect (edge1-frame frame) (xcor-vect v))
289                (scale-vect (edge2-frame frame) (ycor-vect v))))))
290
291 (defn segments->painter [segment-list]
292   (fn [frame]
293     (for-each
294      (fn [segment]
295        (draw-line
296         ((frame-coord-map frame) (start-segment segment))
297         ((frame-coord-map frame) (end-segment segment))))
298      (segment-list))))
299
300 ;; transformation
301 (defn transform-painter [painter origin corner1 corner2]
302   (fn [frame]
303     (let [m (frame-coord-map frame)
304           new-origin (m origin)]
305       (painter (make-frame new-origin
306                            (sub-vect (m corner1) new-origin)
307                            (sub-vect (m corner2) new-origin))))))
308
309 (defn flip-vert [painter]
310   (transform-painter painter
311                      (make-vect 0 1)
312                      (make-vect 1 1)
313                      (make-vect 0 0)))
314
315 (defn shrink-to-upper-right [painter]
316   (transform-painter painter
317                      (make-vect 0.5 0.5)
318                      (make-vect 1 0.5)
319                      (make-vect 0.5 1)))
320
321 (defn rotate90 [painter]
322   (transform-painter painter
323                      (make-vect 1 0)
324                      (make-vect 1 1)
325                      (make-vect 0 0)))
326
327 (defn squash-inwards [painter]
328   (transform-painter painter
329                      (make-vect 0.0 0.0)
330                      (make-vect 0.65 0.35)
331                      (make-vect 0.35 0.65)))
332
333 (defn beside [painter1 painter2]
334   (let [split-point (make-vect 0.5 1)
335         paint-left (transform-painter painter1
336                                   (make-vect 0 0)
337                                   split-point
338                                   (make-vect 0 1))
339         paint-right (transform-painter painter2
340                                    split-point
341                                    (make-vect 1 1)
342                                    (make-vect 0 1))]
343     (fn [frame]
344       (paint-left frame)
345       (paint-right frame))))
346