Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv7623
Modified Files:
bordered-output.lisp package.lisp
Log Message:
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.
--- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2006/03/29 10:43:36 1.14
+++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2007/02/05 03:16:55 1.15
@@ -1,6 +1,7 @@
-;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
+;;; -*- Mode: lisp; Package: CLIM-INTERNALS -*-
;;; (c) copyright 2002 by Alexey Dejneka (adejneka(a)comail.ru)
+;;; (c) copyright 2007 by Andy Hefner (ahefner(a)gmail.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
;;; License as published by the Free Software Foundation; either
@@ -17,16 +18,76 @@
;;; Boston, MA 02111-1307 USA.
;;; TODO:
-;;; - Use DRAWING-OPTIONS, MOVE-CURSOR in I-S-O-W-B
-;;; - Gap computation
+;;; - Define a protocol which the graph formatter can utilize to determine
+;;; where graph edges should be connected to shaped output borders.
+
+;;; - ** Double check default value and intent of move-cursor argument.
+;;; If I understand things right, move-cursor t for underlining is usually
+;;; the wrong thing.
+
+;;; FIXME:
+;;; - Various functions which try to accomodate line-thickness do not
+;;; attempt to consider possibility of a line-style argument.
+;;; - In a perfect world we could make the default shadow ink a tranlucent
+;;; ink, but the CLX backend isn't there yet. A stopgap measure could
+;;; simply blend against the pane-background.
+;;; - Using padding to control the rounded rectangles might be the wrong thing.
+
+;;; ???
+;;; - Would it make more sense to draw borders as part of replay (with recording
+;;; off, like a displayed record), and letting them effortlessly accomodate
+;;; changes in the bounding rectangle of the contents? This would only benefit
+;;; people doing unusual things with output records. How would be determine
+;;; bounds of the border?
(in-package :clim-internals)
-(defvar *border-types* (make-hash-table))
+(defclass bordered-output-record (standard-sequence-output-record)
+ (under record over))
+
+(defgeneric make-bordered-output-record (stream shape record &key
+ &allow-other-keys)
+ (:documentation "Instantiates an output record of a class appropriate for the
+ specified shape containing the given output record, and renders any decorations
+ associated with the shape."))
+
+(defgeneric draw-output-border-under
+ (shape stream record &rest drawing-options &key &allow-other-keys)
+ (:documentation
+ "Draws the portion of border shape which is visible underneath the surrounded
+ output"))
+
+(defgeneric draw-output-border-over
+ (shape stream record &rest drawing-options &key &allow-other-keys)
+ (:documentation
+ "Draws the portion of border shape which is visible above the surrounded
+ output"))
+
+;; Keep this around just for fun, so we can list the defined border types.
+(defvar *border-types* nil)
+
+(defparameter *border-default-padding* 4)
+(defparameter *border-default-radius* 7)
+(defparameter *drop-shadow-default-offset* 6)
+
+;; Defining the border edges directly by the edges of the surrounded output
+;; record is wrong in the 'null bounding rectangle' case, occuring when the
+;; record has no chidren, or no children with non-null bounding rectangles.
+;; Intuitively, the empty border should remain centered on the cursor.
+(defmacro with-border-edges ((stream record) &body body)
+ `(if (null-bounding-rectangle-p ,record)
+ (multiple-value-bind (left top) (stream-cursor-position ,stream)
+ (let ((right (1+ left))
+ (bottom (1+ top)))
+ ,@body))
+ (with-bounding-rectangle* (left top right bottom) ,record
+ ,@body)))
(defmacro surrounding-output-with-border ((&optional stream
- &rest drawing-options
- &key (shape :rectangle) (move-cursor t))
+ &rest drawing-options &key
+ (shape :rectangle)
+ (move-cursor t)
+ &allow-other-keys)
&body body)
(declare (ignore shape move-cursor))
(setf stream (stream-designator-symbol stream '*standard-output*))
@@ -35,102 +96,622 @@
drawing-options
body))
+(defun %prepare-bordered-output-record
+ (stream shape border inner-record drawing-options)
+ (with-sheet-medium (medium stream)
+ (macrolet ((capture (&body body)
+ `(multiple-value-bind (cx cy) (stream-cursor-position stream)
+ (with-output-to-output-record (stream)
+ (setf (stream-cursor-position stream) (values cx cy))
+ ,@body))))
+ (let* ((border-under
+ (with-identity-transformation (medium)
+ (capture
+ (apply #'draw-output-border-under
+ shape stream inner-record drawing-options))))
+ (border-over
+ (with-identity-transformation (medium)
+ (capture
+ (apply #'draw-output-border-over
+ shape stream inner-record drawing-options)))))
+ (with-slots (under record over) border
+ (setf under border-under
+ record inner-record
+ over border-over)
+ (add-output-record under border)
+ (add-output-record record border)
+ (add-output-record over border))
+ border))))
+
+(defmethod make-bordered-output-record (stream shape inner-record
+ &rest drawing-options)
+ (%prepare-bordered-output-record stream shape
+ (make-instance 'bordered-output-record)
+ inner-record drawing-options))
+
+;; This should have been exported by the CLIM package, otherwise you can't
+;; apply a computed list of drawing options.
(defun invoke-surrounding-output-with-border (stream cont
&rest drawing-options
&key (shape :rectangle)
- (move-cursor t))
- (with-sheet-medium (medium stream)
- (let ((bbox-record
- (with-new-output-record (stream)
- (let ((record (with-new-output-record (stream)
- (funcall cont stream))))
- (with-bounding-rectangle* (left top right bottom) record
- (with-identity-transformation (medium)
- (with-keywords-removed
- (drawing-options (:shape :move-cursor))
- (apply (or (gethash shape *border-types*)
- (error "Border shape ~S not defined." shape))
- :stream stream
- :record record
- :left left :top top
- :right right :bottom bottom
- :allow-other-keys t
- drawing-options))))))))
- (when move-cursor
- (with-bounding-rectangle* (left top right bottom) bbox-record
- (declare (ignore left top))
- (setf (stream-cursor-position stream) (values right bottom))))
- bbox-record)))
-
+ (move-cursor t)
+ &allow-other-keys)
+ (with-keywords-removed (drawing-options (:shape :move-cursor))
+ (multiple-value-bind (cx cy) (stream-cursor-position stream)
+ (let ((border (apply #'make-bordered-output-record
+ stream
+ shape
+ (with-output-to-output-record (stream)
+ ;; w-o-t-o-r moved the cursor to the origin.
+ (setf (stream-cursor-position stream)
+ (values cx cy))
+ (funcall cont stream)
+ (setf (values cx cy)
+ (stream-cursor-position stream)))
+ drawing-options)))
+
+ (stream-add-output-record stream border)
+
+ (when (stream-drawing-p stream)
+ (with-output-recording-options (stream :record nil)
+ (replay border stream)))
+
+ (if move-cursor
+ ;; move-cursor is true, move cursor to lower-right corner of output.
+ (with-bounding-rectangle* (left top right bottom) border
+ (declare (ignore left top))
+ (setf (stream-cursor-position stream) (values right bottom)))
+ ;; move-cursor is false, preserve the cursor position from after
+ ;; the output (I think this is right, it's useful for :underline)
+ (setf (stream-cursor-position stream) (values cx cy)))
+ border))))
+
+(defmethod draw-output-border-under
+ (shape stream record &rest drawing-options &key &allow-other-keys)
+ (declare (ignore drawing-options))
+ (values))
+
+(defmacro %%line-style-for-method ()
+ `(or line-style
+ (merge-line-styles
+ (make-line-style
+ :unit line-unit
+ :thickness line-thickness
+ :cap-shape line-cap-shape
+ :dashes line-dashes)
+ (medium-line-style stream))))
+
+(defmacro %%adjusting-for-padding (&body body)
+ `(let ((left (- left padding-left))
+ (right (+ right padding-right))
+ (top (- top padding-top))
+ (bottom (+ bottom padding-bottom)))
+ ,@body))
+
+(defmacro %%adjusting-padding-for-line-style (&body body)
+ `(let ((padding-left (+ padding-left (/ (or line-thickness 0) 2)))
+ (padding-right (+ padding-right (/ (or line-thickness 0) 2)))
+ (padding-top (+ padding-top (/ (or line-thickness 0) 2)))
+ (padding-bottom (+ padding-bottom (/ (or line-thickness 0) 2))))
+ ,@body))
+
+
(defmacro define-border-type (shape arglist &body body)
(check-type arglist list)
- (loop for arg in arglist
- do (check-type arg symbol))
;; The Franz User guide implies that &key isn't needed.
(pushnew '&key arglist)
- `(setf (gethash ,shape *border-types*)
- (lambda ,arglist ,@body)))
-
+ `(progn
+ (pushnew ,shape *border-types*)
+ (defmethod draw-output-border-over ((shape (eql ',shape)) stream record
+ &rest drawing-options)
+ (with-border-edges (stream record)
+ (apply (lambda (,@arglist &allow-other-keys)
+ ,@body)
+ :stream stream
+ :record record
+ :left left
+ :right right
+ :top top
+ :bottom bottom
+ drawing-options)))))
+
;;;; Standard border types
-(define-border-type :rectangle (stream left top right bottom)
- (let ((gap 3)) ; FIXME
- (draw-rectangle* stream
- (- left gap) (- top gap)
- (+ right gap) (+ bottom gap)
- :filled nil)))
-
-(define-border-type :oval (stream left top right bottom)
- (let ((gap 3)) ; FIXME
- (draw-oval* stream
- (/ (+ left right) 2) (/ (+ top bottom) 2)
- (+ (/ (- right left) 2) gap) (+ (/ (- bottom top) 2) gap)
- :filled nil)))
-
-(define-border-type :drop-shadow (stream left top right bottom)
- (let* ((gap 3) ; FIXME?
- (offset 3)
- (left-edge (- left gap))
- (bottom-edge (+ bottom gap))
- (top-edge (- top gap))
- (right-edge (+ right gap)))
- (draw-rectangle* stream
- left-edge top-edge
- right-edge bottom-edge
- :filled nil)
- (draw-rectangle* stream
- right-edge (+ top-edge offset)
- (+ right-edge offset) bottom-edge :filled t)
- (draw-rectangle* stream
- (+ left-edge offset) bottom-edge
- (+ right-edge offset) (+ bottom-edge offset)
- :filled t)))
-
-(define-border-type :underline (stream record)
- (labels ((fn (record)
- (loop for child across (output-record-children record) do
- (typecase child
- (text-displayed-output-record
- (with-bounding-rectangle* (left top right bottom) child
- (declare (ignore top))
- (draw-line* stream left bottom right bottom)))
- (updating-output-record nil)
- (compound-output-record (fn child))))))
- (fn record)))
-
-(define-border-type :inset (stream left top right bottom)
- (let* ((gap 3)
- (left-edge (- left gap))
- (bottom-edge (+ bottom gap))
- (top-edge (- top gap))
- (right-edge (+ right gap))
- (dark *3d-dark-color*)
- (light *3d-light-color*))
- (flet ((draw (left-edge right-edge bottom-edge top-edge light dark)
- (draw-line* stream left-edge bottom-edge left-edge top-edge :ink dark)
- (draw-line* stream left-edge top-edge right-edge top-edge :ink dark)
- (draw-line* stream right-edge bottom-edge right-edge top-edge :ink light)
- (draw-line* stream left-edge bottom-edge right-edge bottom-edge :ink light)))
- (draw left-edge right-edge bottom-edge top-edge light dark)
- (draw (1+ left-edge) (1- right-edge) (1- bottom-edge) (1+ top-edge) light dark))))
+(define-border-type :rectangle (stream left top right bottom
+ ink outline-ink filled
+ (padding *border-default-padding*)
+ (padding-x padding)
+ (padding-y padding)
+ (padding-left padding-x)
+ (padding-right padding-x)
+ (padding-top padding-y)
+ (padding-bottom padding-y)
+ line-style
+ line-unit
+ line-thickness
+ line-cap-shape
+ line-dashes)
+ (%%adjusting-padding-for-line-style
+ (%%adjusting-for-padding
+ (let ((ink (or outline-ink
+ (and (not filled)
+ (or ink (medium-ink stream))))))
+ (when ink
+ (draw-rectangle* stream
+ left top right bottom
+ :line-style (%%line-style-for-method)
+ :ink ink
+ :filled nil))))))
+
+(defmethod draw-output-border-under
+ ((shape (eql :rectangle)) stream record
+ &key background ink filled
+ (padding *border-default-padding*)
+ (padding-x padding)
+ (padding-y padding)
+ (padding-left padding-x)
+ (padding-right padding-x)
+ (padding-top padding-y)
+ (padding-bottom padding-y)
+ shadow
+ (shadow-offset *drop-shadow-default-offset*)
+ line-thickness
+ &allow-other-keys)
+
+ (when (or background filled)
+ (with-border-edges (stream record)
+ (%%adjusting-padding-for-line-style
+ (%%adjusting-for-padding
+ (when (and shadow shadow-offset)
+ (draw-rectangle* stream
+ (+ shadow-offset left)
+ (+ shadow-offset top)
+ (+ shadow-offset right)
+ (+ shadow-offset bottom)
+ :ink shadow
+ :filled t))
+ (draw-rectangle* stream
+ left top
+ right bottom
+ :ink (or background ink +background-ink+)
+ :filled t))))))
+
+(define-border-type :oval (stream left top right bottom
+ (ink (medium-ink stream))
+ outline-ink
+
+ (padding *border-default-padding*)
+ (padding-x padding)
+ (padding-y padding)
+ (padding-left padding-x)
+ (padding-right padding-x)
+ (padding-top padding-y)
+ (padding-bottom padding-y)
+
+ line-style
+ line-unit
+ line-thickness
+ line-cap-shape
+ line-dashes)
+ (%%adjusting-padding-for-line-style
+ (%%adjusting-for-padding
+ (when ink
+ (draw-oval* stream
+ (/ (+ left right) 2) (/ (+ top bottom) 2)
+ (/ (- right left) 2) (/ (- bottom top) 2)
+ :line-style (%%line-style-for-method)
+ :ink (or outline-ink ink)
+ :filled nil)))))
+
+(defmethod draw-output-border-under
+ ((shape (eql :oval)) stream record &key
+ background ink filled line-thickness
+ (shadow-offset *drop-shadow-default-offset*)
+ shadow
+ (padding *border-default-padding*)
[405 lines skipped]
--- /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/04 12:55:43 1.60
+++ /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/05 03:16:55 1.61
@@ -1923,6 +1923,16 @@
#:pointer-motion-hint-event
#:frame-display-pointer-documentation-string
#:list-pane-items
+
+ #:draw-output-border-over
+ #:draw-output-border-under
+ #:make-bordered-output-record
+ #:bordered-output-record
+
+ #:draw-rounded-rectangle*
+
+ #:highlight-output-record-tree
+
;; Font listing extension:
#:font-family
#:font-face
