[graphic-forms-cvs] r427 - in trunk/src: demos/textedit demos/unblocked uitoolkit/system uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jan 22 05:07:55 UTC 2007
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)
More information about the Graphic-forms-cvs
mailing list