1 (define (right-split painter n)
4 (let ((smaller (right-split painter (- n 1))))
5 (beside painter (below smaller smaller)))))
6 (define (corner-split painter n)
9 (let ((up (up-split painter (- n 1)))
10 (right (right-split painter (- n 1))))
11 (let ((top-left (beside up up))
12 (bottom-right (below right right))
13 (corner (corner-split painter (- n 1))))
14 (beside (below painter top-left)
15 (below bottom-right corner))))))
16 (define (square-limit painter n)
17 (let ((quarter (corner-split painter n)))
18 (let ((half (beside (flip-horiz quarter) quarter)))
19 (below (flip-vert half) half))))
20 (define (up-split painter n)
23 (let ((up (up-split painter (- n 1))))
24 (below painter (beside up up)))))
25 (define (square-of-four tl tr bl br)
27 (let ((top (beside (tl painter) (tr painter)))
28 (bottom (beside (bl painter) (br painter))))
31 (define (flipped-pairs painter)
32 (let ((combine4 (square-of-four identity flip-vert
35 (define (square-limit painter n)
36 (let ((combine4 (square-of-four flip-horiz identity
37 rotate180 flip-vert)))
38 (combine4 (corner-split painter n))))
40 (define (split op1 op2)
41 (define (split-n painter n)
44 (let ((split-painter (split-n painter (- n 1))))
45 (op1 painter (op2 split-painter split-painter)))))
48 (define right-split (split beside below))
49 (define up-split (split below beside))
51 (define (frame-coord-map frame)
55 (add-vect (scale-vect (xcor-vect v)
57 (scale-vect (ycor-vect v)
58 (edge2-frame frame))))))
60 (define (make-vect xcor ycor)
66 (define (add-vect v1 v2)
67 (make-vect (+ (xcor-vect v1) (xcor-vect v2))
68 (+ (ycor-vect v1) (ycor-vect v2))))
69 (define (sub-vect v1 v2)
70 (make-vect (- (xcor-vect v1) (xcor-vect v2))
71 (- (ycor-vect v1) (ycor-vect v2))))
72 (define (scale-vect s v)
73 (make-vect (* s (xcor-vect v))
76 ;; Exercise 2.47. Here are two possible constructors for frames:
78 (define (make-frame origin edge1 edge2)
79 (list origin edge1 edge2))
80 (define (origin-frame frame)
82 (define (edge1-frame frame)
84 (define (edge2-frame frame)
87 (define (segments->painter segment-list)
92 ((frame-coord-map frame) (start-segment segment))
93 ((frame-coord-map frame) (end-segment segment))))
96 (define (make-vect xcor ycor)
99 (define (add-vect v1 v2)
100 (define (sub-vect v1 v2)
101 (define (scale-vect s v)
104 (define (make-segment start end)
106 (define (start-segment segment)
108 (define (end-segment segment)
112 (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
113 (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
114 (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
115 (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
117 (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
118 (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
120 (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
121 (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
122 (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
123 (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
125 (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
126 (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
127 (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
128 (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
130 ;; last one is too much trouble
132 (define (transform-painter painter origin corner1 corner2)
134 (let ((m (frame-coord-map frame)))
135 (let ((new-origin (m origin)))
137 (make-frame new-origin
138 (sub-vect (m corner1) new-origin)
139 (sub-vect (m corner2) new-origin)))))))
140 (define (flip-vert painter)
141 (transform-painter painter
144 (make-vect 0.0 0.0)))
145 (define (shrink-to-upper-right painter)
146 (transform-painter painter
149 (make-vect 0.5 1.0)))
150 (define (rotate90 painter)
151 (transform-painter painter
154 (make-vect 0.0 0.0)))
155 (define (squash-inwards painter)
156 (transform-painter painter
158 (make-vect 0.65 0.35)
159 (make-vect 0.35 0.65)))
160 (define (beside painter1 painter2)
161 (let ((split-point (make-vect 0.5 0.0)))
163 (transform-painter painter1
166 (make-vect 0.0 1.0)))
168 (transform-painter painter2
171 (make-vect 0.5 1.0))))
174 (paint-right frame)))))
176 ;; Exercise 2.50. Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees.
178 (define (flip-horiz painter)
179 (transform-painter painter
180 (make-vector 1.0 0.0)
181 (make-vector 0.0 0.0)
182 (make-vector 1.0 1.0)))
184 (define (rotate180 painter)
185 (transform-painter painter
186 (make-vector 1.0 1.0)
187 (make-vector 0.0 1.0)
188 (make-vector 1.0 0.0)))
190 (define (rotate270 painter)
191 (transform-painter painter
192 (make-vector 1.0 0.0)
193 (make-vector 1.0 1.0)
194 (make-vector 0.0 0.0)))
196 ;; Exercise 2.51. Define the below operation for painters. Below takes two painters as arguments. The resulting painter, given a frame, draws with the first painter in the bottom of the frame and with the second painter in the top. Define below in two different ways -- first by writing a procedure that is analogous to the beside procedure given above, and again in terms of beside and suitable rotation operations (from exercise 2.50).