[graphic-forms-cvs] r84 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Mar 31 23:21:20 UTC 2006
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
- at 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.
+ at deffn GenericFunction draw-text self text point &optional style tab-width
+Draws @code{text} in the current font and foreground color, with
+ at 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:
+ at table @code
+ at item :mnemonic
+underline the mnemonic character (specified in the original string
+by preceding the character with an ampersand @samp{&})
+ at 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
+ at item :transparent
+ at emph{This style is not yet implemented.} the background of the
+rectangular area where text is drawn will not be modified
+ at end table
@end deffn
@deffn GenericFunction font self
@@ -1041,12 +1055,27 @@
Returns a color object corresponding to the current foreground color.
@end deffn
- at deffn GenericFunction metrics self
-Returns a metrics object describing key attributes of the specified object.
+ at 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.
+ at end deffn
+
+ at 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:
+ at table @code
+ at item :mnemonic
+underline the mnemonic character (specified in the original string
+by preceding the character with an ampersand @samp{&})
+ at 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
+ at 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)))))
More information about the Graphic-forms-cvs
mailing list