1 665c255d 2023-08-04 jrmu (define (right-split painter n)
  2 665c255d 2023-08-04 jrmu   (if (= n 0)
  3 665c255d 2023-08-04 jrmu       painter
  4 665c255d 2023-08-04 jrmu       (let ((smaller (right-split painter (- n 1))))
  5 665c255d 2023-08-04 jrmu 	(beside painter (below smaller smaller)))))
  6 665c255d 2023-08-04 jrmu (define (corner-split painter n)
  7 665c255d 2023-08-04 jrmu   (if (= n 0)
  8 665c255d 2023-08-04 jrmu       painter
  9 665c255d 2023-08-04 jrmu       (let ((up (up-split painter (- n 1)))
 10 665c255d 2023-08-04 jrmu 	    (right (right-split painter (- n 1))))
 11 665c255d 2023-08-04 jrmu 	(let ((top-left (beside up up))
 12 665c255d 2023-08-04 jrmu 	      (bottom-right (below right right))
 13 665c255d 2023-08-04 jrmu 	      (corner (corner-split painter (- n 1))))
 14 665c255d 2023-08-04 jrmu 	  (beside (below painter top-left)
 15 665c255d 2023-08-04 jrmu 		  (below bottom-right corner))))))
 16 665c255d 2023-08-04 jrmu (define (square-limit painter n)
 17 665c255d 2023-08-04 jrmu   (let ((quarter (corner-split painter n)))
 18 665c255d 2023-08-04 jrmu     (let ((half (beside (flip-horiz quarter) quarter)))
 19 665c255d 2023-08-04 jrmu       (below (flip-vert half) half))))
 20 665c255d 2023-08-04 jrmu (define (up-split painter n)
 21 665c255d 2023-08-04 jrmu   (if (= n 0)
 22 665c255d 2023-08-04 jrmu       painter
 23 665c255d 2023-08-04 jrmu       (let ((up (up-split painter (- n 1))))
 24 665c255d 2023-08-04 jrmu 	(below painter (beside up up)))))
 25 665c255d 2023-08-04 jrmu (define (square-of-four tl tr bl br)
 26 665c255d 2023-08-04 jrmu   (lambda (painter)
 27 665c255d 2023-08-04 jrmu     (let ((top (beside (tl painter) (tr painter)))
 28 665c255d 2023-08-04 jrmu 	  (bottom (beside (bl painter) (br painter))))
 29 665c255d 2023-08-04 jrmu       (below bottom top))))
 30 665c255d 2023-08-04 jrmu 
 31 665c255d 2023-08-04 jrmu (define (flipped-pairs painter)
 32 665c255d 2023-08-04 jrmu   (let ((combine4 (square-of-four identity flip-vert
 33 665c255d 2023-08-04 jrmu 				  identity flip-vert)))
 34 665c255d 2023-08-04 jrmu     (combine4 painter)))
 35 665c255d 2023-08-04 jrmu (define (square-limit painter n)
 36 665c255d 2023-08-04 jrmu   (let ((combine4 (square-of-four flip-horiz identity
 37 665c255d 2023-08-04 jrmu 				  rotate180 flip-vert)))
 38 665c255d 2023-08-04 jrmu     (combine4 (corner-split painter n))))
 39 665c255d 2023-08-04 jrmu 
 40 665c255d 2023-08-04 jrmu (define (split op1 op2)
 41 665c255d 2023-08-04 jrmu   (define (split-n painter n)
 42 665c255d 2023-08-04 jrmu     (if (= n 0)
 43 665c255d 2023-08-04 jrmu 	painter
 44 665c255d 2023-08-04 jrmu 	(let ((split-painter (split-n painter (- n 1))))
 45 665c255d 2023-08-04 jrmu 	  (op1 painter (op2 split-painter split-painter)))))
 46 665c255d 2023-08-04 jrmu   split-n)
 47 665c255d 2023-08-04 jrmu 
 48 665c255d 2023-08-04 jrmu (define right-split (split beside below))
 49 665c255d 2023-08-04 jrmu (define up-split (split below beside))
 50 665c255d 2023-08-04 jrmu 
 51 665c255d 2023-08-04 jrmu (define (frame-coord-map frame)
 52 665c255d 2023-08-04 jrmu   (lambda (v)
 53 665c255d 2023-08-04 jrmu     (add-vect
 54 665c255d 2023-08-04 jrmu      (origin-frame frame)
 55 665c255d 2023-08-04 jrmu      (add-vect (scale-vect (xcor-vect v)
 56 665c255d 2023-08-04 jrmu 			   (edge1-frame frame))
 57 665c255d 2023-08-04 jrmu 	       (scale-vect (ycor-vect v)
 58 665c255d 2023-08-04 jrmu 			   (edge2-frame frame))))))
 59 665c255d 2023-08-04 jrmu 
 60 665c255d 2023-08-04 jrmu (define (make-vect xcor ycor)
 61 665c255d 2023-08-04 jrmu   (cons xcor ycor))
 62 665c255d 2023-08-04 jrmu (define (xcor-vect v)
 63 665c255d 2023-08-04 jrmu   (car v))
 64 665c255d 2023-08-04 jrmu (define (ycor-vect v)
 65 665c255d 2023-08-04 jrmu   (cdr v))
 66 665c255d 2023-08-04 jrmu (define (add-vect v1 v2)
 67 665c255d 2023-08-04 jrmu   (make-vect (+ (xcor-vect v1) (xcor-vect v2))
 68 665c255d 2023-08-04 jrmu 	     (+ (ycor-vect v1) (ycor-vect v2))))
 69 665c255d 2023-08-04 jrmu (define (sub-vect v1 v2)
 70 665c255d 2023-08-04 jrmu   (make-vect (- (xcor-vect v1) (xcor-vect v2))
 71 665c255d 2023-08-04 jrmu 	     (- (ycor-vect v1) (ycor-vect v2))))
 72 665c255d 2023-08-04 jrmu (define (scale-vect s v)
 73 665c255d 2023-08-04 jrmu   (make-vect (* s (xcor-vect v))
 74 665c255d 2023-08-04 jrmu 	     (* x (ycor-vect v))))
 75 665c255d 2023-08-04 jrmu 
 76 665c255d 2023-08-04 jrmu ;; Exercise 2.47.  Here are two possible constructors for frames:
 77 665c255d 2023-08-04 jrmu 
 78 665c255d 2023-08-04 jrmu (define (make-frame origin edge1 edge2)
 79 665c255d 2023-08-04 jrmu   (list origin edge1 edge2))
 80 665c255d 2023-08-04 jrmu (define (origin-frame frame)
 81 665c255d 2023-08-04 jrmu   (car frame))
 82 665c255d 2023-08-04 jrmu (define (edge1-frame frame)
 83 665c255d 2023-08-04 jrmu   (cadr frame))
 84 665c255d 2023-08-04 jrmu (define (edge2-frame frame)
 85 665c255d 2023-08-04 jrmu   (caddr frame))
 86 665c255d 2023-08-04 jrmu 
 87 665c255d 2023-08-04 jrmu (define (segments->painter segment-list)
 88 665c255d 2023-08-04 jrmu   (lambda (frame)
 89 665c255d 2023-08-04 jrmu     (for-each
 90 665c255d 2023-08-04 jrmu      (lambda (segment)
 91 665c255d 2023-08-04 jrmu        (draw-line
 92 665c255d 2023-08-04 jrmu 	((frame-coord-map frame) (start-segment segment))
 93 665c255d 2023-08-04 jrmu 	((frame-coord-map frame) (end-segment segment))))
 94 665c255d 2023-08-04 jrmu      segment-list)))
 95 665c255d 2023-08-04 jrmu 
 96 665c255d 2023-08-04 jrmu (define (make-vect xcor ycor)
 97 665c255d 2023-08-04 jrmu (define (xcor-vect v)
 98 665c255d 2023-08-04 jrmu (define (ycor-vect v)
 99 665c255d 2023-08-04 jrmu (define (add-vect v1 v2)
100 665c255d 2023-08-04 jrmu (define (sub-vect v1 v2)
101 665c255d 2023-08-04 jrmu (define (scale-vect s v)
102 665c255d 2023-08-04 jrmu 
103 665c255d 2023-08-04 jrmu 
104 665c255d 2023-08-04 jrmu (define (make-segment start end)
105 665c255d 2023-08-04 jrmu   (list start end))
106 665c255d 2023-08-04 jrmu (define (start-segment segment)
107 665c255d 2023-08-04 jrmu   (car segment))
108 665c255d 2023-08-04 jrmu (define (end-segment segment)
109 665c255d 2023-08-04 jrmu   (cadr segment))
110 665c255d 2023-08-04 jrmu 
111 665c255d 2023-08-04 jrmu (segments->painter
112 665c255d 2023-08-04 jrmu  (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 0.0))
113 665c255d 2023-08-04 jrmu        (make-segment (make-vector 1.0 0.0) (make-vector 1.0 1.0))
114 665c255d 2023-08-04 jrmu        (make-segment (make-vector 1.0 1.0) (make-vector 0.0 1.0))
115 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.0 1.0) (make-vector 0.0 0.0))))
116 665c255d 2023-08-04 jrmu (segments->painter
117 665c255d 2023-08-04 jrmu  (list (make-segment (make-vector 0.0 0.0) (make-vector 1.0 1.0))
118 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.0 1.0) (make-vector 1.0 0.0))))
119 665c255d 2023-08-04 jrmu (segments->painter
120 665c255d 2023-08-04 jrmu  (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
121 665c255d 2023-08-04 jrmu        (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
122 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
123 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
124 665c255d 2023-08-04 jrmu (segments->painter
125 665c255d 2023-08-04 jrmu  (list (make-segment (make-vector 0.5 0.0) (make-vector 1.0 0.5))
126 665c255d 2023-08-04 jrmu        (make-segment (make-vector 1.0 0.5) (make-vector 0.5 1.0))
127 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.5 1.0) (make-vector 0.0 0.5))
128 665c255d 2023-08-04 jrmu        (make-segment (make-vector 0.0 0.5) (make-vector 0.5 0.0))))
129 665c255d 2023-08-04 jrmu 
130 665c255d 2023-08-04 jrmu ;; last one is too much trouble
131 665c255d 2023-08-04 jrmu 
132 665c255d 2023-08-04 jrmu (define (transform-painter painter origin corner1 corner2)
133 665c255d 2023-08-04 jrmu   (lambda (frame)
134 665c255d 2023-08-04 jrmu     (let ((m (frame-coord-map frame)))
135 665c255d 2023-08-04 jrmu       (let ((new-origin (m origin)))
136 665c255d 2023-08-04 jrmu 	(painter
137 665c255d 2023-08-04 jrmu 	 (make-frame new-origin
138 665c255d 2023-08-04 jrmu 		     (sub-vect (m corner1) new-origin)
139 665c255d 2023-08-04 jrmu 		     (sub-vect (m corner2) new-origin)))))))
140 665c255d 2023-08-04 jrmu (define (flip-vert painter)
141 665c255d 2023-08-04 jrmu   (transform-painter painter
142 665c255d 2023-08-04 jrmu 		     (make-vect 0.0 1.0)
143 665c255d 2023-08-04 jrmu 		     (make-vect 1.0 1.0)
144 665c255d 2023-08-04 jrmu 		     (make-vect 0.0 0.0)))
145 665c255d 2023-08-04 jrmu (define (shrink-to-upper-right painter)
146 665c255d 2023-08-04 jrmu   (transform-painter painter
147 665c255d 2023-08-04 jrmu 		     (make-vect 0.5 0.5)
148 665c255d 2023-08-04 jrmu 		     (make-vect 1.0 0.5)
149 665c255d 2023-08-04 jrmu 		     (make-vect 0.5 1.0)))
150 665c255d 2023-08-04 jrmu (define (rotate90 painter)
151 665c255d 2023-08-04 jrmu   (transform-painter painter
152 665c255d 2023-08-04 jrmu 		     (make-vect 1.0 0.0)
153 665c255d 2023-08-04 jrmu 		     (make-vect 1.0 1.0)
154 665c255d 2023-08-04 jrmu 		     (make-vect 0.0 0.0)))
155 665c255d 2023-08-04 jrmu (define (squash-inwards painter)
156 665c255d 2023-08-04 jrmu   (transform-painter painter
157 665c255d 2023-08-04 jrmu 		     (make-vect 0.0 0.0)
158 665c255d 2023-08-04 jrmu 		     (make-vect 0.65 0.35)
159 665c255d 2023-08-04 jrmu 		     (make-vect 0.35 0.65)))
160 665c255d 2023-08-04 jrmu (define (beside painter1 painter2)
161 665c255d 2023-08-04 jrmu   (let ((split-point (make-vect 0.5 0.0)))
162 665c255d 2023-08-04 jrmu     (let ((paint-left
163 665c255d 2023-08-04 jrmu 	   (transform-painter painter1
164 665c255d 2023-08-04 jrmu 			      (make-vect 0.0 0.0)
165 665c255d 2023-08-04 jrmu 			      split-point
166 665c255d 2023-08-04 jrmu 			      (make-vect 0.0 1.0)))
167 665c255d 2023-08-04 jrmu 	  (paint-right 
168 665c255d 2023-08-04 jrmu 	   (transform-painter painter2
169 665c255d 2023-08-04 jrmu 			      split-point
170 665c255d 2023-08-04 jrmu 			      (make-vect 1.0 0.0)
171 665c255d 2023-08-04 jrmu 			      (make-vect 0.5 1.0))))
172 665c255d 2023-08-04 jrmu       (lambda (frame)
173 665c255d 2023-08-04 jrmu 	(paint-left frame)
174 665c255d 2023-08-04 jrmu 	(paint-right frame)))))
175 665c255d 2023-08-04 jrmu 
176 665c255d 2023-08-04 jrmu ;; Exercise 2.50.  Define the transformation flip-horiz, which flips painters horizontally, and transformations that rotate painters counterclockwise by 180 degrees and 270 degrees. 
177 665c255d 2023-08-04 jrmu 
178 665c255d 2023-08-04 jrmu (define (flip-horiz painter)
179 665c255d 2023-08-04 jrmu   (transform-painter painter
180 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 0.0)
181 665c255d 2023-08-04 jrmu 		     (make-vector 0.0 0.0)
182 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 1.0)))
183 665c255d 2023-08-04 jrmu 
184 665c255d 2023-08-04 jrmu (define (rotate180 painter)
185 665c255d 2023-08-04 jrmu   (transform-painter painter
186 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 1.0)
187 665c255d 2023-08-04 jrmu 		     (make-vector 0.0 1.0)
188 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 0.0)))
189 665c255d 2023-08-04 jrmu 
190 665c255d 2023-08-04 jrmu (define (rotate270 painter)
191 665c255d 2023-08-04 jrmu   (transform-painter painter
192 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 0.0)
193 665c255d 2023-08-04 jrmu 		     (make-vector 1.0 1.0)
194 665c255d 2023-08-04 jrmu 		     (make-vector 0.0 0.0)))
195 665c255d 2023-08-04 jrmu 
196 665c255d 2023-08-04 jrmu ;; 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). 
197 665c255d 2023-08-04 jrmu 
198 665c255d 2023-08-04 jrmu (define (below