[graphic-forms-cvs] r139 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets

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)