[graphic-forms-cvs] r147 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Jun 4 06:16:20 UTC 2006
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.
+ at 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)
More information about the Graphic-forms-cvs
mailing list