[graphic-forms-cvs] r114 - in trunk: . docs/manual src src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Apr 30 06:08:27 UTC 2006
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
- at deffn Accessor layout
+ at deffn Accessor layout-of
@end deffn
@end deftp
@@ -513,17 +513,59 @@
@strong{NOTE:} A future release will provide additional layout
manager classes.
- at anchor{layout-manager}
- at deftp Class layout-manager style
-Subclasses implement layout strategies on behalf of window objects.
+ at anchor{flow-layout}
+ at 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.
+ at deffn Initarg :style
+This initarg accepts a list containing one of the following
+style keywords:
+ at table @code
+ at item :horizontal
+Specifies arrangement in a horizontal row. This style is the default.
+ at item :vertical
+Specifies arrangement in a vertical column.
+ at 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.
+ at end table
+ at end deffn
@end deftp
- at anchor{flow-layout}
- at 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.
+ at anchor{heap-layout}
+ at 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.
+ at 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.
+ at end deffn
+ at end deftp
+
+ at anchor{layout-manager}
+ at 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.
+ at deffn Initarg :horizontal-margins
+This initarg accepts a horizontal margin value that is applied to both
+the left and right sides of the container.
+ at end deffn
+ at deffn Initarg :margins
+This initarg accepts a margin value that is applied to all sides of
+the container.
+ at end deffn
+ at deffn Initarg :vertical-margins
+This initarg accepts a vertical margin value that is applied to both
+the top and bottom of the container.
+ at 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
+ at 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
- at 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
+ at code{height-hint}, indicating that the container's size is
+constrained.
+
+ at anchor{compute-layout}
+ at 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
- at deffn GenericFunction compute-size layout window width-hint height-hint
-Computes and returns the new @ref{size} of the window's client area. A
- at 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.
+ at 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.
+ at end deffn
+
+ at 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)
More information about the Graphic-forms-cvs
mailing list