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

Contents of /mcclim/bordered-output.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (hide annotations)
Mon Feb 5 03:16:55 2007 UTC (7 years, 2 months ago) by ahefner
Branch: MAIN
Changes since 1.14: +676 -95 lines
Mostly rewrote bordered output. Introduced new border types :rounded
and :ellipse, and introduced various new keywords (:filled, :background,
:outline-ink, :shadow, :shadow-offset, :line-*, :padding-*, etc, to be
documented). Introduced generic functions make-bordered-output-record,
draw-output-border-under, draw-output-border-over to provide a CLOS-style
underpinning for the define-border-type macro. This also means you can
implement anonymous border styles via any object having applicable methods
for these functions. Filled borders should respond to presentation
highlighting if a :highlight keyword provides an alternate background ink
to use while highlighted.

Export aforementioned new border functions, draw-rounded-rectangle*, the
bordered-output-record class, and the highlight-output-record-tree function
via clim-externals.
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     (merge-line-styles
177     (make-line-style
178     :unit line-unit
179     :thickness line-thickness
180     :cap-shape line-cap-shape
181     :dashes line-dashes)
182     (medium-line-style stream))))
183    
184     (defmacro %%adjusting-for-padding (&body body)
185     `(let ((left (- left padding-left))
186     (right (+ right padding-right))
187     (top (- top padding-top))
188     (bottom (+ bottom padding-bottom)))
189     ,@body))
190    
191     (defmacro %%adjusting-padding-for-line-style (&body body)
192     `(let ((padding-left (+ padding-left (/ (or line-thickness 0) 2)))
193     (padding-right (+ padding-right (/ (or line-thickness 0) 2)))
194     (padding-top (+ padding-top (/ (or line-thickness 0) 2)))
195     (padding-bottom (+ padding-bottom (/ (or line-thickness 0) 2))))
196     ,@body))
197    
198    
199 adejneka 1.1 (defmacro define-border-type (shape arglist &body body)
200     (check-type arglist list)
201 moore 1.10 ;; The Franz User guide implies that &key isn't needed.
202     (pushnew '&key arglist)
203 ahefner 1.15 `(progn
204     (pushnew ,shape *border-types*)
205     (defmethod draw-output-border-over ((shape (eql ',shape)) stream record
206     &rest drawing-options)
207     (with-border-edges (stream record)
208     (apply (lambda (,@arglist &allow-other-keys)
209     ,@body)
210     :stream stream
211     :record record
212     :left left
213     :right right
214     :top top
215     :bottom bottom
216     drawing-options)))))
217    
218 adejneka 1.1
219     ;;;; Standard border types
220    
221 ahefner 1.15 (define-border-type :rectangle (stream left top right bottom
222     ink outline-ink filled
223     (padding *border-default-padding*)
224     (padding-x padding)
225     (padding-y padding)
226     (padding-left padding-x)
227     (padding-right padding-x)
228     (padding-top padding-y)
229     (padding-bottom padding-y)
230     line-style
231     line-unit
232     line-thickness
233     line-cap-shape
234     line-dashes)
235     (%%adjusting-padding-for-line-style
236     (%%adjusting-for-padding
237     (let ((ink (or outline-ink
238     (and (not filled)
239     (or ink (medium-ink stream))))))
240     (when ink
241     (draw-rectangle* stream
242     left top right bottom
243     :line-style (%%line-style-for-method)
244     :ink ink
245     :filled nil))))))
246    
247     (defmethod draw-output-border-under
248     ((shape (eql :rectangle)) stream record
249     &key background ink filled
250     (padding *border-default-padding*)
251     (padding-x padding)
252     (padding-y padding)
253     (padding-left padding-x)
254     (padding-right padding-x)
255     (padding-top padding-y)
256     (padding-bottom padding-y)
257     shadow
258     (shadow-offset *drop-shadow-default-offset*)
259     line-thickness
260     &allow-other-keys)
261    
262     (when (or background filled)
263     (with-border-edges (stream record)
264     (%%adjusting-padding-for-line-style
265     (%%adjusting-for-padding
266     (when (and shadow shadow-offset)
267     (draw-rectangle* stream
268     (+ shadow-offset left)
269     (+ shadow-offset top)
270     (+ shadow-offset right)
271     (+ shadow-offset bottom)
272     :ink shadow
273     :filled t))
274     (draw-rectangle* stream
275     left top
276     right bottom
277     :ink (or background ink +background-ink+)
278     :filled t))))))
279    
280     (define-border-type :oval (stream left top right bottom
281     (ink (medium-ink stream))
282     outline-ink
283    
284     (padding *border-default-padding*)
285     (padding-x padding)
286     (padding-y padding)
287     (padding-left padding-x)
288     (padding-right padding-x)
289     (padding-top padding-y)
290     (padding-bottom padding-y)
291    
292     line-style
293     line-unit
294     line-thickness
295     line-cap-shape
296     line-dashes)
297     (%%adjusting-padding-for-line-style
298     (%%adjusting-for-padding
299     (when ink
300     (draw-oval* stream
301     (/ (+ left right) 2) (/ (+ top bottom) 2)
302     (/ (- right left) 2) (/ (- bottom top) 2)
303     :line-style (%%line-style-for-method)
304     :ink (or outline-ink ink)
305     :filled nil)))))
306    
307     (defmethod draw-output-border-under
308     ((shape (eql :oval)) stream record &key
309     background ink filled line-thickness
310     (shadow-offset *drop-shadow-default-offset*)
311     shadow
312     (padding *border-default-padding*)
313     (padding-x padding)
314     (padding-y padding)
315     (padding-left padding-x)
316     (padding-right padding-x)
317     (padding-top padding-y)
318     (padding-bottom padding-y)
319     &allow-other-keys)
320     (when (or filled background)
321     (with-border-edges (stream record)
322     (%%adjusting-padding-for-line-style
323     (%%adjusting-for-padding
324     (when shadow
325     (draw-oval* stream
326     (+ shadow-offset (/ (+ left right) 2))
327     (+ shadow-offset (/ (+ top bottom) 2))
328     (/ (- right left) 2) (/ (- bottom top) 2)
329     :ink shadow
330     :filled t))
331     (draw-oval* stream
332     (/ (+ left right) 2) (/ (+ top bottom) 2)
333     (/ (- right left) 2) (/ (- bottom top) 2)
334     :ink (or background ink +background-ink+)
335     :filled t))))))
336    
337     ;;; A filled :drop-shadow is almost identical to :rectangle with a
338     ;;; :shadow keyword. So, just use :rectangle instead.
339     (define-border-type :drop-shadow (stream
340     left top right bottom
341     (filled nil)
342     (shadow-offset 3)
343     outline-ink
344     background
345     (ink (medium-ink stream))
346     (padding *border-default-padding*)
347     (padding-x padding)
348     (padding-y padding)
349     (padding-left padding-x)
350     (padding-right padding-x)
351     (padding-top padding-y)
352     (padding-bottom padding-y)
353     line-style
354     line-unit
355     line-thickness
356     line-cap-shape
357     line-dashes)
358     (%%adjusting-padding-for-line-style
359     (%%adjusting-for-padding
360     (draw-rectangle* stream
361     left top
362     right bottom
363     :line-style (%%line-style-for-method)
364     :ink (or outline-ink ink)
365     :filled nil)
366     ;; If the user has (wisely) chosen my more modern "filled" style,
367     ;; we'll simply draw two rectangles, one offset from the other,
368     ;; to provide a solid background color and shadow.
369     ;; Note that the background keyword implies :filled t.
370     (unless (or filled background)
371     (when (< shadow-offset 0) ; FIXME!
372     (setf shadow-offset 0))
373     (draw-rectangle* stream
374     right (+ top shadow-offset)
375     (+ right shadow-offset) bottom
376     :ink (or outline-ink ink)
377     :filled t)
378     (draw-rectangle* stream
379     (+ left shadow-offset) bottom
380     (+ right shadow-offset) (+ bottom shadow-offset)
381     :ink (or outline-ink ink)
382     :filled t)))))
383    
384     (defmethod draw-output-border-under
385     ((shape (eql :drop-shadow)) stream record &key
386     (filled nil)
387     (shadow-offset *drop-shadow-default-offset*)
388     background
389     outline-ink
390     shadow
391     (ink +foreground-ink+)
392     line-thickness
393     (padding *border-default-padding*)
394     (padding-x padding)
395     (padding-y padding)
396     (padding-left padding-x)
397     (padding-right padding-x)
398     (padding-top padding-y)
399     (padding-bottom padding-y))
400     (with-border-edges (stream record)
401     (%%adjusting-padding-for-line-style
402     (%%adjusting-for-padding
403     (when (or filled background)
404     (let* ((fill-color (or background +background-ink+))
405     (shadow-color (or shadow outline-ink ink +background-ink+)))
406     (draw-rectangle* stream
407     (+ shadow-offset left)
408     (+ shadow-offset top)
409     (+ shadow-offset right)
410     (+ shadow-offset bottom)
411     :filled t
412     :ink shadow-color)
413     (draw-rectangle* stream left top right bottom
414     :filled t
415     :ink fill-color)))))))
416    
417     (define-border-type :underline (stream record
418     (ink (medium-ink stream))
419     line-style
420     line-unit
421     line-thickness
422     line-cap-shape
423     line-dashes)
424     (let ((line-style (%%line-style-for-method)))
425     (labels ((fn (record)
426     (loop for child across (output-record-children record) do
427     (typecase child
428     (text-displayed-output-record
429     (with-bounding-rectangle* (left top right bottom) child
430     (declare (ignore top))
431     (draw-line* stream left bottom right bottom
432     :ink ink
433     :line-style line-style)))
434     (updating-output-record nil)
435     (compound-output-record (fn child))))))
436     (fn record))))
437    
438     (define-border-type :inset (stream left top right bottom
439     (padding *border-default-padding*)
440     (padding-x padding)
441     (padding-y padding)
442     (padding-left padding-x)
443     (padding-right padding-x)
444     (padding-top padding-y)
445     (padding-bottom padding-y))
446     (%%adjusting-for-padding
447     (let ((dark *3d-dark-color*)
448     (light *3d-light-color*))
449     (flet ((draw (left-edge right-edge bottom-edge top-edge light dark)
450     (draw-line* stream left-edge bottom-edge left-edge top-edge
451     :ink dark)
452     (draw-line* stream left-edge top-edge right-edge top-edge
453     :ink dark)
454     (draw-line* stream right-edge bottom-edge right-edge top-edge
455     :ink light)
456     (draw-line* stream left-edge bottom-edge right-edge bottom-edge
457     :ink light)))
458     (draw left right bottom top light dark)
459     (draw (1+ left) (1- right) (1- bottom) (1+ top) light dark)))))
460    
461     ;;; Padding defaults to radius. I'm not sure if this is right, but it lets you do
462     ;;; things like forcing the radius on one side to zero, flattening that side,
463     ;;; and stopping the edge from jamming against the output (saving you the trouble
464     ;;; of having to manually hack the padding on one side to compensate). If someone
465     ;;; can think of a better approach to defaulting the radius and padding arguments,
466     ;;; do share.
467     (define-border-type :rounded (stream left top right bottom
468     (radius *border-default-radius*)
469     (radius-x radius)
470     (radius-y radius)
471     (radius-left radius-x)
472     (radius-right radius-x)
473     (radius-top radius-y)
474     (radius-bottom radius-y)
475     (padding radius)
476     (padding-x padding)
477     (padding-y padding)
478     (padding-left padding-x)
479     (padding-right padding-x)
480     (padding-top padding-y)
481     (padding-bottom padding-y)
482     ink
483     filled
484     outline-ink
485     line-style
486     line-unit
487     line-thickness
488     line-cap-shape
489     line-dashes)
490     (%%adjusting-padding-for-line-style
491     (%%adjusting-for-padding
492     (let ((ink (or outline-ink
493     (and (not filled) (or ink +foreground-ink+)))))
494     (when ink
495     (draw-rounded-rectangle* stream left top right bottom
496     :radius-left radius-left ; padding-left
497     :radius-right radius-right ; padding-right
498     :radius-top radius-top ; padding-top
499     :radius-bottom radius-bottom ; padding-bottom
500     :ink ink
501     :filled nil
502     :line-style (%%line-style-for-method)))))))
503    
504     (defmethod draw-output-border-under ((shape (eql :rounded)) stream record &key
505     (radius *border-default-radius*)
506     (radius-x radius)
507     (radius-y radius)
508     (radius-left radius-x)
509     (radius-right radius-x)
510     (radius-top radius-y)
511     (radius-bottom radius-y)
512     (padding radius)
513     (padding-x padding)
514     (padding-y padding)
515     (padding-left padding-x)
516     (padding-right padding-x)
517     (padding-top padding-y)
518     (padding-bottom padding-y)
519     ink
520     filled
521     background
522     shadow
523     (shadow-offset *drop-shadow-default-offset*)
524     line-thickness)
525     (with-border-edges (stream record)
526     (%%adjusting-padding-for-line-style
527     (%%adjusting-for-padding
528     (when (or filled background)
529     (when (and shadow shadow-offset)
530     (draw-rounded-rectangle* stream
531     (+ left shadow-offset)
532     (+ top shadow-offset)
533     (+ shadow-offset right)
534     (+ shadow-offset bottom)
535     :radius-left radius-left
536     :radius-right radius-right
537     :radius-top radius-top
538     :radius-bottom radius-bottom
539     :ink shadow
540     :filled t))
541     (let ((ink (or background ink +background-ink+)))
542     (draw-rounded-rectangle* stream left top right bottom
543     :radius-left radius-left
544     :radius-right radius-right
545     :radius-top radius-top
546     :radius-bottom radius-bottom
547     :ink ink
548     :filled t)))))))
549    
550     (define-border-type :ellipse (stream left top right bottom
551     (padding *border-default-radius*)
552     (padding-x padding)
553     (padding-y padding)
554     (padding-left padding-x)
555     (padding-right padding-x)
556     (padding-top padding-y)
557     (padding-bottom padding-y)
558     ink outline-ink filled
559     circle
560     line-style
561     line-unit
562     min-radius
563     (min-radius-x min-radius)
564     (min-radius-y min-radius)
565     line-thickness
566     line-cap-shape
567     line-dashes)
568     (%%adjusting-padding-for-line-style
569     (%%adjusting-for-padding
570     (let ((ink (or outline-ink (and (not filled)
571     (or ink +foreground-ink+)))))
572     (when ink
573     (let* ((cx (/ (+ right left) 2))
574     (cy (/ (+ top bottom) 2))
575     (radius-x (- right cx))
576     (radius-y (- bottom cy))
577     (radius-x (if circle
578     (sqrt (+ (* radius-x radius-x)
579     (* radius-y radius-y)))
580     radius-x))
581     (radius-y (if circle radius-x radius-y))
582     (fx (/ radius-x (cos (/ pi 4))))
583     (fy (/ radius-y (sin (/ pi 4))))
584     (fx (max fx (or min-radius-x 0)))
585     (fy (max fy (or min-radius-y 0))))
586     (draw-ellipse* stream cx cy fx 0 0 fy
587     :filled nil :ink ink
588     :line-style (%%line-style-for-method))))))))
589    
590     (defmethod draw-output-border-under
591     ((shape (eql :ellipse)) stream record &key
592     (padding *border-default-radius*)
593     (padding-x padding)
594     (padding-y padding)
595     (padding-left padding-x)
596     (padding-right padding-x)
597     (padding-top padding-y)
598     (padding-bottom padding-y)
599     ink background filled
600     circle
601     min-radius
602     shadow
603     (shadow-offset *drop-shadow-default-offset*)
604     (min-radius-x min-radius)
605     (min-radius-y min-radius)
606     line-thickness)
607     (with-border-edges (stream record)
608     (%%adjusting-padding-for-line-style
609     (%%adjusting-for-padding
610     (let ((ink (or background (and filled (or ink +background-ink+)))))
611     (when ink
612     (let* ((cx (/ (+ right left) 2))
613     (cy (/ (+ top bottom) 2))
614     (radius-x (- right cx))
615     (radius-y (- bottom cy))
616     (radius-x (if circle
617     (sqrt (+ (* radius-x radius-x)
618     (* radius-y radius-y)))
619     radius-x))
620     (radius-y (if circle radius-x radius-y))
621     (fx (/ radius-x (cos (/ pi 4))))
622     (fy (/ radius-y (sin (/ pi 4))))
623     (fx (max fx (or min-radius-x 0)))
624     (fy (max fy (or min-radius-y 0))) )
625     (when (and shadow shadow-offset)
626     (draw-ellipse* stream (+ cx shadow-offset) (+ cy shadow-offset)
627     fx 0 0 fy :filled t :ink shadow))
628     (draw-ellipse* stream cx cy fx 0 0 fy
629     :filled t :ink ink))))))))
630    
631     (defmethod highlight-output-record ((record bordered-output-record) stream state)
632     (format *trace-output* "b-o-r ~A ~A ~A~%" record stream state)
633     (call-next-method))
634    
635     ;;; Suppress highlighting of the border decoration itself:
636     (defmethod highlight-output-record-tree
637     ((record bordered-output-record) stream state)
638     (highlight-output-record-tree (slot-value record 'record) stream state))
639    
640    
641     ;;;; Highlighting of bordered output records
642    
643     (defclass highlighting-bordered-output-record (bordered-output-record)
644     ((shape :reader shape :initarg :shape)
645     (drawing-options :reader drawing-options
646     :initarg :drawing-options
647     :initform nil)))
648    
649     (defmethod highlight-output-record-tree
650     ((record highlighting-bordered-output-record)
651     stream state)
652     ;; Was this border created with the required options for highlighting?
653     (if (and (member state '(:highlight :unhighlight))
654     (or (getf (drawing-options record) :highlight-background)
655     (getf (drawing-options record) :highlight-outline)))
656     (highlight-output-record record stream state)
657     (call-next-method)))
658    
659    
660     (defmethod highlight-output-record ((record highlighting-bordered-output-record)
661     stream state)
662     (let ((drawing-options (drawing-options record)))
663     (destructuring-bind (&key background
664     outline-ink
665     highlight-background
666     highlight-outline
667     &allow-other-keys)
668     drawing-options
669     (if (and (member state '(:highlight :unhighlight))
670     (or highlight-background highlight-outline))
671     (flet ((redraw (new-drawing-options)
672     (clear-output-record record)
673     (%prepare-bordered-output-record stream (shape record) record
674     (slot-value record 'record)
675     new-drawing-options)
676     ;; Great, this again..
677     (queue-repaint stream
678     (make-instance 'window-repaint-event
679     :sheet stream
680     :region (transform-region
681     (sheet-native-transformation stream)
682     record)))))
683     (ecase state
684     (:highlight
685     (with-keywords-removed (drawing-options (:background :outline-ink))
686     (redraw (list* :background
687     (or (and (eql t highlight-background)
688     (highlight-shade (or background
689     (getf drawing-options :ink)
690     +background-ink+)))
691     highlight-background
692     background)
693     :outline-ink
694     (or (and (eql t highlight-outline)
695     (highlight-shade (or outline-ink
696     (getf drawing-options :ink)
697     +foreground-ink+)))
698     highlight-outline
699     outline-ink)
700     drawing-options))))
701     (:unhighlight (redraw drawing-options))))
702     (call-next-method)))))
703    
704     (defmacro define-default-highlighting-method (shape)
705     `(defmethod make-bordered-output-record (stream (shape (eql ,shape))
706     inner-record &rest drawing-options)
707     (%prepare-bordered-output-record stream shape
708     (make-instance 'highlighting-bordered-output-record
709     :shape shape
710     :drawing-options drawing-options)
711     inner-record drawing-options)))
712    
713     (define-default-highlighting-method :rectangle)
714     (define-default-highlighting-method :oval)
715     (define-default-highlighting-method :drop-shadow)
716     (define-default-highlighting-method :rounded)
717     (define-default-highlighting-method :ellipse)

  ViewVC Help
Powered by ViewVC 1.1.5