SICP学习笔记 （2.2.4）

                                                            SICP学习笔记 （2.2.4）
                                                                    周银辉

1，Scheme的GUI编程

很幸运的是，PLT scheme提供了GUI库，叫做“MrEd”，在DrScheme中可以直接使用，但需要在IDE的左下角将语言选择为Module，并且在代码开始处加上#lang scheme/gui，具体的语法信息可以参考这里：http://docs.plt-scheme.org/gui/index.html

 下面这段代码，画了一个小头像

#lang scheme/gui

;定义一些画刷
(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)
  (send dc set-smoothing 'smoothed)
  (send dc set-pen black-pen)
  (send dc set-brush no-brush)
  (send dc draw-ellipse 50 50 100 100)
  (send dc set-brush yellow-brush)
  (send dc draw-line 70 100 90 100)
  (send dc draw-ellipse 50 90 20 20)
  (send dc draw-ellipse 90 90 20 20)
  (send dc set-brush no-brush)
  (send dc set-pen red-pen)
  (let ([-pi (atan 0 -1)])
    (send dc draw-arc 50 60 60 80 (* 3/2 -pi) (* 7/4 -pi))))

;定义一个窗口
(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)

 

2，向量和向量操作

我这里用List来定义的向量，其实也可以用cons以及其他任何可行的方式，但都比较简单：

(define (make-vect x y) (list x y))

(define (xcor-vect v) (car v))

(define (ycor-vect v) (cadr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
             (+ (ycor-vect v1) (ycor-vect v2))))

(define (sub-vect v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2))
             (- (ycor-vect v1) (ycor-vect v2))))

(define (scale-vect s v)
  (make-vect (* s (xcor-vect v))
             (* s (ycor-vect v))))

(define (length v)
  (sqrt (+ (* (xcor-vect v) (xcor-vect v))  (* (ycor-vect v) (ycor-vect v)))))

(define (sinθ v)
  (/ (ycor-vect v) (length v)))

(define (cosθ v)
  (/ (xcor-vect v) (length v)))

(define (rotation-vect v θ)
  (let ((x (xcor-vect v))
        (y (ycor-vect v)))
    (make-vect (- (* x (cos θ)) (* y (sin θ)))
               (+ (* x (sin θ)) (* y (cos θ))))))

 其中length是求向量的长度， sinθ和cosθ是求向量与x轴夹角的正弦与余弦值。 rotation-vect将向量绕X轴旋转θ度（弧度）

3， 定义Frame

(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define (origin-frame f)
  (car f))

(define (edge1-frame f)
  (cadr f))

(define (edge2-frame f)
  (caddr f))


(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))))))

我这里只采用的List的方式来定义，练习2.47中要求用list和cons两种方式，cons方式这里就不给出了，依葫芦画瓢即可

4，定义线段

(define (make-segment v-start v-end)
  (cons v-start v-end))

(define (start-segment seg)
  (car seg))

(define (end-segment seg)
  (cdr seg))

(define (draw-segment dc seg)
  (let ((v-start (start-segment seg))
        (v-end (end-segment seg)))
    (send dc draw-line
      (xcor-vect v-start)
      (ycor-vect v-start)
      (xcor-vect v-end)
      (ycor-vect v-end))))

其中draw-segment 方法是关键，其用一个指定的dc来绘制线段，由于MrEd中绘制线段时要求传入的是x1 y1 x2 y2四个数值而非点坐标，所以上稍稍转换了一下

5，绘制线段列表

(define (segments->painter dc segment-list)
  (lambda (frame)
    (for-each
      (lambda (segment)
        (let ((new-start-segment ((frame-coord-map frame) (start-segment segment)))
              (new-end-segment ((frame-coord-map frame) (end-segment segment))))
        (draw-segment
          dc
          (make-segment new-start-segment new-end-segment))))
      segment-list)))

一个for-each语句就可以搞定了，但需要注意的是这里将frame拉了进来，所以在调用draw-segment时传入的点坐标必须是经过frame映射之后的，也就是我们上面的new-start-segment 和 new-end-segment

6，一个简单的实例

经过上面5点的预备知识，我们现在便可以定义一个线段列表来绘制一个由线段组成的图形了，下面是一个简单的示例代码：

#lang scheme/gui

;---------------vector---------------------------
(define (make-vect x y) (list x y))

(define (xcor-vect v) (car v))

(define (ycor-vect v) (cadr v))

(define (add-vect v1 v2)
  (make-vect (+ (xcor-vect v1) (xcor-vect v2))
             (+ (ycor-vect v1) (ycor-vect v2))))

(define (sub-vect v1 v2)
  (make-vect (- (xcor-vect v1) (xcor-vect v2))
             (- (ycor-vect v1) (ycor-vect v2))))

(define (scale-vect s v)
  (make-vect (* s (xcor-vect v))
             (* s (ycor-vect v))))

(define (length v)
  (sqrt (+ (* (xcor-vect v) (xcor-vect v))  (* (ycor-vect v) (ycor-vect v)))))

(define (sinθ v)
  (/ (ycor-vect v) (length v)))

(define (cosθ v)
  (/ (xcor-vect v) (length v)))

(define (rotation-vect v θ)
  (let ((x (xcor-vect v))
        (y (ycor-vect v)))
    (make-vect (- (* x (cos θ)) (* y (sin θ)))
               (+ (* x (sin θ)) (* y (cos θ))))))

;---------------Frame---------------------------
(define (make-frame origin edge1 edge2)
  (list origin edge1 edge2))

(define (origin-frame f)
  (car f))

(define (edge1-frame f)
  (cadr f))

(define (edge2-frame f)
  (caddr f))

(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))))))

;---------------segment---------------------------

(define (make-segment v-start v-end)
  (cons v-start v-end))

(define (start-segment seg)
  (car seg))

(define (end-segment seg)
  (cdr seg))

(define (draw-segment dc seg)
  (let ((v-start (start-segment seg))
        (v-end (end-segment seg)))
    (send dc draw-line
      (xcor-vect v-start)
      (ycor-vect v-start)
      (xcor-vect v-end)
      (ycor-vect v-end))))

(define (segments->painter dc segment-list)
  (lambda (frame)
    (for-each
      (lambda (segment)
        (let ((new-start-segment ((frame-coord-map frame) (start-segment segment)))
              (new-end-segment ((frame-coord-map frame) (end-segment segment))))
        (draw-segment
          dc
          (make-segment new-start-segment new-end-segment))))
      segment-list)))

;---------------------------------------------------------

(define red-pen (instantiate pen% ("RED" 2 'solid)))

;一个线段列表  -_-!
(define mySegmentList
  (list
    (make-segment
      (make-vect 0.1 0.4)
      (make-vect 0.3 0.4))
    (make-segment
      (make-vect 0.5 0.4)
      (make-vect 0.7 0.4))
    (make-segment
      (make-vect 0.3 0.6)
      (make-vect 0.5 0.6))
    (make-segment
      (make-vect 0.8 0.3)
      (make-vect 0.8 0.55))
    (make-segment
      (make-vect 0.78 0.6)
      (make-vect 0.80 0.6))
    (make-segment
      (make-vect 0.9 0.3)
      (make-vect 0.9 0.55))
    (make-segment
      (make-vect 0.88 0.6)
      (make-vect 0.90 0.6))))

;定义我们的Frame
(define myFrame
  (make-frame
    (make-vect 0 0)
    (make-vect 200 0)
    (make-vect 0 200)))

;定义一个窗口
(define myWindow (new frame% [label "example window"]
                   [width 300] [height 300]))

;定义一个面板，附着在刚才的窗口上
(define myCanvas (new canvas%
                      [parent myWindow]
                      ;事件回调    
                      [paint-callback (lambda (canvas dc)
                                        (begin
                                          (send dc set-pen red-pen)
                                          ( (segments->painter dc mySegmentList) myFrame)))]))

(send myWindow show #t)

运行效果如下：

 

7，beside 和 below

其实在SICP本节的最后是给了beside方法的（below被留成了练习2.51），但它们都是基于transform-painter方法的，在学会transform-painter 方法之前，我们还是有办法做到了，运用一点三角函数的知识就可以了(准备一张草稿纸，画画直角坐标系和三角函数)：

(define (beside painter1 painter2)
  (lambda (frame)
    (let ((f1 (make-frame
               (origin-frame frame)
               (make-vect
                (* (/ (length (edge1-frame frame)) 2.0) (cosθ (edge1-frame frame)))
                (* (/ (length (edge1-frame frame)) 2.0) (sinθ (edge1-frame frame))))
               (edge2-frame frame )))
          (f2 (make-frame
               (make-vect
                (* (/ (length (edge1-frame frame)) 2.0) (cosθ (edge1-frame frame)))
                (* (/ (length (edge1-frame frame)) 2.0) (sinθ (edge1-frame frame))))
               (make-vect (/ (xcor-vect(edge1-frame frame)) 2.0) (/ (ycor-vect(edge1-frame frame)) 2.0))
               (edge2-frame frame ))))
      (painter1 f1)
      (painter2 f2))))

(define (below painter1 painter2)
  (lambda (frame)
    (let ((f1 (make-frame
               (origin-frame frame)              
               (edge1-frame frame )
               (make-vect
                (* (/ (length (edge2-frame frame)) 2.0) (cosθ (edge2-frame frame)))
                (* (/ (length (edge2-frame frame)) 2.0) (sinθ (edge2-frame frame))))))
          (f2 (make-frame
               (make-vect
                (* (/ (length (edge2-frame frame)) 2.0) (cosθ (edge2-frame frame)))
                (* (/ (length (edge2-frame frame)) 2.0) (sinθ (edge2-frame frame))))
               (edge1-frame frame )
               (make-vect (/ (xcor-vect(edge2-frame frame)) 2.0) (/ (ycor-vect(edge2-frame frame)) 2.0)))))
      (painter1 f1)
      (painter2 f2))))

 上面的代码有不少语句是重复的，你可以用let变量重构一下，然后看看我们的below效果：

 

8，练习2.45

(define (split combine-main combine-smaller)
  (lambda (painter n)
    (if (zero? n)
      painter
      (let ((smaller ((split combine-main combine-smaller) painter (- n 1))))
        (combine-main
          painter
          (combine-smaller smaller smaller))))))

9，练习2.46，2.47，2.48，2.49

2.46、2.47、2.48 前面已经给出答案了哈，copy 一下吧。2.49的直接略掉

10，练习2.50

(define (rotate90 painter)
  (transform-painter
    painter
    (make-vect 0.0 1.0)     ; new origin
    (make-vect 0.0 0.0)     ; new end of edge1
    (make-vect 1.0 1.0)))   ; new end of edge2

(define (rotate180 painter)
  (transform-painter
    painter
    (make-vect 1.0 1.0)
    (make-vect 0.0 1.0)
    (make-vect 1.0 0.0)))

(define (rotate270 painter)
  (transform-painter
    painter
    (make-vect 1.0 0.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)))

11，练习2.51

(define (below painter1 painter2)
  (let ( (split-point (make-vect 0.0 0.5))
          (paint-up
            (transform-painter
              painter2
              (make-vect 0.0 0.0)
              (make-vect 1.0 0.0)
              split-point))
          (paint-down
            (transform-painter
              painter1
              split-point
              (make-vect 1.0 0.5)
              (make-vect 0.0 1.0))))
    (lambda (frame)
      (paint-up frame)
      (paint-down frame))))

12，练习2.52

(define (corner-split painter n)
  (if (zero? n)
    painter
    (let ( (up (up-split painter (- n 1)))
            (right (right-split painter (- n 1)))
            (top-left up)
            (bottom-right right)
            (corner (corner-split painter (- n 1))))
      (beside (below painter top-left)
              (below bottom-right corner)))))

13，Functional Geometry

本节中所有的这些图形变换统称为“Functional Geometry ”，有专门的站点介绍这个: http://www.frank-buss.de/lisp/functional.html 
完整的代码在这里：

;;; Functional Geometry
;;;
;;; Original idea by Peter Henderson, see
;;; http://www.ecs.soton.ac.uk/~ph/funcgeo.pdf
;;; and http://www.ecs.soton.ac.uk/~ph/papers/funcgeo2.pdf
;;;
;;; Implemented in Lisp by Frank Bu?
;;;
;;; call it with (plot *fishes*)

;;;
;;; the framework
;;;

(defun p* (vector m)
  "vector scalar multiplication"
  (destructuring-bind (vx vy) vector
    (list (* vx m) (* vy m))))

(defun p/ (vector d)
  "vector scalar division"
  (destructuring-bind (vx vy) vector
    (list (/ vx d) (/ vy d))))

(defun p+ (&rest vectors)
  "#'+ for vectors"
  (case (length vectors)
    (0 '(0 0))
    (1 (car vectors))
    (otherwise (flet ((p+p (v1 v2)
                        (destructuring-bind (vx0 vy0) v1 
                          (destructuring-bind (vx1 vy1) v2
                            (list (+ vx0 vx1) (+ vy0 vy1))))))
                 (reduce #'p+p vectors)))))

(defun p- (&rest vectors)
  "#'- for vectors"
  (case (length vectors)
    (0 '(0 0))
    (1 (p* (car vectors) -1))
    (otherwise (flet ((p-p (v1 v2)
                        (destructuring-bind (vx0 vy0) v1
                          (destructuring-bind (vx1 vy1) v2
                            (list (- vx0 vx1) (- vy0 vy1))))))
                 (reduce #'p-p vectors)))))

(defun grid (m n s)
  "defines a picture from lines in a grid"
  (lambda (a b c)
    (loop for line in s collect
          (destructuring-bind ((x0 y0) (x1 y1)) line
            (list (p+ (p/ (p* b x0) m) a (p/ (p* c y0) n))
                  (p+ (p/ (p* b x1) m) a (p/ (p* c y1) n)))))))

(defun polygon (points)
  "converts the points, which specifies a polygon, in a list of lines"
  (let ((start (car (last points))))
    (loop for point in points collect
          (list start point)
          do (setf start point))))

(defun blank ()
  "a blank picture"
  (lambda (a b c)
    (declare (ignore a b c))
    '()))

(defun beside (p q)
  "returns picture p besides picture q"
  (lambda (a b c)
    (let ((b-half (p/ b 2)))
      (union (funcall p a b-half c)
             (funcall q (p+ a b-half) b-half c)))))

(defun above (p q)
  "returns picture q above picture p"
  (lambda (a b c)
    (let ((c-half (p/ c 2)))
      (union (funcall p (p+ a c-half) b c-half)
             (funcall q a b c-half)))))

(defun rot (p)
  "returns picture p rotated by 90 degree"
  (lambda (a b c)
    (funcall p (p+ a b) c (p- b))))

(defun quartet (p1 p2 p3 p4)
  "returns the pictures p1-p4, layouted in a square"
  (above (beside p1 p2) (beside p3 p4)))

(defun cycle (p)
  "returns four times the p, layouted in a square and rotated"
  (quartet p (rot (rot (rot p))) (rot p) (rot (rot p))))

(defun plot (p)
  " saves a picture as postscript and shows it"
  (with-open-file (s "c:/tmp/test.ps" 
                     :direction :output :if-exists :supersede)
    (format s "500 500 scale~%")
    (format s ".1 .1 translate~%")
    (format s "0 setlinewidth~%")
    (format s "0 0 moveto 1 0 lineto 1 1 lineto 0 1 lineto 0 0 lineto~%")
    (dolist (line (funcall p '(0 0) '(1 0) '(0 1)))
      (destructuring-bind ((x0 y0) (x1 y1)) line
        (format s "~D ~D moveto ~D ~D lineto~%" (float x0) (float y0) (float x1) (float y1))))
    (format s "stroke~%")
    (format s "showpage~%"))
  (sys:call-system "c:/gs/gs7.05/bin/gswin32.exe -g800x800 c:/tmp/test.ps"))


;;;
;;; a simple test
;;;

;; defines a man
(defparameter *man* 
  (grid 14 20 
        (polygon 
         '((6 10) (0 10) (0 12) (6 12) (6 14)
           (4 16) (4 18) (6 20) (8 20) (10 18)
           (10 16) (8 14) (8 12) (10 12) (10 14)
           (12 14) (12 10) (8 10) (8 8) (10 0)
           (8 0) (7 4) (6 0) (4 0) (6 8)))))

;; demonstrates beside
(defparameter *man-beside-man* (beside *man* *man*))

;; demonstrates above
(defparameter *man-above-man* (above *man* *man*))

;; demonstrates rot
(defparameter *man-rotated* (rot *man*))

;; demonstrates quartet
(defparameter *man-quartet* (quartet *man* *man* *man* *man*))

;; demonstrates cycle
(defparameter *man-cycle* (cycle *man*))


;;;
;;; the fish
;;;

;; defines part p of the fish
(defparameter *p* 
  (grid 16 16 
        '(((4 4) (6 0)) ((0 3)(3 4)) ((3 4)(0 8))
          ((0 8)(0 3)) ((4 5)(7 6)) ((7 6)(4 10))
          ((4 10)(4 5)) ((11 0)(10 4)) ((10 4)(8 8))
          ((8 8)(4 13)) ((4 13)(0 16)) ((11 0)(14 2))
          ((14 2)(16 2)) ((10 4)(13 5)) ((13 5)(16 4))
          ((9 6)(12 7)) ((12 7)(16 6)) ((8 8)(12 9))
          ((12 9)(16 8)) ((8 12)(16 10)) ((0 16)(6 15))
          ((6 15)(8 16)) ((8 16)(12 12)) ((12 12)(16 12))
          ((10 16)(12 14)) ((12 14)(16 13)) ((12 16)(13 15))
          ((13 15)(16 14)) ((14 16)(16 15)))))

;; defines part q of the fish
(defparameter *q*
  (grid 16 16 
        '(((2 0)(4 5)) ((4 5)(4 7)) ((4 0)(6 5))
          ((6 5)(6 7)) ((6 0)(8 5)) ((8 5)(8 8))
          ((8 0)(10 6)) ((10 6)(10 9)) ((10 0)(14 11))
          ((12 0)(13 4)) ((13 4)(16 8)) ((16 8)(15 10))
          ((15 10)(16 16)) ((16 16)(12 10)) ((12 10)(6 7))
          ((6 7)(4 7)) ((4 7)(0 8)) ((13 0)(16 6))
          ((14 0)(16 4)) ((15 0)(16 2)) ((0 10)(7 11))
          ((9 12)(10 10)) ((10 10)(12 12)) ((12 12)(9 12))
          ((8 15)(9 13)) ((9 13)(11 15)) ((11 15)(8 15))
          ((0 12)(3 13)) ((3 13)(7 15)) ((7 15)(8 16))
          ((2 16)(3 13)) ((4 16)(5 14)) ((6 16)(7 15)))))

;; defines part r of the fish
(defparameter *r*
  (grid 16 16 
        '(((0 12)(1 14)) ((0 8)(2 12)) ((0 4)(5 10))
          ((0 0)(8 8)) ((1 1)(4 0)) ((2 2)(8 0))
          ((3 3)(8 2)) ((8 2)(12 0)) ((5 5)(12 3))
          ((12 3)(16 0)) ((0 16)(2 12)) ((2 12)(8 8))
          ((8 8)(14 6)) ((14 6)(16 4)) ((6 16)(11 10))
          ((11 10)(16 6)) ((11 16)(12 12)) ((12 12)(16 8))
          ((12 12)(16 16)) ((13 13)(16 10)) ((14 14)(16 12))
          ((15 15)(16 14)))))

;; defines part s of the fish
(defparameter *s* 
  (grid 16 16 
        '(((0 0)(4 2)) ((4 2)(8 2)) ((8 2)(16 0))
          ((0 4)(2 1)) ((0 6)(7 4)) ((0 8)(8 6))
          ((0 10)(7 8)) ((0 12)(7 10)) ((0 14)(7 13))
          ((8 16)(7 13)) ((7 13)(7 8)) ((7 8)(8 6))
          ((8 6)(10 4)) ((10 4)(16 0)) ((10 16)(11 10))
          ((10 6)(12 4)) ((12 4)(12 7)) ((12 7)(10 6))
          ((13 7)(15 5)) ((15 5)(15 8)) ((15 8)(13 7))
          ((12 16)(13 13)) ((13 13)(15 9)) ((15 9)(16 8))
          ((13 13)(16 14)) ((14 11)(16 12)) ((15 9)(16 10)))))

;; builds the fishes drawing

(defparameter *t*
  (quartet *p* *q* *r* *s*))

(defparameter *u*
  (cycle (rot *q*)))

(defparameter *side1*
  (quartet (blank) (blank) (rot *t*) *t*))

(defparameter *side2*
  (quartet *side1* *side1* (rot *t*) *t*))

(defparameter *corner1*
  (quartet (blank) (blank) (blank) *u*))

(defparameter *corner2*
  (quartet *corner1* *side1* (rot *side1*) *u*))

(defparameter *pseudocorner* 
  (quartet *corner2* *side2* (rot *side2*) (rot *t*)))

(defparameter *fishes*
  (cycle *pseudocorner*))

 

注：这是一篇读书笔记，所以其中的内容仅 属个人理解而不代表SICP的观点，并随着理解的深入其中 的内容可能会被修改