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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
;;;-*- Mode:Lisp; Package:PICTURES; Base:10 -*-
;;;
;;;
;;;
;;; TEXAS INSTRUMENTS INCORPORATED
;;; P.O. BOX 149149
;;; AUSTIN, TEXAS 78714-9149
;;;
;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; Authors: Delmar Hager, James Dutton, Teri Crowe
;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke
(in-package "PICTURES")
(export '(
circle-center-x
circle-center-y
circle-radius
circle-center
make-circle
make-filled-circle
make-filled-circle-edge
circle
filled-circle-edge
filled-circle
)
'pictures)
;Circle Class Definition:
(defclass circle (extent-cache graphic)
(
(center-x :type wcoord
:initarg :center-x
:accessor circle-center-x
:documentation "x-coordinate of the center")
(center-y :type wcoord
:initarg :center-y
:accessor circle-center-y
:documentation "y-coordinate of the center")
(radius :type wcoord
:initarg :radius
:accessor circle-radius
:documentation "Radius of the circle")
)
(:documentation "A graphic that represents a circle in object coordinates"))
;Filled-Circle Class Definition:
(defclass filled-circle ( circle)
()
(:documentation "Filled circle class in pictures"))
;Filled-Circle-Edge Class Definition:
(defclass filled-circle-edge ( circle edge)
()
(:documentation "Filled circle edge class in pictures"))
;Function: make-circle
; Return a new circle object with the given CENTER and RADIUS.
(defun make-circle (center-x center-y radius
&rest options
)
"Make a circle with the center coordinate of (CENTER-X CENTER-Y) and RADIUS.
The following keyword OPTIONS are allowed:
GSTATE PARENT SENESITIVITY TRANSFORM PLIST"
(declare (type wcoord center-x center-y radius))
(apply #'make-instance 'circle
:center-x center-x
:center-y center-y
:radius radius
options)
)
;Function: make-filled-circle
; Return a new filled-circle object with the given CENTER and RADIUS.
(defun make-filled-circle (center-x center-y radius
&rest options
)
"Make a filled-circle with the center coordinate of
(CENTER-X CENTER-Y) and RADIUS.
The following keyword OPTIONS are allowed:
GSTATE PARENT SENESITIVITY TRANSFORM PLIST"
(declare (type wcoord center-x center-y radius))
(apply #'make-instance 'filled-circle
:center-x center-x
:center-y center-y
:radius radius
options))
;Function: make-filled-circle-edge
; Return a new filled-circle-edge object with the given CENTER and RADIUS.
(defun make-filled-circle-edge (center-x center-y radius &rest options)
"Make a filled-circle with the center coordinate of
(CENTER-X CENTER-Y) and RADIUS.
The following keyword OPTIONS are allowed:
GSTATE PARENT SENESITIVITY TRANSFORM PLIST"
(declare (type wcoord center-x center-y radius))
(apply #'make-instance 'filled-circle-edge
:center-x center-x
:center-y center-y
:radius radius
options))
;Method: circle-radius
; Returns or changes the object coordinates for the radius of the CIRCLE.
(defmethod (setf circle-radius) :after (new-radius (circle circle))
(declare (ignore new-radius))
(extent-changed circle))
;Method: circle-center
; Returns or changes the object coordinates of the center of the CIRCLE.
(defmethod circle-center ((circle circle))
(with-slots (center-x center-y) circle
(values center-x center-y)))
(defmethod (SETF circle-center-x) :after (new-center-x (circle circle))
(declare (ignore new-center-x))
(extent-changed circle))
(defmethod (setf circle-center-y) :after (new-center-y (circle circle))
(declare (ignore new-center-y))
(extent-changed circle))
; Graphic methods for circle graphics
;Method: extent-compute
; Compute the extent rectangle for the CIRCLE.
; Note: A graphic's extent rectangle is defined in the object coordinate
; system. This means that each graphic should apply its own transform to
; its computed extent before returning it.
(defmethod extent-compute ((circle circle))
(with-slots (center-x center-y radius transform) circle
(let (new-center-x new-center-y new-radius-x new-radius-y new-radius)
(multiple-value-setq
(new-center-x new-center-y) ; Transform circle center
(transform-point transform center-x center-y))
(multiple-value-setq
(new-radius-x new-radius-y) ; Transform circle radius
(scale-point transform radius radius))
(setf new-radius
(min new-radius-x new-radius-y)) ; Use the smaller scale factor
(let ((xmin (- new-center-x new-radius))
(ymin (- new-center-y new-radius))
(xmax (+ new-center-x new-radius))
(ymax (+ new-center-y new-radius)))
(with-coercion ((xmin ymin xmax ymax) extent-element)
(make-extent-rect ; Build the extent square
:xmin xmin
:ymin ymin
:xmax xmax
:ymax ymax
:valid t))))))
;Method: draw-graphic
; Draw the CIRCLE object in the given VIEW. If MIN-X, MIN-Y, WIDTH, and
; HEIGHT are given, then only parts of the object that lie within the
; given rectangle need to be drawn.
(defmethod draw-graphic ((circle circle) (view view)
&optional min-x min-y width height)
(declare (type (or null wcoord) min-x min-y width height))
(with-slots (extent) circle
(WHEN (visible-p circle)
(multiple-value-bind (xmin ymin diameter)
(square-bounding-circle circle)
(view-draw-arc
view ; Draw the circle
xmin
ymin
diameter
diameter
0
(* 2 pi)
(graphic-gstate circle)) ; Pass the combined gstate
))))
;Method: draw-graphic Draw the FILLED-CIRCLE object in the given VIEW. If
;MIN-X, MIN-Y, WIDTH, and HEIGHT are given, then only parts of the object
;that lie within the given rectangle need to be drawn.
(defmethod draw-graphic ((circle filled-circle) (view view)
&optional min-x min-y width height)
(declare (type (or null wcoord) min-x min-y width height))
(with-slots (extent) circle
(WHEN (visible-p circle)
(multiple-value-bind (xmin ymin diameter)
(square-bounding-circle circle)
(view-draw-filled-arc
view ; Draw the circle
xmin
ymin
diameter
diameter
0
(* 2 pi)
(graphic-gstate circle)) ; Pass the combined gstate
))))
;Method: draw-graphic
; Draw the FILLED-CIRCLE-EDGE object by first drawing the interior and
; then boundary. If MIN-X, MIN-Y, WIDTH, and HEIGHT are given, then only
; parts of the object that lie within the given rectangle need to be
; drawn.
(defmethod draw-graphic ((circle filled-circle-edge) (view view)
&optional min-x min-y width height)
(declare (type (or null wcoord) min-x min-y width height))
(with-slots (extent) circle
(WHEN (visible-p circle)
(with-slots (edge-gstate) circle
; Use global temp buffer
(multiple-value-bind (xmin ymin diameter)
(square-bounding-circle circle)
(view-draw-filled-arc
view ; Draw the circle's interior
xmin
ymin
diameter
diameter
0
(* 2 pi)
(graphic-gstate circle)) ; Pass the combined gstate
(view-draw-arc
view ; Draw the circle's boundary
xmin
ymin
diameter
diameter
0
(* 2 pi)
(edge-gstate circle)) ; Pass the combined edge gstate
)))))
;Method: normalize-graphic
; Normalize the CIRCLE by applying its transform
; to its geometry, changing it accordingly, and then setting its transform
; to nil (the identity transform). Nothing of value is returned.
(defmethod normalize-graphic :before ((circle circle))
(with-slots (center-x center-y radius transform) circle
(multiple-value-setq (center-x center-y) ; Transform the center
(transform-point transform center-x center-y))
(let (radius-x radius-y)
(multiple-value-setq (radius-x radius-y) ; Transform the radius
(scale-point transform radius radius))
(setf radius (min radius-x radius-y))))) ; Use the smaller scale factor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Private Function: square-bounding-circle
; Return the southwest corner and the width of the square in which the
; given CIRCLE is inscribed.
(defun square-bounding-circle (circle)
(with-slots (center-x center-y radius) circle
(let (new-center-x new-center-y new-radius-x new-radius-y new-radius)
(multiple-value-setq (new-center-x new-center-y) ; Transform circle center
(transform-point (graphic-world-transform circle) center-x center-y))
(multiple-value-setq (new-radius-x new-radius-y) ; Transform circle radius
(scale-point (graphic-world-transform circle) radius radius))
(setf new-radius (min new-radius-x new-radius-y)) ; Use the smaller scale factor
(values (- new-center-x new-radius)
(- new-center-y new-radius)
(* 2 new-radius)))))
|
