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")))