SICP_2.50-2.51

 1 #lang sicp
 2 
 3 (#%require sicp-pict)
 4 
 5 (define (origin-frame frame)
 6   (car frame))
 7 
 8 (define (edge1-frame frame)
 9   (cadr frame))
10 
11 (define (edge2-frame frame)
12   (caddr frame))
13 
14 (define (make-vect a b)
15   (cons a b))
16 
17 (define (xcor-vect v)
18   (car v))
19 
20 (define (ycor-vect v)
21   (cdr v))
22 
23 (define (add-vect v1 v2)
24   (make-vect (+ (xcor-vect v1)
25                 (xcor-vect v2))
26              (+ (ycor-vect v1)
27                 (ycor-vect v2))))
28 
29 (define (sub-vect v1 v2)
30   (make-vect (- (xcor-vect v1)
31                 (xcor-vect v2))
32              (- (ycor-vect v1)
33                 (ycor-vect v2))))
34 
35 (define (scale-vect s v1)
36   (make-vect (* s (xcor-vect v1))
37              (* s (ycor-vect v1))))
38 
39 (define (frame-coord-map frame)
40   (lambda (v)
41     (add-vect
42      (origin-frame frame)
43      (add-vect (scale-vect (xcor-vect v)
44                            (edge1-frame frame))
45                (scale-vect (ycor-vect v)
46                            (edge2-frame frame))))))
47 ;;;;;;;;;;;;;;;;;;;2.50
48 (define (transform-painter painter origin corner1 corner2)
49   (lambda (frame)
50     (let ((m (frame-coord-map frame)))
51       (let ((new-origin (m origin)))
52         (painter
53          (make-frame new-origin
54                      (sub-vect (m corner1) new-origin)
55                      (sub-vect (m corner2) new-origin)))))))
56 
57 (define (flip-horiz painter)
58   (transform-painter painter
59                      (make-vect 1.0 0.0)
60                      (make-vect 0.0 0.0)
61                      (make-vect 1.0 1.0)))
62 
63 (define (roate90 painter)
64   (transform-painter painter
65                      (make-vect 1.0 0.0)
66                      (make-vect 1.0 1.0)
67                      (make-vect 0.0 0.0)))
68 
69 (define (roate180 painter)
70   (transform-painter painter
71                      (make-vect 1.0 1.0)
72                      (make-vect 0.0 1.0)
73                      (make-vect 1.0 0.0)))
74 
75 (define (roate270 painter)
76   (transform-painter painter
77                      (make-vect 0.0 1.0)
78                      (make-vect 0.0 0.0)
79                      (make-vect 1.0 1.0)))
80 
81 ;;;;;;;;;;;;;;;;;2.51
82 (define (my-below painter1 painter2)
83   (let ((split-point (make-vect 0.0 0.5)))
84     (let ((paint-up
85            (transform-painter painter2
86                                split-point
87                               (make-vect 1.0 0.5)
88                               (make-vect 0.0 1.0)))
89           (paint-bottom
90            (transform-painter painter1
91                               (make-vect 0.0 0.0)
92                                (make-vect 1.0 0.0)
93                                split-point)))
94       (lambda (frame)
95         (paint-up frame)
96         (paint-bottom frame)))))
97 
98 (define (my-below2 painter1 painter2)
99   (roate270 (beside (roate90 painter1) (roate90 painter2))))