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)))) - ,@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))))) + (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))