[graphic-forms-cvs] r423 - in trunk: . docs/manual docs/website src src/demos/textedit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Jan 4 03:04:47 UTC 2007
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 @@
</para>
&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 @@
<!--
gfw-symbols.xml
- Copyright (c) 2006, Jack D. Unrue
+ Copyright (c) 2006-2007, Jack D. Unrue
-->
<package name="gfw" fullname="graphic-forms.uitoolkit.widgets">
@@ -1284,8 +1284,8 @@
<argument name=":style">
<description>
This is a <refclhs>list</refclhs> 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:
<enum>
<argument name=":application-modal">
<description>
@@ -1309,6 +1309,10 @@
</description>
</argument>
</enum>
+ The following optional style may also be specified:
+ <enum>
+ <argument name=":status-bar"/>
+ </enum>
</description>
</argument>
<argument name=":text">
@@ -1335,6 +1339,7 @@
<reftopic>gfw:owner</reftopic>
<reftopic>gfw:parent</reftopic>
<reftopic>gfw:text</reftopic>
+ <reftopic>gfw:status-bar-of</reftopic>
</seealso>
</class>
@@ -1415,7 +1420,7 @@
One or more of the following optional styles:
<enum>
<argument name=":horizontal-scrollbar"/>
- <argument name=":statusbar"/>
+ <argument name=":status-bar"/>
<argument name=":vertical-scrollbar"/>
</enum>
</description>
@@ -1449,7 +1454,7 @@
<reftopic>gfw:text</reftopic>
<reftopic>gfw:obtain-horizontal-scrollbar</reftopic>
<reftopic>gfw:obtain-vertical-scrollbar</reftopic>
- <reftopic>gfw:obtain-status-bar</reftopic>
+ <reftopic>gfw:status-bar-of</reftopic>
</seealso>
</class>
@@ -3783,29 +3788,6 @@
</seealso>
</generic-function>
- <generic-function name="obtain-status-bar">
- <syntax>
- <arguments>
- <argument name="self">
- <description>
- An object configured with a statusbar.
- </description>
- </argument>
- </arguments>
- <return>
- <reftopic>gfw:status-bar</reftopic>
- </return>
- </syntax>
- <description>
- Returns the <reftopic>gfw:status-bar</reftopic>
- attached to the bottom of <arg0/>, if <arg0/> is configured to
- have one.
- </description>
- <seealso>
- <reftopic>gfw:status-item</reftopic>
- </seealso>
- </generic-function>
-
<generic-function name="menu-bar">
<syntax with-setf="t">
<arguments>
@@ -6121,6 +6103,30 @@
<!-- ACCESSORS -->
+ <slot-accessor name="status-bar-of">
+ <syntax>
+ <arguments>
+ <argument name="self">
+ <description>
+ An instance of <reftopic>gfw:top-level</reftopic> or
+ <reftopic>gfw:dialog</reftopic>.
+ </description>
+ </argument>
+ </arguments>
+ <return>
+ <reftopic>gfw:status-bar</reftopic>
+ </return>
+ </syntax>
+ <description>
+ If <arg0/> was created with the :status-bar style, then this function
+ returns an object representing the status bar widget; otherwise, this
+ function returns NIL.
+ </description>
+ <seealso>
+ <reftopic>gfw:status-item</reftopic>
+ </seealso>
+ </slot-accessor>
+
<slot-accessor name="style-of">
<syntax with-setf="t">
<arguments>
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 @@
<title>Protocols</title>
<para role="normal">
- This chapter's sections discuss the <glossterm linkend="protocol">protocols</glossterm>
+ This section discusses the <glossterm linkend="protocol">protocols</glossterm>
representing major functional areas of Graphic-Forms.
</para>
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 @@
<div class="footer">
<a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a>
- Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>
+ Copyright © 2006-2007 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>
</div>
-<!--
- <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a>
--->
-
</body>
</html>
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)))))
More information about the Graphic-forms-cvs
mailing list