blob: f98364e4b70318ea770a4e3c0169501df371da92 (
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
|
;;;; 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)))))
|
