Author: junrue Date: Sun Mar 12 19:19:36 2006 New Revision: 35
Added: trunk/src/intrinsics/datastructs/datastruct.lisp trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp - copied, changed from r32, trunk/src/uitoolkit/widgets/layouts.lisp Removed: trunk/src/uitoolkit/widgets/layouts.lisp Modified: trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/tests/uitoolkit/layout-tester.lisp trunk/tests.lisp Log: flow layout unit-test code; bug fixes for vertical flow layout style
Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Mar 12 19:19:36 2006 @@ -49,6 +49,8 @@ :components ((:module "uitoolkit" :components - ((:file "hello-world") + ((:file "mock-objects") + (:file "layout-unit-tests") + (:file "hello-world") (:file "event-tester") (:file "layout-tester")))))))))
Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Mar 12 19:19:36 2006 @@ -51,7 +51,8 @@ :components ((:module "datastructs" :components - ((:file "datastruct-classes"))) + ((:file "datastruct-classes") + (:file "datastruct"))) (:module "system" :components ((:file "native-classes") @@ -106,4 +107,5 @@ (:file "menu-language") (:file "event") (:file "window") - (:file "layouts"))))))))) + (:file "layout") + (:file "flow-layout")))))))))
Added: trunk/src/intrinsics/datastructs/datastruct.lisp ============================================================================== --- (empty file) +++ trunk/src/intrinsics/datastructs/datastruct.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; datastruct.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.intrinsics) + +(defmethod print-object ((obj rectangle) stream) + (print-unreadable-object (obj stream :type t) + (format stream "location: ~a size: ~a" (location obj) (size obj))))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 19:19:36 2006 @@ -157,6 +157,18 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*))))
+(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)) + (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)) + (gfw:layout *layout-tester-win*))) + (defun flow-mod-callback (disp menu time) (declare (ignore disp time)) (gfw:clear-all menu) @@ -173,8 +185,10 @@ (:item "Bottom" :submenu ((:item "Decrease") (:item "Increase")))))) - (orient-menu (gfw:defmenusystem ((:item "Horizontal") - (:item "Vertical")))) + (orient-menu (gfw:defmenusystem ((:item "Horizontal" + :callback #'set-flow-horizontal) + (:item "Vertical" + :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) (gfw:append-submenu menu "Margin" margin-menu)
Added: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,81 @@ +;;;; +;;;; layout-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(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)) + +(define-test flow-layout-test1 + ;; orient: horizontal + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:horizontal) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:horizontal) 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) + (assert-equal 60 (gfi:size-width size)) + (assert-equal 10 (gfi:size-height size)) + (validate-layout-points actual expected-pnts))) + +(define-test flow-layout-test2 + ;; orient: vertical + ;; wrap: disabled + ;; fill: disabled + ;; container: visible + ;; kids: uniform + ;; + (let* ((size (gfw::flow-container-size '(:vertical) t *flow-layout-kids1* -1 -1)) + (actual (gfw::flow-container-layout '(:vertical) 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) + (assert-equal 20 (gfi:size-width size)) + (assert-equal 30 (gfi:size-height size)) + (validate-layout-points actual expected-pnts)))
Added: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,79 @@ +;;;; +;;;; mock-objects.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +(defconstant +max-widget-size+ 5000) + +;;; +;;; stand-ins for widgets that would be children of windows, to be organized +;;; via layout managers +;;; + +(defclass mock-widget (gfw:widget) + ((visibility + :accessor visibility-of + :initform t) + (actual-size + :accessor actual-size-of + :initarg :actual-size + :initform (gfi:make-size)) + (max-size + :accessor max-size-of + :initarg :max-size + :initform (gfi:make-size :width +max-widget-size+ :height +max-widget-size+)) + (min-size + :accessor min-size-of + :initarg :min-size + :initform (gfi:make-size)))) + +(defmethod initialize-instance :after ((widget mock-widget) &key &allow-other-keys) + (setf (slot-value widget 'gfi:handle) (cffi:make-pointer #xFFFFFFFF))) + +(defmethod gfw:minimum-size ((widget mock-widget)) + (gfi:make-size :width (gfi:size-width (min-size-of widget)) + :height (gfi:size-height (min-size-of widget)))) + +(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint) + (let ((size (gfi:make-size)) + (min-size (min-size-of widget))) + (if (< width-hint 0) + (setf (gfi:size-width size) (gfi:size-width min-size)) + (setf (gfi:size-width size) width-hint)) + (if (< height-hint 0) + (setf (gfi:size-height size) (gfi:size-height min-size)) + (setf (gfi:size-height size) height-hint)) + size)) + +(defmethod gfw:visible-p ((widget mock-widget)) + (visibility-of widget))
Added: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 19:19:36 2006 @@ -0,0 +1,109 @@ +;;;; +;;;; flow-layout.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun flow-container-size (style win-visible kids width-hint height-hint) + (let ((max -1) + (total 0) + (vert-orient (find :vertical style))) + (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 (gfi:size-height size)) + (if (< max (gfi:size-width size)) + (setf max (gfi:size-width size)))) + (progn + (incf total (gfi:size-width size)) + (if (< max (gfi:size-height size)) + (setf max (gfi:size-height size)))))))) + (if vert-orient + (gfi:make-size :width max :height total) + (gfi:make-size :width total :height max)))) + +(defun flow-container-layout (style win-visible kids width-hint height-hint) + (let ((entries nil) + (last-coord 0) + (last-dim 0) + (vert-orient (find :vertical style))) + (loop for kid in kids + do (let ((size (preferred-size kid + (if vert-orient width-hint -1) + (if vert-orient -1 height-hint))) + (pnt (gfi:make-point))) + (when (or (visible-p kid) (not win-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))) + (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)))) + (reverse entries))) + +;;; +;;; methods +;;; + +(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-size (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) + (with-children (win kids) + (flow-container-layout (style-of layout) (visible-p win) kids width-hint height-hint))) + +(defmethod initialize-instance :after ((layout flow-layout) &key style) + (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)))
Copied: trunk/src/uitoolkit/widgets/layout.lisp (from r32, trunk/src/uitoolkit/widgets/layouts.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/layouts.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 19:19:36 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; layouts.lisp +;;;; layout.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -45,6 +45,7 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) +(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k)) @@ -68,65 +69,3 @@ +window-pos-flags+))))) (unless (gfi:null-handle-p hdwp) (gfs::end-defer-window-pos hdwp))))) - -;;; -;;; flow-layout methods -;;; - -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((max -1) - (total 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint)))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (incf total (gfi:size-width kid-size)) - (if (< max (gfi:size-height kid-size)) - (setf max (gfi:size-height kid-size)))) - (progn - (incf total (gfi:size-height kid-size)) - (if (< max (gfi:size-width kid-size)) - (setf max (gfi:size-width kid-size))))))))) - (if vert-orient - (gfi:make-size :width max :height total) - (gfi:make-size :width total :height max)))) - -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((entries nil) - (last-coord 0) - (last-dim 0) - (vert-orient (find :vertical (style-of layout)))) - (with-children (win kids) - (loop for k in kids - do (let ((kid-size (preferred-size k - (if vert-orient width-hint -1) - (if vert-orient -1 height-hint))) - (pnt (gfi:make-point))) - (when (or (visible-p k) (not (visible-p win))) - (if (not vert-orient) - (progn - (setf (gfi:point-x pnt) (+ last-coord last-dim)) - (if (>= height-hint 0) - (setf (gfi:size-height kid-size) height-hint)) - (setf last-coord (gfi:point-x pnt)) - (setf last-dim (gfi:size-width kid-size))) - (progn - (setf (gfi:point-y pnt) (+ last-coord last-dim)) - (if (>= width-hint 0) - (setf (gfi:size-width kid-size) width-hint)) - (setf last-coord (gfi:point-y pnt)) - (setf last-dim (gfi:size-height kid-size)))) - (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))) - (reverse entries))) - -(defmethod initialize-instance :after ((layout flow-layout) &key style) - (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)))
Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Mar 12 19:19:36 2006 @@ -33,15 +33,15 @@
(in-package #:graphic-forms-system)
-(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp")) +(defvar *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit"))
-(load (compile-file *lisp-unit-srcfile*)) +(load (compile-file *lisp-unit-file*))
(defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit))
-(defun load-adhoc-tests () +(defun load-tests () (if *external-build-dirs* (chdir *gf-build-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests))