/[mcclim]/mcclim/bordered-output.lisp
ViewVC logotype

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Mar 20 01:41:17 2007 UTC (7 years, 1 month ago) by ahefner
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-6, HEAD
Changes since 1.16: +8 -9 lines
Merge with medium line style. Eliminated merge-line-styles due to the
contraint in the spec that you can't have NIL components in your line
style.
1 ;;; -*- Mode: lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4 ;;; (c) copyright 2007 by Andy Hefner (ahefner@gmail.com)
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 ;;; TODO:
21 ;;; - Define a protocol which the graph formatter can utilize to determine
22 ;;; where graph edges should be connected to shaped output borders.
23
24 ;;; - ** Double check default value and intent of move-cursor argument.
25 ;;; If I understand things right, move-cursor t for underlining is usually
26 ;;; the wrong thing.
27
28 ;;; FIXME:
29 ;;; - Various functions which try to accomodate line-thickness do not
30 ;;; attempt to consider possibility of a line-style argument.
31 ;;; - In a perfect world we could make the default shadow ink a tranlucent
32 ;;; ink, but the CLX backend isn't there yet. A stopgap measure could
33 ;;; simply blend against the pane-background.
34 ;;; - Using padding to control the rounded rectangles might be the wrong thing.
35
36 ;;; ???
37 ;;; - Would it make more sense to draw borders as part of replay (with recording
38 ;;; off, like a displayed record), and letting them effortlessly accomodate
39 ;;; changes in the bounding rectangle of the contents? This would only benefit
40 ;;; people doing unusual things with output records. How would be determine
41 ;;; bounds of the border?
42
43 (in-package :clim-internals)
44
45 (defclass bordered-output-record (standard-sequence-output-record)
46 (under record over))
47
48 (defgeneric make-bordered-output-record (stream shape record &key
49 &allow-other-keys)
50 (:documentation "Instantiates an output record of a class appropriate for the
51 specified shape containing the given output record, and renders any decorations
52 associated with the shape."))
53
54 (defgeneric draw-output-border-under
55 (shape stream record &rest drawing-options &key &allow-other-keys)
56 (:documentation
57 "Draws the portion of border shape which is visible underneath the surrounded
58 output"))
59
60 (defgeneric draw-output-border-over
61 (shape stream record &rest drawing-options &key &allow-other-keys)
62 (:documentation
63 "Draws the portion of border shape which is visible above the surrounded
64 output"))
65
66 ;; Keep this around just for fun, so we can list the defined border types.
67 (defvar *border-types* nil)
68
69 (defparameter *border-default-padding* 4)
70 (defparameter *border-default-radius* 7)
71 (defparameter *drop-shadow-default-offset* 6)
72
73 ;; Defining the border edges directly by the edges of the surrounded output
74 ;; record is wrong in the 'null bounding rectangle' case, occuring when the
75 ;; record has no chidren, or no children with non-null bounding rectangles.
76 ;; Intuitively, the empty border should remain centered on the cursor.
77 (defmacro with-border-edges ((stream record) &body body)
78 `(if (null-bounding-rectangle-p ,record)
79 (multiple-value-bind (left top) (stream-cursor-position ,stream)
80 (let ((right (1+ left))
81 (bottom (1+ top)))
82 ,@body))
83 (with-bounding-rectangle* (left top right bottom) ,record
84 ,@body)))
85
86 (defmacro surrounding-output-with-border ((&optional stream
87 &rest drawing-options &key
88 (shape :rectangle)
89 (move-cursor t)
90 &allow-other-keys)
91 &body body)
92 (declare (ignore shape move-cursor))
93 (setf stream (stream-designator-symbol stream '*standard-output*))
94 (gen-invoke-trampoline 'invoke-surrounding-output-with-border
95 (list stream)
96 drawing-options
97 body))
98
99 (defun %prepare-bordered-output-record
100 (stream shape border inner-record drawing-options)
101 (with-sheet-medium (medium stream)
102 (macrolet ((capture (&body body)
103 `(multiple-value-bind (cx cy) (stream-cursor-position stream)
104 (with-output-to-output-record (stream)
105 (setf (stream-cursor-position stream) (values cx cy))
106 ,@body))))
107 (let* ((border-under
108 (with-identity-transformation (medium)
109 (capture
110 (apply #'draw-output-border-under
111 shape stream inner-record drawing-options))))
112 (border-over
113 (with-identity-transformation (medium)
114 (capture
115 (apply #'draw-output-border-over
116 shape stream inner-record drawing-options)))))
117 (with-slots (under record over) border
118 (setf under border-under
119 record inner-record
120 over border-over)
121 (add-output-record under border)
122 (add-output-record record border)
123 (add-output-record over border))
124 border))))
125
126 (defmethod make-bordered-output-record (stream shape inner-record
127 &rest drawing-options)
128 (%prepare-bordered-output-record stream shape
129 (make-instance 'bordered-output-record)
130 inner-record drawing-options))
131
132 ;; This should have been exported by the CLIM package, otherwise you can't
133 ;; apply a computed list of drawing options.
134 (defun invoke-surrounding-output-with-border (stream cont
135 &rest drawing-options
136 &key (shape :rectangle)
137 (move-cursor t)
138 &allow-other-keys)
139 (with-keywords-removed (drawing-options (:shape :move-cursor))
140 (multiple-value-bind (cx cy) (stream-cursor-position stream)
141 (let ((border (apply #'make-bordered-output-record
142 stream
143 shape
144 (with-output-to-output-record (stream)
145 ;; w-o-t-o-r moved the cursor to the origin.
146 (setf (stream-cursor-position stream)
147 (values cx cy))
148 (funcall cont stream)
149 (setf (values cx cy)
150 (stream-cursor-position stream)))
151 drawing-options)))
152
153 (stream-add-output-record stream border)
154
155 (when (stream-drawing-p stream)
156 (with-output-recording-options (stream :record nil)
157 (replay border stream)))
158
159 (if move-cursor
160 ;; move-cursor is true, move cursor to lower-right corner of output.
161 (with-bounding-rectangle* (left top right bottom) border
162 (declare (ignore left top))
163 (setf (stream-cursor-position stream) (values right bottom)))
164 ;; move-cursor is false, preserve the cursor position from after
165 ;; the output (I think this is right, it's useful for :underline)
166 (setf (stream-cursor-position stream) (values cx cy)))
167 border))))
168
169 (defmethod draw-output-border-under
170 (shape stream record &rest drawing-options &key &allow-other-keys)
171 (declare (ignore drawing-options))
172 (values))
173
174 (defmacro %%line-style-for-method ()
175 `(or line-style
176 (let ((mls (medium-line-style stream)))
177 (make-line-style
178 :unit (or line-unit (line-style-unit mls))
179 :thickness (or line-thickness (line-style-thickness mls))
180 :cap-shape (or line-cap-shape (line-style-cap-shape mls))
181 :dashes (or line-dashes (line-style-dashes mls))))))
182
183 (defmacro %%adjusting-for-padding (&body body)
184 `(let ((left (- left padding-left))
185 (right (+ right padding-right))
186 (top (- top padding-top))
187 (bottom (+ bottom padding-bottom)))
188 ,@body))
189
190 (defmacro %%adjusting-padding-for-line-style (&body body)
191 `(let ((padding-left (+ padding-left (/ (or line-thickness 0) 2)))
192 (padding-right (+ padding-right (/ (or line-thickness 0) 2)))
193 (padding-top (+ padding-top (/ (or line-thickness 0) 2)))
194 (padding-bottom (+ padding-bottom (/ (or line-thickness 0) 2))))
195 ,@body))
196
197
198 (defmacro define-border-type (shape arglist &body body)
199 (check-type arglist list)
200 ;; The Franz User guide implies that &key isn't needed.
201 (pushnew '&key arglist)
202 `(progn
203 (pushnew ',shape *border-types*)
204 (defmethod draw-output-border-over ((shape (eql ',shape)) stream record
205 &rest drawing-options)
206 (with-border-edges (stream record)
207 (apply (lambda (,@arglist &allow-other-keys)
208 ,@body)
209 :stream stream
210 :record record
211 :left left
212 :right right
213 :top top
214 :bottom bottom
215 drawing-options)))))
216
217
218 ;;;; Standard border types
219
220 (define-border-type :rectangle (stream left top right bottom
221 ink outline-ink filled
222 (padding *border-default-padding*)
223 (padding-x padding)
224 (padding-y padding)
225 (padding-left padding-x)
226 (padding-right padding-x)
227 (padding-top padding-y)
228 (padding-bottom padding-y)
229 line-style
230 line-unit
231 line-thickness
232 line-cap-shape
233 line-dashes)
234 (%%adjusting-padding-for-line-style
235 (%%adjusting-for-padding
236 (let ((ink (or outline-ink
237 (and (not filled)
238 (or ink (medium-ink stream))))))
239 (when ink
240 (draw-rectangle* stream
241 left top right bottom
242 :line-style (%%line-style-for-method)
243 :ink ink
244 :filled nil))))))
245
246 (defmethod draw-output-border-under
247 ((shape (eql :rectangle)) stream record
248 &key background ink filled
249 (padding *border-default-padding*)
250 (padding-x padding)
251 (padding-y padding)
252 (padding-left padding-x)
253 (padding-right padding-x)
254 (padding-top padding-y)
255 (padding-bottom padding-y)
256 shadow
257 (shadow-offset *drop-shadow-default-offset*)
258 line-thickness
259 &allow-other-keys)
260
261 (when (or background filled)
262 (with-border-edges (stream record)
263 (%%adjusting-padding-for-line-style
264 (%%adjusting-for-padding
265 (when (and shadow shadow-offset)
266 (draw-rectangle* stream
267 (+ shadow-offset left)
268 (+ shadow-offset top)
269 (+ shadow-offset right)
270 (+ shadow-offset bottom)
271 :ink shadow
272 :filled t))
273 (draw-rectangle* stream
274 left top
275 right bottom
276 :ink (or background ink +background-ink+)
277 :filled t))))))
278
279 (define-border-type :oval (stream left top right bottom
280 (ink (medium-ink stream))
281 outline-ink
282
283 (padding *border-default-padding*)
284 (padding-x padding)
285 (padding-y padding)
286 (padding-left padding-x)
287 (padding-right padding-x)
288 (padding-top padding-y)
289 (padding-bottom padding-y)
290
291 line-style
292 line-unit
293 line-thickness
294 line-cap-shape
295 line-dashes)
296 (%%adjusting-padding-for-line-style
297 (%%adjusting-for-padding
298 (when ink
299 (draw-oval* stream
300 (/ (+ left right) 2) (/ (+ top bottom) 2)
301 (/ (- right left) 2) (/ (- bottom top) 2)
302 :line-style (%%line-style-for-method)
303 :ink (or outline-ink ink)
304 :filled nil)))))
305
306 (defmethod draw-output-border-under
307 ((shape (eql :oval)) stream record &key
308 background ink filled line-thickness
309 (shadow-offset *drop-shadow-default-offset*)
310 shadow
311 (padding *border-default-padding*)
312 (padding-x padding)
313 (padding-y padding)
314 (padding-left padding-x)
315 (padding-right padding-x)
316 (padding-top padding-y)
317 (padding-bottom padding-y)
318 &allow-other-keys)
319 (when (or filled background)
320 (with-border-edges (stream record)
321 (%%adjusting-padding-for-line-style
322 (%%adjusting-for-padding
323 (when shadow
324 (draw-oval* stream
325 (+ shadow-offset (/ (+ left right) 2))
326 (+ shadow-offset (/ (+ top bottom) 2))
327 (/ (- right left) 2) (/ (- bottom top) 2)
328 :ink shadow
329 :filled t))
330 (draw-oval* stream
331 (/ (+ left right) 2) (/ (+ top bottom) 2)
332 (/ (- right left) 2) (/ (- bottom top) 2)
333 :ink (or background ink +background-ink+)
334 :filled t))))))
335
336 ;;; A filled :drop-shadow is almost identical to :rectangle with a
337 ;;; :shadow keyword. So, just use :rectangle instead.
338 (define-border-type :drop-shadow (stream
339 left top right bottom
340 (filled nil)
341 (shadow-offset 3)
342 outline-ink
343 background
344 (ink (medium-ink stream))
345 (padding *border-default-padding*)
346 (padding-x padding)
347 (padding-y padding)
348 (padding-left padding-x)
349 (padding-right padding-x)
350 (padding-top padding-y)
351 (padding-bottom padding-y)
352 line-style
353 line-unit
354 line-thickness
355 line-cap-shape
356 line-dashes)
357 (%%adjusting-padding-for-line-style
358 (%%adjusting-for-padding
359 (draw-rectangle* stream
360 left top
361 right bottom
362 :line-style (%%line-style-for-method)
363 :ink (or outline-ink ink)
364 :filled nil)
365 ;; If the user has (wisely) chosen my more modern "filled" style,
366 ;; we'll simply draw two rectangles, one offset from the other,
367 ;; to provide a solid background color and shadow.
368 ;; Note that the background keyword implies :filled t.
369 (unless (or filled background)
370 (when (< shadow-offset 0) ; FIXME!
371 (setf shadow-offset 0))
372 (draw-rectangle* stream
373 right (+ top shadow-offset)
374 (+ right shadow-offset) bottom
375 :ink (or outline-ink ink)
376 :filled t)
377 (draw-rectangle* stream
378 (+ left shadow-offset) bottom
379 (+ right shadow-offset) (+ bottom shadow-offset)
380 :ink (or outline-ink ink)
381 :filled t)))))
382
383 (defmethod draw-output-border-under
384 ((shape (eql :drop-shadow)) stream record &key
385 (filled nil)
386 (shadow-offset *drop-shadow-default-offset*)
387 background
388 outline-ink
389 shadow
390 (ink +foreground-ink+)
391 line-thickness
392 (padding *border-default-padding*)
393 (padding-x padding)
394 (padding-y padding)
395 (padding-left padding-x)
396 (padding-right padding-x)
397 (padding-top padding-y)
398 (padding-bottom padding-y))
399 (with-border-edges (stream record)
400 (%%adjusting-padding-for-line-style
401 (%%adjusting-for-padding
402 (when (or filled background)
403 (let* ((fill-color (or background +background-ink+))
404 (shadow-color (or shadow outline-ink ink +background-ink+)))
405 (draw-rectangle* stream
406 (+ shadow-offset left)
407 (+ shadow-offset top)
408 (+ shadow-offset right)
409 (+ shadow-offset bottom)
410 :filled t
411 :ink shadow-color)
412 (draw-rectangle* stream left top right bottom
413 :filled t
414 :ink fill-color)))))))
415
416 (define-border-type :underline (stream record
417 (ink (medium-ink stream))
418 line-style
419 line-unit
420 line-thickness
421 line-cap-shape
422 line-dashes)
423 (let ((line-style (%%line-style-for-method)))
424 (labels ((fn (record)
425 (loop for child across (output-record-children record) do
426 (typecase child
427 (text-displayed-output-record
428 (with-bounding-rectangle* (left top right bottom) child
429 (declare (ignore top))
430 (draw-line* stream left bottom right bottom
431 :ink ink
432 :line-style line-style)))
433 (updating-output-record nil)
434 (compound-output-record (fn child))))))
435 (fn record))))
436
437 (define-border-type :inset (stream left top right bottom
438 (padding *border-default-padding*)
439 (padding-x padding)
440 (padding-y padding)
441 (padding-left padding-x)
442 (padding-right padding-x)
443 (padding-top padding-y)
444 (padding-bottom padding-y))
445 (%%adjusting-for-padding
446 (let ((dark *3d-dark-color*)
447 (light *3d-light-color*))
448 (flet ((draw (left-edge right-edge bottom-edge top-edge light dark)
449 (draw-line* stream left-edge bottom-edge left-edge top-edge
450 :ink dark)
451 (draw-line* stream left-edge top-edge right-edge top-edge
452 :ink dark)
453 (draw-line* stream right-edge bottom-edge right-edge top-edge
454 :ink light)
455 (draw-line* stream left-edge bottom-edge right-edge bottom-edge
456 :ink light)))
457 (draw left right bottom top light dark)
458 (draw (1+ left) (1- right) (1- bottom) (1+ top) light dark)))))
459
460 ;;; Padding defaults to radius. I'm not sure if this is right, but it lets you do
461 ;;; things like forcing the radius on one side to zero, flattening that side,
462 ;;; and stopping the edge from jamming against the output (saving you the trouble
463 ;;; of having to manually hack the padding on one side to compensate). If someone
464 ;;; can think of a better approach to defaulting the radius and padding arguments,
465 ;;; do share.
466 (define-border-type :rounded (stream left top right bottom
467 (radius *border-default-radius*)
468 (radius-x radius)
469 (radius-y radius)
470 (radius-left radius-x)
471 (radius-right radius-x)
472 (radius-top radius-y)
473 (radius-bottom radius-y)
474 (padding radius)
475 (padding-x padding)
476 (padding-y padding)
477 (padding-left padding-x)
478 (padding-right padding-x)
479 (padding-top padding-y)
480 (padding-bottom padding-y)
481 ink
482 filled
483 outline-ink
484 line-style
485 line-unit
486 line-thickness
487 line-cap-shape
488 line-dashes)
489 (%%adjusting-padding-for-line-style
490 (%%adjusting-for-padding
491 (let ((ink (or outline-ink
492 (and (not filled) (or ink +foreground-ink+)))))
493 (when ink
494 (draw-rounded-rectangle* stream left top right bottom
495 :radius-left radius-left ; padding-left
496 :radius-right radius-right ; padding-right
497 :radius-top radius-top ; padding-top
498 :radius-bottom radius-bottom ; padding-bottom
499 :ink ink
500 :filled nil
501 :line-style (%%line-style-for-method)))))))
502
503 (defmethod draw-output-border-under ((shape (eql :rounded)) stream record &key
504 (radius *border-default-radius*)
505 (radius-x radius)
506 (radius-y radius)
507 (radius-left radius-x)
508 (radius-right radius-x)
509 (radius-top radius-y)
510 (radius-bottom radius-y)
511 (padding radius)
512 (padding-x padding)
513 (padding-y padding)
514 (padding-left padding-x)
515 (padding-right padding-x)
516 (padding-top padding-y)
517 (padding-bottom padding-y)
518 ink
519 filled
520 background
521 shadow
522 (shadow-offset *drop-shadow-default-offset*)
523 line-thickness)
524 (with-border-edges (stream record)
525 (%%adjusting-padding-for-line-style
526 (%%adjusting-for-padding
527 (when (or filled background)
528 (when (and shadow shadow-offset)
529 (draw-rounded-rectangle* stream
530 (+ left shadow-offset)
531 (+ top shadow-offset)
532 (+ shadow-offset right)
533 (+ shadow-offset bottom)
534 :radius-left radius-left
535 :radius-right radius-right
536 :radius-top radius-top
537 :radius-bottom radius-bottom
538 :ink shadow
539 :filled t))
540 (let ((ink (or background ink +background-ink+)))
541 (draw-rounded-rectangle* stream left top right bottom
542 :radius-left radius-left
543 :radius-right radius-right
544 :radius-top radius-top
545 :radius-bottom radius-bottom
546 :ink ink
547 :filled t)))))))
548
549 (define-border-type :ellipse (stream left top right bottom
550 (padding *border-default-radius*)
551 (padding-x padding)
552 (padding-y padding)
553 (padding-left padding-x)
554 (padding-right padding-x)
555 (padding-top padding-y)
556 (padding-bottom padding-y)
557 ink outline-ink filled
558 circle
559 line-style
560 line-unit
561 min-radius
562 (min-radius-x min-radius)
563 (min-radius-y min-radius)
564 line-thickness
565 line-cap-shape
566 line-dashes)
567 (%%adjusting-padding-for-line-style
568 (%%adjusting-for-padding
569 (let ((ink (or outline-ink (and (not filled)
570 (or ink +foreground-ink+)))))
571 (when ink
572 (let* ((cx (/ (+ right left) 2))
573 (cy (/ (+ top bottom) 2))
574 (radius-x (- right cx))
575 (radius-y (- bottom cy))
576 (radius-x (if circle
577 (sqrt (+ (* radius-x radius-x)
578 (* radius-y radius-y)))
579 radius-x))
580 (radius-y (if circle radius-x radius-y))
581 (fx (/ radius-x (cos (/ pi 4))))
582 (fy (/ radius-y (sin (/ pi 4))))
583 (fx (max fx (or min-radius-x 0)))
584 (fy (max fy (or min-radius-y 0))))
585 (draw-ellipse* stream cx cy fx 0 0 fy
586 :filled nil :ink ink
587 :line-style (%%line-style-for-method))))))))
588
589 (defmethod draw-output-border-under
590 ((shape (eql :ellipse)) stream record &key
591 (padding *border-default-radius*)
592 (padding-x padding)
593 (padding-y padding)
594 (padding-left padding-x)
595 (padding-right padding-x)
596 (padding-top padding-y)
597 (padding-bottom padding-y)
598 ink background filled
599 circle
600 min-radius
601 shadow
602 (shadow-offset *drop-shadow-default-offset*)
603 (min-radius-x min-radius)
604 (min-radius-y min-radius)
605 line-thickness)
606 (with-border-edges (stream record)
607 (%%adjusting-padding-for-line-style
608 (%%adjusting-for-padding
609 (let ((ink (or background (and filled (or ink +background-ink+)))))
610 (when ink
611 (let* ((cx (/ (+ right left) 2))
612 (cy (/ (+ top bottom) 2))
613 (radius-x (- right cx))
614 (radius-y (- bottom cy))
615 (radius-x (if circle
616 (sqrt (+ (* radius-x radius-x)
617 (* radius-y radius-y)))
618 radius-x))
619 (radius-y (if circle radius-x radius-y))
620 (fx (/ radius-x (cos (/ pi 4))))
621 (fy (/ radius-y (sin (/ pi 4))))
622 (fx (max fx (or min-radius-x 0)))
623 (fy (max fy (or min-radius-y 0))) )
624 (when (and shadow shadow-offset)
625 (draw-ellipse* stream (+ cx shadow-offset) (+ cy shadow-offset)
626 fx 0 0 fy :filled t :ink shadow))
627 (draw-ellipse* stream cx cy fx 0 0 fy
628 :filled t :ink ink))))))))
629
630 (defmethod highlight-output-record ((record bordered-output-record) stream state)
631 (format *trace-output* "b-o-r ~A ~A ~A~%" record stream state)
632 (call-next-method))
633
634 ;;; Suppress highlighting of the border decoration itself:
635 (defmethod highlight-output-record-tree
636 ((record bordered-output-record) stream state)
637 (highlight-output-record-tree (slot-value record 'record) stream state))
638
639
640 ;;;; Highlighting of bordered output records
641
642 (defclass highlighting-bordered-output-record (bordered-output-record)
643 ((shape :reader shape :initarg :shape)
644 (drawing-options :reader drawing-options
645 :initarg :drawing-options
646 :initform nil)))
647
648 (defmethod highlight-output-record-tree
649 ((record highlighting-bordered-output-record)
650 stream state)
651 ;; Was this border created with the required options for highlighting?
652 (if (and (member state '(:highlight :unhighlight))
653 (or (getf (drawing-options record) :highlight-background)
654 (getf (drawing-options record) :highlight-outline)))
655 (highlight-output-record record stream state)
656 (call-next-method)))
657
658
659 (defmethod highlight-output-record ((record highlighting-bordered-output-record)
660 stream state)
661 (let ((drawing-options (drawing-options record)))
662 (destructuring-bind (&key background
663 outline-ink
664 highlight-background
665 highlight-outline
666 &allow-other-keys)
667 drawing-options
668 (if (and (member state '(:highlight :unhighlight))
669 (or highlight-background highlight-outline))
670 (flet ((redraw (new-drawing-options)
671 (clear-output-record record)
672 (%prepare-bordered-output-record stream (shape record) record
673 (slot-value record 'record)
674 new-drawing-options)
675 ;; Great, this again..
676 (queue-repaint stream
677 (make-instance 'window-repaint-event
678 :sheet stream
679 :region (transform-region
680 (sheet-native-transformation stream)
681 record)))))
682 (ecase state
683 (:highlight
684 (with-keywords-removed (drawing-options (:background :outline-ink))
685 (redraw (list* :background
686 (or (and (eql t highlight-background)
687 (highlight-shade (or background
688 (getf drawing-options :ink)
689 +background-ink+)))
690 highlight-background
691 background)
692 :outline-ink
693 (or (and (eql t highlight-outline)
694 (highlight-shade (or outline-ink
695 (getf drawing-options :ink)
696 +foreground-ink+)))
697 highlight-outline
698 outline-ink)
699 drawing-options))))
700 (:unhighlight (redraw drawing-options))))
701 (call-next-method)))))
702
703 (defmacro define-default-highlighting-method (shape)
704 `(defmethod make-bordered-output-record (stream (shape (eql ,shape))
705 inner-record &rest drawing-options)
706 (%prepare-bordered-output-record stream shape
707 (make-instance 'highlighting-bordered-output-record
708 :shape shape
709 :drawing-options drawing-options)
710 inner-record drawing-options)))
711
712 (define-default-highlighting-method :rectangle)
713 (define-default-highlighting-method :oval)
714 (define-default-highlighting-method :drop-shadow)
715 (define-default-highlighting-method :rounded)
716 (define-default-highlighting-method :ellipse)

  ViewVC Help
Powered by ViewVC 1.1.5