sicp2.2.4 画家的完整实现
Posted plumnut
tags:
篇首语：本文由小常识网(cha138.com)小编为大家整理，主要介绍了sicp2.2.4 画家的完整实现相关的知识，希望对你有一定的参考价值。
此代码可以在 Racket v7.0上完整允许，运行结果如下：
代码如下：
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
以上是关于sicp2.2.4 画家的完整实现的主要内容，如果未能解决你的问题，请参考以下文章
VSCode自定义代码片段15——git命令操作一个完整流程