1 665c255d 2023-08-04 jrmu (define (right-split painter n)
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)
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)
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))))
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))))
40 665c255d 2023-08-04 jrmu (define (split op1 op2)
41 665c255d 2023-08-04 jrmu (define (split-n painter n)
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)))))
48 665c255d 2023-08-04 jrmu (define right-split (split beside below))
49 665c255d 2023-08-04 jrmu (define up-split (split below beside))
51 665c255d 2023-08-04 jrmu (define (frame-coord-map frame)
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))))))
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)
64 665c255d 2023-08-04 jrmu (define (ycor-vect 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))))
76 665c255d 2023-08-04 jrmu ;; Exercise 2.47. Here are two possible constructors for frames:
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))
87 665c255d 2023-08-04 jrmu (define (segments->painter segment-list)
88 665c255d 2023-08-04 jrmu (lambda (frame)
90 665c255d 2023-08-04 jrmu (lambda (segment)
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)))
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)
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))