[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