Author: junrue Date: Sun Jun 4 02:16:18 2006 New Revision: 147 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp Log: refactored flow-layout implementation, added initial code for :normalize style; still buggy Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jun 4 02:16:18 2006 @@ -602,7 +602,10 @@ style keywords: @table @code @item :horizontal -Specifies arrangement in a horizontal row. This style is the default. +Specifies arrangement in a horizontal row. This arrangement is the default. +@item :normalize +Instructs the @code{flow-layout} to size the children equally using the +maximum dimensions of the preferred sizes of all the children. @item :vertical Specifies arrangement in a vertical column. @item :wrap Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jun 4 02:16:18 2006 @@ -470,6 +470,7 @@ #:style-of #:sub-menu #:text + #:text-baseline #:text-height #:text-limit #:thumb-size Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Jun 4 02:16:18 2006 @@ -205,6 +205,15 @@ (setf (gfw:style-of layout) style) (gfw:layout *layout-tester-win*))) +(defun set-flow-layout-normalize (disp item time rect) + (declare (ignorable disp item time rect)) + (let* ((layout (gfw:layout-of *layout-tester-win*)) + (style (gfw:style-of layout))) + (if (find :normalize style) + (setf (gfw:style-of layout) (remove :normalize style)) + (setf (gfw:style-of layout) (push :normalize style))) + (gfw:layout *layout-tester-win*))) + (defun set-flow-layout-wrap (disp item time rect) (declare (ignorable disp item time rect)) (let* ((layout (gfw:layout-of *layout-tester-win*)) @@ -341,8 +350,11 @@ (gfw:append-submenu menu "Margin" margin-menu nil) (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-items) (gfw:append-submenu menu "Spacing" spacing-menu #'enable-flow-spacing-items) - (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) - (gfw:check it (find :wrap (gfw:style-of (gfw:layout-of *layout-tester-win*)))))) + (let ((style (gfw:style-of (gfw:layout-of *layout-tester-win*)))) + (setf it (gfw:append-item menu "Normalize" nil #'set-flow-layout-normalize)) + (gfw:check it (find :normalize style)) + (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap)) + (gfw:check it (find :wrap style))))) (defun exit-layout-callback (disp item time rect) (declare (ignorable disp item time rect)) 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 Sun Jun 4 02:16:18 2006 @@ -33,25 +33,30 @@ (in-package :graphic-forms.uitoolkit.tests) -(defvar *minsize1* (gfs:make-size :width 20 :height 10)) -(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*) - (make-instance 'mock-widget :min-size *minsize1*))) +(defvar *large-size* (gfs:make-size :width 25 :height 5)) +(defvar *small-size* (gfs:make-size :width 20 :height 10)) +(defvar *flow-layout-uniform-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *small-size*))) +(defvar *flow-layout-mixed-kids* (list (make-instance 'mock-widget :min-size *small-size*) + (make-instance 'mock-widget :min-size *large-size*) + (make-instance 'mock-widget :min-size *small-size*))) (defun validate-layout-rects (entries expected-rects) (let ((actual-rects (loop for entry in entries collect (cdr entry)))) (mapc #'(lambda (expected actual) (let ((pnt-a (gfs:location actual)) (sz-a (gfs:size actual))) - (assert-equal (gfs:point-x pnt-a) (first expected)) - (assert-equal (gfs:point-y pnt-a) (second expected)) - (assert-equal (gfs:size-width sz-a) (third expected)) - (assert-equal (gfs:size-height sz-a) (fourth expected)))) + (assert-equal (first expected) (gfs:point-x pnt-a)) + (assert-equal (second expected) (gfs:point-y pnt-a)) + (assert-equal (third expected) (gfs:size-width sz-a)) + (assert-equal (fourth expected) (gfs:size-height sz-a)))) expected-rects actual-rects))) (define-test flow-layout-test1 ;; orient: horizontal + ;; normalize: disabled ;; wrap: disabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -68,6 +73,7 @@ (define-test flow-layout-test2 ;; orient: vertical + ;; normalize: disabled ;; wrap: disabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -84,6 +90,7 @@ (define-test flow-layout-test3 ;; orient: horizontal + ;; normalize: disabled ;; wrap: enabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -97,6 +104,7 @@ (define-test flow-layout-test4 ;; orient: vertical + ;; normalize: disabled ;; wrap: enabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -110,6 +118,7 @@ (define-test flow-layout-test5 ;; orient: horizontal + ;; normalize: disabled ;; wrap: enabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -123,6 +132,7 @@ (define-test flow-layout-test6 ;; orient: vertical + ;; normalize: disabled ;; wrap: enabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -136,6 +146,7 @@ (define-test flow-layout-test7 ;; orient: horizontal + ;; normalize: disabled ;; wrap: disabled ;; spacing: 4 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -152,6 +163,7 @@ (define-test flow-layout-test8 ;; orient: vertical + ;; normalize: disabled ;; wrap: disabled ;; spacing: 4 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -168,6 +180,7 @@ (define-test flow-layout-test9 ;; orient: horizontal + ;; normalize: disabled ;; wrap: enabled ;; spacing: 4 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -181,6 +194,7 @@ (define-test flow-layout-test10 ;; orient: vertical + ;; normalize: disabled ;; wrap: enabled ;; spacing: 4 ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 @@ -194,6 +208,7 @@ (define-test flow-layout-test11 ;; orient: horizontal + ;; normalize: disabled ;; wrap: disabled ;; spacing: 0 ;; left-margin: 3, top-margin: 3, right-margin: 0, bottom-margin: 0 @@ -213,6 +228,7 @@ (define-test flow-layout-test12 ;; orient: vertical + ;; normalize: disabled ;; wrap: disabled ;; spacing: 0 ;; left-margin: 0, top-margin: 0, right-margin: 3, bottom-margin: 3 @@ -229,3 +245,37 @@ (assert-equal 23 (gfs:size-width size)) (assert-equal 33 (gfs:size-height size)) (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test13 + ;; orient: horizontal + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :normalize))) + (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) + (expected-rects '((0 0 25 10) (25 0 25 10) (50 0 25 10)))) + (assert-equal 75 (gfs:size-width size)) + (assert-equal 10 (gfs:size-height size)) + (validate-layout-rects data expected-rects))) + +(define-test flow-layout-test14 + ;; orient: vertical + ;; normalize: enabled + ;; wrap: disabled + ;; spacing: 0 + ;; left-margin: 0, top-margin: 0, right-margin: 0, bottom-margin: 0 + ;; container: unrestricted width and height + ;; kids: mixed + ;; + (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :normalize))) + (size (gfw::flow-container-size layout t *flow-layout-mixed-kids* -1 -1)) + (data (gfw::flow-container-layout layout t *flow-layout-mixed-kids* -1 -1)) + (expected-rects '((0 0 25 10) (0 10 25 10) (0 20 25 10)))) + (assert-equal 25 (gfs:size-width size)) + (assert-equal 30 (gfs:size-height size)) + (validate-layout-rects data expected-rects))) Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Jun 4 02:16:18 2006 @@ -60,6 +60,9 @@ (defmethod initialize-instance :after ((widget mock-widget) &key) (setf (slot-value widget 'gfs:handle) (cffi:make-pointer #xFFFFFFFF))) +(defmethod gfw:location ((widget mock-widget)) + (gfs:make-point)) + (defmethod gfw:minimum-size ((widget mock-widget)) (gfs:make-size :width (gfs:size-width (min-size-of widget)) :height (gfs:size-height (min-size-of widget)))) @@ -75,5 +78,8 @@ (setf (gfs:size-height size) height-hint)) size)) +(defmethod gfw:text-baseline ((widget mock-widget)) + (floor (/ (* (gfs:size-height (min-size-of widget)) 3) 4))) + (defmethod gfw:visible-p ((widget mock-widget)) (visibility-of widget)) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Jun 4 02:16:18 2006 @@ -37,89 +37,143 @@ ;;; helper functions ;;; -(defun flow-container-size (layout win-visible kids width-hint height-hint) - (let ((max -1) - (total 0) - (vert-orient (find :vertical (style-of layout)))) +(defun flow-container-size (layout visible kids width-hint height-hint) + (let ((kid-count (length kids)) + (vertical (find :vertical (style-of layout))) + (horizontal (find :horizontal (style-of layout))) + (normal (find :normalize (style-of layout))) + (horz-max 0) + (horz-total 0) + (vert-max 0) + (vert-total 0)) (loop for kid in kids - do (let ((size (preferred-size kid - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint)))) - (when (or (visible-p kid) (not win-visible)) - (if vert-orient - (progn - (incf total (gfs:size-height size)) - (if (< max (gfs:size-width size)) - (setf max (gfs:size-width size)))) - (progn - (incf total (gfs:size-width size)) - (if (< max (gfs:size-height size)) - (setf max (gfs:size-height size)))))))) - (unless (null kids) - (incf total (* (spacing-of layout) (1- (length kids))))) - (if vert-orient - (progn - (incf max (+ (left-margin-of layout) (right-margin-of layout))) - (incf total (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfs:make-size :width max :height total)) - (progn - (incf total (+ (left-margin-of layout) (right-margin-of layout))) - (incf max (+ (top-margin-of layout) (bottom-margin-of layout))) - (gfs:make-size :width total :height max))))) + do (let* ((size (preferred-size kid + (if vertical width-hint -1) + (if vertical -1 height-hint))) + (width (gfs:size-width size)) + (height (gfs:size-height size))) + (when (or (visible-p kid) (not visible)) + (incf horz-total width) + (incf vert-total height) + (if (< vert-max height) + (setf vert-max height)) + (if (< horz-max width) + (setf horz-max width))))) + (if (and normal vertical) + (setf vert-total (* vert-max kid-count)) + (if (and normal horizontal) + (setf horz-total (* horz-max kid-count)))) + (let ((spacing-total (* (spacing-of layout) (1- kid-count))) + (horz-margin-total (+ (left-margin-of layout) (right-margin-of layout))) + (vert-margin-total (+ (top-margin-of layout) (bottom-margin-of layout)))) + (cond + (vertical + (gfs:make-size :width (+ horz-max horz-margin-total) + :height (+ vert-total spacing-total vert-margin-total))) + (horizontal + (gfs:make-size :width (+ horz-total spacing-total horz-margin-total) + :height (+ vert-max vert-margin-total))) + (t + (error 'gfs:toolkit-error + :detail (format nil "unrecognized flow layout style: ~a" (style-of layout)))))))) + +(defstruct flow-data + (hint 0) + (kid-sizes nil) + (max-extent 0) + (max-distance 0) + (next-coord 0) + (wrap-coord 0) + (spacing 0) + (distance-fn nil) + (extent-fn nil) + (limit-margin-fn nil) + (start-margin-fn nil) + (current nil)) + +(defun init-flow-data (layout visible kids width-hint height-hint) + (let ((state (if (find :vertical (style-of layout)) + (make-flow-data :hint height-hint + :next-coord (top-margin-of layout) + :wrap-coord (left-margin-of layout) + :spacing (spacing-of layout) + :distance-fn #'gfs:size-height + :extent-fn #'gfs:size-width + :limit-margin-fn #'bottom-margin-of + :start-margin-fn #'top-margin-of) + (make-flow-data :hint width-hint + :next-coord (left-margin-of layout) + :wrap-coord (top-margin-of layout) + :spacing (spacing-of layout) + :distance-fn #'gfs:size-width + :extent-fn #'gfs:size-height + :limit-margin-fn #'right-margin-of + :start-margin-fn #'left-margin-of)))) + (loop for kid in kids + when (or (visible-p kid) (not visible)) + do (let* ((size (preferred-size kid -1 -1)) + (dist (funcall (flow-data-distance-fn state) size)) + (extent (funcall (flow-data-extent-fn state) size))) + (if (< (flow-data-max-distance state) dist) + (setf (flow-data-max-distance state) dist)) + (if (< (flow-data-max-extent state) extent) + (setf (flow-data-max-extent state) extent)) + (push (list kid size) (flow-data-kid-sizes state)))) + (nreverse (flow-data-kid-sizes state)) + state)) + +(defun wrap-needed-p (state layout kid-size) + (and (>= (flow-data-hint state) 0) + (> (+ (flow-data-next-coord state) + (funcall (flow-data-distance-fn state) kid-size) + (funcall (flow-data-limit-margin-fn state) layout)) + (flow-data-hint state)))) + +(defun wrap-flow (state layout) + (let ((curr-flow (flow-data-current state))) + (setf (flow-data-current state) nil) + (setf (flow-data-next-coord state) (funcall (flow-data-start-margin-fn state) layout)) + (incf (flow-data-wrap-coord state) (+ (flow-data-max-extent state) (flow-data-spacing state))) + (setf (flow-data-max-extent state) 0) + (reverse curr-flow))) + +(defun new-flow-element (state layout kid kid-size) + (let ((pnt (gfs:make-point)) + (vertical (find :vertical (style-of layout))) + (normal (find :normalize (style-of layout)))) + (cond + ((and vertical normal) + (setf (gfs:point-x pnt) (flow-data-wrap-coord state) + (gfs:point-y pnt) (flow-data-next-coord state)) + (setf (gfs:size-width kid-size) (flow-data-max-extent state) + (gfs:size-height kid-size) (flow-data-max-distance state))) + ((and vertical (not normal)) + (setf (gfs:point-x pnt) (flow-data-wrap-coord state) + (gfs:point-y pnt) (flow-data-next-coord state))) + ((and (not vertical) normal) + (setf (gfs:point-x pnt) (flow-data-next-coord state) + (gfs:point-y pnt) (flow-data-wrap-coord state)) + (setf (gfs:size-width kid-size) (flow-data-max-distance state) + (gfs:size-height kid-size) (flow-data-max-extent state))) + ((and (not vertical) (not normal)) + (setf (gfs:point-x pnt) (flow-data-next-coord state) + (gfs:point-y pnt) (flow-data-wrap-coord state)))) + (incf (flow-data-next-coord state) (+ (funcall (flow-data-distance-fn state) kid-size) + (flow-data-spacing state))) + (cons kid (make-instance 'gfs:rectangle :size kid-size :location pnt)))) (defun flow-container-layout (layout visible kids width-hint height-hint) - (let* ((flows nil) - (curr-flow nil) - (spacing (spacing-of layout)) - (style (style-of layout)) - (vert-orient (find :vertical style)) - (wrap (find :wrap style)) - (max-size -1) - (next-coord (if vert-orient (top-margin-of layout) (left-margin-of layout))) - (wrap-coord (if vert-orient (left-margin-of layout) (top-margin-of layout)))) - (loop for kid in kids - do (let ((size (preferred-size kid -1 -1)) - (pnt (gfs:make-point))) - (when (or (visible-p kid) (not visible)) - (if vert-orient - (progn - (when (and wrap - (>= height-hint 0) - (> (+ next-coord - (gfs:size-height size) - (bottom-margin-of layout)) - height-hint)) - (push (reverse curr-flow) flows) - (setf curr-flow nil) - (setf next-coord (top-margin-of layout)) - (incf wrap-coord (+ max-size spacing)) - (setf max-size -1)) - (setf (gfs:point-x pnt) wrap-coord) - (setf (gfs:point-y pnt) next-coord) - (if (< max-size (gfs:size-width size)) - (setf max-size (gfs:size-width size))) - (incf next-coord (+ (gfs:size-height size) spacing))) - (progn - (when (and wrap - (>= width-hint 0) - (> (+ next-coord - (gfs:size-width size) - (right-margin-of layout)) - width-hint)) - (push (reverse curr-flow) flows) - (setf curr-flow nil) - (setf next-coord (left-margin-of layout)) - (incf wrap-coord (+ max-size spacing)) - (setf max-size -1)) - (setf (gfs:point-x pnt) next-coord) - (setf (gfs:point-y pnt) wrap-coord) - (if (< max-size (gfs:size-height size)) - (setf max-size (gfs:size-height size))) - (incf next-coord (+ (gfs:size-width size) spacing)))) - (push (cons kid (make-instance 'gfs:rectangle :size size :location pnt)) curr-flow)))) - (unless (null curr-flow) - (push (reverse curr-flow) flows)) - (loop for flow in (nreverse flows) append flow))) + (let ((flows nil) + (state (init-flow-data layout visible kids width-hint height-hint)) + (max-distance 0)) + (loop with wrap = (find :wrap (style-of layout)) + for (kid kid-size) in (flow-data-kid-sizes state) + do (if (and wrap (wrap-needed-p state layout kid-size)) + (setf flows (append flows (wrap-flow state layout)))) + (push (new-flow-element state layout kid kid-size) (flow-data-current state))) + (if (flow-data-current state) + (setf flows (append flows (wrap-flow state layout)))) + flows)) ;;; ;;; methods @@ -131,7 +185,6 @@ (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) (with-children (win kids) - #+gf-debug-widgets (format t "compute-layout: ~a~%~a~%" win kids) (flow-container-layout layout (visible-p win) kids width-hint height-hint))) (defmethod initialize-instance :after ((layout flow-layout) &key)