[graphic-forms-cvs] r263 - in trunk: . src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 22 00:48:29 UTC 2006
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))
More information about the Graphic-forms-cvs
mailing list