[graphic-forms-cvs] r395 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Nov 17 19:34:42 UTC 2006
Author: junrue
Date: Fri Nov 17 14:34:40 2006
New Revision: 395
Modified:
trunk/docs/manual/gfw-symbols.xml
trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp
trunk/src/tests/uitoolkit/test-utils.lisp
trunk/src/uitoolkit/widgets/border-layout.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/src/uitoolkit/widgets/widget-constants.lisp
Log:
rewrote border-layout; added unit-test cases
Modified: trunk/docs/manual/gfw-symbols.xml
==============================================================================
--- trunk/docs/manual/gfw-symbols.xml (original)
+++ trunk/docs/manual/gfw-symbols.xml Fri Nov 17 14:34:40 2006
@@ -98,7 +98,11 @@
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>.
+ secondary axis is determined by <reftopic>gfw:preferred-size</reftopic>. When
+ positive <emphasis>width-hint</emphasis> and/or <emphasis>height-hint</emphasis>
+ values are provided to <reftopic>gfw:layout</reftopic>, the available space
+ is parceled out in amounts proportional to the preferred sizes for each
+ component.
</para>
</description>
<initargs>
Modified: trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/border-layout-unit-tests.lisp Fri Nov 17 14:34:40 2006
@@ -33,32 +33,66 @@
(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*)))
-
-(defvar *outer-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*)
+(defvar *all-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
+ (make-instance 'mock-widget :min-size *child-size-2*) ; right
+ (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
+ (make-instance 'mock-widget :min-size *child-size-2*) ; left
+ (make-instance 'mock-widget :min-size *child-size-3*))) ; center
+
+(defvar *outer-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
+ (make-instance 'mock-widget :min-size *child-size-2*) ; right
+ (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
+ (make-instance 'mock-widget :min-size *child-size-2*) ; left
nil))
+(defvar *top-right-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
+ (make-instance 'mock-widget :min-size *child-size-2*) ; right
+ nil nil nil))
+
+(defvar *top-bottom-border-kids* (list (make-instance 'mock-widget :min-size *child-size-1*) ; top
+ nil
+ (make-instance 'mock-widget :min-size *child-size-1*) ; bottom
+ nil nil))
+
(defvar *center-border-kid* (list nil nil nil nil
(make-instance 'mock-widget :min-size *child-size-3*)))
+;;;
+;;; NOTE: the rects to be validated in each test must be specified in the
+;;; the following order: center, top, left, bottom, right
+;;;
+
(define-layout-test border-layout-test1
-1 -1 80 50
- '((0 45 80 5) (60 5 20 40) (0 5 20 40) (0 0 80 5) (20 5 40 40))
+ '((20 5 40 40) (0 0 80 5) (0 5 20 40) (0 45 80 5) (60 5 20 40))
#'make-border-layout *all-border-kids*)
(define-layout-test border-layout-test2
-1 -1 40 20
- '((0 15 40 5) (20 5 20 10) (0 5 20 10) (0 0 40 5))
+ '((0 0 40 5) (0 5 20 10) (0 15 40 5) (20 5 20 10))
#'make-border-layout *outer-border-kids*)
(define-layout-test border-layout-test3
-1 -1 40 40
'((0 0 40 40))
#'make-border-layout *center-border-kid*)
+
+(define-layout-test border-layout-test4
+ -1 -1 25 15
+ '((0 0 25 5) (0 5 20 10))
+ #'make-border-layout *top-right-border-kids*)
+
+(define-layout-test border-layout-test5
+ -1 -1 25 10
+ '((0 0 25 5) (0 5 25 5))
+ #'make-border-layout *top-bottom-border-kids*)
+
+(define-layout-test border-layout-test6
+ 26 -1 26 50
+ '((6 5 13 40) (0 0 26 5) (0 5 6 40) (0 45 26 5) (19 5 6 40))
+ #'make-border-layout *all-border-kids*)
+
+(define-layout-test border-layout-test7
+ -1 25 80 25
+ '((20 2 40 20) (0 0 80 2) (0 2 20 20) (0 22 80 2) (60 2 20 20))
+ #'make-border-layout *all-border-kids*)
Modified: trunk/src/tests/uitoolkit/test-utils.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/test-utils.lisp (original)
+++ trunk/src/tests/uitoolkit/test-utils.lisp Fri Nov 17 14:34:40 2006
@@ -59,21 +59,12 @@
(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))
+ (loop for kid in kids
+ for region in '(:top :left :bottom :right :center)
+ when kid
+ do (progn
+ (gfw::append-layout-item layout kid)
+ (setf (gfw:layout-attribute layout kid region) t)))
layout))
(defun validate-image (image expected-size expected-depth)
Modified: trunk/src/uitoolkit/widgets/border-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/border-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/border-layout.lisp Fri Nov 17 14:34:40 2006
@@ -37,67 +37,128 @@
;;; 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)))))
+ (defstruct borders layout hint-size inside-size outer-size
+ pref-top-height pref-left-width pref-right-width pref-bottom-height
+ center-widget top-widget left-widget bottom-widget right-widget
+ center-rect top-rect left-rect bottom-rect right-rect))
+
+(defun map-border-rects (data map-func)
+ (loop for region in '(center top left bottom right)
+ for sym = (symbol-name region)
+ for widget-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-WIDGET") :gfw)
+ for rect-acc = (find-symbol (concatenate 'string "BORDERS-" sym "-RECT") :gfw)
+ for widget = (funcall widget-acc data)
+ when widget
+ collect (funcall map-func widget (funcall rect-acc data))))
+
+(defun init-borders (layout width-hint height-hint)
+ (let* ((data (make-borders
+ :layout layout
+ :hint-size (gfs:make-size :width width-hint
+ :height height-hint)
+ :center-widget (first (first (obtain-children-with-attribute layout :center)))
+ :top-widget (first (first (obtain-children-with-attribute layout :top)))
+ :left-widget (first (first (obtain-children-with-attribute layout :left)))
+ :bottom-widget (first (first (obtain-children-with-attribute layout :bottom)))
+ :right-widget (first (first (obtain-children-with-attribute layout :right)))))
+ (c-size (if (borders-center-widget data)
+ (preferred-size (borders-center-widget data) -1 -1)
+ (gfs:size *empty-rect*)))
+ (t-size (if (borders-top-widget data)
+ (preferred-size (borders-top-widget data) -1 -1)
+ (gfs:size *empty-rect*)))
+ (l-size (if (borders-left-widget data)
+ (preferred-size (borders-left-widget data) -1 -1)
+ (gfs:size *empty-rect*)))
+ (b-size (if (borders-bottom-widget data)
+ (preferred-size (borders-bottom-widget data) -1 -1)
+ (gfs:size *empty-rect*)))
+ (r-size (if (borders-right-widget data)
+ (preferred-size (borders-right-widget data) -1 -1)
+ (gfs:size *empty-rect*))))
+ (setf (borders-pref-top-height data) (gfs:size-height t-size)
+ (borders-pref-left-width data) (gfs:size-width l-size)
+ (borders-pref-right-width data) (gfs:size-width r-size)
+ (borders-pref-bottom-height data) (gfs:size-height b-size))
+ (setf (borders-inside-size data)
+ (gfs:make-size :width (max (gfs:size-width c-size)
+ (- (gfs:size-width t-size)
+ (gfs:size-width l-size)
+ (gfs:size-width r-size))
+ (- (gfs:size-width b-size)
+ (gfs:size-width l-size)
+ (gfs:size-width r-size)))
+ :height (max (gfs:size-height l-size)
+ (gfs:size-height c-size)
+ (gfs:size-height r-size))))
+ (setf (borders-outer-size data)
+ (gfs:make-size :width (max (gfs:size-width t-size)
+ (gfs:size-width b-size)
+ (+ (gfs:size-width l-size)
+ (gfs:size-width c-size)
+ (gfs:size-width r-size)))
+ :height (+ (gfs:size-height t-size)
+ (gfs:size-height (borders-inside-size data))
+ (gfs:size-height b-size))))
+ data))
+
+(defun top-border-rect (data)
+ (unless (borders-top-widget data)
+ (return-from top-border-rect *empty-rect*))
+ (or (borders-top-rect data)
+ (setf (borders-top-rect data)
+ (gfs:create-rectangle :width (gfs:size-width (borders-outer-size data))
+ :height (borders-pref-top-height data)))))
+
+(defun bottom-border-rect (data)
+ (unless (borders-bottom-widget data)
+ (return-from bottom-border-rect *empty-rect*))
+ (or (borders-bottom-rect data)
+ (let ((ypos (- (gfs:size-height (borders-outer-size data))
+ (borders-pref-bottom-height data))))
+ (setf (borders-bottom-rect data)
+ (gfs:create-rectangle :y ypos
+ :width (gfs:size-width (borders-outer-size data))
+ :height (borders-pref-bottom-height data))))))
+
+(defun left-border-rect (data)
+ (unless (borders-left-widget data)
+ (return-from left-border-rect *empty-rect*))
+ (or (borders-left-rect data)
+ (let ((ypos (gfs:size-height (gfs:size (top-border-rect data))))
+ (inside-height (gfs:size-height (borders-inside-size data))))
+ (setf (borders-left-rect data)
+ (gfs:create-rectangle :y ypos
+ :width (borders-pref-left-width data)
+ :height inside-height)))))
+
+(defun right-border-rect (data)
+ (unless (borders-right-widget data)
+ (return-from right-border-rect *empty-rect*))
+ (or (borders-right-rect data)
+ (let ((xpos (+ (gfs:size-width (gfs:size (left-border-rect data)))
+ (gfs:size-width (gfs:size (center-border-rect data)))))
+ (ypos (gfs:size-height (gfs:size (top-border-rect data))))
+ (inside-height (gfs:size-height (borders-inside-size data))))
+ (setf (borders-right-rect data)
+ (gfs:create-rectangle :x xpos
+ :y ypos
+ :width (borders-pref-right-width data)
+ :height inside-height)))))
+
+(defun center-border-rect (data)
+ (unless (borders-center-widget data)
+ (return-from center-border-rect *empty-rect*))
+ (or (borders-center-rect data)
+ (let ((xpos (gfs:size-width (gfs:size (left-border-rect data))))
+ (ypos (gfs:size-height (gfs:size (top-border-rect data))))
+ (size (borders-inside-size data)))
+ (setf (borders-center-rect data)
+ (gfs:create-rectangle :x xpos
+ :y ypos
+ :width (gfs:size-width size)
+ :height (gfs:size-height size))))))
;;;
;;; methods
@@ -105,59 +166,28 @@
(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)))))
+ (let ((size (borders-outer-size (init-borders self width-hint height-hint))))
(if (>= width-hint 0)
- (setf (gfs:size-width layout-size) width-hint))
+ (setf (gfs:size-width size) width-hint))
(if (>= height-hint 0)
- (setf (gfs:size-height layout-size) height-hint))
- layout-size))
+ (setf (gfs:size-height size) height-hint))
+ 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))
+ (let ((data (init-borders self width-hint height-hint)))
+ (loop for func in (list #'top-border-rect #'bottom-border-rect
+ #'left-border-rect #'right-border-rect
+ #'center-border-rect)
+ do (funcall func data))
+ (if (or (>= width-hint 0) (>= height-hint 0))
+ (let ((total-size (borders-outer-size data))
+ (hint-size (gfs:make-size :width width-hint :height height-hint)))
+ (map-border-rects data
+ (lambda (widget rect)
+ (declare (ignore widget))
+ (let ((pnt (gfs:location rect))
+ (size (gfs:size rect)))
+ (setf (gfs:location rect) (scale-point total-size hint-size pnt)
+ (gfs:size rect) (scale-size total-size hint-size size)))))))
+ (map-border-rects data #'cons)))
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Fri Nov 17 14:34:40 2006
@@ -70,6 +70,37 @@
(defun cleanup-disposed-items (layout)
(setf (data-of layout) (remove-if #'gfs:disposed-p (data-of layout) :key #'first)))
+(declaim (inline scale-coord))
+(defun scale-coord (total hint orig-value)
+ (if (and (> total 0) (>= hint 0))
+ (floor (* (/ hint total) orig-value))
+ orig-value))
+
+(declaim (inline scale-point))
+(defun scale-point (total-size hint-size orig-pnt)
+ (gfs:make-point :x (scale-coord (gfs:size-width total-size)
+ (gfs:size-width hint-size)
+ (gfs:point-x orig-pnt))
+ :y (scale-coord (gfs:size-height total-size)
+ (gfs:size-height hint-size)
+ (gfs:point-y orig-pnt))))
+
+(declaim (inline scale-size))
+(defun scale-size (total-size hint-size orig-size)
+ (gfs:make-size :width (scale-coord (gfs:size-width total-size)
+ (gfs:size-width hint-size)
+ (gfs:size-width orig-size))
+ :height (scale-coord (gfs:size-height total-size)
+ (gfs:size-height hint-size)
+ (gfs:size-height orig-size))))
+
+(declaim (inline scale-rectangle))
+(defun scale-rectangle (total-size hint-size orig-rect)
+ (let ((pnt (gfs:location orig-rect))
+ (size (gfs:size orig-rect)))
+ (gfs:make-rectangle :location (scale-point total-size hint-size pnt)
+ :size (scale-size total-size hint-size size))))
+
(defun arrange-hwnds (kid-specs flags-func)
(let ((hdwp (gfs::begin-defer-window-pos (length kid-specs))))
(loop for k in kid-specs
Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-constants.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-constants.lisp Fri Nov 17 14:34:40 2006
@@ -105,3 +105,5 @@
gfs::+swp-noownerzorder+
gfs::+swp-noactivate+
gfs::+swp-nocopybits+)))
+
+(defvar *empty-rect* (gfs:make-rectangle))
More information about the Graphic-forms-cvs
mailing list