Author: junrue Date: Mon Jan 22 00:07:43 2007 New Revision: 427
Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/system/system-types.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/status-bar.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: starting to update geometry management to account for status bars (and later, toolbars)
Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Mon Jan 22 00:07:43 2007 @@ -148,7 +148,7 @@
(defmethod gfw:event-activate ((self textedit-win-events) window) (declare (ignore window)) - (if *textedit-control* + (when *textedit-control* (gfw:give-focus *textedit-control*)))
(defmethod gfw:event-close ((disp textedit-win-events) window) @@ -200,7 +200,6 @@ (gfw:text *textedit-win*) *textedit-new-title*) (let ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*))) (setf (gfw:image *textedit-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "textedit.ico")))) - (gfw::stb-set-text (gfw:status-bar-of *textedit-win*) "Testing...1, 2, 3") (gfw:show *textedit-win* t)))
(defun textedit ()
Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Jan 22 00:07:43 2007 @@ -108,7 +108,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace))) + :style '(:workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win*
Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Mon Jan 22 00:07:43 2007 @@ -325,11 +325,20 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME
-(defcstruct nccalcsize_params - (clientnewrect rect) - (destvalidrect rect) - (srcvalidrect rect) - (lppos LPTR)) +(defcstruct nccalcsize-params + (clientnewleft LONG) + (clientnewtop LONG) + (clientnewright LONG) + (clientnewbottom LONG) + (destvalidleft LONG) + (destvalidtop LONG) + (destvalidright LONG) + (destvalidbottom LONG) + (srcvalidleft LONG) + (srcvalidtop LONG) + (srcvalidright LONG) + (srcvalidbottom LONG) + (lppos LPTR))
(defcstruct openfilename (ofnsize DWORD)
Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Jan 22 00:07:43 2007 @@ -64,7 +64,7 @@ ;; FIXME: this is a temporary hack to allow layout management testing; ;; it won't work if virtual containers like group are implemented. ;; - (when (and parent (layout-of parent)) + (when (and parent (layout-of parent) (not (typep ctrl 'status-bar))) (append-layout-item (layout-of parent) ctrl)) hwnd)))
@@ -205,7 +205,8 @@
(defmethod print-object ((self control) stream) (print-unreadable-object (self stream :type t) - (call-next-method) + (format stream "handle: ~x " (gfs:handle self)) + (format stream "dispatcher: ~a" (dispatcher self)) (unless (gfs:disposed-p self) (format stream "size: ~a " (size self)) (format stream "text baseline: ~a" (text-baseline self)))))
Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Mon Jan 22 00:07:43 2007 @@ -121,6 +121,13 @@ (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) (update-native-style cancel-widget style)))
+(defmethod client-size ((self dialog)) + (let ((sbar (status-bar-of self)) + (client-size (call-next-method))) + (if sbar + (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) + client-size)) + (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Mon Jan 22 00:07:43 2007 @@ -127,6 +127,25 @@ (#.gfs::+lbn-selchange+ (event-select disp widget)) (#.gfs::+lbn-setfocus+ (event-focus-gain disp widget)))))
+(defun process-nccalcsize-message (widget wparam lparam) + ;; NOTE: this function is currently a stub until there is actually + ;; a need to process WM_NCCALCSIZE messages. + ;; + (let ((size (gfs:make-size))) + (cond + ((zerop wparam) + (cffi:with-foreign-slots ((gfs::bottom) + (cffi:make-pointer (logand #xFFFFFFFF lparam)) + gfs::rect) + (setf gfs::bottom (- gfs::bottom (gfs:size-height size)))) + 0) + (t + (cffi:with-foreign-slots ((gfs::clientnewbottom) + (cffi:make-pointer (logand #xFFFFFFFF lparam)) + gfs::nccalcsize-params) + (setf gfs::clientnewbottom (- gfs::clientnewbottom (gfs:size-height size)))) + 0)))) + (defun process-ctlcolor-message (wparam lparam) (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) (hdc (cffi:make-pointer wparam)) @@ -531,6 +550,24 @@ gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)))))) 1)
+#| +(defmethod process-message (hwnd (msg (eql gfs::+wm-nccalcsize+)) wparam lparam) + (let ((widget (get-widget (thread-context) hwnd))) + (cond + ((typep widget 'dialog) + (let ((retval (gfs::def-dlg-proc hwnd msg wparam lparam))) + (if (status-bar-of widget) + (setf retval (process-nccalcsize-message widget wparam lparam))) + retval)) + ((typep widget 'top-level) + (let ((retval (gfs::def-window-proc hwnd msg wparam lparam))) + (if (status-bar-of widget) + (setf retval (process-nccalcsize-message widget wparam lparam))) + retval)) + (t + (gfs::def-window-proc hwnd msg wparam lparam))))) +|# + (defmethod process-message (hwnd (msg (eql gfs::+wm-timer+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Mon Jan 22 00:07:43 2007 @@ -122,6 +122,9 @@ (let ((kid-count (length (data-of self))) (horz-margin-total (+ (left-margin-of self) (right-margin-of self))) (vert-margin-total (+ (top-margin-of self) (bottom-margin-of self))) + (sbar-height (if (status-bar-of container) + (gfs:size-height (preferred-size (status-bar-of container) -1 -1)) + 0)) (vertical (find :vertical (style-of self))) (horizontal (find :horizontal (style-of self)))) (let ((spacing-total (* (spacing-of self) (1- kid-count))) @@ -137,14 +140,16 @@ (gfs:make-size :width (+ (flow-data-distance-total state) horz-margin-total spacing-total) - :height (+ (flow-data-max-extent state) - vert-margin-total))) + :height (- (+ (flow-data-max-extent state) + vert-margin-total) + sbar-height))) (vertical (gfs:make-size :width (+ (flow-data-max-extent state) horz-margin-total) - :height (+ (flow-data-distance-total state) - vert-margin-total - spacing-total))) + :height (- (+ (flow-data-distance-total state) + vert-margin-total + spacing-total) + sbar-height))) (t (error 'gfs:toolkit-error :detail (format nil "unrecognized flow layout style: ~a" (style-of self))))))))
Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Mon Jan 22 00:07:43 2007 @@ -114,11 +114,16 @@ (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths)))))
(defmethod preferred-size ((self status-bar) width-hint height-hint) + (declare (ignore height-hint)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((client-area (client-size (parent self))) - (tmp-size (compute-size (layout-of self) self width-hint height-hint)) + (let ((tmp-size (if (data-of (layout-of self)) + (compute-size (layout-of self) self width-hint -1) + (widget-text-size self + (lambda (widget) + (declare (ignore widget)) + "X") + gfs::+dt-singleline+))) (widths (stb-get-border-widths self))) - (gfs:make-size :width (gfs:size-width client-area)) - :height (+ (gfs:size-height tmp-size) (* (first widths) 2)))) - + (gfs:make-size :width 0 + :height (+ (gfs:size-height tmp-size) (* (second widths) 2) 1))))
Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Jan 22 00:07:43 2007 @@ -68,6 +68,13 @@ ;;; methods ;;;
+(defmethod client-size ((self top-level)) + (let ((sbar (status-bar-of self)) + (client-size (call-next-method))) + (if sbar + (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) + client-size)) + (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) @@ -126,14 +133,13 @@ (values std-flags ex-flags)))
(defmethod gfs:dispose ((self top-level)) - (let ((menu (menu-bar self)) - (sbar (status-bar-of self)) - (tc (thread-context))) + (let ((menu (menu-bar self))) (when menu (visit-menu-tree menu #'menu-cleanup-callback) - (delete-widget tc (gfs:handle menu))) + (delete-widget (thread-context) (gfs:handle menu)))) + (let ((sbar (status-bar-of self))) (when sbar - (delete-widget tc (gfs:handle sbar)) + (delete-widget (thread-context) (gfs:handle sbar)) (setf (slot-value self 'status-bar) nil))) (call-next-method))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Mon Jan 22 00:07:43 2007 @@ -65,6 +65,9 @@ (layout :accessor layout-of :initarg :layout + :initform nil) + (status-bar + :reader status-bar-of :initform nil)) (:documentation "Instances of this class employ a layout manager to organize their children."))
@@ -261,10 +264,7 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers."))
-(defclass dialog (window) - ((status-bar - :reader status-bar-of - :initform nil)) +(defclass dialog (window) () (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs."))
(defclass panel (window) () @@ -273,10 +273,7 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy."))
-(defclass top-level (window) - ((status-bar - :reader status-bar-of - :initform nil)) +(defclass top-level (window) () (:documentation "Base class for windows that can be moved and resized by the user, and which normally have title bars."))
(defclass timer (event-source)
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Mon Jan 22 00:07:43 2007 @@ -274,8 +274,8 @@ (defmethod event-resize (disp (self window) size type) (declare (ignore disp size type)) (unless (null (layout-of self)) - (let ((sz (client-size self))) - (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + (let ((client-size (client-size self))) + (perform (layout-of self) self (gfs:size-width client-size) (gfs:size-height client-size)))))
(defmethod focus-p :before ((self window)) (if (gfs:disposed-p self)