[graphic-forms-cvs] r140 - in trunk: docs/manual src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue May 23 03:59:49 UTC 2006
Author: junrue
Date: Mon May 22 23:59:48 2006
New Revision: 140
Modified:
trunk/docs/manual/api.texinfo
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined new generic function text-baseline; implemented it for labels
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon May 22 23:59:48 2006
@@ -980,8 +980,22 @@
parent's coordinate system.
@end deffn
- at deffn GenericFunction text self
-Returns the object's text.
+ at deffn GenericFunction text self => string
+For a @ref{window} or @ref{dialog}, this function returns @code{self}'s
+titlebar text (which may be blank). For other @ref{widget}s that have a text
+component, this function returns that text component. For anything else,
+this function returns @sc{nil}.
+ at end deffn
+
+ at deffn GenericFunction text-baseline self => integer
+Returns the y coordinate value (relative to the top of the @code{self}'s
+bounding box) that correlates to the baseline of the text of the
+ at ref{control}, if any. For controls in which a text baseline is not
+meaningful, such as a @ref{label} with an @ref{image}, this function
+returns the control's height.@*@*
+By default, the library does not implement this function for @ref{window}
+subclasses. However, custom controls should implement this function if
+the custom control will be managed by a @ref{layout-manager}.
@end deffn
@deffn GenericFunction update self
@@ -1138,7 +1152,13 @@
@deftp Class graphics-context
This subclass of @ref{native-object} wraps a native device context,
hence instances of this class are used to perform drawing operations.
-One normally obtains a graphics-context via @ref{event-paint}.
+One normally obtains a graphics-context via @ref{event-paint}; however,
+initargs are also available for creating a context associated with an
+ at ref{image} or a @ref{widget}.
+ at deffn Initarg :image
+This initarg associates the context with an image,
+thus allowing applications to draw on the image.
+ at end deffn
@anchor{miter-limit}
@deffn Accessor miter-limit
This accessor accepts or returns a floating point value that
@@ -1210,6 +1230,11 @@
value is 0, which translates to a 1 pixel-wide line drawn with an
optimized drawing algorithm.
@end deffn
+ at deffn Initarg :widget
+This initarg associates the context with a widget,
+thus allowing applications to query graphics-related
+attributes of the widget.
+ at end deffn
@end deftp
@anchor{image}
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Mon May 22 23:59:48 2006
@@ -33,6 +33,9 @@
(in-package :graphic-forms.uitoolkit.widgets)
+(defconstant +horizontal-button-text-margin+ 7)
+(defconstant +vertical-button-text-margin+ 5)
+
;;;
;;; methods
;;;
@@ -81,18 +84,20 @@
(setf (slot-value btn 'gfs:handle) hwnd)))
(init-control btn))
-(defmethod preferred-size ((btn button) width-hint height-hint)
- (let ((sz (widget-text-size btn gfs::+dt-singleline+)))
+(defmethod preferred-size ((self button) width-hint height-hint)
+ (let ((size (widget-text-size self gfs::+dt-singleline+)))
(if (>= width-hint 0)
- (setf (gfs:size-width sz) width-hint)
- (setf (gfs:size-width sz) (+ (gfs:size-width sz) 14)))
+ (setf (gfs:size-width size) width-hint)
+ (setf (gfs:size-width size) (+ (gfs:size-width size)
+ (* +horizontal-button-text-margin+ 2))))
(if (>= height-hint 0)
- (setf (gfs:size-height sz) height-hint)
- (setf (gfs:size-height sz) (+ (gfs:size-height sz) 10)))
- sz))
+ (setf (gfs:size-height size) height-hint)
+ (setf (gfs:size-height size) (+ (gfs:size-height size)
+ ( * +vertical-button-text-margin+ 2))))
+ size))
-(defmethod text ((btn button))
- (get-widget-text btn))
+(defmethod text ((self button))
+ (get-widget-text self))
-(defmethod (setf text) (str (btn button))
- (set-widget-text btn str))
+(defmethod (setf text) (str (self button))
+ (set-widget-text self str))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Mon May 22 23:59:48 2006
@@ -100,48 +100,57 @@
(if (gfs:disposed-p ctrl)
(error 'gfs:disposed-error)))
-(defmethod gfg:font ((ctrl control))
- (font-of ctrl))
+(defmethod gfg:font ((self control))
+ (let ((font (font-of self)))
+ (unless font
+ (let ((result (gfs::send-message (gfs:handle self) gfs::+wm-getfont+ 0 0)))
+ (if (zerop result)
+ (let ((gc (make-instance 'gfg:graphics-context :widget self)))
+ (unwind-protect
+ (setf font (gfg:font gc)))
+ (gfs:dispose gc))
+ (setf font (make-instance 'gfg:font :handle (cffi:make-pointer result))))))
+ font))
-(defmethod (setf gfg:font) :before (font (ctrl control))
+(defmethod (setf gfg:font) :before (font (self control))
(declare (ignore color))
- (if (or (gfs:disposed-p ctrl) (gfs:disposed-p font))
+ (if (or (gfs:disposed-p self) (gfs:disposed-p font))
(error 'gfs:disposed-error)))
-(defmethod (setf gfg:font) (font (ctrl control))
- (setf (font-of ctrl) font)
- (redraw ctrl))
+(defmethod (setf gfg:font) (font (self control))
+ (setf (font-of self) font)
+ (redraw self))
-(defmethod gfg:foreground-color :before ((ctrl control))
- (if (gfs:disposed-p ctrl)
+(defmethod gfg:foreground-color :before ((self control))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod gfg:foreground-color ((ctrl control))
- (or (text-color-of ctrl) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+))))
+(defmethod gfg:foreground-color ((self control))
+ (or (text-color-of self) (gfg:rgb->color (gfs::get-sys-color gfs::+color-btntext+))))
-(defmethod (setf gfg:foreground-color) :before (color (ctrl control))
+(defmethod (setf gfg:foreground-color) :before (color (self control))
(declare (ignore color))
- (if (gfs:disposed-p ctrl)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod (setf gfg:foreground-color) (color (ctrl control))
- (setf (text-color-of ctrl) (gfg:copy-color color))
- (redraw ctrl))
+(defmethod (setf gfg:foreground-color) (color (self control))
+ (setf (text-color-of self) (gfg:copy-color color))
+ (redraw self))
-(defmethod give-focus :before ((ctrl control))
- (if (gfs:disposed-p ctrl)
+(defmethod give-focus :before ((self control))
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod give-focus ((ctrl control))
- (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl)))
+(defmethod give-focus ((self control))
+ (if (gfs:null-handle-p (gfs::set-focus (gfs:handle self)))
(error 'gfs:win32-error :detail "set-focus failed")))
-(defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys)
+(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys)
(if (gfs:disposed-p parent)
(error 'gfs:disposed-error))
(unless (or disp callbacks (not (functionp callback)))
(let ((class (define-dispatcher `((event-select . ,callback)))))
- (setf (dispatcher ctrl) (make-instance (class-name class))))))
+ (setf (dispatcher self) (make-instance (class-name class))))))
(defmethod (setf maximum-size) :after (max-size (self control))
(unless (gfs:disposed-p self)
@@ -168,4 +177,8 @@
(print-unreadable-object (self stream :type t)
(format stream "handle: ~x " (gfs:handle self))
(format stream "dispatcher: ~a " (dispatcher self))
- (format stream "size: ~a" (size self))))
+ (format stream "size: ~a " (size self))
+ (format stream "text baseline: ~a" (text-baseline self))))
+
+(defmethod text-baseline ((self control))
+ (gfs:size-height (size self)))
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Mon May 22 23:59:48 2006
@@ -175,7 +175,7 @@
(bits (gfs::get-window-long hwnd gfs::+gwl-style+))
(b-width (border-width label))
(sz nil))
- (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+) ; SS_BITMAP is not a single bit
+ (if (= (logand bits gfs::+ss-bitmap+) gfs::+ss-bitmap+)
(let ((image (image label)))
(if image
(gfg:size image)
@@ -208,3 +208,16 @@
gfs::+ws-child+
gfs::+ws-visible+))))
(set-widget-text label str))
+
+(defmethod text-baseline ((self label))
+ (if (= (logand (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)
+ gfs::+ss-bitmap+)
+ gfs::+ss-bitmap+)
+ (let ((image (image self)))
+ (if image
+ (gfs:size-height (gfg:size image))
+ 0))
+ (let* ((font (font self))
+ (gc (make-instance 'gfg:graphics-context :widget self))
+ (b-width (border-width self)))
+ (+ b-width (gfg:ascent (gfg:metrics gc font))))))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon May 22 23:59:48 2006
@@ -330,6 +330,9 @@
(defgeneric text (self)
(:documentation "Returns the object's text."))
+(defgeneric text-baseline (self)
+ (:documentation "Returns the y coordinate of the object's text component, if any."))
+
(defgeneric text-height (self)
(:documentation "Returns the height of the object's text field."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Mon May 22 23:59:48 2006
@@ -295,6 +295,10 @@
(defmethod show ((w widget) flag)
(gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))
+(defmethod text-baseline :before ((self widget))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod update :before ((w widget))
(if (gfs:disposed-p w)
(error 'gfs:disposed-error)))
More information about the Graphic-forms-cvs
mailing list