Author: junrue Date: Mon Nov 13 01:58:13 2006 New Revision: 393 Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp trunk/src/uitoolkit/widgets/border-layout.lisp Modified: trunk/NEWS.txt trunk/docs/manual/Makefile trunk/docs/manual/gfs-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/flow-layout-unit-tests.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/system/datastructs.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/tests.lisp Log: initial implementation of border-layout; added create-rectangle convenience function Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Nov 13 01:58:13 2006 @@ -1,5 +1,9 @@ +. Implemented a new layout manager called GFW:BORDER-LAYOUT which assigns + children to 5 possible regions identified by :top, :left, :right, + :bottom, or :center. + . GFW:APPEND-ITEM now accepts an optional classname argument so that applications can use custom item classes. Modified: trunk/docs/manual/Makefile ============================================================================== --- trunk/docs/manual/Makefile (original) +++ trunk/docs/manual/Makefile Mon Nov 13 01:58:13 2006 @@ -1,4 +1,4 @@ -# -*- Mode: Makefile; tab-width: 3; indent-tabs-mode: t -*- +# -*- Mode: Makefile; tab-width: 4; indent-tabs-mode: t -*- # # Makefile # Modified: trunk/docs/manual/gfs-symbols.xml ============================================================================== --- trunk/docs/manual/gfs-symbols.xml (original) +++ trunk/docs/manual/gfs-symbols.xml Mon Nov 13 01:58:13 2006 @@ -264,6 +264,7 @@ </initargs> <seealso> <reftopic>gfs:copy-rectangle</reftopic> + <reftopic>gfs:create-rectangle</reftopic> <reftopic>gfs:location</reftopic> <reftopic>gfs:make-rectangle</reftopic> <reftopic>gfs:size</reftopic> @@ -410,7 +411,7 @@ <notarg name="point"/> <argument name=":size"> <description> - A <reftopic>gfs:size</reftopic> specifing the dimensions of the + A <reftopic>gfs:size</reftopic> specifying the dimensions of the rectangle. </description> </argument> @@ -425,6 +426,52 @@ </description> <seealso> <reftopic>gfs:copy-rectangle</reftopic> + <reftopic>gfs:create-rectangle</reftopic> + </seealso> + </function> + + <function name="create-rectangle"> + <syntax> + <arguments> + <argument name=":x"> + <description> + An <refclhs>integer</refclhs> specifying the X coordinate of the + upper-left corner of the rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":y"> + <description> + An <refclhs>integer</refclhs> specifying the Y coordinate of the + upper-left corner of the rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":width"> + <description> + An <refclhs>integer</refclhs> specifying the width of the + rectangle. + </description> + </argument> + <notarg name="integer"/> + <argument name=":height"> + <description> + An <refclhs>integer</refclhs> specifying the height of the + rectangle. + </description> + </argument> + <notarg name="integer"/> + </arguments> + <return> + <reftopic label="new rectangle">gfs:rectangle</reftopic> + </return> + </syntax> + <description> + Returns a new <reftopic>gfs:rectangle</reftopic>. This function is a + wrapper around <reftopic>gfs:make-rectangle</reftopic>. + </description> + <seealso> + <reftopic>gfs:copy-rectangle</reftopic> </seealso> </function> Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Nov 13 01:58:13 2006 @@ -17,6 +17,130 @@ <!-- CLASSES --> + <class name="border-layout"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:layout-manager</reftopic> + </inherits> + </hierarchy> + <para role="normal"> + This layout manager organizes the space within a container as 5 regions, + one region for each edge of the container and a center region. Applications + specify the region for each component via <reftopic>gfw:layout-attribute</reftopic>, + using one of the following keywords: + <enum> + <argument name=":center"> + <description> + Place the component in the central region of the container. + </description> + </argument> + <argument name=":bottom"> + <description> + Place the component in the bottom region of the container; note that + the bottom region extends to the left and right sides of the container. + </description> + </argument> + <argument name=":left"> + <description> + Place the component in the left-hand region of the container. This region + is bounded vertically by the top and bottom regions. + </description> + </argument> + <argument name=":right"> + <description> + Place the component in the right-hand region of the container. This region + is bounded vertically by the top and bottom regions. + </description> + </argument> + <argument name=":top"> + <description> + Place the component in the top region of the container; note that + the top region extends to the left and right sides of the container. + </description> + </argument> + </enum> + Note that only one child may be assigned to each region at a time. + </para> + <para role="normal"> + Spacing between adjacent regions can also be specified via + <reftopic>gfw:layout-attribute</reftopic> using one or more + of the following keywords (note that not all keywords apply + to all regions): + <enum> + <argument name=":center-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + the center region and a region on the perimeter. + </description> + </argument> + <argument name=":leading-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + neighboring regions on the leading edge of the specified region. + </description> + </argument> + <argument name=":trailing-spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + neighboring regions on the trailing edge of the specified region. + </description> + </argument> + <argument name=":spacing"> + <description> + An <refclhs>integer</refclhs> specifying the number of pixels between + a region and its immediate neighbors. + </description> + </argument> + </enum> + </para> + <para role="normal"> + The :top and :bottom components may be stretched horizontally, while the + :left and :right components may be stretched vertically. The :center component + will be sized to fill the remaining space. Each component's extent on the + secondary axis is determined by <reftopic>gfw:preferred-size</reftopic>. + </para> + </description> + <initargs> + <argument name=":bottom-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":left-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":right-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":top-margin"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":horizontal-margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":vertical-margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + <argument name=":margins"> + <description> + See <reftopic>gfw:layout-manager</reftopic>. + </description> + </argument> + </initargs> + <para role="normal"/> + </class> + <class name="flow-layout"> <description> <hierarchy> @@ -30,7 +154,7 @@ <argument name=":spacing"> <description> An <refclhs>integer</refclhs> value specifying the number of pixels - between succeeding child widgets. + between neighboring child widgets. </description> </argument> <argument name=":style"> @@ -171,6 +295,7 @@ <description> <hierarchy> <inheritedby> + <reftopic>gfw:border-layout</reftopic> <reftopic>gfw:flow-layout</reftopic> <reftopic>gfw:heap-layout</reftopic> </inheritedby> @@ -187,22 +312,29 @@ <initargs> <argument name=":bottom-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the margin + between the layout area and the bottom edge of the container, in pixels. </description> </argument> <argument name=":left-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the left edge of the container, + in pixels. </description> </argument> <argument name=":right-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the right edge of the container, + in pixels. </description> </argument> <argument name=":top-margin"> <description> - An <refclhs>integer</refclhs> value specifying margin thickness in pixels. + An <refclhs>integer</refclhs> value specifying the thickness of the + margin between the layout area and the top edge of the container, + in pixels. </description> </argument> <argument name=":horizontal-margins"> @@ -2159,10 +2291,9 @@ positioning <arg1/>'s children. </description> </argument> - <argument name="container"> + <argument name="thing"> <description> - A <reftopic>gfw:window</reftopic> or other type containing - children. + An object whose position and size are managed by <arg0/>. </description> </argument> <argument name="symbol"> @@ -2178,9 +2309,9 @@ </syntax> <description> Each <reftopic>gfw:layout-manager</reftopic> subclass can support attributes - that apply to each child of <arg1/>, which this function allows to be set + that apply to each <arg1/>, which this function allows to be set or retrieved. After setting attribute values, call <reftopic>gfw:layout</reftopic> - on <arg1/>. + on the container managed by <arg0/>. </description> </function> @@ -2493,7 +2624,7 @@ </argument> </arguments> <return> - <emphasis>undefined</emphasis> + <refclhs>list</refclhs> </return> </syntax> <description> @@ -2539,7 +2670,7 @@ </argument> </arguments> <return> - <emphasis>undefined</emphasis> + <reftopic>gfs:size</reftopic> </return> </syntax> <description> Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Nov 13 01:58:13 2006 @@ -149,6 +149,7 @@ (:file "panel") (:file "dialog") (:file "layout") + (:file "border-layout") (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Nov 13 01:58:13 2006 @@ -59,9 +59,11 @@ ;; constants ;; methods, functions, macros + #:copy-rectangle #:copy-point #:copy-size #:copy-span + #:create-rectangle #:detail #:dispose #:disposed-p @@ -346,6 +348,7 @@ #:auto-vscroll-p #:background-color #:background-pattern + #:border-layout #:border-width #:bottom-margin-of #:capture-mouse @@ -365,7 +368,9 @@ #:column-index #:column-order #:columns + #:compute-layout #:compute-outer-size + #:compute-size #:copy-area #:copy-text #:cut-text Added: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; border-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 *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-3*))) + +(define-test border-layout-test1 + ;; regions: all + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((layout (make-border-layout *all-border-kids*)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40)))) + (assert-equal 80 (gfs:size-width size)) + (assert-equal 50 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test2 + ;; regions: all but center + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append (butlast *all-border-kids*) '(nil))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 20 (gfs:size-height size)) + (validate-rects data expected-rects))) + +(define-test border-layout-test3 + ;; regions: center only + ;; spacing: 0 + ;; margins: 0 + ;; + (let* ((kids (append '(nil nil nil nil) (last *all-border-kids*))) + (layout (make-border-layout kids)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-container* -1 -1)) + (expected-rects '((0 0 40 40)))) + (assert-equal 40 (gfs:size-width size)) + (assert-equal 40 (gfs:size-height size)) + (validate-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/flow-layout-unit-tests.lisp Mon Nov 13 01:58:13 2006 @@ -33,17 +33,12 @@ (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)) +(defvar *flow-uniform-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-2*))) +(defvar *flow-mixed-kids* (list (make-instance 'mock-widget :min-size *child-size-2*) + (make-instance 'mock-widget :min-size *child-size-1*) + (make-instance 'mock-widget :min-size *child-size-2*))) (define-test flow-layout-test1 ;; orient: horizontal @@ -55,12 +50,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -72,12 +67,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -89,9 +84,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 -1)) + (data (gfw::compute-layout layout *mock-container* 45 -1)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test4 ;; orient: vertical @@ -103,9 +98,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* -1 25)) + (data (gfw::compute-layout layout *mock-container* -1 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test5 ;; orient: horizontal @@ -117,9 +112,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap))) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test6 ;; orient: vertical @@ -131,9 +126,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap))) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test7 ;; orient: horizontal @@ -145,12 +140,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -162,12 +157,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -179,9 +174,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:horizontal :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 45 18)) + (data (gfw::compute-layout layout *mock-container* 45 18)) (expected-rects '((0 0 20 10) (24 0 20 10) (0 14 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test10 ;; orient: vertical @@ -193,9 +188,9 @@ ;; kids: uniform ;; (let* ((layout (make-flow-layout *flow-uniform-kids* '(:vertical :wrap) 4)) - (data (gfw::compute-layout layout *flow-container* 30 25)) + (data (gfw::compute-layout layout *mock-container* 30 25)) (expected-rects '((0 0 20 10) (0 14 20 10) (24 0 20 10)))) - (validate-rects data expected-rects))) + (validate-rects data expected-rects))) (define-test flow-layout-test11 ;; orient: horizontal @@ -207,12 +202,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -224,12 +219,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -241,12 +236,12 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 @@ -258,9 +253,9 @@ ;; 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)) + (size (gfw::compute-size layout *mock-container* -1 -1)) + (data (gfw::compute-layout layout *mock-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))) + (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 Mon Nov 13 01:58:13 2006 @@ -36,14 +36,21 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234))) (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678)))) - (let ((data1 `(,widget1 (a 1 b 2))) - (data2 `(,widget2 (a 10 c 30))) + (let ((data1 (list widget1 (list 'a 1 'b 2))) + (data2 (list widget2 (list 'a 10 'c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) (assert-equal 2 (gfw:layout-attribute layout widget1 'b)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'b))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget1)))) (assert-equal 10 (gfw:layout-attribute layout widget2 'a)) (assert-equal 30 (gfw:layout-attribute layout widget2 'c)) + (let ((tmp (gfw::obtain-children-with-attribute layout 'c))) + (assert-equal 1 (length tmp)) + (assert-true (cffi:pointer-eq (gfs:handle (car (first tmp))) (gfs:handle widget2)))) + (assert-true (null (gfw::obtain-children-with-attribute layout 'd))) (setf (gfw:layout-attribute layout widget1 'b) 66 (gfw:layout-attribute layout widget2 'd) 100) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Mon Nov 13 01:58:13 2006 @@ -57,6 +57,8 @@ :initarg :visibility :initform t))) +(defvar *mock-container* (make-instance 'mock-container)) + (defmethod gfw:visible-p ((self mock-container)) (visibility-of self)) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Mon Nov 13 01:58:13 2006 @@ -33,6 +33,10 @@ (in-package :graphic-forms.uitoolkit.tests) +(defvar *child-size-1* (gfs:make-size :width 25 :height 5)) +(defvar *child-size-2* (gfs:make-size :width 20 :height 10)) +(defvar *child-size-3* (gfs:make-size :width 40 :height 40)) + (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 @@ -44,6 +48,34 @@ (loop for kid in kids do (gfw::append-layout-item layout kid)) layout)) +(defun make-border-layout (kids &optional spacing left-margin top-margin right-margin bottom-margin) + (let ((layout (make-instance 'gfw:border-layout + :left-margin (or left-margin 0) + :top-margin (or top-margin 0) + :right-margin (or right-margin 0) + :bottom-margin (or bottom-margin 0))) + (top-kid (first kids)) + (right-kid (second kids)) + (bottom-kid (third kids)) + (left-kid (fourth kids)) + (center-kid (fifth kids))) + (when top-kid + (gfw::append-layout-item layout top-kid) + (setf (gfw:layout-attribute layout top-kid :top) t)) + (when right-kid + (gfw::append-layout-item layout right-kid) + (setf (gfw:layout-attribute layout right-kid :right) t)) + (when bottom-kid + (gfw::append-layout-item layout bottom-kid) + (setf (gfw:layout-attribute layout bottom-kid :bottom) t)) + (when left-kid + (gfw::append-layout-item layout left-kid) + (setf (gfw:layout-attribute layout left-kid :left) t)) + (when center-kid + (gfw::append-layout-item layout center-kid) + (setf (gfw:layout-attribute layout center-kid :center) t)) + layout)) + (defun validate-image (image expected-size expected-depth) (declare (ignore expected-depth)) (assert-false (null image)) @@ -52,6 +84,7 @@ (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) (defun validate-rects (entries expected-rects) + (assert-equal (length expected-rects) (length entries)) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) (let ((pnt-a (gfs:location actual)) Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Mon Nov 13 01:58:13 2006 @@ -41,6 +41,11 @@ (defstruct span (start 0) (end 0)) +(declaim (inline create-rectangle)) +(defun create-rectangle (&key (height 0) (width 0) (x 0) (y 0)) + (make-rectangle :location (make-point :x x :y y) + :size (make-size :width width :height height))) + (declaim (inline location)) (defun location (rect) (rectangle-location rect)) Added: trunk/src/uitoolkit/widgets/border-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/border-layout.lisp Mon Nov 13 01:58:13 2006 @@ -0,0 +1,163 @@ +;;;; +;;;; border-layout.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.widgets) + +;;; +;;; helpers +;;; + +(declaim (inline total-border-layout-width)) +(defun total-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max twidth bwidth (+ lwidth cwidth rwidth))) + +(declaim (inline inside-border-layout-width)) +(defun inside-border-layout-width (cwidth twidth lwidth bwidth rwidth) + (max cwidth (- twidth lwidth rwidth) (- bwidth lwidth rwidth))) + +(declaim (inline inside-border-layout-height)) +(defun inside-border-layout-height (cheight lheight rheight) + (max cheight lheight rheight)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-border-components ((layout center top left bottom right) &body body) + `(progn + (let ((,center (first (obtain-children-with-attribute ,layout :center))) + (,top (first (obtain-children-with-attribute ,layout :top))) + (,left (first (obtain-children-with-attribute ,layout :left))) + (,bottom (first (obtain-children-with-attribute ,layout :bottom))) + (,right (first (obtain-children-with-attribute ,layout :right)))) + ,@body))) + + (defmacro with-border-sizes ((layout center top left bottom right + total-width inside-width inside-height) &body body) + (let ((nil-size (gensym)) + (c-size (gensym)) + (t-size (gensym)) + (l-size (gensym)) + (b-size (gensym)) + (r-size (gensym)) + (c-widget (gensym)) + (t-widget (gensym)) + (l-widget (gensym)) + (r-widget (gensym)) + (b-widget (gensym))) + `(with-border-components (,layout ,c-widget ,t-widget ,l-widget ,b-widget ,r-widget) + (let* ((,nil-size (gfs:make-size)) + (,c-size (if ,c-widget (preferred-size (first ,c-widget) -1 -1) ,nil-size)) + (,t-size (if ,t-widget (preferred-size (first ,t-widget) -1 -1) ,nil-size)) + (,l-size (if ,l-widget (preferred-size (first ,l-widget) -1 -1) ,nil-size)) + (,b-size (if ,b-widget (preferred-size (first ,b-widget) -1 -1) ,nil-size)) + (,r-size (if ,r-widget (preferred-size (first ,r-widget) -1 -1) ,nil-size)) + (,center (cons (first ,c-widget) ,c-size)) + (,top (cons (first ,t-widget) ,t-size)) + (,left (cons (first ,l-widget) ,l-size)) + (,bottom (cons (first ,b-widget) ,b-size)) + (,right (cons (first ,r-widget) ,r-size)) + (,total-width (total-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-width (inside-border-layout-width (gfs:size-width ,c-size) + (gfs:size-width ,t-size) + (gfs:size-width ,l-size) + (gfs:size-width ,b-size) + (gfs:size-width ,r-size))) + (,inside-height (inside-border-layout-height (gfs:size-height ,c-size) + (gfs:size-height ,l-size) + (gfs:size-height ,r-size)))) + ,@body))))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((layout-size (gfs:make-size))) + (with-border-sizes (self unused1 top unused2 bottom unused3 total-width unused4 inside-height) + (declare (ignore unused1 unused2 unused3 unused4)) + ;; + ;; remember that top and/or bottom might be nil + ;; + (setf (gfs:size-width layout-size) total-width + (gfs:size-height layout-size) (+ (gfs:size-height (cdr top)) + inside-height + (gfs:size-height (cdr bottom))))) + (if (>= width-hint 0) + (setf (gfs:size-width layout-size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height layout-size) height-hint)) + layout-size)) + +(defmethod compute-layout ((self border-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((results nil)) + (with-border-sizes (self center top left bottom right total-width inside-width inside-height) + (let ((left-width (gfs:size-width (cdr left))) + (right-width (gfs:size-width (cdr right))) + (top-height (gfs:size-height (cdr top))) + (bottom-height (gfs:size-height (cdr bottom)))) + (when (car center) + (setf (cdr center) + (gfs:create-rectangle :x left-width + :y top-height + :width inside-width + :height inside-height)) + (push center results)) + (when (car top) + (setf (cdr top) + (gfs:create-rectangle :width total-width + :height top-height)) + (push top results)) + (when (car left) + (setf (cdr left) + (gfs:create-rectangle :y top-height + :width left-width + :height inside-height)) + (push left results)) + (when (car right) + (setf (cdr right) + (gfs:create-rectangle :x (+ left-width inside-width) + :y top-height + :width right-width + :height inside-height)) + (push right results)) + (when (car bottom) + (setf (cdr bottom) + (gfs:create-rectangle :y (+ top-height inside-height) + :width total-width + :height bottom-height)) + (push bottom results)))) + results)) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Mon Nov 13 01:58:13 2006 @@ -67,16 +67,16 @@ (let* ((size (client-size container)) (horz-margin (+ (left-margin-of self) (right-margin-of self))) (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) - (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) - width-hint - (gfs:size-width size)) - horz-margin) - :height (- (if (> height-hint vert-margin) - height-hint - (gfs:size-height size)) - vert-margin))) - (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) - (bounds (gfs:make-rectangle :size new-size :location new-pnt))) + (bounds (gfs:create-rectangle :x (left-margin-of self) + :y (top-margin-of self) + :width (- (if (> width-hint horz-margin) + width-hint + (gfs:size-width size)) + horz-margin) + :height (- (if (> height-hint vert-margin) + height-hint + (gfs:size-height size)) + vert-margin)))) (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Mon Nov 13 01:58:13 2006 @@ -59,6 +59,9 @@ :initform nil)) (:documentation "Subclasses implement layout strategies to manage space within windows.")) +(defclass border-layout (layout-manager) () + (:documentation "Window children are assigned a position on the edges or center of a container.")) + (defclass flow-layout (layout-manager) ((spacing :accessor spacing-of Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Mon Nov 13 01:58:13 2006 @@ -39,20 +39,26 @@ (defun layout-attribute (layout thing name) "Return the value associated with name for thing; or NIL if no value is set." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (getf (first (rest items)) name))) + (getf (second item-data) name))) (defun set-layout-attribute (layout thing name value) "Sets a value associated with name for thing in the specified layout." - (let ((items (assoc thing (data-of layout)))) - (unless items + (let ((item-data (assoc thing (data-of layout)))) + (unless item-data (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) - (setf (getf (first (rest items)) name) value))) + (setf (getf (second item-data) name) value))) (defsetf layout-attribute set-layout-attribute) +(defun obtain-children-with-attribute (layout name) + "Returns a list of layout entries that have the named attribute." + (loop for pair in (data-of layout) + when (getf (second pair) name) + collect pair)) + (defun append-layout-item (layout thing) "Adds thing to layout. Duplicate entries are not prevented." (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) @@ -68,24 +74,25 @@ (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) + for widget = (car k) for size = (gfs:size rect) for pnt = (gfs:location rect) do (if (gfs:null-handle-p hdwp) - (gfs::set-window-pos (gfs:handle (car k)) + (gfs::set-window-pos (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))) + (funcall flags-func widget)) (gfs::defer-window-pos hdwp - (gfs:handle (car k)) + (gfs:handle widget) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) (gfs:size-width size) (gfs:size-height size) - (funcall flags-func (car k))))) + (funcall flags-func widget)))) (unless (gfs:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp)))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Mon Nov 13 01:58:13 2006 @@ -43,5 +43,6 @@ "graphics-context-unit-tests" "image-unit-tests" "icon-bundle-unit-tests" "layout-unit-tests" "flow-layout-unit-tests" "widget-unit-tests" - "item-manager-unit-tests" "misc-unit-tests") + "item-manager-unit-tests" "misc-unit-tests" + "border-layout-unit-tests") do (load (merge-pathnames file *gf-tests-dir*))))