blob: 601d17c0961213c83a3a4a71179172e6eb879edd (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
|
;;;; License: CC0-1.0
#lang racket
(require racket/draw)
(require racket/snip)
(require "46.rkt")
(require "47.rkt")
(require "48.rkt")
(define dc #f) ; drawing context. gets initialized by paint function.
(define (draw-line v1 v2)
(let ((x1 (xcor-vect v1))
(y1 (ycor-vect v1))
(x2 (xcor-vect v2))
(y2 (ycor-vect v2)))
(send dc draw-line x1 y1 x2 y2)))
(define (paint painter)
(let ((frame (make-frame (make-vect 250 250)
(make-vect 500 0)
(make-vect 0 500)))
(target (make-bitmap 1000 1000)))
(set! dc (new bitmap-dc% (bitmap target)))
(painter frame)
(make-object image-snip% target)))
(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 (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)))
(define (outline->painter)
(let ((v-tl (make-vect 0 0)) ; top left
(v-tr (make-vect 1 0)) ; top right
(v-br (make-vect 1 1)) ; bottom right
(v-bl (make-vect 0 1))) ; bottom left
(segments->painter
(list (make-segment v-tl v-tr)
(make-segment v-tr v-br)
(make-segment v-br v-bl)
(make-segment v-bl v-tl)))))
(define (x->painter)
(let ((v-tl (make-vect 0 0)) ; top left
(v-tr (make-vect 1 0)) ; top right
(v-br (make-vect 1 1)) ; bottom right
(v-bl (make-vect 0 1))) ; bottom left
(segments->painter
(list (make-segment v-tl v-br)
(make-segment v-tr v-bl)))))
(define (diamond->painter)
(let ((v-mt (make-vect 0.5 0)) ; midpoint top
(v-mr (make-vect 1 0.5)) ; midpoint right
(v-mb (make-vect 0.5 1)) ; midpoint bottom
(v-ml (make-vect 0 0.5))) ; midpoint left
(segments->painter
(list (make-segment v-mt v-mr)
(make-segment v-mr v-mb)
(make-segment v-mb v-ml)
(make-segment v-ml v-mt)))))
(define (wave->painter)
(let* ((h-ls (make-vect 0.426 0.000)) ; head - left start
(h-le (make-vect 0.349 0.164)) ; head - left end
(h-rs (make-vect 0.505 0.000)) ; head - right start
(h-re (make-vect 0.577 0.165)) ; head - right end
(n-le (make-vect 0.434 0.287)) ; neck - left end
(n-re (make-vect 0.499 0.283)) ; neck - right end
(sh-le (make-vect 0.302 0.288)) ; shoulder - left end
(sh-re (make-vect 0.620 0.290)) ; shoulder - right end
(lh-ts (make-vect 0.000 0.200)) ; left hand - top start
(lh-te (make-vect 0.257 0.400)) ; left hand - top end
(lh-bs (make-vect 0.000 0.316)) ; left hand - bottom start
(lh-be (make-vect 0.296 0.533)) ; left hand - bottom end
(uat-ls sh-le) ; upper arm top - left start
(uat-le lh-te) ; upper arm top - left end
(uab-ls (make-vect 0.398 0.371)) ; upper arm bottom - left end
(uab-le lh-be) ; upper arm bottom - left end
(uat-rs sh-re) ; upper arm top - right start
(uat-re (make-vect 1.000 0.550)) ; upper arm top - right end
(uab-rs (make-vect 1.000 0.660)) ; upper arm bottom - right start
(uab-re (make-vect 0.563 0.376)) ; upper arm bottom - right end
(wll-os uab-ls) ; waist left leg - outside start
(wll-oe (make-vect 0.290 1.000)) ; waist left leg - outside end
(wll-is (make-vect 0.490 0.642)) ; waist left leg - inside start
(wll-ie (make-vect 0.384 1.000)) ; waist left leg - inside end
(wrl-os uab-re) ; waist right leg - outside start
(wrl-oe (make-vect 0.730 1.000)) ; waist right leg - outside end
(wrl-is wll-is) ; waist right leg - inside start
(wrl-ie (make-vect 0.650 1.000))) ; waist right leg - inside end
(segments->painter
(list
;; head
(make-segment h-ls h-le)
(make-segment h-rs h-re)
(make-segment h-le n-le)
(make-segment h-re n-re)
;; neck
(make-segment n-le sh-le)
(make-segment n-re sh-re)
;; left hand
(make-segment lh-ts lh-te)
(make-segment lh-bs lh-be)
;; upper arm left
(make-segment uat-ls uat-le)
(make-segment uab-ls uab-le)
;; upper arm right
(make-segment uat-rs uat-re)
(make-segment uab-rs uab-re)
;; waist - legs
(make-segment wll-os wll-oe)
(make-segment wll-is wll-ie)
(make-segment wrl-os wrl-oe)
(make-segment wrl-is wrl-ie)))))
;;; https://ricketyspace.net/sicp/2.49.webm
|
