Author: junrue Date: Sun Apr 30 02:08:25 2006 New Revision: 114 Added: trunk/src/uitoolkit/widgets/heap-layout.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout-classes.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial implementation of heap-layout, possible container cleanup issues needing investigation; also made some layout-related doc enhancements Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Apr 30 02:08:25 2006 @@ -502,7 +502,7 @@ @end deffn @deffn Initarg :layout @end deffn -@deffn Accessor layout +@deffn Accessor layout-of @end deffn @end deftp @@ -513,17 +513,59 @@ @strong{NOTE:} A future release will provide additional layout manager classes. -@anchor{layout-manager} -@deftp Class layout-manager style -Subclasses implement layout strategies on behalf of window objects. +@anchor{flow-layout} +@deftp Class flow-layout spacing +This @ref{layout-manager} subclass arranges dialog or window children +in a row or column, with optional spacing (specified in pixels) +between children. +@deffn Initarg :style +This initarg accepts a list containing one of the following +style keywords: +@table @code +@item :horizontal +Specifies arrangement in a horizontal row. This style is the default. +@item :vertical +Specifies arrangement in a vertical column. +@item :wrap +This style keyword enables the arrangement of children to be +wrapped if the available horizontal (or vertical) space within +the container is less than the layout requests for a full +row (or column). The default behavior is unwrapped. +@end table +@end deffn @end deftp -@anchor{flow-layout} -@deftp Class flow-layout spacing left-margin top-margin right-margin bottom-margin -This @ref{layout-manager} subclass arranges window children in a row -or column, with optional margins around the row/column and spacing in -between children. The layout can wrap the window children if desired -and the available horizontal (or vertical) space is constrained. +@anchor{heap-layout} +@deftp Class heap-layout top-child +This @ref{layout-manager} subclass resizes all children to the same +size and stacks them on top of each other. +@deffn Initarg :top-child +Use this initarg to specify the child widget that should be visible. +The corresponding accessor @code{top-child-of} can be set +subsequently, followed by calling @ref{layout} on the container, in +order to make a different child visible. +@end deffn +@end deftp + +@anchor{layout-manager} +@deftp Class layout-manager style left-margin top-margin right-margin bottom-margin +Subclasses implement layout strategies on behalf of window +objects. Every layout manager allows optional margins (specified in +pixels) within the perimeter of the container being managed.@*@* The +values accepted by the @code{:style} initarg vary depending on the +actual @code{layout-manager} subclass being used. +@deffn Initarg :horizontal-margins +This initarg accepts a horizontal margin value that is applied to both +the left and right sides of the container. +@end deffn +@deffn Initarg :margins +This initarg accepts a margin value that is applied to all sides of +the container. +@end deffn +@deffn Initarg :vertical-margins +This initarg accepts a vertical margin value that is applied to both +the top and bottom of the container. +@end deffn @end deftp @@ -709,6 +751,7 @@ Return the zero-based index of the location of the other object in this object. @end deffn +@anchor{layout} @deffn GenericFunction layout self Set the size and location of this object's children. @end deffn @@ -861,19 +904,42 @@ @node layout functions @section layout functions -@deffn GenericFunction compute-layout layout window width-hint height-hint -Returns a list of conses @code{(window . rectangle)} describing the +These functions comprise the protocol for @ref{layout-manager}s. As +such, they are not normally called by application code, but instead +are the concern of layout-manager implementers. + +The @code{width-hint} and @code{height-hint} parameters are a +mechanism to express the @emph{what-if} scenario where the total width +or height of the container is fixed; the proper response is to +calculate the container's desired dimension on the opposite +axis. While this behavior is primarily the concern of child windows +and/or controls, layout manager implementations should look for +non-negative values for either @code{width-hint} or +@code{height-hint}, indicating that the container's size is +constrained. + +@anchor{compute-layout} +@deffn GenericFunction compute-layout layout container width-hint height-hint +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child window or control. A @ref{layout-manager} subclass implements this method based on its particular layout strategy, taking into account attributes set by the user. Certain Graphic-Forms functions -call this method to accomplish layout within a window. +call this method to accomplish layout within a container. @end deffn -@deffn GenericFunction compute-size layout window width-hint height-hint -Computes and returns the new @ref{size} of the window's client area. A -@ref{layout-manager} subclass implements this method based on its -particular layout strategy, taking into account attributes set by the -user. The @ref{pack} function ultimately calls this method. +@deffn GenericFunction compute-size layout container width-hint height-hint +Computes and returns the new @ref{size} of the @code{container}'s +client area. A @ref{layout-manager} subclass implements this method +based on its particular layout strategy, taking into account +attributes set by the user. The @ref{pack} function ultimately calls +this method. +@end deffn + +@deffn GenericFunction perform layout container width-hint height-hint +Calls @ref{compute-layout} for @code{container} and then moves and +resizes @code{container}'s children. Layout subclasses may override +this method -- most derivations should call @sc{CALL-NEXT-METHOD} to +allow the base implementation to execute. @end deffn Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Apr 30 02:08:25 2006 @@ -112,4 +112,5 @@ (:file "dialog") (:file "file-dialog") (:file "layout") + (:file "heap-layout") (:file "flow-layout"))))))))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Apr 30 02:08:25 2006 @@ -222,6 +222,7 @@ #:event-source #:file-dialog #:flow-layout + #:heap-layout #:item #:layout-manager #:menu @@ -463,6 +464,7 @@ #:text-limit #:thumb-size #:tooltip-text + #:top-child-of #:top-index #:top-margin-of #:traverse Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Apr 30 02:08:25 2006 @@ -33,6 +33,14 @@ (in-package :graphic-forms.uitoolkit.system) +;;; +;;; The following variables are used with set-window-pos +;;; +(defvar *hwnd-top* (cffi:null-pointer)) +(defvar *hwnd-bottom* (cffi:make-pointer #x00000001)) +(defvar *hwnd-topmost* (cffi:make-pointer #xFFFFFFFF)) +(defvar *hwnd-notopmost* (cffi:make-pointer #xFFFFFFFE)) + (defconstant +button-classname+ "button") (defconstant +static-classname+ "static") Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Apr 30 02:08:25 2006 @@ -134,22 +134,6 @@ #+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 style margins horz-margins vert-margins - &allow-other-keys) - (unless (listp style) - (setf style (list style))) - (if (and (null (find :horizontal style)) (null (find :vertical style))) - (push :horizontal style)) - (setf (style-of layout) style) - (unless (null margins) - (setf (left-margin-of layout) margins) - (setf (right-margin-of layout) margins) - (setf (top-margin-of layout) margins) - (setf (bottom-margin-of layout) margins)) - (unless (null horz-margins) - (setf (left-margin-of layout) horz-margins) - (setf (right-margin-of layout) horz-margins)) - (unless (null vert-margins) - (setf (top-margin-of layout) vert-margins) - (setf (bottom-margin-of layout) vert-margins))) +(defmethod initialize-instance :after ((layout flow-layout) &key) + (unless (intersection (style-of layout) '(:horizontal :vertical)) + (setf (style-of layout) (list :horizontal)))) Added: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sun Apr 30 02:08:25 2006 @@ -0,0 +1,104 @@ +;;;; +;;;; heap-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) + +;;; +;;; methods +;;; + +(defmethod compute-size ((self heap-layout) win width-hint height-hint) + (let ((size (gfs:make-size))) + (with-children (win kids) + (loop for kid in kids + do (let ((kid-size (preferred-size kid width-hint height-hint))) + (setf (gfs:size-width size) (max (gfs:size-width size) + (gfs:size-width kid-size)) + (gfs:size-height size) (max (gfs:size-height size) + (gfs:size-height kid-size)))))) + (incf (gfs:size-width size) (+ (left-margin-of self) (right-margin-of self))) + (incf (gfs:size-height size) (+ (top-margin-of self) (bottom-margin-of self))) + size)) + +(defmethod compute-layout ((self heap-layout) win width-hint height-hint) + (let* ((size (client-size win)) + (horz-margin (+ (left-margin-of self) (right-margin-of self))) + (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) + (new-size (gfs:make-size :width (- (if (> width-hint horz-margin) + width-hint + (gfs:size-width size)) + horz-margin) + :height (- (if (> height-hint vert-margin) + height-hint + (gfs:size-height size)) + vert-margin))) + (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) + (bounds (make-instance 'gfs:rectangle :size new-size :location new-pnt))) + (with-children (win kids) + (loop for kid in kids collect (cons kid bounds))))) + +(defmethod perform ((self heap-layout) win width-hint height-hint) + (let ((kids nil) + (hdwp (cffi:null-pointer)) + (top (top-child-of self))) + (when (layout-p win) + (setf kids (compute-layout self win width-hint height-hint)) + (setf hdwp (gfs::begin-defer-window-pos (length kids))) + (loop for k in kids + do (let* ((rect (cdr k)) + (sz (gfs:size rect)) + (pnt (gfs:location rect)) + (kid-win (car k)) + (hwnd-after (cffi:null-pointer)) + (flags (logior +window-pos-flags+ gfs::+swp-hidewindow+))) + (when (cffi:pointer-eq (gfs:handle kid-win) (gfs:handle top)) + (setf hwnd-after gfs::*hwnd-top* + flags (logior +window-pos-flags+ gfs::+swp-showwindow+))) + (if (gfs:null-handle-p hdwp) + (gfs::set-window-pos (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags) + (setf hdwp (gfs::defer-window-pos hdwp + (gfs:handle kid-win) + hwnd-after + (gfs:point-x pnt) + (gfs:point-y pnt) + (gfs:size-width sz) + (gfs:size-height sz) + flags))))) + (unless (gfs:null-handle-p hdwp) + (gfs::end-defer-window-pos hdwp))))) Modified: trunk/src/uitoolkit/widgets/layout-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-classes.lisp Sun Apr 30 02:08:25 2006 @@ -37,14 +37,7 @@ ((style :accessor style-of :initarg :style - :initform nil)) - (:documentation "Subclasses implement layout strategies on behalf of window objects.")) - -(defclass flow-layout (layout-manager) - ((spacing - :accessor spacing-of - :initarg :spacing - :initform 0) + :initform nil) (left-margin :accessor left-margin-of :initarg :left-margin @@ -61,4 +54,18 @@ :accessor bottom-margin-of :initarg :bottom-margin :initform 0)) + (:documentation "Subclasses implement layout strategies on behalf of window objects.")) + +(defclass flow-layout (layout-manager) + ((spacing + :accessor spacing-of + :initarg :spacing + :initform 0)) (:documentation "Window children are arranged in a row or column.")) + +(defclass heap-layout (layout-manager) + ((top-child + :accessor top-child-of + :initarg :top-child + :initform nil)) + (:documentation "Window children are stacked one on top of the other.")) Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Sun Apr 30 02:08:25 2006 @@ -38,3 +38,6 @@ (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.")) + +(defgeneric perform (layout window widget-hint height-hint) + (:documentation "Moves and resizes window children based on layout strategy.")) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Apr 30 02:08:25 2006 @@ -38,12 +38,31 @@ gfs::+swp-noactivate+ gfs::+swp-nocopybits+)) -(defun perform-layout (win width-hint height-hint) +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((layout layout-manager) + &key style margins horizontal-margins vertical-margins + &allow-other-keys) + (setf (style-of layout) (if (listp style) style (list style))) + (unless (null margins) + (setf (left-margin-of layout) margins) + (setf (right-margin-of layout) margins) + (setf (top-margin-of layout) margins) + (setf (bottom-margin-of layout) margins)) + (unless (null horizontal-margins) + (setf (left-margin-of layout) horizontal-margins) + (setf (right-margin-of layout) horizontal-margins)) + (unless (null vertical-margins) + (setf (top-margin-of layout) vertical-margins) + (setf (bottom-margin-of layout) vertical-margins))) + +(defmethod perform ((layout layout-manager) win width-hint height-hint) "Calls compute-layout for a window and then handles the actual moving and resizing of its children." - (let ((layout (layout-of win)) - (kids nil) - (hdwp nil)) - (when (and (layout-p win) layout) + (let ((kids nil) + (hdwp (cffi:null-pointer))) + (when (layout-p win) (setf kids (compute-layout layout win width-hint height-hint)) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Apr 30 02:08:25 2006 @@ -156,10 +156,10 @@ m))) (defmethod (setf maximum-size) :after (max-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size max-size (size win) #'min))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod (setf menu-bar) :before ((m menu) (win top-level)) (declare (ignore m)) @@ -178,10 +178,10 @@ (gfs::draw-menu-bar hwnd))) (defmethod (setf minimum-size) :after (min-size (win top-level)) - (unless (gfs:disposed-p win) + (unless (or (gfs:disposed-p win) (null (layout-of win))) (let ((size (constrain-new-size min-size (size win) #'max))) (setf (size win) size) - (perform-layout win (gfs:size-width size) (gfs:size-height size))))) + (perform (layout-of win) win (gfs:size-width size) (gfs:size-height size))))) (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Apr 30 02:08:25 2006 @@ -174,14 +174,15 @@ (defmethod enable-layout ((win window) flag) (setf (slot-value win 'layout-p) flag) - (if flag + (if (and flag (layout-of win)) (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz))))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod event-resize ((d event-dispatcher) (win window) time size type) (declare (ignorable d time size type)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod focus-p :before ((win window)) (if (gfs:disposed-p win) @@ -207,11 +208,13 @@ pnt)) (defmethod layout ((win window)) - (let ((sz (client-size win))) - (perform-layout win (gfs:size-width sz) (gfs:size-height sz)))) + (unless (null (layout-of win)) + (let ((sz (client-size win))) + (perform (layout-of win) win (gfs:size-width sz) (gfs:size-height sz))))) (defmethod pack ((win window)) - (perform-layout win -1 -1) + (unless (null (layout-of win)) + (perform (layout-of win) win -1 -1)) (call-next-method)) (defmethod preferred-size ((win window) width-hint height-hint)