sicp2.2.4 画家的完整实现

  1 #lang scheme/gui
  2 (define (frame-coord-map frame)
  3   (lambda (v)
  4     (add-vect
  5      (origin-frame frame)
  6      (add-vect (scale-vect (xcor-vect v)
  7                            (edge1-frame frame))
  8                (scale-vect (ycor-vect v)
  9                            (edge2-frame frame))))))
 10 
 11 (define (make-vect x y)
 12   (cons  x y))
 13 (define (xcor-vect v)
 14   (car v))
 15 (define (ycor-vect v)
 16   (cdr v))
 17 (define (add-vect a b)
 18   (cons (+ (xcor-vect a) (xcor-vect b)) (+ (ycor-vect a) (ycor-vect b))))
 19 (define (sub-vect a b)
 20   (cons (- (xcor-vect a) (xcor-vect b)) (- (ycor-vect a) (ycor-vect b))))
 21 (define (scale-vect s a)
 22   (cons (* (xcor-vect a) s) (* (ycor-vect a) s)))
 23 (define (make-frame origin edge1 edge2)
 24   (list origin edge1 edge2))
 25 (define (origin-frame frame)
 26   (car frame))
 27 (define (edge1-frame frame)
 28   (car (cdr frame)))
 29 (define (edge2-frame frame)
 30   (car (cdr (cdr frame))))
 31 
 32 ;定义一些画刷
 33 (define no-pen (make-object pen% "BLACK" 1 ‘transparent))
 34 (define red-pen (make-object pen% "RED" 2 ‘solid))
 35 (define black-pen (make-object pen% "BLACK" 2 ‘solid))
 36 (define no-brush (make-object brush% "BLACK" ‘transparent))
 37 (define yellow-brush (make-object brush% "YELLOW" ‘solid))
 38 (define red-brush (make-object brush% "RED" ‘solid))
 39 
 40 ;定义图形
 41 (define (draw-face dc)
 42   (define (draw-line start end)
 43     (define (draw-line-coef coef)
 44     (send dc draw-line (* coef (car start))  (* coef (cdr  start)) (* coef (car end)) (* coef (cdr end))))
 45     (draw-line-coef 50))
 46   (define (make-segment a b c d)
 47     (list (cons (/ a 4.1) (/ b 4.1)) (cons (/ c 4.1) (/ d 4.1))))
 48   (define (start-segment segment)
 49     (car segment))
 50   (define (end-segment segment)
 51     (car (cdr segment)))
 52   
 53   (define (segments->painter segment-list)
 54     (lambda (frame)
 55       (for-each
 56        (lambda (segment)
 57          (draw-line
 58           ((frame-coord-map frame) (start-segment segment))
 59           ((frame-coord-map frame) (end-segment segment))))
 60        segment-list)))
 61   
 62   (send dc set-smoothing ‘smoothed)
 63   (send dc set-pen black-pen)
 64   #|
 65   ((segments->painter (list (make-segment 0 0 1 0) (make-segment 1 0 1 1) (make-segment 1 1 0 1) (make-segment 0 1 0 0))) (make-frame (cons 1 1) (cons 1 0) (cons 0 1)))
 66   ((segments->painter (list (make-segment 0 0 1 1) (make-segment 1 0 0 1) )) (make-frame (cons 1 1) (cons 1 0) (cons 0 1)))
 67   ((segments->painter (list (make-segment 0 0.5 0.5 0) (make-segment 0.5 0 1 0.5) (make-segment 1 0.5 0.5 1) (make-segment 0.5 1 0 0.5))) (make-frame (cons 1 1) (cons 1 0) (cons 0 1)))
 68 |#
 69   
 70     (define (wave frame)
 71       ((segments->painter (list
 72                        (make-segment 0     0.7   0.6    1.7)
 73                        (make-segment 0.6   1.7   1.2    1.5)
 74                        (make-segment 1.2   1.5   1.6    1.5)
 75                        (make-segment 1.6   1.5   1.45   0.6)                       
 76                        (make-segment 1.45  0.6   1.6  0)
 77                        
 78                        (make-segment 2.45  0     2.65    0.61)
 79                        (make-segment 2.65  0.61  2.5    1.45)
 80                        (make-segment 2.5   1.45   3.1    1.5)                       
 81                        (make-segment 3.1   1.5   4.1     2.7)
 82                        
 83                        (make-segment 0     1.5     0.6    2.5)
 84                        (make-segment 0.6    2.5   1.2     1.7)
 85                        (make-segment 1.2     1.7   1.4    2.2)
 86                        (make-segment 1.4    2.2   1   4.1)
 87                        
 88                        (make-segment 1.6   4.1     2.05   3)
 89                        (make-segment 2.05   3     2.4   4.1)
 90                        
 91                        (make-segment 3.2   4.1     2.45     2.35)
 92                        (make-segment 2.45     2.35   4.1    3.5)
 93                        )) frame))
 94     #|
 95     ((wave) (make-frame (cons 0 0) (cons 1 0) (cons 0 1)))
 96     ((wave) (make-frame (cons 5 5) (cons 0 1) (cons 1 0)))
 97 ((wave) (make-frame (cons 0 1.0) (cons 1 1) (cons 0 0)))
 98 |#
 99     
100     (define (transform-painter painter origin corner1 corner2)
101       (lambda (frame)
102         (let ((m (frame-coord-map frame)))
103           (let ((new-origin (m origin)))
104             (painter
105              (make-frame new-origin
106                          (sub-vect (m corner1) new-origin)
107                          (sub-vect (m corner2) new-origin)))))))
108     (define (flip-vert painter)
109       (transform-painter painter
110                          (make-vect 0.0 1.0)
111                          (make-vect 1.0 1.0)
112                          (make-vect 0.0 0.0)))
113   (define (flip-horiz painter)
114       (transform-painter painter
115                          (make-vect 1.0 0.0)
116                          (make-vect 0.0 0.0)
117                          (make-vect 1.0 1.0)))
118     #|
119     ((flip-vert wave) (make-frame (cons 5 5) (cons 1 0) (cons 0 1)))
120 |#
121   
122   
123   (define (beside left right)
124     (lambda (frame)
125       ((transform-painter left
126                           (make-vect 0.0 0.0)
127                           (make-vect 0.5 0.0)
128                           (make-vect 0.0 1)) frame)
129       ((transform-painter right
130                           (make-vect 0.5 0.0)
131                           (make-vect 1 0.0)
132                           (make-vect 0.5 1)) frame))
133     )
134   (define (below left right)
135     (lambda (frame)
136       ((transform-painter right
137                           (make-vect 0.0 0.0)
138                           (make-vect 1 0.0)
139                           (make-vect 0.0 0.5)) frame)
140       ((transform-painter left
141                           (make-vect 0.0 0.5)
142                           (make-vect 1 0.5)
143                           (make-vect 0.0 1)) frame)))
144 
145   (define wave2 (beside wave (flip-vert wave)))
146   (define wave4 (below wave2 wave2))
147   ;(wave (make-frame (cons 0 0) (cons 1 0) (cons 0 1)))
148   ;(wave2 (make-frame (cons 0 0) (cons 1 0) (cons 0 1)))
149   ;(wave4 (make-frame (cons 5 5) (cons 1 0) (cons 0 1)))
150   
151   (define (right-split painter n)
152     (if (= n 0)
153         painter
154         (let ((smaller (right-split painter (- n 1))))
155           (beside painter (below smaller smaller)))))
156   ;((right-split wave 4) (make-frame (cons 3 3) (cons 5 0) (cons 0 10)))
157 
158   
159   (define (up-split painter n)
160     (if (= n 0)
161         painter
162         (let ((smaller (up-split painter (- n 1))))
163           (below painter (beside smaller smaller)))))
164   ;((up-split wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10)))
165   
166   (define (corner-split painter n)
167     (if (= n 0)
168         painter
169         (let ((up (up-split painter (- n 1)))
170               (right (right-split painter (- n 1))))
171           (let ((top-left (beside up up))
172                 (bottom-right (below right right))
173                 (corner (corner-split painter (- n 1))))
174             (beside (below painter top-left)
175                     (below bottom-right corner))))))
176   
177   ;((corner-split wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10)))
178   (define (4-corner painter n)
179     (beside
180       (flip-horiz (below
181        (flip-vert (corner-split painter n))
182        (corner-split painter n)))
183      (below
184       (flip-vert (corner-split painter n))
185       (corner-split painter n))
186       ))
187   ;((below-corner wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10)))
188     ((4-corner wave 4) (make-frame (cons 8 4) (cons 8 0) (cons 0 8)))
189   ;((flip-horiz (below-corner wave 4)) (make-frame (cons 10 10) (cons 5 0) (cons 0 5)))
190 
191   )
192 
193 ;定义一个窗口
194 (define myWindow (new frame% [label "example window"] 
195                    [width 300] [height 300]))
196 
197 ;定义一个面板，附着在刚才的窗口上
198 (define myCanvas (new canvas% 
199                       [parent myWindow]
200                       ;事件处理，Paint回调时将draw-face
201                       [paint-callback (lambda (canvas dc) (draw-face dc))]))
202 
203 (send myWindow show #t)
204