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 -@deffn GenericFunction text self -Returns the object's text. +@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}. +@end deffn + +@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 +@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 +@ref{image} or a @ref{widget}. +@deffn Initarg :image +This initarg associates the context with an image, +thus allowing applications to draw on the image. +@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 +@deffn Initarg :widget +This initarg associates the context with a widget, +thus allowing applications to query graphics-related +attributes of the widget. +@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)))