sicp 2.2.4 画家的完整实现（ex-2.44 ex-2.45 ex-2.46 ex-2.47 ex-2.50 ex-2.51 ）
此代码可以在 Racket v7.0上完整运行，运行结果如下：
代码如下：
#lang scheme/gui (define (frame-coord-map frame) (lambda (v) (add-vect (origin-frame frame) (add-vect (scale-vect (xcor-vect v) (edge1-frame frame)) (scale-vect (ycor-vect v) (edge2-frame frame)))))) (define (make-vect x y) (cons x y)) (define (xcor-vect v) (car v)) (define (ycor-vect v) (cdr v)) (define (add-vect a b) (cons (+ (xcor-vect a) (xcor-vect b)) (+ (ycor-vect a) (ycor-vect b)))) (define (sub-vect a b) (cons (- (xcor-vect a) (xcor-vect b)) (- (ycor-vect a) (ycor-vect b)))) (define (scale-vect s a) (cons (* (xcor-vect a) s) (* (ycor-vect a) s))) (define (make-frame origin edge1 edge2) (list origin edge1 edge2)) (define (origin-frame frame) (car frame)) (define (edge1-frame frame) (car (cdr frame))) (define (edge2-frame frame) (car (cdr (cdr frame)))) ;定义一些画刷 (define no-pen (make-object pen% "BLACK" 1 'transparent)) (define red-pen (make-object pen% "RED" 2 'solid)) (define black-pen (make-object pen% "BLACK" 2 'solid)) (define no-brush (make-object brush% "BLACK" 'transparent)) (define yellow-brush (make-object brush% "YELLOW" 'solid)) (define red-brush (make-object brush% "RED" 'solid)) ;定义图形 (define (draw-face dc) (define (draw-line start end) (define (draw-line-coef coef) (send dc draw-line (* coef (car start)) (* coef (cdr start)) (* coef (car end)) (* coef (cdr end)))) (draw-line-coef 50)) (define (make-segment a b c d) (list (cons (/ a 4.1) (/ b 4.1)) (cons (/ c 4.1) (/ d 4.1)))) (define (start-segment segment) (car segment)) (define (end-segment segment) (car (cdr segment))) (define (segments->painter segment-list) (lambda (frame) (for-each (lambda (segment) (draw-line ((frame-coord-map frame) (start-segment segment)) ((frame-coord-map frame) (end-segment segment)))) segment-list))) (send dc set-smoothing 'smoothed) (send dc set-pen black-pen) #| ((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))) ((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))) ((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))) |# (define (wave frame) ((segments->painter (list (make-segment 0 0.7 0.6 1.7) (make-segment 0.6 1.7 1.2 1.5) (make-segment 1.2 1.5 1.6 1.5) (make-segment 1.6 1.5 1.45 0.6) (make-segment 1.45 0.6 1.6 0) (make-segment 2.45 0 2.65 0.61) (make-segment 2.65 0.61 2.5 1.45) (make-segment 2.5 1.45 3.1 1.5) (make-segment 3.1 1.5 4.1 2.7) (make-segment 0 1.5 0.6 2.5) (make-segment 0.6 2.5 1.2 1.7) (make-segment 1.2 1.7 1.4 2.2) (make-segment 1.4 2.2 1 4.1) (make-segment 1.6 4.1 2.05 3) (make-segment 2.05 3 2.4 4.1) (make-segment 3.2 4.1 2.45 2.35) (make-segment 2.45 2.35 4.1 3.5) )) frame)) #| ((wave) (make-frame (cons 0 0) (cons 1 0) (cons 0 1))) ((wave) (make-frame (cons 5 5) (cons 0 1) (cons 1 0))) ((wave) (make-frame (cons 0 1.0) (cons 1 1) (cons 0 0))) |# (define (transform-painter painter origin corner1 corner2) (lambda (frame) (let ((m (frame-coord-map frame))) (let ((new-origin (m origin))) (painter (make-frame new-origin (sub-vect (m corner1) new-origin) (sub-vect (m corner2) new-origin))))))) (define (flip-vert painter) (transform-painter painter (make-vect 0.0 1.0) (make-vect 1.0 1.0) (make-vect 0.0 0.0))) (define (flip-horiz painter) (transform-painter painter (make-vect 1.0 0.0) (make-vect 0.0 0.0) (make-vect 1.0 1.0))) #| ((flip-vert wave) (make-frame (cons 5 5) (cons 1 0) (cons 0 1))) |# (define (beside left right) (lambda (frame) ((transform-painter left (make-vect 0.0 0.0) (make-vect 0.5 0.0) (make-vect 0.0 1)) frame) ((transform-painter right (make-vect 0.5 0.0) (make-vect 1 0.0) (make-vect 0.5 1)) frame)) ) (define (below left right) (lambda (frame) ((transform-painter right (make-vect 0.0 0.0) (make-vect 1 0.0) (make-vect 0.0 0.5)) frame) ((transform-painter left (make-vect 0.0 0.5) (make-vect 1 0.5) (make-vect 0.0 1)) frame))) (define wave2 (beside wave (flip-vert wave))) (define wave4 (below wave2 wave2)) ;(wave (make-frame (cons 0 0) (cons 1 0) (cons 0 1))) ;(wave2 (make-frame (cons 0 0) (cons 1 0) (cons 0 1))) ;(wave4 (make-frame (cons 5 5) (cons 1 0) (cons 0 1))) (define (right-split painter n) (if (= n 0) painter (let ((smaller (right-split painter (- n 1)))) (beside painter (below smaller smaller))))) ;((right-split wave 4) (make-frame (cons 3 3) (cons 5 0) (cons 0 10))) (define (up-split painter n) (if (= n 0) painter (let ((smaller (up-split painter (- n 1)))) (below painter (beside smaller smaller))))) ;((up-split wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10))) (define (corner-split painter n) (if (= n 0) painter (let ((up (up-split painter (- n 1))) (right (right-split painter (- n 1)))) (let ((top-left (beside up up)) (bottom-right (below right right)) (corner (corner-split painter (- n 1)))) (beside (below painter top-left) (below bottom-right corner)))))) ;((corner-split wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10))) (define (4-corner painter n) (beside (flip-horiz (below (flip-vert (corner-split painter n)) (corner-split painter n))) (below (flip-vert (corner-split painter n)) (corner-split painter n)) )) ;((below-corner wave 4) (make-frame (cons 3 3) (cons 10 0) (cons 0 10))) ((4-corner wave 4) (make-frame (cons 8 4) (cons 8 0) (cons 0 8))) ;((flip-horiz (below-corner wave 4)) (make-frame (cons 10 10) (cons 5 0) (cons 0 5))) ) ;定义一个窗口 (define myWindow (new frame% [label "example window"] [width 300] [height 300])) ;定义一个面板，附着在刚才的窗口上 (define myCanvas (new canvas% [parent myWindow] ;事件处理，Paint回调时将draw-face [paint-callback (lambda (canvas dc) (draw-face dc))])) (send myWindow show #t)
