Author: junrue Date: Thu Sep 21 20:48:28 2006 New Revision: 263 Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Modified: trunk/NEWS.txt trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed bugs in setf of minimum and maximum sizes for windows; improved heap-layout such that it obeys the top child min and max sizes if any Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Thu Sep 21 20:48:28 2006 @@ -14,6 +14,15 @@ Additional list box control features will be provided in a future release. +. Implemented scrolling support: + + * new window styles :horizontal-scrollbar and :vertical-scrollbar + + * new event-scroll method for handling raw scrolling events + +. Improved GFW:HEAP-LAYOUT such that it obeys the top child's minimum and + maximum sizes, if any such sizes are set. + . Did some housecleaning of the item-manager protocol and heavily refactored the implementation of item-manager base functionality. @@ -23,6 +32,14 @@ . Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and radio button -style buttons. +. Fixed another silly bug, this one in the initialization of the paint + rectangle in the WM_PAINT message handling method; the correct rectangle + is now passed to GFW:EVENT-PAINT + +. Fixed a bug in the SETF methods for GFW:MAXIMUM-SIZE and GFW:MINIMUM-SIZE + for windows whereby the size value was not being set in the appropriate + slot if there were no layout set for the window. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 20:48:28 2006 @@ -90,5 +90,6 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-grid-panel") (:file "scroll-tester") (:file "windlg"))))))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Thu Sep 21 20:48:28 2006 @@ -187,3 +187,26 @@ (assert-false (gfs::remove-elements tmp (gfs:make-span :start 0 :end 0) #'reaam-test-make-array)))) + +(define-test clamp-size-test + (let ((min-size (gfs:make-size :width 10 :height 10)) + (max-size (gfs:make-size :width 100 :height 100)) + (test-sizes (loop for width in '(5 10 50 100 150) + for height in '(10 5 100 50 150) + collect (gfs:make-size :width width :height height))) + (expected-sizes-1 (loop for width in '(10 10 50 100 100) + for height in '(10 10 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-2 (loop for width in '(5 10 50 100 100) + for height in '(10 5 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-3 (loop for width in '(10 10 50 100 150) + for height in '(10 10 100 50 150) + collect (gfs:make-size :width width :height height)))) + (loop for min-size-1 in (list min-size nil min-size nil) + for max-size-1 in (list max-size max-size nil nil) + for exp-list in (list expected-sizes-1 expected-sizes-2 expected-sizes-3 test-sizes) + do (loop for test-size in test-sizes + for exp-size in exp-list + do (let ((clamped-size (gfs::clamp-size test-size min-size-1 max-size-1))) + (assert-true (gfs:equal-size-p exp-size clamped-size) exp-size test-size)))))) Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Thu Sep 21 20:48:28 2006 @@ -0,0 +1,50 @@ +;;;; +;;;; scroll-grid-panel.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) + +(defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) + +(defun make-scroll-grid-panel (parent) + (let ((panel-size (gfs:make-size :width 1000 :height 800)) + (panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events) + :parent parent))) + (setf (gfw:maximum-size panel) panel-size) + (assert (gfs:equal-size-p panel-size (gfw::max-size-of panel))) + panel)) + +(defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 20:48:28 2006 @@ -47,31 +47,18 @@ (declare (ignore window)) (scroll-tester-exit disp nil)) -(defclass scroll-panel-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) - (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect)) - (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) - (panel-disp (make-instance 'scroll-panel-events)) (layout (make-instance 'gfw:heap-layout)) (menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout - :style '(:frame))) + :style '(:workspace))) (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) - (panel (make-instance 'gfw:panel :dispatcher panel-disp - :parent *scroll-tester-win*)) - (panel-size (gfs:make-size :width 200 :height 200))) - (setf (gfw:minimum-size panel) panel-size - (gfw:maximum-size panel) panel-size - (gfw:menu-bar *scroll-tester-win*) menubar + (panel (make-scroll-grid-panel *scroll-tester-win*))) + (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) (gfw:show *scroll-tester-win* t))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 21 20:48:28 2006 @@ -115,6 +115,21 @@ (list tree) (mapcan (function flatten) tree))) +(defun clamp-size (proposed-size min-size max-size) + (let ((clamped-size (make-size :width (gfs:size-width proposed-size) + :height (gfs:size-height proposed-size)))) + (when min-size + (if (< (gfs:size-width proposed-size) (gfs:size-width min-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width min-size))) + (if (< (gfs:size-height proposed-size) (gfs:size-height min-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height min-size)))) + (when max-size + (if (> (gfs:size-width proposed-size) (gfs:size-width max-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width max-size))) + (if (> (gfs:size-height proposed-size) (gfs:size-height max-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height max-size)))) + clamped-size)) + ;;; lifted from lispbuilder-windows/windows/util.lisp ;;; author: Frank Buss ;;; Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu Sep 21 20:48:28 2006 @@ -164,8 +164,8 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self control)) + (setf (max-size-of self) max-size) (unless (gfs:disposed-p self) - (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) @@ -176,8 +176,8 @@ size))) (defmethod (setf minimum-size) (min-size (self control)) + (setf (min-size-of self) min-size) (unless (gfs:disposed-p self) - (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Sep 21 20:48:28 2006 @@ -72,8 +72,17 @@ (if (layout-p container) (let ((top (top-child-of self)) (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) + (let ((spec (if top + (find-if (lambda (x) (eql x top)) kid-specs :key #'car) + (progn + (setf top (car (first kid-specs))) + (first kid-specs))))) + (if spec + (let ((bounds (cdr spec))) + (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds) + (min-size-of top) + (max-size-of top))) + (setf (cdr spec) bounds)))) (arrange-hwnds kid-specs (lambda (item) (if (eql top item) (logior +window-pos-flags+ gfs::+swp-showwindow+) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 20:48:28 2006 @@ -287,22 +287,24 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (max-size-of self) max-size) + (setf (max-size-of self) max-size) + (unless (gfs:disposed-p 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)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod minimum-size ((self window)) (min-size-of self)) (defmethod (setf minimum-size) (min-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (min-size-of self) min-size) + (setf (min-size-of self) min-size) + (unless (gfs:disposed-p 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)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod pack ((self window))