[graphic-forms-cvs] r38 - in trunk/src: tests/uitoolkit uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Mar 14 04:37:44 UTC 2006
Author: junrue
Date: Mon Mar 13 23:37:44 2006
New Revision: 38
Modified:
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/uitoolkit/widgets/flow-layout.lisp
Log:
implemented wrap style for flow layout; refactored flow layout unit tests
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Mar 13 23:37:44 2006
@@ -165,14 +165,29 @@
(defun set-flow-horizontal (disp item time rect)
(declare (ignorable disp item time rect))
- (let ((layout (gfw:layout-manager *layout-tester-win*)))
- (setf (gfw:style-of layout) (list :horizontal))
+ (let* ((layout (gfw:layout-manager *layout-tester-win*))
+ (style (gfw:style-of layout)))
+ (setf style (remove :vertical style))
+ (push :horizontal style)
+ (setf (gfw:style-of layout) style)
(gfw:layout *layout-tester-win*)))
(defun set-flow-vertical (disp item time rect)
(declare (ignorable disp item time rect))
- (let ((layout (gfw:layout-manager *layout-tester-win*)))
- (setf (gfw:style-of layout) (list :vertical))
+ (let* ((layout (gfw:layout-manager *layout-tester-win*))
+ (style (gfw:style-of layout)))
+ (setf style (remove :horizontal style))
+ (push :vertical style)
+ (setf (gfw:style-of layout) 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-manager *layout-tester-win*))
+ (style (gfw:style-of layout)))
+ (if (find :wrap style)
+ (setf (gfw:style-of layout) (remove :wrap style))
+ (setf (gfw:style-of layout) (push :wrap style)))
(gfw:layout *layout-tester-win*)))
(defun flow-mod-callback (disp menu time)
@@ -200,9 +215,8 @@
(gfw:append-submenu menu "Margin" margin-menu nil)
(gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item)
(gfw:append-submenu menu "Spacing" spacing-menu nil)
- (setf it (gfw:append-item menu "Fill" nil nil))
- (gfw:check it t)
- (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))
+ (setf it (gfw:append-item menu "Wrap" nil #'set-flow-layout-wrap))
+ (gfw:check it (find :wrap (gfw:style-of (gfw:layout-manager *layout-tester-win*))))))
(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 Mon Mar 13 23:37:44 2006
@@ -34,50 +34,90 @@
(in-package :graphic-forms.uitoolkit.tests)
(defvar *minsize1* (gfi:make-size :width 20 :height 10))
-(defvar *flow-layout-kids1* (list (make-instance 'mock-widget :min-size *minsize1*)
- (make-instance 'mock-widget :min-size *minsize1*)
- (make-instance 'mock-widget :min-size *minsize1*)))
-
-(defun validate-layout-points (actual-entries expected-pnts)
- (mapc #'(lambda (pnt entry)
- (let ((pnt2 (gfi:location (cdr entry))))
- (assert-true (and (= (gfi:point-x pnt) (gfi:point-x pnt2))
- (= (gfi:point-y pnt) (gfi:point-y pnt2))))))
- expected-pnts
- actual-entries))
+(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*)))
+
+(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 (gfi:location actual))
+ (sz-a (gfi:size actual)))
+ (assert-equal (gfi:point-x pnt-a) (first expected))
+ (assert-equal (gfi:point-y pnt-a) (second expected))
+ (assert-equal (gfi:size-width sz-a) (third expected))
+ (assert-equal (gfi:size-height sz-a) (fourth expected))))
+ expected-rects
+ actual-rects)))
(define-test flow-layout-test1
;; orient: horizontal
;; wrap: disabled
- ;; fill: disabled
- ;; container: visible
+ ;; container: unrestricted width and height
;; kids: uniform
;;
(let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal)))
- (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1))
- (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1))
- (expected-pnts nil))
- (push (gfi:make-point :x 40 :y 0) expected-pnts)
- (push (gfi:make-point :x 20 :y 0) expected-pnts)
- (push (gfi:make-point :x 0 :y 0) expected-pnts)
+ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (40 0 20 10))))
(assert-equal 60 (gfi:size-width size))
(assert-equal 10 (gfi:size-height size))
- (validate-layout-points actual expected-pnts)))
+ (validate-layout-rects data expected-rects)))
(define-test flow-layout-test2
;; orient: vertical
;; wrap: disabled
- ;; fill: disabled
- ;; container: visible
+ ;; container: unrestricted width and height
;; kids: uniform
;;
(let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical)))
- (size (gfw::flow-container-size layout t *flow-layout-kids1* -1 -1))
- (actual (gfw::flow-container-layout layout t *flow-layout-kids1* -1 -1))
- (expected-pnts nil))
- (push (gfi:make-point :x 0 :y 20) expected-pnts)
- (push (gfi:make-point :x 0 :y 10) expected-pnts)
- (push (gfi:make-point :x 0 :y 0) expected-pnts)
+ (size (gfw::flow-container-size layout t *flow-layout-uniform-kids* -1 -1))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 -1))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (0 20 20 10))))
(assert-equal 20 (gfi:size-width size))
(assert-equal 30 (gfi:size-height size))
- (validate-layout-points actual expected-pnts)))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test3
+ ;; orient: horizontal
+ ;; wrap: enabled
+ ;; container: restricted width, unrestricted height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 -1))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test4
+ ;; orient: vertical
+ ;; wrap: enabled
+ ;; container: unrestricted width, restricted height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* -1 25))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test5
+ ;; orient: horizontal
+ ;; wrap: enabled
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :style '(:horizontal :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 45 18))
+ (expected-rects '((0 0 20 10) (20 0 20 10) (0 10 20 10))))
+ (validate-layout-rects data expected-rects)))
+
+(define-test flow-layout-test6
+ ;; orient: vertical
+ ;; wrap: enabled
+ ;; container: restricted width and height
+ ;; kids: uniform
+ ;;
+ (let* ((layout (make-instance 'gfw:flow-layout :style '(:vertical :wrap)))
+ (data (gfw::flow-container-layout layout t *flow-layout-uniform-kids* 30 25))
+ (expected-rects '((0 0 20 10) (0 10 20 10) (20 0 20 10))))
+ (validate-layout-rects data expected-rects)))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/flow-layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Mar 13 23:37:44 2006
@@ -59,35 +59,52 @@
(gfi:make-size :width max :height total)
(gfi:make-size :width total :height max))))
-(defun flow-container-layout (layout win-visible kids width-hint height-hint)
- (let ((entries nil)
- (last-coord 0)
- (last-dim 0)
- (vert-orient (find :vertical (style-of layout))))
+(defun flow-container-layout (layout visible kids width-hint height-hint)
+ (let* ((flows nil)
+ (curr-flow nil)
+ (max-size -1)
+ (next-coord 0)
+ (wrap-coord 0)
+ (style (style-of layout))
+ (vert-orient (find :vertical style))
+ (wrap (find :wrap style)))
(loop for kid in kids
- do (let ((size (preferred-size kid
- (if vert-orient width-hint -1)
- (if vert-orient -1 height-hint)))
+ do (let ((size (preferred-size kid -1 -1))
(pnt (gfi:make-point)))
- (when (or (visible-p kid) (not win-visible))
+ (when (or (visible-p kid) (not visible))
(if vert-orient
(progn
- (setf (gfi:point-y pnt) (+ last-coord last-dim))
- (if (>= width-hint 0)
- (setf (gfi:size-width size) width-hint))
- (setf last-coord (gfi:point-y pnt))
- (setf last-dim (gfi:size-height size)))
+ (when (and wrap
+ (>= height-hint 0)
+ (> (+ next-coord (gfi:size-height size)) height-hint))
+ (push (reverse curr-flow) flows)
+ (setf curr-flow nil)
+ (setf next-coord 0)
+ (incf wrap-coord max-size)
+ (setf max-size -1))
+ (setf (gfi:point-x pnt) wrap-coord)
+ (setf (gfi:point-y pnt) next-coord)
+ (if (< max-size (gfi:size-width size))
+ (setf max-size (gfi:size-width size)))
+ (incf next-coord (gfi:size-height size)))
(progn
- (setf (gfi:point-x pnt) (+ last-coord last-dim))
- (if (>= height-hint 0)
- (setf (gfi:size-height size) height-hint))
- (setf last-coord (gfi:point-x pnt))
- (setf last-dim (gfi:size-width size))))
- (push (cons kid (make-instance 'gfi:rectangle
- :size size
- :location pnt))
- entries))))
- (nreverse entries)))
+ (when (and wrap
+ (>= width-hint 0)
+ (> (+ next-coord (gfi:size-width size)) width-hint))
+ (push (reverse curr-flow) flows)
+ (setf curr-flow nil)
+ (setf next-coord 0)
+ (incf wrap-coord max-size)
+ (setf max-size -1))
+ (setf (gfi:point-x pnt) next-coord)
+ (setf (gfi:point-y pnt) wrap-coord)
+ (if (< max-size (gfi:size-height size))
+ (setf max-size (gfi:size-height size)))
+ (incf next-coord (gfi:size-width size))))
+ (push (cons kid (make-instance 'gfi:rectangle :size size :location pnt)) curr-flow))))
+ (unless (null curr-flow)
+ (push (reverse curr-flow) flows))
+ (loop for flow in (nreverse flows) append flow)))
;;;
;;; methods
@@ -105,5 +122,5 @@
(unless (listp style)
(setf style (list style)))
(if (and (null (find :horizontal style)) (null (find :vertical style)))
- (setf (style-of layout) '(:horizontal))
- (setf (style-of layout) style)))
+ (push :horizontal style))
+ (setf (style-of layout) style))
More information about the Graphic-forms-cvs
mailing list