Author: junrue Date: Fri Mar 31 18:21:19 2006 New Revision: 84 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: implemented :tab and :mnemonic text drawing styles; implemented text-extent method and refactored widgets package at the same time Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 31 18:21:19 2006 @@ -1027,9 +1027,23 @@ using the current pen width and style. @end deffn -@deffn GenericFunction draw-text self text pnt -Draws the given string in the current font and foreground color, with -(x, y) being the top-left coordinate of a bounding box for the string. +@deffn GenericFunction draw-text self text point &optional style tab-width +Draws @code{text} in the current font and foreground color, with +@code{point} being the top-left coordinate of a bounding box for the +string. The optional @code{style} parameter is a list containing the +following text style keywords: +@table @code +@item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) +@item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width +@item :transparent +@emph{This style is not yet implemented.} the background of the +rectangular area where text is drawn will not be modified +@end table @end deffn @deffn GenericFunction font self @@ -1041,12 +1055,27 @@ Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics self -Returns a metrics object describing key attributes of the specified object. +@deffn GenericFunction metrics self font +Returns a @ref{font-metrics} object describing key attributes of @code{font}. @end deffn @deffn GenericFunction size self -Returns a size object describing the size of the object. +Returns a size object describing the dimensions of the object. +@end deffn + +@deffn GenericFunction text-extent self text &optional style tab-width +Returns the size of a rectangular that would enclose @code{text} if it +were drawn in the current font. The optional @code{style} parameter is +a list containing the following text style keywords: +@table @code +@item :mnemonic +underline the mnemonic character (specified in the original string +by preceding the character with an ampersand @samp{&}) +@item :tab +expand tabs when the string is rendered; by default the tab-width +is 8 characters, but the optional @code{tab-width} parameter may +be used to specify a different width +@end table @end deffn @deffn GenericFunction transparency-mask self Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Fri Mar 31 18:21:19 2006 @@ -272,34 +272,51 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-rects) (gfw:redraw *drawing-win*)) -(defun draw-a-string (gc pnt face-name pt-size style) +(defun draw-a-string (gc pnt text face-name pt-size font-style text-style) (let* ((font (make-instance 'gfg:font :gc gc :data (gfg:make-font-data :face-name face-name - :style style + :style font-style :point-size pt-size))) (metrics (gfg:metrics gc font))) + (if (or (null text) (zerop (length text))) + (setf text face-name)) (unwind-protect (progn (setf (gfg:font gc) font) - (gfg:draw-text gc face-name pnt) + (gfg:draw-text gc text pnt text-style) (gfs:make-point :x (gfs:point-x pnt) :y (+ (gfs:point-y pnt) (gfg:height metrics)))) (gfs:dispose font)))) (defun draw-strings (gc) (setf (gfg:foreground-color gc) gfg:*color-blue*) (let ((pnt (gfs:make-point :x 2 :y 0))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 10 nil)) - (setf pnt (draw-a-string gc pnt "Times New Roman" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Times New Roman" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Tahoma" 10 nil)) - (setf pnt (draw-a-string gc pnt "Tahoma" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Tahoma" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 10 nil)) - (setf pnt (draw-a-string gc pnt "Lucida Console" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Lucida Console" 18 '(:strikeout))) - (setf pnt (draw-a-string gc pnt "Courier New" 10 nil)) - (setf pnt (draw-a-string gc pnt "Courier New" 14 '(:italic :bold :underline))) - (setf pnt (draw-a-string gc pnt "Courier New" 18 '(:strikeout))))) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Times New Roman" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Tahoma" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Lucida Console" 18 '(:strikeout) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 10 nil nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 14 '(:italic :bold :underline) nil)) + (setf pnt (draw-a-string gc pnt nil "Courier New" 18 '(:strikeout) nil)) + + (setf (gfs:point-x pnt) (+ (floor (/ (gfs:size-width (gfw:client-size *drawing-win*)) 2)) 10)) + (setf (gfs:point-y pnt) 0) + (setf pnt (draw-a-string gc pnt (format nil "tab~ctab~ctab" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt (format nil "even~cmore~ctabs" #\Tab #\Tab) "Verdana" 10 nil '(:tab))) + (setf pnt (draw-a-string gc pnt " " "Verdana" 10 nil nil)) + (setf pnt (draw-a-string gc pnt "and a &mnemonic" "Verdana" 10 nil '(:mnemonic))))) + +#| + (setf pnt (draw-a-string gc pnt " " "Arial" 18 nil nil)) + (draw-a-string gc pnt "transparent" "Arial" 18 '(:bold) nil) + (incf (gfs:point-x pnt) 50) + (setf (gfg:foreground-color gc) gfg:*color-red*) + (draw-a-string gc pnt "text" "Arial" 10 '(:bold) '(:transparent)) +|# (defun select-text (disp item time rect) (declare (ignore disp time rect)) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Fri Mar 31 18:21:19 2006 @@ -152,6 +152,44 @@ (error 'gfs:win32-error :detail (format nil "~a failed" name)))) (cffi:foreign-free array)))) +(defun compute-draw-text-style (style) + (let ((flags (logior gfs::+dt-noclip+ gfs::+dt-noprefix+ gfs::+dt-singleline+ gfs::+dt-vcenter+))) + (unless (null style) + (loop for sym in style + do (cond + ((eq sym :mnemonic) + (setf flags (logand flags (lognot gfs::+dt-noprefix+)))) + ((eq sym :tab) + (setf flags (logior flags gfs::+dt-expandtabs+))) + ;; FIXME: the :transparent style needs to be implemented + ;; + ((eq sym :transparent))))) + flags)) + +(defun text-bounds (hdc str dt-flags tab-width) + (let ((len (length str)) + (sz (gfs:make-size))) + (when (> len 0) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tab-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) rect-ptr gfs::rect) + (gfs::draw-text-ex hdc str -1 rect-ptr (logior dt-flags gfs::+dt-calcrect+) dt-ptr) + (setf (gfs:size-width sz) (- gfs::right gfs::left)) + (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))))) + (when (or (zerop len) (zerop (gfs:size-height sz))) + (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) + (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) tm-ptr gfs::textmetrics) + (if (zerop (gfs::get-text-metrics hdc tm-ptr)) + (error 'gfs:win32-error :detail "get-text-metrics failed")) + (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))) + sz)) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -385,29 +423,35 @@ (with-null-brush (self) (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) -(defmethod draw-text ((self graphics-context) text (pnt gfs:point)) +(defmethod draw-text ((self graphics-context) text (pnt gfs:point) &optional style tab-width) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (setf gfs::left (gfs:point-x pnt)) - (setf gfs::top (gfs:point-y pnt)) - (gfs::draw-text (gfs:handle self) - text - -1 - rect-ptr - (logior gfs::+dt-calcrect+ gfs::+dt-singleline+) - (cffi:null-pointer)) - (gfs::draw-text (gfs:handle self) - text - (length text) - rect-ptr - (logior gfs::+dt-noclip+ - gfs::+dt-noprefix+ - gfs::+dt-singleline+ - gfs::+dt-vcenter+) - (cffi:null-pointer))))) + (let ((flags (compute-draw-text-style style)) + (tb-width (if (null tab-width) 0 tab-width))) + (cffi:with-foreign-object (dt-ptr 'gfs::drawtextparams) + (cffi:with-foreign-slots ((gfs::cbsize gfs::tablength gfs::leftmargin gfs::rightmargin) + dt-ptr gfs::drawtextparams) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::drawtextparams)) + (setf gfs::tablength tb-width) + (setf gfs::leftmargin 0) + (setf gfs::rightmargin 0) + (cffi:with-foreign-object (rect-ptr 'gfs::rect) + (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) + rect-ptr gfs::rect) + (setf gfs::left (gfs:point-x pnt)) + (setf gfs::top (gfs:point-y pnt)) + (gfs::draw-text-ex (gfs:handle self) + text + -1 + rect-ptr + (logior gfs::+dt-calcrect+ (logand flags (lognot gfs::+dt-vcenter+))) + dt-ptr) + (gfs::draw-text-ex (gfs:handle self) + text + (length text) + rect-ptr + flags + dt-ptr))))))) (defmethod (setf font) ((font font) (self graphics-context)) (if (gfs:disposed-p self) @@ -466,3 +510,11 @@ (error 'gfs:disposed-error)) (setf (slot-value self 'pen-width) width) (update-pen-for-gc self)) + +(defmethod text-extent ((self graphics-context) str &optional style tab-width) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (text-bounds (gfs:handle self) + str + (compute-draw-text-style style) + (if (or (null tab-width) (< tab-width 0)) 0 tab-width))) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Fri Mar 31 18:21:19 2006 @@ -33,27 +33,9 @@ (in-package :graphic-forms.uitoolkit.graphics) -(defgeneric alpha (self) - (:documentation "Returns an integer representing an alpha value.")) - -(defgeneric anti-alias (self) - (:documentation "Returns an int representing the current anti-alias setting.")) - (defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric background-pattern (self) - (:documentation "Returns a pattern object representing the current background pattern.")) - -(defgeneric clipped-p (self) - (:documentation "Returns T if a clipping region is set; nil otherwise.")) - -(defgeneric clipping-rectangle (self) - (:documentation "Returns a rectangle object representing the current clipping rectangle.")) - -(defgeneric copy-area (self src-rect dest-pnt) - (:documentation "Copies a rectangular area of the source onto the destination.")) - (defgeneric data-obj (self) (:documentation "Returns the data structure representing the raw form of the object.")) @@ -120,8 +102,8 @@ (defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners.")) -(defgeneric draw-text (self text pnt) - (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string.")) +(defgeneric draw-text (self text pnt &optional style tab-width) + (:documentation "Draws the given string in the current font and foreground color.")) (defgeneric font (self) (:documentation "Returns the current font.")) @@ -129,65 +111,17 @@ (defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric foreground-pattern (self) - (:documentation "Returns a pattern object representing the current foreground pattern.")) - -(defgeneric invert (self) - (:documentation "Returns a modified version of the object which is the mathematical inverse of the original.")) - -(defgeneric line-cap-style (self) - (:documentation "Returns an integer representing the line cap style.")) - -(defgeneric line-dash-style (self) - (:documentation "Returns a list of integers representing the line dash style.")) - -(defgeneric line-join-style (self) - (:documentation "Returns an integer representing the line join style.")) - -(defgeneric line-style (self) - (:documentation "Returns an integer representing the line style.")) - -(defgeneric line-width (self) - (:documentation "Returns an integer representing the line width.")) - (defgeneric load (self path) (:documentation "Loads the object from filesystem data identified by the specified pathname or string.")) -(defgeneric matrix (self) - (:documentation "Returns a matrix that represents the transformation or other computation represented by the object.")) - (defgeneric metrics (self font) - (:documentation "Returns a metrics object describing key attributes of the specified font.")) - -(defgeneric multiply (self other) - (:documentation "Returns a modified version of the object which is the result of multiplying the original with the other parameter.")) - -(defgeneric rotate (self angle) - (:documentation "Returns a modified version of the object which is the result of rotating the original by the specified angle.")) - -(defgeneric scale (self delta-x delta-y) - (:documentation "Returns a modified version of the object which is the result of scaling the original by the specified mathematical vector.")) + (:documentation "Returns a font-metrics object describing key attributes of the specified font.")) (defgeneric size (self) (:documentation "Returns a size object describing the size of the object.")) -(defgeneric text-anti-alias (self) - (:documentation "Returns an integer representing the text anti-alias setting.")) - -(defgeneric text-extent (self str) +(defgeneric text-extent (self str &optional style tab-width) (:documentation "Returns the size of the rectangular area that would be covered by the string if drawn in the current font.")) -(defgeneric transform (self) - (:documentation "Returns a transform object indicating how coordinates are transformed in the context of this object.")) - -(defgeneric transform-coordinates (self pnts) - (:documentation "Returns a list of point objects that are the result of applying a transformation against the specified list of points.")) - -(defgeneric translate (self delta-x delta-y) - (:documentation "Returns a modified version of the object which is the result of translating the original by the specified mathematical vector.")) - (defgeneric transparency-mask (self) (:documentation "Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency.")) - -(defgeneric xor-mode-p (self) - (:documentation "Returns T if colors are combined in XOR mode; nil otherwise.")) Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Fri Mar 31 18:21:19 2006 @@ -147,7 +147,7 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text) + ("DrawTextExA" draw-text-ex) INT (hdc HANDLE) (text :string) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 31 18:21:19 2006 @@ -114,6 +114,13 @@ (biclrused DWORD) (biclrimp DWORD)) +(defcstruct drawtextparams + (cbsize UINT) + (tablength INT) + (leftmargin INT) + (rightmargin INT) + (lengthdrawn UINT)) + (defcstruct logbrush (style UINT) (color COLORREF) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Fri Mar 31 18:21:19 2006 @@ -77,7 +77,7 @@ (init-control btn)) (defmethod preferred-size ((btn button) width-hint height-hint) - (let ((sz (widget-text-size btn gfs::+dt-singleline+ 0))) + (let ((sz (widget-text-size btn gfs::+dt-singleline+))) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint) (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14))) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Mar 31 18:21:19 2006 @@ -97,7 +97,7 @@ gfs::+dt-expandtabs+))) (if (and (= (logand bits gfs::+ss-left+) gfs::+ss-left+) (> width-hint 0)) (setf flags (logior flags gfs::+dt-wordbreak+))) - (setf sz (widget-text-size label flags width-hint)) + (setf sz (widget-text-size label flags)) (if (>= width-hint 0) (setf (gfs:size-width sz) width-hint)) (if (>= height-hint 0) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Mar 31 18:21:19 2006 @@ -122,30 +122,10 @@ (error 'gfs:disposed-error)) (gfs::set-window-text (gfs:handle w) str)) -(defun widget-text-size (widget dt-flags width-hint) - (let* ((hwnd (gfs:handle widget)) - (str (text widget)) - (len (length str)) - (sz (gfs:make-size)) - (hfont nil)) - (setf dt-flags (logior dt-flags gfs::+dt-calcrect+)) +(defun widget-text-size (widget dt-flags) + (let ((hwnd (gfs:handle widget)) + (hfont nil)) (gfs::with-retrieved-dc (hwnd hdc) (setf hfont (cffi:make-pointer (gfs::send-message hwnd gfs::+wm-getfont+ 0 0))) (gfs::with-hfont-selected (hdc hfont) - (when (> len 0) - (cffi:with-foreign-object (rect-ptr 'gfs::rect) - (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom) - rect-ptr gfs::rect) - (if (> width-hint 0) - (setf gfs::right width-hint)) - (gfs::draw-text hdc str -1 rect-ptr dt-flags (cffi:null-pointer)) - (setf (gfs:size-width sz) (- gfs::right gfs::left)) - (setf (gfs:size-height sz) (- gfs::bottom gfs::top))))) - (when (or (zerop len) (zerop (gfs:size-height sz))) - (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics) - (cffi:with-foreign-slots ((gfs::tmheight gfs::tmexternalleading) - tm-ptr gfs::textmetrics) - (if (zerop (gfs::get-text-metrics hdc tm-ptr)) - (error 'gfs:win32-error :detail "get-text-metrics failed")) - (setf (gfs:size-height sz) (+ gfs::tmheight gfs::tmexternalleading))))))) - sz)) + (gfg::text-bounds hdc (text widget) dt-flags 0)))))