Protocols

From junrue at common-lisp.net Thu Jan 4 03:04:47 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 3 Jan 2007 22:04:47 -0500 (EST) Subject: [graphic-forms-cvs] r423 - in trunk: . docs/manual docs/website src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20070104030447.EB40924007@common-lisp.net> Author: junrue Date: Wed Jan 3 22:04:43 2007 New Revision: 423 Added: trunk/src/uitoolkit/widgets/status-bar.lisp Modified: trunk/docs/manual/api.xml trunk/docs/manual/gfw-symbols.xml trunk/docs/manual/graphic-forms.xml trunk/docs/manual/protocols.xml trunk/docs/website/index.html trunk/graphic-forms-uitoolkit.asd trunk/src/demos/textedit/textedit-window.lisp trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: check in a snapshot of status bar work Modified: trunk/docs/manual/api.xml ============================================================================== --- trunk/docs/manual/api.xml (original) +++ trunk/docs/manual/api.xml Wed Jan 3 22:04:43 2007 @@ -11,6 +11,7 @@ &constants; + &protocols; &gfcpkg; &gfgpkg; &gfspkg; Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Jan 3 22:04:43 2007 @@ -2,7 +2,7 @@ @@ -1284,8 +1284,8 @@ This is a list of keyword symbols that define - the look-and-feel of the dialog. Currently, only one of the following - symbols may be specified: + the look-and-feel of the dialog. One of the following + primary styles may be specified: @@ -1309,6 +1309,10 @@ + The following optional style may also be specified: + + + @@ -1335,6 +1339,7 @@ gfw:owner gfw:parent gfw:text + gfw:status-bar-of @@ -1415,7 +1420,7 @@ One or more of the following optional styles: - + @@ -1449,7 +1454,7 @@ gfw:text gfw:obtain-horizontal-scrollbar gfw:obtain-vertical-scrollbar - gfw:obtain-status-bar + gfw:status-bar-of @@ -3783,29 +3788,6 @@ - - - - - - An object configured with a statusbar. - - - - - gfw:status-bar - - - - Returns the gfw:status-bar - attached to the bottom of , if is configured to - have one. - - - gfw:status-item - - - @@ -6121,6 +6103,30 @@ + + + + + + An instance of gfw:top-level or + gfw:dialog. + + + + + gfw:status-bar + + + + If was created with the :status-bar style, then this function + returns an object representing the status bar widget; otherwise, this + function returns NIL. + + + gfw:status-item + + + Modified: trunk/docs/manual/graphic-forms.xml ============================================================================== --- trunk/docs/manual/graphic-forms.xml (original) +++ trunk/docs/manual/graphic-forms.xml Wed Jan 3 22:04:43 2007 @@ -34,7 +34,6 @@ &legal; &introduction; &api; - &protocols; &misctopics; &glossary; Modified: trunk/docs/manual/protocols.xml ============================================================================== --- trunk/docs/manual/protocols.xml (original) +++ trunk/docs/manual/protocols.xml Wed Jan 3 22:04:43 2007 @@ -7,7 +7,7 @@ Protocols - This chapter's sections discuss the protocols + This section discusses the protocols representing major functional areas of Graphic-Forms. Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Jan 3 22:04:43 2007 @@ -76,12 +76,8 @@ - - Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Jan 3 22:04:43 2007 @@ -147,6 +147,7 @@ (:file "scrolling-helper") (:file "scrollbar") (:file "slider") + (:file "status-bar") (:file "window") (:file "root-window") (:file "top-level") Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Wed Jan 3 22:04:43 2007 @@ -189,7 +189,7 @@ :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) :layout (make-instance 'gfw:heap-layout) - :style '(:frame))) + :style '(:frame :status-bar))) (setf *textedit-control* (make-instance 'gfw:edit :parent *textedit-win* :style '(:multi-line :auto-vscroll Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; packages.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -285,6 +285,7 @@ #:scrollbar #:scrolling-helper #:slider + #:status-bar #:timer #:top-level #:widget @@ -536,6 +537,7 @@ #:size #:spacing-of #:startup + #:status-bar-of #:step-increments #:style-of #:sub-menu Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-constants.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; dialog.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -165,6 +165,10 @@ (reenable-top-levels) (if (visible-p self) (show self nil)) + (let ((sbar (status-bar-of self))) + (when sbar + (delete-widget (thread-context) (gfs:handle sbar)) + (setf (slot-value self 'status-bar) nil))) (call-next-method)) (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Jan 3 22:04:43 2007 @@ -495,7 +495,6 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam) - (declare (ignore lparam)) (let* ((tc (thread-context)) (w (get-widget tc hwnd)) (type (cond @@ -503,9 +502,13 @@ ((= wparam gfs::+size-minimized+) :minimized) ((= wparam gfs::+size-restored+) :restored) (t nil)))) - (when w + (when (and w (not (typep w 'status-bar))) (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) w (size-event-size tc) type))) + (event-resize (dispatcher w) w (size-event-size tc) type) + (if (or (typep w 'top-level) (typep w 'dialog)) + (let ((sbar (status-bar-of w))) + (if sbar + (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ wparam lparam)))))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; label.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -81,30 +81,30 @@ ;;; methods ;;; -(defmethod (setf gfg:background-color) (color (label label)) +(defmethod (setf gfg:background-color) (color (self label)) (declare (ignorable color)) (call-next-method) - (let ((image (image label)) - (pnt (pixel-point-of label))) + (let ((image (image self)) + (pnt (pixel-point-of self))) (when image (if pnt (setf (gfg:transparency-pixel-of image) pnt)) - (setf (image label) image)))) + (setf (image self) image)))) -(defmethod compute-style-flags ((label label) &rest extra-data) +(defmethod compute-style-flags ((self label) &rest extra-data) (if (> (count-if-not #'null extra-data) 1) (error 'gfs:toolkit-error :detail "only one of :image, :separator, or :text are allowed")) (let ((std-style (logior gfs::+ws-child+ gfs::+ws-visible+ (cond ((first extra-data) - (compute-image-style-flags (style-of label))) + (compute-image-style-flags (style-of self))) ((second extra-data) - (if (find :vertical (style-of label)) + (if (find :vertical (style-of self)) gfs::+ss-etchedvert+ gfs::+ss-etchedhorz+)) (t - (compute-text-style-flags (style-of label))))))) + (compute-text-style-flags (style-of self))))))) (values std-style 0))) (defmethod initialize-instance :after ((self label) &key image parent text &allow-other-keys) Added: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Wed Jan 3 22:04:43 2007 @@ -0,0 +1,45 @@ +;;;; +;;;; status-bar.lisp +;;;; +;;;; Copyright (C) 2007, 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-style-flags ((self status-bar) &rest extra-data) + (declare (ignore extra-data)) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) + +(defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) + (create-control self parent "" gfs::+icc-win95-classes+)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; top-level.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -120,15 +120,21 @@ |# (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:status-bar) ;; nothing to do, but need to allow this style symbol (:vertical-scrollbar (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags))) (defmethod gfs:dispose ((self top-level)) - (let ((m (menu-bar self))) - (unless (null m) - (visit-menu-tree m #'menu-cleanup-callback) - (delete-widget (thread-context) (gfs:handle m)))) + (let ((menu (menu-bar self)) + (sbar (status-bar-of self)) + (tc (thread-context))) + (when menu + (visit-menu-tree menu #'menu-cleanup-callback) + (delete-widget tc (gfs:handle menu))) + (when sbar + (delete-widget tc (gfs:handle sbar)) + (setf (slot-value self 'status-bar) nil))) (call-next-method)) (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-classes.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -245,6 +245,13 @@ :allocation :class)) ; shadowing same slot from event-source (:documentation "The menu class represents a container for menu items (and submenus).")) +(defclass status-bar (control item-manager layout-managed) + ((system-classname + :reader system-classname-of + :initform "msctls_statusbar32" + :allocation :class)) + (:documentation "This class represents the status bar widget configured within top-level windows.")) + (defclass window (widget layout-managed) ((max-size :initarg :maximum-size @@ -254,7 +261,10 @@ :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) -(defclass dialog (window) () +(defclass dialog (window) + ((status-bar + :reader status-bar-of + :initform nil)) (:documentation "The dialog class is the base class for both system-defined and application-defined dialogs.")) (defclass panel (window) () @@ -263,7 +273,10 @@ (defclass root-window (window) () (:documentation "This class encapsulates the root of the desktop window hierarchy.")) -(defclass top-level (window) () +(defclass top-level (window) + ((status-bar + :reader status-bar-of + :initform nil)) (: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 Wed Jan 3 22:04:43 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; window.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -61,6 +61,8 @@ (if (find :keyboard-navigation (style-of win)) (put-kbdnav-widget tc win)) (put-widget tc win)) + (if (find :status-bar (style-of win)) + (setf (slot-value win 'status-bar) (make-instance 'status-bar :parent win))) ;; FIXME: this is a temporary hack to allow layout management testing; ;; it breaks in the presence of virtual containers like group ;; @@ -269,8 +271,8 @@ (update-scrollbar-page-sizes self) (update-scrolling-state self :both)) -(defmethod event-resize ((disp event-dispatcher) (self window) size type) - (declare (ignore size type)) +(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))))) From junrue at common-lisp.net Thu Jan 4 06:03:08 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 4 Jan 2007 01:03:08 -0500 (EST) Subject: [graphic-forms-cvs] r424 - trunk/src/uitoolkit/widgets Message-ID: <20070104060308.0153D6913D@common-lisp.net> Author: junrue Date: Thu Jan 4 01:03:07 2007 New Revision: 424 Modified: trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: replace thread-context GFs with simple functions; add a thread-context slot for storing raw event data; move status-bar resizing logic from WM_SIZE process-message to top-level and dialog event-resize methods Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Jan 4 01:03:07 2007 @@ -171,6 +171,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method)) +(defmethod event-resize (disp (self dialog) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jan 4 01:03:07 2007 @@ -502,13 +502,10 @@ ((= wparam gfs::+size-minimized+) :minimized) ((= wparam gfs::+size-restored+) :restored) (t nil)))) - (when (and w (not (typep w 'status-bar))) + (record-raw-event tc hwnd msg wparam lparam) + (when w (outer-size w (size-event-size tc)) - (event-resize (dispatcher w) w (size-event-size tc) type) - (if (or (typep w 'top-level) (typep w 'dialog)) - (let ((sbar (status-bar-of w))) - (if sbar - (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ wparam lparam)))))) + (event-resize (dispatcher w) w (size-event-size tc) type))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Jan 4 01:03:07 2007 @@ -33,11 +33,14 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defstruct event (hwnd (cffi:null-pointer)) (msg 0) (wparam 0) (lparam 0)) + (defclass thread-context () ((child-visitor-func :initform nil :accessor child-visitor-func) (child-visitor-results :initform nil :accessor child-visitor-results) (display-visitor-func :initform nil :accessor display-visitor-func) (display-visitor-results :initform nil :accessor display-visitor-results) + (raw-event :initform (make-event) :reader raw-event) (job-table :initform (make-hash-table :test #'equal)) (job-table-lock :initform nil) (virtual-key :initform 0 :accessor virtual-key) @@ -55,7 +58,7 @@ (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) (utility-hwnd :initform (cffi:null-pointer) :accessor utility-hwnd) - (wip :initform nil)) + (widget-in-progress :initform nil :accessor widget-in-progress)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) ;; TODO: change this when CLISP acquires MT support @@ -107,32 +110,7 @@ (gfs::destroy-window hwnd))))) (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) nil)) -(defgeneric init-utility-hwnd (self)) -(defgeneric call-child-visitor-func (self parent child)) -(defgeneric call-display-visitor-func (self hmonitor data)) -(defgeneric call-top-level-visitor-func (self window)) -(defgeneric get-widget (self hwnd)) -(defgeneric put-widget (self widget)) -(defgeneric delete-widget (self hwnd)) -(defgeneric widget-in-progress (self)) -(defgeneric (setf widget-in-progress) (widget self)) -(defgeneric clear-widget-in-progress (self)) -(defgeneric put-kbdnav-widget (self widget)) -(defgeneric delete-kbdnav-widget (self widget)) -(defgeneric intercept-kbdnav-message (self msg-ptr)) -(defgeneric get-item (self id)) -(defgeneric put-item (self item)) -(defgeneric delete-tc-item (self item)) -(defgeneric increment-item-id (self)) -(defgeneric put-job (self id closure)) -(defgeneric take-job (self id)) -(defgeneric increment-job-id (self)) -(defgeneric get-timer (self id)) -(defgeneric put-timer (self timer)) -(defgeneric delete-timer (self timer)) -(defgeneric increment-widget-id (self)) - -(defmethod init-utility-hwnd ((tc thread-context)) +(defun init-utility-hwnd (tc) (register-toplevel-noerasebkgnd-window-class) (let ((hwnd (create-window "GraphicFormsTopLevelNoEraseBkgnd" ; can't use constant here "" ; because of circular dependency @@ -144,65 +122,57 @@ 0))) (setf (slot-value tc 'utility-hwnd) hwnd))) -(defmethod call-child-visitor-func ((tc thread-context) parent child) +(defun call-child-visitor-func (tc parent child) (let ((func (child-visitor-func tc))) (if func (funcall func parent child) (warn 'gfs:toolkit-warning :detail "child visitor function is nil")))) -(defmethod call-display-visitor-func ((tc thread-context) hmonitor data) +(defun call-display-visitor-func (tc hmonitor data) (let ((func (display-visitor-func tc))) (if func (funcall func hmonitor data) (warn 'gfs:toolkit-warning :detail "display visitor function is nil")))) -(defmethod call-top-level-visitor-func ((tc thread-context) win) +(defun call-top-level-visitor-func (tc win) (let ((func (top-level-visitor-func tc))) (if func (funcall func win) (warn 'gfs:toolkit-warning :detail "top-level visitor function is nil")))) -(defmethod get-widget ((tc thread-context) hwnd) +(defun get-widget (tc hwnd) "Return the widget object corresponding to the specified native window handle." - (let ((tmp-widget (slot-value tc 'wip))) + (let ((tmp-widget (widget-in-progress tc))) (when tmp-widget (setf (slot-value tmp-widget 'gfs:handle) hwnd) (return-from get-widget tmp-widget))) (unless (gfs:null-handle-p hwnd) (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) -(defmethod put-widget ((tc thread-context) (w widget)) +(defun put-widget (tc w) "Add the specified widget to the widget table using its native handle as the key." (setf (gethash (cffi:pointer-address (gfs:handle w)) (slot-value tc 'widgets-by-hwnd)) w)) -(defmethod delete-widget ((tc thread-context) hwnd) +(defun delete-widget (tc hwnd) "Remove the widget object corresponding to the specified native window handle." - (when (not (slot-value tc 'wip)) + (when (not (widget-in-progress tc)) (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd)))) -(defmethod widget-in-progress ((tc thread-context)) - "Return the widget currently under construction." - (slot-value tc 'wip)) - -(defmethod (setf widget-in-progress) ((w widget) (tc thread-context)) +(defun clear-widget-in-progress (tc) "Store the widget currently under construction." - (setf (slot-value tc 'wip) w)) + (setf (widget-in-progress tc) nil)) -(defmethod clear-widget-in-progress ((tc thread-context)) - "Store the widget currently under construction." - (setf (slot-value tc 'wip) nil)) - -(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) +(defun put-kbdnav-widget (tc widget) (if (find :keyboard-navigation (style-of widget)) (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) -(defmethod delete-kbdnav-widget ((tc thread-context) (widget widget)) +(defun delete-kbdnav-widget (tc widget) (setf (kbdnav-widgets tc) (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) (kbdnav-widgets tc) :key #'gfs:handle))) -(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) +(defun intercept-kbdnav-message (tc msg-ptr) (let ((widgets (kbdnav-widgets tc))) (unless widgets (return-from intercept-kbdnav-message nil)) @@ -217,15 +187,15 @@ (return-from intercept-kbdnav-message widget)))) nil) -(defmethod get-item ((tc thread-context) id) +(defun get-item (tc id) "Returns the item identified by id." (gethash id (slot-value tc 'items-by-id))) -(defmethod put-item ((tc thread-context) (it item)) +(defun put-item (tc it) "Stores an item using its id as the key." (setf (gethash (item-id it) (slot-value tc 'items-by-id)) it)) -(defmethod delete-tc-item ((tc thread-context) (it item)) +(defun delete-tc-item (tc it) "Removes the item using its id as the key." (maphash #'(lambda (k v) @@ -234,37 +204,37 @@ (remhash k (slot-value tc 'items-by-id)))) (slot-value tc 'items-by-id))) -(defmethod increment-item-id ((tc thread-context)) +(defun increment-item-id (tc) "Return the next menu item ID; also increment the internal value." (let ((id (next-item-id tc))) (incf (slot-value tc 'next-item-id)) id)) -(defmethod put-job ((tc thread-context) id closure) +(defun put-job (tc id closure) "Stores a closure using the specified ID for later retrieval." ;; FIXME: thread-safety (setf (gethash id (slot-value tc 'job-table)) closure)) -(defmethod take-job ((tc thread-context) id) +(defun take-job (tc id) (let ((closure (gethash id (slot-value tc 'job-table)))) (remhash id (slot-value tc 'job-table)) closure)) -(defmethod increment-job-id ((tc thread-context)) +(defun increment-job-id (tc) "Return the next job ID; also increment the internal value." (let ((id (next-job-id tc))) (incf (slot-value tc 'next-job-id)) id)) -(defmethod get-timer ((tc thread-context) id) +(defun get-timer (tc id) "Returns the timer identified by the specified (system-defined) id." (gethash id (slot-value tc 'timers-by-id))) -(defmethod put-timer ((tc thread-context) (timer timer)) +(defun put-timer (tc timer) "Stores a timer using its id as the key." (setf (gethash (id-of timer) (slot-value tc 'timers-by-id)) timer)) -(defmethod delete-timer ((tc thread-context) (timer timer)) +(defun delete-timer (tc timer) "Removes the timer using its id as the key." (maphash #'(lambda (k v) @@ -273,8 +243,16 @@ (remhash k (slot-value tc 'timers-by-id)))) (slot-value tc 'timers-by-id))) -(defmethod increment-widget-id ((tc thread-context)) +(defun increment-widget-id (tc) "Return the next timer ID; also increment the internal value." (let ((id (next-widget-id tc))) (incf (slot-value tc 'next-widget-id)) id)) + +(defun record-raw-event (tc hwnd msg wparam lparam) + (let ((event (raw-event tc))) + (setf (event-hwnd event) hwnd + (event-msg event) msg + (event-wparam event) wparam + (event-lparam event) lparam) + event)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Jan 4 01:03:07 2007 @@ -137,6 +137,17 @@ (setf (slot-value self 'status-bar) nil))) (call-next-method)) +(defmethod event-resize (disp (self top-level) size type) + (declare (ignore disp size type)) + (let ((event (raw-event (thread-context))) + (sbar (status-bar-of self))) + (if (and sbar (not (gfs:disposed-p sbar))) + (gfs::send-message (gfs:handle sbar) + gfs::+wm-size+ + (event-wparam event) + (event-lparam event)))) + (call-next-method)) + (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) From junrue at common-lisp.net Sun Jan 7 07:16:31 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 7 Jan 2007 02:16:31 -0500 (EST) Subject: [graphic-forms-cvs] r425 - in trunk/src: demos/textedit uitoolkit/system uitoolkit/widgets Message-ID: <20070107071631.1BBD73906E@common-lisp.net> Author: junrue Date: Sun Jan 7 02:16:30 2007 New Revision: 425 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: text now displays in simple status bars; related refactoring Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Jan 7 02:16:30 2007 @@ -200,6 +200,7 @@ (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/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jan 7 02:16:30 2007 @@ -951,6 +951,11 @@ ;;; statusbar constants ;;; +(defconstant +sb-simpleid+ #x00FF) + +(defconstant +sb-settext+ #x0401) ; (WM_USER+1) SB_SETTEXTA +(defconstant +sb-gettext+ #x0402) ; (WM_USER+2) SB_GETTEXTA +(defconstant +sb-gettextlength+ #x0403) ; (WM_USER+3) SB_GETTEXTLENGTHA (defconstant +sb-setparts+ #x0404) ; (WM_USER+4) (defconstant +sb-getparts+ #x0406) ; (WM_USER+6) (defconstant +sb-getborders+ #x0407) ; (WM_USER+7) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jan 7 02:16:30 2007 @@ -65,7 +65,8 @@ ;; it won't work if virtual containers like group are implemented. ;; (when (and parent (layout-of parent)) - (append-layout-item (layout-of parent) ctrl))))) + (append-layout-item (layout-of parent) ctrl)) + hwnd))) ;;; ;;; methods Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Jan 7 02:16:30 2007 @@ -34,12 +34,92 @@ (in-package :graphic-forms.uitoolkit.widgets) ;;; +;;; helper functions +;;; + +(declaim (inline stb-is-simple)) +(defun stb-is-simple (status-bar) + (/= (gfs::send-message (gfs:handle status-bar) gfs::+sb-issimple+ 0 0) 0)) + +(defun stb-get-border-widths (status-bar) + "Returns a list of integer widths (0: horz border, 1: vert border, 2: internal)" + (cffi:with-foreign-pointer (array (* (cffi:foreign-type-size :int) 3)) + (when (zerop (gfs::send-message (gfs:handle status-bar) + gfs::+sb-getborders+ + 0 + (cffi:pointer-address array))) + (warn 'gfs:win32-warning :detail "SB_GETBORDERS message failed") + (return-from stb-get-border-widths (list 0 0 0))) + (loop for index from 0 to 2 + collect (cffi:mem-aref array :int index)))) + +(defun stb-set-min-height (status-bar height) + (let ((widths (stb-get-border-widths status-bar)) + (hstatus (gfs:handle status-bar))) + (when (zerop (gfs::send-message hstatus + gfs::+sb-setminheight+ + (+ height (* (second widths) 2)) + 0)) + (warn 'gfs:win32-warning :detail "SB_SETMINHEIGHT message failed") + (return-from stb-set-min-height nil)) + (gfs::send-message hstatus gfs::+wm-size+ 0 0)) + height) + +(defun stb-set-text (status-bar str &optional item-index) + (let ((part-id (if (stb-is-simple status-bar) gfs::+sb-simpleid+ item-index))) + (cffi:with-foreign-string (str-ptr str) + (if (zerop (gfs::send-message (gfs:handle status-bar) + gfs::+sb-settext+ + part-id + (cffi:pointer-address str-ptr))) + (warn 'gfs:win32-warning :detail "SB_SETTEXT message failed")))) + str) + +(defun stb-get-text-properties (status-bar item-index) + "Returns the text length and operation type of the status bar part at item-index." + (let ((hresult (gfs::send-message (gfs:handle status-bar) + gfs::+sb-gettextlength+ + item-index + 0))) + (values (gfs::lparam-low-word hresult) (gfs::lparam-high-word hresult)))) + +(defun stb-get-text (status-bar item-index) + (multiple-value-bind (length op-type) + (stb-get-text-properties status-bar item-index) + (declare (ignore op-type)) + (if (zerop length) + "" + (cffi:with-foreign-pointer-as-string (str-ptr (1+ length)) + (gfs::send-message (gfs:handle status-bar) + gfs::+sb-gettext+ + item-index + (cffi:pointer-address str-ptr)))))) + +;;; ;;; methods ;;; +(defmethod border-width ((self status-bar)) + (let ((widths (stb-get-border-widths self))) + (max (first widths) (second widths)))) + (defmethod compute-style-flags ((self status-bar) &rest extra-data) (declare (ignore extra-data)) (values (logior gfs::+ws-child+ gfs::+ws-visible+ gfs::+sbars-sizegrip+) 0)) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (create-control self parent "" gfs::+icc-win95-classes+)) + (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (gfs::send-message hctl gfs::+sb-simple+ 1 0)) + (let ((widths (stb-get-border-widths self))) + (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) + +(defmethod preferred-size ((self status-bar) width-hint height-hint) + (declare (ignore width-hint 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)) + (widths (stb-get-border-widths self))) + (gfs:make-size :width (gfs:size-width client-area)) + :height (+ (gfs:size-height tmp-size) (* (first widths) 2)))) + Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jan 7 02:16:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; widget-utils.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -162,20 +162,16 @@ (error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func)))) retval)) -(defun get-widget-text (w) - (if (gfs:disposed-p w) +(defun get-widget-text (widget) + (if (gfs:disposed-p widget) (error 'gfs:disposed-error)) (let* ((text "") - (hwnd (gfs:handle w)) - (len (gfs::get-window-text-length hwnd))) - (unless (zerop len) - (incf len) - (let ((str-ptr (cffi:foreign-alloc :char :count len))) - (unwind-protect - (unless (zerop (gfs::get-window-text hwnd str-ptr len)) - (setf text (cffi:foreign-string-to-lisp str-ptr))) - (cffi:foreign-free str-ptr)))) - text)) + (hwnd (gfs:handle widget)) + (length (gfs::get-window-text-length hwnd))) + (if (zerop length) + "" + (cffi:with-foreign-pointer-as-string (str-ptr (1+ length)) + (gfs::get-window-text hwnd str-ptr (1+ length)))))) (defun outer-location (w pnt) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) From junrue at common-lisp.net Sun Jan 21 17:13:50 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 21 Jan 2007 12:13:50 -0500 (EST) Subject: [graphic-forms-cvs] r426 - in trunk: . docs/manual src src/tests/mcclim src/uitoolkit/widgets Message-ID: <20070121171350.24C482E1C9@common-lisp.net> Author: junrue Date: Sun Jan 21 12:13:49 2007 New Revision: 426 Added: trunk/src/tests/mcclim/buttons.lisp Modified: trunk/docs/manual/clhs-table.xml trunk/graphic-forms-tests.asd trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: miscellaneous tweaks and fixes, some of it originating from McCLIM backend work Modified: trunk/docs/manual/clhs-table.xml ============================================================================== --- trunk/docs/manual/clhs-table.xml (original) +++ trunk/docs/manual/clhs-table.xml Sun Jan 21 12:13:49 2007 @@ -15,6 +15,7 @@ + Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Jan 21 12:13:49 2007 @@ -51,7 +51,7 @@ #:windlg)) (print "Graphic-Forms UI Toolkit Tests") -(print "Copyright (c) 2006 by Jack D. Unrue") +(print "Copyright (c) 2006-2007 by Jack D. Unrue") (print " ") (defsystem graphic-forms-tests Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Sun Jan 21 12:13:49 2007 @@ -36,7 +36,7 @@ ;(in-package #:graphic-forms-system) (print "Graphic-Forms UI Toolkit") -(print "Copyright (c) 2006 by Jack D. Unrue") +(print "Copyright (c) 2006-2007 by Jack D. Unrue") (print " ") (defsystem graphic-forms-uitoolkit Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sun Jan 21 12:13:49 2007 @@ -511,6 +511,7 @@ #:peer #:preferred-size #:primary-p + #:process-events #:redraw #:redrawing-p #:release-mouse Added: trunk/src/tests/mcclim/buttons.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/mcclim/buttons.lisp Sun Jan 21 12:13:49 2007 @@ -0,0 +1,16 @@ + +(defpackage :clim-graphic-forms-tests + (:use :clim :clim-lisp)) + +(in-package :clim-graphic-forms-tests) + +;;; +;;; (run-frame-top-level (make-application-frame 'buttons)) +;;; + +(define-application-frame buttons () () + (:menu-bar nil) + (:layouts + (default + (vertically (:equalize-width t) + (make-pane 'push-button :label "First"))))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jan 21 12:13:49 2007 @@ -205,10 +205,10 @@ (defmethod print-object ((self control) stream) (print-unreadable-object (self stream :type t) - (format stream "handle: ~x " (gfs:handle self)) - (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a " (size self)) - (format stream "text baseline: ~a" (text-baseline self)))) + (call-next-method) + (unless (gfs:disposed-p self) + (format stream "size: ~a " (size self)) + (format stream "text baseline: ~a" (text-baseline self))))) (defmethod text-baseline ((self control)) (floor (gfs:size-height (size self)) 2)) Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Sun Jan 21 12:13:49 2007 @@ -114,7 +114,6 @@ (setf (layout-of self) (make-instance 'flow-layout :spacing (third widths))))) (defmethod preferred-size ((self status-bar) width-hint height-hint) - (declare (ignore width-hint height-hint)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((client-area (client-size (parent self))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jan 21 12:13:49 2007 @@ -165,8 +165,7 @@ (defun get-widget-text (widget) (if (gfs:disposed-p widget) (error 'gfs:disposed-error)) - (let* ((text "") - (hwnd (gfs:handle widget)) + (let* ((hwnd (gfs:handle widget)) (length (gfs::get-window-text-length hwnd))) (if (zerop length) "" From junrue at common-lisp.net Mon Jan 22 05:07:55 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Mon, 22 Jan 2007 00:07:55 -0500 (EST) Subject: [graphic-forms-cvs] r427 - in trunk/src: demos/textedit demos/unblocked uitoolkit/system uitoolkit/widgets Message-ID: <20070122050755.D208A2E1BB@common-lisp.net> 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) From junrue at common-lisp.net Sat Jan 27 22:13:09 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 27 Jan 2007 17:13:09 -0500 (EST) Subject: [graphic-forms-cvs] r429 - in trunk/src: demos uitoolkit/widgets Message-ID: <20070127221309.751F06A004@common-lisp.net> Author: junrue Date: Sat Jan 27 17:13:08 2007 New Revision: 429 Modified: trunk/src/demos/demo-utils.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: further work on coordination betweeen layout managers and status bar Modified: trunk/src/demos/demo-utils.lisp ============================================================================== --- trunk/src/demos/demo-utils.lisp (original) +++ trunk/src/demos/demo-utils.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; demo-utils.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -63,7 +63,7 @@ :text " ")) (line3 (make-instance 'gfw:label :parent text-panel - :text (format nil "Copyright ~c 2006 by Jack D. Unrue" (code-char 169)))) + :text (format nil "Copyright ~c 2006-2007 by Jack D. Unrue" (code-char 169)))) (line4 (make-instance 'gfw:label :parent text-panel :text "All Rights Reserved.")) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sat Jan 27 17:13:08 2007 @@ -121,12 +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))) +(defmethod compute-outer-size ((self dialog) desired-client-size) + (declare (ignore desired-client-size)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) (if sbar - (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) - client-size)) + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) (defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -208,6 +209,14 @@ ;; (init-window self *dialog-classname* #'register-dialog-class owner text)) +(defmethod preferred-size ((self dialog) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) + (if sbar + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) + (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) (owner-modal (find :owner-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; flow-layout.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Sat Jan 27 17:13:08 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; heap-layout.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -63,21 +63,22 @@ size)) (defmethod compute-layout ((self heap-layout) (container layout-managed) width-hint height-hint) + (declare (ignore 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))) - (bounds (gfs:create-rectangle :x (left-margin-of self) - :y (top-margin-of self) - :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)))) - (mapcar (lambda (item) (cons (first item) bounds)) (data-of self)))) + (let ((size (client-size container)) + (sbar (if (or (typep container 'top-level) (typep container 'dialog)) + (status-bar-of container)))) + (if sbar + (decf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + (let* ((horz-margin (+ (left-margin-of self) (right-margin-of self))) + (vert-margin (+ (top-margin-of self) (bottom-margin-of self))) + (bounds (gfs:create-rectangle :x (left-margin-of self) + :y (top-margin-of self) + :width (- (gfs:size-width size) + horz-margin) + :height (- (gfs:size-height size) + vert-margin)))) + (mapcar (lambda (item) (cons (first item) bounds)) (data-of self))))) (defmethod perform ((self heap-layout) (container layout-managed) width-hint height-hint) (if (layout-p container) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sat Jan 27 17:13:08 2007 @@ -68,12 +68,13 @@ ;;; methods ;;; -(defmethod client-size ((self top-level)) - (let ((sbar (status-bar-of self)) - (client-size (call-next-method))) +(defmethod compute-outer-size ((self top-level) desired-client-size) + (declare (ignore desired-client-size)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) (if sbar - (decf (gfs:size-height client-size) (gfs:size-height (preferred-size sbar -1 -1)))) - client-size)) + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) (defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) @@ -204,6 +205,14 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod preferred-size ((self top-level) width-hint height-hint) + (declare (ignore width-hint height-hint)) + (let ((size (call-next-method)) + (sbar (status-bar-of self))) + (if sbar + (incf (gfs:size-height size) (gfs:size-height (preferred-size sbar -1 -1)))) + size)) + (defmethod print-object ((self top-level) stream) (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) From junrue at common-lisp.net Wed Jan 31 14:17:45 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 31 Jan 2007 09:17:45 -0500 (EST) Subject: [graphic-forms-cvs] r430 - in trunk: docs/manual src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20070131141745.9C0447D002@common-lisp.net> Author: junrue Date: Wed Jan 31 09:17:41 2007 New Revision: 430 Modified: trunk/docs/manual/gfg-symbols.xml trunk/docs/manual/gfw-symbols.xml trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/drawing-tester.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-text-panel.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/graphics/graphics-generics.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: Modified: trunk/docs/manual/gfg-symbols.xml ============================================================================== --- trunk/docs/manual/gfg-symbols.xml (original) +++ trunk/docs/manual/gfg-symbols.xml Wed Jan 31 09:17:41 2007 @@ -794,6 +794,33 @@ + + + + + + A gfg:graphics-context on which to draw. + + + + + The gfg:color with which to fill the + window associated with . + + + + + undefined + + + + Fills the window associated with using . + + + colors + + + Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Wed Jan 31 09:17:41 2007 @@ -843,7 +843,7 @@ used. - Like other system dialogs in Graphic-Forms, file-dialog is derived from + Like other system dialogs in Graphic-Forms, color-dialog is derived from gfw:widget rather than gfw:dialog since the majority of its functionality is implemented by the system. A future release will provide a customization mechanism. @@ -3867,7 +3867,7 @@ return the same value by default as would gfw:preferred-size. - If the new minimum size provided via the SET function is larger than the + If the new minimum size provided via the SETF function is larger than the current size, the widget is resized to the new minimum. Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp ============================================================================== --- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original) +++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Wed Jan 31 09:17:41 2007 @@ -46,10 +46,7 @@ :initform nil))) (defmethod clear-buffer ((self double-buffered-event-dispatcher) gc) - (let ((image (image-buffer-of self))) - (setf (gfg:background-color gc) *background-color*) - (setf (gfg:foreground-color gc) *background-color*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfg:size image))))) + (gfg:clear gc *background-color*)) (defmethod dispose ((self double-buffered-event-dispatcher)) (let ((image (image-buffer-of self))) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Jan 31 09:17:41 2007 @@ -200,6 +200,7 @@ #:background-pattern #:blue-mask #:blue-shift + #:clear #:clipped-p #:clipping-rectangle #:color->rgb Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Wed Jan 31 09:17:41 2007 @@ -66,10 +66,8 @@ (drawing-exit-fn self nil)) (defmethod gfw:event-paint ((self drawing-win-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white*) (let ((func (draw-func-of self))) (unless (null func) (funcall func gc)))) Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Jan 31 09:17:41 2007 @@ -48,10 +48,8 @@ (exit-fn disp nil)) (defmethod gfw:event-paint ((disp hellowin-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white-smoke*) (setf (gfg:background-color gc) gfg:*color-red*) (setf (gfg:foreground-color gc) gfg:*color-green*) (gfg:draw-text gc "Hello World!" (gfs:make-point))) Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jan 31 09:17:41 2007 @@ -73,10 +73,8 @@ :initform 0))) (defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect) - (declare (ignore rect)) - (setf (gfg:background-color gc) gfg:*color-white*) - (setf (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))) + (declare (ignore window rect)) + (gfg:clear gc gfg:*color-white*)) (defclass test-panel (gfw:panel) ()) Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Wed Jan 31 09:17:41 2007 @@ -77,10 +77,7 @@ (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) (declare (ignore window)) - (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect) + (gfg:clear gc gfg:*color-button-face*) (setf (gfg:foreground-color gc) gfg:*color-black* (gfg:pen-style gc) '(:solid :flat-endcap)) (let* ((pnt (gfs:location rect)) Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Jan 31 09:17:41 2007 @@ -107,9 +107,7 @@ (defmethod gfw:event-paint ((disp scroll-text-panel-events) window gc rect) (declare (ignore window)) - (setf (gfg:background-color gc) gfg:*color-white* - (gfg:foreground-color gc) gfg:*color-white*) - (gfg:draw-filled-rectangle gc rect) + (gfg:clear gc gfg:*color-white*) (setf (gfg:foreground-color gc) gfg:*color-black* (gfg:font gc) (font-of disp)) (let* ((metrics (gfg:metrics gc (font-of disp))) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Jan 31 09:17:41 2007 @@ -219,6 +219,28 @@ (gfs::set-dc-brush-color hdc rgb) (gfs::set-bk-color hdc rgb))) +(defmethod clear ((self graphics-context) (color color)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (setf (background-color self) color + (foreground-color self) color) + (let* ((hdc (gfs:handle self)) + (hwnd (gfs::window-from-dc hdc))) + (if (gfs:null-handle-p hwnd) + (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC") + (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom) + wi-ptr gfs::windowinfo) + (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) + (if (zerop (gfs::get-window-info hwnd wi-ptr)) + (warn 'gfs:win32-warning :detail "get-window-info failed") + (gfs::with-rect (rect-ptr) + (setf gfs::top 0 + gfs::left 0 + gfs::bottom gfs::clientbottom + gfs::right gfs::clientright) + (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))))))))) + (defmethod gfs:dispose ((self graphics-context)) (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) (gfs::delete-object (pen-handle-of self)) @@ -282,31 +304,6 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect)) -;;; FIXME: consider preserving this version as a "fast path" -;;; rectangle filler. -;;; -#| -(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (let ((hdc (gfs:handle self)) - (pnt (gfs:location rect)) - (size (gfs:size rect))) - (gfs::with-rect (rect-ptr) - (setf gfs::top (gfs:point-y pnt) - gfs::left (gfs:point-x pnt) - gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size)) - gfs::right (+ (gfs:point-x pnt) (gfs:size-width size))) - (gfs::ext-text-out hdc - (gfs:point-x pnt) - (gfs:point-y pnt) - gfs::+eto-opaque+ - rect-ptr - "" - 0 - (cffi:null-pointer))))) -|# - (defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Wed Jan 31 09:17:41 2007 @@ -39,6 +39,9 @@ (defgeneric (setf background-color) (color self) (:documentation "Sets the current background color.")) +(defgeneric clear (self color) + (:documentation "Fills self with the specified color.")) + (defgeneric data-object (self &optional gc) (:documentation "Returns the data structure representing the raw form of self.")) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Wed Jan 31 09:17:41 2007 @@ -838,6 +838,11 @@ (rct LPTR)) (defcfun + ("WindowFromDC" window-from-dc) + HANDLE + (hdc HANDLE)) + +(defcfun ("WindowFromPoint" window-from-point) HANDLE (pnt :pointer)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jan 31 09:17:41 2007 @@ -187,7 +187,7 @@ (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ (event-wparam event) - (event-lparam event)))) + (logand (event-lparam event) #xFFFFFFFF)))) (call-next-method)) (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Wed Jan 31 09:17:41 2007 @@ -152,7 +152,7 @@ (gfs::send-message (gfs:handle sbar) gfs::+wm-size+ (event-wparam event) - (event-lparam event)))) + (logand (event-lparam event) #xFFFFFFFF)))) (call-next-method)) (defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys)