Author: junrue Date: Fri Aug 18 13:18:48 2006 New Revision: 220 Modified: trunk/docs/manual/widgets-api.texinfo trunk/src/tests/uitoolkit/layout-unit-tests.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented layout item registration, no longer directly using mapchildren to layout children Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Fri Aug 18 13:18:48 2006 @@ -539,8 +539,10 @@ Instances of this class employ a @ref{layout-manager} to maintain the positions and sizes of their children. @deffn Accessor layout-of -Accepts or returns the @ref{layout-manager} associated with this -container. +Accepts or returns the layout-manager associated with this +container. Note that children currently registered with the previous +layout-manager are copied to the new one, but existing layout +attributes that were set for each child are not copied. @end deffn @deffn Initarg :layout Accepts a @ref{layout-manager} object whose responsibility is to manage @@ -1701,11 +1703,10 @@ @anchor{compute-layout} @deffn GenericFunction compute-layout @ref{layout-manager} container width-hint height-hint -Returns a list of pairs @code{(item rectangle)} describing the +Returns a list of conses @code{(child . rectangle)} describing the new bounds of each child within @var{container}. A layout-manager subclass implements this method based on its particular layout strategy, taking -into account attributes set by the user via @ref{layout-attribute}. Certain -Graphic-Forms functions call this method to accomplish layout within a container. +into account attributes set by the user via @ref{layout-attribute}. @table @var @item layout-manager The layout object dictating how children of @var{container} Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Aug 18 13:18:48 2006 @@ -57,8 +57,8 @@ (define-test layout-attributes-test (let ((widget1 (make-instance 'mock-widget :handle 1234)) (widget2 (make-instance 'mock-widget :handle 5678))) - (let ((data1 `(,(cffi:make-pointer 1234) (a 1 b 2))) - (data2 `(,(cffi:make-pointer 5678) (a 10 c 30))) + (let ((data1 `(,widget1 (a 1 b 2))) + (data2 `(,widget2 (a 10 c 30))) (layout (make-instance 'gfw:layout-manager))) (setf (slot-value layout 'gfw::data) (list data1 data2)) (assert-equal 1 (gfw:layout-attribute layout widget1 'a)) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Fri Aug 18 13:18:48 2006 @@ -1014,6 +1014,14 @@ (defconstant +wm-displaychange+ #x007E) (defconstant +wm-geticon+ #x007F) (defconstant +wm-seticon+ #x0080) +(defconstant +wm-nccreate+ #x0081) +(defconstant +wm-ncdestroy+ #x0082) +(defconstant +wm-nccalcsize+ #x0083) +(defconstant +wm-nchittest+ #x0084) +(defconstant +wm-ncpaint+ #x0085) +(defconstant +wm-ncactivate+ #x0086) +(defconstant +wm-getdlgcode+ #x0087) +(defconstant +wm-syncpaint+ #x0088) (defconstant +wm-ncmousemove+ #x00A0) (defconstant +wm-nclbuttondown+ #x00A1) (defconstant +wm-nclbuttonup+ #x00A2) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Aug 18 13:18:48 2006 @@ -43,7 +43,13 @@ (put-widget (thread-context) ctrl) (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+))) (unless (gfs:null-handle-p hfont) - (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))))) + (gfs::send-message hwnd gfs::+wm-setfont+ (cffi:pointer-address hfont) 0))) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent ctrl))) + (when (and parent (layout-of parent)) + (append-layout-item (layout-of parent) ctrl))))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri Aug 18 13:18:48 2006 @@ -169,7 +169,7 @@ (error 'gfs:disposed-error))) (if (null text) (setf text *default-dialog-title*)) - ;; NOTE: do not allow apps to specify the desktop window as the + ;; Don't allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. ;; Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Fri Aug 18 13:18:48 2006 @@ -33,10 +33,12 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ - gfs::+pm-noyield+ - gfs::+pm-qs-input+ - gfs::+pm-qs-postmessage+)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant +wm-gf-init-msg+ #xABCD) + (defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+ + gfs::+pm-noyield+ + gfs::+pm-qs-input+ + gfs::+pm-qs-postmessage+))) ;;; ;;; window procedures @@ -139,6 +141,8 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) +;;; FIXME: replace event-time slot with call to GetMessageTime +;;; (defun obtain-event-time () (event-time (thread-context))) @@ -216,13 +220,30 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam) - (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot - (if (typep w 'dialog) - (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam)))) + (let ((widget (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot + (if (typep widget 'dialog) + (let ((tmp (gfs::def-dlg-proc hwnd msg wparam lparam))) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0) ; 2nd stage init with fully-baked widget + (return-from process-message tmp)) + (gfs::post-message hwnd +wm-gf-init-msg+ 0 0))) ; 2nd stage init with fully-baked widget + 0) + +(defmethod process-message (hwnd (msg (eql +wm-gf-init-msg+)) wparam lparam) + (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless widget + (return-from process-message 0))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam) (declare (ignore wparam lparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (if widget + (event-dispose (dispatcher widget) widget))) + ;; If widget is registered with a layout manager, that reference + ;; is not cleared until the next time the layout manager is invoked. + ;; This alleviates the need for slow messy code here. + ;; (delete-widget (thread-context) hwnd) 0) @@ -242,10 +263,10 @@ (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context)) - (w (get-widget tc hwnd)) + (widget (get-widget tc hwnd)) (ch (code-char (lo-word wparam)))) - (when w - (event-key-down (dispatcher w) w (virtual-key tc) ch))) + (when widget + (event-key-down (dispatcher widget) widget (virtual-key tc) ch))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Fri Aug 18 13:18:48 2006 @@ -170,18 +170,16 @@ ;;; methods ;;; -(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-size layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-size ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-size self (visible-p container) kids width-hint height-hint))) -(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint) - (let ((kids (mapchildren win (lambda (parent child) - (declare (ignore parent)) - child)))) - (flow-container-layout layout (visible-p win) kids width-hint height-hint))) +(defmethod compute-layout ((self flow-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let ((kids (loop for item in (data-of self) collect (first item)))) + (flow-container-layout self (visible-p container) kids width-hint height-hint))) -(defmethod initialize-instance :after ((layout flow-layout) &key) - (unless (intersection (style-of layout) '(:horizontal :vertical)) - (setf (style-of layout) (list :horizontal)))) +(defmethod initialize-instance :after ((self flow-layout) &key) + (unless (intersection (style-of self) '(:horizontal :vertical)) + (setf (style-of self) (list :horizontal)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Aug 18 13:18:48 2006 @@ -37,21 +37,23 @@ ;;; methods ;;; -(defmethod compute-size ((self heap-layout) win width-hint height-hint) +(defmethod compute-size ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) (let ((size (gfs:make-size))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (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)))))) + (mapc (lambda (item) + (let ((kid-size (preferred-size (first item) 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))))) + (data-of self)) (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)) +(defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (cleanup-disposed-items self) + (let* ((size (client-size container)) (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) @@ -64,16 +66,19 @@ vert-margin))) (new-pnt (gfs:make-point :x (left-margin-of self) :y (top-margin-of self))) (bounds (gfs:make-rectangle :size new-size :location new-pnt))) - (mapchildren win (lambda (parent kid) - (declare (ignore parent)) - (cons kid bounds))))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) - (let ((top (top-child-of self)) - (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) - (arrange-children kid-specs (lambda (item) - (if (cffi:pointer-eq (gfs:handle top) (gfs:handle item)) - (logior +window-pos-flags+ gfs::+swp-showwindow+) - (logior +window-pos-flags+ gfs::+swp-hidewindow+)))))) + (if (layout-p container) + (let ((top (top-child-of self)) + (kid-specs (compute-layout self container width-hint height-hint))) + (unless top + (setf top (car (first kid-specs)))) + (arrange-hwnds kid-specs (lambda (item) + (if (eql top item) + (logior +window-pos-flags+ gfs::+swp-showwindow+) + (logior +window-pos-flags+ gfs::+swp-hidewindow+))))))) + +(defmethod (setf top-child-of) :after (child (self heap-layout)) + (unless (typep child 'widget) + (error 'gfs:toolkit-error :detail "top child must be an instance of a widget subclass"))) Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Fri Aug 18 13:18:48 2006 @@ -43,27 +43,34 @@ ;;; helper functions ;;; -(defun layout-attribute (layout widget name) - "Return the value associated with name for widget; or NIL if no value is set." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (getf (first (rest attrs)) name))) - -(defun set-layout-attribute (layout widget name value) - "Sets a value associated with name for widget in the specified layout." - (if (gfs:disposed-p widget) - (error 'gfs:disposed-error)) - (let ((attrs (assoc (gfs:handle widget) (data-of layout) :test #'cffi:pointer-eq))) - (unless attrs - (error 'gfs:toolkit-error :detail (format nil "~a is not managed ~a" widget layout))) - (setf (getf (first (rest attrs)) name) value))) +(defun layout-attribute (layout thing name) + "Return the value associated with name for thing; or NIL if no value is set." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (getf (first (rest items)) name))) + +(defun set-layout-attribute (layout thing name value) + "Sets a value associated with name for thing in the specified layout." + (let ((items (assoc thing (data-of layout)))) + (unless items + (error 'gfs:toolkit-error :detail (format nil "~a is not managed by ~a" thing layout))) + (setf (getf (first (rest items)) name) value))) (defsetf layout-attribute set-layout-attribute) -(defun arrange-children (kid-specs flags-func) +(defun append-layout-item (layout thing) + "Adds thing to layout unless it is already registered." + (setf (data-of layout) (nconc (data-of layout) (list (list thing nil))))) + +(defun delete-layout-item (layout thing) + "Removes thing from layout." + (delete thing (data-of layout) :key #'first)) + +(defun cleanup-disposed-items (layout) + (delete-if #'gfs:disposed-p (data-of layout) :key #'first)) + +(defun arrange-hwnds (kid-specs flags-func) (let ((hdwp (gfs::begin-defer-window-pos (length kid-specs)))) (loop for k in kid-specs for rect = (cdr k) @@ -93,25 +100,37 @@ ;;; methods ;;; -(defmethod initialize-instance :after ((layout layout-manager) +(defmethod initialize-instance :after ((self layout-manager) &key style margins horizontal-margins vertical-margins &allow-other-keys) - (setf (style-of layout) (if (listp style) style (list style))) + (setf (style-of self) (if (listp style) style (list style))) (unless (null margins) - (setf (left-margin-of layout) margins - (right-margin-of layout) margins - (top-margin-of layout) margins - (bottom-margin-of layout) margins)) + (setf (left-margin-of self) margins + (right-margin-of self) margins + (top-margin-of self) margins + (bottom-margin-of self) margins)) (unless (null horizontal-margins) - (setf (left-margin-of layout) horizontal-margins - (right-margin-of layout) horizontal-margins)) + (setf (left-margin-of self) horizontal-margins + (right-margin-of self) horizontal-margins)) (unless (null vertical-margins) - (setf (top-margin-of layout) vertical-margins - (bottom-margin-of layout) vertical-margins))) + (setf (top-margin-of self) vertical-margins + (bottom-margin-of self) vertical-margins))) + +(defmethod (setf layout-of) :after ((self layout-manager) (container layout-managed)) + (let ((orig-layout (layout-of container))) + (if orig-layout + (setf (data-of self) (loop for item in (data-of orig-layout) + when (not (gfs:disposed-p (first item))) + collect item) + (data-of orig-layout) nil) + (if (typep container 'window) + (setf (data-of self) (mapchildren container (lambda (parent child) + (declare (ignore parent)) + (list child nil)))))))) (defmethod perform ((self layout-manager) (container layout-managed) width-hint height-hint) - (when (layout-p container) - (arrange-children (compute-layout self container width-hint height-hint) - (lambda (item) - (declare (ignore item)) - +window-pos-flags+)))) + (if (layout-p container) + (arrange-hwnds (compute-layout self container width-hint height-hint) + (lambda (item) + (declare (ignore item)) + +window-pos-flags+)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Fri Aug 18 13:18:48 2006 @@ -40,7 +40,7 @@ (display-visitor-results :initform nil :accessor display-visitor-results) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) - (event-time :initform 0 :accessor event-time) + (event-time :initform 0 :accessor event-time) ; FIXME: GetMessageTime (virtual-key :initform 0 :accessor virtual-key) (menuitems-by-id :initform (make-hash-table :test #'equal)) (mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Aug 18 13:18:48 2006 @@ -50,11 +50,7 @@ (:documentation "Instances of this class employ a layout manager to organize their children.")) (defclass group (layout-managed) - ((children - :accessor children-of - :initarg :children - :initform nil) - (location + ((location :accessor location-of :initarg :location :initform nil) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Fri Aug 18 13:18:48 2006 @@ -219,37 +219,37 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod initialize-instance :after ((w widget) &key style &allow-other-keys) - (setf (slot-value w 'style) (if (listp style) style (list style)))) +(defmethod initialize-instance :after ((self widget) &key style &allow-other-keys) + (setf (slot-value self 'style) (if (listp style) style (list style)))) -(defmethod location :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod location :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod location ((w widget)) +(defmethod location ((self widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::clientleft gfs::clienttop) wi-ptr gfs::windowinfo) (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (when (zerop (gfs::get-window-info (gfs:handle w) wi-ptr)) + (when (zerop (gfs::get-window-info (gfs:handle self) wi-ptr)) (error 'gfs:win32-error :detail "get-window-info failed")) (cffi:with-foreign-object (pnt-ptr 'gfs::point) (cffi:with-foreign-slots ((gfs::x gfs::y) pnt-ptr gfs::point) (setf gfs::x gfs::clientleft) (setf gfs::y gfs::clienttop) - (gfs::screen-to-client (gfs:handle w) pnt-ptr) + (gfs::screen-to-client (gfs:handle self) pnt-ptr) (gfs:make-point :x gfs::x :y gfs::y)))))) -(defmethod (setf location) :before ((pnt gfs:point) (w widget)) +(defmethod (setf location) :before ((pnt gfs:point) (self widget)) (declare (ignore pnt)) - (if (gfs:disposed-p w) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf location) ((pnt gfs:point) (w widget)) - (if (zerop (gfs::set-window-pos (gfs:handle w) +(defmethod (setf location) ((pnt gfs:point) (self widget)) + (if (zerop (gfs::set-window-pos (gfs:handle self) (cffi:null-pointer) (gfs:point-x pnt) (gfs:point-y pnt) @@ -272,12 +272,12 @@ nil (get-widget (thread-context) hwnd)))) -(defmethod pack :before ((w widget)) - (if (gfs:disposed-p w) +(defmethod pack :before ((self widget)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod pack ((w widget)) - (setf (size w) (preferred-size w -1 -1))) +(defmethod pack ((self widget)) + (setf (size self) (preferred-size self -1 -1))) (defmethod parent ((self widget)) ;; Unlike the owner method, this method should Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Aug 18 13:18:48 2006 @@ -58,7 +58,13 @@ (error 'gfs:win32-error :detail "create-window failed")) (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) - (put-widget tc win)))) + (put-widget tc win)) + ;; FIXME: this is a temporary hack to allow layout management testing; + ;; it breaks in the presence of virtual containers like group + ;; + (let ((parent (parent win))) + (if (and parent (layout-of parent)) + (append-layout-item (layout-of parent) win))))) (defun child-window-visitor (hwnd lparam) (let* ((tc (thread-context))