Lazy version of evaluator and tests.

[sicp.git] / src / sicp / ch2_2.clj

diff --git a/src/sicp/ch2_2.clj b/src/sicp/ch2_2.clj
index 30fd55bdbd9cf2d7c221d3fc41c42585a2976883..6ace1650fbc97e4f00c4827960b02e376f13fd46 100644 (file)
--- a/src/sicp/ch2_2.clj
+++ b/src/sicp/ch2_2.clj
@@ -1,6 +1,9 @@
 (ns sicp.ch2-2
-  (:refer-clojure :exclude (map))
-  (:use [sicp [ch1-2 :only (fib)]]
+  (:refer-clojure :exclude (map remove))
+  (:use [sicp [ch1-2 :only (fib prime?)]
+              [ex2_23 :only (for-each)]
+              [ex2_44 :only (up-split)]
+              [ex2_50 :only (flip-horiz)]]
         [clojure.test]))
 
 (cons 1
@@ -206,3 +209,138 @@
        (map square ,,,)
        (accumulate * 1 ,,,)))
 
+;; nested mapping
+(accumulate append
+            nil
+            (map (fn [i]
+                   (map (fn [j] (list i j))
+                        (enumerate-interval 1 (- i 1))))
+                 (enumerate-interval 1 6)))
+
+(defn flatmap [proc xs]
+  (accumulate append nil (map proc xs)))
+
+(defn prime-sum? [pair]
+  (prime? (+ (first pair)
+             (first (rest pair)))))
+
+;;; create the triple (i,j,sum)
+(defn make-pair-sum [pair]
+  (list (first pair)
+        (first (rest pair))
+        (+ (first pair)
+           (first (rest pair)))))
+
+(defn prime-sum-pairs [n]
+  (map make-pair-sum 
+       (filter prime-sum?
+               (flatmap (fn [i]
+                          (map (fn [j] (list i j))
+                               (enumerate-interval 1 (- i 1))))
+                        (enumerate-interval 1 n)))))
+
+;;; permutations
+(defn remove [item sequence]
+  (filter (fn [x] (not= item x)) sequence))
+
+(defn permutations [s]
+  (if (empty? s)
+    (list nil)
+    (flatmap (fn [x]
+               (map (fn [p] (cons x p))
+                    (permutations (remove x s))))
+             s)))
+
+
+;;; 2.2.4 picture language
+(declare beside flip-vert)
+
+(defn flipped-pairs [painter]
+  (let [painter2 (beside painter (flip-vert painter))]
+    (below painter2 painter2)))
+
+(defn right-split [painter n]
+  (if (= n 0)
+    painter
+    (let [smaller (right-split painter (- n 1))]
+      (beside painter (below smaller smaller)))))
+
+(defn corner-split [painter n]
+  (if (= n 0)
+    painter
+    (let [up       (up-split painter (- n 1))
+          right    (right-split painter (- n 1))
+          top-left (beside up up)
+          bottom-right (below right right)
+          corner   (corner-split painter (- n 1))]
+      (beside (below painter top-left)
+              (below bottom-right corner)))))
+
+(defn square-limit [painter n]
+  (let [quarter (corner-split painter n)
+        half    (beside (flip-horiz quarter) quarter)]
+    (below (flip-vert half) half)))
+
+(defn frame-coord-map [frame]
+  (fn [v]
+    (add-vect
+     (origin-frame frame)
+     (add-vect (scale-vect (edge1-frame frame) (xcor-vect v))
+               (scale-vect (edge2-frame frame) (ycor-vect v))))))
+
+(defn segments->painter [segment-list]
+  (fn [frame]
+    (for-each
+     (fn [segment]
+       (draw-line
+        ((frame-coord-map frame) (start-segment segment))
+        ((frame-coord-map frame) (end-segment segment))))
+     (segment-list))))
+
+;; transformation
+(defn transform-painter [painter origin corner1 corner2]
+  (fn [frame]
+    (let [m (frame-coord-map frame)
+          new-origin (m origin)]
+      (painter (make-frame new-origin
+                           (sub-vect (m corner1) new-origin)
+                           (sub-vect (m corner2) new-origin))))))
+
+(defn flip-vert [painter]
+  (transform-painter painter
+                     (make-vect 0 1)
+                     (make-vect 1 1)
+                     (make-vect 0 0)))
+
+(defn shrink-to-upper-right [painter]
+  (transform-painter painter
+                     (make-vect 0.5 0.5)
+                     (make-vect 1 0.5)
+                     (make-vect 0.5 1)))
+
+(defn rotate90 [painter]
+  (transform-painter painter
+                     (make-vect 1 0)
+                     (make-vect 1 1)
+                     (make-vect 0 0)))
+
+(defn squash-inwards [painter]
+  (transform-painter painter
+                     (make-vect 0.0 0.0)
+                     (make-vect 0.65 0.35)
+                     (make-vect 0.35 0.65)))
+
+(defn beside [painter1 painter2]
+  (let [split-point (make-vect 0.5 1)
+        paint-left (transform-painter painter1
+                                  (make-vect 0 0)
+                                  split-point
+                                  (make-vect 0 1))
+        paint-right (transform-painter painter2
+                                   split-point
+                                   (make-vect 1 1)
+                                   (make-vect 0 1))]
+    (fn [frame]
+      (paint-left frame)
+      (paint-right frame))))
+