SICP_2.48-2.49 

 1 #lang sicp
 2 
 3 (#%require sicp-pict)
 4 
 5 (define (make-vect a b)
 6   (cons a b))
 7 
 8 (define (xcor-vect v)
 9   (car v))
10 
11 (define (ycor-vect v)
12   (cdr v))
13 
14 (define (add-vect v1 v2)
15   (make-vect (+ (xcor-vect v1)
16                 (xcor-vect v2))
17              (+ (ycor-vect v1)
18                 (ycor-vect v2))))
19 
20 (define (sub-vect v1 v2)
21   (make-vect (- (xcor-vect v1)
22                 (xcor-vect v2))
23              (- (ycor-vect v1)
24                 (ycor-vect v2))))
25 
26 (define (scale-vect s v1)
27   (make-vect (* s (xcor-vect v1))
28              (* s (ycor-vect v1))))
29 
30 ;;;;;;;;;;;;;;;;;;;2.48
31 (define (make-segment start end)
32   (make-vect start end))
33 
34 (define (start-segment segment)
35   (car segment))
36 
37 (define (end-segment segment)
38   (cdr segment))
39 
40 ;;;;;;;;;;;;;;;;;;;2.49
41 (define (segment->painter segment-list)
42   (lambda (frame)
43     (for-each
44      (lambda (segment)
45        (draw-line
46         ((frame-coord-map frame) (start-segment segment))
47         ((frame-coord-map frame) (end-segment segmnet))))
48      segment-list)))
49 
50 (define top-left (make-vect 0.0 1.0))
51 (define top-right (make-vect 1.0 1.0))
52 (define bottom-left (make-vect 0.0 0.0))
53 (define bottom-right (make-vect 1.0 0.0))
54 
55 (define top (make-segment top-left top-right))
56 (define left (make-segment top-left bottom-left))
57 (define right (make-segment top-right bottom-right))
58 (define bottom (make-segment bottom-left bottom-right))
59 
60 (segment->painter (list top bottom left right))
61 
62 ;;;下同

 

 

posted @ 2017-02-21 23:44  lan126  阅读(285)  评论(0)  编辑  收藏  举报