From: Ramakrishnan Muthukrishnan <vu3rdd@gmail.com>
Date: Tue, 23 Nov 2010 14:13:32 +0000 (+0530)
Subject: picture language implemented again using racket.
X-Git-Url: https://git.rkrishnan.org/listings/frontends?a=commitdiff_plain;h=f4636d51811ab6dd8ca33a1aa3deb3e40811d322;p=sicp.git

picture language implemented again using racket.
---

diff --git a/src/sicp/ch2_2_4.rkt b/src/sicp/ch2_2_4.rkt
new file mode 100644
index 0000000..8d26cd0
--- /dev/null
+++ b/src/sicp/ch2_2_4.rkt
@@ -0,0 +1,218 @@
+#lang racket/load
+;#lang planet neil/sicp
+(require (planet "sicp.ss" ("soegaard" "sicp.plt" 2 1)))
+;(require (planet neil/sicp:1:13))
+
+(define (identity x) x)
+
+(define (flipped-pairs painter)
+  (let ((painter2 (beside painter (flip-vert painter))))
+    (below painter2 painter2)))
+
+(paint (flipped-pairs einstein))
+
+(define (right-split painter n)
+  (if (= n 0)
+      painter
+      (let ((smaller (right-split painter (- n 1))))
+        (beside painter (below smaller smaller)))))
+
+(paint (right-split einstein 2))
+
+(define (corner-split painter n)
+  (if (= n 0)
+      painter
+      (let ((up (up-split painter (- n 1)))
+            (right (right-split painter (- n 1))))
+        (let ((top-left (beside up up))
+              (bottom-right (below right right))
+              (corner (corner-split painter (- n 1))))
+          (below (beside painter bottom-right)
+                 (beside top-left corner))))))
+
+(define (square-limit painter n)
+  (let ((corner (corner-split painter n)))
+    (let ((half (beside (flip-horiz corner) corner)))
+      (below (flip-vert half) half))))
+
+;; ex 2.44
+(define (up-split painter n)
+  (if (= n 0)
+      painter
+      (let ((smaller (up-split painter (- n 1))))
+        (below painter (beside smaller smaller)))))
+
+(paint (up-split einstein 2))
+
+;; higher order operations
+(define (square-of-four tl tr bl br)
+  (lambda (painter)
+    (let ((top (beside (tl painter) (tr painter)))
+          (bottom (beside (bl painter) (br painter))))
+      (below bottom top))))
+
+(define (flipped-pairs2 painter)
+  (let ((combine4 (square-of-four identity flip-vert
+                                  identity flip-vert)))
+    (combine4 painter)))
+
+(paint (flipped-pairs2 einstein))
+
+;; square-limit in terms of square-of-four
+(define (square-limit2 painter n)
+  (let ((square (square-of-four flip-horiz identity
+                                rotate180  flip-vert)))
+    (square (corner-split painter n))))
+
+(paint (square-limit2 einstein 1))
+
+;; ex 2.45
+(define (split op1 op2)
+  (lambda (painter n)
+    (if (= n 0)
+        painter
+        (let ((smaller ((split op1 op2) painter (- n 1))))
+          (op1 painter (op2 smaller smaller))))))
+
+(define usplit (split below beside))
+(define rsplit (split beside below))
+
+;; ex 2.46
+;; A vector running from origin to (x,y) can be represented by a cons cell
+(define (make-vect x y) (cons x y))
+(define (xcor-vect v)   (car v))
+(define (ycor-vect v)   (cdr v))
+
+;; vector operations
+(define (add-vect v1 v2)
+  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
+             (+ (ycor-vect v1) (ycor-vect v2))))
+
+(define (sub-vect v1 v2)
+  (make-vect (- (xcor-vect v1) (xcor-vect v2))
+             (- (ycor-vect v1) (ycor-vect v2))))
+
+(define (scale-vect s v)
+  (make-vect (* s (xcor-vect v))
+             (* s (ycor-vect v))))
+
+;; ex 2.47
+;; a
+(define (make-frame1 origin edge1 edge2)
+  (list origin edge1 edge2))
+
+(define (origin-frame1 frame)
+  (car frame))
+
+(define (edge1-frame1 frame)
+  (car (cdr frame)))
+
+(define (edge2-frame1 frame)
+  (car (cdr (cdr frame))))
+
+;; b
+(define (make-frame2 origin edge1 edge2)
+  (cons origin (cons edge1 edge2)))
+
+(define (origin-frame2 frame)
+  (car frame))
+
+(define (edge1-frame2 frame)
+  (car (cdr frame)))
+
+(define (edge2-frame2 frame)
+  (cdr (cdr frame)))
+
+;; for now use option a.
+(define origin-frame origin-frame1)
+(define edge1-frame  edge1-frame1)
+(define edge2-frame  edge2-frame1)
+
+;;; frames
+(define (frame-coord-map frame)
+  (lambda (v)
+    (add-vect (origin-frame frame)
+              (add-vect (scale-vect (xcor-vect v) (edge1-frame frame))
+                        (scale-vect (ycor-vect v) (edge2-frame frame))))))
+
+;; ex 2.48
+(define (make-segment v1 v2)    (cons v1 v2))
+(define (start-segment segment) (car segment))
+(define (end-segment segment)   (cdr segment))
+
+;; ex 2.49
+;; a. The painter that draws the outline of the designated frame.
+(define one  0.99)
+(define zero 0)
+
+(define (outline frame)
+  ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one zero))
+                            (make-segment (make-vect one zero) (make-vect one one))
+                            (make-segment (make-vect one one) (make-vect zero one))
+                            (make-segment (make-vect zero one) (make-vect zero zero))))
+   frame))
+
+;; b.  The painter that draws an ``X'' by connecting opposite corners of the frame.
+(define (x-connect frame)
+  ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one one))
+                            (make-segment (make-vect zero one) (make-vect one zero))))
+   frame))
+    
+;; c.  The painter that draws a diamond shape by connecting the midpoints of the 
+;;     sides of the frame.
+(define (diamond frame)
+  (let ((v1 (make-vect 0.5 0))
+        (v2 (make-vect 0.999 0.5))
+        (v3 (make-vect 0.5 0.999))
+        (v4 (make-vect 0 0.5)))
+    ((segments->painter (list (make-segment v1 v2)
+                              (make-segment v2 v3)
+                              (make-segment v3 v4)
+                              (make-segment v4 v1))) 
+     frame)))
+
+;; d. The wave painter. 
+(define (waveman frame)
+  (let ((p1 (make-vect 0.25 0))
+        (p2 (make-vect 0.4 0.4))
+        (p3 (make-vect 0.25 0.5))
+        (p4 (make-vect 0.15 0.4))
+        (p5 (make-vect 0 0.7))
+        (p6 (make-vect 0 0.8))
+        (p7 (make-vect 0.15 0.55))
+        (p8 (make-vect 0.25 0.6))
+        (p9 (make-vect 0.4 0.6))
+        (p10 (make-vect 0.35 0.75))
+        (p11 (make-vect 0.4 0.9))
+        (p12 (make-vect 0.6 0.9))
+        (p13 (make-vect 0.65 0.75))
+        (p14 (make-vect 0.6 0.6))
+        (p15 (make-vect 0.8 0.6))
+        (p16 (make-vect 0.999 0.25))
+        (p17 (make-vect 0.999 0.1))
+        (p18 (make-vect 0.6 0.4))
+        (p19 (make-vect 0.75 0))
+        (p20 (make-vect 0.65 0))
+        (p21 (make-vect 0.5 0.2))
+        (p22 (make-vect 0.35 0)))
+    (let ((s1 (make-vect p1 p2))
+          (s2 (make-vect p2 p3))
+          (s3 (make-vect p3 p4))
+          (s4 (make-vect p4 p5))
+          (s5 (make-vect p6 p7))
+          (s6 (make-vect p7 p8))
+          (s7 (make-vect p8 p9))
+          (s8 (make-vect p9 p10))
+          (s9 (make-vect p10 p11))
+          (s10 (make-vect p12 p13))
+          (s11 (make-vect p13 p14))
+          (s12 (make-vect p14 p15))
+          (s13 (make-vect p15 p16))
+          (s14 (make-vect p17 p18))
+          (s15 (make-vect p18 p19))
+          (s16 (make-vect p20 p21))
+          (s17 (make-vect p21 p22)))
+      ((segments->painter (list s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15 s16 s17))
+       frame))))
+
+         
\ No newline at end of file