Author: junrue Date: Sun Feb 19 15:50:50 2006 New Revision: 11 Added: trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layouts.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: flow layout implementation Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Feb 19 15:50:50 2006 @@ -87,6 +87,7 @@ :components ((:file "widget-constants") (:file "widget-classes") + (:file "layout-classes") (:file "thread-context") (:file "message-generics") (:file "event-generics") @@ -100,4 +101,5 @@ (:file "widget-with-items") (:file "menu") (:file "event") - (:file "window"))))))))) + (:file "window") + (:file "layouts"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Feb 19 15:50:50 2006 @@ -205,7 +205,9 @@ #:control #:event-dispatcher #:event-source + #:flow-layout #:item + #:layout-manager #:menu #:menu-item #:widget @@ -305,7 +307,6 @@ #:column-order #:columns #:compute-outer-size - #:compute-size #:copy #:copy-area #:current-font @@ -408,7 +409,6 @@ #:parent #:paste #:peer - #:perform-layout #:preferred-size #:realize #:redraw Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Feb 19 15:50:50 2006 @@ -67,8 +67,7 @@ (defun add-layout-tester-widget (primary-type sub-type) (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*)) - (w (make-instance primary-type :dispatcher be)) - (pnt (gfi:make-point))) + (w (make-instance primary-type :dispatcher be))) (setf (widget be) w) (cond ((eql sub-type :push-button) @@ -89,11 +88,8 @@ (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child)) (gfi:size-width (gfw:size child))))))) |# - (setf (gfi:point-x pnt) (* 77 (1- *button-counter*))) (gfw:realize w *layout-tester-win* sub-type) - (setf (gfw:text w) (funcall (toggle-fn be))) - (gfw:pack w) - (setf (gfw:location w) pnt))) + (setf (gfw:text w) (funcall (toggle-fn be))))) (defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect)) @@ -107,12 +103,11 @@ (let* ((mb (gfw:menu-bar *layout-tester-win*)) (menu (gfw:sub-menu mb 1))) (gfw:clear-all menu) - (gfw:with-children (*layout-tester-win* child-list) - (mapc #'(lambda (child) - (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) - (setf (gfw:text it) (gfw:text child)))) - child-list)))) + (gfw:with-children (*layout-tester-win* kids) + (loop for k in kids + do (let ((it (make-instance 'gfw:menu-item))) + (gfw:item-append menu it) + (setf (gfw:text it) (gfw:text k))))))) (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -125,7 +120,8 @@ (let* ((menubar nil) (fed (make-instance 'layout-tester-exit-dispatcher)) (cmd (make-instance 'layout-tester-child-menu-dispatcher))) - (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events))) + (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) + :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150)) (setf menubar (gfw:defmenusystem `(((:menu "&File") @@ -136,6 +132,7 @@ (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) (add-layout-tester-widget 'gfw:button :push-button) + (gfw:layout *layout-tester-win*) (gfw:show *layout-tester-win*))) (defun run-layout-tester () Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Feb 19 15:50:50 2006 @@ -39,10 +39,9 @@ (load-foreign-library "user32.dll") (defcfun - ("GetAncestor" get-ancestor) + ("BeginDeferWindowPos" begin-defer-window-pos) HANDLE - (hwnd HANDLE) - (flags UINT)) + (numwin INT)) (defcfun ("BeginPaint" begin-paint) @@ -89,6 +88,18 @@ (param LPVOID)) (defcfun + ("DeferWindowPos" defer-window-pos) + HANDLE + (posinfo HANDLE) + (hwnd HANDLE) + (hwndafter HANDLE) + (x INT) + (y INT) + (cx INT) + (cy INT) + (flags UINT)) + +(defcfun ("DefWindowProcA" def-window-proc) LRESULT (hwnd HANDLE) @@ -117,6 +128,11 @@ (hwnd HANDLE)) (defcfun + ("EndDeferWindowPos" end-defer-window-pos) + BOOL + (posinfo HANDLE)) + +(defcfun ("EndPaint" end-paint) BOOL (hwnd HANDLE) @@ -158,6 +174,12 @@ (:return-type ffi:int)) (defcfun + ("GetAncestor" get-ancestor) + HANDLE + (hwnd HANDLE) + (flags UINT)) + +(defcfun ("GetAsyncKeyState" get-async-key-state) SHORT (virtkey INT)) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Sun Feb 19 15:50:50 2006 @@ -121,7 +121,7 @@ (defgeneric event-mouse-down (dispatcher time point btn) (:documentation "Implement this to respond to a mouse down event.") (:method (dispatcher time point btn) - (declare (ignorable dispatcher time ptn btn)))) + (declare (ignorable dispatcher time point btn)))) (defgeneric event-mouse-enter (dispatcher time point btn) (:documentation "Implement this to respond to a mouse passing into the bounds of an object.") Added: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Feb 19 15:50:50 2006 @@ -0,0 +1,44 @@ +;;;; +;;;; layout-classes.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) + +(defclass layout-manager () + ((style + :accessor style + :initarg :style + :initform nil)) + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + +(defclass flow-layout (layout-manager) () + (:documentation "Window children are arranged in a row or column.")) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Feb 19 15:50:50 2006 @@ -33,8 +33,8 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defgeneric compute-size (mgr win width-hint height-hint) - (:documentation "Computes and returns the size of the window's client area based on this layout's strategy.")) +(defgeneric compute-size (layout win width-hint height-hint) + (:documentation "Computes and returns the size of the window's client area based on the layout's strategy.")) -(defgeneric perform-layout (mgr win) - (:documentation "Lays out the children of the window based on this layout's strategy.")) +(defgeneric compute-layout (layout win width-hint height-hint) + (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window.")) Added: trunk/src/uitoolkit/widgets/layouts.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/layouts.lisp Sun Feb 19 15:50:50 2006 @@ -0,0 +1,106 @@ +;;;; +;;;; layouts.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) + +(defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+ + gfs::+swp-noownerzorder+ + gfs::+swp-noactivate+ + gfs::+swp-nocopybits+)) + +(defun perform-layout (layout win) + "Calls compute-layout and then handles the actual moving and resizing of a window's children." + (let* ((win-size (client-size win)) + (kids (compute-layout layout win (gfi:size-width win-size) (gfi:size-height win-size))) + (hdwp (gfs::begin-defer-window-pos (length kids)))) + (loop for k in kids + do (let* ((rect (cdr k)) + (sz (gfi:size rect)) + (pnt (gfi:location rect))) + (if (gfi:null-handle-p hdwp) + (gfs::set-window-pos (gfi:handle (car k)) + (cffi:null-pointer) + (gfi:point-x pnt) + (gfi:point-y pnt) + (gfi:size-width sz) + (gfi:size-height sz) + +window-pos-flags+) + (setf hdwp (gfs::defer-window-pos hdwp + (gfi:handle (car k)) + (cffi:null-pointer) + (gfi:point-x pnt) + (gfi:point-y pnt) + (gfi:size-width sz) + (gfi:size-height sz) + +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) + (error "not yet implemented")) + +(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) + (let ((layout-style (gfw:style layout)) + (entries nil) + (last-coord 0) + (last-dim 0)) + (with-children (win kids) + (loop for k in kids + do (let ((kid-size (preferred-size k width-hint height-hint)) + (pnt (gfi:make-point))) + (if (not (find :vertical layout-style)) + (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 (slot-value layout 'style) '(:horizontal)) + (setf (slot-value layout 'style) style))) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Feb 19 15:50:50 2006 @@ -36,9 +36,6 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) -(defclass layout-manager () () - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) - (defclass event-source (gfi:native-object) ((dispatcher :accessor dispatcher @@ -80,7 +77,7 @@ (defclass window (widget) ((layout-p - :reader :layout-p + :reader layout-p :initform t) (layout-manager :accessor layout-manager Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Feb 19 15:50:50 2006 @@ -126,6 +126,7 @@ (visit-child-widgets ,win #'(lambda (parent child) (if (gfw:ancestor-p parent child) (push child ,var)))) + (nreverse ,var) ,@body)) (defun register-workspace-window-class () @@ -215,6 +216,10 @@ (setf (slot-value win 'layout-p) t) (layout win)) +(defmethod event-resize ((d dispatcher) time size type) + (declare (ignorable time size type)) + (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here! + (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+))