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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide 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 ahefner 1.15 ;;; -*- Mode: lisp; Package: CLIM-INTERNALS -*-
2 adejneka 1.1
3     ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4 ahefner 1.15 ;;; (c) copyright 2007 by Andy Hefner (ahefner@gmail.com)
5 adejneka 1.1 ;;; 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 ahefner 1.15 ;;; - 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 adejneka 1.1
43 mikemac 1.5 (in-package :clim-internals)
44 adejneka 1.1
45 ahefner 1.15 (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 adejneka 1.1
86     (defmacro surrounding-output-with-border ((&optional stream
87 ahefner 1.15 &rest drawing-options &key
88     (shape :rectangle)
89     (move-cursor t)
90     &allow-other-keys)
91 adejneka 1.1 &body body)
92     (declare (ignore shape move-cursor))
93 moore 1.12 (setf stream (stream-designator-symbol stream '*standard-output*))
94 gilbert 1.8 (gen-invoke-trampoline 'invoke-surrounding-output-with-border
95     (list stream)
96     drawing-options
97     body))
98 adejneka 1.1
99 ahefner 1.15 (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 adejneka 1.1 (defun invoke-surrounding-output-with-border (stream cont
135     &rest drawing-options
136 moore 1.11 &key (shape :rectangle)
137 ahefner 1.15 (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 ahefner 1.17 (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 ahefner 1.15
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 adejneka 1.1 (defmacro define-border-type (shape arglist &body body)
199     (check-type arglist list)
200 moore 1.10 ;; The Franz User guide implies that &key isn't needed.
201     (pushnew '&key arglist)
202 ahefner 1.15 `(progn
203 ahefner 1.17 (pushnew ',shape *border-types*)
204 ahefner 1.15 (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 adejneka 1.1
218     ;;;; Standard border types
219    
220 ahefner 1.15 (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 ahefner 1.17 (make-instance 'window-repaint-event
678 ahefner 1.15 :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