[graphic-forms-cvs] r69 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Mar 24 07:37:41 UTC 2006
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
+ at anchor{display}
+ at 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}.
+ at deffn Reader primary-p
+Returns T if the system regards this display as the primary
+display; nil otherwise.
+ at end deffn
+ at 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}.
+ at 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
+ at ref{event-dispatcher} class and associated methods.
+ at end deffn
@deffn Initarg :dispatcher
@end deffn
@deffn Accessor dispatcher
@@ -208,8 +228,10 @@
@end deftp
@anchor{item}
- at deftp Class item
-The item class is the base class for all non-windowed user interface objects.
+ at 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
+ at 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
+ at 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
+ at 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}
+ at ref{window}s (or other panels).
+ at end deftp
+
+ at anchor{root-window}
+ at deftp Class root-window
+This class encapsulates the root of the desktop window hierarchy. Note
+that applications may create multiple instances that are not
+ at 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
+ at ref{top-level}, a @ref{toolkit-error} will be thrown.
+In a reply to an entry at
+ at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx},
+Raymond Chen says:
+ at 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.
+ at 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
+ at 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
- at 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.
+ 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.
@end deffn
- at deffn GenericFunction append-submenu object text submenu dispatcher
+ at deffn GenericFunction append-submenu self text submenu dispatcher
Adds a submenu anchored to a parent menu and returns the corresponding item.
@end deffn
- at deffn GenericFunction check object flag
+ at anchor{center-on-owner}
+ at deffn GenericFunction center-on-owner self
+Position @code{self} such that it is centrally located relative to its
+ at ref{owner}, based on @code{self}'s current outermost size.
+See also @ref{center-on-parent}.
+ at end deffn
+
+ at anchor{center-on-parent}
+ at deffn GenericFunction center-on-parent self
+Position @code{self} such that it is centrally located relative to its
+ at ref{parent}, based on @code{self}'s current outermost size.
+See also @ref{center-on-owner}.
+ at end deffn
+
+ at deffn GenericFunction check self flag
Sets the object into the checked state.
@end deffn
- at deffn GenericFunction checked-p object
+ at deffn GenericFunction checked-p self
Returns T if the object is in the checked state; nil otherwise.
@end deffn
- at deffn GenericFunction clear-item object index
+ at deffn GenericFunction clear-item self index
Clears the item at the zero-based index.
@end deffn
- at deffn GenericFunction clear-span object sp
+ at deffn GenericFunction clear-span self sp
Clears the items whose zero-based indices lie within the specified span.
@end deffn
- at 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.
+ at 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
- at 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.
+ at 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
- at 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.
+ at 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
- at 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.
+ at 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
- at 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.
+ at 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
- at deffn GenericFunction enable-layout object flag
+ at deffn GenericFunction enable-layout self flag
Cause the object to allow or disallow layout management.
@end deffn
- at deffn GenericFunction enabled-p object
+ at deffn GenericFunction enabled-p self
Returns T if the object is enabled; nil otherwise.
@end deffn
- at deffn GenericFunction item-at object index
+ at deffn GenericFunction item-at self index
Return the item at the given zero-based index from the object.
@end deffn
- at deffn GenericFunction item-count object
+ at deffn GenericFunction item-count self
Return the number of items possessed by the object.
@end deffn
- at deffn GenericFunction item-index object item
+ at deffn GenericFunction item-index self item
Return the zero-based index of the location of the other object in this object.
@end deffn
- at deffn GenericFunction item-owner item
-Return the widget containing this item.
- at end deffn
-
- at deffn GenericFunction layout object
+ at deffn GenericFunction layout self
Set the size and location of this object's children.
@end deffn
- at 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.
+ at 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
- at deffn GenericFunction menu-bar object
+ at deffn GenericFunction menu-bar self
Returns the menu object serving as the menubar for this object.
@end deffn
- at 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.
+ at 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.
+ at end deffn
+
+ at anchor{obtain-displays}
+ at 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}.
+ at end deffn
+
+ at anchor{obtain-primary-display}
+ at deffn Function obtain-primary-display
+Return a @ref{display} object that is regarded by the system as
+being the primary.
+ at end deffn
+
+ at anchor{owner}
+ at deffn GenericFunction owner self
+Returns the @code{owner} of @code{self}, which may be different from
+ at code{self}'s @ref{parent} because the window ownership hierarchy
+includes the relationships between physically separate
+ at ref{top-level}s and dialogs. And it is possible for a window to be
+unowned but still have a @ref{parent}. Consequently, calling
+ at ref{parent} on a @ref{top-level} will return an instance of
+ at ref{root-window}, but calling @ref{owner} may return @code{nil}. In
+a reply to an entry at
+ at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx},
+Raymond Chen says:
+ at 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.
+ at end quotation
@end deffn
@anchor{pack}
- at deffn GenericFunction pack object
-Causes the object to be resized to its preferred size.
+ at deffn GenericFunction pack self
+Causes @code{self} to be resized to its preferred @ref{size}.
@end deffn
- at deffn GenericFunction parent object
-Returns the object's parent.
+ at anchor{parent}
+ at 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
+ at 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
+ at url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx},
+Raymond Chen says:
+ at 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.
+ at end quotation
+ at end deffn
+
+ at 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
+ at 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
- at deffn GenericFunction preferred-size object width-hint height-hint
-Returns a size object representing the object's 'preferred' size.
- at end deffn
-
- at deffn GenericFunction redraw object
+ at deffn GenericFunction redraw self
Causes the entire bounds of the object to be marked as needing to be redrawn
@end deffn
- at deffn GenericFunction running-p object
+ at deffn GenericFunction running-p self
Returns T if the object is in event generation mode; nil otherwise.
@end deffn
- at 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.
+ at 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
- at deffn GenericFunction size object
-Returns a size object describing the size of the object in its parent's coordinate system.
+ at deffn GenericFunction size self
+Returns a size object describing the size of the object in its
+parent's coordinate system.
@end deffn
- at deffn GenericFunction start object
+ at deffn GenericFunction start self
Enable event generation at regular intervals.
@end deffn
- at deffn GenericFunction stop object
+ at deffn GenericFunction stop self
Stop producing events.
@end deffn
- at deffn GenericFunction text object
+ at deffn GenericFunction text self
Returns the object's text.
@end deffn
- at deffn GenericFunction update object
-Forces all outstanding paint requests for the object to be processed before this function returns.
+ at deffn GenericFunction update self
+Forces all outstanding paint requests for the object to be processed
+before this function returns.
@end deffn
- at deffn GenericFunction visible-p object
+ at deffn GenericFunction visible-p self
Returns T if the object is visible (not necessarily top-most); nil otherwise.
@end deffn
+ at html
+ at 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}.
+ at end deffn
+ at 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.
- at deffn GenericFunction background-color object
+ at deffn GenericFunction background-color self
Returns a color object corresponding to the current background color.
@end deffn
- at deffn GenericFunction data-obj object
+ at deffn GenericFunction data-obj self
Returns the data structure representing the raw form of the object.
@end deffn
- at deffn GenericFunction depth object
+ at deffn GenericFunction depth self
Returns the bits-per-pixel depth of the object.
@end deffn
- at deffn GenericFunction draw-filled-rectangle object rect
+ at deffn GenericFunction draw-filled-rectangle self rect
Fills the interior of the rectangle in the current background color.
@end deffn
- at deffn GenericFunction draw-image object im pnt
+ at deffn GenericFunction draw-image self im pnt
Draws the given image in the receiver at the specified coordinates.
@end deffn
- at 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.
+ at 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
- at deffn GenericFunction font object
+ at deffn GenericFunction font self
Returns the current font.
@end deffn
- at deffn GenericFunction foreground-color object
+ at deffn GenericFunction foreground-color self
Returns a color object corresponding to the current foreground color.
@end deffn
- at deffn GenericFunction metrics object
+ at deffn GenericFunction metrics self
Returns a metrics object describing key attributes of the specified object.
@end deffn
- at deffn GenericFunction size object
+ at deffn GenericFunction size self
Returns a size object describing the size of the object.
@end deffn
- at 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.
+ at 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))
More information about the Graphic-forms-cvs
mailing list