From junrue at common-lisp.net  Sun Jul  2 18:32:28 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  2 Jul 2006 14:32:28 -0400 (EDT)
Subject: [graphic-forms-cvs] r168 - in trunk: . docs/manual src
	src/tests/uitoolkit src/uitoolkit/graphics
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060702183228.AD09B2F034@common-lisp.net>

Author: junrue
Date: Sun Jul  2 14:32:26 2006
New Revision: 168

Added:
   trunk/src/uitoolkit/widgets/font-dialog.lisp
Modified:
   trunk/docs/manual/api.texinfo
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/image-unit-tests.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/graphics/font-data.lisp
   trunk/src/uitoolkit/graphics/font.lisp
   trunk/src/uitoolkit/graphics/graphics-generics.lisp
   trunk/src/uitoolkit/graphics/image.lisp
   trunk/src/uitoolkit/system/comdlg32.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/system-types.lisp
   trunk/src/uitoolkit/widgets/file-dialog.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
implemented font-dialog, refactored font-data and font classes, implemented show-common-dialog to centralize system dialog invocation

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  2 14:32:26 2006
@@ -377,18 +377,17 @@
 @end itemize
 The @ref{with-file-dialog} macro wraps the creation of a
 @code{file-dialog} and subsequent retrieval of the file paths selected
-by the user. However, applications may choose to implements these
+by the user. However, applications may choose to implement these
 steps manually, in which case the @ref{file-dialog-paths} function can
 be used to obtain the user's selection(s). Unless the
 @code{:multiple-select} style keyword is specified, there will at most
 be one selected file returned. In either case, zero is returned if the
-user cancelled the dialog. Also, manual construction of an instance
+user cancelled the dialog. Manual construction of an instance
 must be followed by an explicit call to @ref{dispose}.@*@*
-Like other system dialogs, @code{file-dialog} is derived from @ref{widget}
-rather than @ref{dialog} since the majority of its functionality is
-implemented by the system and is not directly extensible by applications.
- at strong{NOTE:} A future release of Graphic-Forms will provide a
-customization mechanism.@*@*
+Like other system dialogs in Graphic-Forms, @code{file-dialog} is
+derived from @ref{widget} rather than @ref{dialog} since the majority
+of its functionality is implemented by the system. @strong{NOTE:} A
+future release will provide a customization mechanism.@*@*
 @deffn Initarg :default-extension
 Specifies a default extension to be appended to a file name if
 the user fails to provide one. Any embedded periods @samp{.} will
@@ -424,8 +423,7 @@
 @end deffn
 @deffn Initarg :owner
 A value is required for this initarg, and it may be either a
- at ref{window} or a @ref{dialog}. The file dialog will remain above the
-specified @code{owner} in the window system Z-order.
+ at ref{window} or a @ref{dialog}.
 @end deffn
 @deffn Initarg :style
 This initarg accepts a list of keyword symbols, as follows:
@@ -448,7 +446,7 @@
 for data to be saved.
 @item :show-hidden
 This keyword enables the dialog to display files marked @sc{hidden} by
-the system. @strong{Note:} files marked both @sc{hidden} and
+the system. @strong{NOTE:} files marked both @sc{hidden} and
 @sc{system} will not be displayed in any case. Also, be aware that
 using this keyword effectively overrides the user's preference
 settings.
@@ -462,8 +460,73 @@
 @end deffn
 @end deftp
 
+ at anchor{font-dialog}
+ at deftp Class font-dialog
+This class provides a standard dialog for choosing attributes
+of a @ref{font}, either from scratch or relative to an existing font.
+A variety of style options may be selected, including strikeout
+and font color.@*@*
+The @ref{with-font-dialog} macro wraps the creation of a @code{font-dialog}
+and provides a new font object based on the user's selections. However,
+applications may choose to implement these steps manually, in which case
+the @ref{font-dialog-results} function can be called to obtain the results
+of the user's selections. Manual construction of an instance must be followed
+by an explicit call to @ref{dispose}.@*@*
+Like other system dialogs in Graphic-Forms, @code{font-dialog} is derived
+from @ref{widget} rather than @ref{dialog} since the majority of its
+functionality is implemented by the system. @strong{NOTE:} A future release
+will provide a customization mechanism.@*
+ at deffn Initarg :gc
+This required initarg accepts a @ref{graphics-context} object providing
+context for the font selection, such as when the set of fonts to be offered
+depends on a printer device.
+ at end deffn
+ at deffn Initarg :initial-color
+This initarg accepts a @ref{color} object which the font dialog
+will use for its initial color selection (as long as the @code{:no-effects}
+style is @strong{not} set).
+ at end deffn
+ at deffn Initarg :initial-font
+This initarg accepts a @ref{font} object which the font dialog
+will use for its initial font attribute selections. If not
+specified, the dialog will be set to the system font's attributes.
+ at end deffn
+ at deffn Initarg :owner
+A value is required for this initarg, and it may be either a
+ at ref{window} or a @ref{dialog}.
+ at end deffn
+ at deffn Initarg :style
+This initarg accepts a list of keyword symbols, as follows:
+ at table @code
+ at item :all-fonts
+This is a convenience style, used by default if no other font
+criteria are specified, that enables the dialog to offer all
+possible fonts.
+ at item :fixed-pitch-fonts
+Enables the dialog to offer fixed pitch fonts.
+ at item :no-effects
+Causes the font dialog to hide the controls that
+allow the user to specify strikeout, underline, and text color
+attributes.
+ at item :printer-fonts
+Enables the dialog to offer fonts supported by the printer associated
+with the graphics-context supplied via the @code{:gc} initarg.
+ at item :screen-fonts
+Enables the dialog to offer screen fonts supported by the system.
+ at item :truetype-fonts
+Enables the dialog to offer TrueType fonts.
+ at item :wysiwyg-fonts
+Enables the dialog to offer the intersection of the sets of fonts
+available on the screen and the printer associated with the
+graphics-context specified by the @code{:gc} initarg.
+ at end table
+ at end deffn
+ at end deftp
+
 @anchor{group}
 @deftp Class group layout children location size style
+ at strong{NOTE:} this class is not yet fully implemented
+and does not yet participate in the layout protocol.@*@*
 A @code{group} represents a logical rectangular aggregation
 of @ref{window} children which has the following properties
 and behaviors:
@@ -970,11 +1033,12 @@
 @end deffn
 
 @anchor{file-dialog-paths}
- at deffn Function file-dialog-paths dlg
+ at deffn Function file-dialog-paths dlg => @sc{list}
 Interrogates the data structure associated with an instance of
 @ref{file-dialog} to obtain the paths for selected files. This return
 value is either @sc{nil} if the user cancelled the dialog, or a list
-of file @sc{namestring}s.
+of file @sc{namestring}s. Use this function when manually constructing
+a file dialog. @xref{with-file-dialog}.
 @end deffn
 
 @deffn GenericFunction focus-p self
@@ -982,6 +1046,19 @@
 otherwise.
 @end deffn
 
+ at anchor{font-dialog-results}
+ at deffn Function font-dialog-results dlg gc => @ref{font}, @ref{color}
+Interrogates the data structure associated with an instance of
+ at ref{font-dialog} to obtain the @ref{font} and @ref{color}
+corresponding to selections made by the user, and returns
+them via @sc{values}. The @code{gc} parameter should be the same
+ at ref{graphics-context} object with which the dialog was created.
+If the user cancelled the dialog, the font value will be @sc{nil}.
+Also, the color value will be @sc{nil} if the dialog was created with
+the @code{:no-effects} style keyword. Use this function when manually
+constructing a font dialog. @xref{with-font-dialog}.
+ at end deffn
+
 @deffn GenericFunction give-focus self
 Places keyboard focus on @code{self}.
 @end deffn
@@ -1173,8 +1250,18 @@
 @anchor{with-file-dialog}
 @deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body
 This macro wraps the instantiation of a standard file open/save dialog
-and the subsequent retrieval of the user's file
-selections. @xref{file-dialog}.
+and the subsequent retrieval of the user's file selections (supplied to @code{body}
+via @code{paths}). @xref{file-dialog}.
+ at end deffn
+
+ at anchor{with-font-dialog}
+ at deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body
+This macro wraps the instantiation of a standard font dialog and binds
+ at code{font} to a font object, and @code{color} to a @ref{color} object,
+corresponding to the attributes selected by the user. If the user cancels
+the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also
+be @sc{nil} if the dialog was created with the @code{:no-effects} style
+keyword. @xref{font-dialog}.
 @end deffn
 
 
@@ -1226,6 +1313,7 @@
 @strong{NOTE:} A future release will provide additional graphics
 classes.
 
+ at anchor{color}
 @deftp Structure color red green blue
 This is a structure representing a color using three bytes in the RGB colorspace.
 @end deftp
@@ -1304,6 +1392,7 @@
 may use to position graphical elements. @xref{font}.
 @end deftp
 
+ at anchor{graphics-context}
 @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.
@@ -1425,8 +1514,11 @@
 Returns a color object corresponding to the current background color.
 @end deffn
 
- at deffn GenericFunction data-obj self
-Returns the data structure representing the raw form of the object.
+ at deffn GenericFunction data-object self &optional gc => object
+Returns the data structure representing the raw data form of the
+object.  The @code{gc} argument must be supplied when calling this
+function on a @ref{font}, and the value must be a
+ at ref{graphics-context}.
 @end deffn
 
 @deffn GenericFunction depth self

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Sun Jul  2 14:32:26 2006
@@ -113,6 +113,7 @@
                        (:file "panel")
                        (:file "dialog")
                        (:file "file-dialog")
+                       (:file "font-dialog")
                        (:file "layout")
                        (:file "heap-layout")
                        (:file "flow-layout")))))))))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sun Jul  2 14:32:26 2006
@@ -140,7 +140,7 @@
     #:copy-color
     #:copy-font-data
     #:copy-font-metrics
-    #:data-obj
+    #:data-object
     #:depth
     #:descent
     #:draw-arc
@@ -231,6 +231,7 @@
     #:event-dispatcher
     #:event-source
     #:file-dialog
+    #:font-dialog
     #:flow-layout
     #:heap-layout
     #:item
@@ -393,6 +394,7 @@
     #:file-dialog-paths
     #:focus-index
     #:focus-p
+    #:font-dialog-results
     #:foreground-color
     #:give-focus
     #:grid-line-width
@@ -492,6 +494,7 @@
     #:visible-p
     #:with-children
     #:with-file-dialog
+    #:with-font-dialog
 
 ;; conditions
   ))

Modified: trunk/src/tests/uitoolkit/image-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-unit-tests.lisp	(original)
+++ trunk/src/tests/uitoolkit/image-unit-tests.lisp	Sun Jul  2 14:32:26 2006
@@ -58,7 +58,7 @@
             (assert-equal (gfs:size-width size1) (gfs:size-width size2) path)
             (assert-equal (gfs:size-height size1) (gfs:size-height size2) path))
           (gfg:load im path)
-          (setf d3 (gfg:data-obj im))
+          (setf d3 (gfg:data-object im))
           (assert-equal (gfg:depth d1) (gfg:depth d3) path)
           (let ((size1 (gfg:size d1))
                 (size2 (gfg:size d3)))

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Sun Jul  2 14:32:26 2006
@@ -118,6 +118,17 @@
                          :initial-directory #P"c:/")
     (print paths)))
 
+(defun choose-font-dlg (disp item time rect)
+  (declare (ignore disp item time rect))
+  (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*)))
+    (unwind-protect
+        (gfw:with-font-dialog (*main-win* nil font color :gc gc)
+          (if color
+            (print color))
+          (if font
+            (print (gfg:data-object font gc))))
+      (gfs:dispose gc))))
+
 (defclass dialog-events (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time)
@@ -231,16 +242,17 @@
                                                    :style '(:workspace)))
     (setf menubar (gfw:defmenu ((:item "&File"
                                  :submenu ((:item "E&xit" :callback #'windlg-exit-fn)))
+                                           (:item "&Custom Dialogs"
+                                            :submenu ((:item "&Modal"       :callback #'open-modal-dlg)
+                                                      (:item "&Modeless"    :callback #'open-modeless-dlg)))
                                            (:item "&System Dialogs"
-                                            :submenu ((:item "&Open File" :callback #'open-file-dlg)
-                                                      (:item "&Save File" :callback #'save-file-dlg)))
-                                           (:item "&User Dialogs"
-                                            :submenu ((:item "&Modal"    :callback #'open-modal-dlg)
-                                                      (:item "&Modeless" :callback #'open-modeless-dlg)))
+                                            :submenu ((:item "&Choose Font" :callback #'choose-font-dlg)
+                                                      (:item "&Open File"   :callback #'open-file-dlg)
+                                                      (:item "&Save File"   :callback #'save-file-dlg)))
                                            (:item "&Windows"
-                                            :submenu ((:item "&Borderless" :callback #'create-borderless-win)
-                                                      (:item "&Mini Frame" :callback #'create-miniframe-win)
-                                                      (:item "&Palette"    :callback #'create-palette-win))))))
+                                            :submenu ((:item "&Borderless"  :callback #'create-borderless-win)
+                                                      (:item "&Mini Frame"  :callback #'create-miniframe-win)
+                                                      (:item "&Palette"     :callback #'create-palette-win))))))
     (setf (gfw:menu-bar *main-win*) menubar)
     (gfw:show *main-win* t)))
 

Modified: trunk/src/uitoolkit/graphics/font-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/font-data.lisp	(original)
+++ trunk/src/uitoolkit/graphics/font-data.lisp	Sun Jul  2 14:32:26 2006
@@ -33,50 +33,99 @@
 
 (in-package :graphic-forms.uitoolkit.graphics)
 
-(defun compute-font-weight (style)
-  (if (null (find :bold style))
-    gfs::+fw-normal+
-    gfs::+fw-bold+))
-
-(defun compute-font-precis (style)
-  (if (find :truetype-only style)
-    (return-from compute-font-precis gfs::+out-tt-only-precis+))
-  (if (find :outline style)
-    (return-from compute-font-precis gfs::+out-outline-precis+))
-  gfs::+out-default-precis+)
-
-(defun compute-font-pitch (style)
-  (if (find :fixed style)
-    (return-from compute-font-pitch gfs::+fixed-pitch+))
-  (if (find :variable style)
-    (return-from compute-font-pitch gfs::+variable-pitch+))
-  gfs::+default-pitch+)
+(defun pntsize->lfheight (hdc pntsize)
+  (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+)))
+    (- (floor (+ (/ (* pntsize log-height) 72) 0.5)))))
 
-(defun data->font (hdc data)
-  (let ((hfont (cffi:null-pointer))
+(defun lfheight->pntsize (hdc lfheight)
+  (let ((log-height (gfs::get-device-caps hdc gfs::+logpixelsy+)))
+    (floor (* (+ (- lfheight) 0.5) 72) log-height)))
+
+(defun style->logfont (style lf-ptr)
+  (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline
+                             gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily)
+                            lf-ptr gfs::logfont)
+    (setf gfs::lfweight    (if (find :bold style)      gfs::+fw-bold+ gfs::+fw-normal+))
+    (setf gfs::lfitalic    (if (find :italic style)    1 0))
+    (setf gfs::lfunderline (if (find :underline style) 1 0))
+    (setf gfs::lfstrikeout (if (find :strikeout style) 1 0))
+    (setf gfs::lfoutprec   (cond
+                             ((find :truetype-only style) gfs::+out-tt-only-precis+)
+                             ((find :outline       style) gfs::+out-outline-precis+)
+                             (t                           gfs::+out-default-precis+)))
+    (setf gfs::lfpitchandfamily (cond
+                                  ((find :fixed style)    gfs::+fixed-pitch+)
+                                  ((find :variable style) gfs::+variable-pitch+)
+                                  (t                      gfs::+default-pitch+)))))
+
+(defun logfont->style (lf-ptr)
+  (let ((style nil))
+    (cffi:with-foreign-slots ((gfs::lfweight gfs::lfitalic gfs::lfunderline
+                               gfs::lfstrikeout gfs::lfoutprec gfs::lfpitchandfamily)
+                              lf-ptr gfs::logfont)
+      (if (= gfs::lfweight gfs::+fw-bold+)
+        (push :bold style))
+      (unless (zerop gfs::lfitalic)
+        (push :italic style))
+      (unless (zerop gfs::lfunderline)
+        (push :underline style))
+      (unless (zerop gfs::lfstrikeout)
+        (push :strikeout style))
+      (case gfs::lfoutprec
+        (#.gfs::+out-tt-only-precis+ (push :truetype-only style))
+        (#.gfs::+out-outline-precis+ (push :outline       style)))
+      (case gfs::lfpitchandfamily
+        (#.gfs::+fixed-pitch+        (push :fixed         style))
+        (#.gfs::+variable-pitch+     (push :variable      style))))
+    style))
+
+(defun data->logfont (hdc data)
+  (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont))
         (style (font-data-style data)))
-    (cffi:with-foreign-object (lf-ptr 'gfs::logfont)
-      (gfs:zero-mem lf-ptr gfs::logfont)
-      (cffi:with-foreign-slots ((gfs::lfheight gfs::lfweight gfs::lfitalic gfs::lfunderline
-                                 gfs::lfstrikeout gfs::lfcharset gfs::lfoutprec
-                                 gfs::lfpitchandfamily gfs::lffacename)
-                                lf-ptr gfs::logfont)
-        (setf gfs::lfheight (- (floor (+ (/ (* (font-data-point-size data)
-                                               (gfs::get-device-caps hdc gfs::+logpixelsy+))
-                                            72)
-                                         0.5))))
-        (setf gfs::lfweight (compute-font-weight style))
-        (setf gfs::lfitalic (if (null (find :italic style)) 0 1))
-        (setf gfs::lfunderline (if (null (find :underline style)) 0 1))
-        (setf gfs::lfstrikeout (if (null (find :strikeout style)) 0 1))
-        (setf gfs::lfcharset (font-data-char-set data))
-        (setf gfs::lfoutprec (compute-font-precis style))
-        (setf gfs::lfpitchandfamily (compute-font-pitch style))
-        (cffi:with-foreign-string (str (font-data-face-name data))
-          (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename)))
-            (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+))
-            (setf (cffi:mem-aref lffacename-ptr  :char (1- gfs::+lf-facesize+)) 0))))
-      (setf hfont (gfs::create-font-indirect lf-ptr))
-      (if (gfs:null-handle-p hfont)
-        (error 'gfs:win32-error :detail "create-font-indirect failed")))
+    (gfs:zero-mem lf-ptr gfs::logfont)
+    (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont)
+      (setf gfs::lfheight (pntsize->lfheight hdc (font-data-point-size data)))
+      (setf gfs::lfcharset (font-data-char-set data))
+      (style->logfont style lf-ptr)
+      (cffi:with-foreign-string (str (font-data-face-name data))
+        (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename)))
+          (gfs::strncpy lffacename-ptr str (1- gfs::+lf-facesize+))
+          (setf (cffi:mem-aref lffacename-ptr :char (1- gfs::+lf-facesize+)) 0))))
+    lf-ptr))
+
+(defun logfont->data (hdc lf-ptr)
+  (let ((char-set 0)
+        (face-name "")
+        (point-size 0)
+        (style nil))
+    (cffi:with-foreign-slots ((gfs::lfheight gfs::lfcharset gfs::lffacename) lf-ptr gfs::logfont)
+      (setf point-size (lfheight->pntsize hdc gfs::lfheight))
+      (setf char-set gfs::lfcharset)
+      (setf style (logfont->style lf-ptr))
+      (let ((lffacename-ptr (cffi:foreign-slot-pointer lf-ptr 'gfs::logfont 'gfs::lffacename)))
+        (setf face-name (cffi:foreign-string-to-lisp lffacename-ptr))))
+    (gfg:make-font-data :char-set char-set
+                        :face-name face-name
+                        :point-size point-size
+                        :style style)))
+
+(defun data->font (hdc data)
+  (let ((hfont (cffi:null-pointer)))
+    (setf hfont (gfs::create-font-indirect (data->logfont hdc data)))
+    (if (gfs:null-handle-p hfont)
+      (error 'gfs:win32-error :detail "create-font-indirect failed"))
     hfont))
+
+(defun font->data (hdc hfont)
+  (cffi:with-foreign-object (lf-ptr 'gfs::logfont)
+    (gfs:zero-mem lf-ptr gfs::logfont)
+    (if (zerop (gfs::get-object hfont (cffi:foreign-type-size 'gfs::logfont) lf-ptr))
+      (error 'gfs:win32-error :detail "get-object failed"))
+    (logfont->data hdc lf-ptr)))
+
+(defmethod print-object ((self font-data) stream)
+  (print-unreadable-object (self stream :type t)
+    (format stream "face name: ~a " (font-data-face-name self))
+    (format stream "point size: ~d " (font-data-point-size self))
+    (format stream "style: ~a " (font-data-style self))
+    (format stream "char-set: ~d" (font-data-char-set self))))

Modified: trunk/src/uitoolkit/graphics/font.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/font.lisp	(original)
+++ trunk/src/uitoolkit/graphics/font.lisp	Sun Jul  2 14:32:26 2006
@@ -37,12 +37,17 @@
 ;;; methods
 ;;;
 
-(defmethod gfs:dispose ((fn font))
-  (let ((hgdi (gfs:handle fn)))
+(defmethod data-object ((self font) &optional gc)
+  (if (or (gfs:disposed-p self) (gfs:disposed-p gc))
+    (error 'gfs:disposed-error))
+  (font->data (gfs:handle gc) (gfs:handle self)))
+
+(defmethod gfs:dispose ((self font))
+  (let ((hgdi (gfs:handle self)))
     (unless (gfs:null-handle-p hgdi)
       (gfs::delete-object hgdi)))
-  (setf (slot-value fn 'gfs:handle) nil))
+  (setf (slot-value self 'gfs:handle) nil))
 
-(defmethod initialize-instance :after ((font font) &key gc data &allow-other-keys)
+(defmethod initialize-instance :after ((self font) &key gc data &allow-other-keys)
   (if gc
-    (setf (slot-value font 'gfs:handle) (data->font (gfs:handle gc) data))))
+    (setf (slot-value self 'gfs:handle) (data->font (gfs:handle gc) data))))

Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp	Sun Jul  2 14:32:26 2006
@@ -36,7 +36,7 @@
 (defgeneric background-color (self)
   (:documentation "Returns a color object corresponding to the current background color."))
 
-(defgeneric data-obj (self)
+(defgeneric data-object (self &optional gc)
   (:documentation "Returns the data structure representing the raw form of the object."))
 
 (defgeneric depth (self)

Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp	(original)
+++ trunk/src/uitoolkit/graphics/image.lisp	Sun Jul  2 14:32:26 2006
@@ -72,15 +72,16 @@
       (gfs::delete-object hgdi)))
   (setf (slot-value im 'gfs:handle) nil))
 
-(defmethod data-obj ((im image))
-  (when (gfs:disposed-p im)
+(defmethod data-object ((self image) &optional gc)
+  (declare (ignore gc))
+  (when (gfs:disposed-p self)
     (error 'gfs:disposed-error))
-  (image->data (gfs:handle im)))
+  (image->data (gfs:handle self)))
 
-(defmethod (setf data-obj) ((id image-data) (im image))
-  (unless (gfs:disposed-p im)
-    (gfs:dispose im))
-  (setf (slot-value im 'gfs:handle) (data->image id)))
+(defmethod (setf data-object) ((id image-data) (self image))
+  (unless (gfs:disposed-p self)
+    (gfs:dispose self))
+  (setf (slot-value self 'gfs:handle) (data->image id)))
 
 (defmethod initialize-instance :after ((image image) &key file size &allow-other-keys)
   (cond
@@ -108,7 +109,7 @@
 (defmethod load ((im image) path)
   (let ((data (make-instance 'image-data)))
     (load data path)
-    (setf (data-obj im) data)
+    (setf (data-object im) data)
     data))
 
 (defmethod size ((image image))

Modified: trunk/src/uitoolkit/system/comdlg32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/comdlg32.lisp	(original)
+++ trunk/src/uitoolkit/system/comdlg32.lisp	Sun Jul  2 14:32:26 2006
@@ -39,6 +39,11 @@
 (load-foreign-library "comdlg32.dll")
 
 (defcfun
+  ("ChooseFontA" choose-font)
+  BOOL
+  (struct LPTR))
+
+(defcfun
   ("CommDlgExtendedError" comm-dlg-extended-error)
   DWORD)
 

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Sun Jul  2 14:32:26 2006
@@ -142,6 +142,35 @@
 (defconstant +cderr-nohook+                #x000b)
 (defconstant +cderr-registermsgfail+       #x000C)
 
+(defconstant +cf-screenfonts+          #x00000001)
+(defconstant +cf-printerfonts+         #x00000002)
+(defconstant +cf-both+                 #x00000003)
+(defconstant +cf-showhelp+             #x00000004)
+(defconstant +cf-enablehook+           #x00000008)
+(defconstant +cf-enabletemplate+       #x00000010)
+(defconstant +cf-enabletemplatehandle+ #x00000020)
+(defconstant +cf-inittologfontstruct+  #x00000040)
+(defconstant +cf-usestyle+             #x00000080)
+(defconstant +cf-effects+              #x00000100)
+(defconstant +cf-apply+                #x00000200)
+(defconstant +cf-ansionly+             #x00000400)
+(defconstant +cf-scriptsonly+          #x00000400)
+(defconstant +cf-novectorfonts+        #x00000800)
+(defconstant +cf-nooemfonts+           #x00000800)
+(defconstant +cf-nosimulations+        #x00001000)
+(defconstant +cf-limitsize+            #x00002000)
+(defconstant +cf-fixedpitchonly+       #x00004000)
+(defconstant +cf-wysiwyg+              #x00008000)
+(defconstant +cf-forcefontexist+       #x00010000)
+(defconstant +cf-scalableonly+         #x00020000)
+(defconstant +cf-ttonly+               #x00040000)
+(defconstant +cf-nofacesel+            #x00080000)
+(defconstant +cf-nostylesel+           #x00100000)
+(defconstant +cf-nosizesel+            #x00200000)
+(defconstant +cf-selectscript+         #x00400000)
+(defconstant +cf-noscriptsel+          #x00800000)
+(defconstant +cf-novertfonts+          #x01000000)
+
 (defconstant +cferr-choosefontcodes+       #x2000)
 (defconstant +cferr-nofonts+               #x2001)
 (defconstant +cferr-maxlessthanmin+        #x2002)

Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp	(original)
+++ trunk/src/uitoolkit/system/system-types.lisp	Sun Jul  2 14:32:26 2006
@@ -127,6 +127,23 @@
   (biclrused DWORD)
   (biclrimp DWORD))
 
+(defcstruct choosefont
+  (structsize DWORD)
+  (howner     HANDLE)
+  (hdc        HANDLE)
+  (logfont    LPTR)
+  (pointsize  INT)
+  (flags      DWORD)
+  (color      COLORREF)
+  (data       LPARAM)
+  (hookfn     LPTR)  ; FIXME: not yet used, but eventually should be CFHookProc
+  (templname  :string)
+  (hinstance  HANDLE)
+  (style      :string)
+  (fonttype   WORD)
+  (minsize    INT)
+  (maxsize    INT))
+
 (defcstruct drawtextparams
   (cbsize UINT)
   (tablength INT)

Modified: trunk/src/uitoolkit/widgets/file-dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/file-dialog.lisp	(original)
+++ trunk/src/uitoolkit/widgets/file-dialog.lisp	Sun Jul  2 14:32:26 2006
@@ -74,12 +74,12 @@
 ;;; methods
 ;;;
 
-(defmethod compute-style-flags ((dlg file-dialog) &rest extra-data)
+(defmethod compute-style-flags ((self file-dialog) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior gfs::+ofn-dontaddtorecent+ gfs::+ofn-hidereadonly+
                            gfs::+ofn-notestfilecreate+ gfs::+ofn-overwriteprompt+
                            gfs::+ofn-explorer+)))
-    (loop for sym in (style-of dlg)
+    (loop for sym in (style-of self)
           do (cond
                ((eq sym :add-to-recent)
                   (setf std-flags (logand std-flags (lognot gfs::+ofn-dontaddtorecent+))))
@@ -91,8 +91,8 @@
                   (setf std-flags (logior std-flags gfs::+ofn-forceshowhidden+)))))
     (values std-flags 0)))
 
-(defmethod gfs:dispose ((dlg file-dialog))
-  (let ((ofn-ptr (gfs:handle dlg)))
+(defmethod gfs:dispose ((self file-dialog))
+  (let ((ofn-ptr (gfs:handle self)))
     (unless (cffi:null-pointer-p ofn-ptr)
       (cffi:with-foreign-slots ((gfs::ofnfile gfs::ofnfilter gfs::ofntitle
                                  gfs::ofninitialdir gfs::ofndefext)
@@ -106,9 +106,9 @@
         (unless (cffi:null-pointer-p gfs::ofndefext)
           (cffi:foreign-free gfs::ofndefext)))
       (cffi:foreign-free ofn-ptr)
-      (setf (slot-value dlg 'gfs:handle) (cffi:null-pointer)))))
+      (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))))
 
-(defmethod initialize-instance :after ((dlg file-dialog) &key default-extension filters initial-directory initial-filename owner style text)
+(defmethod initialize-instance :after ((self file-dialog) &key default-extension filters initial-directory initial-filename owner style text)
   ;; FIXME: implement an OFNHookProc to process CDN_SELCHANGE
   ;; so that the file buffer can be resized as needed for
   ;; multi-select mode.
@@ -137,7 +137,7 @@
         (gfs::strncpy file-buffer tmp-str 1023))
       (setf (cffi:mem-ref file-buffer :char) 0))
     (multiple-value-bind (std-style ex-style)
-        (compute-style-flags dlg)
+        (compute-style-flags self)
       (cffi:with-foreign-slots ((gfs::ofnsize gfs::ofnhwnd gfs::ofnhinst gfs::ofnfilter
                                  gfs::ofncustomfilter gfs::ofnmaxcustfilter gfs::ofnfilterindex
                                  gfs::ofnfile gfs::ofnmaxfile gfs::ofnfiletitle gfs::ofnmaxfiletitle
@@ -168,12 +168,11 @@
               gfs::ofnpvreserved    (cffi:null-pointer)
               gfs::ofndwreserved    0
               gfs::ofnexflags       ex-style)))
-    (setf (slot-value dlg 'gfs:handle) ofn-ptr)
-    (setf (slot-value dlg 'open-mode) (find :open style))))
+    (setf (slot-value self 'gfs:handle) ofn-ptr)
+    (setf (slot-value self 'open-mode) (find :open style))))
 
-(defmethod show ((dlg file-dialog) flag)
+(defmethod show ((self file-dialog) flag)
   (declare (ignore flag))
-  (let ((ofn-ptr (gfs:handle dlg))
-        (fn (if (open-mode dlg) #'gfs::get-open-filename #'gfs::get-save-filename)))
-    (if (and (zerop (funcall fn ofn-ptr)) (/= (gfs::comm-dlg-extended-error) 0))
-      (error 'gfs:comdlg-error :detail "file dialog function failed"))))
+  (if (open-mode self)
+    (show-common-dialog self #'gfs::get-open-filename)
+    (show-common-dialog self #'gfs::get-save-filename)))

Added: trunk/src/uitoolkit/widgets/font-dialog.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/font-dialog.lisp	Sun Jul  2 14:32:26 2006
@@ -0,0 +1,144 @@
+;;;;
+;;;; font-dialog.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 
+;;;;     1. Redistributions of source code must retain the above copyright
+;;;;        notice, this list of conditions and the following disclaimer.
+;;;; 
+;;;;     2. Redistributions in binary form must reproduce the above copyright
+;;;;        notice, this list of conditions and the following disclaimer in the
+;;;;        documentation and/or other materials provided with the distribution.
+;;;; 
+;;;;     3. Neither the names of the authors nor the names of its contributors
+;;;;        may be used to endorse or promote products derived from this software
+;;;;        without specific prior written permission.
+;;;; 
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED.  IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.widgets)
+
+(defconstant +font-dialog-flags+ (logior gfs::+cf-effects+ gfs::+cf-inittologfontstruct+))
+
+;;;
+;;; helper functions
+;;;
+
+(defun font-dialog-results (dlg gc)
+  (if (or (gfs:disposed-p dlg) (gfs:disposed-p gc))
+    (error 'gfs:disposed-error))
+  (cffi:with-foreign-slots ((gfs::logfont gfs::color) (gfs:handle dlg) gfs::choosefont)
+    (values (make-instance 'gfg:font :handle (gfs::create-font-indirect gfs::logfont))
+            (gfg::rgb->color gfs::color))))
+
+(defun lookup-default-font ()
+  (let ((lf-ptr (cffi:foreign-alloc 'gfs::logfont)))
+    (gfs:zero-mem lf-ptr gfs::logfont)
+    (gfs::get-object (gfs::get-stock-object gfs::+system-font+)
+                     (cffi:foreign-type-size 'gfs::logfont)
+                     lf-ptr)
+    lf-ptr))
+
+(defmacro with-font-dialog ((owner style font color &key gc initial-color initial-font) &body body)
+  (let ((dlg (gensym)))
+   `(let ((,font nil)
+          (,color nil)
+          (,dlg (make-instance 'font-dialog
+                               :gc ,gc
+                               :initial-color ,initial-color
+                               :initial-font ,initial-font
+                               :owner ,owner
+                               :style ,style)))
+      (unwind-protect
+          (progn
+            (unless (zerop (show ,dlg t))
+              (multiple-value-bind (f c) (font-dialog-results ,dlg ,gc)
+                (setf ,font f)
+                (setf ,color c))
+              , at body))
+        (gfs:dispose ,dlg)))))
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((self font-dialog) &rest extra-data)
+  (declare (ignore extra-data))
+  (let ((std-flags (logior gfs::+cf-both+ +font-dialog-flags+)))
+    (loop for sym in (style-of self)
+          do (ecase sym
+               ;; primary styles
+               ;;
+               (:all-fonts
+                 (setf std-flags (logior gfs::+cf-both+ +font-dialog-flags+)))
+               (:fixed-pitch-fonts
+                 (setf std-flags (logior gfs::+cf-fixedpitchonly+ +font-dialog-flags+)))
+               (:printer-fonts
+                 (setf std-flags (logior gfs::+cf-printerfonts+ +font-dialog-flags+)))
+               (:screen-fonts
+                 (setf std-flags (logior gfs::+cf-screenfonts+ +font-dialog-flags+)))
+               (:truetype-fonts
+                 (setf std-flags (logior gfs::+cf-ttonly+ +font-dialog-flags+)))
+               (:wsyiwyg-fonts
+                 (setf std-flags (logior gfs::+cf-both+
+                                         gfs::+cf-scalableonly+
+                                         gfs::+cf-wysiwyg+
+                                         +font-dialog-flags+)))
+
+               ;; styles that can be combined
+               ;;
+               (:no-effects
+                 (setf std-flags (logand std-flags (lognot gfs::+cf-effects+))))))
+    (values std-flags 0)))
+
+(defmethod gfs:dispose ((self font-dialog))
+  (let ((cf-ptr (gfs:handle self)))
+    (unless (cffi:null-pointer-p cf-ptr)
+      (cffi:with-foreign-slots ((gfs::logfont) cf-ptr gfs::choosefont)
+        (unless (cffi:null-pointer-p gfs::logfont)
+          (cffi:foreign-free gfs::logfont)))
+      (cffi:foreign-free cf-ptr)))
+  (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
+
+(defmethod initialize-instance :after ((self font-dialog) &key gc initial-color initial-font owner &allow-other-keys)
+  (if (null gc)
+    (error 'gfs:toolkit-error :detail ":gc initarg is required"))
+  (if (null owner)
+    (error 'gfs:toolkit-error :detail ":owner initarg is required"))
+  (if (gfs:disposed-p owner)
+    (error 'gfs:disposed-error))
+  (let ((cf-ptr (cffi:foreign-alloc 'gfs::choosefont))
+        (lf-ptr (if initial-font
+                  (gfg::data->logfont (gfs:handle gc) (gfg:data-object initial-font gc))
+                  (lookup-default-font))))
+    (multiple-value-bind (std-style ex-style) (compute-style-flags self)
+      (declare (ignore ex-style))
+      (cffi:with-foreign-slots ((gfs::structsize gfs::howner gfs::hdc gfs::logfont
+                                 gfs::flags gfs::color)
+                                cf-ptr gfs::choosefont)
+        (setf gfs::structsize (cffi:foreign-type-size 'gfs::choosefont)
+              gfs::howner     (gfs:handle owner)
+              gfs::hdc        (gfs:handle gc)
+              gfs::logfont    lf-ptr
+              gfs::flags      std-style
+              gfs::color      (if initial-color (gfg:color->rgb initial-color) 0))))
+    (setf (slot-value self 'gfs:handle) cf-ptr)))
+
+(defmethod show ((self font-dialog) flag)
+  (declare (ignore flag))
+  (show-common-dialog self #'gfs::choose-font))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Sun Jul  2 14:32:26 2006
@@ -130,6 +130,9 @@
     :initform t))
   (:documentation "This class represents the standard file open/save dialog."))
 
+(defclass font-dialog (widget) ()
+  (:documentation "This class represents the standard font dialog."))
+
 (defclass widget-with-items (widget)
   ((items
     :accessor items

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Sun Jul  2 14:32:26 2006
@@ -107,6 +107,13 @@
           (error 'gfs:win32-error :detail "create-window failed"))
         hwnd))))
 
+(defun show-common-dialog (dlg dlg-func)
+  (let* ((struct-ptr (gfs:handle dlg))
+         (retval (funcall dlg-func struct-ptr)))
+    (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error))))
+      (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func))))
+    retval))
+
 (defun get-widget-text (w)
   (if (gfs:disposed-p w)
     (error 'gfs:disposed-error))


From junrue at common-lisp.net  Mon Jul  3 01:08:13 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  2 Jul 2006 21:08:13 -0400 (EDT)
Subject: [graphic-forms-cvs] r169 - in trunk: docs/manual
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060703010813.7974F16033@common-lisp.net>

Author: junrue
Date: Sun Jul  2 21:08:12 2006
New Revision: 169

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/dialog.lisp
   trunk/src/uitoolkit/widgets/thread-context.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
implemented keyboard navigation for windows and modeless dialogs

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  2 21:08:12 2006
@@ -679,31 +679,37 @@
 boundaries of the window.
 @end deffn
 @deffn Initarg :style
-The :style initarg is a list of keywords that define the overall
+The @code{:style} initarg is a list of keywords that define the overall
 look-and-feel of the window being created. Applications may choose
-from one of the following primary style keywords:
+from one of the following primary styles:
 @table @code
 @item :borderless
-a window with a one-pixel border (so not really @emph{borderless} in the
-strictest sense); no frame icon, system menu, minimize/maximize buttons,
-or close buttons; the system does not paint the background
+Specifies a window with a one-pixel border (so not really @emph{borderless}
+in the strictest sense); no frame icon, system menu, minimize/maximize
+buttons, or close buttons; the system does not paint the background.
 @item :frame
-the standard top-level frame style with system menu, close box, and
-minimize/maximize buttons; this window type is resizable; it differs
+Specifies the standard top-level frame style with system menu, close box,
+and minimize/maximize buttons; this window type is resizable; it differs
 from the @code{:workspace} style in that the application is completely
-responsible for painting the contents
+responsible for painting the contents.
 @item :miniframe
-a resizable window with a shorter than normal caption; has a close box
-but no system menu or minimize/maximize buttons; the system does not
-paint the background
+Specifies a resizable window with a shorter than normal caption; has a
+close box but no system menu or minimize/maximize buttons; the system
+does not paint the background.
 @item :palette
-similar to the @code{:miniframe} style, but in this case the window
-does not have a resize frame; the system does not paint the background
+Similar to the @code{:miniframe} style, except that this style also
+restricts the window from having a resize frame.
 @item :workspace
-the standard top-level frame style with system menu, close box, and
-minimize/maximize buttons; this window type is resizable; it differs
+Specifies the standard top-level frame style with system menu, close box,
+and minimize/maximize buttons; this window type is resizable; it differs
 from the @code{:frame} style in that the system paints the background
-using the @sc{color_appworkspace} color scheme
+using the @sc{color_appworkspace} Win32 color scheme.
+ at end table
+The following style keyword(s) may also be included:
+ at table @code
+ at item :keyboard-navigation
+Enables keyboard traversal of controls within the @code{window} as if
+it were a @ref{dialog}.
 @end table
 @end deffn
 @end deftp
@@ -716,8 +722,8 @@
 behavior of the widget; style keywords are widget-specific.
 @end deftp
 
- at anchor{widget-with-items} items
- at deftp Class widget-with-items
+ at anchor{widget-with-items}
+ at deftp Class widget-with-items items
 The widget-with-items class is the base class for objects composed of
 sub-items.  It derives from @ref{widget}. The @code{items} slot is an
 @sc{adjustable} @sc{vector} containing @ref{item} objects,
@@ -725,13 +731,27 @@
 @end deftp
 
 @anchor{window}
- at deftp Class window
+ at deftp Class window layout-p layout maximum-size minimum-size
 This is the base class for user-defined @ref{widget}s that serve as containers.
- at deffn Reader layout-p
+ at deffn Accessor layout-of
+Accepts or returns the @ref{layout-manager} associated with this
+ at code{window}.
+ at end deffn
+ at deffn Accessor maximum-size
+ at end deffn
+ at deffn Accessor minimum-size
 @end deffn
 @deffn Initarg :layout
+Accepts a @ref{layout-manager} object whose responsibility is to manage
+the direct children of this @code{window}.
 @end deffn
- at deffn Accessor layout-of
+ at deffn Reader layout-p => boolean
+Returns T if layout behavior is enabled for the @code{window};
+ at sc{nil} otherwise.
+ at end deffn
+ at deffn Initarg :maximum-size
+ at end deffn
+ at deffn Initarg :minimum-size
 @end deffn
 @end deftp
 

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Sun Jul  2 21:08:12 2006
@@ -127,7 +127,7 @@
 
 (defconstant +ccerr-choosecolorcodes+      #x5000)
 
-(defconstant +cderr-dialogfailure+         #xffff)
+(defconstant +cderr-dialogfailure+         #xFFFF)
 (defconstant +cderr-generalcodes+          #x0000)
 (defconstant +cderr-structsize+            #x0001)
 (defconstant +cderr-initialization+        #x0002)
@@ -138,8 +138,8 @@
 (defconstant +cderr-loadresfailure+        #x0007)
 (defconstant +cderr-lockresfailure+        #x0008)
 (defconstant +cderr-memallocfailure+       #x0009)
-(defconstant +cderr-memlockfailure+        #x000a)
-(defconstant +cderr-nohook+                #x000b)
+(defconstant +cderr-memlockfailure+        #x000A)
+(defconstant +cderr-nohook+                #x000B)
 (defconstant +cderr-registermsgfail+       #x000C)
 
 (defconstant +cf-screenfonts+          #x00000001)

Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp	(original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp	Sun Jul  2 21:08:12 2006
@@ -168,6 +168,7 @@
   ;;
   (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window))
     (setf owner nil))
+  (push :keyboard-navigation (style-of self))
   ;; FIXME: check if owner is actually a top-level or dialog, and if not,
   ;; walk up the ancestors until one is found. Only top level hwnds can
   ;; be owners.

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Sun Jul  2 21:08:12 2006
@@ -50,6 +50,7 @@
    (next-widget-id            :initform 100 :reader next-widget-id)
    (size-event-size           :initform (gfs:make-size) :accessor size-event-size)
    (widgets-by-hwnd           :initform (make-hash-table :test #'equal))
+   (kbdnav-widgets            :initform nil :accessor kbdnav-widgets)
    (timers-by-id              :initform (make-hash-table :test #'equal))
    (top-level-visitor-func    :initform nil :accessor top-level-visitor-func)
    (top-level-visitor-results :initform nil :accessor top-level-visitor-results)
@@ -149,6 +150,31 @@
   "Store the widget currently under construction."
   (setf (slot-value tc 'wip) nil))
 
+(defmethod put-kbdnav-widget ((tc thread-context) (widget widget))
+  (if (find :keyboard-navigation (style-of widget))
+    (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc)))))
+
+(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget))
+  (setf (kbdnav-widgets tc)
+        (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd))
+                   (kbdnav-widgets tc)
+                   :key #'gfs:handle)))
+
+(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr)
+  (let ((widgets (kbdnav-widgets tc)))
+    (unless widgets
+      (return-from intercept-kbdnav-message nil))
+    (let ((widget (first widgets)))
+      (if (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0)
+        (return-from intercept-kbdnav-message widget))
+      (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr)))
+                            (rest widgets)))
+      (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0))
+        (let ((tmp (remove-kbdnav-widget tc widget)))
+          (setf (kbdnav-widgets tc) (push widget tmp)))
+        (return-from intercept-kbdnav-message widget))))
+  nil)
+
 (defmethod get-menuitem ((tc thread-context) id)
   "Returns the menu item identified by id."
   (gethash id (slot-value tc 'menuitems-by-id)))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Sun Jul  2 21:08:12 2006
@@ -81,7 +81,7 @@
 
 (defclass widget (event-source)
   ((style
-    :reader style-of
+    :accessor style-of
     :initarg :style
     :initform nil))
   (:documentation "The widget class is the base class for all windowed user interface objects."))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Sun Jul  2 21:08:12 2006
@@ -48,6 +48,8 @@
     ((= gm-code -1)
        (warn 'gfs:win32-warning :detail "get-message failed")
        t)
+    ((intercept-kbdnav-message (thread-context) msg-ptr)
+       nil)
     (t
        (translate-and-dispatch msg-ptr)
        nil)))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Jul  2 21:08:12 2006
@@ -57,6 +57,8 @@
     (let ((hwnd (gfs:handle win)))
       (if (not hwnd) ; handle slot should have been set during create-window
         (error 'gfs:win32-error :detail "create-window failed"))
+      (if (find :keyboard-navigation (style-of win))
+        (put-kbdnav-widget tc win))
       (put-widget tc win))))
 
 #+lispworks
@@ -191,6 +193,10 @@
             (gfs:size-height new-size) (- gfs::bottom gfs::top)))
     new-size))
 
+(defmethod gfs:dispose ((self window))
+  (remove-kbdnav-widget (thread-context) self)
+  (call-next-method))
+
 (defmethod enable-layout :before ((win window) flag)
   (declare (ignore flag))
   (if (gfs:disposed-p win)


From junrue at common-lisp.net  Mon Jul  3 03:54:06 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  2 Jul 2006 23:54:06 -0400 (EDT)
Subject: [graphic-forms-cvs] r170 - in trunk: docs/manual src
	src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060703035406.36E5F2E1AD@common-lisp.net>

Author: junrue
Date: Sun Jul  2 23:54:05 2006
New Revision: 170

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/unblocked/unblocked-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/system/datastructs.lisp
   trunk/src/uitoolkit/widgets/top-level.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented resizable-p, refactored minimum-size/maximum-size methods for top-level windows

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  2 23:54:05 2006
@@ -1221,6 +1221,16 @@
 @xref{capture-mouse}.
 @end deffn
 
+ at anchor{resizable-p}
+ at deffn GenericFunction resizable-p self => boolean
+Returns T if @code{self} can be resized by the user; @sc{nil}
+otherwise.  The corresponding @sc{setf} function is implemented for
+the @ref{top-level} class (but only has meaning when the @code{:frame}
+or @code{:workspace} styles are set), allowing the application to
+modify the resizability of @code{self}, whereupon the frame
+decorations are modified appropriately.
+ 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/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp	(original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp	Sun Jul  2 23:54:05 2006
@@ -201,9 +201,12 @@
                                        :dispatcher (make-instance 'tiles-panel-events
                                                                   :buffer-size tile-buffer-size)))
     (setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked")
+
+    (setf (gfw:resizable-p *unblocked-win*) nil)
     (let ((size (gfw:preferred-size *unblocked-win* -1 -1)))
       (setf (gfw:minimum-size *unblocked-win*) size)
       (setf (gfw:maximum-size *unblocked-win*) size))
+
     (new-unblocked nil nil nil nil)
     (gfw:show *unblocked-win* t)))
 

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sun Jul  2 23:54:05 2006
@@ -65,6 +65,7 @@
     #:detail
     #:dispose
     #:disposed-p
+    #:equal-size-p
     #:flatten
     #:handle
     #:location

Modified: trunk/src/uitoolkit/system/datastructs.lisp
==============================================================================
--- trunk/src/uitoolkit/system/datastructs.lisp	(original)
+++ trunk/src/uitoolkit/system/datastructs.lisp	Sun Jul  2 23:54:05 2006
@@ -46,3 +46,7 @@
 
 (defmacro size (rect)
   `(rectangle-size ,rect))
+
+(defun equal-size-p (size1 size2)
+  (and (= (size-width size1) (size-width size2))
+       (= (size-height size1) (size-height size2))))

Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp	(original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp	Sun Jul  2 23:54:05 2006
@@ -51,6 +51,24 @@
                          gfs::+cs-dblclks+
                          -1))
 
+(defun update-top-level-resizability (win same-size-flag)
+  (let* ((hwnd (gfs:handle win))
+         (orig-flags (gfs::get-window-long hwnd gfs::+gwl-style+))
+         (new-flags 0))
+    (cond
+      (same-size-flag
+         (setf new-flags (logand orig-flags (lognot gfs::+ws-maximizebox+)))
+         (setf new-flags (logand new-flags (lognot gfs::+ws-thickframe+))))
+      (t
+         (setf new-flags (logior orig-flags gfs::+ws-maximizebox+))
+         (setf new-flags (logior new-flags gfs::+ws-thickframe+))))
+    (when (/= orig-flags new-flags)
+      (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags)
+      (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+
+                                                                    gfs::+swp-nomove+
+                                                                    gfs::+swp-nosize+
+                                                                    gfs::+swp-nozorder+)))))
+
 ;;;
 ;;; methods
 ;;;
@@ -132,6 +150,10 @@
       (setf register-func #'register-toplevel-erasebkgnd-window-class))
     (init-window win classname register-func owner text)))
 
+(defmethod (setf maximum-size) :after (max-size (self top-level))
+  (when (and max-size (minimum-size self))
+    (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size))))
+
 (defmethod menu-bar :before ((win top-level))
   (if (gfs:disposed-p win)
     (error 'gfs:disposed-error)))
@@ -161,6 +183,10 @@
     (gfs::set-menu hwnd (gfs:handle m))
     (gfs::draw-menu-bar hwnd)))
 
+(defmethod (setf minimum-size) :after (min-size (self top-level))
+  (when (and (maximum-size self) min-size)
+    (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self)))))
+
 (defmethod print-object ((self top-level) stream)
   (print-unreadable-object (self stream :type t)
     (format stream "handle: ~x " (gfs:handle self))
@@ -169,17 +195,26 @@
     (format stream "min size: ~a " (minimum-size self))
     (format stream "max size: ~a" (maximum-size self))))
 
-(defmethod text :before ((win top-level))
-  (if (gfs:disposed-p win)
+(defmethod resizable-p ((self top-level))
+  (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+    (= (logand bits gfs::+ws-thickframe+) gfs::+ws-thickframe+)))
+
+(defmethod (setf resizable-p) (flag (self top-level))
+  (let ((style (style-of self)))
+    (if (or (find :frame style) (find :workspace style))
+      (update-top-level-resizability self (not flag)))))
+
+(defmethod text :before ((self top-level))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod text ((win top-level))
-  (get-widget-text win))
+(defmethod text ((self top-level))
+  (get-widget-text self))
 
-(defmethod (setf text) :before (str (win top-level))
+(defmethod (setf text) :before (str (self top-level))
   (declare (ignore str))
-  (if (gfs:disposed-p win)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod (setf text) (str (win top-level))
-  (set-widget-text win str))
+(defmethod (setf text) (str (self top-level))
+  (set-widget-text self str))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sun Jul  2 23:54:05 2006
@@ -246,39 +246,46 @@
     (format stream "handle: ~x " (gfs:handle self))
     (format stream "dispatcher: ~a " (dispatcher self))))
 
-(defmethod redraw :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod redraw :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod redraw ((w widget))
-  (let ((hwnd (gfs:handle w)))
+(defmethod redraw ((self widget))
+  (let ((hwnd (gfs:handle self)))
     (unless (gfs:null-handle-p hwnd)
       (gfs::invalidate-rect hwnd nil 1))))
 
-(defmethod selected-p :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod resizable-p :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod selected-p ((w widget))
-  (declare (ignore w))
+(defmethod resizable-p ((self widget))
   nil)
 
-(defmethod size :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod selected-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod selected-p ((self widget))
+  (declare (ignore self))
+  nil)
+
+(defmethod size :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod size ((w widget))
-  (client-size w))
+(defmethod size ((self widget))
+  (client-size self))
 
-(defmethod (setf size) :before ((size gfs:size) (w widget))
+(defmethod (setf size) :before ((size gfs:size) (self widget))
   (declare (ignore size))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod (setf size) ((size gfs:size) (w widget))
-  (if (gfs:disposed-p w)
+(defmethod (setf size) ((size gfs:size) (self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error))
-  (if (zerop (gfs::set-window-pos (gfs:handle w)
+  (if (zerop (gfs::set-window-pos (gfs:handle self)
                                    (cffi:null-pointer)
                                    0 0
                                    (gfs:size-width size)
@@ -287,13 +294,13 @@
     (error 'gfs:win32-error :detail "set-window-pos failed"))
   size)
 
-(defmethod show :before ((w widget) flag)
+(defmethod show :before ((self widget) flag)
   (declare (ignore flag))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod show ((w widget) flag)
-  (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))
+(defmethod show ((self widget) flag)
+  (gfs::show-window (gfs:handle self) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))
 
 (defmethod text-baseline :before ((self widget))
   (if (gfs:disposed-p self)


From junrue at common-lisp.net  Mon Jul  3 05:25:20 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon,  3 Jul 2006 01:25:20 -0400 (EDT)
Subject: [graphic-forms-cvs] r171 - trunk/src/demos/unblocked
Message-ID: <20060703052520.8C2ED7E052@common-lisp.net>

Author: junrue
Date: Mon Jul  3 01:25:20 2006
New Revision: 171

Modified:
   trunk/src/demos/unblocked/about.bmp
Log:
finished unblocked about dialog image

Modified: trunk/src/demos/unblocked/about.bmp
==============================================================================
Binary files. No diff available.


From junrue at common-lisp.net  Mon Jul  3 16:31:38 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon,  3 Jul 2006 12:31:38 -0400 (EDT)
Subject: [graphic-forms-cvs] r172 - in trunk: . docs/manual
	src/uitoolkit/widgets
Message-ID: <20060703163138.69FD34904C@common-lisp.net>

Author: junrue
Date: Mon Jul  3 12:31:37 2006
New Revision: 172

Modified:
   trunk/README.txt
   trunk/docs/manual/api.texinfo
   trunk/src/uitoolkit/widgets/menu-language.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
Log:
refactored menu item/submenu/separator convenience functions and fixed behavior of :disabled in menu language

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Mon Jul  3 12:31:37 2006
@@ -61,18 +61,13 @@
    has not been tested with all of them. Therefore, images may not
    display properly, expecially when a transparency is selected.
 
-3. The event-tester application's menu definition specifies that the
-   Test Menu | Submenu | Item A  item should be disabled but it does
-   not get disabled. However, the GFW:ENABLE function does otherwise
-   work correctly for menu items.
-
-4. The src/demos/unblocked directory contains a start at a demo
+3. The src/demos/unblocked directory contains a start at a demo
    program (a simple game where one clicks on block shapes to
    score points, where the rest of the blocks fall down to fill
    in the gaps). This demo program is not yet finished, but the
    source code can still serve as sample code.
 
-5. The text-extent generic function currently does not return
+4. The text-extent generic function currently does not return
    the correct text height. As a workaround, get the text metrics
    for the desired font and base height calculations on that
    value. The text-extent function does return the correct width.

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Mon Jul  3 12:31:37 2006
@@ -939,9 +939,11 @@
 Returns T if ancestor is an ancestor of descendant; nil otherwise.
 @end deffn
 
- at deffn GenericFunction append-item self text image dispatcher
-Adds the new item with the specified text to the object, and returns
-the newly-created item.
+ at deffn GenericFunction append-item self text image dispatcher &optional disabled checked
+Adds the new item with the specified @code{text}, @code{image}, and
+ at ref{event-dispatcher} to the object, and returns the newly-created item.
+The optional @code{checked} and @code{disabled} arguments can be used
+to set the item's initial state.
 @end deffn
 
 @deffn GenericFunction append-separator self
@@ -949,8 +951,10 @@
 item.
 @end deffn
 
- at deffn GenericFunction append-submenu self text submenu dispatcher
-Adds a submenu anchored to a parent menu and returns the corresponding item.
+ at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked
+Adds a submenu anchored to a parent menu and returns the corresponding
+menu item. The optional @code{checked} and @code{disabled} arguments can
+be used to set the menu item's initial state.
 @end deffn
 
 @deffn GenericFunction cancel-widget self

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Mon Jul  3 12:31:37 2006
@@ -196,21 +196,16 @@
     (push m (menu-stack-of gen))))
 
 (defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image)
-  (let* ((owner (first (menu-stack-of gen)))
-         (item (append-item owner label image dispatcher)))
-    (enable item (not disabled))
-    (check item checked)))
+  (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked))
 
 (defmethod define-separator ((gen win32-menu-generator))
   (let ((owner (first (menu-stack-of gen))))
     (append-separator owner)))
 
 (defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
-  (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))
-         (parent (first (menu-stack-of gen)))
-         (item (append-submenu parent label submenu dispatcher)))
-    (push submenu (menu-stack-of gen))
-    (enable item (not disabled))))
+  (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))))
+    (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled)
+    (push submenu (menu-stack-of gen))))
 
 (defmethod complete-submenu ((gen win32-menu-generator))
   (pop (menu-stack-of gen)))

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Mon Jul  3 12:31:37 2006
@@ -37,8 +37,14 @@
 ;;; helper functions
 ;;;
 
-(defun insert-menuitem (hmenu mid label hbmp)
-  (cffi:with-foreign-string (str-ptr label)
+(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked)
+  (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items
+  (let ((info-mask (logior gfs::+miim-id+
+                           (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+)
+                           (if hchildmenu gfs::+miim-submenu+)))
+        (info-type (if label 0 gfs::+mft-separator+))
+        (info-state (logior (if checked gfs::+mfs-checked+ 0)
+                            (if disabled gfs::+mfs-disabled+ 0))))
     (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
       (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
                                  gfs::state gfs::id gfs::hsubmenu
@@ -46,69 +52,23 @@
                                  gfs::idata gfs::tdata gfs::cch
                                  gfs::hbmpitem)
                                 mii-ptr gfs::menuiteminfo)
-        (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
-        (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+))
-        (setf gfs::type 0)
-        (setf gfs::state 0)
-        (setf gfs::id mid)
-        (setf gfs::hsubmenu (cffi:null-pointer))
-        (setf gfs::hbmpchecked (cffi:null-pointer))
-        (setf gfs::hbmpunchecked (cffi:null-pointer))
-        (setf gfs::idata 0)
-        (setf gfs::tdata str-ptr)
-        (setf gfs::cch (length label))
-        (setf gfs::hbmpitem hbmp))
-      (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
-        (error 'gfs::win32-error :detail "insert-menu-item failed")))))
-
-(defun insert-submenu (hparent mid label hbmp hchildmenu)
-  (cffi:with-foreign-string (str-ptr label)
-    (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
-      (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
-                                 gfs::state gfs::id gfs::hsubmenu
-                                 gfs::hbmpchecked gfs::hbmpunchecked
-                                 gfs::idata gfs::tdata gfs::cch
-                                 gfs::hbmpitem)
-                                mii-ptr gfs::menuiteminfo)
-        (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
-        (setf gfs::mask (logior gfs::+miim-id+
-                                   gfs::+miim-string+
-                                   gfs::+miim-submenu+))
-        (setf gfs::type 0)
-        (setf gfs::state 0)
-        (setf gfs::id mid)
-        (setf gfs::hsubmenu hchildmenu)
-        (setf gfs::hbmpchecked (cffi:null-pointer))
-        (setf gfs::hbmpunchecked (cffi:null-pointer))
-        (setf gfs::idata 0)
-        (setf gfs::tdata str-ptr)
-        (setf gfs::cch (length label))
-        (setf gfs::hbmpitem hbmp))
-      (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
-        (error 'gfs::win32-error :detail "insert-menu-item failed")))))
-
-(defun insert-separator (hmenu mid)
-  (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
-    (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
-                               gfs::state gfs::id gfs::hsubmenu
-                               gfs::hbmpchecked gfs::hbmpunchecked
-                               gfs::idata gfs::tdata gfs::cch
-                               gfs::hbmpitem)
-                              mii-ptr gfs::menuiteminfo)
-      (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
-      (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+))
-      (setf gfs::type gfs::+mft-separator+)
-      (setf gfs::state 0)
-      (setf gfs::id mid)
-      (setf gfs::hsubmenu (cffi:null-pointer))
-      (setf gfs::hbmpchecked (cffi:null-pointer))
-      (setf gfs::hbmpunchecked (cffi:null-pointer))
-      (setf gfs::idata 0)
-      (setf gfs::tdata (cffi:null-pointer))
-      (setf gfs::cch 0)
-      (setf gfs::hbmpitem (cffi:null-pointer)))
-    (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
-      (error 'gfs::win32-error :detail "insert-menu-item failed"))))
+        (setf gfs::cbsize        (cffi:foreign-type-size 'gfs::menuiteminfo)
+              gfs::mask          info-mask
+              gfs::type          info-type
+              gfs::state         info-state
+              gfs::id            mid
+              gfs::hsubmenu      hchildmenu
+              gfs::hbmpchecked   (cffi:null-pointer)
+              gfs::hbmpunchecked (cffi:null-pointer)
+              gfs::idata         0
+              gfs::tdata         (cffi:null-pointer))
+        (if label
+          (cffi:with-foreign-string (str-ptr label)
+            (setf gfs::tdata str-ptr)
+            (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
+              (error 'gfs::win32-error :detail "insert-menu-item failed")))
+          (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
+            (error 'gfs::win32-error :detail "insert-menu-item failed")))))))
 
 (defun sub-menu (m index)
   (if (gfs:disposed-p m)
@@ -130,13 +90,13 @@
 ;;; methods
 ;;;
 
-(defmethod append-item ((owner menu) text image disp)
+(defmethod append-item ((owner menu) text image disp &optional disabled checked)
   (declare (ignore image)) ; FIXME: temporary measure until we support images in menu items
   (let* ((tc (thread-context))
          (id (increment-menuitem-id tc))
          (hmenu (gfs:handle owner))
          (item (create-menuitem-with-callback hmenu disp)))
-    (insert-menuitem hmenu id text (cffi:null-pointer))
+    (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked)
     (setf (item-id item) id)
     (put-menuitem tc item)
     (vector-push-extend item (items owner))
@@ -149,13 +109,13 @@
          (id (increment-menuitem-id tc))
          (howner (gfs:handle owner))
          (item (make-instance 'menu-item :handle howner)))
-    (insert-separator howner id)
+    (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil)
     (setf (item-id item) id)
     (put-menuitem tc item)
     (vector-push-extend item (items owner))
     item))
 
-(defmethod append-submenu ((parent menu) text (submenu menu) disp)
+(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked)
   (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu))
     (error 'gfs:disposed-error))
   (let* ((tc (thread-context))
@@ -163,7 +123,7 @@
          (hparent (gfs:handle parent))
          (hmenu (gfs:handle submenu))
          (item (make-instance 'menu-item :handle hparent)))
-    (insert-submenu hparent id text (cffi:null-pointer) hmenu)
+    (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked)
     (setf (item-id item) id)
     (put-menuitem tc item)
     (vector-push-extend item (items parent))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Mon Jul  3 12:31:37 2006
@@ -45,13 +45,13 @@
 (defgeneric ancestor-p (ancestor descendant)
   (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise."))
 
-(defgeneric append-item (self text image dispatcher)
+(defgeneric append-item (self text image dispatcher &optional checked disabled)
   (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
 
 (defgeneric append-separator (self)
   (:documentation "Add a separator item to the object, and returns the newly-created item."))
 
-(defgeneric append-submenu (self text submenu dispatcher)
+(defgeneric append-submenu (self text submenu dispatcher &optional checked disabled)
   (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
 
 (defgeneric border-width (self)

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Mon Jul  3 12:31:37 2006
@@ -33,8 +33,8 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher))
-  (declare (ignore text image disp))
+(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
+  (declare (ignore text image disp checked disabled))
   (if (gfs:disposed-p w)
     (error 'gfs:disposed-error)))
 


From junrue at common-lisp.net  Mon Jul  3 18:40:35 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon,  3 Jul 2006 14:40:35 -0400 (EDT)
Subject: [graphic-forms-cvs] r173 - in trunk/docs: manual website
Message-ID: <20060703184035.03A8A1D007@common-lisp.net>

Author: junrue
Date: Mon Jul  3 14:40:32 2006
New Revision: 173

Added:
   trunk/docs/website/gradient.png   (contents, props changed)
Modified:
   trunk/docs/manual/overview.texinfo
   trunk/docs/website/index.html
   trunk/docs/website/style.css
Log:
doc update in preparation for 0.4.0 release

Modified: trunk/docs/manual/overview.texinfo
==============================================================================
--- trunk/docs/manual/overview.texinfo	(original)
+++ trunk/docs/manual/overview.texinfo	Mon Jul  3 14:40:32 2006
@@ -11,35 +11,26 @@
 @chapter Overview
 
 Graphic-Forms is a user interface library implemented in Common Lisp
-focusing on the Windows at registeredsymbol{} platform. Graphic-Forms is
-licensed under the terms of the BSD License.
+focusing on the Windows platform. Graphic-Forms is licensed under the
+terms of the BSD License.
 
-Graphic-Forms has two primary goals:
-
- at itemize @bullet
- at item
-in the short term, provide a toolkit encapsulating the underlying
-window system primitives, custom controls and dialogs, and
-platform-specific features
-
- at item
-in the longer-term, implement an application framework on
-top of the toolkit -- as an analogy, consider the relationship between
-SWT and JFace in the Eclipse framework.
- at end itemize
-
-Support for multiple Common Lisp implementations is planned; see the
-project website for up-to-date information on supported vendors and
-current known issues.
-
-Why implement another UI toolkit? The niche for Graphic-Forms is that
-it emphasizes the use of Windows at registeredsymbol{} features without
-comprising functionality due to portability constraints. Applications
-that need portability across windowing systems are already served by
-projects such as McCLIM and LTK in the open-source world or the
-toolkits provided by commercial vendors. Or you might consider helping
-new portable UI projects such as wxCL. This project is aimed
-specifically at Windows at registeredsymbol{} developers.
+The goal is to provide a Lisp-based toolkit for developing GUI
+applications on Windows. Platform-specific features are encapsulated
+by a thin abstraction layer that presents a more Lisp-friendly
+interface for programmers. The library can be extended by using the
+Lisp bindings for system APIs, rather than requiring knowledge of
+some other programming language.
+
+Why implement another UI toolkit? Applications that need portability
+across windowing systems are already served by projects such as McCLIM
+or LTK or wxCL in the open-source world, or the toolkits provided by
+commercial vendors. The audience served by Graphic-Forms consists of
+GUI developers focused on the Windows platform who want to leverage
+platform features without compromises due to portability.
+
+Long-term goals for this project may include implementing an application
+framework on top of the toolkit, or a rapid UI development language, or
+a UI design tool, or some combination thereof.
 
 The remainder of this chapter provides basic information for
 programmers that want to use Graphic-Forms in their projects as well
@@ -50,9 +41,30 @@
 changes unless and until the interfaces are deemed stable, at which
 time a policy for backwards compatibility will be published.
 
-The main project website: @*
+
+ at section Project Website
+
 @url{http://common-lisp.net/project/graphic-forms}
 
+
+ at section Supported Lisp Implementations
+
+Graphic-Forms is currently developed and tested with:
+
+ at itemize @bullet
+ at item CLISP 2.38
+ at item LispWorks 4.4.6
+ at end itemize
+
+
+ at section Support Windows Versions
+
+ at itemize @bullet
+ at item XP SP2
+ at item Vista (testing on Beta 2 is in-progress as of this release)
+ at end itemize
+
+
 @section Dependencies
 
 The libraries that Graphic-Forms relies upon are:
@@ -109,3 +121,10 @@
 
 Please use the following patch tracking mechanism to contribute patches:
 @url{http://sourceforge.net/tracker/?group_id=163034&atid=826147}
+
+
+ at section Trademarks
+
+Windows at registeredsymbol{} is a registered trademark of Microsoft Corporation.
+LispWorks is a trademark of LispWorks Ltd. All other trademarks used are owned
+by their respective owners.

Added: trunk/docs/website/gradient.png
==============================================================================
Binary file. No diff available.

Modified: trunk/docs/website/index.html
==============================================================================
--- trunk/docs/website/index.html	(original)
+++ trunk/docs/website/index.html	Mon Jul  3 14:40:32 2006
@@ -10,7 +10,7 @@
 <body>
   <div class="header">
     <h1>Graphic-Forms</h1>
-    <h2>A user interface toolkit for the Windows&#174; platform.</h2>
+    <h2>A user interface toolkit for the Windows platform.</h2>
   </div>
 
   <div class="NavBar">
@@ -26,42 +26,51 @@
 
   <p>Graphic-Forms is a user interface library implemented in
   <a href="http://www.lisp.org">Common Lisp</a> focusing on the
-  Windows&#174; platform. Graphic-Forms is licensed under the
+  Windows platform. Graphic-Forms is licensed under the
   terms of the
   <a href="http://home.earthlink.net/~jdunrue/license.html">BSD License</a>.</p>
 
- <p>In the near term, the goal
- is to provide a toolkit encapsulating the underlying
- window system primitives, also providing custom controls and dialogs,
- and facilitating application use of platform-specific features. A
- long-term goal is to implement an application framework on top of
- the toolkit -- as an analogy, consider the relationship between SWT
- and JFace in the <a href="http://www.eclipse.org">Eclipse</a>
- framework. Support for multiple CL implementations is planned,
- but at this time development is occurring on
- <a href="http://clisp.cons.org">CLISP</a> and
- <a href="http://www.lispworks.com">LispWorks</a>&#174;.</p>
-
- <p>Why implement another UI toolkit? The niche for Graphic-Forms is
- that it emphasizes the use of Windows&#174; features without comprising
- functionality due to portability constraints. Applications that need
- portability across windowing systems are already served by projects
- such as
- <a href="http://common-lisp.net/project/mcclim/">McCLIM</a>
- and
- <a href="http://www.peter-herth.de/ltk/">LTK</a>
- in the open-source world or the toolkits provided by commercial
- vendors. Or you might consider helping new portable UI projects
- such as <a href="http://www.wxcl-project.org">wxCL</a>. <i>This
- project</i> is aimed specifically at Windows&#174; developers.</p>
+  <p>The goal is to provide a Lisp-based toolkit for developing GUI
+     applications on Windows. Platform-specific features are encapsulated
+     by a thin abstraction layer that presents a more Lisp-friendly interface
+     for programmers. The library can be extended by using the Lisp
+     bindings for system APIs, rather than requiring knowledge of some other
+     programming language.</p>
+  <p>Why implement another UI toolkit? Applications that need portability
+     across windowing systems are already served by projects such as
+     <a href="http://common-lisp.net/project/mcclim/">McCLIM</a>
+     or
+     <a href="http://www.peter-herth.de/ltk/">LTK</a>
+     or
+     <a href="http://www.wxcl-project.org">wxCL</a>
+     in the open-source world, or the toolkits provided by commercial
+     vendors. The audience served by Graphic-Forms consists of GUI
+     developers focused on the Windows platform who want to leverage
+     platform features without compromises due to portability.
+  <p>Long-term goals for this project may include implementing an application
+     framework on top of the toolkit, or a rapid UI development language, or a
+     UI design tool, or some combination thereof.</p>
 
  <h3>Status</h3>
 
- <p>The current release is version 0.3.0.</p>
+ <p>The current release is
+    <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">version 0.4.0</a>.
+    This library is in the alpha stage of development, which means that new
+    features are still being added and existing features require considerable
+    testing. Brave souls who experiment with the code should expect significant
+    API and behavior changes for at least several more releases.</p>
 
- <p>This library is in the early implementation stage. Brave souls who
- experiment with the code should expect significant API and
- behavior changes in the preliminary releases leading up to the 1.0 release.</p>
+ <p>The supported Lisp implementations are:
+ <ul>
+   <li><a href="http://clisp.cons.org/">CLISP 2.38</a></li>
+   <li><a href="http://www.lispworks.com/">LispWorks 4.4.6</a></li>
+ </ul>
+
+ <p>The supported Windows versions are:
+ <ul>
+   <li>XP SP2</li>
+   <li>Vista <i>(in progress, testing on Beta 2 currently underway)</i></li>
+ </ul>
 
  <h3 id="mailinglists">Mailing Lists</h3>
  <ul>
@@ -76,10 +85,15 @@
     graphic-forms-announce</a><br>for announcements</li>
  </ul>
 
-  <div class="footer">
-    <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a>
-    Copyright &#169; 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>
-  </div>
+ <p><b>Trademarks</b><br>
+    Windows&#174; is a registered trademark of <a href="http://www.microsoft.com/">Microsoft</a>.
+    LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other
+    trademarks used are owned by their respective owners.</p>
+
+ <div class="footer">
+   <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a>
+   Copyright &#169; 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>
+ </div>
 
 <!--
   <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a>

Modified: trunk/docs/website/style.css
==============================================================================
--- trunk/docs/website/style.css	(original)
+++ trunk/docs/website/style.css	Mon Jul  3 14:40:32 2006
@@ -1,11 +1,10 @@
 
 .header {
         font-size: medium;
-        background-color:#336699;
-        color:#ffffff;
-        border-style:solid;
-        border-width: 5px;
-        border-color:#002244;
+        color:#fafa00;
+        background-image: url("gradient.png");
+        background-repeat: repeat-fixed;
+        background-attachment: fixed;
         padding: 1mm 1mm 1mm 5mm;
 }
 
@@ -13,11 +12,10 @@
         font-size: small;
         font-style: italic;
         text-align: right;
-        background-color:#336699;
-        color:#ffffff;
-        border-style:solid;
-        border-width: 2px;
-        border-color:#002244;
+        color:#fafa00;
+        background-image: url("gradient.png");
+        background-repeat: repeat-fixed;
+        background-attachment: fixed;
         padding: 1mm 1mm 1mm 1mm;
 }
 


From junrue at common-lisp.net  Mon Jul  3 23:22:32 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon,  3 Jul 2006 19:22:32 -0400 (EDT)
Subject: [graphic-forms-cvs] r174 - trunk
Message-ID: <20060703232232.7EDD7431C8@common-lisp.net>

Author: junrue
Date: Mon Jul  3 19:22:32 2006
New Revision: 174

Added:
   trunk/NEWS.txt
Modified:
   trunk/README.txt
Log:
more doc updates for 0.4.0

Added: trunk/NEWS.txt
==============================================================================
--- (empty file)
+++ trunk/NEWS.txt	Mon Jul  3 19:22:32 2006
@@ -0,0 +1,97 @@
+
+Release 0.4.0 of Graphic-Forms, a Common Lisp library for Windows GUI
+programming, is now available. This is an alpha release, meaning that
+the feature set and API have not yet stabilized.
+
+Here is what's new in this release:
+
+. CFFI snapshot 060606 or later is required in order to benefit from a
+bugfix for a problem when running on LispWorks where foreign structure
+contents could be corrupted; the most obvious symptom of this was a
+Win32 error encountered when attempting to create a window.
+
+. A new layout manager called `heap-layout' has been implemented.  Its
+purpose is to align all the children of a container in a single
+Z-orderwise stack and allow the application to select which of the
+children are top-most at any given time. This is useful when
+implemnenting windows with panels containing related functionality,
+where only one such panel should be visible at a time (e.g., property
+sheets or wizard dialogs).
+
+. This release provides access to the standard font dialog, and
+integrates with the previously-defined font and font-data classes.
+
+. Application-defined modal and modeless dialogs are now fully
+supported, including keyboard navigation (tab traversal, default
+button invocation via the ENTER key, and cancel button invocation via
+the ESC key).
+
+. In this release, the flow-layout manager gets a new style called
+:normalize which instructs the manager to size children equally using
+the maximum dimension of the children's preferred sizes opposite to
+the dimension in which the layout is oriented.
+
+. Applications may set minimum size and/or maximum size constraints
+for top-level windows. Setting both constraints to the same size
+implicitly disables resizing by the user.
+
+. It is also possible to explicitly disable resizabilty, which not
+only results in a fixed window size but also causes window decorations
+to be updated appropriately (no maximize box and no resize handles in
+the window frame).
+
+. The button class has been expanded to support checkboxes, radio
+buttons, toggle buttons, and tri-state button controls.
+
+. There is now basic support for instantiating single-line and
+multi-line edit controls. Edit controls participate in the focus gain
+/ focus loss protocol; they also provide notification when contents
+change via the event-modify generic function.
+
+. Implemented event-focus-gain and event-focus-loss to allow applications
+to response to changes in focus.
+
+. It is now possible to customize the background color, foreground
+color, and font of label controls. Infrastructure to support similar
+customizations for other controls is in place.
+
+. Functions capture-mouse and release-mouse are available to implement
+mouse capturing behavior.
+
+. Added a function to programmatically append separators to menus;
+this was already possible via DEFMENU but not yet supported for
+dynamic menu management.
+
+. Rewrote timer event processing such that the library no longer uses
+the TimerProc callback technique, but instead each call to the Win32
+SetTimer function is made with the handle to a hidden utility window
+managed by the library code.
+
+. Changed the rectangle type to be a structure; it was a class before.
+
+. Started work on infrastructure required to support a new layout
+manager called `group-layout' which will appear in a subsequent
+release. The infrastructure developed this time includes definition of
+a text-baseline method that widgets implement to help layout managers
+align text appropriately.
+
+. Also started work on infrastructure needed to enable WinXP-themed
+controls.
+
+. Continued work on the UnBlocked demo game.
+
+The above list is in addition to documentation enhancements and
+bug fixes. The README.txt file in the release zip file also has
+additional important information about this release.
+
+Download the release zip file here:
+http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.4.0.zip?download
+
+The project website is:
+http://common-lisp.net/project/graphic-forms/
+
+Jack Unrue
+jdunrue (at) gmail (dot) com
+July 3rd 2006
+
+==============================================================================

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Mon Jul  3 19:22:32 2006
@@ -18,7 +18,7 @@
  - Cells
    http://common-lisp.net/project/cells/
 
- - CFFI 0.9.0
+ - CFFI (cffi-060606 or later)
    http://common-lisp.net/project/cffi/
 
  - lw-compat
@@ -62,9 +62,9 @@
    display properly, expecially when a transparency is selected.
 
 3. The src/demos/unblocked directory contains a start at a demo
-   program (a simple game where one clicks on block shapes to
-   score points, where the rest of the blocks fall down to fill
-   in the gaps). This demo program is not yet finished, but the
+   program in the form of a simple game where one clicks on block
+   shapes to score points, and the rest of the blocks fall down to
+   fill in the gaps. This demo program is not yet finished, but the
    source code can still serve as sample code.
 
 4. The text-extent generic function currently does not return


From junrue at common-lisp.net  Mon Jul  3 23:32:35 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon,  3 Jul 2006 19:32:35 -0400 (EDT)
Subject: [graphic-forms-cvs] r175 - tags/release-0.4.0
Message-ID: <20060703233235.A3C0B52000@common-lisp.net>

Author: junrue
Date: Mon Jul  3 19:32:35 2006
New Revision: 175

Added:
   tags/release-0.4.0/
      - copied from r174, trunk/
Log:
tagging the 0.4.0 release


From junrue at common-lisp.net  Wed Jul  5 04:18:48 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Wed,  5 Jul 2006 00:18:48 -0400 (EDT)
Subject: [graphic-forms-cvs] r176 - in trunk: . docs/manual src
	src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060705041848.7EBC31A007@common-lisp.net>

Author: junrue
Date: Wed Jul  5 00:18:46 2006
New Revision: 176

Modified:
   trunk/README.txt
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/reference.texinfo
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/dialog.lisp
   trunk/src/uitoolkit/widgets/flow-layout.lisp
   trunk/src/uitoolkit/widgets/heap-layout.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
promoted mapchildren to a widget generic function and cleaned up its semantics, and got rid of with-children at the same time

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Wed Jul  5 00:18:46 2006
@@ -1,5 +1,5 @@
 
-Graphic-Forms README for version 0.4.0
+Graphic-Forms README for version 0.5.0
 Copyright (c) 2006, Jack D. Unrue
 
 Graphic-Forms is a user interface library implemented in Common Lisp focusing

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Wed Jul  5 00:18:46 2006
@@ -1107,6 +1107,13 @@
 system. @xref{parent}.
 @end deffn
 
+ at deffn GenericFunction mapchildren self func => result-list
+Calls @code{func}, which is a function of two arguments, for each
+child of @code{self} and places @code{func}'s return value in
+ at code{result-list}. @code{func}'s two arguments are @code{self} and
+the current child.
+ at end deffn
+
 @anchor{maximum-size}
 @deffn GenericFunction maximum-size self => size
 Returns a @ref{size} object describing the largest dimensions to which

Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo	(original)
+++ trunk/docs/manual/reference.texinfo	Wed Jul  5 00:18:46 2006
@@ -126,7 +126,7 @@
 
 @titlepage
 @title Graphic-Forms Programming Reference
- at c @subtitle Version 0.4
+ at c @subtitle Version 0.5
 @c @author Jack D. Unrue
 
 @page
@@ -136,7 +136,7 @@
 
 @ifnottex
 @node Top
- at top Graphic-Forms Programming Reference (version 0.4)
+ at top Graphic-Forms Programming Reference (version 0.5)
 @insertcopying
 @end ifnottex
 

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Wed Jul  5 00:18:46 2006
@@ -423,6 +423,7 @@
     #:location
     #:lock
     #:locked-p
+    #:mapchildren
     #:maximize
     #:maximized-p
     #:maximum-size
@@ -493,7 +494,6 @@
     #:vertical-scrollbar
     #:visible-item-count
     #:visible-p
-    #:with-children
     #:with-file-dialog
     #:with-font-dialog
 

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Wed Jul  5 00:18:46 2006
@@ -172,24 +172,29 @@
 (defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
   (declare (ignore time))
   (gfw:clear-all menu)
-  (gfw:with-children (*layout-tester-win* kids)
-    (loop for k in kids
-          do (let ((it (gfw::append-item menu (gfw:text k) nil nil)))
-               (unless (null (sub-disp-class-of d))
-                 (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d))))
-               (unless (null (check-test-fn d))
-                 (gfw:check it (funcall (check-test-fn d) k)))))))
+  (gfw:mapchildren *layout-tester-win*
+                   (lambda (parent child)
+                     (declare (ignore parent))
+                     (let ((it (gfw::append-item menu (gfw:text child) nil nil)))
+                       (unless (null (sub-disp-class-of d))
+                         (setf (gfw:dispatcher it) (make-instance (sub-disp-class-of d))))
+                       (unless (null (check-test-fn d))
+                         (gfw:check it (funcall (check-test-fn d) child)))))))
+
+(defun find-victim (text)
+  (let ((victim nil))
+    (gfw:mapchildren *layout-tester-win*
+                     (lambda (parent child)
+                       (declare (ignore parent))
+                       (if (string= (gfw:text child) text)
+                         (setf victim child))))
+    victim))
 
 (defclass remove-child-dispatcher (gfw:event-dispatcher) ())  
 
 (defmethod gfw:event-select ((d remove-child-dispatcher) item time rect)
   (declare (ignorable time rect))
-  (let ((text (gfw:text item))
-        (victim nil))
-    (gfw:with-children (*layout-tester-win* kids)
-      (loop for k in kids
-            do (if (string= (gfw:text k) text)
-                 (setf victim k))))
+  (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfs:dispose victim)
       (gfw:layout *layout-tester-win*))))
@@ -198,12 +203,7 @@
 
 (defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect)
   (declare (ignorable time rect))
-  (let ((text (gfw:text item))
-        (victim nil))
-    (gfw:with-children (*layout-tester-win* kids)
-      (loop for k in kids
-            do (if (string= (gfw:text k) text)
-                 (setf victim k))))
+  (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfw:show victim (not (gfw:visible-p victim)))
       (gfw:layout *layout-tester-win*))))

Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp	(original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp	Wed Jul  5 00:18:46 2006
@@ -83,10 +83,13 @@
     (error 'gfs:disposed-error)))
 
 (defmethod cancel-widget ((self dialog))
-  (with-children (self kids)
-    (loop for kid in kids
-          until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idcancel+)
-          finally (return kid))))
+  (let ((kid nil))
+    (mapchildren self
+                 (lambda (parent child)
+                   (declare (ignore parent))
+                   (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idcancel+)
+                     (setf kid child))))
+    kid))
 
 (defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog))
   (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))
@@ -118,10 +121,13 @@
     (error 'gfs:disposed-error)))
 
 (defmethod default-widget ((self dialog))
-  (with-children (self kids)
-    (loop for kid in kids
-          until (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+) gfs::+idok+)
-          finally (return kid))))
+  (let ((kid nil))
+    (mapchildren self
+                 (lambda (parent child)
+                   (declare (ignore parent))
+                   (if (= (gfs::get-window-long (gfs:handle child) gfs::+gwlp-id+) gfs::+idok+)
+                     (setf kid child))))
+    kid))
 
 (defmethod (setf default-widget) :before ((def-widget widget) (self dialog))
   (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))

Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp	Wed Jul  5 00:18:46 2006
@@ -171,11 +171,15 @@
 ;;;
 
 (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
-  (with-children (win kids)
+  (let ((kids (mapchildren win (lambda (parent child)
+                                 (declare (ignore parent))
+                                 child))))
     (flow-container-size layout (visible-p win) kids width-hint height-hint)))
 
 (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
-  (with-children (win kids)
+  (let ((kids (mapchildren win (lambda (parent child)
+                                 (declare (ignore parent))
+                                 child))))
     (flow-container-layout layout (visible-p win) kids width-hint height-hint)))
 
 (defmethod initialize-instance :after ((layout flow-layout) &key)

Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/heap-layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/heap-layout.lisp	Wed Jul  5 00:18:46 2006
@@ -39,13 +39,13 @@
 
 (defmethod compute-size ((self heap-layout) win width-hint height-hint)
   (let ((size (gfs:make-size)))
-    (with-children (win kids)
-      (loop for kid in kids
-            do (let ((kid-size (preferred-size kid width-hint height-hint)))
-                 (setf (gfs:size-width size)  (max (gfs:size-width size)
-                                                   (gfs:size-width kid-size))
-                       (gfs:size-height size) (max (gfs:size-height size)
-                                                   (gfs:size-height kid-size))))))
+    (mapchildren win (lambda (parent kid)
+                       (declare (ignore parent))
+                       (let ((kid-size (preferred-size kid width-hint height-hint)))
+                         (setf (gfs:size-width size)  (max (gfs:size-width size)
+                                                           (gfs:size-width kid-size))
+                               (gfs:size-height size) (max (gfs:size-height size)
+                                                           (gfs:size-height kid-size))))))
     (incf (gfs:size-width size)  (+ (left-margin-of self) (right-margin-of self)))
     (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self)))
     size))
@@ -64,8 +64,9 @@
                                              vert-margin)))
          (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self)))
          (bounds (gfs:make-rectangle :size new-size :location new-pnt)))
-    (with-children (win kids)
-      (loop for kid in kids collect (cons kid bounds)))))
+    (mapchildren win (lambda (parent kid)
+                       (declare (ignore parent))
+                       (cons kid bounds)))))
 
 (defmethod perform ((self heap-layout) win width-hint height-hint)
   (let ((kids nil)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Wed Jul  5 00:18:46 2006
@@ -204,6 +204,9 @@
 (defgeneric locked-p (self)
   (:documentation "Returns T if this object's contents are locked from being modified."))
 
+(defgeneric mapchildren (self func)
+  (:documentation "Executes func for each direct child of self."))
+
 (defgeneric maximize (self flag)
   (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size)."))
 

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Wed Jul  5 00:18:46 2006
@@ -61,52 +61,35 @@
         (put-kbdnav-widget tc win))
       (put-widget tc win))))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro child-visitor-proper (hwnd lparam)
+    (let ((tc (gensym))
+          (tmp-list (gensym))
+          (child (gensym))
+          (parent (gensym))
+          (ancestor-hwnd (gensym)))
+     `(let* ((,tc (thread-context))
+             (,child (get-widget ,tc ,hwnd))
+             (,parent (get-widget ,tc (cffi:make-pointer ,lparam))))
+        (unless (or (null ,parent) (null ,child))
+          (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+))
+                (,tmp-list (child-visitor-results ,tc)))
+            (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd)
+              (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list)))))))))
+
 #+lispworks
 (fli:define-foreign-callable
   ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
   ((hwnd :pointer)
    (lparam :long))
-  (let* ((tc (thread-context))
-         (child (get-widget tc hwnd))
-         (parent (get-widget tc (cffi:make-pointer lparam))))
-    (unless (or (null parent) (null child))
-      (call-child-visitor-func tc parent child)))
+  (child-visitor-proper hwnd lparam)
   1)
 
 #+clisp
 (defun child_window_visitor (hwnd lparam)
-  (let* ((tc (thread-context))
-         (child (get-widget tc hwnd))
-         (parent (get-widget tc (cffi:make-pointer lparam))))
-    (unless (or (null child) (null parent))
-      (call-child-visitor-func tc parent child)))
+  (child-visitor-proper hwnd lparam)
   1)
 
-(defun mapchildren (win func)
-  ;;
-  ;; supplied closure should expect two parameters:
-  ;;  parent window object
-  ;;  current child widget
-  ;;
-  (let ((tc (thread-context)))
-    (setf (child-visitor-func tc) func)
-    (unwind-protect
-#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle win)))
-                                     (fli:make-pointer :symbol-name "child_window_visitor")
-                                     (cffi:pointer-address (gfs:handle win)))
-#+clisp     (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
-              (setf ptr (ffi:set-foreign-pointer
-                          (ffi:unsigned-foreign-address
-                            (cffi:pointer-address (gfs:handle win)))
-                          ptr))
-              (gfs::enum-child-windows ptr
-                                       #'child_window_visitor
-                                       (cffi:pointer-address (gfs:handle win))))
-      (setf (child-visitor-func tc) nil))
-    (let ((tmp (reverse (child-visitor-results tc))))
-      (setf (child-visitor-results tc) nil)
-      tmp)))
-
 (defun register-window-class (class-name proc-ptr style bkgcolor &optional wndextra)
   (let ((retval 0))
     (cffi:with-foreign-string (str-ptr class-name)
@@ -153,17 +136,6 @@
 (defun release-mouse ()
   (gfs::release-capture))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (defmacro with-children ((win var) &body body)
-    (let ((hwnd (gensym)))
-     `(let ((,var (mapchildren ,win (lambda (parent child)
-                                      (let ((,hwnd (gfs::get-ancestor
-                                                   (gfs:handle child)
-                                                   gfs::+ga-parent+)))
-                                        (if (cffi:pointer-eq (gfs:handle parent) ,hwnd)
-                                          (push child (child-visitor-results (thread-context)))))))))
-        , at body))))
-
 ;;;
 ;;; methods
 ;;;
@@ -242,6 +214,28 @@
     (let ((sz (client-size self)))
       (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
 
+(defmethod mapchildren ((self window) func)
+  (let ((tc (thread-context)))
+    (setf (child-visitor-func tc) func)
+    (unwind-protect
+#+lispworks
+        (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self)))
+                                 (fli:make-pointer :symbol-name "child_window_visitor")
+                                 (cffi:pointer-address (gfs:handle self)))
+#+clisp
+        (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
+              (setf ptr (ffi:set-foreign-pointer
+                          (ffi:unsigned-foreign-address
+                            (cffi:pointer-address (gfs:handle self)))
+                          ptr))
+              (gfs::enum-child-windows ptr
+                                       #'child_window_visitor
+                                       (cffi:pointer-address (gfs:handle self))))
+      (setf (child-visitor-func tc) nil))
+    (let ((tmp (reverse (child-visitor-results tc))))
+      (setf (child-visitor-results tc) nil)
+      tmp)))
+
 (defmethod (setf maximum-size) :after (max-size (self window))
   (unless (or (gfs:disposed-p self) (null (layout-of self)))
     (let ((size (constrain-new-size max-size (size self) #'min)))


From junrue at common-lisp.net  Wed Jul  5 14:55:14 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Wed,  5 Jul 2006 10:55:14 -0400 (EDT)
Subject: [graphic-forms-cvs] r177 - in trunk: . docs/manual
	src/uitoolkit/widgets
Message-ID: <20060705145514.2759121030@common-lisp.net>

Author: junrue
Date: Wed Jul  5 10:55:13 2006
New Revision: 177

Modified:
   trunk/README.txt
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/overview.texinfo
   trunk/src/uitoolkit/widgets/heap-layout.lisp
   trunk/src/uitoolkit/widgets/layout.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
Log:
added layout-managed base class, modified window and group inheritance accordingly, some initial related refactoring in the layout code

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Wed Jul  5 10:55:13 2006
@@ -15,17 +15,17 @@
  - ASDF
    http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/
 
- - Cells
-   http://common-lisp.net/project/cells/
+ - Cells (latest from CVS)
+   http://www.common-lisp.net/project/cells/
 
  - CFFI (cffi-060606 or later)
    http://common-lisp.net/project/cffi/
 
  - lw-compat
-   http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz
+   http://common-lisp.net/project/closer/downloads.html
 
  - Closer to MOP
-   http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz
+   http://common-lisp.net/project/closer/downloads.html
 
  - ImageMagick 6.2.6.5-Q16
    http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Wed Jul  5 10:55:13 2006
@@ -524,7 +524,7 @@
 @end deftp
 
 @anchor{group}
- at deftp Class group layout children location size style
+ at deftp Class group children location size style
 @strong{NOTE:} this class is not yet fully implemented
 and does not yet participate in the layout protocol.@*@*
 A @code{group} represents a logical rectangular aggregation
@@ -606,9 +606,27 @@
 @end deffn
 @end deftp
 
+ at anchor{layout-managed}
+ at deftp Class layout-managed layout layout-p
+Instances of this class employ a @ref{layout-manager} to maintain
+the positions and sizes of their children.
+ at deffn Accessor layout-of
+Accepts or returns the @ref{layout-manager} associated with this
+container.
+ at end deffn
+ at deffn Initarg :layout
+Accepts a @ref{layout-manager} object whose responsibility is to manage
+the direct children of this container.
+ at end deffn
+ at deffn Reader layout-p => boolean
+Returns T if layout behavior is enabled for this container;
+ at sc{nil} otherwise.
+ at end deffn
+ at end deftp
+
 @anchor{menu}
 @deftp Class menu
-The menu class represents a container for menu items and submenus. It
+This class represents a container for menu items and submenus. It
 derives from @ref{widget-with-items}.
 @end deftp
 
@@ -732,23 +750,12 @@
 
 @anchor{window}
 @deftp Class window layout-p layout maximum-size minimum-size
-This is the base class for user-defined @ref{widget}s that serve as containers.
- at deffn Accessor layout-of
-Accepts or returns the @ref{layout-manager} associated with this
- at code{window}.
- at end deffn
+This is the base class for user-defined @ref{widget}s that serve as containers;
+it is also a @ref{layout-managed} subclass.
 @deffn Accessor maximum-size
 @end deffn
 @deffn Accessor minimum-size
 @end deffn
- at deffn Initarg :layout
-Accepts a @ref{layout-manager} object whose responsibility is to manage
-the direct children of this @code{window}.
- at end deffn
- at deffn Reader layout-p => boolean
-Returns T if layout behavior is enabled for the @code{window};
- at sc{nil} otherwise.
- at end deffn
 @deffn Initarg :maximum-size
 @end deffn
 @deffn Initarg :minimum-size

Modified: trunk/docs/manual/overview.texinfo
==============================================================================
--- trunk/docs/manual/overview.texinfo	(original)
+++ trunk/docs/manual/overview.texinfo	Wed Jul  5 10:55:13 2006
@@ -73,14 +73,14 @@
 @item ASDF
 @url{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf}
 
- at item Cells
- at url{http://common-lisp.net/project/cells}
+ at item Cells (latest from CVS)
+ at url{http://www.common-lisp.net/project/cells/}
 
 @item CFFI
 @url{http://common-lisp.net/project/cffi}
 
 @item Closer to MOP
- at url{http://common-lisp.net/project/cl-containers/closer-mop/closer-mop_latest.tar.gz}
+ at url{http://common-lisp.net/project/closer/downloads.html}
 
 @item ImageMagick
 @url{http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-windows-dll.exe}
@@ -89,7 +89,7 @@
 @url{http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html}
 
 @item lw-compat
- at url{http://common-lisp.net/project/cl-containers/lw-compat/lw-compat_latest.tar.gz}
+ at url{http://common-lisp.net/project/closer/downloads.html}
 @end table
 
 

Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/heap-layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/heap-layout.lisp	Wed Jul  5 10:55:13 2006
@@ -68,12 +68,12 @@
                        (declare (ignore parent))
                        (cons kid bounds)))))
 
-(defmethod perform ((self heap-layout) win width-hint height-hint)
+(defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint)
   (let ((kids nil)
         (hdwp (cffi:null-pointer))
         (top (top-child-of self)))
-    (when (layout-p win)
-      (setf kids (compute-layout self win width-hint height-hint))
+    (when (layout-p container)
+      (setf kids (compute-layout self container width-hint height-hint))
       (setf hdwp (gfs::begin-defer-window-pos (length kids)))
       (loop for k in kids
             do (let* ((rect (cdr k))

Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layout.lisp	Wed Jul  5 10:55:13 2006
@@ -59,12 +59,12 @@
     (setf (top-margin-of layout) vertical-margins)
     (setf (bottom-margin-of layout) vertical-margins)))
 
-(defmethod perform ((layout layout-manager) win width-hint height-hint)
-  "Calls compute-layout for a window and then handles the actual moving and resizing of its children."
+(defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint)
+  "Calls compute-layout for a container and then handles the actual moving and resizing of its children."
   (let ((kids nil)
         (hdwp (cffi:null-pointer)))
-    (when (layout-p win)
-      (setf kids (compute-layout layout win width-hint height-hint))
+    (when (layout-p container)
+      (setf kids (compute-layout self container width-hint height-hint))
       (setf hdwp (gfs::begin-defer-window-pos (length kids)))
       (loop for k in kids
             do (let* ((rect (cdr k))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Wed Jul  5 10:55:13 2006
@@ -39,12 +39,18 @@
 (defclass event-dispatcher () ()
   (:documentation "Instances of this class receive events on behalf of user interface objects."))
 
-(defclass group ()
-  ((layout
+(defclass layout-managed ()
+  ((layout-p
+    :reader layout-p
+    :initform t)
+   (layout
     :accessor layout-of
     :initarg :layout
-    :initform nil)
-   (children
+    :initform nil))
+  (:documentation "Instances of this class employ a layout manager to organize their children."))
+
+(defclass group (layout-managed)
+  ((children
     :accessor children-of
     :initarg :children
     :initform nil)
@@ -60,7 +66,7 @@
     :accessor style-of
     :initarg :style
     :initform nil))
-  (:documentation "Instances of this class act as lightweight containers for other objects."))
+  (:documentation "Instances of this class act as logical containers for other objects."))
 
 (defclass event-source (gfs:native-object)
   ((dispatcher
@@ -143,15 +149,8 @@
 (defclass menu (widget-with-items) ()
   (:documentation "The menu class represents a container for menu items (and submenus)."))
 
-(defclass window (widget)
-  ((layout-p
-    :reader layout-p
-    :initform t)
-   (layout
-    :accessor layout-of
-    :initarg :layout
-    :initform nil)
-   (maximum-size
+(defclass window (widget layout-managed)
+  ((maximum-size
     :accessor maximum-size
     :initarg :maximum-size
     :initform nil)


From junrue at common-lisp.net  Wed Jul  5 19:37:19 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Wed,  5 Jul 2006 15:37:19 -0400 (EDT)
Subject: [graphic-forms-cvs] r178 - in trunk: . src/demos/textedit
	src/demos/unblocked src/uitoolkit/widgets
Message-ID: <20060705193719.7DC64751A1@common-lisp.net>

Author: junrue
Date: Wed Jul  5 15:37:18 2006
New Revision: 178

Added:
   trunk/src/demos/textedit/
   trunk/src/demos/textedit/about.bmp   (contents, props changed)
   trunk/src/demos/textedit/textedit-window.lisp
Modified:
   trunk/graphic-forms-tests.asd
   trunk/src/demos/unblocked/tiles-panel.lisp
   trunk/src/demos/unblocked/unblocked-window.lisp
   trunk/src/uitoolkit/widgets/heap-layout.lisp
Log:
started new demo called textedit

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Wed Jul  5 15:37:18 2006
@@ -41,6 +41,7 @@
     #:run-image-tester
     #:run-layout-tester
     #:run-windlg
+    #:textedit
     #:unblocked))
 
 (print "Graphic-Forms UI Toolkit Tests")
@@ -58,7 +59,10 @@
         :components
           ((:module "demos"
               :components
-                ((:module "unblocked"
+                ((:module "textedit"
+                  :components
+                    ((:file "textedit-window")))
+                 (:module "unblocked"
                   :components
                     ((:file "tiles")
                      (:file "unblocked-model")

Added: trunk/src/demos/textedit/about.bmp
==============================================================================
Binary file. No diff available.

Added: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- (empty file)
+++ trunk/src/demos/textedit/textedit-window.lisp	Wed Jul  5 15:37:18 2006
@@ -0,0 +1,172 @@
+;;;;
+;;;; textedit-window.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 
+;;;;     1. Redistributions of source code must retain the above copyright
+;;;;        notice, this list of conditions and the following disclaimer.
+;;;; 
+;;;;     2. Redistributions in binary form must reproduce the above copyright
+;;;;        notice, this list of conditions and the following disclaimer in the
+;;;;        documentation and/or other materials provided with the distribution.
+;;;; 
+;;;;     3. Neither the names of the authors nor the names of its contributors
+;;;;        may be used to endorse or promote products derived from this software
+;;;;        without specific prior written permission.
+;;;; 
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED.  IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.tests)
+
+(defvar *textedit-control*     nil)
+(defvar *textedit-win*         nil)
+(defvar *textedit-startup-dir* nil)
+
+(defun new-textedit-doc (disp item time rect)
+  (declare (ignore disp item time rect))
+  (if *textedit-control*
+    (setf (gfw:text *textedit-control*) "")))
+
+(defun quit-textedit (disp item time rect)
+  (declare (ignore disp item time rect))
+  (setf *textedit-control* nil)
+  (gfs:dispose *textedit-win*)
+  (setf *textedit-win* nil)
+  (gfw:shutdown 0))
+
+(defclass textedit-win-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((disp textedit-win-events) window time)
+  (declare (ignore window time))
+  (quit-textedit disp nil nil nil))
+
+(defmethod gfw:event-focus-gain ((self textedit-win-events) window time)
+  (declare (ignore window time))
+  (if *textedit-control*
+    (gfw:give-focus *textedit-control*)))
+
+(defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time)
+  (declare (ignore time))
+  (call-next-method)
+  (gfs:dispose dlg))
+
+(defun about-textedit (disp item time rect)
+  (declare (ignore disp item time rect))
+  (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*)))
+         (dlg (make-instance 'gfw:dialog :owner *textedit-win*
+                                         :dispatcher (make-instance 'textedit-about-dialog-events)
+                                         :layout (make-instance 'gfw:flow-layout
+                                                                :margins 8
+                                                                :spacing 8)
+                                         :style '(:owner-modal)
+                                         :text (concatenate 'string "About TextEdit")))
+         (label (make-instance 'gfw:label :parent dlg))
+         (text-panel (make-instance 'gfw:panel
+                                    :layout (make-instance 'gfw:flow-layout
+                                                           :margins 0
+                                                           :spacing 2
+                                                           :style '(:vertical))
+                                    :parent dlg))
+         (line1 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text "TextEdit version 0.5"))
+         (line2 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text " "))
+         (line3 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169))))
+         (line4 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text "All Rights Reserved."))
+         (line5 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text " "))
+         (line6 (make-instance 'gfw:label
+                               :parent text-panel
+                               :text " "))
+         (btn-panel (make-instance 'gfw:panel
+                                   :parent dlg
+                                   :layout (make-instance 'gfw:flow-layout
+                                                          :margins 0
+                                                          :spacing 0
+                                                          :style '(:vertical :normalize))))
+         (close-btn (make-instance 'gfw:button
+                                   :callback (lambda (disp btn time rect)
+                                               (declare (ignore disp btn time rect))
+                                               (gfs:dispose dlg))
+                                   :style '(:cancel-button)
+                                   :text "Close"
+                                   :parent btn-panel)))
+    (declare (ignore line1 line2 line3 line4 line5 line6 close-btn))
+    (unwind-protect
+        (gfg:with-image-transparency (image (gfs:make-point))
+          (setf (gfw:image label) image))
+      (gfs:dispose image))
+    (gfw:pack dlg)
+    (gfw:center-on-owner dlg)
+    (gfw:show dlg t)))
+
+(defun textedit-startup ()
+#+clisp
+  (setf *textedit-startup-dir* (ext:cd))
+#+lispworks
+  (setf *textedit-startup-dir* (hcl:get-working-directory))
+  (let ((menubar (gfw:defmenu ((:item "&File"
+                                :submenu ((:item "&New"            :callback #'new-textedit-doc)
+                                          (:item "&Open...")
+                                          (:item "&Save")
+                                          (:item "Save &As...")
+                                          (:item ""                :separator)
+                                          (:item "E&xit"           :callback #'quit-textedit)))
+                               (:item "&Edit"
+                                :submenu ((:item "&Undo")
+                                          (:item "" :separator)
+                                          (:item "Cu&t")
+                                          (:item "&Copy")
+                                          (:item "&Paste")
+                                          (:item "De&lete")
+                                          (:item "" :separator)
+                                          (:item "&Find...")
+                                          (:item "Find &Next")
+                                          (:item "&Replace...")
+                                          (:item "&Go To...")
+                                          (:item "" :separator)
+                                          (:item "Select &All")))
+                               (:item "F&ormat"
+                                :submenu ((:item "&Font...")
+                                          (:item "&Word Wrap")))
+                               (:item "&Help"
+                                :submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
+    (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)
+                                                       :layout (make-instance 'gfw:heap-layout)
+                                                       :style '(:frame)))
+    (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win*
+                                                      :style '(:multi-line
+                                                               :auto-hscroll :auto-vscroll
+                                                               :horizontal-scrollbar
+                                                               :vertical-scrollbar
+                                                               :want-return)))
+    (setf (gfw:menu-bar *textedit-win*) menubar)
+    (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500))
+    (gfw:show *textedit-win* t)))
+
+(defun textedit ()
+  (gfw:startup "TextEdit" #'textedit-startup))

Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp	(original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp	Wed Jul  5 15:37:18 2006
@@ -89,9 +89,10 @@
     (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp"
                             "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp")
           do (let ((image (make-instance 'gfg:image)))
-               (gfg:load image (complete-pathname (concatenate 'string
-                                                               "src/demos/unblocked/"
-                                                               filename)))
+               (gfg:load image (merge-pathnames (concatenate 'string
+                                                             "src/demos/unblocked/"
+                                                             filename)
+                                                (unblocked-startup-dir)))
                (setf (gethash kind table) image)
                (incf kind)))))
 

Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp	(original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp	Wed Jul  5 15:37:18 2006
@@ -43,8 +43,8 @@
 (defvar *tiles-panel*           nil)
 (defvar *unblocked-win*         nil)
 
-(defun complete-pathname (path-segment)
-  (merge-pathnames path-segment *unblocked-startup-dir*))
+(defun unblocked-startup-dir ()
+  *unblocked-startup-dir*)
 
 (defun get-tiles-panel ()
   *tiles-panel*)
@@ -107,7 +107,7 @@
 
 (defun about-unblocked (disp item time rect)
   (declare (ignore disp item time rect))
-  (let* ((image (make-instance 'gfg:image :file (complete-pathname "src/demos/unblocked/about.bmp")))
+  (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*)))
          (dlg (make-instance 'gfw:dialog :owner *unblocked-win*
                                          :dispatcher (make-instance 'unblocked-about-dialog-events)
                                          :layout (make-instance 'gfw:flow-layout
@@ -124,7 +124,7 @@
                                     :parent dlg))
          (line1 (make-instance 'gfw:label
                                :parent text-panel
-                               :text "UnBlocked version 0.4"))
+                               :text "UnBlocked version 0.5"))
          (line2 (make-instance 'gfw:label
                                :parent text-panel
                                :text " "))
@@ -160,9 +160,6 @@
       (gfs:dispose image))
     (gfw:pack dlg)
     (gfw:center-on-owner dlg)
-    ;; FIXME: Close button not getting initial focus; looks like
-    ;; labels or panels are getting it, because I can tab to the
-    ;; button with enough tabs
     (gfw:show dlg t)))
 
 (defun unblocked-startup ()

Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/heap-layout.lisp	(original)
+++ trunk/src/uitoolkit/widgets/heap-layout.lisp	Wed Jul  5 15:37:18 2006
@@ -74,6 +74,8 @@
         (top (top-child-of self)))
     (when (layout-p container)
       (setf kids (compute-layout self container width-hint height-hint))
+      (unless top
+        (setf top (car (first kids))))
       (setf hdwp (gfs::begin-defer-window-pos (length kids)))
       (loop for k in kids
             do (let* ((rect (cdr k))


From junrue at common-lisp.net  Thu Jul  6 16:19:39 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu,  6 Jul 2006 12:19:39 -0400 (EDT)
Subject: [graphic-forms-cvs] r179 - in trunk: docs/manual src
	src/demos/textedit src/uitoolkit/widgets
Message-ID: <20060706161939.3B5222D010@common-lisp.net>

Author: junrue
Date: Thu Jul  6 12:19:37 2006
New Revision: 179

Modified:
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/glossary.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/top-level.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined new generic functions for configuring auto-scrolling and scrollbars; refactored existing code that modifies native styles to use a centralized function to set the bits and then refresh the hwnd

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu Jul  6 12:19:37 2006
@@ -294,11 +294,14 @@
 Specifies that the @code{edit control} will scroll text content to the
 right by 10 characters when the user types a character at the end
 of the line. For single-line @code{edit control}s, this style is set
-by the library.
+by the library. See @ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and
+ at ref{enable-auto-scrolling}.
 @item :auto-vscroll
 Specifies that the @code{edit control} will scroll text up by a page
 when the user types @sc{enter} on the last line. This style keyword
-is only meaningful when @code{:multi-line} is also specified.
+is only meaningful when @code{:multi-line} is also specified. See
+ at ref{auto-hscroll-p}, @ref{auto-vscroll-p}, and
+ at ref{enable-auto-scrolling}.
 @item :horizontal-scrollbar
 Specifies that a horizontal scrollbar should be displayed.
 @item :mask-characters
@@ -964,6 +967,18 @@
 be used to set the menu item's initial state.
 @end deffn
 
+ at anchor{auto-hscroll-p}
+ at deffn GenericFunction auto-hscroll-p self => boolean
+Returns T if @code{self} is configured for automatic horizontal scrolling;
+ at sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}.
+ at end deffn
+
+ at anchor{auto-vscroll-p}
+ at deffn GenericFunction auto-vscroll-p self => boolean
+Returns T if @code{self} is configured for automatic vertical scrolling;
+ at sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}.
+ at end deffn
+
 @deffn GenericFunction cancel-widget self
 Returns the @ref{widget} that responds to the @sc{esc} key or
 otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this
@@ -1055,6 +1070,13 @@
 function is also used to start and stop @ref{timer}s.
 @end deffn
 
+ at anchor{enable-auto-scrolling}
+ at deffn GenericFunction enable-auto-scrolling self horizontal vertical
+Configures the object to allow (or to disable) automatic scrolling in
+the horizontal or vertical directions. See @ref{auto-hscroll-p}
+and @ref{auto-vscroll-p}.
+ at end deffn
+
 @deffn GenericFunction enable-layout self flag
 Cause the object to allow or disallow layout management.
 @end deffn
@@ -1063,6 +1085,16 @@
 Returns @sc{t} if @code{self} is enabled; @sc{nil} otherwise.
 @end deffn
 
+ at anchor{enable-scrollbars}
+ at deffn GenericFunction enable-scrollbars self horizontal vertical
+Specifying T for @code{horizontal} (@code{vertical}) reveals a
+scrollbar to attached to the right-hand (bottom) of
+ at code{self}. Specifying @sc{nil} hides the scrollbar. These flags do
+not affect scrolling behavior in @code{self} -- they only control
+scrollbar visibility. See @ref{horizontal-scrollbar-p} and
+ at ref{vertical-scrollbar-p}.
+ at end deffn
+
 @anchor{file-dialog-paths}
 @deffn Function file-dialog-paths dlg => @sc{list}
 Interrogates the data structure associated with an instance of
@@ -1094,6 +1126,12 @@
 Places keyboard focus on @code{self}.
 @end deffn
 
+ at anchor{horizontal-scrollbar-p}
+ at deffn GenericFunction horizontal-scrollbar-p self => boolean
+Returns T if @code{self} has been configured to display a horizontal
+scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
+ at end deffn
+
 @deffn GenericFunction item-index self item
 Return the zero-based index of the location of the other object in this object.
 @end deffn
@@ -1283,6 +1321,12 @@
 before this function returns.
 @end deffn
 
+ at anchor{vertical-scrollbar-p}
+ at deffn GenericFunction vertical-scrollbar-p self => boolean
+Returns T if @code{self} has been configured to display a vertical
+scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
+ at end deffn
+
 @deffn GenericFunction visible-p self
 Returns T if the object is visible (not necessarily top-most); nil otherwise.
 @end deffn

Modified: trunk/docs/manual/glossary.texinfo
==============================================================================
--- trunk/docs/manual/glossary.texinfo	(original)
+++ trunk/docs/manual/glossary.texinfo	Thu Jul  6 12:19:37 2006
@@ -26,6 +26,13 @@
 intended for more knowledgeable users and should not be the sole
 mechanism for invoking functionality. Compare with @ref{mnemonic}.
 
+ at item auto-scrolling
+ at cindex auto-scrolling
+Auto-scrolling is a feature whereby scrolling occurs
+as a side effect of user input so content can remain visible,
+thus avoiding the need to explicitly manipulate scrollbars to
+achieve the same result.
+
 @item control
 @cindex control
 A control is a system-defined window class that accepts user input

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Thu Jul  6 12:19:37 2006
@@ -49,6 +49,18 @@
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
+(defun format-textedit (disp menu time)
+  (declare (ignore disp time))
+  (gfw:check (elt (gfw:items menu) 1)
+             (and *textedit-control* (gfw:auto-hscroll-p *textedit-control*))))
+
+(defun wordwrap-textedit (disp item time rect)
+  (declare (ignore disp item time rect))
+  (when *textedit-control*
+    (let ((flag (not (gfw:auto-hscroll-p *textedit-control*))))
+      ;(gfw:enable-auto-scrolling *textedit-control* flag t)
+      (gfw:enable-scrollbars *textedit-control* flag t))))
+
 (defclass textedit-win-events (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-close ((disp textedit-win-events) window time)
@@ -150,9 +162,9 @@
                                           (:item "&Go To...")
                                           (:item "" :separator)
                                           (:item "Select &All")))
-                               (:item "F&ormat"
+                               (:item "F&ormat"                    :callback #'format-textedit
                                 :submenu ((:item "&Font...")
-                                          (:item "&Word Wrap")))
+                                          (:item "&Word Wrap"      :callback #'wordwrap-textedit)))
                                (:item "&Help"
                                 :submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
     (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Thu Jul  6 12:19:37 2006
@@ -317,6 +317,8 @@
     #:append-item
     #:append-separator
     #:append-submenu
+    #:auto-hscroll-p
+    #:auto-vscroll-p
     #:background-color
     #:background-pattern
     #:border-width
@@ -355,8 +357,10 @@
     #:display-to-object
     #:echo-char
     #:enable
+    #:enable-auto-scrolling
     #:enable-layout
     #:enable-redraw
+    #:enable-scrollbars
     #:enabled-p
     #:event-activate
     #:event-arm

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Thu Jul  6 12:19:37 2006
@@ -40,6 +40,14 @@
 ;;; methods
 ;;;
 
+(defmethod auto-hscroll-p ((self edit))
+  (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+    (= (logand bits gfs::+es-autohscroll+) gfs::+es-autohscroll+)))
+
+(defmethod auto-vscroll-p ((self edit))
+  (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+    (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+)))
+
 (defmethod compute-style-flags ((self edit) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -66,6 +74,20 @@
       (setf std-flags (logior std-flags gfs::+es-autohscroll+)))
     (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
 
+(defmethod enable-auto-scrolling ((self edit) horizontal vertical)
+  (declare (ignore horizontal vertical))
+  (error 'gfs:toolkit-error :detail "not yet implemented"))
+
+(defmethod enable-scrollbars ((self edit) horizontal vertical)
+  (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
+    (if horizontal
+      (setf bits (logior bits gfs::+ws-hscroll+))
+      (setf bits (logand bits (lognot gfs::+ws-hscroll+))))
+    (if vertical
+      (setf bits (logior bits gfs::+ws-vscroll+))
+      (setf bits (logand bits (lognot gfs::+ws-vscroll+))))
+    (update-native-style self bits)))
+
 (defmethod initialize-instance :after ((self edit) &key parent text &allow-other-keys)
   (initialize-comctl-classes gfs::+icc-standard-classes+)
   (multiple-value-bind (std-style ex-style)

Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp	(original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp	Thu Jul  6 12:19:37 2006
@@ -63,11 +63,7 @@
          (setf new-flags (logior orig-flags gfs::+ws-maximizebox+))
          (setf new-flags (logior new-flags gfs::+ws-thickframe+))))
     (when (/= orig-flags new-flags)
-      (gfs::set-window-long hwnd gfs::+gwl-style+ new-flags)
-      (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+
-                                                                    gfs::+swp-nomove+
-                                                                    gfs::+swp-nosize+
-                                                                    gfs::+swp-nozorder+)))))
+      (update-native-style win new-flags))))
 
 ;;;
 ;;; methods

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Thu Jul  6 12:19:37 2006
@@ -54,6 +54,12 @@
 (defgeneric append-submenu (self text submenu dispatcher &optional checked disabled)
   (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
 
+(defgeneric auto-hscroll-p (self)
+  (:documentation "Returns T if automatic horizontal scrolling is enabled; nil otherwise."))
+
+(defgeneric auto-vscroll-p (self)
+  (:documentation "Returns T if automatic vertical scrolling is enabled; nil otherwise."))
+
 (defgeneric border-width (self)
   (:documentation "Returns the object's border width."))
 
@@ -135,6 +141,9 @@
 (defgeneric enable (self flag)
   (:documentation "Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected."))
 
+(defgeneric enable-auto-scrolling (self horizontal vertical)
+  (:documentation "Enables or disables automatic scrolling in either dimension."))
+
 (defgeneric enable-layout (self flag)
   (:documentation "Cause the object to allow or disallow layout management."))
 
@@ -144,6 +153,9 @@
 (defgeneric enabled-p (self)
   (:documentation "Returns T if the object is enabled; nil otherwise."))
 
+(defgeneric enable-scrollbars (self horizontal vertical)
+  (:documentation "Shows or hides scrollbars for the widget in either dimension."))
+
 (defgeneric expand (self deep flag)
   (:documentation "Set the object (and optionally it's children) to the expanded or collapsed state."))
 

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Thu Jul  6 12:19:37 2006
@@ -116,6 +116,14 @@
       (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func))))
     retval))
 
+(defun update-native-style (widget bits)
+  (let ((hwnd (gfs:handle widget)))
+    (gfs::set-window-long hwnd gfs::+gwl-style+ bits)
+    (gfs::set-window-pos hwnd (cffi:null-pointer) 0 0 0 0 (logior gfs::+swp-framechanged+
+                                                                  gfs::+swp-nomove+
+                                                                  gfs::+swp-nosize+
+                                                                  gfs::+swp-nozorder+))))
+
 (defun get-widget-text (w)
   (if (gfs:disposed-p w)
     (error 'gfs:disposed-error))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Thu Jul  6 12:19:37 2006
@@ -79,12 +79,20 @@
       (error 'gfs:toolkit-error :detail "no widget for parent handle"))
     (ancestor-p ancestor parent)))
 
-(defmethod border-width :before ((widget widget))
-  (if (gfs:disposed-p widget)
+(defmethod auto-hscroll-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod auto-vscroll-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod border-width :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod border-width ((widget widget))
-  (let* ((hwnd (gfs:handle widget))
+(defmethod border-width ((self widget))
+  (let* ((hwnd (gfs:handle self))
          (bits (gfs::get-window-long hwnd gfs::+gwl-exstyle+)))
     (cond
       ((/= (logand bits gfs::+ws-ex-clientedge+) 0)
@@ -152,13 +160,18 @@
         (error 'gfs:win32-error :detail "destroy-window failed"))))
   (setf (slot-value w 'gfs:handle) nil))
 
-(defmethod enable :before ((w widget) flag)
+(defmethod enable :before ((self widget) flag)
   (declare (ignore flag))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod enable ((w widget) flag)
-  (gfs::enable-window (gfs:handle w) (if (null flag) 0 1)))
+(defmethod enable ((self widget) flag)
+  (gfs::enable-window (gfs:handle self) (if (null flag) 0 1)))
+
+(defmethod enable-auto-scrolling :before ((self widget) hscroll vscroll)
+  (declare (ignore hscroll vscroll))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
 
 (defmethod enabled-p :before ((w widget))
   (if (gfs:disposed-p w)


From junrue at common-lisp.net  Fri Jul  7 06:34:12 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri,  7 Jul 2006 02:34:12 -0400 (EDT)
Subject: [graphic-forms-cvs] r180 - in trunk/src: demos/textedit
	uitoolkit/system uitoolkit/widgets
Message-ID: <20060707063412.20A82C@common-lisp.net>

Author: junrue
Date: Fri Jul  7 02:34:12 2006
New Revision: 180

Modified:
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
some minor cleanup after a bunch of experimentation trying to use EditWordBreakProc to implement dynamically changing word wrap behavior in edit controls, which I have given up on for now

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Fri Jul  7 02:34:12 2006
@@ -49,18 +49,6 @@
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
-(defun format-textedit (disp menu time)
-  (declare (ignore disp time))
-  (gfw:check (elt (gfw:items menu) 1)
-             (and *textedit-control* (gfw:auto-hscroll-p *textedit-control*))))
-
-(defun wordwrap-textedit (disp item time rect)
-  (declare (ignore disp item time rect))
-  (when *textedit-control*
-    (let ((flag (not (gfw:auto-hscroll-p *textedit-control*))))
-      ;(gfw:enable-auto-scrolling *textedit-control* flag t)
-      (gfw:enable-scrollbars *textedit-control* flag t))))
-
 (defclass textedit-win-events (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-close ((disp textedit-win-events) window time)
@@ -162,9 +150,8 @@
                                           (:item "&Go To...")
                                           (:item "" :separator)
                                           (:item "Select &All")))
-                               (:item "F&ormat"                    :callback #'format-textedit
-                                :submenu ((:item "&Font...")
-                                          (:item "&Word Wrap"      :callback #'wordwrap-textedit)))
+                               (:item "F&ormat"
+                                :submenu ((:item "&Font...")))
                                (:item "&Help"
                                 :submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
     (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)
@@ -172,8 +159,7 @@
                                                        :style '(:frame)))
     (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win*
                                                       :style '(:multi-line
-                                                               :auto-hscroll :auto-vscroll
-                                                               :horizontal-scrollbar
+                                                               :auto-vscroll
                                                                :vertical-scrollbar
                                                                :want-return)))
     (setf (gfw:menu-bar *textedit-win*) menubar)

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Fri Jul  7 02:34:12 2006
@@ -889,6 +889,10 @@
 (defconstant +user-timer-maximum+      #x7FFFFFFF)
 (defconstant +user-timer-minimum+      #x0000000A)
 
+(defconstant +wb-left+                          0)
+(defconstant +wb-right+                         1)
+(defconstant +wb-isdelimiter+                   2)
+
 (defconstant +wm-create+                   #x0001)
 (defconstant +wm-destroy+                  #x0002)
 (defconstant +wm-move+                     #x0003)

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Fri Jul  7 02:34:12 2006
@@ -74,10 +74,6 @@
       (setf std-flags (logior std-flags gfs::+es-autohscroll+)))
     (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
 
-(defmethod enable-auto-scrolling ((self edit) horizontal vertical)
-  (declare (ignore horizontal vertical))
-  (error 'gfs:toolkit-error :detail "not yet implemented"))
-
 (defmethod enable-scrollbars ((self edit) horizontal vertical)
   (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
     (if horizontal
@@ -99,7 +95,9 @@
                                ex-style
                                (increment-widget-id (thread-context)))))
       (setf (slot-value self 'gfs:handle) hwnd)))
-  (init-control self))
+  (init-control self)
+  (if (find :auto-hscroll (style-of self))
+    (replace-edit-wordbreak-func self)))
 
 (defmethod line-count ((self edit))
   (if (gfs:disposed-p self)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Fri Jul  7 02:34:12 2006
@@ -114,8 +114,7 @@
 (defun subclass-wndproc (hwnd)
   (if (zerop (gfs::set-window-long hwnd
                                    gfs::+gwlp-wndproc+
-                                   (cffi:pointer-address
-                                   (cffi:get-callback 'subclassing_wndproc))))
+                                   (cffi:pointer-address (cffi:get-callback 'subclassing_wndproc))))
     (error 'gfs:win32-error :detail "set-window-long failed")))
 
 (defun dispatch-notification (widget wparam-hi)


From junrue at common-lisp.net  Fri Jul  7 06:35:24 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri,  7 Jul 2006 02:35:24 -0400 (EDT)
Subject: [graphic-forms-cvs] r181 - trunk/src/uitoolkit/widgets
Message-ID: <20060707063524.18634102A@common-lisp.net>

Author: junrue
Date: Fri Jul  7 02:35:23 2006
New Revision: 181

Modified:
   trunk/src/uitoolkit/widgets/edit.lisp
Log:
somehow missed a stray call to obsolete replace-edit-wordbreak-func

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Fri Jul  7 02:35:23 2006
@@ -95,9 +95,7 @@
                                ex-style
                                (increment-widget-id (thread-context)))))
       (setf (slot-value self 'gfs:handle) hwnd)))
-  (init-control self)
-  (if (find :auto-hscroll (style-of self))
-    (replace-edit-wordbreak-func self)))
+  (init-control self))
 
 (defmethod line-count ((self edit))
   (if (gfs:disposed-p self)


From junrue at common-lisp.net  Fri Jul  7 17:53:02 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri,  7 Jul 2006 13:53:02 -0400 (EDT)
Subject: [graphic-forms-cvs] r182 - in trunk: docs/manual src
	src/demos/textedit src/demos/unblocked src/tests/uitoolkit
	src/uitoolkit/widgets
Message-ID: <20060707175302.0C8487634D@common-lisp.net>

Author: junrue
Date: Fri Jul  7 13:52:59 2006
New Revision: 182

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/demos/unblocked/tiles-panel.lisp
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/widgets/label.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
created with-graphics-context macro to simplify common usage

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Fri Jul  7 13:52:59 2006
@@ -1356,6 +1356,14 @@
 keyword. @xref{font-dialog}.
 @end deffn
 
+ at anchor{with-graphics-context}
+ at deffn Macro with-graphics-context (gc &optional thing) &body body
+This macro manages a @ref{graphics-context} representing the underlying
+device context of @code{thing}, which can be a @ref{widget} or an
+ at ref{image}. If @code{thing} is not specified, then the macro creates
+a graphics-context compatible with the @ref{display}.
+ at end deffn
+
 
 @node layout functions
 @section layout functions

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Fri Jul  7 13:52:59 2006
@@ -49,6 +49,13 @@
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
+(defun textedit-font (disp item time rect)
+  (declare (ignore disp item time rect))
+  (gfw:with-graphics-context (gc *textedit-control*)
+    (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*))
+      (if font
+        (setf (gfg:font *textedit-control*) font)))))
+
 (defclass textedit-win-events (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-close ((disp textedit-win-events) window time)
@@ -151,7 +158,7 @@
                                           (:item "" :separator)
                                           (:item "Select &All")))
                                (:item "F&ormat"
-                                :submenu ((:item "&Font...")))
+                                :submenu ((:item "&Font..."        :callback #'textedit-font)))
                                (:item "&Help"
                                 :submenu ((:item "&About TextEdit" :callback #'about-textedit)))))))
     (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events)

Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp	(original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp	Fri Jul  7 13:52:59 2006
@@ -64,13 +64,11 @@
     :initform nil)))
 
 (defun draw-tiles-directly (panel shape-pnts kind)
-  (let ((gc (make-instance 'gfg:graphics-context :widget panel))
-        (image-table (tile-image-table-of (gfw:dispatcher panel))))
-    (unwind-protect
-        (loop for pnt in shape-pnts
-              do (let ((image (gethash kind image-table)))
-                   (gfg:draw-image gc image (tiles->window pnt))))
-      (gfs:dispose gc))))
+  (gfw:with-graphics-context (gc panel)
+    (let ((image-table (tile-image-table-of (gfw:dispatcher panel))))
+      (loop for pnt in shape-pnts
+            do (let ((image (gethash kind image-table)))
+                 (gfg:draw-image gc image (tiles->window pnt)))))))
 
 (defmethod dispose ((self tiles-panel-events))
   (let ((table (tile-image-table-of self)))
@@ -129,16 +127,13 @@
   (setf (shape-pnts-of self) nil))
 
 (defmethod update-buffer ((self tiles-panel-events))
-  (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self)))
-        (image-table (tile-image-table-of self)))
-    (unwind-protect
-        (progn
-          (clear-buffer self gc)
-          (map-tiles #'(lambda (pnt kind)
-                         (unless (= kind 0)
-                           (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
-                     (game-tiles)))
-      (gfs:dispose gc))))
+  (gfw:with-graphics-context (gc (image-buffer-of self))
+    (let ((image-table (tile-image-table-of self)))
+      (clear-buffer self gc)
+      (map-tiles #'(lambda (pnt kind)
+                     (unless (= kind 0)
+                       (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt))))
+                 (game-tiles)))))
 
 (defclass tiles-panel (gfw:panel) ())
 

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Fri Jul  7 13:52:59 2006
@@ -500,6 +500,7 @@
     #:visible-p
     #:with-file-dialog
     #:with-font-dialog
+    #:with-graphics-context
 
 ;; conditions
   ))

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Fri Jul  7 13:52:59 2006
@@ -120,14 +120,12 @@
 
 (defun choose-font-dlg (disp item time rect)
   (declare (ignore disp item time rect))
-  (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*)))
-    (unwind-protect
-        (gfw:with-font-dialog (*main-win* nil font color :gc gc)
-          (if color
-            (print color))
-          (if font
-            (print (gfg:data-object font gc))))
-      (gfs:dispose gc))))
+  (gfw:with-graphics-context (gc *main-win*)
+    (gfw:with-font-dialog (*main-win* nil font color :gc gc)
+      (if color
+        (print color))
+      (if font
+        (print (gfg:data-object font gc))))))
 
 (defclass dialog-events (gfw:event-dispatcher) ())
 

Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp	(original)
+++ trunk/src/uitoolkit/widgets/label.lisp	Fri Jul  7 13:52:59 2006
@@ -131,18 +131,15 @@
       (let* ((color (gfg:background-color label))
              (size (gfg:size image))
              (bounds (gfs:make-rectangle :size size))
-             (tmp-image (make-instance 'gfg:image :size size))
-             (gc (make-instance 'gfg:graphics-context :image tmp-image)))
-        (unwind-protect
-            (progn
-              (setf (gfg:background-color gc) color)
-              (let ((orig-color (gfg:foreground-color gc)))
-                (setf (gfg:foreground-color gc) color)
-                (gfg:draw-filled-rectangle gc bounds)
-                (setf (gfg:foreground-color gc) orig-color))
-              (gfg:draw-image gc image (gfs:location bounds))
-              (setf (pixel-point-of label) (gfs:copy-point tr-pnt)))
-          (gfs:dispose gc))
+             (tmp-image (make-instance 'gfg:image :size size)))
+        (with-graphics-context (gc tmp-image)
+          (setf (gfg:background-color gc) color)
+          (let ((orig-color (gfg:foreground-color gc)))
+            (setf (gfg:foreground-color gc) color)
+            (gfg:draw-filled-rectangle gc bounds)
+            (setf (gfg:foreground-color gc) orig-color))
+          (gfg:draw-image gc image (gfs:location bounds))
+          (setf (pixel-point-of label) (gfs:copy-point tr-pnt)))
         (setf image tmp-image)))
     (if (/= orig-flags flags)
       (gfs::set-window-long hwnd gfs::+gwl-style+ flags))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Fri Jul  7 13:52:59 2006
@@ -35,6 +35,22 @@
 
 (defvar *check-box-size* nil)
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-graphics-context ((gc &optional thing) &body body)
+    `(let ((,gc (cond
+                  ((null ,thing)
+                     (make-instance 'gfg:graphics-context)) ; DC compatible with display
+                  ((typep ,thing 'gfw:widget)
+                     (make-instance 'gfg:graphics-context :widget ,thing))
+                  ((typep ,thing 'gfg:image)
+                     (make-instance 'gfg:graphics-context :image ,thing))
+                  (t
+                     (error 'gfs:toolkit-error
+                            :detail (format nil "~a is an unsupported type" ,thing))))))
+       (unwind-protect
+           (progn
+             , at body)
+         (gfs:dispose ,gc)))))
 
 (defun translate-and-dispatch (msg-ptr)
   (gfs::translate-message msg-ptr)
@@ -187,17 +203,15 @@
   (let ((size (gfw:size widget))
         (b-width (border-width widget))
         (font (gfg:font widget))
-        (gc (make-instance 'gfg:graphics-context :widget widget))
         (baseline 0))
-    (unwind-protect
-        (let ((metrics (gfg:metrics gc font)))
-          (setf baseline (+ b-width
-                            top-margin
-                            (gfg:ascent metrics)
-                            (floor (- (gfs:size-height size)
-                                      (+ (gfg:ascent metrics) (gfg:descent metrics)))
-                                   2))))
-      (gfs:dispose gc))
+    (with-graphics-context (gc widget)
+      (let ((metrics (gfg:metrics gc font)))
+        (setf baseline (+ b-width
+                          top-margin
+                          (gfg:ascent metrics)
+                          (floor (- (gfs:size-height size)
+                                    (+ (gfg:ascent metrics) (gfg:descent metrics)))
+                                 2)))))
     baseline))
 
 (defun check-box-size ()


From junrue at common-lisp.net  Fri Jul  7 19:16:28 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri,  7 Jul 2006 15:16:28 -0400 (EDT)
Subject: [graphic-forms-cvs] r183 - trunk/src/uitoolkit/widgets
Message-ID: <20060707191628.37409111C9@common-lisp.net>

Author: junrue
Date: Fri Jul  7 15:16:26 2006
New Revision: 183

Modified:
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
refactored ctlcolor message handling, implemented better means for setting control fonts

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Fri Jul  7 15:16:26 2006
@@ -117,7 +117,13 @@
 
 (defmethod (setf gfg:font) (font (self control))
   (setf (font-of self) font)
+  (gfs::send-message (gfs:handle self)
+                     gfs::+wm-setfont+
+                     (cffi:pointer-address (gfs:handle font))
+                     1))
+#|
   (redraw self))
+|#
 
 (defmethod gfg:foreground-color :before ((self control))
   (if (gfs:disposed-p self)

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Fri Jul  7 15:16:26 2006
@@ -126,6 +126,21 @@
       (#.gfs::+en-setfocus+  (event-focus-gain disp widget time))
       (#.gfs::+en-update+    (event-modify     disp widget time)))))
 
+(defun process-ctlcolor-message (wparam lparam)
+  (let* ((tc (thread-context))
+         (widget (get-widget tc (cffi:make-pointer lparam)))
+         (hdc (cffi:make-pointer wparam))
+         (bkgdcolor (brush-color-of widget))
+         (textcolor (text-color-of widget))
+         (ret-val 0))
+    (when widget
+      (if bkgdcolor
+        (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor)))
+      (if textcolor
+        (gfs::set-text-color hdc (gfg:color->rgb textcolor)))
+      (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
+    ret-val))
+
 ;;;
 ;;; process-message methods
 ;;;
@@ -309,33 +324,21 @@
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam)
+  (declare (ignore hwnd))
+  (process-ctlcolor-message wparam lparam))
+
 (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam)
   (declare (ignore hwnd))
-  (let* ((tc (thread-context))
-         (widget (get-widget tc (cffi:make-pointer lparam)))
-         (hdc (cffi:make-pointer wparam))
-         (bkgdcolor (brush-color-of widget))
-         (textcolor (text-color-of widget))
-         (ret-val 0))
-    (when widget
-#|
-      ;; temporarily disabling this until I decide whether this sort
-      ;; of sanity check really makes sense (for one thing, I didn't
-      ;; expect buttons with BS_CHECKBOX or BS_RADIOBUTTON to send
-      ;; WM_CTLCOLORSTATIC, but I guess it makes sense).
-      ;;
-      (if (not (or (typep widget 'button) (typep widget 'label)))
-        (warn 'gfs:toolkit-warning :detail "incorrect widget type received WM_CTLCOLORSTATIC"))
-|#
-      (let ((font (font-of widget)))
-        (if font
-          (gfs::select-object hdc (gfs:handle font))))
-      (if bkgdcolor
-        (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor)))
-      (if textcolor
-        (gfs::set-text-color hdc (gfg:color->rgb textcolor)))
-      (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
-    ret-val))
+  (process-ctlcolor-message wparam lparam))
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
   (declare (ignore wparam))


From junrue at common-lisp.net  Fri Jul  7 22:37:46 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri,  7 Jul 2006 18:37:46 -0400 (EDT)
Subject: [graphic-forms-cvs] r184 - in trunk: . docs/manual src
	src/demos/textedit src/uitoolkit/widgets
Message-ID: <20060707223746.5219A2009@common-lisp.net>

Author: junrue
Date: Fri Jul  7 18:37:45 2006
New Revision: 184

Added:
   trunk/src/demos/textedit/textedit-document.lisp
Modified:
   trunk/docs/manual/api.texinfo
   trunk/graphic-forms-tests.asd
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined text-modified-p generic function and implemented it for edit controls; added initial model definition for textedit demo

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Fri Jul  7 18:37:45 2006
@@ -1316,6 +1316,15 @@
 the custom control will be managed by a @ref{layout-manager}.
 @end deffn
 
+ at anchor{text-modified-p}
+ at deffn GenericFunction text-modified-p self
+Returns T if the text component of @code{self} has been modified by
+the user; @sc{nil} otherwise. The corresponding @sc{setf} function
+updates the dirty state flag. This function is not implemented for all
+widgets, since in some cases there are multiple text components and in
+other cases there is no text component at all.
+ at end deffn
+
 @deffn GenericFunction update self
 Forces all outstanding paint requests for the object to be processed
 before this function returns.

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Fri Jul  7 18:37:45 2006
@@ -61,7 +61,8 @@
               :components
                 ((:module "textedit"
                   :components
-                    ((:file "textedit-window")))
+                    ((:file "textedit-document")
+                     (:file "textedit-window")))
                  (:module "unblocked"
                   :components
                     ((:file "tiles")

Added: trunk/src/demos/textedit/textedit-document.lisp
==============================================================================
--- (empty file)
+++ trunk/src/demos/textedit/textedit-document.lisp	Fri Jul  7 18:37:45 2006
@@ -0,0 +1,44 @@
+;;;;
+;;;; textedit-document.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 
+;;;;     1. Redistributions of source code must retain the above copyright
+;;;;        notice, this list of conditions and the following disclaimer.
+;;;; 
+;;;;     2. Redistributions in binary form must reproduce the above copyright
+;;;;        notice, this list of conditions and the following disclaimer in the
+;;;;        documentation and/or other materials provided with the distribution.
+;;;; 
+;;;;     3. Neither the names of the authors nor the names of its contributors
+;;;;        may be used to endorse or promote products derived from this software
+;;;;        without specific prior written permission.
+;;;; 
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED.  IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.tests)
+
+(cells:defmodel textedit-document ()
+  ((content-replaced
+    :cell :ephemeral
+    :accessor content-replaced
+    :initform (cells:c-in nil))
+   (content-modified
+    :cell :ephemeral
+    :accessor content-modified
+    :initform (cells:c-in nil))))

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Fri Jul  7 18:37:45 2006
@@ -37,10 +37,35 @@
 (defvar *textedit-win*         nil)
 (defvar *textedit-startup-dir* nil)
 
+(defun manage-textedit-file-menu (disp menu time)
+  (declare (ignore disp time))
+  (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
+
 (defun new-textedit-doc (disp item time rect)
   (declare (ignore disp item time rect))
-  (if *textedit-control*
-    (setf (gfw:text *textedit-control*) "")))
+  (when *textedit-control*
+    (setf (gfw:text *textedit-control*) "")
+    (setf (gfw:text-modified-p *textedit-control*) nil)))
+
+(defun open-textedit-doc (disp item time rect)
+  (declare (ignore disp item time rect))
+  (gfw:with-file-dialog (*textedit-win*
+                         '(:open :add-to-recent :path-must-exist)
+                         paths
+                         :filters '(("Text Files (*.txt)" . "*.txt")
+                                    ("All Files (*.*)"    . "*.*")))))
+
+(defun save-textedit-doc (disp item time rect)
+  (declare (ignore disp item time rect)))
+
+(defun save-as-textedit-doc (disp item time rect)
+  (declare (ignore disp item time rect))
+  (gfw:with-file-dialog (*textedit-win*
+                         '(:save :add-to-recent)
+                         paths
+                         :filters '(("Text Files (*.txt)" . "*.txt")
+                                    ("All Files (*.*)"    . "*.*"))
+                         :text "Save As")))
 
 (defun quit-textedit (disp item time rect)
   (declare (ignore disp item time rect))
@@ -131,16 +156,22 @@
     (gfw:center-on-owner dlg)
     (gfw:show dlg t)))
 
+(cells:defobserver content-replaced ((self textedit-document))
+  (if *textedit-control*
+    (setf (gfw:text *textedit-control*) (content-replaced self))))
+
+(cells:defobserver content-modified ((self textedit-document)))
+
 (defun textedit-startup ()
 #+clisp
   (setf *textedit-startup-dir* (ext:cd))
 #+lispworks
   (setf *textedit-startup-dir* (hcl:get-working-directory))
-  (let ((menubar (gfw:defmenu ((:item "&File"
+  (let ((menubar (gfw:defmenu ((:item "&File"                      :callback #'manage-textedit-file-menu
                                 :submenu ((:item "&New"            :callback #'new-textedit-doc)
-                                          (:item "&Open...")
-                                          (:item "&Save")
-                                          (:item "Save &As...")
+                                          (:item "&Open..."        :callback #'open-textedit-doc)
+                                          (:item "&Save"           :callback #'save-textedit-doc :disabled)
+                                          (:item "Save &As..."     :callback #'save-as-textedit-doc)
                                           (:item ""                :separator)
                                           (:item "E&xit"           :callback #'quit-textedit)))
                                (:item "&Edit"

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Fri Jul  7 18:37:45 2006
@@ -486,6 +486,7 @@
     #:text-baseline
     #:text-height
     #:text-limit
+    #:text-modified-p
     #:thumb-size
     #:tooltip-text
     #:top-child-of

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Fri Jul  7 18:37:45 2006
@@ -126,3 +126,9 @@
 
 (defmethod text-baseline ((self edit))
   (widget-text-baseline self +vertical-edit-text-margin+))
+
+(defmethod text-modified-p ((self edit))
+  (/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0))
+
+(defmethod (setf text-modified-p) (flag (self edit))
+  (gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 0) 0))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Fri Jul  7 18:37:45 2006
@@ -357,6 +357,9 @@
 (defgeneric text-limit (self)
   (:documentation "Returns the number of characters that the object's text field is capable of holding."))
 
+(defgeneric text-modified-p (self)
+  (:documentation "Returns true if the text component has been modified; nil otherwise."))
+
 (defgeneric thumb-size (self)
   (:documentation "Returns an integer representing the width (or height) of this object's thumb."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Fri Jul  7 18:37:45 2006
@@ -319,18 +319,27 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
+(defmethod (setf text-modified-p) :before (flag (self widget))
+  (declare (ignore flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod text-modified-p :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)))
 
-(defmethod update ((w widget))
-  (let ((hwnd (gfs:handle w)))
+(defmethod update ((self widget))
+  (let ((hwnd (gfs:handle self)))
     (unless (gfs:null-handle-p hwnd)
       (gfs::update-window hwnd))))
 
-(defmethod visible-p :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod visible-p :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod visible-p ((w widget))
-  (not (zerop (gfs::is-window-visible (gfs:handle w)))))
+(defmethod visible-p ((self widget))
+  (not (zerop (gfs::is-window-visible (gfs:handle self)))))


From junrue at common-lisp.net  Sat Jul  8 19:43:22 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat,  8 Jul 2006 15:43:22 -0400 (EDT)
Subject: [graphic-forms-cvs] r185 - in trunk: . src/demos/textedit
Message-ID: <20060708194322.BBB8D36014@common-lisp.net>

Author: junrue
Date: Sat Jul  8 15:43:21 2006
New Revision: 185

Modified:
   trunk/graphic-forms-tests.asd
   trunk/src/demos/textedit/textedit-document.lisp
   trunk/src/demos/textedit/textedit-window.lisp
Log:
implemented basic text file I/O

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Sat Jul  8 15:43:21 2006
@@ -60,6 +60,7 @@
           ((:module "demos"
               :components
                 ((:module "textedit"
+                  :serial t
                   :components
                     ((:file "textedit-document")
                      (:file "textedit-window")))

Modified: trunk/src/demos/textedit/textedit-document.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-document.lisp	(original)
+++ trunk/src/demos/textedit/textedit-document.lisp	Sat Jul  8 15:43:21 2006
@@ -41,4 +41,24 @@
    (content-modified
     :cell :ephemeral
     :accessor content-modified
+    :initform (cells:c-in nil))
+   (file-path
+    :accessor file-path
     :initform (cells:c-in nil))))
+
+(defvar *textedit-model* (make-instance 'textedit-document))
+
+(defun load-textedit-doc (path)
+  (let ((buffer ""))
+    (with-open-file (input path)
+      (do ((line (read-line input nil)
+                 (read-line input nil)))
+          ((null line))
+        (if (zerop (length line))
+          (setf buffer (concatenate 'string buffer (format nil "~c~c" #\Return #\Newline)))
+          (setf buffer (concatenate 'string buffer (format nil "~a~c~c" line #\Return #\Newline))))))
+    (setf (content-replaced *textedit-model*) buffer)))
+
+(defun save-textedit-doc (path buffer)
+  (with-open-file (output path :direction :output :if-exists :supersede)
+    (format output buffer)))

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Sat Jul  8 15:43:21 2006
@@ -33,41 +33,53 @@
 
 (in-package :graphic-forms.uitoolkit.tests)
 
-(defvar *textedit-control*     nil)
-(defvar *textedit-win*         nil)
-(defvar *textedit-startup-dir* nil)
+(defvar *textedit-control*      nil)
+(defvar *textedit-win*          nil)
+(defvar *textedit-startup-dir*  nil)
+
+(defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt")
+                                  ("All Files (*.*)"    . "*.*")))
 
 (defun manage-textedit-file-menu (disp menu time)
   (declare (ignore disp time))
   (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
 
-(defun new-textedit-doc (disp item time rect)
+(defun textedit-file-new (disp item time rect)
   (declare (ignore disp item time rect))
   (when *textedit-control*
     (setf (gfw:text *textedit-control*) "")
-    (setf (gfw:text-modified-p *textedit-control*) nil)))
+    (setf (gfw:text-modified-p *textedit-control*) nil)
+    (setf (file-path *textedit-model*) nil)))
 
-(defun open-textedit-doc (disp item time rect)
+(defun textedit-file-open (disp item time rect)
   (declare (ignore disp item time rect))
   (gfw:with-file-dialog (*textedit-win*
                          '(:open :add-to-recent :path-must-exist)
                          paths
-                         :filters '(("Text Files (*.txt)" . "*.txt")
-                                    ("All Files (*.*)"    . "*.*")))))
-
-(defun save-textedit-doc (disp item time rect)
-  (declare (ignore disp item time rect)))
+                         :filters *textedit-file-filters*)
+    (when paths
+      (load-textedit-doc (first paths))
+      (setf (file-path *textedit-model*) (namestring (first paths))))))
+
+(defun textedit-file-save (disp item time rect)
+  (if (file-path *textedit-model*)
+    (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*))
+    (textedit-file-save-as disp item time rect))
+  (setf (gfw:text-modified-p *textedit-control*) nil))
 
-(defun save-as-textedit-doc (disp item time rect)
+(defun textedit-file-save-as (disp item time rect)
   (declare (ignore disp item time rect))
   (gfw:with-file-dialog (*textedit-win*
                          '(:save :add-to-recent)
                          paths
-                         :filters '(("Text Files (*.txt)" . "*.txt")
-                                    ("All Files (*.*)"    . "*.*"))
-                         :text "Save As")))
+                         :filters *textedit-file-filters*
+                         :text "Save As")
+    (when paths
+      (save-textedit-doc (first paths) (gfw:text *textedit-control*))
+      (setf (file-path *textedit-model*) (namestring (first paths)))
+      (setf (gfw:text-modified-p *textedit-control*) nil))))
 
-(defun quit-textedit (disp item time rect)
+(defun textedit-file-quit (disp item time rect)
   (declare (ignore disp item time rect))
   (setf *textedit-control* nil)
   (gfs:dispose *textedit-win*)
@@ -85,7 +97,7 @@
 
 (defmethod gfw:event-close ((disp textedit-win-events) window time)
   (declare (ignore window time))
-  (quit-textedit disp nil nil nil))
+  (textedit-file-quit disp nil nil nil))
 
 (defmethod gfw:event-focus-gain ((self textedit-win-events) window time)
   (declare (ignore window time))
@@ -162,18 +174,23 @@
 
 (cells:defobserver content-modified ((self textedit-document)))
 
+(cells:defobserver file-path ((self textedit-document))
+  (if *textedit-win*
+    (setf (gfw:text *textedit-win*) (format nil "~s - GraphicForms TextEdit" (file-path self)))
+    (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit")))
+
 (defun textedit-startup ()
 #+clisp
   (setf *textedit-startup-dir* (ext:cd))
 #+lispworks
   (setf *textedit-startup-dir* (hcl:get-working-directory))
   (let ((menubar (gfw:defmenu ((:item "&File"                      :callback #'manage-textedit-file-menu
-                                :submenu ((:item "&New"            :callback #'new-textedit-doc)
-                                          (:item "&Open..."        :callback #'open-textedit-doc)
-                                          (:item "&Save"           :callback #'save-textedit-doc :disabled)
-                                          (:item "Save &As..."     :callback #'save-as-textedit-doc)
+                                :submenu ((:item "&New"            :callback #'textedit-file-new)
+                                          (:item "&Open..."        :callback #'textedit-file-open)
+                                          (:item "&Save"           :callback #'textedit-file-save :disabled)
+                                          (:item "Save &As..."     :callback #'textedit-file-save-as)
                                           (:item ""                :separator)
-                                          (:item "E&xit"           :callback #'quit-textedit)))
+                                          (:item "E&xit"           :callback #'textedit-file-quit)))
                                (:item "&Edit"
                                 :submenu ((:item "&Undo")
                                           (:item "" :separator)
@@ -202,6 +219,7 @@
                                                                :want-return)))
     (setf (gfw:menu-bar *textedit-win*) menubar)
     (setf (gfw:size *textedit-win*) (gfs:make-size :width 500 :height 500))
+    (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit")
     (gfw:show *textedit-win* t)))
 
 (defun textedit ()


From junrue at common-lisp.net  Sun Jul  9 06:35:40 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  9 Jul 2006 02:35:40 -0400 (EDT)
Subject: [graphic-forms-cvs] r186 - in trunk: docs/manual src
	src/demos/textedit src/demos/unblocked src/tests/uitoolkit
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060709063540.4153D111C9@common-lisp.net>

Author: junrue
Date: Sun Jul  9 02:35:37 2006
New Revision: 186

Modified:
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/reference.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
   trunk/src/demos/unblocked/tiles-panel.lisp
   trunk/src/demos/unblocked/unblocked-window.lisp
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/drawing-tester.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/image-tester.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event-source.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
refactored event-*** functions by removing time argument - call OBTAIN-EVENT-TIME instead now; added type argument to event-activate; significantly enhanced documentation of event functions

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  9 02:35:37 2006
@@ -834,112 +834,297 @@
 @node event functions
 @section event functions
 
+This chapter documents two types of functions:
+ at itemize @bullet
+ at item generic functions implemented in order to handle system events
+ at item functions provided to help implement application message pumps
+ at end itemize
+
 @anchor{default-message-filter}
- at deffn Function default-message-filter gm-code msg-ptr
+ at defun default-message-filter gm-code msg-ptr
 Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and
 @ref{control}s. Accelerator keys are also translated by this
 function. Returns @sc{nil} so that @ref{message-loop} will continue,
-unless @code{gm-code} is less than or equal to zero, in which case
+unless @var{gm-code} is less than or equal to zero, in which case
 @sc{t} is returned so that @ref{message-loop} will exit. When
- at code{gm-code} is zero, @code{msg-ptr} identifies a @sc{WM_QUIT}
-message indicating normal shutdown. If @code{gm-code} is -1, then the
-system has reported an error during message retrieval which should be
-handled by (hopefully) graceful shutdown.
- at end deffn
+ at var{gm-code} is zero, @var{msg-ptr} identifies a @sc{WM_QUIT}
+message indicating normal shutdown. If @var{gm-code} is -1, then the
+system has reported an error during message retrieval; in this
+situation, the application should attempt a graceful shutdown.
+ at table @var
+ at item gm-code
+The code returned by the @code{GetMessage} Win32 @sc{api} call.
+ at item msg-ptr
+A pointer to a Win32 @sc{api} @code{MSG} data structure, filled in
+by @code{GetMessage} and containing raw event data to be
+translated and dispatched.
+ at end table
+ at end defun
 
- at deffn GenericFunction event-activate dispatcher widget time
-Implement this to respond to an object being activated.
+ at deffn GenericFunction event-activate dispatcher widget type
+Implement this method to respond to @var{widget} being activated. For
+a @ref{top-level} @ref{window} or @ref{dialog}, this means that
+ at var{widget} was brought to the foreground and its trim (titlebar and
+border) was highlighted to indicate that it is now the active
+window. For a @ref{menu}, it means that the user has clicked on the
+ at ref{item} invoking @ref{widget} and it is about to be shown; this is
+an opportunity to update the menu's contents.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The menu, dialog, or window that has been activated.
+ at item type
+Provides a hint as to how activation occurred, via one of the following
+keywords:
+ at table @code
+ at item :click
+Indicates that @var{widget} was activated as the result of a mouse click.
+ at item :programmatic
+Indicates that @var{widget} was activated as the result of the keyboard
+interface to select a window, or programmatically via a call to
+ at sc{activate}.
+ at end table
+ at end table
 @end deffn
 
- at deffn GenericFunction event-arm dispatcher item time
-Implement this to respond to an object about to be selected.
+ at deffn GenericFunction event-arm dispatcher item
+Implement this method to respond to the prior notice of @var{item}
+being selected. Of course, an arm event is not necessarily always
+followed by a selection, such as if the user moves the mouse across
+items on a @ref{menu}.
+ at table @var
+ at event-dispatcher-arg
+ at item item
+The @ref{item} about to be selected.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-close dispatcher widget time
-Implement this to respond to an object being closed.
+ at deffn GenericFunction event-close dispatcher widget
+Implement this method to respond to @var{widget} being closed by the user.
+Only @ref{dialog}s and @ref{top-level} @ref{window}s receive close
+events.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The dialog or window being closed.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-dispose dispatcher widget time
-Implement this to respond to an object being disposed (via
- at ref{dispose}, not the garbage collector).
+ at deffn GenericFunction event-dispose dispatcher widget
+Implement this method to respond to @var{widget} being disposed (explicitly
+via @ref{dispose}, not collected via the garbage collector). This
+event function is called while the contents of @var{widget} are still
+valid.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} being disposed.
+ at end table
 @end deffn
 
 @anchor{event-focus-gain}
- at deffn GenericFunction event-focus-gain dispatcher widget time
-Implement this to respond to an object gaining keyboard focus.
+ at deffn GenericFunction event-focus-gain dispatcher widget
+Implement this method to respond to @var{widget} gaining keyboard focus.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} gaining keyboard focus.
+ at end table
 @end deffn
 
 @anchor{event-focus-loss}
- at deffn GenericFunction event-focus-loss dispatcher widget time
-Implement this to respond to an object losing keyboard focus.
+ at deffn GenericFunction event-focus-loss dispatcher widget
+Implement this method to respond to @var{widget} losing keyboard focus.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} losing keyboard focus.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-key-down dispatcher widget time keycode char
-Implement this to respond to a key down event.
+ at deffn GenericFunction event-key-down dispatcher widget keycode char
+Implement this method to respond to a key being pressed within
+ at var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} in which the key was pressed.
+ at item keycode
+The virtual key code of the key that was pressed.
+ at item char
+The character value resulting from translation of the virtual key code,
+or @sc{nil} if the key code cannot be translated.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-key-up dispatcher widget time keycode char
-Implement this to respond to a key up event.
+ at deffn GenericFunction event-key-up dispatcher widget keycode char
+Implement this method to respond to a key being released within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} in which the key was released.
+ at item keycode
+The virtual key code of the key that was released.
+ at item char
+The character value resulting from translation of the virtual key code,
+or @sc{nil} if the key code cannot be translated.
+ at end table
 @end deffn
 
 @anchor{event-modify}
- at deffn GenericFunction event-modify dispatcher widget time
-Implement this to respond to changes within a @ref{widget}, for example
-when the user types text inside an @ref{edit} control.
+ at deffn GenericFunction event-modify dispatcher widget
+Implement this method to respond to changes due to user input within
+ at ref{widget}, for example when the user types text inside an
+ at ref{edit} @ref{control}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} that was modified by the user.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-mouse-double dispatcher widget time point button
-Implement this to respond to a mouse double-click.
+ at deffn GenericFunction event-mouse-double dispatcher widget point button
+Implement this method to respond to a mouse button double-click within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was double-clicked.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
 @end deffn
 
- at deffn GenericFunction event-mouse-down dispatcher widget time point button
-Implement this to respond to a mouse down event.
+ at deffn GenericFunction event-mouse-down dispatcher widget point button
+Implement this method to respond to a mouse button click within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was clicked.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
 @end deffn
 
- at deffn GenericFunction event-mouse-move dispatcher widget time point button
-Implement this to respond to a mouse move event.
+ at deffn GenericFunction event-mouse-move dispatcher widget point button
+Implement this method to respond to a mouse move event within @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse was moved.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
 @end deffn
 
- at deffn GenericFunction event-mouse-up dispatcher widget time point button
-Implement this to respond to a mouse up event.
+ at deffn GenericFunction event-mouse-up dispatcher widget point button
+Implement this method to respond to a mouse button being released within
+ at var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} inside of which the mouse button was released.
+ at event-mouse-point-arg
+ at event-mouse-button-arg
+ at end table
 @end deffn
 
- at deffn GenericFunction event-move dispatcher widget time point
-Implement this to respond to an object being moved within its parent's
-coordinate system.
+ at deffn GenericFunction event-move dispatcher widget point
+Implement this method to respond to @var{widget} being moved within its
+ at ref{parent}'s coordinate system.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} being moved.
+ at item point
+The destination @ref{point} to which @var{widget} was moved.
+ at end table
 @end deffn
 
 @anchor{event-paint}
- at deffn GenericFunction event-paint dispatcher widget time gc rect
-Implement this to respond to paint requests.
+ at deffn GenericFunction event-paint dispatcher widget gc rect
+Implement this method to respond to system requests to repaint @var{widget}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} whose contents need to be repainted.
+ at item gc
+A @ref{graphics-context} initialized for use during this paint event and
+which will be @ref{dispose}d after this method returns.
+ at item rect
+The specific @ref{rectangle} within @var{widget} needing to be repainted.
+ at end table
 @end deffn
 
- at deffn GenericFunction event-resize dispatcher widget time size type
-Implement this to respond to an object being resized.
+ at deffn GenericFunction event-resize dispatcher widget size type
+Implement this method to respond to @var{widget} being resized.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} whose dimensions are being changed.
+ at item size
+A @ref{size} object describing @var{widget}'s new dimensions.
+ at item type
+Identifies three different kinds of resizing actions:
+ at table @code
+ at item :maximized
+Indicates that @var{widget} was expanded to its maximum size, such as
+when the user clicks on the maximize button in a @ref{window} frame.
+ at item :minimized
+Indicates that @var{widget} was minimized to the taskbar.
+ at item :restored
+Indicates that @var{widget} was either restored from a minimized
+state, or that resizing occurred while @var{widget} was already
+in a visible, non-maximized state.
+ at end table
+ at end table
 @end deffn
 
 @anchor{event-select}
- at deffn GenericFunction event-select dispatcher item time rect
-Implement this to respond to an object (or item within) being selected.
+ at deffn GenericFunction event-select dispatcher widget rect
+Implement this method to handle notification that @var{widget} (or some
+ at ref{item} within @var{widget}) has been clicked on by the user in order
+to invoke some action.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The @ref{widget} (or item) that was selected.
+ at item rect
+The @ref{rectangle} bounding @var{widget}.
+ at end table
 @end deffn
 
 @anchor{event-timer}
- at deffn GenericFunction event-timer dispatcher timer time
-Implement this to respond to a tick from a specific timer.
+ at deffn GenericFunction event-timer dispatcher timer
+Implement this method to respond to expiration of the current
+delay configured for @var{timer}.
+ at table @var
+ at event-dispatcher-arg
+ at item timer
+The @ref{timer} that generated this event.
+ at end table
 @end deffn
 
 @anchor{message-loop}
- at deffn Function message-loop msg-filter
+ at defun message-loop msg-filter
 This function retrieves messages from the system with the intent of
-passing each one to the function specified by @code{msg-filter} so
+passing each one to the function specified by @var{msg-filter} so
 that it may be translated and dispatched. The return value of the
- at code{msg-filter} function determines whether @code{message-loop}
-continues or returns, and this termination condition depends on the
-context of the message loop being executed. The return value is
- at sc{nil} if @code{message-loop} should continue, or not @sc{nil} if
-the loop should exit. The pre-defined implementation
- at ref{default-message-filter} is provided.
- at end deffn
+ at var{msg-filter} function determines whether @code{message-loop}
+continues or returns. The return value must be @sc{nil} if
+ at code{message-loop} should continue, or not @sc{nil} if the
+loop should exit.
+ at table @var
+ at item msg-filter
+A @sc{function} object; see @ref{default-message-filter} for more
+details.
+ at end table
+ at end defun
+
+ at anchor{obtain-event-time}
+ at defun obtain-event-time => milliseconds
+Returns the timestamp for the event currently being processed, or
+zero if called prior to the delivery of any events.
+ at end defun
 
 
 @node widget functions

Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo	(original)
+++ trunk/docs/manual/reference.texinfo	Sun Jul  9 02:35:37 2006
@@ -75,6 +75,31 @@
 @end quotation
 @end macro
 
+ at macro event-dispatcher-arg
+ at item dispatcher
+The @ref{event-dispatcher} to process this event.
+ at end macro
+
+ at macro event-mouse-button-arg
+ at item button
+A keyword identifying which mouse button was used:
+ at table @code
+ at item :left-button
+ at item :middle-button
+ at item :right-button
+ at end table
+ at end macro
+
+ at macro event-mouse-point-arg
+ at item point
+The @ref{point} location of the mouse cursor.
+ at end macro
+
+ at macro event-time-arg
+ at item time
+This event's timestamp in milliseconds.
+ at end macro
+
 @c Info "requires" that x-refs end in a period or comma, or ) in the
 @c case of @pxref.  So the following implements that requirement for
 @c the "See also" subheadings that permeate this manual, but only in

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Sun Jul  9 02:35:37 2006
@@ -40,19 +40,19 @@
 (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt")
                                   ("All Files (*.*)"    . "*.*")))
 
-(defun manage-textedit-file-menu (disp menu time)
-  (declare (ignore disp time))
+(defun manage-textedit-file-menu (disp menu type)
+  (declare (ignore disp type))
   (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
 
-(defun textedit-file-new (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun textedit-file-new (disp item rect)
+  (declare (ignore disp item rect))
   (when *textedit-control*
     (setf (gfw:text *textedit-control*) "")
     (setf (gfw:text-modified-p *textedit-control*) nil)
     (setf (file-path *textedit-model*) nil)))
 
-(defun textedit-file-open (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun textedit-file-open (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-file-dialog (*textedit-win*
                          '(:open :add-to-recent :path-must-exist)
                          paths
@@ -61,14 +61,14 @@
       (load-textedit-doc (first paths))
       (setf (file-path *textedit-model*) (namestring (first paths))))))
 
-(defun textedit-file-save (disp item time rect)
+(defun textedit-file-save (disp item rect)
   (if (file-path *textedit-model*)
     (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*))
-    (textedit-file-save-as disp item time rect))
+    (textedit-file-save-as disp item rect))
   (setf (gfw:text-modified-p *textedit-control*) nil))
 
-(defun textedit-file-save-as (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun textedit-file-save-as (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-file-dialog (*textedit-win*
                          '(:save :add-to-recent)
                          paths
@@ -79,15 +79,15 @@
       (setf (file-path *textedit-model*) (namestring (first paths)))
       (setf (gfw:text-modified-p *textedit-control*) nil))))
 
-(defun textedit-file-quit (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun textedit-file-quit (disp item rect)
+  (declare (ignore disp item rect))
   (setf *textedit-control* nil)
   (gfs:dispose *textedit-win*)
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
-(defun textedit-font (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun textedit-font (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-graphics-context (gc *textedit-control*)
     (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*))
       (if font
@@ -95,24 +95,23 @@
 
 (defclass textedit-win-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp textedit-win-events) window time)
-  (declare (ignore window time))
-  (textedit-file-quit disp nil nil nil))
+(defmethod gfw:event-close ((disp textedit-win-events) window)
+  (declare (ignore window))
+  (textedit-file-quit disp nil nil))
 
-(defmethod gfw:event-focus-gain ((self textedit-win-events) window time)
-  (declare (ignore window time))
+(defmethod gfw:event-focus-gain ((self textedit-win-events) window)
+  (declare (ignore window))
   (if *textedit-control*
     (gfw:give-focus *textedit-control*)))
 
 (defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog) time)
-  (declare (ignore time))
+(defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog))
   (call-next-method)
   (gfs:dispose dlg))
 
-(defun about-textedit (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun about-textedit (disp item rect)
+  (declare (ignore disp item rect))
   (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*)))
          (dlg (make-instance 'gfw:dialog :owner *textedit-win*
                                          :dispatcher (make-instance 'textedit-about-dialog-events)
@@ -153,8 +152,8 @@
                                                           :spacing 0
                                                           :style '(:vertical :normalize))))
          (close-btn (make-instance 'gfw:button
-                                   :callback (lambda (disp btn time rect)
-                                               (declare (ignore disp btn time rect))
+                                   :callback (lambda (disp btn rect)
+                                               (declare (ignore disp btn rect))
                                                (gfs:dispose dlg))
                                    :style '(:cancel-button)
                                    :text "Close"

Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
==============================================================================
--- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp	(original)
+++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp	Sun Jul  9 02:35:37 2006
@@ -60,6 +60,6 @@
 (defmethod initialize-instance :after ((self double-buffered-event-dispatcher) &key buffer-size)
   (setf (image-buffer-of self) (make-instance 'gfg:image :size buffer-size)))
 
-(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window time gc rect)
-  (declare (ignore window time rect))
+(defmethod gfw:event-paint ((self double-buffered-event-dispatcher) window gc rect)
+  (declare (ignore window rect))
   (gfg:draw-image gc (image-buffer-of self) (gfs:make-point)))

Modified: trunk/src/demos/unblocked/tiles-panel.lisp
==============================================================================
--- trunk/src/demos/unblocked/tiles-panel.lisp	(original)
+++ trunk/src/demos/unblocked/tiles-panel.lisp	Sun Jul  9 02:35:37 2006
@@ -94,8 +94,7 @@
                (setf (gethash kind table) image)
                (incf kind)))))
 
-(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel time point button)
-  (declare (ignore time))
+(defmethod gfw:event-mouse-down ((self tiles-panel-events) panel point button)
   (let* ((tiles (game-tiles))
          (tile-pnt (window->tiles point))
          (tile-kind (obtain-tile tiles tile-pnt))
@@ -114,8 +113,7 @@
       (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))
+(defmethod gfw:event-mouse-up ((self tiles-panel-events) panel point button)
   (gfw:release-mouse)
   (let ((tile-pnt (window->tiles point))
         (shape-pnts (shape-pnts-of self)))

Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp	(original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp	Sun Jul  9 02:35:37 2006
@@ -52,14 +52,14 @@
 (defun get-scoreboard-panel ()
   *scoreboard-panel*)
 
-(defun new-unblocked (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun new-unblocked (disp item rect)
+  (declare (ignore disp item rect))
   (new-game)
   (update-panel *scoreboard-panel*)
   (update-panel *tiles-panel*))
 
-(defun restart-unblocked (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun restart-unblocked (disp item rect)
+  (declare (ignore disp item rect))
   (restart-game)
   (update-panel *scoreboard-panel*)
   (update-panel *tiles-panel*))
@@ -69,8 +69,8 @@
         (kind (shape-kind shape)))
     (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+))))
 
-(defun reveal-unblocked (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun reveal-unblocked (disp item rect)
+  (declare (ignore disp item rect))
   (let ((shape (find-shape (game-tiles) #'accept-shape-p)))
     (when shape
       (let ((shape-pnts (shape-tile-points shape))
@@ -80,8 +80,8 @@
         (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+)
         (gfw:enable timer t)))))
 
-(defun quit-unblocked (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun quit-unblocked (disp item rect)
+  (declare (ignore disp item rect))
   (setf *scoreboard-panel* nil)
   (setf *tiles-panel* nil)
   (gfs:dispose *unblocked-win*)
@@ -90,23 +90,22 @@
 
 (defclass unblocked-win-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp unblocked-win-events) window time)
-  (declare (ignore window time))
-  (quit-unblocked disp nil nil nil))
+(defmethod gfw:event-close ((disp unblocked-win-events) window)
+  (declare (ignore window))
+  (quit-unblocked disp nil nil))
 
-(defmethod gfw:event-timer ((disp unblocked-win-events) timer time)
-  (declare (ignore timer time))
+(defmethod gfw:event-timer ((disp unblocked-win-events) timer)
+  (declare (ignore timer))
   (update-panel *tiles-panel*))
 
 (defclass unblocked-about-dialog-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog) time)
-  (declare (ignore time))
+(defmethod gfw:event-close ((disp unblocked-about-dialog-events) (dlg gfw:dialog))
   (call-next-method)
   (gfs:dispose dlg))
 
-(defun about-unblocked (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun about-unblocked (disp item rect)
+  (declare (ignore disp item rect))
   (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*)))
          (dlg (make-instance 'gfw:dialog :owner *unblocked-win*
                                          :dispatcher (make-instance 'unblocked-about-dialog-events)
@@ -147,8 +146,8 @@
                                                           :spacing 0
                                                           :style '(:vertical :normalize))))
          (close-btn (make-instance 'gfw:button
-                                   :callback (lambda (disp btn time rect)
-                                               (declare (ignore disp btn time rect))
+                                   :callback (lambda (disp btn rect)
+                                               (declare (ignore disp btn rect))
                                                (gfs:dispose dlg))
                                    :style '(:cancel-button)
                                    :text "Close"
@@ -204,7 +203,7 @@
       (setf (gfw:minimum-size *unblocked-win*) size)
       (setf (gfw:maximum-size *unblocked-win*) size))
 
-    (new-unblocked nil nil nil nil)
+    (new-unblocked nil nil nil)
     (gfw:show *unblocked-win* t)))
 
 (defun unblocked ()

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sun Jul  9 02:35:37 2006
@@ -441,6 +441,7 @@
     #:moveable-p
     #:object-to-display
     #:obtain-displays
+    #:obtain-event-time
     #:obtain-primary-display
     #:owner
     #:pack

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp	Sun Jul  9 02:35:37 2006
@@ -42,16 +42,16 @@
     (gfw:check *last-checked-drawing-item* nil))
   (gfw:check item t))
 
-(defun find-checked-item (disp menu time)
-  (declare (ignore disp time))
+(defun find-checked-item (disp menu type)
+  (declare (ignore disp type))
   (dotimes (i (length (gfw:items menu)))
     (let ((item (elt (gfw:items menu) i)))
       (when (gfw:checked-p item)
         (setf *last-checked-drawing-item* item)
         (return)))))
 
-(defun drawing-exit-fn (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun drawing-exit-fn (disp item rect)
+  (declare (ignore disp item rect))
   (gfs:dispose *drawing-win*)
   (setf *drawing-win* nil)
   (gfw:shutdown 0))
@@ -61,12 +61,12 @@
     :accessor draw-func-of
     :initform nil)))
 
-(defmethod gfw:event-close ((self drawing-win-events) window time)
-  (declare (ignore window time))
-  (drawing-exit-fn self nil nil 0))
+(defmethod gfw:event-close ((self drawing-win-events) window)
+  (declare (ignore window))
+  (drawing-exit-fn self nil nil))
 
-(defmethod gfw:event-paint ((self drawing-win-events) window time gc rect)
-  (declare (ignore time rect))
+(defmethod gfw:event-paint ((self drawing-win-events) window gc rect)
+  (declare (ignore rect))
   (setf (gfg:background-color gc) gfg:*color-white*)
   (setf (gfg:foreground-color gc) gfg:*color-white*)
   (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))
@@ -162,8 +162,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil)))
 
-(defun select-arcs (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-arcs (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
   (gfw:redraw *drawing-win*))
@@ -185,8 +185,8 @@
       (setf (gfg:pen-style gc) '(:dot :square-endcap))
       (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts))))
 
-(defun select-beziers (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-beziers (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers)
   (gfw:redraw *drawing-win*))
@@ -202,8 +202,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil)))
 
-(defun select-ellipses (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-ellipses (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses)
   (gfw:redraw *drawing-win*))
@@ -240,8 +240,8 @@
                     #'gfg:draw-line
                     nil)))
 
-(defun select-lines (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-lines (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-lines)
   (gfw:redraw *drawing-win*))
@@ -264,8 +264,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil)))
 
-(defun select-rects (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-rects (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-rects)
   (gfw:redraw *drawing-win*))
@@ -314,8 +314,8 @@
     (setf (gfg:foreground-color gc) gfg:*color-red*)
     (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent))))
 
-(defun select-text (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-text (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-strings)
   (gfw:redraw *drawing-win*))
@@ -336,8 +336,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil)))
 
-(defun select-wedges (disp item time rect)
-  (declare (ignore disp time rect))
+(defun select-wedges (disp item rect)
+  (declare (ignore disp rect))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges)
   (gfw:redraw *drawing-win*))

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Jul  9 02:35:37 2006
@@ -47,16 +47,16 @@
 
 (defclass event-tester-window-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect)
-  (declare (ignorable time rect))
+(defmethod gfw:event-paint ((d event-tester-window-events) window gc rect)
+  (declare (ignore rect))
   (setf (gfg:background-color gc) gfg:*color-white*)
   (setf (gfg:foreground-color gc) gfg:*color-blue*)
   (let* ((sz (gfw:client-size window))
          (pnt (gfs:make-point :x 0 :y (floor (gfs:size-height sz) 2))))
     (gfg:draw-text gc *event-tester-text* pnt)))
 
-(defmethod gfw:event-close ((d event-tester-window-events) widget time)
-  (declare (ignore widget time))
+(defmethod gfw:event-close ((d event-tester-window-events) widget)
+  (declare (ignore widget))
   (exit-event-tester))
 
 (defun text-for-modifiers ()
@@ -72,7 +72,7 @@
           (not (gfw:key-toggled-p gfw:+vk-num-lock+))
           (not (gfw:key-toggled-p gfw:+vk-scroll-lock+))))
 
-(defun text-for-mouse (action time button pnt)
+(defun text-for-mouse (action button pnt)
   (format nil
           "~a mouse action: ~s  button: ~a  point: (~d,~d)  time: 0x~x  ~s"
           (incf *event-counter*)
@@ -80,131 +80,130 @@
           button
           (gfs:point-x pnt)
           (gfs:point-y pnt)
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
 
-(defun text-for-key (action time key-code char)
+(defun text-for-key (action key-code char)
   (format nil
           "~a key action: ~s  char: ~s  code: 0x~x  time: 0x~x  ~s"
           (incf *event-counter*)
           action
           char
           key-code
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
 
-(defun text-for-item (text time desc)
+(defun text-for-item (text desc)
   (format nil
           "~a ~s: ~s  time: 0x~x  ~s"
           (incf *event-counter*)
           desc
           text
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
 
-(defun text-for-size (type time size)
+(defun text-for-size (type size)
   (format nil
           "~a resize action: ~s  size: (~d,~d)  time: 0x~x  ~s"
           (incf *event-counter*)
           (symbol-name type)
           (gfs:size-width size)
           (gfs:size-height size)
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
 
-(defun text-for-move (time pnt)
+(defun text-for-move (pnt)
   (format nil
           "~a move  point: (~d,~d)  time: 0x~x  ~s"
           (incf *event-counter*)
           (gfs:point-x pnt)
           (gfs:point-y pnt)
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
 
-(defun text-for-timer (time)
+(defun text-for-timer ()
   (format nil
           "~a timer tick id: ~d  time: 0x~x  ~s"
           (incf *event-counter*)
           (gfw:id-of *timer*)
-          time
+          (gfw:obtain-event-time)
           (text-for-modifiers)))
           
-(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char)
-  (setf *event-tester-text* (text-for-key "down" time key-code char))
+(defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char)
+  (setf *event-tester-text* (text-for-key "down" key-code char))
   (gfw:redraw window))
 
-(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char)
-  (setf *event-tester-text* (text-for-key "up" time key-code char))
+(defmethod gfw:event-key-up ((d event-tester-window-events) window key-code char)
+  (setf *event-tester-text* (text-for-key "up" key-code char))
   (gfw:redraw window))
 
-(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button)
-  (setf *event-tester-text* (text-for-mouse "double" time button pnt))
+(defmethod gfw:event-mouse-double ((d event-tester-window-events) window pnt button)
+  (setf *event-tester-text* (text-for-mouse "double" button pnt))
   (gfw:redraw window))
 
-(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button)
-  (setf *event-tester-text* (text-for-mouse "down" time button pnt))
+(defmethod gfw:event-mouse-down ((d event-tester-window-events) window pnt button)
+  (setf *event-tester-text* (text-for-mouse "down" button pnt))
   (setf *mouse-down-flag* t)
   (gfw:redraw window))
 
-(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button)
+(defmethod gfw:event-mouse-move ((d event-tester-window-events) window pnt button)
   (when *mouse-down-flag*
-    (setf *event-tester-text* (text-for-mouse "move" time button pnt))
+    (setf *event-tester-text* (text-for-mouse "move" button pnt))
     (gfw:redraw window)))
 
-(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button)
-  (setf *event-tester-text* (text-for-mouse "up" time button pnt))
+(defmethod gfw:event-mouse-up ((d event-tester-window-events) window pnt button)
+  (setf *event-tester-text* (text-for-mouse "up" button pnt))
   (setf *mouse-down-flag* nil)
   (gfw:redraw window))
 
-(defmethod gfw:event-move ((d event-tester-window-events) window time pnt)
-  (setf *event-tester-text* (text-for-move time pnt))
+(defmethod gfw:event-move ((d event-tester-window-events) window pnt)
+  (setf *event-tester-text* (text-for-move pnt))
   (gfw:redraw window)
   0)
 
-(defmethod gfw:event-resize ((d event-tester-window-events) window time size type)
-  (setf *event-tester-text* (text-for-size type time size))
+(defmethod gfw:event-resize ((d event-tester-window-events) window size type)
+  (setf *event-tester-text* (text-for-size type size))
   (gfw:redraw window)
   0)
 
 (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect)
-  (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect)
+  (declare (ignore item rect))
   (exit-event-tester))
 
-(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time)
-  (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item)
+  (setf *event-tester-text* (text-for-item (gfw:text item) "item armed"))
   (gfw:redraw *event-tester-window*))
 
 (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect)
+(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect)
   (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected"))
+  (setf *event-tester-text* (text-for-item (gfw:text item) "item selected"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time)
-  (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item)
+  (setf *event-tester-text* (text-for-item (gfw:text item) "item armed"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time)
-  (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated"))
+(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type)
+  (declare (ignore type))
+  (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer time)
-  (declare (ignore disp timer))
-  (setf *event-tester-text* (text-for-timer time))
+(defmethod gfw:event-timer ((disp event-tester-echo-dispatcher) timer)
+  (declare (ignore timer))
+  (setf *event-tester-text* (text-for-timer))
   (gfw:redraw *event-tester-window*))
 
-(defun manage-file-menu (disp menu time)
-  (declare (ignore disp time))
+(defun manage-file-menu (disp menu type)
+  (declare (ignore disp type))
   (let ((item (elt (gfw:items menu) 0)))
     (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
 
-(defun manage-timer (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun manage-timer (disp item rect)
+  (declare (ignore disp item rect))
   (if *timer*
     (progn
       (gfw:enable *timer* nil)

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Sun Jul  9 02:35:37 2006
@@ -37,18 +37,18 @@
 
 (defclass hellowin-events (gfw:event-dispatcher) ())
 
-(defun exit-fn (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun exit-fn (disp item rect)
+  (declare (ignore disp item rect))
   (gfs:dispose *hello-win*)
   (setf *hello-win* nil)
   (gfw:shutdown 0))
 
-(defmethod gfw:event-close ((disp hellowin-events) window time)
+(defmethod gfw:event-close ((disp hellowin-events) window)
   (declare (ignore window))
-  (exit-fn disp nil time nil))
+  (exit-fn disp nil nil))
 
-(defmethod gfw:event-paint ((disp hellowin-events) window time gc rect)
-  (declare (ignore time rect))
+(defmethod gfw:event-paint ((disp hellowin-events) window gc rect)
+  (declare (ignore rect))
   (setf (gfg:background-color gc) gfg:*color-white*)
   (setf (gfg:foreground-color gc) gfg:*color-white*)
   (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))

Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp	Sun Jul  9 02:35:37 2006
@@ -48,15 +48,15 @@
   (gfs:dispose *true-image*)
   (setf *true-image* nil))
 
-(defmethod gfw:event-close ((d image-events) window time)
-  (declare (ignore window time))
+(defmethod gfw:event-close ((d image-events) window)
+  (declare (ignore window))
   (dispose-images)
   (gfs:dispose *image-win*)
   (setf *image-win* nil)
   (gfw:shutdown 0))
 
-(defmethod gfw:event-paint ((d image-events) window time gc rect)
-  (declare (ignore window time rect))
+(defmethod gfw:event-paint ((d image-events) window gc rect)
+  (declare (ignore window rect))
   (let ((pnt (gfs:make-point))
         (pixel-pnt1 (gfs:make-point))
         (pixel-pnt2 (gfs:make-point :x 0 :y 15)))
@@ -86,8 +86,8 @@
       (incf (gfs:point-x pnt) 20)
       (gfg:draw-image gc *true-image* pnt))))
 
-(defun exit-image-fn (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun exit-image-fn (disp item rect)
+  (declare (ignorable disp item rect))
   (dispose-images)
   (gfs:dispose *image-win*)
   (setf *image-win* nil)

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Jul  9 02:35:37 2006
@@ -52,14 +52,14 @@
 
 (defclass layout-tester-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((d layout-tester-events) widget time)
-  (declare (ignore widget time))
+(defmethod gfw:event-close ((d layout-tester-events) widget)
+  (declare (ignore widget))
   (exit-layout-tester))
 
 (defclass pack-layout-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect)
-  (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect)
+  (declare (ignore item rect))
   (gfw:pack *layout-tester-win*))
 
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
@@ -71,8 +71,8 @@
     :initarg :id
     :initform 0)))
 
-(defmethod gfw:event-paint ((self layout-tester-widget-events) window time gc rect)
-  (declare (ignore time rect))
+(defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect)
+  (declare (ignore rect))
   (setf (gfg:background-color gc) gfg:*color-white*)
   (setf (gfg:foreground-color gc) gfg:*color-white*)
   (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
@@ -139,8 +139,8 @@
                                 :dispatcher be))))
     (incf *widget-counter*)))
 
-(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
-  (declare (ignorable time rect))
+(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect)
+  (declare (ignore rect))
   (setf (gfw:text btn) (funcall (toggle-fn d)))
   (gfw:layout *layout-tester-win*))
 
@@ -154,8 +154,8 @@
     :initarg :subtype
     :initform :push-button)))
 
-(defmethod gfw:event-select ((d add-child-dispatcher) item time rect)
-  (declare (ignorable item time rect))
+(defmethod gfw:event-select ((d add-child-dispatcher) item rect)
+  (declare (ignorable item rect))
   (add-layout-tester-widget (widget-class d) (subtype d))
   (gfw:pack *layout-tester-win*))
 
@@ -169,8 +169,8 @@
     :initarg :sub-disp-class
     :initform nil)))
 
-(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
-  (declare (ignore time))
+(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type)
+  (declare (ignore type))
   (gfw:clear-all menu)
   (gfw:mapchildren *layout-tester-win*
                    (lambda (parent child)
@@ -192,8 +192,8 @@
 
 (defclass remove-child-dispatcher (gfw:event-dispatcher) ())  
 
-(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect)
-  (declare (ignorable time rect))
+(defmethod gfw:event-select ((d remove-child-dispatcher) item rect)
+  (declare (ignore rect))
   (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfs:dispose victim)
@@ -201,21 +201,21 @@
 
 (defclass visibility-child-dispatcher (gfw:event-dispatcher) ())  
 
-(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect)
-  (declare (ignorable time rect))
+(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect)
+  (declare (ignore rect))
   (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfw:show victim (not (gfw:visible-p victim)))
       (gfw:layout *layout-tester-win*))))
 
-(defun check-flow-orient-items (disp menu time)
-  (declare (ignore disp time))
+(defun check-flow-orient-items (disp menu type)
+  (declare (ignore disp type))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout)))
     (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))
 
-(defun set-flow-horizontal (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun set-flow-horizontal (disp item rect)
+  (declare (ignorable disp item rect))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (setf style (remove :vertical style))
@@ -223,8 +223,8 @@
     (setf (gfw:style-of layout) style)
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-vertical (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun set-flow-vertical (disp item rect)
+  (declare (ignorable disp item rect))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (setf style (remove :horizontal style))
@@ -232,8 +232,8 @@
     (setf (gfw:style-of layout) style)
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-layout-normalize (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun set-flow-layout-normalize (disp item rect)
+  (declare (ignorable disp item rect))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (if (find :normalize style)
@@ -241,8 +241,8 @@
       (setf (gfw:style-of layout) (push :normalize style)))
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-layout-wrap (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun set-flow-layout-wrap (disp item rect)
+  (declare (ignorable disp item rect))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (if (find :wrap style)
@@ -250,13 +250,13 @@
       (setf (gfw:style-of layout) (push :wrap style)))
     (gfw:layout *layout-tester-win*)))
 
-(defun enable-flow-spacing-items (disp menu time)
-  (declare (ignore disp time))
+(defun enable-flow-spacing-items (disp menu type)
+  (declare (ignore disp type))
   (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
     (gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))
 
-(defun decrease-flow-spacing (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun decrease-flow-spacing (disp item rect)
+  (declare (ignore disp item rect))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (spacing (gfw:spacing-of layout)))
     (unless (zerop spacing)
@@ -264,82 +264,82 @@
       (setf (gfw:spacing-of layout) spacing)
       (gfw:layout *layout-tester-win*))))
 
-(defun increase-flow-spacing (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun increase-flow-spacing (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:spacing-of layout) +spacing-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun enable-left-flow-margin-items (disp menu time)
-  (declare (ignore disp time))
+(defun enable-left-flow-margin-items (disp menu rect)
+  (declare (ignore disp rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0))))
 
-(defun enable-top-flow-margin-items (disp menu time)
-  (declare (ignore disp time))
+(defun enable-top-flow-margin-items (disp menu rect)
+  (declare (ignore disp rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0))))
 
-(defun enable-right-flow-margin-items (disp menu time)
-  (declare (ignore disp time))
+(defun enable-right-flow-margin-items (disp menu rect)
+  (declare (ignore disp rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0))))
 
-(defun enable-bottom-flow-margin-items (disp menu time)
-  (declare (ignore disp time))
+(defun enable-bottom-flow-margin-items (disp menu rect)
+  (declare (ignore disp rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0))))
 
-(defun inc-left-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun inc-left-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:left-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-top-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun inc-top-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:top-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-right-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun inc-right-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:right-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-bottom-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun inc-bottom-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:bottom-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-left-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun dec-left-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:left-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-top-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun dec-top-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:top-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-right-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun dec-right-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:right-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-bottom-flow-margin (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun dec-bottom-flow-margin (disp item rect)
+  (declare (ignore disp item rect))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:bottom-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun flow-mod-callback (disp menu time)
-  (declare (ignore disp time))
+(defun flow-mod-callback (disp menu type)
+  (declare (ignore disp type))
   (gfw:clear-all menu)
   (let ((it nil)
         (margin-menu (gfw:defmenu ((:item "Left"
@@ -383,8 +383,8 @@
       (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
       (gfw:check it (find :wrap style)))))
 
-(defun exit-layout-callback (disp item time rect)
-  (declare (ignorable disp item time rect))
+(defun exit-layout-callback (disp item rect)
+  (declare (ignorable disp item rect))
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Sun Jul  9 02:35:37 2006
@@ -37,38 +37,37 @@
 
 (defclass main-win-events (gfw:event-dispatcher) ())
 
-(defun windlg-exit-fn (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun windlg-exit-fn (disp item rect)
+  (declare (ignore disp item rect))
   (gfs:dispose *main-win*)
   (setf *main-win* nil)
   (gfw:shutdown 0))
 
-(defmethod gfw:event-close ((self main-win-events) window time)
-  (declare (ignore window time))
-  (windlg-exit-fn self nil nil 0))
+(defmethod gfw:event-close ((self main-win-events) window)
+  (declare (ignore window))
+  (windlg-exit-fn self nil nil))
 
 (defclass test-win-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-paint ((d test-win-events) window time gc rect)
-  (declare (ignore time rect))
+(defmethod gfw:event-paint ((d test-win-events) window gc rect)
+  (declare (ignore rect))
   (setf (gfg:background-color gc) gfg:*color-white*)
   (setf (gfg:foreground-color gc) gfg:*color-white*)
   (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
 
 (defclass test-mini-events (test-win-events) ())
 
-(defmethod gfw:event-close ((d test-mini-events) window time)
-  (declare (ignore time))
+(defmethod gfw:event-close ((d test-mini-events) window)
   (gfs:dispose window))
 
 (defclass test-borderless-events (test-win-events) ())
 
-(defmethod gfw:event-mouse-down ((d test-borderless-events) window time point button)
-  (declare (ignore time point button))
+(defmethod gfw:event-mouse-down ((d test-borderless-events) window point button)
+  (declare (ignore point button))
   (gfs:dispose window))
 
-(defun create-borderless-win (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun create-borderless-win (disp item rect)
+  (declare (ignore disp item rect))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events)
                                               :owner *main-win*
                                               :style '(:borderless))))
@@ -76,8 +75,8 @@
     (gfw:center-on-owner window)
     (gfw:show window t)))
 
-(defun create-miniframe-win (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun create-miniframe-win (disp item rect)
+  (declare (ignore disp item rect))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
                                               :text "Mini Frame"
@@ -86,8 +85,8 @@
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
     (gfw:show window t)))
 
-(defun create-palette-win (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun create-palette-win (disp item rect)
+  (declare (ignore disp item rect))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
                                               :text "Palette"
@@ -96,8 +95,8 @@
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
     (gfw:show window t)))
 
-(defun open-file-dlg (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun open-file-dlg (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-file-dialog (*main-win*
                          '(:open :add-to-recent :multiple-select)
                          paths
@@ -108,8 +107,8 @@
                          :text "Select Lisp-related files...")
     (print paths)))
 
-(defun save-file-dlg (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun save-file-dlg (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-file-dialog (*main-win*
                          '(:save)
                          paths
@@ -118,8 +117,8 @@
                          :initial-directory #P"c:/")
     (print paths)))
 
-(defun choose-font-dlg (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun choose-font-dlg (disp item rect)
+  (declare (ignore disp item rect))
   (gfw:with-graphics-context (gc *main-win*)
     (gfw:with-font-dialog (*main-win* nil font color :gc gc)
       (if color
@@ -129,9 +128,7 @@
 
 (defclass dialog-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time)
-  (declare (ignore time))
-  (format t "dialog-events event-close called~%")
+(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog))
   (call-next-method)
   (gfs:dispose dlg))
 
@@ -140,16 +137,13 @@
 (defun truncate-text (str)
   (subseq str 0 (min (length str) 5)))
 
-(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit) time)
-  (declare (ignore time))
+(defmethod gfw:event-focus-gain ((disp edit-control-events) (ctrl gfw:edit))
   (format t "gained focus: ~a...~%" (truncate-text (gfw:text ctrl))))
 
-(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit) time)
-  (declare (ignore time))
+(defmethod gfw:event-focus-loss ((disp edit-control-events) (ctrl gfw:edit))
   (format t "lost focus: ~a...~%" (truncate-text (gfw:text ctrl))))
 
-(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit) time)
-  (declare (ignore time))
+(defmethod gfw:event-modify ((disp edit-control-events) (ctrl gfw:edit))
   (format t "modified: ~a...~%" (truncate-text (gfw:text ctrl))))
 
 (defun open-dlg (title style)
@@ -204,15 +198,15 @@
                                                           :style '(:vertical :normalize))
                                    :parent dlg))
          (ok-btn (make-instance 'gfw:button
-                                :callback (lambda (disp btn time rect)
-                                            (declare (ignore disp btn time rect))
+                                :callback (lambda (disp btn rect)
+                                            (declare (ignore disp btn rect))
                                             (gfs:dispose dlg))
                                 :style '(:default-button)
                                 :text "OK"
                                 :parent btn-panel))
          (cancel-btn (make-instance 'gfw:button
-                                    :callback (lambda (disp btn time rect)
-                                                (declare (ignore disp btn time rect))
+                                    :callback (lambda (disp btn rect)
+                                                (declare (ignore disp btn rect))
                                                 (gfs:dispose dlg))
                                     :style '(:cancel-button)
                                     :text "Cancel"
@@ -226,12 +220,12 @@
     (gfw:show dlg t)
     dlg))
 
-(defun open-modal-dlg (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun open-modal-dlg (disp item rect)
+  (declare (ignore disp item rect))
   (open-dlg "Modal" '(:owner-modal)))
 
-(defun open-modeless-dlg (disp item time rect)
-  (declare (ignore disp item time rect))
+(defun open-modeless-dlg (disp item rect)
+  (declare (ignore disp item rect))
   (open-dlg "Modeless" '(:modeless)))
 
 (defun run-windlg-internal ()

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Sun Jul  9 02:35:37 2006
@@ -889,6 +889,10 @@
 (defconstant +user-timer-maximum+      #x7FFFFFFF)
 (defconstant +user-timer-minimum+      #x0000000A)
 
+(defconstant +wa-inactive+                      0)
+(defconstant +wa-active+                        1)
+(defconstant +wa-clickactive+                   2)
+
 (defconstant +wb-left+                          0)
 (defconstant +wb-right+                         1)
 (defconstant +wb-isdelimiter+                   2)

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Sun Jul  9 02:35:37 2006
@@ -33,162 +33,157 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defgeneric event-activate (dispatcher widget time)
+(defgeneric event-activate (dispatcher widget type)
   (:documentation "Implement this to respond to an object being activated.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget type)
+    (declare (ignorable dispatcher widget type))))
 
-(defgeneric event-arm (dispatcher item time)
+(defgeneric event-arm (dispatcher item)
   (:documentation "Implement this to respond to an object about to be selected.")
-  (:method (dispatcher item time)
-    (declare (ignorable dispatcher item time))))
+  (:method (dispatcher item)
+    (declare (ignorable dispatcher item))))
 
-(defgeneric event-close (dispatcher widget time)
+(defgeneric event-close (dispatcher widget)
   (:documentation "Implement this to respond to an object being closed.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-collapse (dispatcher item time rect)
+(defgeneric event-collapse (dispatcher item rect)
   (:documentation "Implement this to respond to an object (or item within) being collapsed.")
-  (:method (dispatcher item time rect)
-    (declare (ignorable dispatcher item time rect))))
+  (:method (dispatcher item rect)
+    (declare (ignorable dispatcher item rect))))
 
-(defgeneric event-deactivate (dispatcher widget time)
+(defgeneric event-deactivate (dispatcher widget type)
   (:documentation "Implement this to respond to an object being deactivated.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget type)
+    (declare (ignorable dispatcher widget type))))
 
-(defgeneric event-deiconify (dispatcher widget time)
+(defgeneric event-deiconify (dispatcher widget)
   (:documentation "Implement this to respond to an object being deiconified.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-dispose (dispatcher widget time)
+(defgeneric event-dispose (dispatcher widget)
   (:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-expand (dispatcher item time rect)
+(defgeneric event-expand (dispatcher item rect)
   (:documentation "Implement this to respond to an object (or item within) being expanded.")
-  (:method (dispatcher item time rect)
-    (declare (ignorable dispatcher item time rect))))
+  (:method (dispatcher item rect)
+    (declare (ignorable dispatcher item rect))))
 
-(defgeneric event-focus-gain (dispatcher widget time)
+(defgeneric event-focus-gain (dispatcher widget)
   (:documentation "Implement this to respond to an object gaining keyboard focus.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-focus-loss (dispatcher widget time)
+(defgeneric event-focus-loss (dispatcher widget)
   (:documentation "Implement this to respond to an object losing keyboard focus.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-hide (dispatcher widget time)
+(defgeneric event-hide (dispatcher widget)
   (:documentation "Implement this to respond to an object being hidden.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-iconify (dispatcher widget time)
+(defgeneric event-iconify (dispatcher widget)
   (:documentation "Implement this to respond to an object being iconified.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-key-down (dispatcher widget time keycode char)
+(defgeneric event-key-down (dispatcher widget keycode char)
   (:documentation "Implement this to respond to a key down event.")
-  (:method (dispatcher widget time keycode char)
-    (declare (ignorable dispatcher widget time keycode char))))
+  (:method (dispatcher widget keycode char)
+    (declare (ignorable dispatcher widget keycode char))))
 
-(defgeneric event-key-traverse (dispatcher widget time keycode char type)
-  (:documentation "Implement this to respond to a key traversal event.")
-  (:method (dispatcher widget time keycode char type)
-    (declare (ignorable dispatcher widget time keycode char type))))
-
-(defgeneric event-key-up (dispatcher widget time keycode char)
+(defgeneric event-key-up (dispatcher widget keycode char)
   (:documentation "Implement this to respond to a key up event.")
-  (:method (dispatcher widget time keycode char)
-    (declare (ignorable dispatcher widget time keycode char))))
+  (:method (dispatcher widget keycode char)
+    (declare (ignorable dispatcher widget keycode char))))
 
-(defgeneric event-modify (dispatcher widget time)
+(defgeneric event-modify (dispatcher widget)
   (:documentation "Implement this to respond to content (e.g., text) in an object being modified.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-mouse-double (dispatcher widget time point button)
+(defgeneric event-mouse-double (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse double-click.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-down (dispatcher widget time point button)
+(defgeneric event-mouse-down (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse down event.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-enter (dispatcher widget time point button)
+(defgeneric event-mouse-enter (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse passing into the bounds of an object.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-exit (dispatcher widget time point button)
+(defgeneric event-mouse-exit (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse leaving the bounds an object.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-hover (dispatcher widget time point button)
+(defgeneric event-mouse-hover (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-move (dispatcher widget time point button)
+(defgeneric event-mouse-move (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse move event.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-mouse-up (dispatcher widget time point button)
+(defgeneric event-mouse-up (dispatcher widget point button)
   (:documentation "Implement this to respond to a mouse up event.")
-  (:method (dispatcher widget time point button)
-    (declare (ignorable dispatcher widget time point button))))
+  (:method (dispatcher widget point button)
+    (declare (ignorable dispatcher widget point button))))
 
-(defgeneric event-move (dispatcher widget time point)
+(defgeneric event-move (dispatcher widget point)
   (:documentation "Implement this to respond to an object being moved within its parent's coordinate system.")
-  (:method (dispatcher widget time point)
-    (declare (ignorable dispatcher widget time point))))
+  (:method (dispatcher widget point)
+    (declare (ignorable dispatcher widget point))))
 
-(defgeneric event-paint (dispatcher widget time gc rect)
+(defgeneric event-paint (dispatcher widget gc rect)
   (:documentation "Implement this to respond to paint requests.")
-  (:method (dispatcher widget time gc rect)
-    (declare (ignorable dispatcher widget time gc rect))))
+  (:method (dispatcher widget gc rect)
+    (declare (ignorable dispatcher widget gc rect))))
 
-(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content)
+(defgeneric event-pre-modify (dispatcher widget keycode char span new-content)
   (:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.")
-  (:method (dispatcher widget time keycode char span new-content)
-    (declare (ignorable dispatcher widget time keycode char span new-content))))
+  (:method (dispatcher widget keycode char span new-content)
+    (declare (ignorable dispatcher widget keycode char span new-content))))
 
-(defgeneric event-pre-move (dispatcher widget time)
+(defgeneric event-pre-move (dispatcher widget)
   (:documentation "Implement this to preempt moving; return T if processed or nil if not.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-pre-resize (dispatcher widget time)
+(defgeneric event-pre-resize (dispatcher widget)
   (:documentation "Implement this to preempt resizing; return T if processed or nil if not.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-resize (dispatcher widget time size type)
+(defgeneric event-resize (dispatcher widget size type)
   (:documentation "Implement this to respond to an object being resized.")
-  (:method (dispatcher widget time size type)
-    (declare (ignorable dispatcher widget time size type))))
+  (:method (dispatcher widget size type)
+    (declare (ignorable dispatcher widget size type))))
 
-(defgeneric event-select (dispatcher item time rect)
+(defgeneric event-select (dispatcher item rect)
   (:documentation "Implement this to respond to an object (or item within) being selected.")
-  (:method (dispatcher item time rect)
-    (declare (ignorable dispatcher item time rect))))
+  (:method (dispatcher item rect)
+    (declare (ignorable dispatcher item rect))))
 
-(defgeneric event-show (dispatcher widget time)
+(defgeneric event-show (dispatcher widget)
   (:documentation "Implement this to respond to an object being shown.")
-  (:method (dispatcher widget time)
-    (declare (ignorable dispatcher widget time))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
-(defgeneric event-timer (dispatcher timer time)
+(defgeneric event-timer (dispatcher timer)
   (:documentation "Implement this to respond to a tick from a specific timer.")
-  (:method (dispatcher timer time)
-    (declare (ignorable dispatcher timer time))))
+  (:method (dispatcher timer)
+    (declare (ignorable dispatcher timer))))

Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp	Sun Jul  9 02:35:37 2006
@@ -33,9 +33,9 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer))
-                               (gfw:event-arm      . (gfw:event-source integer))
-                               (gfw:event-select   . (gfw:event-source integer gfs:rectangle))))
+(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol))
+                               (gfw:event-arm      . (gfw:event-source))
+                               (gfw:event-select   . (gfw:event-source gfs:rectangle))))
 
 (defun make-specializer-list (disp-class arg-info)
   (let ((tmp (mapcar #'find-class arg-info)))

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Jul  9 02:35:37 2006
@@ -102,7 +102,7 @@
     (when w
       (setf (gfs:point-x pnt) (lo-word lparam))
       (setf (gfs:point-y pnt) (hi-word lparam))
-      (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol)))
+      (funcall fn (dispatcher w) w pnt btn-symbol)))
   0)
 
 (defun get-class-wndproc (hwnd)
@@ -118,17 +118,15 @@
     (error 'gfs:win32-error :detail "set-window-long failed")))
 
 (defun dispatch-notification (widget wparam-hi)
-  (let ((disp (dispatcher widget))
-        (time (event-time (thread-context))))
+  (let ((disp (dispatcher widget)))
     (case wparam-hi
-      (0                     (event-select     disp widget time (gfs:make-rectangle))) ; FIXME: debug
-      (#.gfs::+en-killfocus+ (event-focus-loss disp widget time))
-      (#.gfs::+en-setfocus+  (event-focus-gain disp widget time))
-      (#.gfs::+en-update+    (event-modify     disp widget time)))))
+      (0                     (event-select     disp widget (gfs:make-rectangle))) ; FIXME
+      (#.gfs::+en-killfocus+ (event-focus-loss disp widget))
+      (#.gfs::+en-setfocus+  (event-focus-gain disp widget))
+      (#.gfs::+en-update+    (event-modify     disp widget)))))
 
 (defun process-ctlcolor-message (wparam lparam)
-  (let* ((tc (thread-context))
-         (widget (get-widget tc (cffi:make-pointer lparam)))
+  (let* ((widget (get-widget (thread-context) (cffi:make-pointer lparam)))
          (hdc (cffi:make-pointer wparam))
          (bkgdcolor (brush-color-of widget))
          (textcolor (text-color-of widget))
@@ -141,6 +139,9 @@
       (setf ret-val (cffi:pointer-address (brush-handle-of widget))))
     ret-val))
 
+(defun obtain-event-time ()
+  (event-time (thread-context)))
+
 ;;;
 ;;; process-message methods
 ;;;
@@ -153,10 +154,9 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
   (declare (ignore wparam lparam))
-  (let* ((tc (thread-context))
-         (w (get-widget tc hwnd)))
+  (let ((w (get-widget (thread-context) hwnd)))
     (if w
-      (event-close (dispatcher w) w (event-time tc))
+      (event-close (dispatcher w) w)
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
@@ -172,10 +172,7 @@
             (if (null item)
               (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo))
               (unless (null (dispatcher item))
-                (event-select (dispatcher item)
-                              item
-                              (event-time tc)
-                              (gfs:make-rectangle)))))) ; FIXME
+                (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam)) ; FIXME: debug
         (t
@@ -193,7 +190,7 @@
     (unless (null menu)
       (let ((d (dispatcher menu)))
         (unless (null d)
-          (event-activate d menu (event-time tc))))))
+          (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
@@ -203,7 +200,7 @@
     (unless (null item)
       (let ((d (dispatcher item)))
         (unless (null d)
-          (event-arm d item (event-time tc))))))
+          (event-arm d item)))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
@@ -223,7 +220,7 @@
          (w (get-widget tc hwnd))
          (ch (code-char (lo-word wparam))))
     (when w
-      (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch)))
+      (event-key-down (dispatcher w) w (virtual-key tc) ch)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
@@ -234,7 +231,7 @@
          (w (get-widget tc hwnd)))
     (setf (virtual-key tc) wparam-lo)
     (when (and w (zerop ch))
-      (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))
+      (event-key-down (dispatcher w) w wparam-lo (code-char ch))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
@@ -244,7 +241,7 @@
            (ch (gfs::map-virtual-key wparam-lo 2))
            (w (get-widget tc hwnd)))
       (when w
-        (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))
+        (event-key-up (dispatcher w) w wparam-lo (code-char ch))))
     (setf (virtual-key tc) 0))
   0)
 
@@ -289,14 +286,14 @@
          (w (get-widget tc hwnd)))
     (when w
       (outer-location w (move-event-pnt tc))
-      (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc))))
+      (event-move (dispatcher w) w (move-event-pnt tc))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
   (declare (ignore wparam lparam))
   (let* ((tc (thread-context))
          (w (get-widget tc hwnd)))
-    (if (and w (event-pre-move (dispatcher w) w (event-time tc)))
+    (if (and w (event-pre-move (dispatcher w) w))
       1
       0)))
 
@@ -318,7 +315,7 @@
                                               :height gfs::rcpaint-height))
           (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
             (unwind-protect
-                (event-paint (dispatcher widget) widget (event-time tc) gc rct)
+                (event-paint (dispatcher widget) widget gc rct)
               (gfs:dispose gc)
               (gfs::end-paint hwnd ps-ptr))))))
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
@@ -357,7 +354,7 @@
   (let* ((tc (thread-context))
          (widget (get-widget tc hwnd)))
     (if widget
-      (event-focus-loss (dispatcher widget) widget (event-time tc))))
+      (event-focus-loss (dispatcher widget) widget)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam)
@@ -365,7 +362,7 @@
   (let* ((tc (thread-context))
          (widget (get-widget tc hwnd)))
     (if widget
-      (event-focus-gain (dispatcher widget) widget (event-time tc))))
+      (event-focus-gain (dispatcher widget) widget)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam)
@@ -407,15 +404,14 @@
                  (t nil))))
     (when w
       (outer-size w (size-event-size tc))
-      #+gf-debug-widgets (format t "about to call event-resize: ~a~%" hwnd)
-      (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type)))
+      (event-resize (dispatcher w) w (size-event-size tc) type)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
   (declare (ignore wparam lparam))
   (let* ((tc (thread-context))
          (w (get-widget tc hwnd)))
-    (if (and w (event-pre-resize (dispatcher w) w (event-time tc)))
+    (if (and w (event-pre-resize (dispatcher w) w))
       1
       0)))
 
@@ -427,15 +423,15 @@
       (gfs::kill-timer hwnd wparam)
       (cond
         ((<= (delay-of timer) 0)
-          (event-timer (dispatcher timer) timer (event-time tc))
+          (event-timer (dispatcher timer) timer)
           (gfs:dispose timer))
         ((/= (delay-of timer) (initial-delay-of timer))
           (let ((delay (reset-timer-to-delay timer (delay-of timer))))
             (setf (slot-value timer 'delay) delay)
             (setf (slot-value timer 'initial-delay) delay))
-          (event-timer (dispatcher timer) timer (event-time tc)))
+          (event-timer (dispatcher timer) timer))
         (t
-          (event-timer (dispatcher timer) timer (event-time tc))))))
+          (event-timer (dispatcher timer) timer)))))
   0)
 
 ;;;

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sun Jul  9 02:35:37 2006
@@ -153,7 +153,7 @@
 
 (defmethod gfs:dispose ((w widget))
   (unless (null (dispatcher w))
-    (event-dispose (dispatcher w) w (event-time (thread-context))))
+    (event-dispose (dispatcher w) w))
   (let ((hwnd (gfs:handle w)))
     (if (not (gfs:null-handle-p hwnd))
       (if (zerop (gfs::destroy-window hwnd))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Jul  9 02:35:37 2006
@@ -180,8 +180,8 @@
     (let ((sz (client-size win)))
       (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
 
-(defmethod event-resize ((d event-dispatcher) (win window) time size type)
-  (declare (ignorable d time size type))
+(defmethod event-resize ((d event-dispatcher) (win window) size type)
+  (declare (ignore size type))
   (unless (null (layout-of win))
     (let ((sz (client-size win)))
       (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))


From junrue at common-lisp.net  Sun Jul  9 15:30:41 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  9 Jul 2006 11:30:41 -0400 (EDT)
Subject: [graphic-forms-cvs] r187 - in trunk: docs/manual src/demos/textedit
	src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060709153041.01CD91F012@common-lisp.net>

Author: junrue
Date: Sun Jul  9 11:30:38 2006
New Revision: 187

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/tests/uitoolkit/drawing-tester.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event-source.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
completed event-activate and added event-deactivate

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  9 11:30:38 2006
@@ -836,8 +836,9 @@
 
 This chapter documents two types of functions:
 @itemize @bullet
- at item generic functions implemented in order to handle system events
- at item functions provided to help implement application message pumps
+ at item generic functions whose methods are to be implemented by application
+code in order to handle system events
+ at item functions provided to help implement message loops
 @end itemize
 
 @anchor{default-message-filter}
@@ -861,29 +862,19 @@
 @end table
 @end defun
 
- at deffn GenericFunction event-activate dispatcher widget type
+ at anchor{event-activate}
+ at deffn GenericFunction event-activate dispatcher widget
 Implement this method to respond to @var{widget} being activated. For
 a @ref{top-level} @ref{window} or @ref{dialog}, this means that
 @var{widget} was brought to the foreground and its trim (titlebar and
 border) was highlighted to indicate that it is now the active
 window. For a @ref{menu}, it means that the user has clicked on the
 @ref{item} invoking @ref{widget} and it is about to be shown; this is
-an opportunity to update the menu's contents.
+an opportunity to update the menu's contents. @xref{event-deactivate}.
 @table @var
 @event-dispatcher-arg
 @item widget
 The menu, dialog, or window that has been activated.
- at item type
-Provides a hint as to how activation occurred, via one of the following
-keywords:
- at table @code
- at item :click
-Indicates that @var{widget} was activated as the result of a mouse click.
- at item :programmatic
-Indicates that @var{widget} was activated as the result of the keyboard
-interface to select a window, or programmatically via a call to
- at sc{activate}.
- at end table
 @end table
 @end deffn
 
@@ -910,6 +901,19 @@
 @end table
 @end deffn
 
+ at anchor{event-deactivate}
+ at deffn GenericFunction event-deactivate dispatcher widget
+Implement this method to respond to @var{widget} being deactivated,
+meaning that some other object has been made active.  This event only
+applies to @ref{top-level} @ref{window}s or
+ at ref{dialog}s. @xref{event-activate}.
+ at table @var
+ at event-dispatcher-arg
+ at item widget
+The dialog or window that has been deactivated.
+ at end table
+ at end deffn
+
 @deffn GenericFunction event-dispose dispatcher widget
 Implement this method to respond to @var{widget} being disposed (explicitly
 via @ref{dispose}, not collected via the garbage collector). This
@@ -1089,7 +1093,7 @@
 @item widget
 The @ref{widget} (or item) that was selected.
 @item rect
-The @ref{rectangle} bounding @var{widget}.
+The @ref{rectangle} bounding the selection inside @var{widget}.
 @end table
 @end deffn
 
@@ -1123,7 +1127,7 @@
 @anchor{obtain-event-time}
 @defun obtain-event-time => milliseconds
 Returns the timestamp for the event currently being processed, or
-zero if called prior to the delivery of any events.
+zero if called prior to delivery of any events.
 @end defun
 
 

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Sun Jul  9 11:30:38 2006
@@ -40,8 +40,8 @@
 (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt")
                                   ("All Files (*.*)"    . "*.*")))
 
-(defun manage-textedit-file-menu (disp menu type)
-  (declare (ignore disp type))
+(defun manage-textedit-file-menu (disp menu)
+  (declare (ignore disp))
   (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
 
 (defun textedit-file-new (disp item rect)
@@ -95,15 +95,15 @@
 
 (defclass textedit-win-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((disp textedit-win-events) window)
-  (declare (ignore window))
-  (textedit-file-quit disp nil nil))
-
-(defmethod gfw:event-focus-gain ((self textedit-win-events) window)
+(defmethod gfw:event-activate ((self textedit-win-events) window)
   (declare (ignore window))
   (if *textedit-control*
     (gfw:give-focus *textedit-control*)))
 
+(defmethod gfw:event-close ((disp textedit-win-events) window)
+  (declare (ignore window))
+  (textedit-file-quit disp nil nil))
+
 (defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-close ((disp textedit-about-dialog-events) (dlg gfw:dialog))

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp	Sun Jul  9 11:30:38 2006
@@ -42,8 +42,8 @@
     (gfw:check *last-checked-drawing-item* nil))
   (gfw:check item t))
 
-(defun find-checked-item (disp menu type)
-  (declare (ignore disp type))
+(defun find-checked-item (disp menu)
+  (declare (ignore disp))
   (dotimes (i (length (gfw:items menu)))
     (let ((item (elt (gfw:items menu) i)))
       (when (gfw:checked-p item)

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Jul  9 11:30:38 2006
@@ -72,6 +72,14 @@
           (not (gfw:key-toggled-p gfw:+vk-num-lock+))
           (not (gfw:key-toggled-p gfw:+vk-scroll-lock+))))
 
+(defun text-for-activation (action)
+  (format nil
+          "~a action: ~s  time: 0x~x  ~s"
+          (incf *event-counter*)
+          action
+          (gfw:obtain-event-time)
+          (text-for-modifiers)))
+
 (defun text-for-mouse (action button pnt)
   (format nil
           "~a mouse action: ~s  button: ~a  point: (~d,~d)  time: 0x~x  ~s"
@@ -128,7 +136,15 @@
           (gfw:id-of *timer*)
           (gfw:obtain-event-time)
           (text-for-modifiers)))
-          
+
+(defmethod gfw:event-activate ((d event-tester-window-events) window)
+  (setf *event-tester-text* (text-for-activation "window activated"))
+  (gfw:redraw window))
+
+(defmethod gfw:event-deactivate ((d event-tester-window-events) window)
+  (setf *event-tester-text* (text-for-activation "window deactivated"))
+  (gfw:redraw window))
+
 (defmethod gfw:event-key-down ((d event-tester-window-events) window key-code char)
   (setf *event-tester-text* (text-for-key "down" key-code char))
   (gfw:redraw window))
@@ -187,8 +203,7 @@
   (setf *event-tester-text* (text-for-item (gfw:text item) "item armed"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget type)
-  (declare (ignore type))
+(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget)
   (setf *event-tester-text* (text-for-item (format nil "~a" widget) "menu activated"))
   (gfw:redraw *event-tester-window*))
 
@@ -197,8 +212,8 @@
   (setf *event-tester-text* (text-for-timer))
   (gfw:redraw *event-tester-window*))
 
-(defun manage-file-menu (disp menu type)
-  (declare (ignore disp type))
+(defun manage-file-menu (disp menu)
+  (declare (ignore disp))
   (let ((item (elt (gfw:items menu) 0)))
     (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
 

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Jul  9 11:30:38 2006
@@ -169,8 +169,7 @@
     :initarg :sub-disp-class
     :initform nil)))
 
-(defmethod gfw:event-activate ((d child-menu-dispatcher) menu type)
-  (declare (ignore type))
+(defmethod gfw:event-activate ((d child-menu-dispatcher) menu)
   (gfw:clear-all menu)
   (gfw:mapchildren *layout-tester-win*
                    (lambda (parent child)
@@ -208,8 +207,8 @@
       (gfw:show victim (not (gfw:visible-p victim)))
       (gfw:layout *layout-tester-win*))))
 
-(defun check-flow-orient-items (disp menu type)
-  (declare (ignore disp type))
+(defun check-flow-orient-items (disp menu)
+  (declare (ignore disp))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout)))
     (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))
@@ -250,8 +249,8 @@
       (setf (gfw:style-of layout) (push :wrap style)))
     (gfw:layout *layout-tester-win*)))
 
-(defun enable-flow-spacing-items (disp menu type)
-  (declare (ignore disp type))
+(defun enable-flow-spacing-items (disp menu)
+  (declare (ignore disp))
   (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
     (gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))
 
@@ -338,8 +337,8 @@
     (decf (gfw:bottom-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun flow-mod-callback (disp menu type)
-  (declare (ignore disp type))
+(defun flow-mod-callback (disp menu)
+  (declare (ignore disp))
   (gfw:clear-all menu)
   (let ((it nil)
         (margin-menu (gfw:defmenu ((:item "Left"

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Sun Jul  9 11:30:38 2006
@@ -146,8 +146,7 @@
     (error 'gfs:disposed-error)))
 
 (defmethod give-focus ((self control))
-  (if (gfs:null-handle-p (gfs::set-focus (gfs:handle self)))
-    (error 'gfs:win32-error :detail "set-focus failed")))
+  (gfs::set-focus (gfs:handle self)))
 
 (defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys)
   (if (gfs:disposed-p parent)

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Sun Jul  9 11:30:38 2006
@@ -33,10 +33,10 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defgeneric event-activate (dispatcher widget type)
+(defgeneric event-activate (dispatcher widget)
   (:documentation "Implement this to respond to an object being activated.")
-  (:method (dispatcher widget type)
-    (declare (ignorable dispatcher widget type))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
 (defgeneric event-arm (dispatcher item)
   (:documentation "Implement this to respond to an object about to be selected.")
@@ -53,10 +53,10 @@
   (:method (dispatcher item rect)
     (declare (ignorable dispatcher item rect))))
 
-(defgeneric event-deactivate (dispatcher widget type)
+(defgeneric event-deactivate (dispatcher widget)
   (:documentation "Implement this to respond to an object being deactivated.")
-  (:method (dispatcher widget type)
-    (declare (ignorable dispatcher widget type))))
+  (:method (dispatcher widget)
+    (declare (ignorable dispatcher widget))))
 
 (defgeneric event-deiconify (dispatcher widget)
   (:documentation "Implement this to respond to an object being deiconified.")

Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp	Sun Jul  9 11:30:38 2006
@@ -33,7 +33,7 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source symbol))
+(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source))
                                (gfw:event-arm      . (gfw:event-source))
                                (gfw:event-select   . (gfw:event-source gfs:rectangle))))
 

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Jul  9 11:30:38 2006
@@ -190,7 +190,7 @@
     (unless (null menu)
       (let ((d (dispatcher menu)))
         (unless (null d)
-          (event-activate d menu :click))))) ; FIXME: menus can be invoked programmatically, too
+          (event-activate d menu)))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
@@ -349,18 +349,26 @@
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-up hwnd lparam :right-button))
 
+(defmethod process-message (hwnd (msg (eql gfs::+wm-activate+)) wparam lparam)
+  (declare (ignore lparam))
+  (let ((widget (get-widget (thread-context) hwnd)))
+    (if widget
+      (ecase wparam
+        (#.gfs::+wa-active+      (event-activate   (dispatcher widget) widget))
+        (#.gfs::+wa-clickactive+ (event-activate   (dispatcher widget) widget))
+        (#.gfs::+wa-inactive+    (event-deactivate (dispatcher widget) widget)))))
+  0)
+
 (defmethod process-message (hwnd (msg (eql gfs::+wm-killfocus+)) wparam lparam)
   (declare (ignore wparam lparam))
-  (let* ((tc (thread-context))
-         (widget (get-widget tc hwnd)))
+  (let ((widget (get-widget (thread-context) hwnd)))
     (if widget
       (event-focus-loss (dispatcher widget) widget)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-setfocus+)) wparam lparam)
   (declare (ignore wparam lparam))
-  (let* ((tc (thread-context))
-         (widget (get-widget tc hwnd)))
+  (let ((widget (get-widget (thread-context) hwnd)))
     (if widget
       (event-focus-gain (dispatcher widget) widget)))
   0)

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Jul  9 11:30:38 2006
@@ -199,8 +199,7 @@
     (error 'gfs:disposed-error)))
 
 (defmethod give-focus ((win window))
-  (if (gfs:null-handle-p (gfs::set-focus (gfs:handle win)))
-    (error 'gfs:win32-error :detail "set-focus failed")))
+  (gfs::set-focus (gfs:handle win)))
 
 (defmethod location ((win window))
   (if (gfs:disposed-p win)


From junrue at common-lisp.net  Sun Jul  9 16:03:28 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  9 Jul 2006 12:03:28 -0400 (EDT)
Subject: [graphic-forms-cvs] r188 - in trunk: docs/manual src/demos/textedit
	src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060709160328.A2EF14405A@common-lisp.net>

Author: junrue
Date: Sun Jul  9 12:03:27 2006
New Revision: 188

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/demos/unblocked/unblocked-window.lisp
   trunk/src/tests/uitoolkit/drawing-tester.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/image-tester.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/tests/uitoolkit/windlg.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event-source.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
removed rectangle argument from event-select and generated callbacks

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  9 12:03:27 2006
@@ -1084,7 +1084,7 @@
 @end deffn
 
 @anchor{event-select}
- at deffn GenericFunction event-select dispatcher widget rect
+ at deffn GenericFunction event-select dispatcher widget
 Implement this method to handle notification that @var{widget} (or some
 @ref{item} within @var{widget}) has been clicked on by the user in order
 to invoke some action.
@@ -1092,8 +1092,6 @@
 @event-dispatcher-arg
 @item widget
 The @ref{widget} (or item) that was selected.
- at item rect
-The @ref{rectangle} bounding the selection inside @var{widget}.
 @end table
 @end deffn
 

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Sun Jul  9 12:03:27 2006
@@ -44,15 +44,15 @@
   (declare (ignore disp))
   (gfw:enable (elt (gfw:items menu) 2) (gfw:text-modified-p *textedit-control*)))
 
-(defun textedit-file-new (disp item rect)
-  (declare (ignore disp item rect))
+(defun textedit-file-new (disp item)
+  (declare (ignore disp item))
   (when *textedit-control*
     (setf (gfw:text *textedit-control*) "")
     (setf (gfw:text-modified-p *textedit-control*) nil)
     (setf (file-path *textedit-model*) nil)))
 
-(defun textedit-file-open (disp item rect)
-  (declare (ignore disp item rect))
+(defun textedit-file-open (disp item)
+  (declare (ignore disp item))
   (gfw:with-file-dialog (*textedit-win*
                          '(:open :add-to-recent :path-must-exist)
                          paths
@@ -61,14 +61,14 @@
       (load-textedit-doc (first paths))
       (setf (file-path *textedit-model*) (namestring (first paths))))))
 
-(defun textedit-file-save (disp item rect)
+(defun textedit-file-save (disp item)
   (if (file-path *textedit-model*)
     (save-textedit-doc (file-path *textedit-model*) (gfw:text *textedit-control*))
-    (textedit-file-save-as disp item rect))
+    (textedit-file-save-as disp item))
   (setf (gfw:text-modified-p *textedit-control*) nil))
 
-(defun textedit-file-save-as (disp item rect)
-  (declare (ignore disp item rect))
+(defun textedit-file-save-as (disp item)
+  (declare (ignore disp item))
   (gfw:with-file-dialog (*textedit-win*
                          '(:save :add-to-recent)
                          paths
@@ -79,15 +79,15 @@
       (setf (file-path *textedit-model*) (namestring (first paths)))
       (setf (gfw:text-modified-p *textedit-control*) nil))))
 
-(defun textedit-file-quit (disp item rect)
-  (declare (ignore disp item rect))
+(defun textedit-file-quit (disp item)
+  (declare (ignore disp item))
   (setf *textedit-control* nil)
   (gfs:dispose *textedit-win*)
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
-(defun textedit-font (disp item rect)
-  (declare (ignore disp item rect))
+(defun textedit-font (disp item)
+  (declare (ignore disp item))
   (gfw:with-graphics-context (gc *textedit-control*)
     (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*))
       (if font
@@ -102,7 +102,7 @@
 
 (defmethod gfw:event-close ((disp textedit-win-events) window)
   (declare (ignore window))
-  (textedit-file-quit disp nil nil))
+  (textedit-file-quit disp nil))
 
 (defclass textedit-about-dialog-events (gfw:event-dispatcher) ())
 
@@ -110,8 +110,8 @@
   (call-next-method)
   (gfs:dispose dlg))
 
-(defun about-textedit (disp item rect)
-  (declare (ignore disp item rect))
+(defun about-textedit (disp item)
+  (declare (ignore disp item))
   (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*)))
          (dlg (make-instance 'gfw:dialog :owner *textedit-win*
                                          :dispatcher (make-instance 'textedit-about-dialog-events)
@@ -152,8 +152,8 @@
                                                           :spacing 0
                                                           :style '(:vertical :normalize))))
          (close-btn (make-instance 'gfw:button
-                                   :callback (lambda (disp btn rect)
-                                               (declare (ignore disp btn rect))
+                                   :callback (lambda (disp btn)
+                                               (declare (ignore disp btn))
                                                (gfs:dispose dlg))
                                    :style '(:cancel-button)
                                    :text "Close"

Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp	(original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp	Sun Jul  9 12:03:27 2006
@@ -52,14 +52,14 @@
 (defun get-scoreboard-panel ()
   *scoreboard-panel*)
 
-(defun new-unblocked (disp item rect)
-  (declare (ignore disp item rect))
+(defun new-unblocked (disp item)
+  (declare (ignore disp item))
   (new-game)
   (update-panel *scoreboard-panel*)
   (update-panel *tiles-panel*))
 
-(defun restart-unblocked (disp item rect)
-  (declare (ignore disp item rect))
+(defun restart-unblocked (disp item)
+  (declare (ignore disp item))
   (restart-game)
   (update-panel *scoreboard-panel*)
   (update-panel *tiles-panel*))
@@ -69,8 +69,8 @@
         (kind (shape-kind shape)))
     (and (> size 1) (/= kind 0) (/= kind +max-tile-kinds+))))
 
-(defun reveal-unblocked (disp item rect)
-  (declare (ignore disp item rect))
+(defun reveal-unblocked (disp item)
+  (declare (ignore disp item))
   (let ((shape (find-shape (game-tiles) #'accept-shape-p)))
     (when shape
       (let ((shape-pnts (shape-tile-points shape))
@@ -80,8 +80,8 @@
         (draw-tiles-directly *tiles-panel* shape-pnts +max-tile-kinds+)
         (gfw:enable timer t)))))
 
-(defun quit-unblocked (disp item rect)
-  (declare (ignore disp item rect))
+(defun quit-unblocked (disp item)
+  (declare (ignore disp item))
   (setf *scoreboard-panel* nil)
   (setf *tiles-panel* nil)
   (gfs:dispose *unblocked-win*)
@@ -92,7 +92,7 @@
 
 (defmethod gfw:event-close ((disp unblocked-win-events) window)
   (declare (ignore window))
-  (quit-unblocked disp nil nil))
+  (quit-unblocked disp nil))
 
 (defmethod gfw:event-timer ((disp unblocked-win-events) timer)
   (declare (ignore timer))
@@ -104,8 +104,8 @@
   (call-next-method)
   (gfs:dispose dlg))
 
-(defun about-unblocked (disp item rect)
-  (declare (ignore disp item rect))
+(defun about-unblocked (disp item)
+  (declare (ignore disp item))
   (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*)))
          (dlg (make-instance 'gfw:dialog :owner *unblocked-win*
                                          :dispatcher (make-instance 'unblocked-about-dialog-events)
@@ -146,8 +146,8 @@
                                                           :spacing 0
                                                           :style '(:vertical :normalize))))
          (close-btn (make-instance 'gfw:button
-                                   :callback (lambda (disp btn rect)
-                                               (declare (ignore disp btn rect))
+                                   :callback (lambda (disp btn)
+                                               (declare (ignore disp btn))
                                                (gfs:dispose dlg))
                                    :style '(:cancel-button)
                                    :text "Close"
@@ -203,7 +203,7 @@
       (setf (gfw:minimum-size *unblocked-win*) size)
       (setf (gfw:maximum-size *unblocked-win*) size))
 
-    (new-unblocked nil nil nil)
+    (new-unblocked nil nil)
     (gfw:show *unblocked-win* t)))
 
 (defun unblocked ()

Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp	Sun Jul  9 12:03:27 2006
@@ -50,8 +50,8 @@
         (setf *last-checked-drawing-item* item)
         (return)))))
 
-(defun drawing-exit-fn (disp item rect)
-  (declare (ignore disp item rect))
+(defun drawing-exit-fn (disp item)
+  (declare (ignore disp item))
   (gfs:dispose *drawing-win*)
   (setf *drawing-win* nil)
   (gfw:shutdown 0))
@@ -63,7 +63,7 @@
 
 (defmethod gfw:event-close ((self drawing-win-events) window)
   (declare (ignore window))
-  (drawing-exit-fn self nil nil))
+  (drawing-exit-fn self nil))
 
 (defmethod gfw:event-paint ((self drawing-win-events) window gc rect)
   (declare (ignore rect))
@@ -162,8 +162,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil)))
 
-(defun select-arcs (disp item rect)
-  (declare (ignore disp rect))
+(defun select-arcs (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
   (gfw:redraw *drawing-win*))
@@ -185,8 +185,8 @@
       (setf (gfg:pen-style gc) '(:dot :square-endcap))
       (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts))))
 
-(defun select-beziers (disp item rect)
-  (declare (ignore disp rect))
+(defun select-beziers (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers)
   (gfw:redraw *drawing-win*))
@@ -202,8 +202,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil)))
 
-(defun select-ellipses (disp item rect)
-  (declare (ignore disp rect))
+(defun select-ellipses (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses)
   (gfw:redraw *drawing-win*))
@@ -240,8 +240,8 @@
                     #'gfg:draw-line
                     nil)))
 
-(defun select-lines (disp item rect)
-  (declare (ignore disp rect))
+(defun select-lines (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-lines)
   (gfw:redraw *drawing-win*))
@@ -264,8 +264,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil)))
 
-(defun select-rects (disp item rect)
-  (declare (ignore disp rect))
+(defun select-rects (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-rects)
   (gfw:redraw *drawing-win*))
@@ -314,8 +314,8 @@
     (setf (gfg:foreground-color gc) gfg:*color-red*)
     (draw-a-string gc pnt "text" "Arial" 12 nil '(:transparent))))
 
-(defun select-text (disp item rect)
-  (declare (ignore disp rect))
+(defun select-text (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-strings)
   (gfw:redraw *drawing-win*))
@@ -336,8 +336,8 @@
     (setf rect (gfs:make-rectangle :location (clone-point rect-pnt) :size rect-size))
     (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil)))
 
-(defun select-wedges (disp item rect)
-  (declare (ignore disp rect))
+(defun select-wedges (disp item)
+  (declare (ignore disp))
   (update-drawing-item-check item)
   (setf (draw-func-of *drawing-dispatcher*) #'draw-wedges)
   (gfw:redraw *drawing-win*))

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Jul  9 12:03:27 2006
@@ -184,8 +184,8 @@
 
 (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item rect)
-  (declare (ignore item rect))
+(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item)
+  (declare (ignore item))
   (exit-event-tester))
 
 (defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item)
@@ -194,8 +194,7 @@
 
 (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item rect)
-  (declare (ignore rect))
+(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item)
   (setf *event-tester-text* (text-for-item (gfw:text item) "item selected"))
   (gfw:redraw *event-tester-window*))
 
@@ -217,8 +216,8 @@
   (let ((item (elt (gfw:items menu) 0)))
     (setf (gfw:text item) (if *timer* "Sto&p Timer" "&Start Timer"))))
 
-(defun manage-timer (disp item rect)
-  (declare (ignore disp item rect))
+(defun manage-timer (disp item)
+  (declare (ignore disp item))
   (if *timer*
     (progn
       (gfw:enable *timer* nil)

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Sun Jul  9 12:03:27 2006
@@ -37,15 +37,15 @@
 
 (defclass hellowin-events (gfw:event-dispatcher) ())
 
-(defun exit-fn (disp item rect)
-  (declare (ignore disp item rect))
+(defun exit-fn (disp item)
+  (declare (ignore disp item))
   (gfs:dispose *hello-win*)
   (setf *hello-win* nil)
   (gfw:shutdown 0))
 
 (defmethod gfw:event-close ((disp hellowin-events) window)
   (declare (ignore window))
-  (exit-fn disp nil nil))
+  (exit-fn disp nil))
 
 (defmethod gfw:event-paint ((disp hellowin-events) window gc rect)
   (declare (ignore rect))

Modified: trunk/src/tests/uitoolkit/image-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/image-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/image-tester.lisp	Sun Jul  9 12:03:27 2006
@@ -86,8 +86,8 @@
       (incf (gfs:point-x pnt) 20)
       (gfg:draw-image gc *true-image* pnt))))
 
-(defun exit-image-fn (disp item rect)
-  (declare (ignorable disp item rect))
+(defun exit-image-fn (disp item)
+  (declare (ignorable disp item))
   (dispose-images)
   (gfs:dispose *image-win*)
   (setf *image-win* nil)

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Jul  9 12:03:27 2006
@@ -58,8 +58,8 @@
 
 (defclass pack-layout-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d pack-layout-dispatcher) item rect)
-  (declare (ignore item rect))
+(defmethod gfw:event-select ((d pack-layout-dispatcher) item)
+  (declare (ignore item))
   (gfw:pack *layout-tester-win*))
 
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
@@ -139,8 +139,7 @@
                                 :dispatcher be))))
     (incf *widget-counter*)))
 
-(defmethod gfw:event-select ((d layout-tester-widget-events) btn rect)
-  (declare (ignore rect))
+(defmethod gfw:event-select ((d layout-tester-widget-events) btn)
   (setf (gfw:text btn) (funcall (toggle-fn d)))
   (gfw:layout *layout-tester-win*))
 
@@ -154,8 +153,8 @@
     :initarg :subtype
     :initform :push-button)))
 
-(defmethod gfw:event-select ((d add-child-dispatcher) item rect)
-  (declare (ignorable item rect))
+(defmethod gfw:event-select ((d add-child-dispatcher) item)
+  (declare (ignore item))
   (add-layout-tester-widget (widget-class d) (subtype d))
   (gfw:pack *layout-tester-win*))
 
@@ -191,8 +190,7 @@
 
 (defclass remove-child-dispatcher (gfw:event-dispatcher) ())  
 
-(defmethod gfw:event-select ((d remove-child-dispatcher) item rect)
-  (declare (ignore rect))
+(defmethod gfw:event-select ((d remove-child-dispatcher) item)
   (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfs:dispose victim)
@@ -200,8 +198,7 @@
 
 (defclass visibility-child-dispatcher (gfw:event-dispatcher) ())  
 
-(defmethod gfw:event-select ((d visibility-child-dispatcher) item rect)
-  (declare (ignore rect))
+(defmethod gfw:event-select ((d visibility-child-dispatcher) item)
   (let ((victim (find-victim (gfw:text item))))
     (unless (null victim)
       (gfw:show victim (not (gfw:visible-p victim)))
@@ -213,8 +210,8 @@
     (gfw:check (elt (gfw:items menu) 0) (find :horizontal (gfw:style-of layout)))
     (gfw:check (elt (gfw:items menu) 1) (find :vertical (gfw:style-of layout)))))
 
-(defun set-flow-horizontal (disp item rect)
-  (declare (ignorable disp item rect))
+(defun set-flow-horizontal (disp item)
+  (declare (ignorable disp item))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (setf style (remove :vertical style))
@@ -222,8 +219,8 @@
     (setf (gfw:style-of layout) style)
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-vertical (disp item rect)
-  (declare (ignorable disp item rect))
+(defun set-flow-vertical (disp item)
+  (declare (ignorable disp item))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (setf style (remove :horizontal style))
@@ -231,8 +228,8 @@
     (setf (gfw:style-of layout) style)
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-layout-normalize (disp item rect)
-  (declare (ignorable disp item rect))
+(defun set-flow-layout-normalize (disp item)
+  (declare (ignorable disp item))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (if (find :normalize style)
@@ -240,8 +237,8 @@
       (setf (gfw:style-of layout) (push :normalize style)))
     (gfw:layout *layout-tester-win*)))
 
-(defun set-flow-layout-wrap (disp item rect)
-  (declare (ignorable disp item rect))
+(defun set-flow-layout-wrap (disp item)
+  (declare (ignorable disp item))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (style (gfw:style-of layout)))
     (if (find :wrap style)
@@ -254,8 +251,8 @@
   (let ((spacing (gfw:spacing-of (gfw:layout-of *layout-tester-win*))))
     (gfw:enable (elt (gfw:items menu) 0) (> spacing 0))))
 
-(defun decrease-flow-spacing (disp item rect)
-  (declare (ignore disp item rect))
+(defun decrease-flow-spacing (disp item)
+  (declare (ignore disp item))
   (let* ((layout (gfw:layout-of *layout-tester-win*))
          (spacing (gfw:spacing-of layout)))
     (unless (zerop spacing)
@@ -263,76 +260,76 @@
       (setf (gfw:spacing-of layout) spacing)
       (gfw:layout *layout-tester-win*))))
 
-(defun increase-flow-spacing (disp item rect)
-  (declare (ignore disp item rect))
+(defun increase-flow-spacing (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:spacing-of layout) +spacing-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun enable-left-flow-margin-items (disp menu rect)
-  (declare (ignore disp rect))
+(defun enable-left-flow-margin-items (disp menu)
+  (declare (ignore disp))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:left-margin-of layout) 0))))
 
-(defun enable-top-flow-margin-items (disp menu rect)
-  (declare (ignore disp rect))
+(defun enable-top-flow-margin-items (disp menu)
+  (declare (ignore disp))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:top-margin-of layout) 0))))
 
-(defun enable-right-flow-margin-items (disp menu rect)
-  (declare (ignore disp rect))
+(defun enable-right-flow-margin-items (disp menu)
+  (declare (ignore disp))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:right-margin-of layout) 0))))
 
-(defun enable-bottom-flow-margin-items (disp menu rect)
-  (declare (ignore disp rect))
+(defun enable-bottom-flow-margin-items (disp menu)
+  (declare (ignore disp))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (gfw:enable (elt (gfw:items menu) 0) (> (gfw:bottom-margin-of layout) 0))))
 
-(defun inc-left-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun inc-left-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:left-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-top-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun inc-top-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:top-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-right-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun inc-right-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:right-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun inc-bottom-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun inc-bottom-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (incf (gfw:bottom-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-left-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun dec-left-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:left-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-top-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun dec-top-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:top-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-right-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun dec-right-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:right-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
 
-(defun dec-bottom-flow-margin (disp item rect)
-  (declare (ignore disp item rect))
+(defun dec-bottom-flow-margin (disp item)
+  (declare (ignore disp item))
   (let ((layout (gfw:layout-of *layout-tester-win*)))
     (decf (gfw:bottom-margin-of layout) +margin-delta+)
     (gfw:layout *layout-tester-win*)))
@@ -382,8 +379,8 @@
       (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
       (gfw:check it (find :wrap style)))))
 
-(defun exit-layout-callback (disp item rect)
-  (declare (ignorable disp item rect))
+(defun exit-layout-callback (disp item)
+  (declare (ignorable disp item))
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()

Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp	(original)
+++ trunk/src/tests/uitoolkit/windlg.lisp	Sun Jul  9 12:03:27 2006
@@ -37,15 +37,15 @@
 
 (defclass main-win-events (gfw:event-dispatcher) ())
 
-(defun windlg-exit-fn (disp item rect)
-  (declare (ignore disp item rect))
+(defun windlg-exit-fn (disp item)
+  (declare (ignore disp item))
   (gfs:dispose *main-win*)
   (setf *main-win* nil)
   (gfw:shutdown 0))
 
 (defmethod gfw:event-close ((self main-win-events) window)
   (declare (ignore window))
-  (windlg-exit-fn self nil nil))
+  (windlg-exit-fn self nil))
 
 (defclass test-win-events (gfw:event-dispatcher) ())
 
@@ -66,8 +66,8 @@
   (declare (ignore point button))
   (gfs:dispose window))
 
-(defun create-borderless-win (disp item rect)
-  (declare (ignore disp item rect))
+(defun create-borderless-win (disp item)
+  (declare (ignore disp item))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events)
                                               :owner *main-win*
                                               :style '(:borderless))))
@@ -75,8 +75,8 @@
     (gfw:center-on-owner window)
     (gfw:show window t)))
 
-(defun create-miniframe-win (disp item rect)
-  (declare (ignore disp item rect))
+(defun create-miniframe-win (disp item)
+  (declare (ignore disp item))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
                                               :text "Mini Frame"
@@ -85,8 +85,8 @@
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
     (gfw:show window t)))
 
-(defun create-palette-win (disp item rect)
-  (declare (ignore disp item rect))
+(defun create-palette-win (disp item)
+  (declare (ignore disp item))
   (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-mini-events)
                                               :owner *main-win*
                                               :text "Palette"
@@ -95,8 +95,8 @@
     (setf (gfw:size window) (gfs:make-size :width 150 :height 225))
     (gfw:show window t)))
 
-(defun open-file-dlg (disp item rect)
-  (declare (ignore disp item rect))
+(defun open-file-dlg (disp item)
+  (declare (ignore disp item))
   (gfw:with-file-dialog (*main-win*
                          '(:open :add-to-recent :multiple-select)
                          paths
@@ -107,8 +107,8 @@
                          :text "Select Lisp-related files...")
     (print paths)))
 
-(defun save-file-dlg (disp item rect)
-  (declare (ignore disp item rect))
+(defun save-file-dlg (disp item)
+  (declare (ignore disp item))
   (gfw:with-file-dialog (*main-win*
                          '(:save)
                          paths
@@ -117,8 +117,8 @@
                          :initial-directory #P"c:/")
     (print paths)))
 
-(defun choose-font-dlg (disp item rect)
-  (declare (ignore disp item rect))
+(defun choose-font-dlg (disp item)
+  (declare (ignore disp item))
   (gfw:with-graphics-context (gc *main-win*)
     (gfw:with-font-dialog (*main-win* nil font color :gc gc)
       (if color
@@ -198,15 +198,15 @@
                                                           :style '(:vertical :normalize))
                                    :parent dlg))
          (ok-btn (make-instance 'gfw:button
-                                :callback (lambda (disp btn rect)
-                                            (declare (ignore disp btn rect))
+                                :callback (lambda (disp btn)
+                                            (declare (ignore disp btn))
                                             (gfs:dispose dlg))
                                 :style '(:default-button)
                                 :text "OK"
                                 :parent btn-panel))
          (cancel-btn (make-instance 'gfw:button
-                                    :callback (lambda (disp btn rect)
-                                                (declare (ignore disp btn rect))
+                                    :callback (lambda (disp btn)
+                                                (declare (ignore disp btn))
                                                 (gfs:dispose dlg))
                                     :style '(:cancel-button)
                                     :text "Cancel"
@@ -220,12 +220,12 @@
     (gfw:show dlg t)
     dlg))
 
-(defun open-modal-dlg (disp item rect)
-  (declare (ignore disp item rect))
+(defun open-modal-dlg (disp item)
+  (declare (ignore disp item))
   (open-dlg "Modal" '(:owner-modal)))
 
-(defun open-modeless-dlg (disp item rect)
-  (declare (ignore disp item rect))
+(defun open-modeless-dlg (disp item)
+  (declare (ignore disp item))
   (open-dlg "Modeless" '(:modeless)))
 
 (defun run-windlg-internal ()

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Sun Jul  9 12:03:27 2006
@@ -48,10 +48,10 @@
   (:method (dispatcher widget)
     (declare (ignorable dispatcher widget))))
 
-(defgeneric event-collapse (dispatcher item rect)
+(defgeneric event-collapse (dispatcher item)
   (:documentation "Implement this to respond to an object (or item within) being collapsed.")
-  (:method (dispatcher item rect)
-    (declare (ignorable dispatcher item rect))))
+  (:method (dispatcher item)
+    (declare (ignorable dispatcher item))))
 
 (defgeneric event-deactivate (dispatcher widget)
   (:documentation "Implement this to respond to an object being deactivated.")
@@ -68,10 +68,10 @@
   (:method (dispatcher widget)
     (declare (ignorable dispatcher widget))))
 
-(defgeneric event-expand (dispatcher item rect)
+(defgeneric event-expand (dispatcher item)
   (:documentation "Implement this to respond to an object (or item within) being expanded.")
-  (:method (dispatcher item rect)
-    (declare (ignorable dispatcher item rect))))
+  (:method (dispatcher item)
+    (declare (ignorable dispatcher item))))
 
 (defgeneric event-focus-gain (dispatcher widget)
   (:documentation "Implement this to respond to an object gaining keyboard focus.")
@@ -173,10 +173,10 @@
   (:method (dispatcher widget size type)
     (declare (ignorable dispatcher widget size type))))
 
-(defgeneric event-select (dispatcher item rect)
+(defgeneric event-select (dispatcher item)
   (:documentation "Implement this to respond to an object (or item within) being selected.")
-  (:method (dispatcher item rect)
-    (declare (ignorable dispatcher item rect))))
+  (:method (dispatcher item)
+    (declare (ignorable dispatcher item))))
 
 (defgeneric event-show (dispatcher widget)
   (:documentation "Implement this to respond to an object being shown.")

Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp	Sun Jul  9 12:03:27 2006
@@ -35,7 +35,7 @@
 
 (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source))
                                (gfw:event-arm      . (gfw:event-source))
-                               (gfw:event-select   . (gfw:event-source gfs:rectangle))))
+                               (gfw:event-select   . (gfw:event-source))))
 
 (defun make-specializer-list (disp-class arg-info)
   (let ((tmp (mapcar #'find-class arg-info)))

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Jul  9 12:03:27 2006
@@ -120,7 +120,7 @@
 (defun dispatch-notification (widget wparam-hi)
   (let ((disp (dispatcher widget)))
     (case wparam-hi
-      (0                     (event-select     disp widget (gfs:make-rectangle))) ; FIXME
+      (0                     (event-select     disp widget))
       (#.gfs::+en-killfocus+ (event-focus-loss disp widget))
       (#.gfs::+en-setfocus+  (event-focus-gain disp widget))
       (#.gfs::+en-update+    (event-modify     disp widget)))))
@@ -172,7 +172,7 @@
             (if (null item)
               (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo))
               (unless (null (dispatcher item))
-                (event-select (dispatcher item) item (gfs:make-rectangle)))))) ; FIXME
+                (event-select (dispatcher item) item)))))
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam)) ; FIXME: debug
         (t


From junrue at common-lisp.net  Sun Jul  9 20:38:16 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun,  9 Jul 2006 16:38:16 -0400 (EDT)
Subject: [graphic-forms-cvs] r189 - in trunk: docs/manual
	src/uitoolkit/widgets
Message-ID: <20060709203816.8496813@common-lisp.net>

Author: junrue
Date: Sun Jul  9 16:38:15 2006
New Revision: 189

Modified:
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/reference.texinfo
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event-source.lisp
   trunk/src/uitoolkit/widgets/menu-item.lisp
   trunk/src/uitoolkit/widgets/menu-language.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
Log:
abstracted :callback setup somewhat for controls; added related documentation

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Sun Jul  9 16:38:15 2006
@@ -178,12 +178,22 @@
 classes.
 
 @anchor{button}
- at deftp Class button
-This @ref{control} class represents selectable controls that invoke
-the @ref{event-select} method defined for an @ref{event-dispatcher}
-associated with the @code{button}.
+ at deftp Class button callback-event-name
+This @ref{control} class represents selectable controls that generate
+an event when clicked.
+ at table @var
+ at item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-select}). See
+ at ref{event-source} for more details on this slot.
+ at end table
+ at deffn Initarg :callback
+The @sc{function} value supplied via this initarg will be
+used as the implementation of @ref{event-select} in an
+ at ref{event-dispatcher} configured for the @code{button}.
+ at end deffn
 @deffn Initarg :image
-Supplies an image to be used as the @code{button} label.
+Supplies an image to be used as the @code{button}'s label.
 @end deffn
 @deffn Initarg :style
 @table @code
@@ -229,7 +239,43 @@
 @anchor{control}
 @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color
 The base class for widgets having pre-defined native behavior. It derives from
- at ref{widget}.
+ at ref{widget}.@*@*
+ at strong{Note:} application code should not manipulate @code{control} slots
+directly, unless defining a new @code{control} type as an extension to
+Graphic-Forms.
+ at table @var
+ at item brush-color
+If set, this @ref{color} object is used as the @code{control}'s background color
+when the @code{control} needs to be redrawn.
+ at item brush-handle
+This is a native handle for a Win32 @sc{brush} that is used when customizing
+the @code{control}'s background color.
+ at item font
+This is a @ref{font} object for customizing the text of a @code{control}.
+ at item pixel-point
+This is a @ref{point} object specifying a pixel in an @ref{image}
+associated with a @code{control}, for the purpose of determining what
+color to use for transparency.
+ at item maximum-size
+This is a @ref{size} object that places a maximum constraint on the
+size that a @ref{layout-manager} may set for the @code{control}. It
+may be @sc{nil} if no such constraint has been set.
+ at item minimum-size
+This is a @ref{size} object that places a minimum constraint on the
+size that a @ref{layout-manager} may set for the @code{control}. It
+may be @sc{nil} if no such constraint has been set.
+ at item text-color
+If set, this color object is used as the @code{control}'s foreground text
+color when the @code{control} needs to be redrawn.
+ at end table
+ at deffn Initarg :callback
+This initarg associates a @sc{function} with an @ref{event-dispatcher}
+subclass that is generated behind the scenes and then instantiated to
+serve as the @code{control}'s event dispatcher. Each @code{control}
+subclass specifies the particular event function (e.g., @ref{event-select})
+that this callback will implement; see the documentation for specific
+ at code{control} subclasses for more information on this initarg.
+ at end deffn
 @end deftp
 
 @anchor{dialog}
@@ -281,13 +327,24 @@
 @end deftp
 
 @anchor{edit}
- at deftp Class edit
+ at deftp Class edit callback-event-name
 This subclass of @ref{control} represents a rectangular area that
 permits the user to enter and edit text. The @ref{event-focus-gain}
 and @ref{event-focus-loss} methods of each @code{edit control}'s
 @ref{event-dispatcher} are invoked when focus is given or taken
 away. The @ref{event-modify} method is invoked when the user edits
 content.
+ at table @var
+ at item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-modify}). See
+ at ref{event-source} for more details on this slot.
+ at end table
+ at deffn Initarg :callback
+The @sc{function} value supplied via this initarg will be
+used as the implementation of @ref{event-modify} in an
+ at ref{event-dispatcher} configured for the @code{edit control}.
+ at end deffn
 @deffn Initarg :style
 @table @code
 @item :auto-hscroll
@@ -346,15 +403,33 @@
 behalf of @ref{widget}s. Applications define subclasses of
 @code{event-dispatcher} and implement one or more of the @ref{event
 functions} specializing on each such application-defined subclass in
-order to implement desired behavior.
+order to implement desired behavior. @xref{event-source}.
 @end deftp
 
 @anchor{event-source}
- at deftp Class event-source dispatcher
+ at deftp Class event-source callback-event-name dispatcher
 This is the base class for user interface objects that generate
-events. It derives from @ref{native-object}. The @code{dispatcher}
-slot holds an instance of @ref{event-dispatcher} that is responsible
-for processing events on behalf of an @code{event-source}.
+events at footnote{Actually, events are generated by underlying
+native window objects, which are represented in the class hierarchy by
+the event-source class}. It derives from @ref{native-object}.
+ at table @var
+ at item callback-event-name
+This is an (@code{:allocation :class}) slot that holds a symbol
+identifying an event function (e.g., @ref{event-select}), to be
+supplied along with a function pointer in calls to the internal
+ at code{define-dispatcher} function. The purpose of this is to
+facilitate implementation of shortcuts for defining dispatchers where
+definition of a primary event function is sufficient, as is the case
+when a @ref{control} class wants to support a @code{:callback}
+initarg.  The choice of event function is determined by each subclass,
+hence this slot is shadowed by each such subclass.  Application code
+typically is not concerned with this slot, except when an application
+defines new kinds of event sources.
+ at item dispatcher
+This slot holds a reference to an instance of @ref{event-dispatcher},
+which has responsibility for handling events on behalf of the event
+source object.
+ at end table
 @deffn Initarg :callbacks
 The @code{:callbacks} initarg value specifies an association list
 where the @code{CAR} of each entry is the symbol of an @code{event-*}
@@ -362,10 +437,6 @@
 pointer. As such, this constitutes a specification for a new
 @ref{event-dispatcher} class and associated methods.
 @end deffn
- at deffn Initarg :dispatcher
- at end deffn
- at deffn Accessor dispatcher
- at end deffn
 @end deftp
 
 @anchor{file-dialog}
@@ -634,13 +705,13 @@
 @end deftp
 
 @deftp Class menu-item
-A subclass of @ref{item} representing a menu item.
+A subclass of @ref{item} representing a @ref{menu} item.
 @end deftp
 
 @anchor{panel}
 @deftp Class panel
 Base class for @ref{window}s that are children of @ref{top-level}
- at ref{window}s (or other panels).
+windows, @ref{dialog}s, or other @code{panel}s.
 @end deftp
 
 @anchor{root-window}
@@ -666,7 +737,7 @@
 @end deftp
 
 @anchor{timer}
- at deftp Class timer
+ at deftp Class timer id initial-delay delay
 A timer is a non-windowed object that generates events at a regular
 (adjustable) frequency. Applications handle timer events by
 implementing the @ref{event-timer} generic function.  This class

Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo	(original)
+++ trunk/docs/manual/reference.texinfo	Sun Jul  9 16:38:15 2006
@@ -149,6 +149,8 @@
 @end copying
 @c %**end of header
 
+ at footnotestyle end
+
 @titlepage
 @title Graphic-Forms Programming Reference
 @c @subtitle Version 0.5

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Sun Jul  9 16:38:15 2006
@@ -148,11 +148,11 @@
 (defmethod give-focus ((self control))
   (gfs::set-focus (gfs:handle self)))
 
-(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys)
+(defmethod initialize-instance :after ((self control) &key callback callbacks dispatcher 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)))))
+  (unless (or dispatcher callbacks (not (functionp callback)))
+    (let ((class (define-dispatcher (class-name (class-of self)) callback)))
       (setf (dispatcher self) (make-instance (class-name class))))))
 
 (defmethod (setf maximum-size) :after (max-size (self control))

Modified: trunk/src/uitoolkit/widgets/event-source.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-source.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-source.lisp	Sun Jul  9 16:38:15 2006
@@ -35,6 +35,7 @@
 
 (defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source))
                                (gfw:event-arm      . (gfw:event-source))
+                               (gfw:event-modify   . (gfw:event-source))
                                (gfw:event-select   . (gfw:event-source))))
 
 (defun make-specializer-list (disp-class arg-info)
@@ -42,10 +43,10 @@
     (push disp-class tmp)
     tmp))
 
-(defun define-dispatcher (callbacks)
-  (let* ((*print-gensym* nil)
-         (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
-                                   :direct-superclasses '(event-dispatcher))))
+(defun define-dispatcher-for-callbacks (callbacks)
+  (let ((*print-gensym* nil)
+        (class (clos:ensure-class (gentemp "EDCLASS" :gfgen)
+                                  :direct-superclasses '(event-dispatcher))))
     (loop for pair in callbacks
           do (let* ((method-sym (car pair))
                     (fn (cdr pair))
@@ -65,13 +66,17 @@
                                     :specializers (make-specializer-list class arg-info))))
     class))
 
+(defun define-dispatcher (classname callback)
+  (let ((proto (c2mop:class-prototype (find-class classname))))
+    (define-dispatcher-for-callbacks `((,(callback-event-name-of proto) . ,callback)))))
+
 ;;;
 ;;; methods
 ;;;
 
-(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys)
-  (unless (or disp (null callbacks))
-    (let ((class (define-dispatcher callbacks)))
+(defmethod initialize-instance :after ((self event-source) &key callbacks dispatcher &allow-other-keys)
+  (unless (or dispatcher (null callbacks))
+    (let ((class (define-dispatcher-for-callbacks callbacks)))
       (setf (dispatcher self) (make-instance (class-name class))))))
 
 (defmethod owner :before ((self event-source))

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp	Sun Jul  9 16:38:15 2006
@@ -172,7 +172,7 @@
       ((null disp)
          (setf item (make-instance 'menu-item :handle hmenu)))
       ((functionp disp)
-         (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp)))))
+         (setf item (make-instance 'menu-item :handle hmenu :callback disp)))
       ((typep disp 'gfw:event-dispatcher)
          (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp)))
       (t
@@ -220,6 +220,12 @@
              gfs::+mfs-enabled+)
      gfs::+mfs-enabled+))
 
+(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys)
+  (when callback
+    (unless (typep callback 'function)
+      (error 'gfs:toolkit-error :detail ":callback value must be a function"))
+    (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback)))))
+
 (defmethod owner ((it menu-item))
   (let ((hmenu (gfs:handle it)))
     (if (gfs:null-handle-p hmenu)

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Sun Jul  9 16:38:15 2006
@@ -150,8 +150,8 @@
       (if (null callback)
         (error 'gfs:toolkit-error :detail "missing callback argument"))
       (if sub
-        (setf disp `(make-instance (define-dispatcher `((gfw:event-activate . ,,callback)))))
-        (setf disp `(make-instance (define-dispatcher `((gfw:event-select   . ,,callback)))))))
+        (setf disp `(make-instance (define-dispatcher 'gfw:menu      ,callback)))
+        (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback)))))
     (when disp
       (if sep
         (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Sun Jul  9 16:38:15 2006
@@ -131,7 +131,7 @@
     (cond
       ((null disp))
       ((functionp disp)
-         (let ((class (define-dispatcher `((event-activate . ,disp)))))
+         (let ((class (define-dispatcher 'gfw:menu disp)))
            (setf (dispatcher submenu) (make-instance (class-name class)))))
       ((typep disp 'gfw:event-dispatcher)
          (setf (dispatcher submenu) disp))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Sun Jul  9 16:38:15 2006
@@ -72,14 +72,22 @@
   ((dispatcher
     :accessor dispatcher
     :initarg :dispatcher
-    :initform (make-instance 'event-dispatcher)))
+    :initform (make-instance 'event-dispatcher))
+   (callback-event-name
+    :accessor callback-event-name-of
+    :initform nil
+    :allocation :class)) ; subclasses will shadow this slot
   (:documentation "This is the base class for user interface objects that generate events."))
 
 (defclass item (event-source)
   ((item-id
     :accessor item-id
     :initarg :item-id
-    :initform 0))
+    :initform 0)
+   (callback-event-name
+    :accessor callback-event-name-of
+    :initform 'event-select
+    :allocation :class)) ; shadowing same slot from event-source
   (:documentation "The item class is the base class for all non-windowed user interface objects."))
 
 (defclass menu-item (item) ()
@@ -121,10 +129,18 @@
     :initform nil))
   (:documentation "The base class for widgets having pre-defined native behavior."))
 
-(defclass button (control) ()
+(defclass button (control)
+  ((callback-event-name
+    :accessor callback-event-name-of
+    :initform 'event-select
+    :allocation :class)) ; shadowing same slot from event-source
   (:documentation "This class represents selectable controls that issue notifications when clicked."))
 
-(defclass edit (control) ()
+(defclass edit (control)
+  ((callback-event-name
+    :accessor callback-event-name-of
+    :initform 'event-modify
+    :allocation :class)) ; shadowing same slot from event-source
   (:documentation "This class represents a control in which the user may enter and edit text."))
 
 (defclass label (control) ()
@@ -146,7 +162,11 @@
     :initform (make-array 7 :fill-pointer 0 :adjustable t)))
   (:documentation "The widget-with-items class is the base class for objects composed of sub-items."))
 
-(defclass menu (widget-with-items) ()
+(defclass menu (widget-with-items)
+  ((callback-event-name
+    :accessor callback-event-name-of
+    :initform 'event-activate
+    :allocation :class)) ; shadowing same slot from event-source
   (:documentation "The menu class represents a container for menu items (and submenus)."))
 
 (defclass window (widget layout-managed)


From junrue at common-lisp.net  Mon Jul 10 21:26:45 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 10 Jul 2006 17:26:45 -0400 (EDT)
Subject: [graphic-forms-cvs] r190 - in trunk: docs/manual src
	src/demos/textedit src/uitoolkit/widgets
Message-ID: <20060710212645.DAEA64405A@common-lisp.net>

Author: junrue
Date: Mon Jul 10 17:26:44 2006
New Revision: 190

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined widget functions for querying undo and redo state, and implemented them for edit controls

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Mon Jul 10 17:26:44 2006
@@ -1525,6 +1525,11 @@
 display; nil otherwise.
 @end deffn
 
+ at deffn GenericFunction redo-available-p self => boolean
+Returns T if @code{self} has @sc{redo} capability and has an
+operation that can be redone; @sc{nil} otherwise.
+ at end deffn
+
 @deffn GenericFunction redraw self
 Causes the entire bounds of the object to be marked as needing to be redrawn
 @end deffn
@@ -1583,6 +1588,11 @@
 other cases there is no text component at all.
 @end deffn
 
+ at deffn GenericFunction undo-available-p self => boolean
+Returns T if @code{self} has @sc{undo} capability and has an
+operation that can be undone; @sc{nil} otherwise.
+ at end deffn
+
 @deffn GenericFunction update self
 Forces all outstanding paint requests for the object to be processed
 before this function returns.

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Mon Jul 10 17:26:44 2006
@@ -86,6 +86,13 @@
   (setf *textedit-win* nil)
   (gfw:shutdown 0))
 
+(defun manage-textedit-edit-menu (disp menu)
+  (declare (ignore disp))
+  (unless *textedit-control*
+    (return-from manage-textedit-edit-menu nil))
+  (let ((items (gfw:items menu)))
+    (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))))
+
 (defun textedit-font (disp item)
   (declare (ignore disp item))
   (gfw:with-graphics-context (gc *textedit-control*)
@@ -175,7 +182,7 @@
 
 (cells:defobserver file-path ((self textedit-document))
   (if *textedit-win*
-    (setf (gfw:text *textedit-win*) (format nil "~s - GraphicForms TextEdit" (file-path self)))
+    (setf (gfw:text *textedit-win*) (format nil "~a - GraphicForms TextEdit" (file-path self)))
     (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit")))
 
 (defun textedit-startup ()
@@ -186,21 +193,21 @@
   (let ((menubar (gfw:defmenu ((:item "&File"                      :callback #'manage-textedit-file-menu
                                 :submenu ((:item "&New"            :callback #'textedit-file-new)
                                           (:item "&Open..."        :callback #'textedit-file-open)
-                                          (:item "&Save"           :callback #'textedit-file-save :disabled)
+                                          (:item "&Save"           :callback #'textedit-file-save   :disabled)
                                           (:item "Save &As..."     :callback #'textedit-file-save-as)
                                           (:item ""                :separator)
                                           (:item "E&xit"           :callback #'textedit-file-quit)))
-                               (:item "&Edit"
-                                :submenu ((:item "&Undo")
+                               (:item "&Edit"                      :callback #'manage-textedit-edit-menu
+                                :submenu ((:item "&Undo"           :callback #'textedit-edit-undo   :disabled)
                                           (:item "" :separator)
-                                          (:item "Cu&t")
-                                          (:item "&Copy")
-                                          (:item "&Paste")
-                                          (:item "De&lete")
+                                          (:item "Cu&t"            :callback #'textedit-edit-cut    :disabled)
+                                          (:item "&Copy"           :callback #'textedit-edit-copy   :disabled)
+                                          (:item "&Paste"          :callback #'textedit-edit-paste  :disabled)
+                                          (:item "De&lete"         :callback #'textedit-edit-delete :disabled)
                                           (:item "" :separator)
                                           (:item "&Find...")
-                                          (:item "Find &Next")
-                                          (:item "&Replace...")
+                                          (:item "Find &Next"                                       :disabled)
+                                          (:item "&Replace..."                                      :disabled)
                                           (:item "&Go To...")
                                           (:item "" :separator)
                                           (:item "Select &All")))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Mon Jul 10 17:26:44 2006
@@ -496,6 +496,7 @@
     #:traverse
     #:traverse-order
     #:trim-sizes
+    #:undo-available-p
     #:update
     #:vertical-scrollbar
     #:visible-item-count

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Mon Jul 10 17:26:44 2006
@@ -132,3 +132,6 @@
 
 (defmethod (setf text-modified-p) (flag (self edit))
   (gfs::send-message (gfs:handle self) gfs::+em-setmodify+ (if flag 1 0) 0))
+
+(defmethod undo-available-p ((self edit))
+  (/= (gfs::send-message (gfs:handle self) gfs::+em-canundo+ 0 0) 0))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Mon Jul 10 17:26:44 2006
@@ -270,6 +270,9 @@
 (defgeneric preferred-size (self width-hint height-hint)
   (:documentation "Returns a size object representing the object's 'preferred' size."))
 
+(defgeneric redo-available-p (self)
+  (:documentation "Returns T if self can redo an operation; nil otherwise."))
+
 (defgeneric redraw (self)
   (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn"))
 
@@ -375,6 +378,9 @@
 (defgeneric traverse-order (self)
   (:documentation "Returns a list of this object's layout-managed children in the order in which tab traversal would visit them."))
 
+(defgeneric undo-available-p (self)
+  (:documentation "Returns T if self can undo an operation; nil otherwise."))
+
 (defgeneric update (self)
   (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Mon Jul 10 17:26:44 2006
@@ -259,6 +259,13 @@
     (format stream "handle: ~x " (gfs:handle self))
     (format stream "dispatcher: ~a " (dispatcher self))))
 
+(defmethod redo-available-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod redo-available-p ((self widget))
+  nil)
+
 (defmethod redraw :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
@@ -328,6 +335,13 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
+(defmethod undo-available-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod undo-available-p ((self widget))
+  nil)
+
 (defmethod update :before ((w widget))
   (if (gfs:disposed-p w)
     (error 'gfs:disposed-error)))


From junrue at common-lisp.net  Tue Jul 11 05:24:43 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 11 Jul 2006 01:24:43 -0400 (EDT)
Subject: [graphic-forms-cvs] r191 - in trunk: docs/manual src
	src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060711052443.CF2925B05C@common-lisp.net>

Author: junrue
Date: Tue Jul 11 01:24:41 2006
New Revision: 191

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/system/datastructs.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
defined and implemented sufficient new methods to implement edit control cut/copy/paste/delete functionality for a window Edit menu; full-blown general clipboard support is still down the road a bit

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Tue Jul 11 01:24:41 2006
@@ -117,13 +117,18 @@
 
 @deffn GenericFunction disposed-p self
 Returns T if @ref{dispose} has been called on @var{self} and the
-object has not since been re-initialized; returns nil otherwise.
-This function also returns T if @var{self} has been instantiated
-but secondary initialization code has not yet executed.
+object has not since been re-initialized; returns @sc{nil} otherwise.
+This function also returns T if @var{self} has been instantiated but
+secondary initialization code has not yet executed.
 @end deffn
 
+ at defun empty-span-p span
+Returns T if the @var{start} and @var{end} of @code{span} are the same;
+ at sc{nil} otherwise.
+ at end defun
+
 @deffn Macro location rect
-This macro returns the @code{location} slot of a @ref{rectangle}.
+This macro returns the @var{location} slot of a @ref{rectangle}.
 @end deffn
 
 @deffn Function make-point :x :y :z
@@ -1276,12 +1281,24 @@
 Returns T if the object is in the checked state; nil otherwise.
 @end deffn
 
+ at deffn GenericFunction clear-all self
+Clears all content from @code{self}.
+ at end deffn
+
 @deffn GenericFunction clear-item self index
-Clears the item at the zero-based index.
+Clears the @ref{item} at the zero-based @var{index}.
+ at end deffn
+
+ at deffn GenericFunction clear-selection self
+Sets the selection status of @code{self} to @samp{not selected} or
+ at samp{empty}. For a @ref{control} with a text field component,
+such as an @ref{edit} control, this function deletes selected
+text.
 @end deffn
 
- at deffn GenericFunction clear-span self sp
-Clears the items whose zero-based indices lie within the specified span.
+ at deffn GenericFunction clear-span self @ref{span}
+Clears the items from @var{self} whose zero-based indices lie within
+the specified @var{span}.
 @end deffn
 
 @deffn GenericFunction client-size self
@@ -1300,6 +1317,32 @@
 enclose the specified desired client area and this object's trim.
 @end deffn
 
+ at anchor{copy-text}
+ at deffn GenericFunction copy-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from @code{self} to the system clipboard.
+The existing content of @code{self} remains in place. Some @ref{control}s
+like the @ref{edit} control have built-in clipboard functionality, and
+in such cases, the implementation of this function delegates directly.
+See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+ at end deffn
+
+ at anchor{cut-text}
+ at deffn GenericFunction cut-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from @code{self} to the system clipboard
+and removal of content from @code{self}. Some @ref{control}s like the
+ at ref{edit} control have built-in clipboard functionality, and in such
+cases, the implementation of this function delegates directly. For
+other @ref{widget}s, this operation is a wrapper around a copy/delete
+sequence. See @ref{copy-text}, @ref{paste-text}, and
+ at ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will
+include more general infrastructure for clipboard operations.
+ at end deffn
+
 @deffn GenericFunction default-widget self
 Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil}
 if none has been set. If @sc{nil} is passed to the corresponding
@@ -1509,6 +1552,19 @@
 @end quotation
 @end deffn
 
+ at anchor{paste-text}
+ at deffn GenericFunction paste-text self
+This function is a shortcut for a common clipboard transfer operation,
+namely the transfer of text from the system clipboard to @code{self}.
+Depending on the current selection within @code{self}, the text either
+gets inserted or existing content is replaced. Some @ref{control}s like the
+ at ref{edit} control have built-in clipboard functionality, and in such
+cases, the implementation of this function delegates directly. See
+ at ref{copy-text}, @ref{cut-text}, and @ref{text-for-pasting-p}.@*@*
+ at strong{Note:} an upcoming release will include more
+general infrastructure for clipboard operations.
+ at end deffn
+
 @anchor{preferred-size}
 @deffn GenericFunction preferred-size self width-hint height-hint
 Implement this function to return @code{self}'s preferred @ref{size};
@@ -1550,6 +1606,12 @@
 decorations are modified appropriately.
 @end deffn
 
+ at deffn GenericFunction selection-span self => @ref{span}
+Returns a span object describing the start and end of the selection
+within @var{self}. If there is no selection, this function returns
+ at sc{nil}.
+ at end deffn
+
 @anchor{show}
 @deffn GenericFunction show self flag
 Causes the object to be visible or hidden on the screen, but not
@@ -1579,6 +1641,16 @@
 the custom control will be managed by a @ref{layout-manager}.
 @end deffn
 
+ at anchor{text-for-pasting-p}
+ at deffn GenericFunction text-for-pasting-p self
+This function is a shortcut means of checking the clipboard for existence
+of data of a specific type (text). This status information is typically
+used to enable or disable a @samp{Paste} menu item. See @ref{copy-text},
+ at ref{cut-text}, and @ref{paste-text}.@*@*
+ at strong{Note:} an upcoming release will include more general
+infrastructure for clipboard operations.
+ at end deffn
+
 @anchor{text-modified-p}
 @deffn GenericFunction text-modified-p self
 Returns T if the text component of @code{self} has been modified by

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Tue Jul 11 01:24:41 2006
@@ -90,8 +90,32 @@
   (declare (ignore disp))
   (unless *textedit-control*
     (return-from manage-textedit-edit-menu nil))
-  (let ((items (gfw:items menu)))
-    (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))))
+  (let ((items (gfw:items menu))
+        (text-sel (gfw:selection-span *textedit-control*)))
+    (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))
+    (gfw:enable (elt items 2) text-sel)
+    (gfw:enable (elt items 3) text-sel)
+    (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*))
+    (gfw:enable (elt items 5) text-sel)))
+
+(defun textedit-edit-copy (disp item)
+  (declare (ignore disp item))
+  (gfw:copy-text *textedit-control*))
+
+(defun textedit-edit-cut (disp item)
+  (declare (ignore disp item))
+  (gfw:cut-text *textedit-control*))
+
+(defun textedit-edit-delete (disp item)
+  (declare (ignore disp item))
+  (gfw:clear-selection *textedit-control*))
+
+(defun textedit-edit-paste (disp item)
+  (declare (ignore disp item))
+  (gfw:paste-text *textedit-control*))
+
+(defun textedit-edit-undo (disp item)
+  (declare (ignore disp item)))
 
 (defun textedit-font (disp item)
   (declare (ignore disp item))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Tue Jul 11 01:24:41 2006
@@ -65,6 +65,7 @@
     #:detail
     #:dispose
     #:disposed-p
+    #:empty-span-p
     #:equal-size-p
     #:flatten
     #:handle
@@ -343,11 +344,11 @@
     #:column-order
     #:columns
     #:compute-outer-size
-    #:copy
     #:copy-area
+    #:copy-text
+    #:cut-text
     #:current-font
     #:cursor
-    #:cut
     #:default-message-filter
     #:default-widget
     #:defmenu
@@ -447,7 +448,7 @@
     #:pack
     #:page-increment
     #:parent
-    #:paste
+    #:paste-text
     #:peer
     #:preferred-size
     #:primary-p
@@ -485,6 +486,7 @@
     #:sub-menu
     #:text
     #:text-baseline
+    #:text-for-pasting-p
     #:text-height
     #:text-limit
     #:text-modified-p

Modified: trunk/src/uitoolkit/system/datastructs.lisp
==============================================================================
--- trunk/src/uitoolkit/system/datastructs.lisp	(original)
+++ trunk/src/uitoolkit/system/datastructs.lisp	Tue Jul 11 01:24:41 2006
@@ -47,6 +47,9 @@
 (defmacro size (rect)
   `(rectangle-size ,rect))
 
+(defun empty-span-p (span)
+  (= (span-start span) (span-end span)))
+
 (defun equal-size-p (size1 size2)
   (and (= (size-width size1) (size-width size2))
        (= (size-height size1) (size-height size2))))

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Tue Jul 11 01:24:41 2006
@@ -142,6 +142,30 @@
 (defconstant +cderr-nohook+                #x000B)
 (defconstant +cderr-registermsgfail+       #x000C)
 
+;;;
+;;; clipboard-related constants
+;;;
+(defconstant +cf-text+                          1)
+(defconstant +cf-bitmap+                        2)
+(defconstant +cf-metafilepict+                  3)
+(defconstant +cf-sylk+                          4)
+(defconstant +cf-dif+                           5)
+(defconstant +cf-tiff+                          6)
+(defconstant +cf-oemtext+                       7)
+(defconstant +cf-dib+                           8)
+(defconstant +cf-palette+                       9)
+(defconstant +cf-pendata+                      10)
+(defconstant +cf-riff+                         11)
+(defconstant +cf-wave+                         12)
+(defconstant +cf-unicodetext+                  13)
+(defconstant +cf-enhmetafile+                  14)
+(defconstant +cf-hdrop+                        15)
+(defconstant +cf-locale+                       16)
+(defconstant +cf-dibv5+                        17)
+
+;;;
+;;; font-related constants
+;;;
 (defconstant +cf-screenfonts+          #x00000001)
 (defconstant +cf-printerfonts+         #x00000002)
 (defconstant +cf-both+                 #x00000003)
@@ -985,6 +1009,29 @@
 (defconstant +wm-mousehover+               #x02A1)
 (defconstant +wm-ncmouseleave+             #x02A2)
 (defconstant +wm-mouseleave+               #x02A3)
+(defconstant +wm-cut+                      #x0300)
+(defconstant +wm-copy+                     #x0301)
+(defconstant +wm-paste+                    #x0302)
+(defconstant +wm-clear+                    #x0303)
+(defconstant +wm-undo+                     #x0304)
+(defconstant +wm-renderformat+             #x0305)
+(defconstant +wm-renderallformats+         #x0306)
+(defconstant +wm-destroyclipboard+         #x0307)
+(defconstant +wm-drawclipboard+            #x0308)
+(defconstant +wm-paintclipboard+           #x0309)
+(defconstant +wm-vscrollclipboard+         #x030A)
+(defconstant +wm-sizeclipboard+            #x030B)
+(defconstant +wm-askcbformatname+          #x030C)
+(defconstant +wm-changecbchain+            #x030D)
+(defconstant +wm-hscrollclipboard+         #x030E)
+(defconstant +wm-querynewpalette+          #x030F)
+(defconstant +wm-paletteischanging+        #x0310)
+(defconstant +wm-palettechanged+           #x0311)
+(defconstant +wm-hotkey+                   #x0312)
+(defconstant +wm-print+                    #x0317)
+(defconstant +wm-printclient+              #x0318)
+(defconstant +wm-appcommand+               #x0319)
+(defconstant +wm-themechanged+             #x031A)
 (defconstant +wm-user-base+                #x0400)
 (defconstant +wm-app-base+                 #x8000)
 

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Tue Jul 11 01:24:41 2006
@@ -454,6 +454,11 @@
   (erase BOOL))
 
 (defcfun
+  ("IsClipboardFormatAvailable" is-clipboard-format-available)
+  BOOL
+  (format UINT))
+
+(defcfun
   ("IsDialogMessageA" is-dialog-message)
   BOOL
   (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Tue Jul 11 01:24:41 2006
@@ -48,6 +48,9 @@
   (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
     (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+)))
 
+(defmethod clear-selection ((self edit))
+  (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))
+
 (defmethod compute-style-flags ((self edit) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -74,6 +77,12 @@
       (setf std-flags (logior std-flags gfs::+es-autohscroll+)))
     (values std-flags (if (find :no-border style) 0 gfs::+ws-ex-clientedge+))))
 
+(defmethod copy-text ((self edit))
+  (gfs::send-message (gfs:handle self) gfs::+wm-copy+ 0 0))
+
+(defmethod cut-text ((self edit))
+  (gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0))
+
 (defmethod enable-scrollbars ((self edit) horizontal vertical)
   (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
     (if horizontal
@@ -102,6 +111,9 @@
     (error 'gfs:disposed-error))
   (gfs::send-message (gfs:handle self) gfs::+em-getlinecount+ 0 0))
 
+(defmethod paste-text ((self edit))
+  (gfs::send-message (gfs:handle self) gfs::+wm-paste+ 0 0))
+
 (defmethod preferred-size ((self edit) width-hint height-hint)
   (let ((text-size (widget-text-size self (logior gfs::+dt-editcontrol+ gfs::+dt-noprefix+)))
         (size (gfs:make-size))
@@ -118,6 +130,17 @@
                                       (* +vertical-edit-text-margin+ 2))))
     size))
 
+(defmethod selection-span ((self edit))
+  (cffi:with-foreign-object (start-ptr :unsigned-long)
+    (cffi:with-foreign-object (end-ptr :unsigned-long)
+      (gfs::send-message (gfs:handle self)
+                         gfs::+em-getsel+
+                         (cffi:pointer-address start-ptr)
+                         (cffi:pointer-address end-ptr))
+      (let ((start (cffi:mem-ref start-ptr :unsigned-long))
+            (end (cffi:mem-ref end-ptr :unsigned-long)))
+        (if (= start end) nil (gfs:make-span :start start :end end))))))
+
 (defmethod text ((self edit))
   (get-widget-text self))
 
@@ -127,6 +150,9 @@
 (defmethod text-baseline ((self edit))
   (widget-text-baseline self +vertical-edit-text-margin+))
 
+(defmethod text-for-pasting-p ((self edit))
+  (/= (gfs::is-clipboard-format-available gfs::+cf-text+) 0))
+
 (defmethod text-modified-p ((self edit))
   (/= (gfs::send-message (gfs:handle self) gfs::+em-getmodify+ 0 0) 0))
 

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Tue Jul 11 01:24:41 2006
@@ -84,6 +84,9 @@
 (defgeneric checked-p (self)
   (:documentation "Returns T if the object is in the checked state; nil otherwise."))
 
+(defgeneric clear-all (self)
+  (:documentation "Clears all content from self."))
+
 (defgeneric clear-item (self index)
   (:documentation "Clears the item at the zero-based index."))
 
@@ -117,14 +120,14 @@
 (defgeneric compute-outer-size (self desired-client-size)
   (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim."))
 
-(defgeneric copy (self)
-  (:documentation "Copies the current selection to the clipboard."))
+(defgeneric copy-text (self)
+  (:documentation "Copies the current text selection to the clipboard."))
 
 (defgeneric cursor (self)
   (:documentation "Returns the cursor object associated with this object."))
 
-(defgeneric cut (self)
-  (:documentation "Copies the current selection to the clipboard and removes it from the object."))
+(defgeneric cut-text (self)
+  (:documentation "Copies the current text selection to the clipboard and removes it from self."))
 
 (defgeneric default-widget (self)
   (:documentation "Returns the child widget or item that has the default emphasis."))
@@ -261,8 +264,8 @@
 (defgeneric parent (self)
   (:documentation "Returns the object's parent."))
 
-(defgeneric paste (self)
-  (:documentation "Copies content from the clipboard into the object."))
+(defgeneric paste-text (self)
+  (:documentation "Copies text from the clipboard into self"))
 
 (defgeneric peer (self)
   (:documentation "Returns the visual object associated with this object (not the underlying window system handle)."))
@@ -322,7 +325,7 @@
   (:documentation "Returns a list of zero-based indices identifying the selected items within this object."))
 
 (defgeneric selection-span (self)
-  (:documentation "Returns a span object describing the start and end indices of the object selection."))
+  (:documentation "Returns a span object describing the start and end indices of the selection within self."))
 
 (defgeneric show (self flag)
   (:documentation "Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order."))
@@ -354,6 +357,9 @@
 (defgeneric text-baseline (self)
   (:documentation "Returns the y coordinate of the object's text component, if any."))
 
+(defgeneric text-for-pasting-p (self)
+  (:documentation "Returns T if the clipboard has data in text format; nil otherwise."))
+
 (defgeneric text-height (self)
   (:documentation "Returns the height of the object's text field."))
 

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Tue Jul 11 01:24:41 2006
@@ -91,11 +91,6 @@
   (gfg::destroy-magick)
   (gfs::post-quit-message exit-code))
 
-(defun clear-all (w)
-  (let ((count (length (items w))))
-    (unless (zerop count)
-      (gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
-
 (defun initialize-comctl-classes (icc-flags)
   (cffi:with-foreign-object (ic-ptr 'gfs::initcommoncontrolsex)
     (cffi:with-foreign-slots ((gfs::size gfs::icc) ic-ptr gfs::initcommoncontrolsex)

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Tue Jul 11 01:24:41 2006
@@ -33,40 +33,45 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
+(defmethod append-item :before ((self widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
   (declare (ignore text image disp checked disabled))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-item :before ((w widget-with-items) index)
+(defmethod clear-all ((self widget-with-items))
+  (let ((count (length (items self))))
+    (unless (zerop count)
+      (clear-span self (gfs:make-span :start 0 :end (1- count))))))
+
+(defmethod clear-item :before ((self widget-with-items) index)
   (declare (ignore index))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-item ((w widget-with-items) index)
-  (let* ((items (items w))
+(defmethod clear-item ((self widget-with-items) index)
+  (let* ((items (items self))
          (it (elt items index)))
-    (delete it (items w) :test #'items-equal-p)
+    (delete it (items self) :test #'items-equal-p)
     (if (gfs:disposed-p it)
       (error 'gfs:disposed-error))
     (gfs:dispose it)))
 
-(defmethod clear-span :before ((w widget-with-items) (sp gfs:span))
+(defmethod clear-span :before ((self widget-with-items) (sp gfs:span))
   (declare (ignore sp))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-span ((w widget-with-items) (sp gfs:span))
+(defmethod clear-span ((self widget-with-items) (sp gfs:span))
   (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
-    (clear-item w (gfs:span-start sp))))
+    (clear-item self (gfs:span-start sp))))
 
-(defmethod item-index :before ((w widget-with-items) (it item))
+(defmethod item-index :before ((self widget-with-items) (it item))
   (declare (ignore it))
-  (if (gfs:disposed-p w)
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod item-index ((w widget-with-items) (it item))
-  (let ((pos (position it (items w) :test #'items-equal-p)))
+(defmethod item-index ((self widget-with-items) (it item))
+  (let ((pos (position it (items self) :test #'items-equal-p)))
     (if (null pos)
       (return-from item-index 0))
     0))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Tue Jul 11 01:24:41 2006
@@ -125,19 +125,27 @@
 (defmethod center-on-parent ((self widget))
   (center-object (parent self) self))
 
-(defmethod checked-p :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod checked-p :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod checked-p ((w widget))
-  (declare (ignore w))
+(defmethod checked-p ((self widget))
+  (declare (ignore self))
   nil)
 
-(defmethod client-size :before ((w widget))
-  (if (gfs:disposed-p w)
+(defmethod clear-all :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod clear-selection :before ((self widget))
+  (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod client-size ((w widget))
+(defmethod client-size :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod client-size ((self widget))
   (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
     (cffi:with-foreign-slots ((gfs::cbsize
                                gfs::clientleft
@@ -146,19 +154,27 @@
                                gfs::clientbottom)
                               wi-ptr gfs::windowinfo)
       (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
-      (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr))
+      (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr))
         (error 'gfs:win32-error :detail "get-window-info failed"))
       (gfs:make-size :width (- gfs::clientright gfs::clientleft)
                      :height (- gfs::clientbottom gfs::clienttop)))))
 
-(defmethod gfs:dispose ((w widget))
-  (unless (null (dispatcher w))
-    (event-dispose (dispatcher w) w))
-  (let ((hwnd (gfs:handle w)))
+(defmethod copy-text :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod cut-text :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod gfs:dispose ((self widget))
+  (unless (null (dispatcher self))
+    (event-dispose (dispatcher self) self))
+  (let ((hwnd (gfs:handle self)))
     (if (not (gfs:null-handle-p hwnd))
       (if (zerop (gfs::destroy-window hwnd))
         (error 'gfs:win32-error :detail "destroy-window failed"))))
-  (setf (slot-value w 'gfs:handle) nil))
+  (setf (slot-value self 'gfs:handle) nil))
 
 (defmethod enable :before ((self widget) flag)
   (declare (ignore flag))
@@ -254,6 +270,10 @@
         (error 'gfs:toolkit-error :detail "no widget for hwnd")))
     widget))
 
+(defmethod paste-text :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod print-object ((self widget) stream)
   (print-unreadable-object (self stream :type t)
     (format stream "handle: ~x " (gfs:handle self))
@@ -290,6 +310,10 @@
   (declare (ignore self))
   nil)
 
+(defmethod selection-span :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod size :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
@@ -326,6 +350,13 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
+(defmethod text-for-pasting-p :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod text-for-pasting-p ((self widget))
+  nil)
+
 (defmethod (setf text-modified-p) :before (flag (self widget))
   (declare (ignore flag))
   (if (gfs:disposed-p self)


From junrue at common-lisp.net  Tue Jul 11 20:33:24 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 11 Jul 2006 16:33:24 -0400 (EDT)
Subject: [graphic-forms-cvs] r192 - in trunk: docs/manual src
	src/demos/textedit src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060711203324.2687F5831C@common-lisp.net>

Author: junrue
Date: Tue Jul 11 16:33:21 2006
New Revision: 192

Modified:
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/miscellaneous.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/menu-item.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/thread-context.lisp
   trunk/src/uitoolkit/widgets/timer.lisp
   trunk/src/uitoolkit/widgets/top-level.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
cleanup of clear vs. delete terminology, and got rid of remove-*

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Tue Jul 11 16:33:21 2006
@@ -127,6 +127,7 @@
 @sc{nil} otherwise.
 @end defun
 
+ at anchor{location}
 @deffn Macro location rect
 This macro returns the @var{location} slot of a @ref{rectangle}.
 @end deffn
@@ -1281,24 +1282,15 @@
 Returns T if the object is in the checked state; nil otherwise.
 @end deffn
 
- at deffn GenericFunction clear-all self
-Clears all content from @code{self}.
- at end deffn
-
- at deffn GenericFunction clear-item self index
-Clears the @ref{item} at the zero-based @var{index}.
- at end deffn
-
 @deffn GenericFunction clear-selection self
-Sets the selection status of @code{self} to @samp{not selected} or
- at samp{empty}. For a @ref{control} with a text field component,
-such as an @ref{edit} control, this function deletes selected
-text.
+Sets the selection status of @code{self} (or @ref{item}s within
+ at var{self}) to the @samp{unselected} state.
 @end deffn
 
- at deffn GenericFunction clear-span self @ref{span}
-Clears the items from @var{self} whose zero-based indices lie within
-the specified @var{span}.
+ at deffn GenericFunction clear-selection-span self @ref{span}
+Sets the selection status of @ref{item}s within @var{self}, whose
+zero-based indices lie within @var{span}, to the @samp{unselected}
+state.
 @end deffn
 
 @deffn GenericFunction client-size self
@@ -1351,6 +1343,26 @@
 presses @sc{enter}.
 @end deffn
 
+ at deffn GenericFunction delete-all self
+Removes all content from @code{self}.
+ at end deffn
+
+ at deffn GenericFunction delete-item self index
+Removes the @ref{item} at the zero-based @var{index}.
+ at end deffn
+
+ at deffn GenericFunction delete-item-span self @ref{span}
+Removes the items from @var{self} whose zero-based indices lie within
+the specified @var{span}.
+ at end deffn
+
+ at deffn GenericFunction delete-selection self
+Removes the subset of items from @var{self} that are in the
+ at samp{selected} state. For a @ref{control} with a text field
+component, such as an @ref{edit} control, this function deletes
+selected text.
+ at end deffn
+
 @deffn GenericFunction display-to-object self pnt
 Return a point that is the result of transforming the specified point
 from display-relative coordinates to this object's coordinate system.
@@ -1660,6 +1672,7 @@
 other cases there is no text component at all.
 @end deffn
 
+ at anchor{undo-available-p}
 @deffn GenericFunction undo-available-p self => boolean
 Returns T if @code{self} has @sc{undo} capability and has an
 operation that can be undone; @sc{nil} otherwise.

Modified: trunk/docs/manual/miscellaneous.texinfo
==============================================================================
--- trunk/docs/manual/miscellaneous.texinfo	(original)
+++ trunk/docs/manual/miscellaneous.texinfo	Tue Jul 11 16:33:21 2006
@@ -10,4 +10,54 @@
 @node Miscellaneous Topics
 @chapter Miscellaneous Topics
 
- at strong{TBD}
+ at menu
+* terminology::           Some notes about terminology conventions.
+ at end menu
+
+
+ at node terminology
+ at section terminology
+
+This chapter documents terminology conventions observed in
+Graphic-Forms. These conventions should be interpreted with the
+traditional Common Lisp conventions in mind (such as
+ at url{http://www.cliki.net/Naming%20conventions}). 
+
+ at table @option
+
+ at item accessor names
+For clearer identification of accessors, Graphic-Forms
+uses the suffix @samp{-of} whenever possible.
+
+ at item function and method names
+Functions and methods should be named using a verb to suggest
+action. It may be tempting (especially for former Java programmers) to
+use the Java getter/setter naming conventions for accessor-like
+functions, but the author prefers @samp{obtain} rather than
+ at samp{get}, and he prefers @sc{setf}'able places which therefore can
+have @sc{setf} functions defined for them. For status querying
+functions, the author suggests @samp{available-p}, such as
+ at ref{undo-available-p}.
+
+ at item @samp{clear} versus @samp{delete}
+Related to the @samp{function and method names} issues, there is
+a distinction between @samp{clear} and @samp{delete} which hinges on
+the difference between the primary content of a @ref{widget} and
+secondary state information. An example of primary content is text
+within an @ref{edit} @ref{control}. An example of secondary state
+information (relevant to this topic at least) is the @ref{span} of
+selected text in an edit control. With that in mind, Graphic-Forms
+functions @samp{delete} content but @samp{clear} secondary state. This
+choice is intended in part to align with the semantics of
+ at sc{CL:delete}, including the notion of that function being a
+destructive operation.
+
+ at item macro names
+Macros should be named consistent with established Common Lisp
+practice, with an exception being allowed for convenience wrappers
+around structure accessors (see @ref{location}). Otherwise, the
+temptation to define an unorthodox macro name is a symptom that maybe
+the code in question should not be a macro in the first place.
+
+ at end table
+

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Tue Jul 11 16:33:21 2006
@@ -108,7 +108,7 @@
 
 (defun textedit-edit-delete (disp item)
   (declare (ignore disp item))
-  (gfw:clear-selection *textedit-control*))
+  (gfw:delete-selection *textedit-control*))
 
 (defun textedit-edit-paste (disp item)
   (declare (ignore disp item))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Tue Jul 11 16:33:21 2006
@@ -331,10 +331,8 @@
     #:check
     #:check-all
     #:checked-p
-    #:clear-all
-    #:clear-item
     #:clear-selection
-    #:clear-span
+    #:clear-selection-span
     #:client-size
     #:close-obj
     #:code
@@ -353,6 +351,10 @@
     #:default-widget
     #:defmenu
     #:delay-of
+    #:delete-all
+    #:delete-item
+    #:delete-selection
+    #:delete-span
     #:disabled-image
     #:dispatcher
     #:display-to-object
@@ -455,9 +457,6 @@
     #:redraw
     #:redrawing-p
     #:release-mouse
-    #:remove-all
-    #:remove-item
-    #:remove-span
     #:reparentable-p
     #:replace-selection
     #:resizable-p

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Tue Jul 11 16:33:21 2006
@@ -169,7 +169,7 @@
     :initform nil)))
 
 (defmethod gfw:event-activate ((d child-menu-dispatcher) menu)
-  (gfw:clear-all menu)
+  (gfw:delete-all menu)
   (gfw:mapchildren *layout-tester-win*
                    (lambda (parent child)
                      (declare (ignore parent))
@@ -336,7 +336,7 @@
 
 (defun flow-mod-callback (disp menu)
   (declare (ignore disp))
-  (gfw:clear-all menu)
+  (gfw:delete-all menu)
   (let ((it nil)
         (margin-menu (gfw:defmenu ((:item "Left"
                                     :callback #'enable-left-flow-margin-items

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Tue Jul 11 16:33:21 2006
@@ -48,9 +48,6 @@
   (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
     (= (logand bits gfs::+es-autovscroll+) gfs::+es-autovscroll+)))
 
-(defmethod clear-selection ((self edit))
-  (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))
-
 (defmethod compute-style-flags ((self edit) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -83,6 +80,9 @@
 (defmethod cut-text ((self edit))
   (gfs::send-message (gfs:handle self) gfs::+wm-cut+ 0 0))
 
+(defmethod delete-selection ((self edit))
+  (gfs::send-message (gfs:handle self) gfs::+wm-clear+ 0 0))
+
 (defmethod enable-scrollbars ((self edit) horizontal vertical)
   (let ((bits (gfs::get-window-long (gfs:handle self) gfs::+gwl-style+)))
     (if horizontal

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Tue Jul 11 16:33:21 2006
@@ -211,7 +211,7 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignore wparam lparam))
-  (remove-widget (thread-context) hwnd)
+  (delete-widget (thread-context) hwnd)
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
@@ -454,7 +454,7 @@
 
 (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignore wparam lparam))
-  (remove-widget (thread-context) hwnd)
+  (delete-widget (thread-context) hwnd)
   (call-next-method))
 
 ;;;

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp	Tue Jul 11 16:33:21 2006
@@ -196,7 +196,7 @@
 
 (defmethod gfs:dispose ((it menu-item))
   (setf (dispatcher it) nil)
-  (remove-menuitem (thread-context) it)
+  (delete-menuitem (thread-context) it)
   (let ((id (item-id it))
         (owner (owner it)))
     (unless (null owner)

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Tue Jul 11 16:33:21 2006
@@ -142,13 +142,13 @@
 
 (defun menu-cleanup-callback (menu item)
   (let ((tc (thread-context)))
-    (remove-widget tc (gfs:handle menu))
-    (remove-menuitem tc item)))
+    (delete-widget tc (gfs:handle menu))
+    (delete-menuitem tc item)))
 
 (defmethod gfs:dispose ((m menu))
   (visit-menu-tree m #'menu-cleanup-callback)
   (let ((hwnd (gfs:handle m)))
-    (remove-widget (thread-context) hwnd)
+    (delete-widget (thread-context) hwnd)
     (if (not (gfs:null-handle-p hwnd))
       (if (zerop (gfs::destroy-menu hwnd))
         (error 'gfs:win32-error :detail "destroy-menu failed"))))

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Tue Jul 11 16:33:21 2006
@@ -133,7 +133,7 @@
   "Add the specified widget to the widget table using its native handle as the key."
   (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w))
 
-(defmethod remove-widget ((tc thread-context) hwnd)
+(defmethod delete-widget ((tc thread-context) hwnd)
   "Remove the widget object corresponding to the specified native window handle."
   (when (not (slot-value tc 'wip))
     (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
@@ -154,7 +154,7 @@
   (if (find :keyboard-navigation (style-of widget))
     (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc)))))
 
-(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget))
+(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget))
   (setf (kbdnav-widgets tc)
         (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd))
                    (kbdnav-widgets tc)
@@ -170,7 +170,7 @@
       (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr)))
                             (rest widgets)))
       (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0))
-        (let ((tmp (remove-kbdnav-widget tc widget)))
+        (let ((tmp (delete-kbdnav-widget tc widget)))
           (setf (kbdnav-widgets tc) (push widget tmp)))
         (return-from intercept-kbdnav-message widget))))
   nil)
@@ -183,7 +183,7 @@
   "Stores a menu item using its id as the key."
   (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it))
 
-(defmethod remove-menuitem ((tc thread-context) (it menu-item))
+(defmethod delete-menuitem ((tc thread-context) (it menu-item))
   "Removes the menu item using its id as the key."
   (maphash
     #'(lambda (k v)
@@ -206,7 +206,7 @@
   "Stores a timer using its id as the key."
   (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer))
 
-(defmethod remove-timer ((tc thread-context) (timer timer))
+(defmethod delete-timer ((tc thread-context) (timer timer))
   "Removes the timer using its id as the key."
   (maphash
     #'(lambda (k v)

Modified: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/timer.lisp	(original)
+++ trunk/src/uitoolkit/widgets/timer.lisp	Tue Jul 11 16:33:21 2006
@@ -78,7 +78,7 @@
 
 (defmethod gfs:dispose ((self timer))
   (let ((tc (thread-context)))
-    (remove-timer tc self)
+    (delete-timer tc self)
     (gfs::kill-timer (utility-hwnd tc) (id-of self))))
 
 (defmethod initialize-instance :after ((self timer) &key)

Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp	(original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp	Tue Jul 11 16:33:21 2006
@@ -130,7 +130,7 @@
   (let ((m (menu-bar win)))
     (unless (null m)
       (visit-menu-tree m #'menu-cleanup-callback)
-      (remove-widget (thread-context) (gfs:handle m))))
+      (delete-widget (thread-context) (gfs:handle m))))
   (call-next-method))
 
 (defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Tue Jul 11 16:33:21 2006
@@ -84,17 +84,11 @@
 (defgeneric checked-p (self)
   (:documentation "Returns T if the object is in the checked state; nil otherwise."))
 
-(defgeneric clear-all (self)
-  (:documentation "Clears all content from self."))
-
-(defgeneric clear-item (self index)
-  (:documentation "Clears the item at the zero-based index."))
-
 (defgeneric clear-selection (self)
-  (:documentation "Sets the object's selection status to empty or not selected."))
+  (:documentation "The set of selected items in self is made empty."))
 
-(defgeneric clear-span (self sp)
-  (:documentation "Clears the items whose zero-based indices lie within the specified span."))
+(defgeneric clear-selection-span (self span)
+  (:documentation "Sets a subset of self's current selection to the unselected state."))
 
 (defgeneric client-size (self)
   (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data."))
@@ -132,6 +126,18 @@
 (defgeneric default-widget (self)
   (:documentation "Returns the child widget or item that has the default emphasis."))
 
+(defgeneric delete-all (self)
+  (:documentation "Removes all content from the object."))
+
+(defgeneric delete-item (self index)
+  (:documentation "Removes the item at the zero-based index from the object."))
+
+(defgeneric delete-item-span (self span)
+  (:documentation "Removes the sequence of items represented by the specified span object."))
+
+(defgeneric delete-selection (self)
+  (:documentation "Removes items from self that are in the selected state."))
+
 (defgeneric disabled-image (self)
   (:documentation "Returns the image used to render this item with a disabled look."))
 
@@ -282,15 +288,6 @@
 (defgeneric redrawing-p (self)
   (:documentation "Returns T if the object is set to allow processing of paint events."))
 
-(defgeneric remove-all (self)
-  (:documentation "Removes all items from the object."))
-
-(defgeneric remove-item (self index)
-  (:documentation "Removes the item at the zero-based index from the object."))
-
-(defgeneric remove-span (self sp)
-  (:documentation "Removes the sequence of items represented by the specified span object."))
-
 (defgeneric reparentable-p (self)
   (:documentation "Returns T if the window system allows this object to be reparented; nil otherwise."))
 

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Tue Jul 11 16:33:21 2006
@@ -38,17 +38,17 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-all ((self widget-with-items))
+(defmethod delete-all ((self widget-with-items))
   (let ((count (length (items self))))
     (unless (zerop count)
-      (clear-span self (gfs:make-span :start 0 :end (1- count))))))
+      (delete-item-span self (gfs:make-span :start 0 :end (1- count))))))
 
-(defmethod clear-item :before ((self widget-with-items) index)
+(defmethod delete-item :before ((self widget-with-items) index)
   (declare (ignore index))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-item ((self widget-with-items) index)
+(defmethod delete-item ((self widget-with-items) index)
   (let* ((items (items self))
          (it (elt items index)))
     (delete it (items self) :test #'items-equal-p)
@@ -56,14 +56,14 @@
       (error 'gfs:disposed-error))
     (gfs:dispose it)))
 
-(defmethod clear-span :before ((self widget-with-items) (sp gfs:span))
+(defmethod delete-item-span :before ((self widget-with-items) (sp gfs:span))
   (declare (ignore sp))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-span ((self widget-with-items) (sp gfs:span))
+(defmethod delete-item-span ((self widget-with-items) (sp gfs:span))
   (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
-    (clear-item self (gfs:span-start sp))))
+    (delete-item self (gfs:span-start sp))))
 
 (defmethod item-index :before ((self widget-with-items) (it item))
   (declare (ignore it))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Tue Jul 11 16:33:21 2006
@@ -133,11 +133,12 @@
   (declare (ignore self))
   nil)
 
-(defmethod clear-all :before ((self widget))
+(defmethod clear-selection :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod clear-selection :before ((self widget))
+(defmethod clear-selection-span :before ((self widget) span)
+  (declare (ignore span))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
@@ -167,6 +168,24 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
+(defmethod delete-all :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod delete-item :before ((self widget) index)
+  (declare (ignore index))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod delete-item-span :before ((self widget) span)
+  (declare (ignore span))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod delete-selection :before ((self widget))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod gfs:dispose ((self widget))
   (unless (null (dispatcher self))
     (event-dispose (dispatcher self) self))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Tue Jul 11 16:33:21 2006
@@ -166,7 +166,7 @@
     new-size))
 
 (defmethod gfs:dispose ((self window))
-  (remove-kbdnav-widget (thread-context) self)
+  (delete-kbdnav-widget (thread-context) self)
   (call-next-method))
 
 (defmethod enable-layout :before ((win window) flag)


From junrue at common-lisp.net  Thu Jul 13 06:38:03 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 13 Jul 2006 02:38:03 -0400 (EDT)
Subject: [graphic-forms-cvs] r193 - in trunk: docs/manual src
	src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060713063803.C939159095@common-lisp.net>

Author: junrue
Date: Thu Jul 13 02:38:01 2006
New Revision: 193

Modified:
   trunk/docs/manual/api.texinfo
   trunk/docs/manual/miscellaneous.texinfo
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/edit.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented select-all and select-span for edit controls

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu Jul 13 02:38:01 2006
@@ -128,9 +128,9 @@
 @end defun
 
 @anchor{location}
- at deffn Macro location rect
+ at defmac location rect
 This macro returns the @var{location} slot of a @ref{rectangle}.
- at end deffn
+ at end defmac
 
 @deffn Function make-point :x :y :z
 This function creates a new @ref{point} object.
@@ -148,9 +148,9 @@
 This function creates a new @ref{span} object.
 @end deffn
 
- at deffn Macro size rect
+ at defmac size rect
 This macro returns the @code{size} slot of a @ref{rectangle}.
- at end deffn
+ at end defmac
 
 
 @node system conditions
@@ -1282,17 +1282,6 @@
 Returns T if the object is in the checked state; nil otherwise.
 @end deffn
 
- at deffn GenericFunction clear-selection self
-Sets the selection status of @code{self} (or @ref{item}s within
- at var{self}) to the @samp{unselected} state.
- at end deffn
-
- at deffn GenericFunction clear-selection-span self @ref{span}
-Sets the selection status of @ref{item}s within @var{self}, whose
-zero-based indices lie within @var{span}, to the @samp{unselected}
-state.
- at end deffn
-
 @deffn GenericFunction client-size self
 Returns a size object that describes the region of the object that can
 be drawn within or can display data.
@@ -1618,10 +1607,31 @@
 decorations are modified appropriately.
 @end deffn
 
+ at deffn GenericFunction select-all self flag
+Sets the entire content of @code{self} to the selected state if
+ at var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
+ at end deffn
+
+ at anchor{select-items}
+ at deffn GenericFunction select-items self indices flag
+Sets the @ref{item}s of @var{self}, each identified by a zero-based
+index from the @var{indices} @sc{list}, to the selected state if
+ at var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
+This is the function to use when not all of the items in question
+are contiguous.
+ at end deffn
+
+ at anchor{select-span}
+ at deffn GenericFunction select-span self span
+Sets the @ref{item}s of @var{self} that lie within @var{span} to
+the selected state. An existing selection's extent is modified
+to match the new @var{span}.
+ at end deffn
+
 @deffn GenericFunction selection-span self => @ref{span}
-Returns a span object describing the start and end of the selection
-within @var{self}. If there is no selection, this function returns
- at sc{nil}.
+Returns a span object describing the @var{start} and @var{end} of the
+selection within @var{self}. If there is no selection, this function
+returns @sc{nil}.
 @end deffn
 
 @anchor{show}
@@ -1701,30 +1711,37 @@
 @end deffn
 @end html
 
+ at defmac with-drawing-disabled (widget) &body body
+This macro executes @var{body} while updates of @var{widget} are
+disabled. Drawing operations attempted while @var{body}
+is executing will be queued so that when the lock is lifted
+ at var{widget} will be repainted.
+ at end defmac
+
 @anchor{with-file-dialog}
- at deffn Macro with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body
+ at defmac with-file-dialog (owner style paths &key default-extension filters initial-directory initial-filename text) &body body
 This macro wraps the instantiation of a standard file open/save dialog
-and the subsequent retrieval of the user's file selections (supplied to @code{body}
-via @code{paths}). @xref{file-dialog}.
- at end deffn
+and the subsequent retrieval of the user's file selections (supplied to @var{body}
+via @var{paths}). @xref{file-dialog}.
+ at end defmac
 
 @anchor{with-font-dialog}
- at deffn Macro with-font-dialog (owner style font color &key gc initial-color initial-font) &body body
+ at defmac with-font-dialog (owner style font color &key gc initial-color initial-font) &body body
 This macro wraps the instantiation of a standard font dialog and binds
- at code{font} to a font object, and @code{color} to a @ref{color} object,
+ at var{font} to a font object, and @var{color} to a @ref{color} object,
 corresponding to the attributes selected by the user. If the user cancels
-the dialog, @code{font} will be @sc{nil}. In addition, @code{color} will also
+the dialog, @var{font} will be @sc{nil}. In addition, @var{color} will also
 be @sc{nil} if the dialog was created with the @code{:no-effects} style
 keyword. @xref{font-dialog}.
- at end deffn
+ at end defmac
 
 @anchor{with-graphics-context}
- at deffn Macro with-graphics-context (gc &optional thing) &body body
+ at defmac with-graphics-context (gc &optional thing) &body body
 This macro manages a @ref{graphics-context} representing the underlying
-device context of @code{thing}, which can be a @ref{widget} or an
- at ref{image}. If @code{thing} is not specified, then the macro creates
+device context of @var{thing}, which can be a @ref{widget} or an
+ at ref{image}. If @var{thing} is not specified, then the macro creates
 a graphics-context compatible with the @ref{display}.
- at end deffn
+ at end defmac
 
 
 @node layout functions

Modified: trunk/docs/manual/miscellaneous.texinfo
==============================================================================
--- trunk/docs/manual/miscellaneous.texinfo	(original)
+++ trunk/docs/manual/miscellaneous.texinfo	Thu Jul 13 02:38:01 2006
@@ -20,8 +20,8 @@
 
 This chapter documents terminology conventions observed in
 Graphic-Forms. These conventions should be interpreted with the
-traditional Common Lisp conventions in mind (such as
- at url{http://www.cliki.net/Naming%20conventions}). 
+traditional Common Lisp conventions in mind (some of which are
+documented here: @url{http://www.cliki.net/Naming%20conventions}). 
 
 @table @option
 
@@ -29,6 +29,41 @@
 For clearer identification of accessors, Graphic-Forms
 uses the suffix @samp{-of} whenever possible.
 
+ at item @samp{check} versus @samp{select}
+Admittedly, these two concepts are similar. They can be used as verbs
+and they both describe a state of being (@samp{checked} and
+ at samp{selected}). Yet they need to remain separate due to the fact
+that certain @ref{widget}s can exist in both states simultaneously,
+like a tri-state @ref{button}, or a table or tree whose items are
+checkboxes. The choice of which best describes an action or state
+amounts to a judgement call. In Graphic-Forms, the author chooses to
+use @samp{select} when a user gesture causes a widget to issue its
+primary notification event, such as a menu item or button being
+clicked. Hence, the verb @samp{select} aligns with the
+ at ref{event-select} function. at footnote{This topic gets muddier when
+edit controls come into the picture. Text in an edit control is
+selected despite there being no notification event; yet there is a
+notification (event-modify) then the user types text. I'm choosing to
+live with this inconsistency, partly because otherwise my
+categorization scheme seems to work well; and one can refer to the act
+of retrieving edit control selection, confident that developers will
+know this means obtaining highlighted text.} And so the
+ at samp{selection} state is associated with highlighting of an
+ at ref{item}. Graphic-Forms uses @samp{check} to identify an operation
+that flags or annotates a widget; the @samp{checked} state means being
+annotated.
+
+ at c @item @samp{clear} versus @samp{delete}
+ at c There is a distinction between @samp{clear} and @samp{delete} which
+ at c hinges on the difference between the primary content of a @ref{widget}
+ at c and secondary state information. An example of primary content is text
+ at c within an @ref{edit} @ref{control}. An example of secondary state
+ at c information (relevant to this topic at least) is the @ref{span} of
+ at c selected text in an edit control. With that in mind, Graphic-Forms
+ at c functions @samp{delete} content but @samp{clear} secondary state. This
+ at c choice aligns with the semantics of @sc{CL:delete}, including the
+ at c notion of that function being a destructive operation.
+
 @item function and method names
 Functions and methods should be named using a verb to suggest
 action. It may be tempting (especially for former Java programmers) to
@@ -39,25 +74,14 @@
 functions, the author suggests @samp{available-p}, such as
 @ref{undo-available-p}.
 
- at item @samp{clear} versus @samp{delete}
-Related to the @samp{function and method names} issues, there is
-a distinction between @samp{clear} and @samp{delete} which hinges on
-the difference between the primary content of a @ref{widget} and
-secondary state information. An example of primary content is text
-within an @ref{edit} @ref{control}. An example of secondary state
-information (relevant to this topic at least) is the @ref{span} of
-selected text in an edit control. With that in mind, Graphic-Forms
-functions @samp{delete} content but @samp{clear} secondary state. This
-choice is intended in part to align with the semantics of
- at sc{CL:delete}, including the notion of that function being a
-destructive operation.
-
 @item macro names
 Macros should be named consistent with established Common Lisp
 practice, with an exception being allowed for convenience wrappers
-around structure accessors (see @ref{location}). Otherwise, the
-temptation to define an unorthodox macro name is a symptom that maybe
-the code in question should not be a macro in the first place.
+around structure accessors (see for example
+ at ref{location}). Otherwise, the temptation to define an unorthodox
+macro name is a symptom that maybe the code in question should not be
+a macro in the first place. The rule of thumb is: if something can
+be a function, then let it be a function; in general, think carefully
+before creating a new macro.
 
 @end table
-

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Thu Jul 13 02:38:01 2006
@@ -96,7 +96,11 @@
     (gfw:enable (elt items 2) text-sel)
     (gfw:enable (elt items 3) text-sel)
     (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*))
-    (gfw:enable (elt items 5) text-sel)))
+    (gfw:enable (elt items 5) text-sel)
+    (gfw:enable (elt items 12) (or (null text-sel)
+                                   (> (gfs:span-start text-sel) 0)
+                                   (< (gfs:span-end text-sel)
+                                      (length (gfw:text *textedit-control*)))))))
 
 (defun textedit-edit-copy (disp item)
   (declare (ignore disp item))
@@ -114,6 +118,10 @@
   (declare (ignore disp item))
   (gfw:paste-text *textedit-control*))
 
+(defun textedit-edit-selall (disp item)
+  (declare (ignore disp item))
+  (gfw:select-all *textedit-control* t))
+
 (defun textedit-edit-undo (disp item)
   (declare (ignore disp item)))
 
@@ -234,7 +242,7 @@
                                           (:item "&Replace..."                                      :disabled)
                                           (:item "&Go To...")
                                           (:item "" :separator)
-                                          (:item "Select &All")))
+                                          (:item "Select &All"     :callback #'textedit-edit-selall)))
                                (:item "F&ormat"
                                 :submenu ((:item "&Font..."        :callback #'textedit-font)))
                                (:item "&Help"

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Thu Jul 13 02:38:01 2006
@@ -465,6 +465,7 @@
     #:scroll
     #:select
     #:select-all
+    #:select-items
     #:selected-p
     #:selection-count
     #:selection-index
@@ -502,6 +503,7 @@
     #:vertical-scrollbar
     #:visible-item-count
     #:visible-p
+    #:with-drawing-disabled
     #:with-file-dialog
     #:with-font-dialog
     #:with-graphics-context

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Thu Jul 13 02:38:01 2006
@@ -497,6 +497,11 @@
   (fu-load UINT))
 
 (defcfun
+  ("LockWindowUpdate" lock-window-update)
+  BOOL
+  (hwnd HANDLE))
+
+(defcfun
   ("MapVirtualKeyA" map-virtual-key)
   UINT
   (code UINT)

Modified: trunk/src/uitoolkit/widgets/edit.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/edit.lisp	(original)
+++ trunk/src/uitoolkit/widgets/edit.lisp	Thu Jul 13 02:38:01 2006
@@ -130,6 +130,17 @@
                                       (* +vertical-edit-text-margin+ 2))))
     size))
 
+(defmethod select-all ((self edit) flag)
+  (if flag
+    (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 (length (text self)))
+    (gfs::send-message (gfs:handle self) gfs::+em-setsel+ 0 0)))
+
+(defmethod select-span ((self edit) (span gfs:span))
+  (with-drawing-disabled (self)
+    (let ((hwnd (gfs:handle self)))
+      (gfs::send-message hwnd gfs::+em-setsel+ 1 1)
+      (gfs::send-message hwnd gfs::+em-setsel+ (gfs:span-start span) (gfs:span-end span)))))
+
 (defmethod selection-span ((self edit))
   (cffi:with-foreign-object (start-ptr :unsigned-long)
     (cffi:with-foreign-object (end-ptr :unsigned-long)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Thu Jul 13 02:38:01 2006
@@ -84,12 +84,6 @@
 (defgeneric checked-p (self)
   (:documentation "Returns T if the object is in the checked state; nil otherwise."))
 
-(defgeneric clear-selection (self)
-  (:documentation "The set of selected items in self is made empty."))
-
-(defgeneric clear-selection-span (self span)
-  (:documentation "Sets a subset of self's current selection to the unselected state."))
-
 (defgeneric client-size (self)
   (:documentation "Returns a size object that describes the region of the object that can be drawn within or can display data."))
 
@@ -303,11 +297,14 @@
 (defgeneric scroll (self dest-pnt src-rect children-too)
   (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
 
-(defgeneric select (self flag)
-  (:documentation "Set this object into (or take it out of) the selected state."))
-
 (defgeneric select-all (self flag)
-  (:documentation "Set all items of this object into (or take them out of) the selected state."))
+  (:documentation "Set all items of this object into (or out of) the selected state."))
+
+(defgeneric select-items (self indices flag)
+  (:documentation "Set items of self, each identified by a zero-based index, into (or out of) the selected state."))
+
+(defgeneric select-span (self span)
+  (:documentation "Set items of self that lie within span into the selected state."))
 
 (defgeneric selected-p (self)
   (:documentation "Returns T if the object is in the selected state; nil otherwise."))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Thu Jul 13 02:38:01 2006
@@ -50,7 +50,16 @@
        (unwind-protect
            (progn
              , at body)
-         (gfs:dispose ,gc)))))
+         (gfs:dispose ,gc))))
+
+  (defmacro with-drawing-disabled ((widget) &body body)
+    `(unwind-protect
+         (progn
+           (unless (gfs:disposed-p ,widget)
+             (error 'gfs:disposed-error))
+           (gfs::lock-window-update (gfs:handle ,widget))
+           , at body)
+       (gfs::lock-window-update (cffi:null-pointer)))))
 
 (defun translate-and-dispatch (msg-ptr)
   (gfs::translate-message msg-ptr)

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Thu Jul 13 02:38:01 2006
@@ -133,15 +133,6 @@
   (declare (ignore self))
   nil)
 
-(defmethod clear-selection :before ((self widget))
-  (if (gfs:disposed-p self)
-    (error 'gfs:disposed-error)))
-
-(defmethod clear-selection-span :before ((self widget) span)
-  (declare (ignore span))
-  (if (gfs:disposed-p self)
-    (error 'gfs:disposed-error)))
-
 (defmethod client-size :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
@@ -296,7 +287,7 @@
 (defmethod print-object ((self widget) stream)
   (print-unreadable-object (self stream :type t)
     (format stream "handle: ~x " (gfs:handle self))
-    (format stream "dispatcher: ~a " (dispatcher self))))
+    (format stream "dispatcher: ~a~%" (dispatcher self))))
 
 (defmethod redo-available-p :before ((self widget))
   (if (gfs:disposed-p self)
@@ -321,12 +312,31 @@
 (defmethod resizable-p ((self widget))
   nil)
 
+(defmethod select :before ((self widget) flag)
+  (declare (ignore flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod select-all :before ((self widget) flag)
+  (declare (ignore flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod select-items :before ((self widget) items flag)
+  (declare (ignore items flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
+(defmethod select-span :before ((self widget) span)
+  (declare (ignore span))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod selected-p :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
 (defmethod selected-p ((self widget))
-  (declare (ignore self))
   nil)
 
 (defmethod selection-span :before ((self widget))


From junrue at common-lisp.net  Thu Jul 13 14:15:32 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 13 Jul 2006 10:15:32 -0400 (EDT)
Subject: [graphic-forms-cvs] r194 - in trunk/src: demos/textedit
	uitoolkit/widgets
Message-ID: <20060713141532.A4D7337002@common-lisp.net>

Author: junrue
Date: Thu Jul 13 10:15:32 2006
New Revision: 194

Modified:
   trunk/src/demos/textedit/textedit-window.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
WM_ACTIVATE seems to be getting additional notification values than documented so changed an ecase to case; fix select all item enabling in textedit when text is empty

Modified: trunk/src/demos/textedit/textedit-window.lisp
==============================================================================
--- trunk/src/demos/textedit/textedit-window.lisp	(original)
+++ trunk/src/demos/textedit/textedit-window.lisp	Thu Jul 13 10:15:32 2006
@@ -91,16 +91,17 @@
   (unless *textedit-control*
     (return-from manage-textedit-edit-menu nil))
   (let ((items (gfw:items menu))
+        (text (gfw:text *textedit-control*))
         (text-sel (gfw:selection-span *textedit-control*)))
     (gfw:enable (elt items 0) (gfw:undo-available-p *textedit-control*))
     (gfw:enable (elt items 2) text-sel)
     (gfw:enable (elt items 3) text-sel)
     (gfw:enable (elt items 4) (gfw:text-for-pasting-p *textedit-control*))
     (gfw:enable (elt items 5) text-sel)
-    (gfw:enable (elt items 12) (or (null text-sel)
-                                   (> (gfs:span-start text-sel) 0)
-                                   (< (gfs:span-end text-sel)
-                                      (length (gfw:text *textedit-control*)))))))
+    (gfw:enable (elt items 12) (and (> (length text) 0)
+                                    (or (null text-sel)
+                                        (> (gfs:span-start text-sel) 0)
+                                        (< (gfs:span-end text-sel) (length text)))))))
 
 (defun textedit-edit-copy (disp item)
   (declare (ignore disp item))

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Thu Jul 13 10:15:32 2006
@@ -353,7 +353,7 @@
   (declare (ignore lparam))
   (let ((widget (get-widget (thread-context) hwnd)))
     (if widget
-      (ecase wparam
+      (case wparam
         (#.gfs::+wa-active+      (event-activate   (dispatcher widget) widget))
         (#.gfs::+wa-clickactive+ (event-activate   (dispatcher widget) widget))
         (#.gfs::+wa-inactive+    (event-deactivate (dispatcher widget) widget)))))


From junrue at common-lisp.net  Thu Jul 13 16:21:55 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 13 Jul 2006 12:21:55 -0400 (EDT)
Subject: [graphic-forms-cvs] r195 - in trunk: docs/manual
	src/tests/uitoolkit src/uitoolkit/widgets
Message-ID: <20060713162155.0972720011@common-lisp.net>

Author: junrue
Date: Thu Jul 13 12:21:53 2006
New Revision: 195

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/button.lisp
   trunk/src/uitoolkit/widgets/item.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
documented select/selected-p methods and implemented them for buttons

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu Jul 13 12:21:53 2006
@@ -1607,6 +1607,11 @@
 decorations are modified appropriately.
 @end deffn
 
+ at deffn GenericFunction select self flag
+Sets @var{self} to the selected state if @var{flag} is not @sc{nil}
+or to the unselected state if @sc{nil}.
+ at end deffn
+
 @deffn GenericFunction select-all self flag
 Sets the entire content of @code{self} to the selected state if
 @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
@@ -1634,6 +1639,10 @@
 returns @sc{nil}.
 @end deffn
 
+ at deffn GenericFunction selected-p self => boolean
+Returns T if @var{self} is in the selected state; @sc{nil} otherwise.
+ 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/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Thu Jul 13 12:21:53 2006
@@ -112,7 +112,10 @@
                                 :dispatcher be
                                 :style (list subtype)))
          (setf (toggle-fn be) (create-button-toggler be))
-         (setf (gfw:text w) (funcall (toggle-fn be))))
+         (setf (gfw:text w) (funcall (toggle-fn be)))
+         (if (eql subtype :tri-state)
+           (gfw:check w t)
+           (gfw:check w t)))
       ((eql subtype :single-line-edit)
          (setf w (make-instance widget-class
                                 :parent *layout-tester-win*

Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp	(original)
+++ trunk/src/uitoolkit/widgets/button.lisp	Thu Jul 13 12:21:53 2006
@@ -40,6 +40,17 @@
 ;;; methods
 ;;;
 
+(defmethod check ((self button) flag)
+  (let ((bits (if flag gfs::+bst-checked+ gfs::+bst-unchecked+)))
+    (gfs::send-message (gfs:handle self) gfs::+bm-setcheck+ bits 0)))
+
+(defmethod checked-p ((self button))
+  (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0)))
+    (case bits
+      (gfs::+bst-checked+    t)
+      (gfs::+bst-unchecked+  nil)
+      (otherwise             nil))))
+
 (defmethod compute-style-flags ((self button) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -115,6 +126,12 @@
                                          (gfs:size-height text-size)))))
     size))
 
+(defmethod select ((self button) flag)
+  (check self flag))
+
+(defmethod selected-p ((self button))
+  (checked-p self))
+
 (defmethod text ((self button))
   (get-widget-text self))
 

Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/item.lisp	Thu Jul 13 12:21:53 2006
@@ -36,7 +36,12 @@
 (defun items-equal-p (item1 item2)
   (= (item-id item1) (item-id item2)))
 
-(defmethod check :before ((it item) flag)
+(defmethod check :before ((self item) flag)
   (declare (ignore flag))
-  (if (gfs:null-handle-p (gfs:handle it))
+  (if (gfs:null-handle-p (gfs:handle self))
+    (error 'gfs:toolkit-error :detail "null owner handle")))
+
+(defmethod checked-p :before ((self item))
+  (declare (ignore flag))
+  (if (gfs:null-handle-p (gfs:handle self))
     (error 'gfs:toolkit-error :detail "null owner handle")))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Thu Jul 13 12:21:53 2006
@@ -297,6 +297,9 @@
 (defgeneric scroll (self dest-pnt src-rect children-too)
   (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
 
+(defgeneric select (self flag)
+  (:documentation "Set self into (or out of) the selected state."))
+
 (defgeneric select-all (self flag)
   (:documentation "Set all items of this object into (or out of) the selected state."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Thu Jul 13 12:21:53 2006
@@ -125,12 +125,16 @@
 (defmethod center-on-parent ((self widget))
   (center-object (parent self) self))
 
+(defmethod check :before ((self widget) flag)
+  (declare (ignore flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod checked-p :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
 (defmethod checked-p ((self widget))
-  (declare (ignore self))
   nil)
 
 (defmethod client-size :before ((self widget))


From junrue at common-lisp.net  Thu Jul 13 17:46:24 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 13 Jul 2006 13:46:24 -0400 (EDT)
Subject: [graphic-forms-cvs] r196 - trunk/src/uitoolkit/system
Message-ID: <20060713174624.23D3831031@common-lisp.net>

Author: junrue
Date: Thu Jul 13 13:46:23 2006
New Revision: 196

Modified:
   trunk/src/uitoolkit/system/comdlg32.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/system-types.lisp
   trunk/src/uitoolkit/system/user32.lisp
Log:
preparation for implementing standard find/replace dialog

Modified: trunk/src/uitoolkit/system/comdlg32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/comdlg32.lisp	(original)
+++ trunk/src/uitoolkit/system/comdlg32.lisp	Thu Jul 13 13:46:23 2006
@@ -41,18 +41,28 @@
 (defcfun
   ("ChooseFontA" choose-font)
   BOOL
-  (struct LPTR))
+  (struct LPTR)) ; choosefont struct
 
 (defcfun
   ("CommDlgExtendedError" comm-dlg-extended-error)
   DWORD)
 
 (defcfun
+  ("FindTextA" find-text)
+  HANDLE
+  (fr LPTR)) ; findreplace struct
+
+(defcfun
   ("GetOpenFileNameA" get-open-filename)
   BOOL
-  (ofn LPTR))
+  (ofn LPTR)) ; openfilename struct
 
 (defcfun
   ("GetSaveFileNameA" get-save-filename)
   BOOL
-  (ofn LPTR))
+  (ofn LPTR)) ; openfilename struct
+
+(defcfun
+  ("ReplaceTextA" replace-text)
+  HANDLE
+  (fr LPTR)) ; findreplace struct

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Thu Jul 13 13:46:23 2006
@@ -33,10 +33,24 @@
 
 (in-package :graphic-forms.uitoolkit.system)
 
+;;;
+;;; control class names
+;;;
 (defconstant +button-classname+          "button")
 (defconstant +edit-classname+              "edit")
 (defconstant +static-classname+          "static")
 
+;;;
+;;; registered message names
+;;;
+(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify")
+(defconstant +sharevistringa+     "commdlg_ShareViolation")
+(defconstant +fileokstringa+          "commdlg_FileNameOK")
+(defconstant +colorokstringa+            "commdlg_ColorOK")
+(defconstant +setrgbstringa+         "commdlg_SetRGBColor")
+(defconstant +helpmsgstringa+               "commdlg_help")
+(defconstant +findmsgstringa+        "commdlg_FindReplace")
+
 (defconstant +ad-counterclockwise+              1)
 (defconstant +ad-clockwise+                     2)
 
@@ -374,6 +388,31 @@
 (defconstant +fr-private+                    #x10)
 (defconstant +fr-not-enum+                   #x20)
 
+;;;
+;;; find/replace dialog-related constants
+;;;
+(defconstant +fr-down+                 #x00000001)
+(defconstant +fr-wholeword+            #x00000002)
+(defconstant +fr-matchcase+            #x00000004)
+(defconstant +fr-findnext+             #x00000008)
+(defconstant +fr-replace+              #x00000010)
+(defconstant +fr-replaceall+           #x00000020)
+(defconstant +fr-dialogterm+           #x00000040)
+(defconstant +fr-showhelp+             #x00000080)
+(defconstant +fr-enablehook+           #x00000100)
+(defconstant +fr-enabletemplate+       #x00000200)
+(defconstant +fr-noupdown+             #x00000400)
+(defconstant +fr-nomatchcase+          #x00000800)
+(defconstant +fr-nowholeword+          #x00001000)
+(defconstant +fr-enabletemplatehandle+ #x00002000)
+(defconstant +fr-hideupdown+           #x00004000)
+(defconstant +fr-hidematchcase+        #x00008000)
+(defconstant +fr-hidewholeword+        #x00010000)
+(defconstant +fr-raw+                  #x00020000)
+(defconstant +fr-matchdiac+            #x20000000)
+(defconstant +fr-matchkashida+         #x40000000)
+(defconstant +fr-matchalefhamza+       #x80000000)
+
 (defconstant +frerr-findreplacecodes+      #x4000)
 (defconstant +frerr-bufferlengthzero+      #x4001)
 

Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp	(original)
+++ trunk/src/uitoolkit/system/system-types.lisp	Thu Jul 13 13:46:23 2006
@@ -151,6 +151,19 @@
   (rightmargin INT)
   (lengthdrawn UINT))
 
+(defcstruct findreplace
+  (structsize DWORD)
+  (howner     HANDLE)
+  (hinst      HANDLE)
+  (flags      DWORD)
+  (whatstr    :string)
+  (withstr    :string)
+  (whatlen    WORD)
+  (withlen    WORD)
+  (data       LPARAM)
+  (hookfn     LPTR) ; FIXME: not yet used, but eventually should be FRHookProc
+  (templname  :string))
+
 (defcstruct initcommoncontrolsex
   (size DWORD)
   (icc DWORD))

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Thu Jul 13 13:46:23 2006
@@ -541,6 +541,11 @@
   (wndclass LPTR))
 
 (defcfun
+  ("RegisterWindowMessageA" register-window-message)
+  UINT
+  (str :string))
+
+(defcfun
   ("ReleaseCapture" release-capture)
   BOOL)
 


From junrue at common-lisp.net  Fri Jul 14 00:20:13 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Thu, 13 Jul 2006 20:20:13 -0400 (EDT)
Subject: [graphic-forms-cvs] r197 - in trunk: docs/manual etc src
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060714002013.7EEE12D01D@common-lisp.net>

Author: junrue
Date: Thu Jul 13 20:20:12 2006
New Revision: 197

Modified:
   trunk/docs/manual/api.texinfo
   trunk/etc/lisp.exe.manifest
   trunk/src/packages.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event.lisp
Log:
implemented event-session function, currently untested

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu Jul 13 20:20:12 2006
@@ -1172,6 +1172,57 @@
 @end table
 @end deffn
 
+ at anchor{event-session}
+ at deffn GenericFunction event-session dispatcher window phase reason
+Implement this method to participate in the system's session shutdown
+protocol.  When the user chooses to end the session (by logging out or
+by shutting down), or if an application calls one of the Win32
+shutdown functions, every application is given a veto option. This
+event function will be called at least once for each @ref{top-level}
+window in the application.@*
+
+The MSDN documentation makes the following recommendations for handling
+this event:
+ at itemize @bullet
+ at item Whenever possible, applications should respect the user's
+intentions by allowing the session to end.
+ at item In the case of a critical operation, provide a @ref{dialog} or
+other feedback with information for the user as to consequences
+if the application is interrupted at this time.
+ at item Respond to the @code{:query} event as quickly as possible, leaving
+time-consuming cleanup to be done in the session @code{:end} event.
+ at end itemize
+
+ at table @var
+ at event-dispatcher-arg
+ at item window
+The @ref{top-level} @ref{window} receiving this event.
+ at item phase
+Identifies which of the two phases this event represents:
+ at table @code
+ at item :query
+This symbol means that the system is querying the application for
+permission to proceed. Return @sc{nil} if there is a reason to veto
+the process, or non- at sc{nil} otherwise.
+ at item :end
+This symbol is specified in the subsequent call to @code{event-session}.
+It means that the system is going ahead with ending the
+session, therefore this is an opportunity for graceful cleanup.
+ at end table
+ at item reason
+Provides more detail to aid in choosing desired behavior:
+ at table @code
+ at item :logoff
+The user is logging off.
+ at item :replacing-file
+The application must exit because a file it is using is being
+replaced.
+ at item :shutdown
+The system is shutting down or restarting.
+ at end table
+ at end table
+ at end deffn
+
 @anchor{event-timer}
 @deffn GenericFunction event-timer dispatcher timer
 Implement this method to respond to expiration of the current

Modified: trunk/etc/lisp.exe.manifest
==============================================================================
--- trunk/etc/lisp.exe.manifest	(original)
+++ trunk/etc/lisp.exe.manifest	Thu Jul 13 20:20:12 2006
@@ -1,10 +1,10 @@
-?<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
+<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
-	<assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/>
+	<assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/>
 	<description>GNU CLISP</description>
 	<dependency>
 		<dependentAssembly>
-			<assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/>
+			<assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/>
 		</dependentAssembly>
 	</dependency>
 </assembly>

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Thu Jul 13 20:20:12 2006
@@ -395,7 +395,7 @@
     #:event-pre-resize
     #:event-resize
     #:event-select
-    #:event-show
+    #:event-session
     #:event-timer
     #:expand
     #:expanded-p

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Thu Jul 13 20:20:12 2006
@@ -974,6 +974,24 @@
 (defconstant +wm-gettextlength+            #x000E)
 (defconstant +wm-paint+                    #x000F)
 (defconstant +wm-close+                    #x0010)
+(defconstant +wm-queryendsession+          #x0011)
+(defconstant +wm-queryopen+                #x0013)
+(defconstant +wm-endsession+               #x0016)
+(defconstant +wm-quit+                     #x0012)
+(defconstant +wm-erasebkgnd+               #x0014)
+(defconstant +wm-syscolorchange+           #x0015)
+(defconstant +wm-showwindow+               #x0018)
+(defconstant +wm-wininichange+             #x001A)
+(defconstant +wm-settingchange+            #x001A)
+(defconstant +wm-devmodechange+            #x001B)
+(defconstant +wm-activateapp+              #x001C)
+(defconstant +wm-fontchange+               #x001D)
+(defconstant +wm-timechange+               #x001E)
+(defconstant +wm-cancelmode+               #x001F)
+(defconstant +wm-setcursor+                #x0020)
+(defconstant +wm-mouseactivate+            #x0021)
+(defconstant +wm-childactivate+            #x0022)
+(defconstant +wm-queuesync+                #x0023)
 (defconstant +wm-getminmaxinfo+            #x0024)
 (defconstant +wm-painticon+                #x0026)
 (defconstant +wm-iconerasebkgnd+           #x0027)

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Thu Jul 13 20:20:12 2006
@@ -178,10 +178,10 @@
   (:method (dispatcher item)
     (declare (ignorable dispatcher item))))
 
-(defgeneric event-show (dispatcher widget)
-  (:documentation "Implement this to respond to an object being shown.")
-  (:method (dispatcher widget)
-    (declare (ignorable dispatcher widget))))
+(defgeneric event-session (dispatcher window phase reason)
+  (:documentation "Implement this to participate in the session shutdown protocol.")
+  (:method (dispatcher window phase reason)
+    (declare (ignorable dispatcher window phase reason))))
 
 (defgeneric event-timer (dispatcher timer)
   (:documentation "Implement this to respond to a tick from a specific timer.")

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Thu Jul 13 20:20:12 2006
@@ -142,6 +142,18 @@
 (defun obtain-event-time ()
   (event-time (thread-context)))
 
+(defun option->reason (lparam)
+  ;; MSDN says the value is a bitmask, so must be tested bit-wise.
+  (cond
+    ((zerop lparam)
+       :shutdown)
+    ((oddp lparam)
+       :replacing-file)
+    ((= (logand lparam #x80000000) #x80000000)
+       :logoff)
+    (t
+       :shutdown)))
+
 ;;;
 ;;; process-message methods
 ;;;
@@ -214,6 +226,19 @@
   (delete-widget (thread-context) hwnd)
   0)
 
+(defmethod process-message (hwnd (msg (eql gfs::+wm-queryendsession+)) wparam lparam)
+  (declare (ignore wparam))
+  (let ((widget (get-widget (thread-context) hwnd)))
+    (unless (null widget)
+      (if (event-session (dispatcher widget) widget :query (option->reason lparam)) 1 0))))
+
+(defmethod process-message (hwnd (msg (eql gfs::+wm-endsession+)) wparam lparam)
+  (declare (ignore wparam))
+  (let ((widget (get-widget (thread-context) hwnd)))
+    (unless (null widget)
+      (event-session (dispatcher widget) widget :end (option->reason lparam))))
+  0)
+
 (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
   (declare (ignore lparam))
   (let* ((tc (thread-context))


From junrue at common-lisp.net  Mon Jul 17 04:48:15 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 17 Jul 2006 00:48:15 -0400 (EDT)
Subject: [graphic-forms-cvs] r198 - in trunk: . src src/uitoolkit/graphics
	src/uitoolkit/graphics/plugins
	src/uitoolkit/graphics/plugins/imagemagick src/uitoolkit/widgets
Message-ID: <20060717044815.892AE1400C@common-lisp.net>

Author: junrue
Date: Mon Jul 17 00:48:13 2006
New Revision: 198

Added:
   trunk/src/uitoolkit/graphics/plugins/
   trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
   trunk/src/uitoolkit/graphics/plugins/imagemagick/
   trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp
      - copied, changed from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp
   trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp
      - copied, changed from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp
   trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
Removed:
   trunk/src/uitoolkit/graphics/magick-core-api.lisp
   trunk/src/uitoolkit/graphics/magick-core-types.lisp
Modified:
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/packages.lisp
   trunk/src/uitoolkit/graphics/graphics-classes.lisp
   trunk/src/uitoolkit/graphics/graphics-generics.lisp
   trunk/src/uitoolkit/graphics/image-data.lisp
   trunk/src/uitoolkit/widgets/thread-context.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
created a plugin system for choosing what library code to load for image data processing, moved existing ImageMagick support into such a plugin

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Mon Jul 17 00:48:13 2006
@@ -69,9 +69,7 @@
                  (:module "graphics"
                     :depends-on ("system")
                     :components
-                      ((:file "magick-core-types")
-                       (:file "magick-core-api")
-                       (:file "graphics-constants")
+                      ((:file "graphics-constants")
                        (:file "graphics-classes")
                        (:file "graphics-generics")
                        (:file "color")
@@ -80,7 +78,18 @@
                        (:file "image")
                        (:file "font-data")
                        (:file "font")
-                       (:file "graphics-context")))
+                       (:file "graphics-context")
+                       (:module "plugins"
+                          :components
+                            ((:file "graphics-plugin-packages")
+#+load-imagemagick-plugin
+                             (:module "imagemagick"
+                                ; :depends-on ("graphics")
+                                :components
+                                  ((:file "magick-core-types")
+                                   (:file "magick-core-api")
+                                   (:file "magick-data-plugin"
+                                      :depends-on ("magick-core-types" "magick-core-api"))))))))
                  (:module "widgets"
                     :depends-on ("graphics")
                     :components

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Mon Jul 17 00:48:13 2006
@@ -111,6 +111,7 @@
     #:graphics-context
     #:image
     #:image-data
+    #:image-data-plugin
     #:palette
     #:pattern
     #:transform
@@ -121,8 +122,10 @@
     #:*color-green*
     #:*color-red*
     #:*color-white*
+    #:*image-file-types*
 
 ;; methods, functions, macros
+    #:accepts-file-p
     #:alpha
     #:anti-alias
     #:ascent
@@ -142,6 +145,7 @@
     #:copy-color
     #:copy-font-data
     #:copy-font-metrics
+    #:data->image
     #:data-object
     #:depth
     #:descent

Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp	Mon Jul 17 00:48:13 2006
@@ -81,7 +81,13 @@
     (direct nil)
     (table nil)))  ; vector of COLOR structs
 
-(defclass image-data (gfs:native-object) ()
+(defclass image-data-plugin (gfs:native-object) ()
+  (:documentation "Graphics library plugin implementation objects."))
+
+(defclass image-data ()
+  ((data-plugin
+    :reader data-plugin-of
+    :initform nil))
   (:documentation "This class maintains image attributes, color, and pixel data."))
 
 (defclass font (gfs:native-object) ()

Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp	Mon Jul 17 00:48:13 2006
@@ -36,6 +36,9 @@
 (defgeneric background-color (self)
   (:documentation "Returns a color object corresponding to the current background color."))
 
+(defgeneric data->image (self)
+  (:documentation "Plugins implement this to translate from a data structure to an HGDIOBJ."))
+
 (defgeneric data-object (self &optional gc)
   (:documentation "Returns the data structure representing the raw form of the object."))
 

Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp	(original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp	Mon Jul 17 00:48:13 2006
@@ -33,10 +33,54 @@
 
 (in-package :graphic-forms.uitoolkit.graphics)
 
+(defvar *image-plugins*    nil)
+
+;;
+;; list the superset of file extensions for formats that any
+;; plugin might support (clearly there are more formats than
+;; this extant in the world, so add more as needed)
+;;
+(defvar *image-file-types* (let ((table (make-hash-table :test #'equal)))
+                             (loop for (key value) in '(("bmp"  "Microsoft Windows bitmap")
+                                                        ("cur"  "Microsoft Windows cursor")
+                                                        ("dib"  "Microsoft Windows device-independent bitmap")
+                                                        ("emf"  "Microsoft Windows Enhanced Metafile")
+                                                        ("eps"  "Adobe Encapsulated PostScript")
+                                                        ("fax"  "Group 3 TIFF")
+                                                        ("fig"  "FIG graphics format")
+                                                        ("gif"  "CompuServe Graphics Interchange Format")
+                                                        ("ico"  "Microsoft Windows icon")
+                                                        ("jpeg" "Joint Photographic Experts Group")
+                                                        ("jpg"  "Joint Photographic Experts Group")
+                                                        ("pbm"  "Portable bitmap format (b/w)")
+                                                        ("pcd"  "Photo CD")
+                                                        ("pcl"  "HP Page Control Language")
+                                                        ("pcx"  "ZSoft IBM PC Paintbrush")
+                                                        ("pdf"  "Portable Document Format")
+                                                        ("pgm"  "Portable graymap")
+                                                        ("pix"  "Alias/Wavefront RLE")
+                                                        ("png"  "Portable Network Graphics")
+                                                        ("ppm"  "Portable pixmap (color)")
+                                                        ("ps"   "Adobe PostScript")
+                                                        ("svg"  "Scalable Vector Graphics")
+                                                        ("tga"  "Truevision Targa")
+                                                        ("tiff" "Tagged Image File")
+                                                        ("wmf"  "Microsoft Windows Metafile")
+                                                        ("xbm"  "X Window System bitmap (b/w)")
+                                                        ("xpm"  "X Window System pixmap (color)"))
+                               do (setf (gethash key table) value))
+                             table))
+
 ;;;
 ;;; helper functions
 ;;;
 
+(defun find-image-plugin (path)
+  (loop for acceptor in *image-plugins*
+            for plugin = (funcall acceptor path)
+            until plugin
+            finally (return plugin)))
+
 (defun image->data (hbmp) (declare (ignore hbmp)))
 #|
 (defun image->data (hbmp)
@@ -124,147 +168,52 @@
     data))
 |#
 
-(defun data->image (data)
-  "Convert the image-data object to a bitmap and return the native handle."
-  (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
-    (cffi:with-foreign-slots ((gfs::bisize
-                               gfs::biwidth
-                               gfs::biheight
-                               gfs::biplanes
-                               gfs::bibitcount
-                               gfs::bicompression
-                               gfs::bisizeimage
-                               gfs::bixpels
-                               gfs::biypels
-                               gfs::biclrused
-                               gfs::biclrimp
-                               gfs::bmicolors)
-                              bi-ptr gfs::bitmapinfo)
-      (let* ((handle (gfs:handle data))
-             (sz (size data))
-             (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
-             (hbmp (cffi:null-pointer))
-             (screen-dc (gfs::get-dc (cffi:null-pointer))))
-        (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
-              gfs::biwidth (gfs:size-width sz)
-              gfs::biheight (- 0 (gfs:size-height sz))
-              gfs::biplanes 1
-              gfs::bibitcount 32   ;; 32bpp even if original image file is not
-              gfs::bicompression gfs::+bi-rgb+
-              gfs::bisizeimage 0
-              gfs::bixpels 0
-              gfs::biypels 0
-              gfs::biclrused 0
-              gfs::biclrimp 0)
-
-        ;; create the bitmap
-        ;;
-        (cffi:with-foreign-object (pix-bits-ptr :pointer)
-          (setf hbmp (gfs::create-dib-section screen-dc
-                                              bi-ptr
-                                              gfs::+dib-rgb-colors+
-                                              pix-bits-ptr
-                                              (cffi:null-pointer)
-                                              0))
-          (if (gfs:null-handle-p hbmp)
-            (error 'gfs:win32-error :detail "create-dib-section failed"))
-
-          ;; update the RGBQUADs
-          ;;
-          (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
-                (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
-            (dotimes (i pix-count)
-              (cffi:with-foreign-slots ((gfg::blue gfg::green gfg::red gfg::reserved)
-                                        (cffi:mem-aref tmp 'gfg::pixel-packet i)
-                                        gfg::pixel-packet)
-                (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
-                                          (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
-                  (setf gfs::rgbreserved 0)
-                  (setf gfs::rgbred (scale-quantum-to-byte red))
-                  (setf gfs::rgbgreen (scale-quantum-to-byte green))
-                  (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
-        (unless (gfs:null-handle-p screen-dc)
-          (gfs::release-dc (cffi:null-pointer) screen-dc))
-        hbmp))))
-
 ;;;
 ;;; methods
 ;;;
 
-(defmethod depth ((data image-data))
-  (let ((handle (gfs:handle data)))
-    (if (null handle)
-      (error 'gfs:disposed-error))
-    (cffi:foreign-slot-value handle 'magick-image 'depth)))
-
-(defmethod gfs:dispose ((data image-data))
-  (let ((victim (gfs:handle data)))
-    (if (null victim)
-      (error 'gfs:disposed-error))
-    (destroy-image victim))
-  (setf (slot-value data 'gfs:handle) nil))
+(defmethod data->image ((self image-data))
+  (data->image (data-plugin-of self)))
+
+(defmethod depth ((self image-data))
+  (depth (data-plugin-of self)))
 
-(defmethod load ((data image-data) path)
+(defmethod gfs:dispose ((self image-data))
+  (let ((victim (data-plugin-of self)))
+    (unless (null victim)
+      (gfs:dispose victim)))
+  (setf (slot-value self 'data-plugin) nil))
+
+(defmethod load ((self image-data) path)
   (setf path (cond
                ((typep path 'pathname) (namestring (merge-pathnames path)))
                ((typep path 'string) (namestring (merge-pathnames path)))
                (t
                  (error 'gfs:toolkit-error :detail "pathname or string required"))))
-  (let ((handle (gfs:handle data)))
-    (when (and handle (not (cffi:null-pointer-p handle)))
-      (destroy-image handle)
-      (setf (slot-value data 'gfs:handle) nil)
-      (setf handle nil))
-    (with-image-path (path info ex)
-      (setf handle (read-image info ex))
-      (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
-        (error 'gfs:toolkit-error :detail (format nil
-                                                  "exception reason: ~s"
-                                                  (cffi:foreign-slot-value ex 'exception-info 'reason))))
-      (if (cffi:null-pointer-p handle)
-        (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
-      (setf (slot-value data 'gfs:handle) handle))))
-
-(defmethod size ((data image-data))
-  (let ((handle (gfs:handle data))
-        (size (gfs:make-size)))
-    (if (or (null handle) (cffi:null-pointer-p handle))
-      (error 'gfs:disposed-error))
-    (cffi:with-foreign-slots ((rows columns) handle magick-image)
-      (setf (gfs:size-height size) rows)
-      (setf (gfs:size-width size) columns))
-    size))
-
-(defmethod (setf size) (size (data image-data))
-  (let ((handle (gfs:handle data))
-        (new-handle (cffi:null-pointer))
-        (ex (acquire-exception-info)))
-    (if (or (null handle) (cffi:null-pointer-p handle))
-      (error 'gfs:disposed-error))
-    (unwind-protect
-        (progn
-          (setf new-handle (resize-image handle
-                                         (gfs:size-width size)
-                                         (gfs:size-height size)
-                                         (cffi:foreign-enum-value 'filter-types :lanczos)
-                                         1.0 ex))
-          (if (gfs:null-handle-p new-handle)
-            (error 'gfs:toolkit-error :detail (format nil
-                                                      "could not resize: ~a"
-                                                      (cffi:foreign-slot-value ex
-                                                                               'exception-info
-                                                                               'reason))))
-          (setf (slot-value data 'gfs:handle) new-handle)
-          (destroy-image handle))
-      (destroy-exception-info ex))))
 
-(defmethod print-object ((data image-data) stream)
-  (if (or (null (gfs:handle data)) (cffi:null-pointer-p (gfs:handle data)))
+  (let ((plugin (data-plugin-of self)))
+    (when plugin
+      (gfs:dispose plugin)
+      (setf (slot-value self 'data-plugin) nil))
+    (setf plugin (find-image-plugin path))
+    (unless plugin
+      (error 'gfs:toolkit-error :detail (format nil "no image data plugin supports: ~a" path)))
+    (load plugin path)
+    (setf (slot-value self 'data-plugin) plugin)))
+
+(defmethod size ((self image-data))
+  (size (data-plugin-of self)))
+
+(defmethod (setf size) (size (self image-data))
+  (setf (gfg:size (data-plugin-of self)) size))
+
+(defmethod print-object ((self image-data) stream)
+  (if (or (null (gfs:handle self)) (cffi:null-pointer-p (gfs:handle self)))
     (error 'gfs:disposed-error))
-  (let ((size (size data)))
-    (print-unreadable-object (data stream :type t)
+  (let ((size (size self)))
+    (print-unreadable-object (self stream :type t)
       ;; FIXME: dump palette info, too
       ;;
       (format stream "width: ~a " (gfs:size-width size))
       (format stream "height: ~a " (gfs:size-height size))
-      (format stream "bits per pixel: ~a " (depth data)))))
+      (format stream "bits per pixel: ~a " (depth self)))))

Added: trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/graphics-plugin-packages.lisp	Mon Jul 17 00:48:13 2006
@@ -0,0 +1,70 @@
+;;;;
+;;;; packages.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 
+;;;;     1. Redistributions of source code must retain the above copyright
+;;;;        notice, this list of conditions and the following disclaimer.
+;;;; 
+;;;;     2. Redistributions in binary form must reproduce the above copyright
+;;;;        notice, this list of conditions and the following disclaimer in the
+;;;;        documentation and/or other materials provided with the distribution.
+;;;; 
+;;;;     3. Neither the names of the authors nor the names of its contributors
+;;;;        may be used to endorse or promote products derived from this software
+;;;;        without specific prior written permission.
+;;;; 
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED.  IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package #:cl-user)
+
+;;;
+;;; package for base Win32 graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.win32
+  (:nicknames #:gfgw32)
+  (:shadow #:load #:type)
+  (:use #:common-lisp)
+  (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+    ))
+
+;;;
+;;; package for ImageMagick graphics plugin
+;;;
+(defpackage #:graphic-forms.uitoolkit.graphics.imagemagick
+  (:nicknames #:gfgim)
+  (:shadow #:load #:type)
+  (:use #:common-lisp)
+  (:export
+
+;; classes and structs
+
+;; constants
+
+;; methods, functions, macros
+
+;; conditions
+    ))

Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp (from r153, trunk/src/uitoolkit/graphics/magick-core-api.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-api.lisp	(original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-api.lisp	Mon Jul 17 00:48:13 2006
@@ -31,12 +31,14 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (use-package :cffi)
   (pushnew cl-user::*magick-library-directory* cffi:*foreign-library-directories* :test #'equal))
 
+(defvar *magick-initialized* nil)
+
 (load-foreign-library "wsock32.dll")
 (load-foreign-library "msvcr71.dll")
 (load-foreign-library "x11.dll")

Copied: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp (from r58, trunk/src/uitoolkit/graphics/magick-core-types.lisp)
==============================================================================
--- trunk/src/uitoolkit/graphics/magick-core-types.lisp	(original)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-core-types.lisp	Mon Jul 17 00:48:13 2006
@@ -31,7 +31,7 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.uitoolkit.graphics)
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (use-package :cffi))
@@ -55,11 +55,11 @@
 (defconstant +yellow-channel+         #x00000004)
 (defconstant +alpha-channel+          #x00000008)
 (defconstant +opacity-channel+        #x00000008)
-(defconstant +matte-channel+          #x00000008) ;; deprecated
+(defconstant +matte-channel+          #x00000008) ; deprecated
 (defconstant +black-channel+          #x00000020)
 (defconstant +index-channel+          #x00000020)
 (defconstant +all-channels+           #x000000FF)
-(defconstant +default-channels+       (logand +all-channels+ (lognot +opacity-channel+))) ;; (AllChannels &~ OpacityChannel)
+(defconstant +default-channels+       (logand +all-channels+ (lognot +opacity-channel+))) ; (AllChannels &~ OpacityChannel)
 
 (defctype quantum :unsigned-short)
 
@@ -373,9 +373,9 @@
   (error-number     :int)
   (reason           :string)
   (description      :string)
-  (exceptions       :pointer)         ;; void*
+  (exceptions       :pointer)         ; void*
   (relinquish       boolean-type)
-  (semaphore        :pointer)         ;; Semaphore*
+  (semaphore        :pointer)         ; Semaphore*
   (signature        :unsigned-long))
 
 (defcstruct primary-info
@@ -398,7 +398,7 @@
 (defcstruct profile-info
   (name             :string)
   (length           :unsigned-long)
-  (info             :pointer)         ;; char*
+  (info             :pointer)         ; char*
   (signature        :unsigned-long))
 
 (defcstruct rectangle-info
@@ -430,24 +430,24 @@
   (rows             :unsigned-long)
   (depth            :unsigned-long)
   (colors           :unsigned-long)
-  (colormap         :pointer)         ;; PixelPacket*
+  (colormap         :pointer)         ; PixelPacket*
   (background-color pixel-packet)
   (border-color     pixel-packet)
   (matte-color      pixel-packet)
   (gamma            :double)
   (chromaticity     chromaticity-info)
   (render-intent    rendering-intent)
-  (profiles         :pointer)         ;; void*
+  (profiles         :pointer)         ; void*
   (units            resolution-type)
-  (montage          :pointer)         ;; char*
-  (directory        :pointer)         ;; char*
-  (geometry         :pointer)         ;; char*
+  (montage          :pointer)         ; char*
+  (directory        :pointer)         ; char*
+  (geometry         :pointer)         ; char*
   (offset           :long)
   (x-resolution     :double)
   (y-resolution     :double)
   (page             rectangle-info)
   (extract-info     rectangle-info)
-  (tile-info        rectangle-info)   ;; deprecated
+  (tile-info        rectangle-info)   ; deprecated
   (bias             :double)
   (blur             :double)
   (fuzz             :double)
@@ -457,7 +457,7 @@
   (gravity          gravity-type)
   (compose          composite-operator)
   (dispose          dispose-type)
-  (clip-mask        :pointer)         ;; Image*
+  (clip-mask        :pointer)         ; Image*
   (scene            :unsigned-long)
   (delay            :unsigned-long)
   (ticks-per-second :unsigned-long)
@@ -466,27 +466,27 @@
   (start-loop       :long)
   (error            error-info)
   (timer            timer-info)
-  (progress-monitor :pointer)         ;; MagickBooleanType (*MagickProgressMonitor)(args)
-  (client-data      :pointer)         ;; void*
-  (cache            :pointer)         ;; void*
-  (attributes       :pointer)         ;; void*
-  (ascii85          :pointer)         ;; _Ascii85Info_*
-  (blob             :pointer)         ;; _BlobInfo_*
+  (progress-monitor :pointer)         ; MagickBooleanType (*MagickProgressMonitor)(args)
+  (client-data      :pointer)         ; void*
+  (cache            :pointer)         ; void*
+  (attributes       :pointer)         ; void*
+  (ascii85          :pointer)         ; _Ascii85Info_*
+  (blob             :pointer)         ; _BlobInfo_*
   (filename         :char :count 4096)
   (magick-filename  :char :count 4096)
   (magick           :char :count 4096)
   (exception        exception-info)
   (debug            boolean-type)
   (reference-count  :long)
-  (semaphore        :pointer)         ;; SemaphoreInfo*
+  (semaphore        :pointer)         ; SemaphoreInfo*
   (color-profile    profile-info)
   (iptc-profile     profile-info)
-  (generic-profile  :pointer)         ;; ProfileInfo*
-  (generic-profiles :unsigned-long)   ;; deprecated (and ProfileInfo too?)
+  (generic-profile  :pointer)         ; ProfileInfo*
+  (generic-profiles :unsigned-long)   ; deprecated (and ProfileInfo too?)
   (signature        :unsigned-long)
-  (previous         :pointer)         ;; Image*
-  (list             :pointer)         ;; Image*
-  (next             :pointer))        ;; Image*
+  (previous         :pointer)         ; Image*
+  (list             :pointer)         ; Image*
+  (next             :pointer))        ; Image*
     
 (defcstruct magick-image-info
   (compression      compression-type)
@@ -495,10 +495,10 @@
   (adjoin           boolean-type)
   (affirm           boolean-type)
   (antialias        boolean-type)
-  (size             :pointer)         ;; char*
-  (extract          :pointer)         ;; char*
-  (page             :pointer)         ;; char*
-  (scenes           :pointer)         ;; char*
+  (size             :pointer)         ; char*
+  (extract          :pointer)         ; char*
+  (page             :pointer)         ; char*
+  (scenes           :pointer)         ; char*
   (scene            :unsigned-long)
   (number-scenes    :unsigned-long)
   (depth            :unsigned-long)
@@ -506,11 +506,11 @@
   (endian           endian-type)
   (units            resolution-type)
   (quality          :unsigned-long)
-  (sampling-factor  :pointer)         ;; char*
-  (server-name      :pointer)         ;; char*
-  (font             :pointer)         ;; char*
-  (texture          :pointer)         ;; char*
-  (density          :pointer)         ;; char*
+  (sampling-factor  :pointer)         ; char*
+  (server-name      :pointer)         ; char*
+  (font             :pointer)         ; char*
+  (texture          :pointer)         ; char*
+  (density          :pointer)         ; char*
   (point-size       :double)
   (fuzz             :double)
   (background-color pixel-packet)
@@ -525,24 +525,24 @@
   (group            :long)
   (ping             boolean-type)
   (verbose          boolean-type)
-  (view             :pointer)         ;; char*
-  (authenticate     :pointer)         ;; char*
-  (channel          :unsigned-int)    ;; ChannelType
-  (attributes       :pointer)         ;; Image*
-  (options          :pointer)         ;; void*
-  (progress-monitor :pointer)         ;; MagickBooleanType (*MagickProgressMonitor)(args)
-  (client-data      :pointer)         ;; void*
-  (cache            :pointer)         ;; void*
-  (stream           :pointer)         ;; size_t (*StreamHandler)(args)
-  (file             :pointer)         ;; FILE*
-  (blob             :pointer)         ;; void*
+  (view             :pointer)         ; char*
+  (authenticate     :pointer)         ; char*
+  (channel          :unsigned-int)    ; ChannelType
+  (attributes       :pointer)         ; Image*
+  (options          :pointer)         ; void*
+  (progress-monitor :pointer)         ; MagickBooleanType (*MagickProgressMonitor)(args)
+  (client-data      :pointer)         ; void*
+  (cache            :pointer)         ; void*
+  (stream           :pointer)         ; size_t (*StreamHandler)(args)
+  (file             :pointer)         ; FILE*
+  (blob             :pointer)         ; void*
   (length           :unsigned-int)
   (magick           :char :count 4096)
   (unique           :char :count 4096)
   (zero             :char :count 4096)
   (filename         :char :count 4906)
   (debug            boolean-type)
-  (tile             :pointer)         ;; deprecated
+  (tile             :pointer)         ; deprecated
   (subimage         :unsigned-long)
   (subrange         :unsigned-long)
   (pen              pixel-packet)

Added: trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp	Mon Jul 17 00:48:13 2006
@@ -0,0 +1,179 @@
+;;;;
+;;;; magick-data-plugin.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;; 
+;;;;     1. Redistributions of source code must retain the above copyright
+;;;;        notice, this list of conditions and the following disclaimer.
+;;;; 
+;;;;     2. Redistributions in binary form must reproduce the above copyright
+;;;;        notice, this list of conditions and the following disclaimer in the
+;;;;        documentation and/or other materials provided with the distribution.
+;;;; 
+;;;;     3. Neither the names of the authors nor the names of its contributors
+;;;;        may be used to endorse or promote products derived from this software
+;;;;        without specific prior written permission.
+;;;; 
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED.  IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.graphics.imagemagick)
+
+(defclass magick-data-plugin (gfg:image-data-plugin) ()
+  (:documentation "ImageMagick library plugin for the graphics package."))
+
+(defun accepts-file-p (path)
+  (unless *magick-initialized*
+    (initialize-magick (cffi:null-pointer))
+    (setf *magick-initialized* t))
+  (cond
+    ((parse-namestring path)) ; syntax check
+    ((typep path 'pathname)
+       (setf path (namestring path)))
+    (t
+       (error 'gfs:toolkit-error :detail (format nil "~s must be a string or pathname" path))))
+  (if (gethash (pathname-type path) gfg:*image-file-types*)
+    (let ((plugin (make-instance 'magick-data-plugin)))
+      (gfg:load plugin path)
+      plugin)
+    nil))
+
+(push #'accepts-file-p gfg::*image-plugins*)
+
+(defmethod gfg:data->image ((self magick-data-plugin))
+  "Convert the image-data object to a bitmap and return the native handle."
+  (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
+    (cffi:with-foreign-slots ((gfs::bisize
+                               gfs::biwidth
+                               gfs::biheight
+                               gfs::biplanes
+                               gfs::bibitcount
+                               gfs::bicompression
+                               gfs::bisizeimage
+                               gfs::bixpels
+                               gfs::biypels
+                               gfs::biclrused
+                               gfs::biclrimp
+                               gfs::bmicolors)
+                              bi-ptr gfs::bitmapinfo)
+      (let* ((handle (gfs:handle self))
+             (sz (gfg:size self))
+             (pix-count (* (gfs:size-width sz) (gfs:size-height sz)))
+             (hbmp (cffi:null-pointer))
+             (screen-dc (gfs::get-dc (cffi:null-pointer))))
+        (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader)
+              gfs::biwidth (gfs:size-width sz)
+              gfs::biheight (- 0 (gfs:size-height sz))
+              gfs::biplanes 1
+              gfs::bibitcount 32   ;; 32bpp even if original image file is not
+              gfs::bicompression gfs::+bi-rgb+
+              gfs::bisizeimage 0
+              gfs::bixpels 0
+              gfs::biypels 0
+              gfs::biclrused 0
+              gfs::biclrimp 0)
+
+        ;; create the bitmap
+        ;;
+        (cffi:with-foreign-object (pix-bits-ptr :pointer)
+          (setf hbmp (gfs::create-dib-section screen-dc
+                                              bi-ptr
+                                              gfs::+dib-rgb-colors+
+                                              pix-bits-ptr
+                                              (cffi:null-pointer)
+                                              0))
+          (if (gfs:null-handle-p hbmp)
+            (error 'gfs:win32-error :detail "create-dib-section failed"))
+
+          ;; update the RGBQUADs
+          ;;
+          (let ((tmp (get-image-pixels handle 0 0 (gfs:size-width sz) (gfs:size-height sz)))
+                (ptr (cffi:mem-ref pix-bits-ptr :pointer)))
+            (dotimes (i pix-count)
+              (cffi:with-foreign-slots ((blue green red reserved)
+                                        (cffi:mem-aref tmp 'pixel-packet i)
+                                        pixel-packet)
+                (cffi:with-foreign-slots ((gfs::rgbred gfs::rgbgreen gfs::rgbblue gfs::rgbreserved)
+                                          (cffi:mem-aref ptr 'gfs::rgbquad i) gfs::rgbquad)
+                  (setf gfs::rgbreserved 0)
+                  (setf gfs::rgbred (scale-quantum-to-byte red))
+                  (setf gfs::rgbgreen (scale-quantum-to-byte green))
+                  (setf gfs::rgbblue (scale-quantum-to-byte blue)))))))
+        (unless (gfs:null-handle-p screen-dc)
+          (gfs::release-dc (cffi:null-pointer) screen-dc))
+        hbmp))))
+
+(defmethod gfg:depth ((self magick-data-plugin))
+  (let ((handle (gfs:handle self)))
+    (if (null handle)
+      (error 'gfs:disposed-error))
+    (cffi:foreign-slot-value handle 'magick-image 'depth)))
+
+(defmethod gfs:dispose ((self magick-data-plugin))
+  (let ((victim (gfs:handle self)))
+    (unless (or (null victim) (cffi:null-pointer-p victim))
+      (destroy-image victim)))
+  (setf (slot-value self 'gfs:handle) (cffi:null-pointer)))
+
+(defmethod gfg:load ((self magick-data-plugin) path)
+  (let ((handle (gfs:handle self)))
+    (when (and handle (not (cffi:null-pointer-p handle)))
+      (destroy-image handle)
+      (setf (slot-value self 'gfs:handle) nil)
+      (setf handle nil))
+    (with-image-path (path info ex)
+      (setf handle (read-image info ex))
+      (if (not (eql (cffi:foreign-slot-value ex 'exception-info 'severity) :undefined))
+        (error 'gfs:toolkit-error :detail (format nil
+                                                  "exception reason: ~s"
+                                                  (cffi:foreign-slot-value ex 'exception-info 'reason))))
+      (if (cffi:null-pointer-p handle)
+        (error 'gfs:toolkit-error :detail (format nil "could not load image: ~a" path)))
+      (setf (slot-value self 'gfs:handle) handle))))
+
+(defmethod gfg:size ((self magick-data-plugin))
+  (let ((handle (gfs:handle self))
+        (size (gfs:make-size)))
+    (if (or (null handle) (cffi:null-pointer-p handle))
+      (error 'gfs:disposed-error))
+    (cffi:with-foreign-slots ((rows columns) handle magick-image)
+      (setf (gfs:size-height size) rows)
+      (setf (gfs:size-width size) columns))
+    size))
+
+(defmethod (setf gfg:size) (size (self magick-data-plugin))
+  (let ((handle (gfs:handle self))
+        (new-handle (cffi:null-pointer))
+        (ex (acquire-exception-info)))
+    (if (or (null handle) (cffi:null-pointer-p handle))
+      (error 'gfs:disposed-error))
+    (unwind-protect
+        (progn
+          (setf new-handle (resize-image handle
+                                         (gfs:size-width size)
+                                         (gfs:size-height size)
+                                         (cffi:foreign-enum-value 'filter-types :lanczos)
+                                         1.0 ex))
+          (if (gfs:null-handle-p new-handle)
+            (error 'gfs:toolkit-error :detail (format nil
+                                                      "could not resize: ~a"
+                                                      (cffi:foreign-slot-value ex
+                                                                               'exception-info
+                                                                               'reason))))
+          (setf (slot-value self 'gfs:handle) new-handle)
+          (destroy-image handle))
+      (destroy-exception-info ex))))

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Mon Jul 17 00:48:13 2006
@@ -38,7 +38,6 @@
    (child-visitor-results     :initform nil :accessor child-visitor-results)
    (display-visitor-func      :initform nil :accessor display-visitor-func)
    (display-visitor-results   :initform nil :accessor display-visitor-results)
-   (image-loaders-by-type     :initform (make-hash-table :test #'equal))
    (job-table                 :initform (make-hash-table :test #'equal))
    (job-table-lock            :initform nil)
    (event-time                :initform 0 :accessor event-time)

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Mon Jul 17 00:48:13 2006
@@ -81,13 +81,11 @@
 
 #+clisp (defun startup (thread-name start-fn)
           (declare (ignore thread-name))
-          (gfg::initialize-magick (cffi:null-pointer))
           (funcall start-fn)
           (message-loop #'default-message-filter))
 
 #+lispworks (defun startup (thread-name start-fn)
               (hcl:add-special-free-action 'gfs::native-object-special-action)
-              (gfg::initialize-magick (cffi:null-pointer))
               (when (null (mp:list-all-processes))
                 (mp:initialize-multiprocessing))
               (mp:process-run-function thread-name
@@ -97,7 +95,6 @@
                                          (message-loop #'default-message-filter))))
 
 (defun shutdown (exit-code)
-  (gfg::destroy-magick)
   (gfs::post-quit-message exit-code))
 
 (defun initialize-comctl-classes (icc-flags)