Author: junrue Date: Fri Mar 24 02:37:39 2006 New Revision: 69 Added: trunk/src/uitoolkit/widgets/display.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: formalized concepts of 'parent' vs. 'owner' and implemented associated functions and classes; implemented display class representing the monitor and provided access function; modified windlg test program to place the borderless window centered within the main window client area Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Mar 24 02:37:39 2006 @@ -186,6 +186,19 @@ @ref{widget}. @end deftp +@anchor{display} +@deftp Class display primary +Instances of this class describe characteristics of monitors attached +to the system. Applications may call @ref{obtain-displays} to get a +list of all @code{display}s (more than one if the system has multiple +monitors), or @ref{obtain-primary-display} to get the primary. It +derives from @ref{native-object}. +@deffn Reader primary-p +Returns T if the system regards this display as the primary +display; nil otherwise. +@end deffn +@end deftp + @anchor{event-dispatcher} @deftp Class event-dispatcher This is the base class of objects responsible for processing events on @@ -197,10 +210,17 @@ @anchor{event-source} @deftp Class event-source 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}. +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}. +@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-*} +method (e.g., @ref{event-select}) and the @code{CDR} is a function +pointer. As such, this constitutes a specification for a new +@ref{event-dispatcher} class and associated methods. +@end deffn @deffn Initarg :dispatcher @end deffn @deffn Accessor dispatcher @@ -208,8 +228,10 @@ @end deftp @anchor{item} -@deftp Class item -The item class is the base class for all non-windowed user interface objects. +@deftp Class item item-id +The @code{item} class is the base class for all non-windowed user +interface objects serving as subcomponents of a +@ref{widget-with-items} object. It derives from @ref{event-source}. @deffn Initarg :item-id @end deffn @deffn Accessor item-id @@ -221,6 +243,7 @@ display a string or image. @end deftp +@anchor{menu} @deftp Class menu The menu class represents a container for menu items and submenus. It derives from @ref{widget-with-items}. @@ -230,14 +253,38 @@ A subclass of @ref{item} representing a menu item. @end deftp +@anchor{panel} @deftp Class panel -Base class for @ref{window}s that are children of @ref{top-level} @ref{window}s (or -other panels). +Base class for @ref{window}s that are children of @ref{top-level} +@ref{window}s (or other panels). +@end deftp + +@anchor{root-window} +@deftp Class root-window +This class encapsulates the root of the desktop window hierarchy. Note +that applications may create multiple instances that are not +@code{eq}, yet all such instances will have the same underlying +handle, so they in fact refer to the same native object. Operations +on the root @ref{window} are somewhat constrained, therefore not all +functions normally implemented for other @ref{window} types are +available for this @ref{window} type. If an application attempts to +set @code{root-window} as the @ref{owner} of a dialog or +@ref{top-level}, a @ref{toolkit-error} will be thrown. +In a reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation @end deftp @deftp Class timer -A timer is a non-windowed object that generates events at a regular (adjustable) frequency. -It derives from @ref{event-source}. +A timer is a non-windowed object that generates events at a regular +(adjustable) frequency. It derives from @ref{event-source}. @deffn Reader id-of @end deffn @deffn Initarg :initial-delay @@ -353,7 +400,8 @@ @end deffn @deffn GenericFunction event-move dispatcher widget time point -Implement this to respond to an object being moved within its parent's coordinate system. +Implement this to respond to an object being moved within its parent's +coordinate system. @end deffn @anchor{event-paint} @@ -365,6 +413,7 @@ Implement this to respond to an object being resized. @end deffn +@anchor{event-select} @deffn GenericFunction event-select dispatcher item time rect Implement this to respond to an object (or item within) being selected. @end deffn @@ -385,139 +434,225 @@ Returns T if ancestor is an ancestor of descendant; nil otherwise. @end deffn -@deffn GenericFunction append-item object text image dispatcher -Adds the new item with the specified text to the object, and returns the newly-created item. +@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. @end deffn -@deffn GenericFunction append-submenu object text submenu dispatcher +@deffn GenericFunction append-submenu self text submenu dispatcher Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn -@deffn GenericFunction check object flag +@anchor{center-on-owner} +@deffn GenericFunction center-on-owner self +Position @code{self} such that it is centrally located relative to its +@ref{owner}, based on @code{self}'s current outermost size. +See also @ref{center-on-parent}. +@end deffn + +@anchor{center-on-parent} +@deffn GenericFunction center-on-parent self +Position @code{self} such that it is centrally located relative to its +@ref{parent}, based on @code{self}'s current outermost size. +See also @ref{center-on-owner}. +@end deffn + +@deffn GenericFunction check self flag Sets the object into the checked state. @end deffn -@deffn GenericFunction checked-p object +@deffn GenericFunction checked-p self Returns T if the object is in the checked state; nil otherwise. @end deffn -@deffn GenericFunction clear-item object index +@deffn GenericFunction clear-item self index Clears the item at the zero-based index. @end deffn -@deffn GenericFunction clear-span object sp +@deffn GenericFunction clear-span self sp Clears the items whose zero-based indices lie within the specified span. @end deffn -@deffn GenericFunction client-size object -Returns a size object that describes the region of the object that can be drawn within or can display data. +@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. @end deffn -@deffn GenericFunction compute-style-flags object &rest style -Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports. +@deffn GenericFunction compute-style-flags self &rest style +Convert a list of keyword symbols to a pair of native bitmasks; the +first conveys normal/standard flags, whereas the second any extended +flags that the system supports. @end deffn -@deffn GenericFunction compute-outer-size object desired-client-size -Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim. +@deffn GenericFunction compute-outer-size self desired-client-size +Return a size object describing the dimensions of the area required to +enclose the specified desired client area and this object's trim. @end deffn -@deffn GenericFunction display-to-object object pnt -Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system. +@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. @end deffn -@deffn GenericFunction enable object flag -Enables or disables the object, causing it to be redrawn with its default look and allows it to be selected. +@deffn GenericFunction enable self flag +Enables or disables the object, causing it to be redrawn with its +default look and allows it to be selected. @end deffn -@deffn GenericFunction enable-layout object flag +@deffn GenericFunction enable-layout self flag Cause the object to allow or disallow layout management. @end deffn -@deffn GenericFunction enabled-p object +@deffn GenericFunction enabled-p self Returns T if the object is enabled; nil otherwise. @end deffn -@deffn GenericFunction item-at object index +@deffn GenericFunction item-at self index Return the item at the given zero-based index from the object. @end deffn -@deffn GenericFunction item-count object +@deffn GenericFunction item-count self Return the number of items possessed by the object. @end deffn -@deffn GenericFunction item-index object item +@deffn GenericFunction item-index self item Return the zero-based index of the location of the other object in this object. @end deffn -@deffn GenericFunction item-owner item -Return the widget containing this item. -@end deffn - -@deffn GenericFunction layout object +@deffn GenericFunction layout self Set the size and location of this object's children. @end deffn -@deffn GenericFunction location object -Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system. +@deffn GenericFunction location self +Returns a point object describing the coordinates of the top-left +corner of the object in its parent's coordinate system. @xref{parent}. @end deffn -@deffn GenericFunction menu-bar object +@deffn GenericFunction menu-bar self Returns the menu object serving as the menubar for this object. @end deffn -@deffn GenericFunction object-to-display object pnt -Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates. +@deffn GenericFunction object-to-display self pnt +Return a point that is the result of transforming the specified point +from this object's coordinate system to display-relative coordinates. +@end deffn + +@anchor{obtain-displays} +@deffn Function obtain-displays +Returns a list of @ref{display} objects, each of which describes +a monitor attached to the system. The system specifies that one +of these is the primary @ref{display}. +@end deffn + +@anchor{obtain-primary-display} +@deffn Function obtain-primary-display +Return a @ref{display} object that is regarded by the system as +being the primary. +@end deffn + +@anchor{owner} +@deffn GenericFunction owner self +Returns the @code{owner} of @code{self}, which may be different from +@code{self}'s @ref{parent} because the window ownership hierarchy +includes the relationships between physically separate +@ref{top-level}s and dialogs. And it is possible for a window to be +unowned but still have a @ref{parent}. Consequently, calling +@ref{parent} on a @ref{top-level} will return an instance of +@ref{root-window}, but calling @ref{owner} may return @code{nil}. In +a reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation @end deffn @anchor{pack} -@deffn GenericFunction pack object -Causes the object to be resized to its preferred size. +@deffn GenericFunction pack self +Causes @code{self} to be resized to its preferred @ref{size}. @end deffn -@deffn GenericFunction parent object -Returns the object's parent. +@anchor{parent} +@deffn GenericFunction parent self +Returns the @code{parent} of @code{self}. In the case of @ref{panel}s +and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or +@ref{top-level} window. In the case of a dialog or @ref{top-level}, +then a @ref{root-window} is returned. In the case of a @code{submenu}, +this will be the @ref{menu}'s ancestor in the hierarchy; but for a +menubar or context @ref{menu}, @code{parent} returns @code{nil}. In a +reply to an entry at +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, +Raymond Chen says: +@quotation +An owned window is not a child window. Disabling a parent also +disables children, but it does NOT disable owned windows. + +The desktop is the parent of all top-level windows, so disabling the +desktop disables everybody. The desktop is special that way. +@end quotation +@end deffn + +@deffn GenericFunction preferred-size self width-hint height-hint +Implement this function to return @code{self}'s preferred @ref{size}; +that is, the dimensions that @code{self} computes as being the best +fit for itself and/or its children. If one or both of +@code{width-hint} and @code{height-hint} are positive, then each such +parameter is used as a constraint on the @ref{size} calculation -- if +for example @code{width-hint} is some positive value, then @code{self} +must determine how tall it would be given that width. @end deffn -@deffn GenericFunction preferred-size object width-hint height-hint -Returns a size object representing the object's 'preferred' size. -@end deffn - -@deffn GenericFunction redraw object +@deffn GenericFunction redraw self Causes the entire bounds of the object to be marked as needing to be redrawn @end deffn -@deffn GenericFunction running-p object +@deffn GenericFunction running-p self Returns T if the object is in event generation mode; nil otherwise. @end deffn -@deffn GenericFunction show object flag -Causes the object to be visible or hidden on the screen, but not necessarily top-most in the display z-order. +@deffn GenericFunction show self flag +Causes the object to be visible or hidden on the screen, but not +necessarily top-most in the display z-order. @end deffn -@deffn GenericFunction size object -Returns a size object describing the size of the object in its parent's coordinate system. +@deffn GenericFunction size self +Returns a size object describing the size of the object in its +parent's coordinate system. @end deffn -@deffn GenericFunction start object +@deffn GenericFunction start self Enable event generation at regular intervals. @end deffn -@deffn GenericFunction stop object +@deffn GenericFunction stop self Stop producing events. @end deffn -@deffn GenericFunction text object +@deffn GenericFunction text self Returns the object's text. @end deffn -@deffn GenericFunction update object -Forces all outstanding paint requests for the object to be processed before this function returns. +@deffn GenericFunction update self +Forces all outstanding paint requests for the object to be processed +before this function returns. @end deffn -@deffn GenericFunction visible-p object +@deffn GenericFunction visible-p self Returns T if the object is visible (not necessarily top-most); nil otherwise. @end deffn +@html +@deffn GenericFunction window->display self +Return the @ref{display} object representing the monitor that is nearest +to @code{self}. The @ref{rectangle} bounding @code{self} is not required +to intersect the returned @ref{display}. +@end deffn +@end html + @node layout functions @section layout functions @@ -578,46 +713,49 @@ in future releases, they just aren't all documented or implemented at this time. -@deffn GenericFunction background-color object +@deffn GenericFunction background-color self Returns a color object corresponding to the current background color. @end deffn -@deffn GenericFunction data-obj object +@deffn GenericFunction data-obj self Returns the data structure representing the raw form of the object. @end deffn -@deffn GenericFunction depth object +@deffn GenericFunction depth self Returns the bits-per-pixel depth of the object. @end deffn -@deffn GenericFunction draw-filled-rectangle object rect +@deffn GenericFunction draw-filled-rectangle self rect Fills the interior of the rectangle in the current background color. @end deffn -@deffn GenericFunction draw-image object im pnt +@deffn GenericFunction draw-image self im pnt Draws the given image in the receiver at the specified coordinates. @end deffn -@deffn GenericFunction draw-text object text pnt -Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string. +@deffn GenericFunction draw-text self text pnt +Draws the given string in the current font and foreground color, with +(x, y) being the top-left coordinate of a bounding box for the string. @end deffn -@deffn GenericFunction font object +@deffn GenericFunction font self Returns the current font. @end deffn -@deffn GenericFunction foreground-color object +@deffn GenericFunction foreground-color self Returns a color object corresponding to the current foreground color. @end deffn -@deffn GenericFunction metrics object +@deffn GenericFunction metrics self Returns a metrics object describing key attributes of the specified object. @end deffn -@deffn GenericFunction size object +@deffn GenericFunction size self Returns a size object describing the size of the object. @end deffn -@deffn GenericFunction transparency-mask object -Returns an image object that will serve as the transparency mask for the original image, based on the original image's assigned transparency. +@deffn GenericFunction transparency-mask self +Returns an image object that will serve as the transparency mask for +the original image, based on the original image's assigned +transparency. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Mar 24 02:37:39 2006 @@ -88,6 +88,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") + (:file "display") (:file "event-source") (:file "widget-utils") (:file "timer") @@ -102,6 +103,7 @@ (:file "menu-language") (:file "event") (:file "window") + (:file "root-window") (:file "top-level") (:file "panel") (:file "layout") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Mar 24 02:37:39 2006 @@ -198,6 +198,7 @@ #:button #:caret #:control + #:display #:event-dispatcher #:event-source #:flow-layout @@ -206,6 +207,7 @@ #:menu #:menu-item #:panel + #:root-window #:timer #:top-level #:widget @@ -292,6 +294,8 @@ #:border-width #:bottom-margin-of #:caret + #:center-on-owner + #:center-on-parent #:check #:check-all #:checked-p @@ -400,12 +404,16 @@ #:move-below #:moveable-p #:object-to-display + #:obtain-displays + #:obtain-primary-display + #:owner #:pack #:page-increment #:parent #:paste #:peer #:preferred-size + #:primary-p #:redraw #:redrawing-p #:remove-all Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Mar 24 02:37:39 2006 @@ -69,8 +69,8 @@ (let ((window (make-instance 'gfw:top-level :dispatcher (make-instance 'test-borderless-events) :owner *main-win* :style '(:style-borderless)))) - (setf (gfw:location window) (gfs:make-point :x 400 :y 250)) (setf (gfw:size window) (gfs:make-size :width 300 :height 250)) + (gfw:center-on-owner window) (gfw:show window t))) (defun create-miniframe-win (disp item time rect) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Mar 24 02:37:39 2006 @@ -92,6 +92,8 @@ (defconstant +cbm-init+ #x04) +(defconstant +cchdevicename+ 32) + (defconstant +color-scrollbar+ 0) (defconstant +color-background+ 1) (defconstant +color-activecaption+ 2) @@ -279,6 +281,12 @@ (defconstant +mns-notifybypos+ #x08000000) (defconstant +mns-checkorbmp+ #x04000000) +(defconstant +monitor-defaulttonull+ #x00000000) +(defconstant +monitor-defaulttoprimary+ #x00000001) +(defconstant +monitor-defaulttonearest+ #x00000002) + +(defconstant +monitorinfoof-primary+ #x00000001) + (defconstant +obm-lfarrowi+ 32734) (defconstant +obm-rgarrowi+ 32735) (defconstant +obm-dnarrowi+ 32736) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Fri Mar 24 02:37:39 2006 @@ -65,6 +65,7 @@ (defctype LPVOID :long) (defctype LRESULT :unsigned-long) (defctype SHORT :unsigned-short) +(defctype TCHAR :char) (defctype UINT :unsigned-int) (defctype ULONG :unsigned-long) (defctype WORD :short) @@ -165,6 +166,13 @@ (right LONG) (bottom LONG)) +(defcstruct monitorinfoex + (cbsize UINT) + (monitor rect) + (work rect) + (flags DWORD) + (device TCHAR :count 32)) ; CCHDEVICENAME + (defcstruct rgbquad (rgbblue BYTE) (rgbgreen BYTE) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Fri Mar 24 02:37:39 2006 @@ -187,6 +187,47 @@ (lparam ffi:long)) (:return-type ffi:int)) +;;; FIXME: uncomment this when CFFI callbacks can +;;; be tagged as stdcall or cdecl (only the latter +;;; is supported as of 0.9.0) +;;; +#| +(defcfun + ("EnumDisplayMonitors" enum-display-monitors) + BOOL + (hdc HANDLE) + (cliprect LPTR) + (enumproc LPTR) + (data LPARAM)) +|# + +#+lispworks +(fli:define-foreign-function + (enum-display-monitors "EnumDisplayMonitors") + ((hdc :pointer) + (cliprect :pointer) + (enumproc :pointer) + (data :long)) + :result-type :int) + +#+clisp +(ffi:def-call-out enum-display-monitors + (:name "EnumDisplayMonitors") + (:library "user32.dll") + (:language :stdc) + (:arguments (hdc ffi:c-pointer) + (cliprect ffi:c-pointer) + (func (ffi:c-function + (:arguments + (hmonitor ffi:c-pointer) + (hdc ffi:c-pointer) + (monitorrect ffi:c-pointer) + (data ffi:long)) + (:return-type ffi:int) + (:language :stdc-stdcall))) + (data ffi:c-pointer)) + (:return-type ffi:int)) + (defcfun ("GetAncestor" get-ancestor) HANDLE @@ -229,6 +270,10 @@ (hwnd HANDLE)) (defcfun + ("GetDesktopWindow" get-desktop-window) + HANDLE) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT)) @@ -261,6 +306,17 @@ (filter-max UINT)) (defcfun + ("GetMonitorInfoA" get-monitor-info) + BOOL + (hmonitor HANDLE) + (monitor-info LPTR)) + +(defcfun + ("GetParent" get-parent) + HANDLE + (hwnd HANDLE)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -349,6 +405,12 @@ (type UINT)) (defcfun + ("MonitorFromWindow" monitor-from-window) + HANDLE + (hwnd HANDLE) + (flags DWORD)) + +(defcfun ("PeekMessageA" peek-message) BOOL (msg LPTR) Added: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/display.lisp Fri Mar 24 02:37:39 2006 @@ -0,0 +1,133 @@ +;;;; +;;;; display.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) + +;;; +;;; helper functions +;;; + +#+lispworks +(fli:define-foreign-callable + ("display_visitor" :result-type :integer :calling-convention :stdcall) + ((hmonitor :pointer) + (hdc :pointer) + (monitorrect :pointer) + (data :long)) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +#+clisp +(defun display_visitor (hmonitor hdc monitorrect data) + (declare (ignore hdc monitorrect)) + (call-display-visitor-func (thread-context) hmonitor data) + 1) + +(defun visit-displays (func) + ;; + ;; supplied closure should expect three parameters: + ;; display handle + ;; flag data + ;; + (let ((tc (thread-context))) + (setf (display-visitor-func tc) func) + (unwind-protect +#+lispworks (let ((ptr (fli:make-pointer :address 0))) + (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) +#+clisp (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) + (gfs::enum-display-monitors ptr ptr #'display_visitor 0)) + (setf (display-visitor-func tc) nil))) + nil) + +(defun obtain-displays () + (let ((display-list nil)) + (visit-displays #'(lambda (hmonitor data) + (let ((pflag (= (logand data gfs::+monitorinfoof-primary+) + gfs::+monitorinfoof-primary+)) + (display (make-instance 'display :handle hmonitor))) + (setf (slot-value display 'primary) pflag) + (push display display-list)))) + display-list)) + +(defun obtain-primary-display () + (find-if #'primary-p (obtain-displays))) + +;;; +;;; methods +;;; + +(defmethod client-size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::work) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::work))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod gfs:dispose ((self display)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod size ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((size (gfs::make-size))) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor))) + (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom) + rect-ptr gfs::rect) + (setf (gfs:size-width size) (- gfs::right gfs::left)) + (setf (gfs:size-height size) (- gfs::bottom gfs::top)))))) + size)) + +(defmethod text ((self display)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (let ((name "")) + (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::device) + mi-ptr gfs::monitorinfoex) + (gfs::get-monitor-info (gfs:handle self) mi-ptr) + (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device))) + (setf name (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)))))) + name)) Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Fri Mar 24 02:37:39 2006 @@ -65,11 +65,19 @@ :specializers (make-specializer-list class arg-info)))) class)) -(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) - "The :callbacks parameter specifies an association list where the CAR is the \ -name of an event-* method (e.g., event-select) and the CDR is a function \ -pointer. As such, this constitutes a specification for a new event-dispatcher \ -object and associated methods." +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) (unless (null callbacks) (let ((class (define-dispatcher callbacks))) - (setf (dispatcher src) (make-instance (class-name class)))))) + (setf (dispatcher self) (make-instance (class-name class)))))) + +(defmethod owner :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod parent :before ((self event-source)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Fri Mar 24 02:37:39 2006 @@ -198,7 +198,7 @@ (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) (let ((id (item-id it)) - (owner (item-owner it))) + (owner (owner it))) (unless (null owner) (gfs::remove-menu (gfs:handle owner) id gfs::+mf-bycommand+) (let* ((index (item-index owner it)) @@ -220,7 +220,7 @@ gfs::+mfs-enabled+) gfs::+mfs-enabled+)) -(defmethod item-owner ((it menu-item)) +(defmethod owner ((it menu-item)) (let ((hmenu (gfs:handle it))) (if (gfs:null-handle-p hmenu) (error 'gfs:toolkit-error :detail "null owner menu handle")) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Fri Mar 24 02:37:39 2006 @@ -49,7 +49,7 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win panel) &rest style) +(defmethod compute-style-flags ((self panel) &rest style) (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)) (ex-flags 0)) (mapc #'(lambda (sym) @@ -61,11 +61,11 @@ (flatten style)) (values std-flags ex-flags))) -(defmethod initialize-instance :after ((win panel) &key parent style &allow-other-keys) +(defmethod initialize-instance :after ((self panel) &key parent style &allow-other-keys) (if (null parent) (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) (if (not (listp style)) (setf style (list style))) - (init-window win +panel-window-classname+ #'register-panel-window-class style parent "")) + (init-window self +panel-window-classname+ #'register-panel-window-class style parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Mar 24 02:37:39 2006 @@ -35,6 +35,7 @@ (defclass thread-context () ((child-visitor-stack :initform nil) + (display-visitor-func :initform nil :accessor display-visitor-func) (image-loaders-by-type :initform (make-hash-table :test #'equal)) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) @@ -88,6 +89,11 @@ "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty." (pop (slot-value tc 'child-visitor-stack))) +(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) + (let ((func (display-visitor-func tc))) + (unless (null func) + (funcall func hmonitor data)))) + (defmethod get-widget ((tc thread-context) hwnd) "Return the widget object corresponding to the specified native window handle." (let ((tmp-widget (slot-value tc 'wip))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Mar 24 02:37:39 2006 @@ -33,6 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) +(defclass display (gfs:native-object) + ((primary + :reader primary-p + :initform nil)) + (:documentation "Instances of this class describe characteristics of monitors attached to the system.")) + (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) @@ -91,6 +97,9 @@ (defclass panel (window) () (:documentation "Base class for windows that are children of top-level windows (or other panels).")) +(defclass root-window (window) () + (:documentation "This class encapsulates the root of the desktop window hierarchy.")) + (defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars.")) Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Mar 24 02:37:39 2006 @@ -33,344 +33,353 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric accelerator (object) +(defgeneric accelerator (self) (:documentation "Returns a bitmask indicating the key and any modifiers corresponding to the accelerator set for this object.")) -(defgeneric activate (object) +(defgeneric activate (self) (:documentation "If the object is visible, move it to the top of the display z-order and request the window manager to set it active.")) -(defgeneric alignment (object) +(defgeneric alignment (self) (:documentation "Returns a keyword symbol describing the position of internal content within the object.")) (defgeneric ancestor-p (ancestor descendant) (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise.")) -(defgeneric append-item (object text image dispatcher) +(defgeneric append-item (self text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item.")) -(defgeneric append-submenu (object text submenu dispatcher) +(defgeneric append-submenu (self text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item.")) -(defgeneric background-color (object) +(defgeneric background-color (self) (:documentation "Returns a color object corresponding to the current background color.")) -(defgeneric border-width (object) +(defgeneric border-width (self) (:documentation "Returns the object's border width.")) -(defgeneric caret (object) +(defgeneric caret (self) (:documentation "Returns the object's caret.")) -(defgeneric caret-position (object) +(defgeneric caret-position (self) (:documentation "Returns a point describing the line number and character position of the caret.")) -(defgeneric check (object flag) +(defgeneric center-on-owner (self) + (:documentation "Position self such that it is centrally located relative to its owner.")) + +(defgeneric center-on-parent (self) + (:documentation "Position self such that it is centrally located relative to its parent.")) + +(defgeneric check (self flag) (:documentation "Sets the object into the checked state.")) -(defgeneric check-all (object flag) +(defgeneric check-all (self flag) (:documentation "Sets all items in this object to the checked state.")) -(defgeneric checked-p (object) +(defgeneric checked-p (self) (:documentation "Returns T if the object is in the checked state; nil otherwise.")) -(defgeneric clear-item (object index) +(defgeneric clear-item (self index) (:documentation "Clears the item at the zero-based index.")) -(defgeneric clear-selection (object) +(defgeneric clear-selection (self) (:documentation "Sets the object's selection status to empty or not selected.")) -(defgeneric clear-span (object sp) +(defgeneric clear-span (self sp) (:documentation "Clears the items whose zero-based indices lie within the specified span.")) -(defgeneric client-size (object) +(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.")) -(defgeneric column-at (object index) +(defgeneric column-at (self index) (:documentation "Returns the column object at the zero-based index.")) -(defgeneric column-count (object) +(defgeneric column-count (self) (:documentation "Returns the number of columns displayed by the object.")) -(defgeneric column-index (object col) +(defgeneric column-index (self col) (:documentation "Return the zero-based index of the location of the column in this object.")) -(defgeneric column-order (object) +(defgeneric column-order (self) (:documentation "Returns a list of zero-based indices, each of whose positions represents the column creation order and whose element value represents the current column order.")) -(defgeneric columns (object) +(defgeneric columns (self) (:documentation "Returns the column objects displayed by the object.")) -(defgeneric compute-style-flags (object &rest style) +(defgeneric compute-style-flags (self &rest style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports.")) -(defgeneric compute-outer-size (object desired-client-size) +(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 (object) +(defgeneric copy (self) (:documentation "Copies the current selection to the clipboard.")) -(defgeneric cursor (object) +(defgeneric cursor (self) (:documentation "Returns the cursor object associated with this object.")) -(defgeneric cut (object) +(defgeneric cut (self) (:documentation "Copies the current selection to the clipboard and removes it from the object.")) -(defgeneric default-item (object) +(defgeneric default-item (self) (:documentation "Returns the item in this object that has the default emphasis.")) -(defgeneric disabled-image (object) +(defgeneric disabled-image (self) (:documentation "Returns the image used to render this item with a disabled look.")) -(defgeneric display-to-object (object pnt) +(defgeneric display-to-object (self pnt) (:documentation "Return a point that is the result of transforming the specified point from display-relative coordinates to this object's coordinate system.")) -(defgeneric echo-char (object) +(defgeneric echo-char (self) (:documentation "Returns the character that will be displayed when the user types text, or nil if no echo character has been set.")) -(defgeneric enable (object flag) +(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-layout (object flag) +(defgeneric enable-layout (self flag) (:documentation "Cause the object to allow or disallow layout management.")) -(defgeneric enable-redraw (object flag) +(defgeneric enable-redraw (self flag) (:documentation "Cause the object to resume or suspend painting.")) -(defgeneric enabled-p (object) +(defgeneric enabled-p (self) (:documentation "Returns T if the object is enabled; nil otherwise.")) -(defgeneric expand (object deep flag) +(defgeneric expand (self deep flag) (:documentation "Set the object (and optionally it's children) to the expanded or collapsed state.")) -(defgeneric expanded-p (object) +(defgeneric expanded-p (self) (:documentation "Returns T if the object is in the expanded state; nil otherwise.")) -(defgeneric focus-index (object) +(defgeneric focus-index (self) (:documentation "Return a zero-based index of the object's sub-item that has focus; nil otherwise.")) -(defgeneric focus-p (object) +(defgeneric focus-p (self) (:documentation "Returns T if this object has the keyboard focus; nil otherwise.")) -(defgeneric foreground-color (object) +(defgeneric foreground-color (self) (:documentation "Returns a color object corresponding to the current foreground color.")) -(defgeneric give-focus (object) +(defgeneric give-focus (self) (:documentation "Causes this object to have the keyboard focus.")) -(defgeneric grid-line-width (object) +(defgeneric grid-line-width (self) (:documentation "Returns the width of a grid line.")) -(defgeneric header-height (object) +(defgeneric header-height (self) (:documentation "Returns the height of the item's header.")) -(defgeneric header-visible-p (object) +(defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (object) +(defgeneric horizontal-scrollbar (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) -(defgeneric iconify (object flag) +(defgeneric iconify (self flag) (:documentation "Set the object to the iconified or restored state.")) -(defgeneric iconified-p (object) +(defgeneric iconified-p (self) (:documentation "Returns T if the object is in its iconified state.")) -(defgeneric image (object) +(defgeneric image (self) (:documentation "Returns the object's image object if it has one, or nil otherwise.")) -(defgeneric item-at (object index) +(defgeneric item-at (self index) (:documentation "Return the item at the given zero-based index from the object.")) -(defgeneric item-count (object) +(defgeneric item-count (self) (:documentation "Return the number of items possessed by the object.")) -(defgeneric item-height (object) +(defgeneric item-height (self) (:documentation "Return the height of the area if one of the object's items were displayed.")) -(defgeneric item-index (object item) +(defgeneric item-index (self item) (:documentation "Return the zero-based index of the location of the other object in this object.")) -(defgeneric item-owner (item) - (:documentation "Return the widget containing this item.")) - -(defgeneric layout (object) +(defgeneric layout (self) (:documentation "Set the size and location of this object's children.")) -(defgeneric lines-visible-p (object) +(defgeneric lines-visible-p (self) (:documentation "Returns T if the object's lines are visible; nil otherwise.")) -(defgeneric location (object) +(defgeneric location (self) (:documentation "Returns a point object describing the coordinates of the top-left corner of the object in its parent's coordinate system.")) -(defgeneric lock (object flag) +(defgeneric lock (self flag) (:documentation "Prevents or enables modification of the object's contents.")) -(defgeneric locked-p (object) +(defgeneric locked-p (self) (:documentation "Returns T if this object's contents are locked from being modified.")) -(defgeneric maximize (object flag) +(defgeneric maximize (self flag) (:documentation "Set the object (or restore it from) the maximized state (not necessarily the same as the maximum size).")) -(defgeneric maximized-p (object) +(defgeneric maximized-p (self) (:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise.")) -(defgeneric maximum-size (object) +(defgeneric maximum-size (self) (:documentation "Returns a size object describing the largest size this object can exist.")) -(defgeneric menu-bar (object) +(defgeneric menu-bar (self) (:documentation "Returns the menu object serving as the menubar for this object.")) -(defgeneric minimum-size (object) +(defgeneric minimum-size (self) (:documentation "Returns a size object describing the smallest size this object can exist.")) -(defgeneric mouse-over-image (object) +(defgeneric mouse-over-image (self) (:documentation "Returns the image displayed when the mouse is hovering over this object.")) -(defgeneric move-above (object other) +(defgeneric move-above (self other) (:documentation "Moves this object above the other object in the drawing order.")) -(defgeneric move-below (object other) +(defgeneric move-below (self other) (:documentation "Moves this object below the other object in the drawing order.")) -(defgeneric moveable-p (object) +(defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise.")) -(defgeneric object-to-display (object pnt) +(defgeneric object-to-display (self pnt) (:documentation "Return a point that is the result of transforming the specified point from this object's coordinate system to display-relative coordinates.")) -(defgeneric pack (object) +(defgeneric owner (self) + (:documentation "Returns self's owner (which is not necessarily the same as parent).")) + +(defgeneric pack (self) (:documentation "Causes the object to be resized to its preferred size.")) -(defgeneric page-increment (object) +(defgeneric page-increment (self) (:documentation "Return an integer representing the configured page size for the object.")) -(defgeneric parent (object) +(defgeneric parent (self) (:documentation "Returns the object's parent.")) -(defgeneric paste (object) +(defgeneric paste (self) (:documentation "Copies content from the clipboard into the object.")) -(defgeneric peer (object) +(defgeneric peer (self) (:documentation "Returns the visual object associated with this object (not the underlying window system handle).")) -(defgeneric preferred-size (object width-hint height-hint) +(defgeneric preferred-size (self width-hint height-hint) (:documentation "Returns a size object representing the object's 'preferred' size.")) -(defgeneric redraw (object) +(defgeneric redraw (self) (:documentation "Causes the entire bounds of the object to be marked as needing to be redrawn")) -(defgeneric redrawing-p (object) +(defgeneric redrawing-p (self) (:documentation "Returns T if the object is set to allow processing of paint events.")) -(defgeneric remove-all (object) +(defgeneric remove-all (self) (:documentation "Removes all items from the object.")) -(defgeneric remove-item (object index) +(defgeneric remove-item (self index) (:documentation "Removes the item at the zero-based index from the object.")) -(defgeneric remove-span (object sp) +(defgeneric remove-span (self sp) (:documentation "Removes the sequence of items represented by the specified span object.")) -(defgeneric reparentable-p (object) +(defgeneric reparentable-p (self) (:documentation "Returns T if the window system allows this object to be reparented; nil otherwise.")) -(defgeneric replace-selection (object content) +(defgeneric replace-selection (self content) (:documentation "Replaces the content of the current selection with new content.")) -(defgeneric resizable-p (object) +(defgeneric resizable-p (self) (:documentation "Returns T if the object is resizable; nil otherwise.")) -(defgeneric retrieve-span (object) +(defgeneric retrieve-span (self) (:documentation "Returns the span object indicating the range of values that are valid for the object.")) -(defgeneric running-p (object) +(defgeneric running-p (self) (:documentation "Returns T if the object is in event generation mode; nil otherwise.")) -(defgeneric scroll (object dest-pnt src-rect children-too) +(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 (object flag) +(defgeneric select (self flag) (:documentation "Set this object into (or take it out of) the selected state.")) -(defgeneric select-all (object flag) +(defgeneric select-all (self flag) (:documentation "Set all items of this object into (or take them out of) the selected state.")) -(defgeneric selected-p (object) +(defgeneric selected-p (self) (:documentation "Returns T if the object is in the selected state; nil otherwise.")) -(defgeneric selection-count (object) +(defgeneric selection-count (self) (:documentation "Returns the number of this object's items that are selected.")) -(defgeneric selection-index (object) +(defgeneric selection-index (self) (:documentation "Returns the zero-based index of the currently-selected item, or nil if no item is selected.")) -(defgeneric selection-indices (object) +(defgeneric selection-indices (self) (:documentation "Returns a list of zero-based indices identifying the selected items within this object.")) -(defgeneric selection-span (object) +(defgeneric selection-span (self) (:documentation "Returns a span object describing the start and end indices of the object selection.")) -(defgeneric show (object flag) +(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.")) -(defgeneric show-column (object col) +(defgeneric show-column (self col) (:documentation "This object's colums are scrolled until the specified column is visible.")) -(defgeneric show-header (object flag) +(defgeneric show-header (self flag) (:documentation "Causes the object's header to be made visible or hidden.")) -(defgeneric show-item (object index) +(defgeneric show-item (self index) (:documentation "This object's items are scrolled until the specified item is visible.")) -(defgeneric show-lines (object flag) +(defgeneric show-lines (self flag) (:documentation "Causes the object's lines to be made visible or hidden.")) -(defgeneric show-selection (object) +(defgeneric show-selection (self) (:documentation "This object's items are scrolled until the selection is visible.")) -(defgeneric size (object) +(defgeneric size (self) (:documentation "Returns a size object describing the size of the object in its parent's coordinate system.")) -(defgeneric start (object) +(defgeneric start (self) (:documentation "Enable event generation at regular intervals.")) -(defgeneric step-increment (object) +(defgeneric step-increment (self) (:documentation "Return an integer representing the configured step size for the object.")) -(defgeneric stop (object) +(defgeneric stop (self) (:documentation "Stop producing events.")) -(defgeneric text (object) +(defgeneric text (self) (:documentation "Returns the object's text.")) -(defgeneric text-height (object) +(defgeneric text-height (self) (:documentation "Returns the height of the object's text field.")) -(defgeneric text-limit (object) +(defgeneric text-limit (self) (:documentation "Returns the number of characters that the object's text field is capable of holding.")) -(defgeneric thumb-size (object) +(defgeneric thumb-size (self) (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) -(defgeneric tooltip-text (object) +(defgeneric tooltip-text (self) (:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object.")) -(defgeneric top-index (object) +(defgeneric top-index (self) (:documentation "Returns the zero-based index of the item currently at the top of the object.")) -(defgeneric traverse (object arg) +(defgeneric traverse (self arg) (:documentation "Execute a traversal action within this object.")) -(defgeneric traverse-order (object) +(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 update (object) +(defgeneric update (self) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns.")) -(defgeneric vertical-scrollbar (object) +(defgeneric vertical-scrollbar (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) -(defgeneric visible-item-count (object) +(defgeneric visible-item-count (self) (:documentation "Return the number of items that are currently visible in the object.")) -(defgeneric visible-p (object) +(defgeneric visible-p (self) (:documentation "Returns T if the object is visible (not necessarily top-most); nil otherwise.")) + +(defgeneric window->display (self) + (:documentation "Return the display object representing the monitor that is nearest to self.")) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Mar 24 02:37:39 2006 @@ -37,6 +37,31 @@ ;;; helper functions ;;; +(defun centered-coord-inside (ancest-coord ancest-size desc-size) + (+ ancest-coord (floor (- (/ ancest-size 2) (/ desc-size 2))))) + +(defun centered-coord-outside (ancest-coord ancest-size desc-size) + (- ancest-coord (floor (/ (- desc-size ancest-size) 2)))) + +(defun center-object (ancestor descendant) + (let* ((ancest-size (client-size ancestor)) + (ancest-width (gfs:size-width ancest-size)) + (ancest-height (gfs:size-height ancest-size)) + (ancest-pnt (location ancestor)) + (desc-size (size descendant)) + (desc-width (gfs:size-width desc-size)) + (desc-height (gfs:size-height desc-size)) + (new-x 0) + (new-y 0)) + (incf (gfs:point-y ancest-pnt) (- (gfs:size-height (size ancestor)) ancest-height)) + (if (> ancest-width desc-width) + (setf new-x (centered-coord-inside (gfs:point-x ancest-pnt) ancest-width desc-width)) + (setf new-x (centered-coord-outside (gfs:point-x ancest-pnt) ancest-width desc-width))) + (if (> ancest-height desc-height) + (setf new-y (centered-coord-inside (gfs:point-y ancest-pnt) ancest-height desc-height)) + (setf new-y (centered-coord-outside (gfs:point-y ancest-pnt) ancest-height desc-height))) + (setf (location descendant) (gfs:make-point :x new-x :y new-y)))) + ;;; ;;; widget methods ;;; @@ -70,6 +95,23 @@ (return-from border-width (gfs::get-system-metrics gfs::+sm-cxborder+))) 0)) +(defmethod center-on-owner :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-owner ((self widget)) + (let ((owner (owner self))) + (if (null owner) + nil + (center-object owner self)))) + +(defmethod center-on-parent :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod center-on-parent ((self widget)) + (center-object (parent self) self)) + (defmethod checked-p :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -155,6 +197,21 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed"))) +(defmethod owner ((self widget)) + ;; I know the following is confusing, but the docs + ;; for MSDN state that GetParent() returns the owner + ;; when the window in question is a top-level, + ;; whereas for child windows the owner and parent + ;; are the same. + ;; + ;; And since GetParent() can return owners, this + ;; means it can return NULL, too. + ;; + (let ((hwnd (gfs::get-parent (gfs:handle self)))) + (if (gfs:null-handle-p hwnd) + nil + (get-widget (thread-context) hwnd)))) + (defmethod pack :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) @@ -162,6 +219,20 @@ (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1))) +(defmethod parent ((self widget)) + ;; Unlike the owner method, this method should + ;; only return nil if self is the root window, + ;; which is taken care of by a specialization + ;; on root-window (see root-window.lisp). + ;; + (let* ((hwnd (gfs::get-ancestor (gfs:handle self) gfs::+ga-parent+)) + (widget (get-widget (thread-context) hwnd))) + (when (null widget) + (if (cffi:pointer-eq hwnd (gfs::get-desktop-window)) + (setf widget (make-instance 'root-window :handle hwnd)) + (error 'gfs:toolkit-error :detail "no widget for hwnd"))) + widget)) + (defmethod redraw :before ((w widget)) (if (gfs:disposed-p w) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Mar 24 02:37:39 2006 @@ -207,3 +207,13 @@ (let ((sz (gfs:make-size))) (outer-size win sz) sz)) + +(defmethod window->display :before ((self top-level)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod window->display ((self top-level)) + (let* ((hmonitor (gfs::monitor-from-window (gfs:handle self) gfs::+monitor-defaulttonearest+)) + (display (make-instance 'display))) + (setf (slot-value display 'gfs:handle) hmonitor) + display))