-
Notifications
You must be signed in to change notification settings - Fork 0
/
functional-geometry.rkt
174 lines (144 loc) · 5.57 KB
/
functional-geometry.rkt
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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
#lang racket
(require racket/draw)
(require racket/gui)
;; vector constructor/selectors
(define (make-vect x y) (cons x y))
(define (xcor-vect v) (car v))
(define (ycor-vect v) (cdr v))
;; vector operations
(define (transpose v)
(make-vect (ycor-vect v) (xcor-vect v)))
(define (add-vect v w)
(make-vect (+ (xcor-vect v) (xcor-vect w))
(+ (ycor-vect v) (ycor-vect w))))
(define (sub-vect v w)
(make-vect (- (xcor-vect v) (xcor-vect w))
(- (ycor-vect v) (ycor-vect w))))
(define (scale-vect v s)
(make-vect (* s (xcor-vect v))
(* s (ycor-vect v))))
;; vector blocks
(define i-hat (make-vect 1 0))
(define j-hat (transpose i-hat))
(define origin-vect (make-vect 0 0))
(define diag-vect (make-vect 1 1))
(define split-vect (make-vect 0.5 0))
;; segment constructor/selectors
(define (make-segment x y) (cons x y))
(define (start-segment s) (car s))
(define (end-segment s) (cdr s))
;; frame constructor/selectors
(define (make-frame orig e1 e2 dc)
(list orig e1 e2 dc))
(define (origin-frame frame) (car frame))
(define (edge1-frame frame) (cadr frame))
(define (edge2-frame frame) (caddr frame))
(define (dc frame) (cadddr frame)) ; bitmap Display Context
;; transform an image to fit the frame
(define (frame-coord-map frame)
(lambda (v)
(add-vect
(origin-frame frame)
(add-vect (scale-vect (edge1-frame frame) (xcor-vect v))
(scale-vect (edge2-frame frame) (ycor-vect v))))))
;; painter generator
(define (segments->painter segment-list)
(lambda (frame)
(for-each
(lambda (segment) (draw-segment dc frame segment))
segment-list)))
(define (draw-segment dc frame segment)
(let ((start ((frame-coord-map frame) (start-segment segment)))
(end ((frame-coord-map frame) (end-segment segment))))
(send (dc frame) draw-line
(xcor-vect start)
(ycor-vect start)
(xcor-vect end)
(ycor-vect end))))
;; painters
(define (frame-outline frame)
((segments->painter (list (make-segment origin-vect i-hat)
(make-segment i-hat diag-vect)
(make-segment diag-vect j-hat)
(make-segment j-hat origin-vect))) frame))
(define (frame-cross frame)
((segments->painter (list (make-segment origin-vect diag-vect)
(make-segment i-hat j-hat))) frame))
(define (frame-diamond frame)
((segments->painter (list (make-segment (make-vect 0 0.5) (make-vect 0.5 1))
(make-segment (make-vect 0.5 1) (make-vect 1 0.5))
(make-segment (make-vect 1 0.5) split-vect)
(make-segment split-vect (make-vect 0 0.5)))) frame))
;; transformer generator
(define (transform-painter painter orig corner1 corner2)
(lambda (frame)
(let ((m (frame-coord-map frame)))
(let ((new-orig (m orig)))
(painter (make-frame new-orig
(sub-vect (m corner1) new-orig)
(sub-vect (m corner2) new-orig)
(dc frame)))))))
;; transformers
(define (flip-vert painter)
(transform-painter painter j-hat diag-vect origin-vect))
(define (flip-horiz painter)
(transform-painter painter i-hat origin-vect diag-vect))
(define (shrink-to-upper-right painter)
(let ((edge1 (make-vect 1 0.5)))
(transform-painter painter
(scale-vect diag-vect 0.5)
edge1
(transpose edge1))))
(define (squash-inwards painter)
(let ((edge1 (make-vect 0.65 0.35)))
(transform-painter painter
(scale-vect diag-vect 0.35)
edge1
(transpose edge1))))
(define (rotate90 painter)
(transform-painter painter i-hat diag-vect origin-vect))
(define (rotate180 painter) (rotate90 (rotate90 painter)))
(define (rotate270 painter) (rotate90 (rotate180 painter)))
(define (rotate360 painter) painter)
(define (paint-left painter)
(transform-painter painter origin-vect split-vect j-hat))
(define (paint-right painter)
(transform-painter painter split-vect i-hat (make-vect 0.5 1)))
(define (paint-top painter)
(transform-painter painter origin-vect i-hat split-vect))
(define (paint-bot painter)
(transform-painter painter split-vect (make-vect 1 0.5) j-hat))
(define (next-to transform1 transform2)
(lambda (frame)
(transform1 frame)
(transform2 frame)))
;; painter composition
(define (beside painter1 painter2)
(next-to (paint-left painter1) (paint-right painter2)))
(define (below painter1 painter2)
(next-to (paint-top painter1) (paint-bot painter2)))
(define (flipped-pairs painter)
(let ((painter2 (beside painter (flip-vert painter))))
(below painter2 painter2)))
(define (split compose-main compose-smaller)
(lambda (painter n)
(if (zero? n) painter
(let ((smaller ((split compose-main compose-smaller) painter (- n 1))))
(compose-main painter (compose-smaller smaller smaller))))))
(define right-split (split beside below))
(define up-split (split below beside))
(define (corner-split painter n)
(if (zero? n) painter
(let ((up (up-split painter (- n 1)))
(right (right-split painter (- n 1)))
(corner (corner-split painter (- n 1))))
(beside (below painter up)
(below right corner)))))
;; main
(define target1 (make-bitmap 100 100))
(define dc1 (new bitmap-dc% [bitmap target1]))
(define frame1
(let ((edge1 (scale-vect split-vect 100)))
(make-frame origin-vect edge1 (transpose edge1) dc1)))
(make-object image-snip% target1)
(frame-diamond frame1)