[graphic-forms-cvs] r95 - in trunk: docs/manual src src/demos/unblocked src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Apr 13 19:14:14 UTC 2006
Author: junrue
Date: Thu Apr 13 15:14:13 2006
New Revision: 95
Modified:
trunk/docs/manual/api.texinfo
trunk/src/demos/unblocked/unblocked-window.lisp
trunk/src/packages.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/system-types.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
implemented maximum-size and minimum-size slots for top-level windows so apps can constrain resizing by the user
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Thu Apr 13 15:14:13 2006
@@ -301,7 +301,15 @@
@deftp Class top-level
Base class for @ref{window}s that are self-contained and parented to
the @ref{root-window}. Except for the @code{:palette} style, they are
-normally resizable have title bars (also called 'captions').
+normally resizable and have title bars (also called 'captions').
+ at deffn Initarg :maximum-size
+Sets the maximum @ref{size} to which the user may adjust the
+boundaries of the window.
+ at end deffn
+ at deffn Initarg :minimum-size
+Sets the minimum @ref{size} to which the user may adjust the
+boundaries of the window.
+ at end deffn
@deffn Initarg :style
The :style initarg is a list of keywords that define the overall
look-and-feel of the window being created. Applications may choose
@@ -553,14 +561,35 @@
@end deffn
@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}.
+Returns a @ref{point} object describing the coordinates of the
+top-left corner of the object in its parent's coordinate
+system. @xref{parent}.
+ at end deffn
+
+ at anchor{maximum-size}
+ at deffn GenericFunction maximum-size self
+Returns a @ref{size} object describing the largest dimensions to which
+the user may resize this widget; by default returns @code{nil},
+indicating that there is effectively no constraint. The corresponding
+ at code{setf} function sets this value; if the new maximum size is
+smaller than the current size, the widget is resized to the new
+maximum. @xref{minimum-size}.
@end deffn
@deffn GenericFunction menu-bar self
Returns the menu object serving as the menubar for this object.
@end deffn
+ at anchor{minimum-size}
+ at deffn GenericFunction minimum-size self
+Returns a @ref{size} object describing the smallest dimensions to
+which the user may resize this widget; by default returns @code{nil},
+indicating that the minimum constraint is determined by the windowing
+system's configuration. The corresponding @code{setf} function sets
+this value; if the new minimum size is larger than the current size,
+the widget is resized to the new minimum. @xref{maximum-size}.
+ at end deffn
+
@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.
@@ -625,6 +654,7 @@
@end quotation
@end deffn
+ at anchor{preferred-size}
@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
Modified: trunk/src/demos/unblocked/unblocked-window.lisp
==============================================================================
--- trunk/src/demos/unblocked/unblocked-window.lisp (original)
+++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Apr 13 15:14:13 2006
@@ -108,7 +108,9 @@
:dispatcher (make-instance 'tiles-panel-events
:buffer-size tile-buffer-size)))
(setf (gfw:text *unblocked-win*) "Graphic-Forms UnBlocked")
- (gfw:pack *unblocked-win*)
+ (let ((size (gfw:preferred-size *unblocked-win* -1 -1)))
+ (setf (gfw:minimum-size *unblocked-win*) size)
+ (setf (gfw:maximum-size *unblocked-win*) size))
(gfw:show *unblocked-win* t)))
(defun unblocked ()
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Thu Apr 13 15:14:13 2006
@@ -232,9 +232,6 @@
#:window
;; constants
- #:maximized ;; FIXME: should be a keyword
- #:minimized ;; FIXME: should be a keyword
- #:restored ;; FIXME: should be a keyword
#:+vk-break+
#:+vk-backspace+
#:+vk-tab+
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu Apr 13 15:14:13 2006
@@ -661,6 +661,7 @@
(defconstant +wm-activate+ #x0006)
(defconstant +wm-paint+ #x000F)
(defconstant +wm-close+ #x0010)
+(defconstant +wm-getminmaxinfo+ #x0024)
(defconstant +wm-setfont+ #x0030)
(defconstant +wm-getfont+ #x0031)
(defconstant +wm-ncmousemove+ #x00A0)
Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp (original)
+++ trunk/src/uitoolkit/system/system-types.lisp Thu Apr 13 15:14:13 2006
@@ -169,6 +169,13 @@
(x LONG)
(y LONG))
+(defcstruct minmaxinfo
+ (reserved point)
+ (maxsize point)
+ (maxposition point)
+ (mintracksize point)
+ (maxtracksize point))
+
(defcstruct msg
(hwnd HANDLE)
(message UINT)
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Thu Apr 13 15:14:13 2006
@@ -298,7 +298,7 @@
:y gfs::rcpaint-y))
(setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width
:height gfs::rcpaint-height))
- (let* ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
+ (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
(unwind-protect
(event-paint (dispatcher widget) widget (event-time tc) gc rct)
(gfs:dispose gc)
@@ -318,14 +318,42 @@
(declare (ignore wparam))
(process-mouse-message #'event-mouse-up hwnd lparam :right-button))
+(defmethod process-message (hwnd (msg (eql gfs::+wm-getminmaxinfo+)) wparam lparam)
+ (declare (ignore wparam))
+ (let* ((tc (thread-context))
+ (w (get-widget tc hwnd))
+ (info-ptr (cffi:make-pointer lparam)))
+ (if (typep w 'top-level)
+ (cffi:with-foreign-slots ((gfs::mintracksize gfs::maxtracksize)
+ info-ptr gfs::minmaxinfo)
+ (let ((max-size (maximum-size w))
+ (min-size (minimum-size w)))
+ (if max-size
+ (cffi:with-foreign-slots ((gfs::x gfs::y)
+ (cffi:foreign-slot-pointer info-ptr
+ 'gfs::minmaxinfo
+ 'gfs::maxtracksize)
+ gfs::point)
+ (setf gfs::x (gfs:size-width max-size)
+ gfs::y (gfs:size-height max-size))))
+ (if min-size
+ (cffi:with-foreign-slots ((gfs::x gfs::y)
+ (cffi:foreign-slot-pointer info-ptr
+ 'gfs::minmaxinfo
+ 'gfs::mintracksize)
+ gfs::point)
+ (setf gfs::x (gfs:size-width min-size)
+ gfs::y (gfs:size-height min-size))))))))
+ 0)
+
(defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam)
(declare (ignore lparam))
(let* ((tc (thread-context))
(w (get-widget tc hwnd))
(type (cond
- ((= wparam gfs::+size-maximized+) 'maximized)
- ((= wparam gfs::+size-minimized+) 'minimized)
- ((= wparam gfs::+size-restored+) 'restored)
+ ((= wparam gfs::+size-maximized+) :maximized)
+ ((= wparam gfs::+size-minimized+) :minimized)
+ ((= wparam gfs::+size-restored+) :restored)
(t nil))))
(when w
(outer-size w (size-event-size tc))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Apr 13 15:14:13 2006
@@ -54,6 +54,11 @@
gfs::+cs-dblclks+
-1))
+(defun constrain-new-size (new-size current-size compare-fn)
+ (let ((new-width (funcall compare-fn (gfs:size-width new-size) (gfs:size-width current-size)))
+ (new-height (funcall compare-fn (gfs:size-height new-size) (gfs:size-height current-size))))
+ (gfs:make-size :width new-width :height new-height)))
+
;;;
;;; methods
;;;
@@ -73,8 +78,6 @@
(setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
((eq sym :min)
(setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
- ((eq sym :resize)
- (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
((eq sym :sysmenu)
(setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
((eq sym :title)
@@ -152,6 +155,12 @@
(error 'gfs:toolkit-error :detail "no object for menu handle"))
m)))
+(defmethod (setf maximum-size) :after (max-size (win top-level))
+ (unless (gfs:disposed-p win)
+ (let ((size (constrain-new-size max-size (size win) #'min)))
+ (setf (size win) size)
+ (perform-layout win (gfs:size-width size) (gfs:size-height size)))))
+
(defmethod (setf menu-bar) :before ((m menu) (win top-level))
(declare (ignore m))
(if (gfs:disposed-p win)
@@ -168,6 +177,12 @@
(gfs::set-menu hwnd (gfs:handle m))
(gfs::draw-menu-bar hwnd)))
+(defmethod (setf minimum-size) :after (min-size (win top-level))
+ (unless (gfs:disposed-p win)
+ (let ((size (constrain-new-size min-size (size win) #'max)))
+ (setf (size win) size)
+ (perform-layout win (gfs:size-width size) (gfs:size-height size)))))
+
(defmethod text :before ((win top-level))
(if (gfs:disposed-p win)
(error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 13 15:14:13 2006
@@ -100,7 +100,15 @@
(defclass root-window (window) ()
(:documentation "This class encapsulates the root of the desktop window hierarchy."))
-(defclass top-level (window) ()
+(defclass top-level (window)
+ ((maximum-size
+ :accessor maximum-size
+ :initarg :maximum-size
+ :initform nil)
+ (minimum-size
+ :accessor minimum-size
+ :initarg :minimum-size
+ :initform nil))
(:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars."))
(defclass timer (event-source)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Thu Apr 13 15:14:13 2006
@@ -217,7 +217,7 @@
(:documentation "Returns T if the object is in its maximized state (not necessarily the same as the maximum size); nil otherwise."))
(defgeneric maximum-size (self)
- (:documentation "Returns a size object describing the largest size this object can exist."))
+ (:documentation "Returns a size object describing the largest dimensions to which the user may resize the widget."))
(defgeneric menu-bar (self)
(:documentation "Returns the menu object serving as the menubar for this object."))
More information about the Graphic-forms-cvs
mailing list