[graphic-forms-cvs] r162 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Mon Jun 26 08:30:24 2006
New Revision: 162

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/unblocked/tiles-panel.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented and documented capture-mouse/release-mouse functions

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Mon Jun 26 08:30:24 2006
@@ -813,6 +813,17 @@
 widget must be a @ref{button} and is typically labelled @emph{Cancel}.
 @end deffn
 
+ at anchor{capture-mouse}
+ at deffn Function capture-mouse self
+Enables the @ref{window} identified by @code{self} to receive mouse
+input events even when the mouse pointer is outside of the bounds
+of @code{self}. Only one window at a time can capture the mouse. This
+function is primarily intended for use with a window in the foreground;
+background windows may still capture the mouse, but only mouse move
+events will be received and those only when the mouse hotspot is within
+the visible portions of such a window. @xref{release-mouse}.
+ at end deffn
+
 @anchor{center-on-owner}
 @deffn GenericFunction center-on-owner self
 Position @code{self} such that it is centrally located relative to its
@@ -1031,6 +1042,12 @@
 Causes the entire bounds of the object to be marked as needing to be redrawn
 @end deffn
 
+ at anchor{release-mouse}
+ at deffn Function release-mouse
+Clears the mouse capture state to restore normal mouse input processing.
+ at xref{capture-mouse}.
+ at end deffn
+
 @anchor{show}
 @deffn GenericFunction show self flag
 Causes the object to be visible or hidden on the screen, but not

Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp	(original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp	Mon Jun 26 08:30:24 2006
@@ -110,19 +110,19 @@
     (if (and (eql button :left-button) (> tile-kind 0))
       (shape-tiles tiles tile-pnt tmp-table))
     (when (> (hash-table-count tmp-table) 1)
+      (gfw:capture-mouse panel)
       (setf (shape-kind-of self) tile-kind)
       (setf (shape-pnts-of self) (shape-tile-points tmp-table))
       (draw-tiles-directly panel (shape-pnts-of self) +max-tile-kinds+))))
 
 (defmethod gfw:event-mouse-up ((self tiles-panel-events) panel time point button)
   (declare (ignore time))
+  (gfw:release-mouse)
   (let ((tile-pnt (window->tiles point))
         (shape-pnts (shape-pnts-of self)))
-    (if (and (eql button :left-button)
-               shape-pnts
-               (find tile-pnt shape-pnts :test #'eql-point))
-      (game-shape-data shape-pnts)
-      (if shape-pnts
+    (when (and (eql button :left-button) shape-pnts)
+      (if (and tile-pnt (find tile-pnt shape-pnts :test #'eql-point))
+        (game-shape-data shape-pnts)
         (draw-tiles-directly panel shape-pnts (shape-kind-of self)))))
   (setf (shape-kind-of self) 0)
   (setf (shape-pnts-of self) nil))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Mon Jun 26 08:30:24 2006
@@ -318,6 +318,7 @@
     #:background-pattern
     #:border-width
     #:bottom-margin-of
+    #:capture-mouse
     #:caret
     #:center-on-owner
     #:center-on-parent
@@ -441,6 +442,7 @@
     #:primary-p
     #:redraw
     #:redrawing-p
+    #:release-mouse
     #:remove-all
     #:remove-item
     #:remove-span

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Mon Jun 26 08:30:24 2006
@@ -141,6 +141,16 @@
             retval
             (error 'gfs::win32-error :detail "register-class failed")))))))
 
+(defun capture-mouse (self)
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error))
+  (unless (typep self 'window)
+    (error 'gfs:toolkit-error :detail "capture-mouse is restricted to window subclasses"))
+  (gfs::set-capture (gfs:handle self)))
+
+(defun release-mouse ()
+  (gfs::release-capture))
+
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro with-children ((win var) &body body)
     (let ((hwnd (gensym)))