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@comail.ru) +;;; (c) copyright 2007 by Andy Hefner (ahefner@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