[graphic-forms-cvs] r393 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Nov 13 06:58:15 UTC 2006
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))))
+ , at 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))))
+ , at 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*))))
More information about the Graphic-forms-cvs
mailing list