[graphic-forms-cvs] r221 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Aug 18 22:31:01 UTC 2006
Author: junrue
Date: Fri Aug 18 18:30:58 2006
New Revision: 221
Added:
trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp
Modified:
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/tests/uitoolkit/mock-objects.lisp
trunk/src/tests/uitoolkit/test-utils.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/tests.lisp
Log:
refactored flow-layout implementation, updated associated unit-tests
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Aug 18 18:30:58 2006
@@ -255,6 +255,7 @@
#:flow-layout
#:heap-layout
#:item
+ #:layout-managed
#:layout-manager
#:menu
#:menu-item
Added: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Fri Aug 18 18:30:58 2006
@@ -0,0 +1,266 @@
+;;;;
+;;;; flow-layout-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)
+
+(defvar *large-size* (gfs:make-size :width 25 :height 5))
+(defvar *small-size* (gfs:make-size :width 20 :height 10))
+
+(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*)
+ (make-instance 'mock-widget :min-size *small-size*)
+ (make-instance 'mock-widget :min-size *small-size*)))
+(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*)
+ (make-instance 'mock-widget :min-size *large-size*)
+ (make-instance 'mock-widget :min-size *small-size*)))
+
+(defvar *flow-container* (make-instance 'mock-container))
+
+(define-test flow-layout-test1
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal)))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10))))
+ (assert-equal 60 (gfs:size-width size))
+ (assert-equal 10 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test2
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical)))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10))))
+ (assert-equal 20 (gfs:size-width size))
+ (assert-equal 30 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test3
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width, unrestricted height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)))
+ (data (gfw::compute-layout layout *flow-container* 45 -1))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test4
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width, restricted height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap)))
+ (data (gfw::compute-layout layout *flow-container* -1 25))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test5
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap)))
+ (data (gfw::compute-layout layout *flow-container* 45 18))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test6
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap)))
+ (data (gfw::compute-layout layout *flow-container* 30 25))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test7
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 4))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10))))
+ (assert-equal 68 (gfs:size-width size))
+ (assert-equal 10 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test8
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 4))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10))))
+ (assert-equal 20 (gfs:size-width size))
+ (assert-equal 38 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test9
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4))
+ (data (gfw::compute-layout layout *flow-container* 45 18))
+ (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test10
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: enabled
+ ;; spacing: 4
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4))
+ (data (gfw::compute-layout layout *flow-container* 30 25))
+ (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10))))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test11
+ ;; orient: horizontal
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal) 0 3 3))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10))))
+ (assert-equal 63 (gfs:size-width size))
+ (assert-equal 13 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test12
+ ;; orient: vertical
+ ;; normalize: disabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3
+ ;; container: unrestricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical) 0 0 0 3 3))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10))))
+ (assert-equal 23 (gfs:size-width size))
+ (assert-equal 33 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test13
+ ;; orient: horizontal
+ ;; normalize: enabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: mixed
+ ;;
+ (let* ((layout (make-flow-layout *flow-mixed-kids* '(:horizontal :normalize)))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10))))
+ (assert-equal 75 (gfs:size-width size))
+ (assert-equal 10 (gfs:size-height size))
+ (validate-rects data expected-rects)))
+
+(define-test flow-layout-test14
+ ;; orient: vertical
+ ;; normalize: enabled
+ ;; wrap: disabled
+ ;; spacing: 0
+ ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
+ ;; container: unrestricted width and height
+ ;; kids: mixed
+ ;;
+ (let* ((layout (make-flow-layout *flow-mixed-kids* '(:vertical :normalize)))
+ (size (gfw::compute-size layout *flow-container* -1 -1))
+ (data (gfw::compute-layout layout *flow-container* -1 -1))
+ (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10))))
+ (assert-equal 25 (gfs:size-width size))
+ (assert-equal 30 (gfs:size-height size))
+ (validate-rects data expected-rects)))
Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 18:30:58 2006
@@ -33,27 +33,6 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defvar *large-size* (gfs:make-size :width 25 :height 5))
-(defvar *small-size* (gfs:make-size :width 20 :height 10))
-(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*)
- (make-instance 'mock-widget :min-size *small-size*)
- (make-instance 'mock-widget :min-size *small-size*)))
-(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*)
- (make-instance 'mock-widget :min-size *large-size*)
- (make-instance 'mock-widget :min-size *small-size*)))
-
-(defun validate-layout-rects (entries expected-rects)
- (let ((actual-rects (loop for entry in entries collect (cdr entry))))
- (mapc #'(lambda (expected actual)
- (let ((pnt-a (gfs:location actual))
- (sz-a (gfs:size actual)))
- (assert-equal (first expected) (gfs:point-x pnt-a))
- (assert-equal (second expected) (gfs:point-y pnt-a))
- (assert-equal (third expected) (gfs:size-width sz-a))
- (assert-equal (fourth expected) (gfs:size-height sz-a))))
- expected-rects
- actual-rects)))
-
(define-test layout-attributes-test
(let ((widget1 (make-instance 'mock-widget :handle 1234))
(widget2 (make-instance 'mock-widget :handle 5678)))
@@ -72,229 +51,3 @@
(assert-equal 10 (gfw:layout-attribute layout widget2 'a))
(assert-equal 30 (gfw:layout-attribute layout widget2 'c))
(assert-equal 100 (gfw:layout-attribute layout widget2 'd)))))
-
-(define-test flow-layout-test1
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal)))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10))))
- (assert-equal 60 (gfs:size-width size))
- (assert-equal 10 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test2
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical)))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10))))
- (assert-equal 20 (gfs:size-width size))
- (assert-equal 30 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test3
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: restricted width, unrestricted height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1))
- (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test4
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width, restricted height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25))
- (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test5
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: restricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18))
- (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test6
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: restricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25))
- (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test7
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 4
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal)))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((0 0 20 10) (24 0 20 10) (48 0 20 10))))
- (assert-equal 68 (gfs:size-width size))
- (assert-equal 10 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test8
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 4
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical)))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((0 0 20 10) (0 14 20 10) (0 28 20 10))))
- (assert-equal 20 (gfs:size-width size))
- (assert-equal 38 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test9
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 4
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: restricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:horizontal :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18))
- (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test10
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: enabled
- ;; spacing: 4
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: restricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :spacing 4 :style '(:vertical :wrap)))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25))
- (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10))))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test11
- ;; orient: horizontal
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout
- :style '(:horizontal)
- :left-margin 3
- :top-margin 3))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((3 3 20 10) (23 3 20 10) (43 3 20 10))))
- (assert-equal 63 (gfs:size-width size))
- (assert-equal 13 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test12
- ;; orient: vertical
- ;; normalize: disabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3
- ;; container: unrestricted width and height
- ;; kids: uniform
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout
- :style '(:vertical)
- :right-margin 3
- :bottom-margin 3))
- (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
- (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10))))
- (assert-equal 23 (gfs:size-width size))
- (assert-equal 33 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test13
- ;; orient: horizontal
- ;; normalize: enabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: mixed
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize)))
- (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1))
- (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10))))
- (assert-equal 75 (gfs:size-width size))
- (assert-equal 10 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
-
-(define-test flow-layout-test14
- ;; orient: vertical
- ;; normalize: enabled
- ;; wrap: disabled
- ;; spacing: 0
- ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0
- ;; container: unrestricted width and height
- ;; kids: mixed
- ;;
- (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize)))
- (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1))
- (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1))
- (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10))))
- (assert-equal 25 (gfs:size-width size))
- (assert-equal 30 (gfs:size-height size))
- (validate-layout-rects data expected-rects)))
Modified: trunk/src/tests/uitoolkit/mock-objects.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/mock-objects.lisp (original)
+++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Aug 18 18:30:58 2006
@@ -33,10 +33,33 @@
(in-package :graphic-forms.uitoolkit.tests)
-(defconstant +max-widget-size+ 5000)
+(defconstant +max-widget-size+ 5000)
+(defconstant +default-container-width+ 300)
+(defconstant +default-container-height+ 200)
;;;
-;;; stand-ins for widgets that would be children of windows, to be organized
+;;; stand-in for a window, used as parent of mock-widget
+;;;
+
+(defclass mock-container (gfw:layout-managed)
+ ((location
+ :accessor location-of
+ :initarg :location
+ :initform (gfs:make-point))
+ (size
+ :accessor size-of
+ :initarg :size
+ :initform (gfs:make-size :width +default-container-width+ :height +default-container-height+))
+ (visibility
+ :accessor visibility-of
+ :initarg :visibility
+ :initform t)))
+
+(defmethod gfw:visible-p ((self mock-container))
+ (visibility-of self))
+
+;;;
+;;; stand-in for widgets that would be children of windows, to be organized
;;; via layout managers
;;;
Modified: trunk/src/tests/uitoolkit/test-utils.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/test-utils.lisp (original)
+++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Aug 18 18:30:58 2006
@@ -33,9 +33,32 @@
(in-package :graphic-forms.uitoolkit.tests)
+(defun make-flow-layout (kids style &optional spacing left-margin top-margin right-margin bottom-margin)
+ (let ((layout (make-instance 'gfw:flow-layout
+ :style style
+ :spacing (or spacing 0)
+ :left-margin (or left-margin 0)
+ :top-margin (or top-margin 0)
+ :right-margin (or right-margin 0)
+ :bottom-margin (or bottom-margin 0))))
+ (loop for kid in kids do (gfw::append-layout-item layout kid))
+ layout))
+
(defun validate-image (image expected-size expected-depth)
(declare (ignore expected-depth))
(assert-false (null image))
(assert-false (gfs:disposed-p image))
;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed
(assert-equality #'gfs:equal-size-p expected-size (gfg:size image)))
+
+(defun validate-rects (entries expected-rects)
+ (let ((actual-rects (loop for entry in entries collect (cdr entry))))
+ (mapc #'(lambda (expected actual)
+ (let ((pnt-a (gfs:location actual))
+ (sz-a (gfs:size actual)))
+ (assert-equal (first expected) (gfs:point-x pnt-a))
+ (assert-equal (second expected) (gfs:point-y pnt-a))
+ (assert-equal (third expected) (gfs:size-width sz-a))
+ (assert-equal (fourth expected) (gfs:size-height sz-a))))
+ expected-rects
+ actual-rects)))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 18:30:58 2006
@@ -34,7 +34,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +wm-gf-init-msg+ #xABCD)
(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+
gfs::+pm-noyield+
gfs::+pm-qs-input+
@@ -222,18 +221,8 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
(let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot
(if (typep widget 'dialog)
- (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam)))
- (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget
- (return-from process-message tmp))
- (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget
- 0)
-
-(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam)
- (declare (ignore wparam lparam))
- (let ((widget (get-widget (thread-context) hwnd)))
- (unless widget
- (return-from process-message 0)))
- 0)
+ (gfs::def-dlg-proc hwnd msg wparam lparam)
+ 0)))
(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
(declare (ignore wparam lparam))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 18:30:58 2006
@@ -53,7 +53,7 @@
(start-margin-fn nil)
(current nil))
-(defun init-flow-data (layout visible kids width-hint height-hint)
+(defun init-flow-data (layout visible items width-hint height-hint)
(let ((state (if (find :vertical (style-of layout))
(make-flow-data :hint height-hint
:next-coord (top-margin-of layout)
@@ -71,7 +71,8 @@
:extent-fn #'gfs:size-height
:limit-margin-fn #'right-margin-of
:start-margin-fn #'left-margin-of))))
- (loop for kid in kids
+ (loop for item in items
+ for kid = (first item)
when (or (visible-p kid) (not visible))
do (let* ((size (preferred-size kid -1 -1))
(dist (funcall (flow-data-distance-fn state) size))
@@ -86,37 +87,6 @@
(setf (flow-data-kid-sizes state) (reverse (flow-data-kid-sizes state)))
state))
-(defun flow-container-size (layout visible kids width-hint height-hint)
- (let ((kid-count (length kids))
- (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout)))
- (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout)))
- (vertical (find :vertical (style-of layout)))
- (horizontal (find :horizontal (style-of layout))))
- (let ((spacing-total (* (spacing-of layout) (1- kid-count)))
- (state (init-flow-data layout
- visible
- kids
- (if vertical width-hint -1)
- (if vertical -1 height-hint))))
- (if (find :normalize (style-of layout))
- (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count)))
- (cond
- (horizontal
- (gfs:make-size :width (+ (flow-data-distance-total state)
- horz-margin-total
- spacing-total)
- :height (+ (flow-data-max-extent state)
- vert-margin-total)))
- (vertical
- (gfs:make-size :width (+ (flow-data-max-extent state)
- horz-margin-total)
- :height (+ (flow-data-distance-total state)
- vert-margin-total
- spacing-total)))
- (t
- (error 'gfs:toolkit-error
- :detail (format nil "unrecognized flow layout style: ~a" (style-of layout))))))))
-
(defun wrap-needed-p (state layout kid-size)
(and (>= (flow-data-hint state) 0)
(> (+ (flow-data-next-coord state)
@@ -143,12 +113,49 @@
(flow-data-spacing state)))
(cons kid (gfs:make-rectangle :size kid-size :location pnt))))
-(defun flow-container-layout (layout visible kids width-hint height-hint)
+;;;
+;;; methods
+;;;
+
+(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
+ (let ((kid-count (length (data-of self)))
+ (horz-margin-total (+ (left-margin-of self) (right-margin-of self)))
+ (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self)))
+ (vertical (find :vertical (style-of self)))
+ (horizontal (find :horizontal (style-of self))))
+ (let ((spacing-total (* (spacing-of self) (1- kid-count)))
+ (state (init-flow-data self
+ (visible-p container)
+ (data-of self)
+ (if vertical width-hint -1)
+ (if vertical -1 height-hint))))
+ (if (find :normalize (style-of self))
+ (setf (flow-data-distance-total state) (* (flow-data-max-distance state) kid-count)))
+ (cond
+ (horizontal
+ (gfs:make-size :width (+ (flow-data-distance-total state)
+ horz-margin-total
+ spacing-total)
+ :height (+ (flow-data-max-extent state)
+ vert-margin-total)))
+ (vertical
+ (gfs:make-size :width (+ (flow-data-max-extent state)
+ horz-margin-total)
+ :height (+ (flow-data-distance-total state)
+ vert-margin-total
+ spacing-total)))
+ (t
+ (error 'gfs:toolkit-error
+ :detail (format nil "unrecognized flow layout style: ~a" (style-of self))))))))
+
+(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint)
+ (cleanup-disposed-items self)
(let ((flows nil)
- (normal (find :normalize (style-of layout)))
- (vertical (find :vertical (style-of layout)))
- (state (init-flow-data layout visible kids width-hint height-hint)))
- (loop with wrap = (find :wrap (style-of layout))
+ (normal (find :normalize (style-of self)))
+ (vertical (find :vertical (style-of self)))
+ (state (init-flow-data self (visible-p container) (data-of self) width-hint height-hint)))
+ (loop with wrap = (find :wrap (style-of self))
for (kid kid-size) in (flow-data-kid-sizes state)
do (cond
((and normal vertical)
@@ -159,26 +166,13 @@
(gfs:size-height kid-size) (flow-data-max-extent state))))
(if (and wrap
(flow-data-current state)
- (wrap-needed-p state layout kid-size))
- (setf flows (append flows (wrap-flow state layout))))
- (push (new-flow-element state layout kid kid-size) (flow-data-current state)))
+ (wrap-needed-p state self kid-size))
+ (setf flows (append flows (wrap-flow state self))))
+ (push (new-flow-element state self kid kid-size) (flow-data-current state)))
(if (flow-data-current state)
- (setf flows (append flows (wrap-flow state layout))))
+ (setf flows (append flows (wrap-flow state self))))
flows))
-;;;
-;;; methods
-;;;
-
-(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint)
- (cleanup-disposed-items self)
- (let ((kids (loop for item in (data-of self) collect (first item))))
- (flow-container-size self (visible-p container) kids width-hint height-hint)))
-
-(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint)
- (cleanup-disposed-items self)
- (let ((kids (loop for item in (data-of self) collect (first item))))
- (flow-container-layout self (visible-p container) kids width-hint height-hint)))
(defmethod initialize-instance :after ((self flow-layout) &key)
(unless (intersection (style-of self) '(:horizontal :vertical))
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 18:30:58 2006
@@ -60,7 +60,7 @@
(defsetf layout-attribute set-layout-attribute)
(defun append-layout-item (layout thing)
- "Adds thing to layout unless it is already registered."
+ "Adds thing to layout. Duplicate entries are not prevented."
(setf (data-of layout) (nconc (data-of layout) (list (list thing nil)))))
(defun delete-layout-item (layout thing)
Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp (original)
+++ trunk/tests.lisp Fri Aug 18 18:30:58 2006
@@ -43,5 +43,6 @@
(load (concatenate 'string *gf-tests-dir* "image-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "layout-unit-tests"))
+ (load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "widget-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))
More information about the Graphic-forms-cvs
mailing list