Author: junrue
Date: Mon May 22 22:53:07 2006
New Revision: 139
Added:
trunk/src/tests/uitoolkit/widget-unit-tests.lisp
Modified:
trunk/config.lisp
trunk/docs/manual/api.texinfo
trunk/graphic-forms-tests.asd
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
refactored minimum/maximum-size slots so that both windows and controls have this feature
Modified: trunk/config.lisp
==============================================================================
--- trunk/config.lisp (original)
+++ trunk/config.lisp Mon May 22 22:53:07 2006
@@ -40,7 +40,7 @@
(in-package #:graphic-forms-system)
(defvar *cells-dir* "cells/")
-(defvar *cffi-dir* "cffi-0.9.0/")
+(defvar *cffi-dir* "cffi-060514/")
(defvar *closer-mop-dir* "closer-mop/")
(defvar *lw-compat-dir* "lw-compat/")
(defvar *gf-dir* "graphic-forms/")
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon May 22 22:53:07 2006
@@ -863,13 +863,14 @@
@end deffn
@anchor{maximum-size}
-@deffn GenericFunction maximum-size self
+@deffn GenericFunction maximum-size self => size
Returns a @ref{size} object describing the largest dimensions to which
-the user may resize this widget; by default returns @sc{nil},
-indicating that there is effectively no constraint. The corresponding
-@sc{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}.
+the user may resize this widget. By default, @ref{window}s and
+@ref{control}s return @sc{nil} indicating that there is effectively no
+constraint.@*@*
+The corresponding @sc{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
@@ -877,13 +878,16 @@
@end deffn
@anchor{minimum-size}
-@deffn GenericFunction minimum-size self
+@deffn GenericFunction minimum-size self => size
Returns a @ref{size} object describing the smallest dimensions to
-which the user may resize this widget; by default returns @sc{nil},
-indicating that the minimum constraint is determined by the windowing
-system's configuration. The corresponding @sc{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}.
+which the user may resize this widget. By default, @ref{window}
+objects return @sc{nil} indicating that the minimum constraint is
+determined by the windowing system's configuration; whereas,
+@ref{control}s return the same value by default as would
+@ref{preferred-size}.@*@*
+The corresponding @sc{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}.
@end deffn
@deffn GenericFunction object-to-display self pnt
Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd (original)
+++ trunk/graphic-forms-tests.asd Mon May 22 22:53:07 2006
@@ -77,6 +77,7 @@
(:file "graphics-context-unit-tests")
(:file "image-unit-tests")
(:file "layout-unit-tests")
+ (:file "widget-unit-tests")
(:file "hello-world")
(:file "event-tester")
(:file "layout-tester")
Added: trunk/src/tests/uitoolkit/widget-unit-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/widget-unit-tests.lisp Mon May 22 22:53:07 2006
@@ -0,0 +1,46 @@
+;;;;
+;;;; widget-unit-tests.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.tests)
+
+(define-test class-registration-test
+ (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class)
+ (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class)
+ (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class)
+ (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class))
+
+(define-test repeat-class-registration-test
+ (assert-true (> (gfw::register-panel-window-class) 0) 'gfw::register-panel-class)
+ (assert-true (> (gfw::register-toplevel-erasebkgnd-window-class) 0) 'gfw::register-toplevel-erasebkgnd-window-class)
+ (assert-true (> (gfw::register-toplevel-noerasebkgnd-window-class) 0) 'gfw::register-toplevel-noerasebkgnd-window-class)
+ (assert-true (> (gfw::register-dialog-class) 0) 'gfw::register-dialog-class))
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Mon May 22 22:53:07 2006
@@ -143,9 +143,25 @@
(let ((class (define-dispatcher `((event-select . ,callback)))))
(setf (dispatcher ctrl) (make-instance (class-name class))))))
-(defmethod preferred-size :before ((ctrl control) width-hint height-hint)
+(defmethod (setf maximum-size) :after (max-size (self control))
+ (unless (gfs:disposed-p self)
+ (let ((size (constrain-new-size max-size (size self) #'min)))
+ (setf (size self) size))))
+
+(defmethod minimum-size :after ((self control))
+ (let ((size (slot-value self 'minimum-size)))
+ (if (null size)
+ (preferred-size self -1 -1)
+ size)))
+
+(defmethod (setf minimum-size) :after (min-size (self control))
+ (unless (gfs:disposed-p self)
+ (let ((size (constrain-new-size min-size (size self) #'max)))
+ (setf (size self) size))))
+
+(defmethod preferred-size :before ((self control) width-hint height-hint)
(declare (ignorable width-hint height-hint))
- (if (gfs:disposed-p ctrl)
+ (if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
(defmethod print-object ((self control) stream)
Modified: trunk/src/uitoolkit/widgets/top-level.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/top-level.lisp (original)
+++ trunk/src/uitoolkit/widgets/top-level.lisp Mon May 22 22:53:07 2006
@@ -51,11 +51,6 @@
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
;;;
@@ -150,12 +145,6 @@
(error 'gfs:toolkit-error :detail "no object for menu handle"))
m)))
-(defmethod (setf maximum-size) :after (max-size (win top-level))
- (unless (or (gfs:disposed-p win) (null (layout-of win)))
- (let ((size (constrain-new-size max-size (size win) #'min)))
- (setf (size win) size)
- (perform (layout-of win) 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)
@@ -172,12 +161,6 @@
(gfs::set-menu hwnd (gfs:handle m))
(gfs::draw-menu-bar hwnd)))
-(defmethod (setf minimum-size) :after (min-size (win top-level))
- (unless (or (gfs:disposed-p win) (null (layout-of win)))
- (let ((size (constrain-new-size min-size (size win) #'max)))
- (setf (size win) size)
- (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size)))))
-
(defmethod print-object ((self top-level) stream)
(print-unreadable-object (self stream :type t)
(format stream "handle: ~x " (gfs:handle self))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon May 22 22:53:07 2006
@@ -84,6 +84,14 @@
:initform nil)
(pixel-point
:accessor pixel-point-of
+ :initform nil)
+ (maximum-size
+ :accessor maximum-size
+ :initarg :maximum-size
+ :initform nil)
+ (minimum-size
+ :accessor minimum-size
+ :initarg :minimum-size
:initform nil))
(:documentation "The base class for widgets having pre-defined native behavior."))
@@ -116,6 +124,14 @@
(layout
:accessor layout-of
:initarg :layout
+ :initform nil)
+ (maximum-size
+ :accessor maximum-size
+ :initarg :maximum-size
+ :initform nil)
+ (minimum-size
+ :accessor minimum-size
+ :initarg :minimum-size
:initform nil))
(:documentation "Base class for user-defined widgets that serve as containers."))
@@ -128,15 +144,7 @@
(defclass root-window (window) ()
(:documentation "This class encapsulates the root of the desktop window hierarchy."))
-(defclass top-level (window)
- ((maximum-size
- :accessor maximum-size
- :initarg :maximum-size
- :initform nil)
- (minimum-size
- :accessor minimum-size
- :initarg :minimum-size
- :initform nil))
+(defclass top-level (window) ()
(: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-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Mon May 22 22:53:07 2006
@@ -168,3 +168,8 @@
(cffi:lisp-string-to-foreign tmp-str (cffi:make-pointer curr-addr) str-len)
(incf curr-addr str-len)))
buffer))
+
+(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)))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Mon May 22 22:53:07 2006
@@ -114,12 +114,10 @@
gfs::hicon gfs::hcursor gfs::hbrush
gfs::menuname gfs::classname gfs::smallicon)
wc-ptr gfs::wndclassex)
- ;; FIXME: move this if form outside of with-foreign-slots
- ;;
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex))
(if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer))
str-ptr wc-ptr))
(progn
- (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex))
(setf gfs::style style)
(setf gfs::wndproc proc-ptr)
(setf gfs::clsextra 0)
@@ -226,22 +224,41 @@
(outer-location win pnt)
pnt))
-(defmethod layout ((win window))
- (unless (null (layout-of win))
- (let ((sz (client-size win)))
- (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz)))))
-
-(defmethod pack ((win window))
- (unless (null (layout-of win))
- (perform (layout-of win) win -1 -1))
+(defmethod layout ((self window))
+ (unless (null (layout-of self))
+ (let ((sz (client-size self)))
+ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
+
+(defmethod (setf maximum-size) :after (max-size (self window))
+ (unless (or (gfs:disposed-p self) (null (layout-of self)))
+ (let ((size (constrain-new-size max-size (size self) #'min)))
+ (setf (size self) size)
+ (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))
+ size)))
+
+(defmethod (setf minimum-size) :after (min-size (self window))
+ (unless (or (gfs:disposed-p self) (null (layout-of self)))
+ (let ((size (constrain-new-size min-size (size self) #'max)))
+ (setf (size self) size)
+ (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))
+ size)))
+
+(defmethod pack ((self window))
+ (unless (null (layout-of self))
+ (perform (layout-of self) self -1 -1))
(call-next-method))
-(defmethod preferred-size ((win window) width-hint height-hint)
- (let ((layout (layout-of win)))
- (if (and (layout-p win) layout)
- (let ((new-client-sz (compute-size layout win width-hint height-hint)))
- (compute-outer-size win new-client-sz))
- (size win))))
+(defmethod preferred-size :before ((self window) width-hint height-hint)
+ (declare (ignorable width-hint height-hint))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod preferred-size ((self window) width-hint height-hint)
+ (let ((layout (layout-of self)))
+ (if (and (layout-p self) layout)
+ (let ((new-client-sz (compute-size layout self width-hint height-hint)))
+ (compute-outer-size self new-client-sz))
+ (size self))))
(defmethod print-object ((self window) stream)
(print-unreadable-object (self stream :type t)
@@ -249,21 +266,21 @@
(format stream "dispatcher: ~a " (dispatcher self))
(format stream "size: ~a" (size self))))
-(defmethod show ((win window) flag)
+(defmethod show ((self window) flag)
(declare (ignore flag))
(call-next-method)
- (gfs::update-window (gfs:handle win)))
+ (gfs::update-window (gfs:handle self)))
-(defmethod size ((win window))
+(defmethod size ((self window))
(let ((sz (gfs:make-size)))
- (outer-size win sz)
+ (outer-size self sz)
sz))
-(defmethod window->display :before ((self top-level))
+(defmethod window->display :before ((self window))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error)))
-(defmethod window->display ((self top-level))
+(defmethod window->display ((self window))
(let* ((hmonitor (gfs::monitor-from-window (gfs:handle self) gfs::+monitor-defaulttonearest+))
(display (make-instance 'display)))
(setf (slot-value display 'gfs:handle) hmonitor)
