Author: junrue Date: Tue Feb 14 00:27:31 2006 New Revision: 10
Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/layout-generics.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial implementation of window side of the layout management protocol
Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Feb 14 00:27:31 2006 @@ -304,7 +304,8 @@ #:column-index #:column-order #:columns - #:compute-trim + #:compute-outer-size + #:compute-size #:copy #:copy-area #:current-font @@ -407,6 +408,7 @@ #: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 Tue Feb 14 00:27:31 2006 @@ -67,7 +67,8 @@
(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))) + (w (make-instance primary-type :dispatcher be)) + (pnt (gfi:make-point))) (setf (widget be) w) (cond ((eql sub-type :push-button) @@ -81,22 +82,18 @@ (setf flag nil) (format nil "~d ~a" (id be) +btn-text-after+)))))) (incf *button-counter*))) +#| + (gfw:with-children (*layout-tester-win* child-list) + (let ((child (first (reverse (rest child-list))))) + (unless (null child) + (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))) - (let ((pnt (gfi:make-point))) - (gfw:with-children (*layout-tester-win* child-list) - (let ((last-child (car (last (cdr child-list))))) - (unless (null last-child) -(format t "****~%") -(format t "widget: ~a~%" (gfw:text last-child)) -(format t "location: ~a~%" (gfw:location last-child)) -(format t "size: ~a~%" (gfw:size last-child)) - (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child)) - (gfi:size-width (gfw:size last-child))))))) - (setf (gfw:location w) pnt) -(format t "++++~%") -(format t "location: ~a~%" (gfw:location w))) - (setf (gfw:size w) (gfw:preferred-size w -1 -1)))) + (gfw:pack w) + (setf (gfw:location w) pnt)))
(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect) (declare (ignorable time rect))
Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/layout-generics.lisp Tue Feb 14 00:27:31 2006 @@ -32,3 +32,9 @@ ;;;;
(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 perform-layout (mgr win) + (:documentation "Lays out the children of the window based on this layout's strategy."))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Feb 14 00:27:31 2006 @@ -36,6 +36,9 @@ (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 @@ -75,5 +78,12 @@ (defclass menu (widget-with-items) () (:documentation "The menu class represents a container for menu items (and submenus)."))
-(defclass window (widget) () - (:documentation "The window class is the base class for top-level window objects.")) +(defclass window (widget) + ((layout-p + :reader :layout-p + :initform t) + (layout-manager + :accessor layout-manager + :initarg :layout-manager + :initform nil)) + (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows)."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Tue Feb 14 00:27:31 2006 @@ -96,8 +96,8 @@ (defgeneric compute-style-flags (object &rest style) (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports."))
-(defgeneric compute-trim (object desired-rect) - (:documentation "Return a rectangle describing the area require to enclose the specified desired client area and this object's trim.")) +(defgeneric compute-outer-size (object desired-client-size) + (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim."))
(defgeneric copy (object) (:documentation "Copies the current selection to the clipboard.")) @@ -222,12 +222,6 @@ (defgeneric layout (object) (:documentation "Set the size and location of this object's children."))
-(defgeneric layout-manager (object) - (:documentation "Returns the layout manager associated with this object.")) - -(defgeneric layout-p (object) - (:documentation "Return T if this object is configured to allow layout management of children, or nil if layout has been disabled.")) - (defgeneric lines-visible-p (object) (:documentation "Returns T if the object's lines are visible; nil otherwise."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Tue Feb 14 00:27:31 2006 @@ -105,6 +105,9 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed")))
+(defmethod pack ((w widget)) + (setf (size w) (preferred-size w -1 -1))) + (defmethod redraw ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd)
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Feb 14 00:27:31 2006 @@ -137,6 +137,17 @@ ;;; methods ;;;
+(defmethod compute-outer-size ((win window) desired-client-size) + (let ((client-sz (client-size win)) + (outer-sz (size win)) + (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size) + :height (gfi:size-height desired-client-size)))) + (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz) + (gfi:size-width client-sz))) + (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz) + (gfi:size-height client-sz))) + trim-sz)) + (defmethod compute-style-flags ((win window) &rest style) (declare (ignore win)) (let ((std-flags 0) @@ -190,6 +201,9 @@ (flatten style)) (values std-flags ex-flags)))
+(defmethod disable-layout ((win window)) + (setf (slot-value win 'layout-p) nil)) + (defmethod gfi:dispose ((win window)) (let ((m (menu-bar win))) (unless (null m) @@ -197,6 +211,10 @@ (remove-widget (thread-context) (gfi:handle m)))) (call-next-method))
+(defmethod enable-layout ((win window)) + (setf (slot-value win 'layout-p) t) + (layout win)) + (defmethod hide ((win window)) (gfs::show-window (gfi:handle win) gfs::+sw-hide+))
@@ -207,6 +225,11 @@ (outer-location w pnt) pnt))
+(defmethod layout ((win window)) + (let ((mgr (layout-manager win))) + (when (and (layout-p win) mgr) + (perform-layout mgr win)))) + (defmethod menu-bar ((win window)) (let ((hmenu (gfs::get-menu (gfi:handle win)))) (if (gfi:null-handle-p hmenu) @@ -227,6 +250,17 @@ (gfs::set-menu hwnd (gfi:handle m)) (gfs::draw-menu-bar hwnd)))
+(defmethod pack ((win window)) + (layout win) + (call-next-method)) + +(defmethod preferred-size ((win window) width-hint height-hint) + (let ((mgr (layout-manager win))) + (if (and (layout-p win) mgr) + (let ((new-client-sz (compute-size mgr win width-hint height-hint))) + (compute-outer-size win new-client-sz)) + (size win)))) + (defmethod realize ((win window) parent &rest style) (if (not (null parent)) (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future