2 ;#lang planet neil/sicp
3 (require (planet "sicp.ss" ("soegaard" "sicp.plt" 2 1)))
4 ;(require (planet neil/sicp:1:13))
6 (define (identity x) x)
8 (define (flipped-pairs painter)
9 (let ((painter2 (beside painter (flip-vert painter))))
10 (below painter2 painter2)))
12 (paint (flipped-pairs einstein))
14 (define (right-split painter n)
17 (let ((smaller (right-split painter (- n 1))))
18 (beside painter (below smaller smaller)))))
20 (paint (right-split einstein 2))
22 (define (corner-split painter n)
25 (let ((up (up-split painter (- n 1)))
26 (right (right-split painter (- n 1))))
27 (let ((top-left (beside up up))
28 (bottom-right (below right right))
29 (corner (corner-split painter (- n 1))))
30 (below (beside painter bottom-right)
31 (beside top-left corner))))))
33 (define (square-limit painter n)
34 (let ((corner (corner-split painter n)))
35 (let ((half (beside (flip-horiz corner) corner)))
36 (below (flip-vert half) half))))
39 (define (up-split painter n)
42 (let ((smaller (up-split painter (- n 1))))
43 (below painter (beside smaller smaller)))))
45 (paint (up-split einstein 2))
47 ;; higher order operations
48 (define (square-of-four tl tr bl br)
50 (let ((top (beside (tl painter) (tr painter)))
51 (bottom (beside (bl painter) (br painter))))
54 (define (flipped-pairs2 painter)
55 (let ((combine4 (square-of-four identity flip-vert
59 (paint (flipped-pairs2 einstein))
61 ;; square-limit in terms of square-of-four
62 (define (square-limit2 painter n)
63 (let ((square (square-of-four flip-horiz identity
64 rotate180 flip-vert)))
65 (square (corner-split painter n))))
67 (paint (square-limit2 einstein 1))
70 (define (split op1 op2)
74 (let ((smaller ((split op1 op2) painter (- n 1))))
75 (op1 painter (op2 smaller smaller))))))
77 (define usplit (split below beside))
78 (define rsplit (split beside below))
81 ;; A vector running from origin to (x,y) can be represented by a cons cell
82 (define (make-vect x y) (cons x y))
83 (define (xcor-vect v) (car v))
84 (define (ycor-vect v) (cdr v))
87 (define (add-vect v1 v2)
88 (make-vect (+ (xcor-vect v1) (xcor-vect v2))
89 (+ (ycor-vect v1) (ycor-vect v2))))
91 (define (sub-vect v1 v2)
92 (make-vect (- (xcor-vect v1) (xcor-vect v2))
93 (- (ycor-vect v1) (ycor-vect v2))))
95 (define (scale-vect s v)
96 (make-vect (* s (xcor-vect v))
101 (define (make-frame1 origin edge1 edge2)
102 (list origin edge1 edge2))
104 (define (origin-frame1 frame)
107 (define (edge1-frame1 frame)
110 (define (edge2-frame1 frame)
111 (car (cdr (cdr frame))))
114 (define (make-frame2 origin edge1 edge2)
115 (cons origin (cons edge1 edge2)))
117 (define (origin-frame2 frame)
120 (define (edge1-frame2 frame)
123 (define (edge2-frame2 frame)
126 ;; for now use option a.
127 (define origin-frame origin-frame1)
128 (define edge1-frame edge1-frame1)
129 (define edge2-frame edge2-frame1)
132 (define (frame-coord-map frame)
134 (add-vect (origin-frame frame)
135 (add-vect (scale-vect (xcor-vect v) (edge1-frame frame))
136 (scale-vect (ycor-vect v) (edge2-frame frame))))))
139 (define (make-segment v1 v2) (cons v1 v2))
140 (define (start-segment segment) (car segment))
141 (define (end-segment segment) (cdr segment))
144 ;; a. The painter that draws the outline of the designated frame.
148 (define (outline frame)
149 ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one zero))
150 (make-segment (make-vect one zero) (make-vect one one))
151 (make-segment (make-vect one one) (make-vect zero one))
152 (make-segment (make-vect zero one) (make-vect zero zero))))
155 ;; b. The painter that draws an ``X'' by connecting opposite corners of the frame.
156 (define (x-connect frame)
157 ((segments->painter (list (make-segment (make-vect zero zero) (make-vect one one))
158 (make-segment (make-vect zero one) (make-vect one zero))))
161 ;; c. The painter that draws a diamond shape by connecting the midpoints of the
162 ;; sides of the frame.
163 (define (diamond frame)
164 (let ((v1 (make-vect 0.5 0))
165 (v2 (make-vect 0.999 0.5))
166 (v3 (make-vect 0.5 0.999))
167 (v4 (make-vect 0 0.5)))
168 ((segments->painter (list (make-segment v1 v2)
171 (make-segment v4 v1)))
174 ;; d. The wave painter.
175 (define (waveman frame)
176 (let ((p1 (make-vect 0.25 0))
177 (p2 (make-vect 0.4 0.4))
178 (p3 (make-vect 0.25 0.5))
179 (p4 (make-vect 0.15 0.4))
180 (p5 (make-vect 0 0.7))
181 (p6 (make-vect 0 0.8))
182 (p7 (make-vect 0.15 0.55))
183 (p8 (make-vect 0.25 0.6))
184 (p9 (make-vect 0.4 0.6))
185 (p10 (make-vect 0.35 0.75))
186 (p11 (make-vect 0.4 0.9))
187 (p12 (make-vect 0.6 0.9))
188 (p13 (make-vect 0.65 0.75))
189 (p14 (make-vect 0.6 0.6))
190 (p15 (make-vect 0.8 0.6))
191 (p16 (make-vect 0.999 0.25))
192 (p17 (make-vect 0.999 0.1))
193 (p18 (make-vect 0.6 0.4))
194 (p19 (make-vect 0.75 0))
195 (p20 (make-vect 0.65 0))
196 (p21 (make-vect 0.5 0.2))
197 (p22 (make-vect 0.35 0)))
198 (let ((s1 (make-vect p1 p2))
199 (s2 (make-vect p2 p3))
200 (s3 (make-vect p3 p4))
201 (s4 (make-vect p4 p5))
202 (s5 (make-vect p6 p7))
203 (s6 (make-vect p7 p8))
204 (s7 (make-vect p8 p9))
205 (s8 (make-vect p9 p10))
206 (s9 (make-vect p10 p11))
207 (s10 (make-vect p12 p13))
208 (s11 (make-vect p13 p14))
209 (s12 (make-vect p14 p15))
210 (s13 (make-vect p15 p16))
211 (s14 (make-vect p17 p18))
212 (s15 (make-vect p18 p19))
213 (s16 (make-vect p20 p21))
214 (s17 (make-vect p21 p22)))
215 ((segments->painter (list s1 s2 s3 s4 s5 s6 s7 s8 s9 s10 s11 s12 s13 s14 s15 s16 s17))