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