- graphic-forms-cvs@common-lisp.net - mailman3.common-lisp.net

[graphic-forms-cvs] r468 - in trunk: . docs/manual docs/website src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 09 Jul '07

09 Jul '07

Author: junrue Date: Mon Jul 9 00:15:15 2007 New Revision: 468 Added: trunk/src/uitoolkit/widgets/defmenu.lisp - copied, changed from r433, trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/defwindow.lisp Removed: trunk/src/uitoolkit/widgets/menu-language.lisp Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/clhs-table.xml trunk/docs/manual/gfw-function-symbols.xml trunk/docs/manual/gfw-macro-symbols.xml trunk/docs/manual/introduction.xml trunk/docs/website/index.html trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/widgets/thread-context.lisp Log: added GFW:DEFMENU2 and GFW:MAKE-MENU, along with various bits of thread context infrastructure, and revised GFW:DEFMENU; updated docs Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Jul 9 00:15:15 2007 @@ -1,4 +1,7 @@ +. Added a new macro GFW:DEFMENU2 and associated function GFW:MAKE-MENU + to allow applications to create reusable menu factories. + . Latest CFFI is required to take advantage of built-in support for the stdcall calling convention. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Mon Jul 9 00:15:15 2007 @@ -17,7 +17,7 @@ http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ *note: ASDF is bundled with SBCL* - - CFFI (cffi-061208 or later) + - CFFI (cffi-XXXXXX or later) http://common-lisp.net/project/cffi/ - Closer to MOP @@ -44,7 +44,7 @@ ------------------------------------- Graphic-Forms currently supports Allegro CL 8.0, CLISP 2.40 or higher, -LispWorks 4.4.6, and SBCL 0.9.15 or higher (with a small patch). +LispWorks 4.4.6, and SBCL 1.0.5 or higher (with a small patch). Known Problems Modified: trunk/docs/manual/clhs-table.xml ============================================================================== --- trunk/docs/manual/clhs-table.xml (original) +++ trunk/docs/manual/clhs-table.xml Mon Jul 9 00:15:15 2007 @@ -2,7 +2,7 @@  <clhs-table> @@ -12,6 +12,7 @@ <entry name="error" url="http://www.lispworks.com/documentation/HyperSpec/Body/e_error.htm"/> <entry name="float" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_float.htm"/> <entry name="format" url="http://www.lispworks.com/documentation/HyperSpec/Body/f_format.htm"/> + <entry name="function" url="http://www.lispworks.com/reference/HyperSpec/Body/a_fn.htm"/> <entry name="hash-table" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_hash_t.htm"/> <entry name="integer" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_intege.htm"/> <entry name="list" url="http://www.lispworks.com/documentation/HyperSpec/Body/t_list.htm"/> Modified: trunk/docs/manual/gfw-function-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-function-symbols.xml (original) +++ trunk/docs/manual/gfw-function-symbols.xml Mon Jul 9 00:15:15 2007 @@ -3880,4 +3880,28 @@ </seealso> </slot-accessor> + <function name="make-menu"> + <syntax> + <arguments> + <argument name="menu-name"> + <description> + The <refclhs>symbol</refclhs> identifying a menu factory + function previously defined via <reftopic>gfw:defmenu2</reftopic>. + </description> + </argument> + </arguments> + <return> + <reftopic>gfw:menu</reftopic> + </return> + </syntax> + <description> + This function invokes the menu factory function identified by <arg0/> + to create a new native menu hierarchy. + </description> + <seealso> + <reftopic>gfw:defmenu</reftopic> + <reftopic>gfw:menu-bar</reftopic> + </seealso> + </function> + </symbols> Modified: trunk/docs/manual/gfw-macro-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-macro-symbols.xml (original) +++ trunk/docs/manual/gfw-macro-symbols.xml Mon Jul 9 00:15:15 2007 @@ -398,6 +398,49 @@ </description> </macro> + <macro name="defmenu2"> + <syntax> + <arguments> + <argument name=":name"> + <description> + A <refclhs>symbol</refclhs> identifying the new menu factory. + </description> + </argument> + <notarg name="symbol"/> + <argument name=":menu"> + <description> + Menu definition forms. + </description> + </argument> + <notarg name="("/> + <notarg name="forms"/> + <notarg name=")"/> + </arguments> + <return> + <refclhs>function</refclhs> + </return> + </syntax> + <description> + This macro defines a language for constructing menu hierarchies. For example: + <programlisting language="lisp"> +(gfw:defmenu2 + :name 'test-menu + :menu ((:item "&File" :submenu ((:item "&Open...") + (:item "&Save..." :disabled) + (:item :separator) + (:item "E&xit" :callback #'some-fn))) + (:item "&Tools" :submenu ((:item "&Fonts" :disabled) + (:item "&Colors" :checked))) + (:item "&Help" :submenu ((:item "&About" :image some-image))))) + </programlisting> + </description> + <seealso> + <reftopic>gfw:menu-bar</reftopic> + <reftopic>gfw:make-menu</reftopic> + <reftopic>gfw:defmenu</reftopic> + </seealso> + </macro> + <macro name="defmenu"> <syntax> <arguments> @@ -417,17 +460,23 @@ This macro defines a language for constructing menu hierarchies. For example: <programlisting language="lisp"> (gfw:defmenu - ((:item "&File" :submenu ((:item "&Open...") - (:item "&Save..." :disabled) - (:item :separator) - (:item "E&xit" :callback #'some-fn))) + ((:item "&File" :submenu ((:item "&Open...") + (:item "&Save..." :disabled) + (:item :separator) + (:item "E&xit" :callback #'some-fn))) (:item "&Tools" :submenu ((:item "&Fonts" :disabled) (:item "&Colors" :checked))) - (:item "&Help" :submenu ((:item "&About" :image some-image))))) + (:item "&Help" :submenu ((:item "&About" :image some-image))))) </programlisting> + Unlike <reftopic>gfw:defmenu2</reftopic>, this macro creates an anonymous + menu factory and then immediately invokes it, thus allowing the direct + construction of a menu hierarchy that can be immediately set on a window. + The factory function is then discarded. </description> <seealso> <reftopic>gfw:menu-bar</reftopic> + <reftopic>gfw:make-menu</reftopic> + <reftopic>gfw:defmenu2</reftopic> </seealso> </macro> Modified: trunk/docs/manual/introduction.xml ============================================================================== --- trunk/docs/manual/introduction.xml (original) +++ trunk/docs/manual/introduction.xml Mon Jul 9 00:15:15 2007 @@ -50,7 +50,7 @@ <listitem>CLISP 2.40 or later</listitem> <listitem>LispWorks 4.4.6</listitem> <listitem> - SBCL 0.9.15 or later + SBCL 1.0.5 or later <footnote> <para role="small"> a small patch to enable the stdcall calling convention for callbacks Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Mon Jul 9 00:15:15 2007 @@ -50,7 +50,7 @@ <li><a href="http://franz.com/">Allegro CL 8.0</a> or later</li> <li><a href="http://clisp.cons.org/">CLISP 2.40</a> or later</li> <li><a href="http://www.lispworks.com/">LispWorks 5.0.1</a></li> - <li><a href="http://www.sbcl.org/">SBCL 1.0.2</a> or later</li> + <li><a href="http://www.sbcl.org/">SBCL 1.0.5</a> or later</li> </ul> <h3 id="mailinglists">Mailing Lists</h3> Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Mon Jul 9 00:15:15 2007 @@ -142,7 +142,7 @@ (:file "list-box") (:file "menu") (:file "menu-item") - (:file "menu-language") + (:file "defmenu") (:file "progress-bar") (:file "event") (:file "scrolling-helper") @@ -157,7 +157,8 @@ (:file "layout") (:file "border-layout") (:file "heap-layout") - (:file "flow-layout"))))))))) + (:file "flow-layout") + (:file "defwindow"))))))))) (defmethod perform :after ((op load-op) (c (eql (find-system :graphic-forms-uitoolkit)))) (pushnew :graphic-forms *features*)) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Jul 9 00:15:15 2007 @@ -442,6 +442,7 @@ #:default-message-filter #:default-widget #:defmenu + #:defmenu2 #:delay-of #:delete-all #:delete-item @@ -524,6 +525,7 @@ #:location #:lock #:locked-p + #:make-menu #:mapchildren #:maximize #:maximized-p Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Mon Jul 9 00:15:15 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; event-tester.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 Copied: trunk/src/uitoolkit/widgets/defmenu.lisp (from r433, trunk/src/uitoolkit/widgets/menu-language.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/defmenu.lisp Mon Jul 9 00:15:15 2007 @@ -1,7 +1,7 @@ ;;;; -;;;; menu-language.lisp +;;;; defmenu.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 @@ -170,6 +170,8 @@ (defstruct menu-item-data text image) (defun generate-menusystem-code (sexp generator-sym) + (if (null sexp) + (error 'gfs:toolkit-error :detail "a value for :MENU is required")) (let ((code nil)) (mapcar #'(lambda (var) (setf code (append (process-item-form var generator-sym) code))) @@ -208,8 +210,28 @@ ;;; top-level API for the menu language ;;; +(defmacro defmenu2 (&key name menu) + (let ((gen (gensym)) + (tmp-name (gensym))) + `(let ((,tmp-name ,name)) + (if (get-menu-factory (thread-context) ,tmp-name) + (warn 'gfs:toolkit-warning + :detail (format nil "a menu with name ~S already exists" ,tmp-name))) + (put-menu-factory (thread-context) + ,tmp-name + (lambda () + (let ((,gen (make-instance 'win32-menu-generator))) + ,@(generate-menusystem-code menu gen) + (pop (menu-stack-of ,gen)))))))) + (defmacro defmenu (sexp) - (let ((gen (gensym))) - `(let ((,gen (make-instance 'win32-menu-generator))) - ,@(generate-menusystem-code sexp gen) - (pop (menu-stack-of ,gen))))) + `(funcall (defmenu2 :menu ,sexp))) + +(defun make-menu (menu-name) + (if (not (symbolp menu-name)) + (error 'toolkit-error :detail "the menu name must be a symbol")) + (let ((menu-fn (get-menu-factory (thread-context) menu-name))) + (unless menu-fn + (error 'gfs:toolkit-error + :detail (format nil "~a does not identify any existing menu" menu-name))) + (funcall menu-fn))) Added: trunk/src/uitoolkit/widgets/defwindow.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/defwindow.lisp Mon Jul 9 00:15:15 2007 @@ -0,0 +1,35 @@ +;;;; +;;;; defwindow.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) + Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Mon Jul 9 00:15:15 2007 @@ -58,6 +58,8 @@ (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) + (menu-factories :initform (make-hash-table :test #'eql)) + (window-factories :initform (make-hash-table :test #'eql)) (widget-in-progress :initform nil :accessor widget-in-progress)) (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop.")) @@ -280,3 +282,27 @@ (event-wparam event) wparam (event-lparam event) lparam) event)) + +(defun get-menu-factory (tc menu-name) + "Returns a function that creates a menu hierarchy based on a template defined via DEFMENU2." + (gethash menu-name (slot-value tc 'menu-factories))) + +(defun put-menu-factory (tc menu-name fn) + "Stores a function that creates a menu hierarchy based on a template defined via DEFMENU2." + (when menu-name + (if (not (symbolp menu-name)) + (error 'gfs:toolkit-error :detail "the menu name must be a symbol")) + (setf (gethash menu-name (slot-value tc 'menu-factories)) fn)) + fn) + +(defun get-window-factory (tc win-name) + "Returns a function that creates a window based on a template defined via DEFWINDOW." + (gethash win-name (slot-value tc 'window-factories))) + +(defun put-window-factory (tc win-name fn) + "Stores a function that creates a window based on a template defined via DEFWINDOW." + (when win-name + (if (not (symbolp win-name)) + (error 'gfs:toolkit-error :detail "the window name must be a symbol")) + (setf (gethash win-name (slot-value tc 'win-factories)) fn)) + fn)

1 0

[graphic-forms-cvs] r466 - branches/graphic-forms-newtypes/docs/manual
by junrue＠common-lisp.net 03 Jun '07

03 Jun '07

Author: junrue Date: Sun Jun 3 18:33:04 2007 New Revision: 466 Modified: branches/graphic-forms-newtypes/docs/manual/gfc-class-symbols.xml branches/graphic-forms-newtypes/docs/manual/gfw-class-symbols.xml branches/graphic-forms-newtypes/docs/manual/packages.xsl branches/graphic-forms-newtypes/docs/manual/symbols.xsl Log: restore alphabetic sorting of sections within each package's chapter Modified: branches/graphic-forms-newtypes/docs/manual/gfc-class-symbols.xml ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/gfc-class-symbols.xml (original) +++ branches/graphic-forms-newtypes/docs/manual/gfc-class-symbols.xml Sun Jun 3 18:33:04 2007 @@ -11,51 +11,6 @@  - <class name="listener-panel"> - <description> - <hierarchy> - <inherits> - <reftopic>gfw:panel</reftopic> - </inherits> - </hierarchy> - This class implements a text-based input/output component which - can serve as a REPL. Its size and location can be - maintained by its parent's layout manager; however, note that best - visual results are achieved when the panel is allowed to maintain - integral height and width. - </description> - <initargs> - <argument name=":callbacks"> - <description> - See <reftopic>gfw:event-source</reftopic>. - </description> - </argument> - <argument name=":dispatcher"> - <description> - See <reftopic>gfw:event-source</reftopic>. - </description> - </argument> - <argument name=":handle"> - <description> - See <reftopic>gfs:native-object</reftopic>. - </description> - </argument> - <argument name=":parent"> - <description> - See <reftopic>gfw:panel</reftopic>. - </description> - </argument> - <argument name=":style"> - <description> - </description> - </argument> - </initargs> - <seealso> - <reftopic>gfs:dispose</reftopic> - <reftopic>gfw:parent</reftopic> - </seealso> - </class> -  </symbols> Modified: branches/graphic-forms-newtypes/docs/manual/gfw-class-symbols.xml ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/gfw-class-symbols.xml (original) +++ branches/graphic-forms-newtypes/docs/manual/gfw-class-symbols.xml Sun Jun 3 18:33:04 2007 @@ -2074,6 +2074,54 @@ </seealso> </class> + <class name="progress-bar"> + <description> + <hierarchy> + <inherits> + <reftopic>gfw:control</reftopic> + </inherits> + </hierarchy> + This class represents non-selectable controls that provide visual feedback + for lengthy operations. The content of the progress-bar is filled as the + associated operation proceeds. + </description> + <initargs> + <argument name=":style"> + <description> + This is a <refclhs>list</refclhs> of keyword symbols that define + the look-and-feel of the progress-bar. + <enum> + <argument name=":horizontal"> + <description>Specifies horizontal orientation (default).</description> + </argument> + <argument name=":smooth"> + <description> + The progress-bar is filled in a continuous manner rather than in + segments. + </description> + </argument> + <argument name=":vertical"> + <description>Specifies vertical orientation.</description> + </argument> + </enum> + </description> + </argument> + <argument name=":parent"> + <description> + See <reftopic>gfw:control</reftopic>. + </description> + </argument> + <argument name=":handle"> + <description> + See <reftopic>gfs:native-object</reftopic>. + </description> + </argument> + </initargs> + <seealso> + <reftopic>gfs:dispose</reftopic> + </seealso> + </class> + <class name="status-bar"> <description> <hierarchy> Modified: branches/graphic-forms-newtypes/docs/manual/packages.xsl ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/packages.xsl (original) +++ branches/graphic-forms-newtypes/docs/manual/packages.xsl Sun Jun 3 18:33:04 2007 @@ -135,11 +135,17 @@ </para> </bridgehead> - <xsl:for-each select="symbol-files/file"> - <xsl:variable name="filename" select="concat(@basename,'-tmp.xml')"/> - <xsl:for-each select="document($filename)/data/section"> - <xsl:copy-of select="current()"/> + <xsl:variable name="sections"> + <xsl:for-each select="symbol-files/file"> + <xsl:variable name="filename" select="concat(@basename,'-tmp.xml')"/> + <xsl:for-each select="document($filename)/data/section"> + <xsl:copy-of select="current()"/> + </xsl:for-each> </xsl:for-each> + </xsl:variable> + <xsl:for-each select="exsl:node-set($sections)/section"> + <xsl:sort select="current()/indexterm/primary" order="ascending" case-order="upper-first"/> + <xsl:copy-of select="current()"/> </xsl:for-each> </chapter> Modified: branches/graphic-forms-newtypes/docs/manual/symbols.xsl ============================================================================== --- branches/graphic-forms-newtypes/docs/manual/symbols.xsl (original) +++ branches/graphic-forms-newtypes/docs/manual/symbols.xsl Sun Jun 3 18:33:04 2007 @@ -475,7 +475,9 @@ <xsl:template match="/symbols"> <data> <xsl:apply-templates> + </xsl:apply-templates> </data> </xsl:template>

1 0

[graphic-forms-cvs] r464 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:30:16 2007 New Revision: 464 Modified: trunk/NEWS.txt trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/progress-bar.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: further implementation of progress-bar control Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Thu Apr 5 00:30:16 2007 @@ -6,10 +6,14 @@ . Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) -. Implemented simple-mode status bars, which have a single text field. +. Implemented GFW:STATUS-BAR which currently allow a single text field. Multi-part status bars, and nested widget support, will be added in a future release. +. Implemented GFW:PROGRESS-BAR, which provides visual progress feedback. This + control can be configured for horizontal or vertical orientation, and can + display a segmented or continuous indicator. + . Simplified the mechanism for specifying fixed, non-resizable windows by adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK to do the right thing if that style flag has been specified. Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Apr 5 00:30:16 2007 @@ -869,6 +869,8 @@ (defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) (defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) +(defconstant +pbs-smooth+ #x01) +(defconstant +pbs-vertical+ #x04) (defconstant +pbs-marquee+ #x08) (defconstant +pbs-smoothreverse+ #x10) Modified: trunk/src/uitoolkit/widgets/progress-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/progress-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/progress-bar.lisp Thu Apr 5 00:30:16 2007 @@ -1,5 +1,5 @@ ;;;; -;;;; progressbar.lisp +;;;; progress-bar.lisp ;;;; ;;;; Copyright (C) 2007, Jack D. Unrue ;;;; All rights reserved. @@ -54,6 +54,10 @@ "Returns the step increment for a progress bar." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) +(declaim (inline pb-horz-flags)) +(defun pb-horz-flags (flags) + (logand flags (lognot gfs::+pbs-vertical+))) + (declaim (inline pb-set-pos-absolute)) (defun pb-set-pos-absolute (p-bar pos) "Sets the absolute position of a progress bar and redraws it; returns the previous position." @@ -78,7 +82,50 @@ "Sets the step increment for a progress bar; returns the previous increment." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) +(declaim (inline pb-smooth-flags)) +(defun pb-smooth-flags (flags) + (logior flags gfs::+pbs-smooth+)) + (declaim (inline pb-stepit)) (defun pb-stepit (p-bar) "Advances the progress bar's position by its step increment and redraws it; returns the previous position." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) + +(declaim (inline pb-vert-flags)) +(defun pb-vert-flags (flags) + (logior flags gfs::+pbs-vertical+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((pbar progress-bar) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags +default-child-style+) + (style (style-of pbar))) + (loop for sym in style + do (ecase sym + ;; primary progress-bar styles + ;; + (:horizontal (setf std-flags (pb-horz-flags std-flags))) + (:vertical (setf std-flags (pb-vert-flags std-flags))) + + ;; styles that can be combined + ;; + (:smooth (setf std-flags (pb-smooth-flags std-flags))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((pbar progress-bar) &key parent &allow-other-keys) + (create-control pbar parent "" gfs::+icc-win95-classes+)) + +(defmethod preferred-size ((pbar progress-bar) width-hint height-hint) + (let ((size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width pbar) 2))) + (if (<= width-hint 0) + (setf (gfs:size-width size) +default-widget-width+)) + (incf (gfs:size-width size) b-width) + (if (<= height-hint 0) + (setf (gfs:size-height size) + (floor (* (gfs::get-system-metrics gfs::+sm-cyvscroll+) 3) 4))) + (incf (gfs:size-height size) b-width) + size)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 5 00:30:16 2007 @@ -218,7 +218,7 @@ (item-manager)) (define-control-class - progressbar + progress-bar "msctls_progress" 'event-select "This class represents controls that provide visual feedback for progress.")

1 0

[graphic-forms-cvs] r463 - in branches/graphic-forms-newtypes: . src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:27:34 2007 New Revision: 463 Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progress-bar.lisp - copied unchanged from r461, branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Removed: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Log: renamed progressbar to progress-bar Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd ============================================================================== --- branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd (original) +++ branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Thu Apr 5 00:27:34 2007 @@ -143,7 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") - (:file "progressbar") + (:file "progress-bar") (:file "event") (:file "scrolling-helper") (:file "scrollbar")

1 0

[graphic-forms-cvs] r462 - in trunk: . src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:26:11 2007 New Revision: 462 Added: trunk/src/uitoolkit/widgets/progress-bar.lisp - copied unchanged from r460, trunk/src/uitoolkit/widgets/progressbar.lisp Removed: trunk/src/uitoolkit/widgets/progressbar.lisp Modified: trunk/graphic-forms-uitoolkit.asd Log: renamed progressbar to progress-bar Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Apr 5 00:26:11 2007 @@ -143,7 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") - (:file "progressbar") + (:file "progress-bar") (:file "event") (:file "scrolling-helper") (:file "scrollbar")

1 0

[graphic-forms-cvs] r461 - in branches/graphic-forms-newtypes: . src src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 05 Apr '07

05 Apr '07

Author: junrue Date: Thu Apr 5 00:25:54 2007 New Revision: 461 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/packages.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Log: further implementation of progress-bar control Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Thu Apr 5 00:25:54 2007 @@ -6,10 +6,14 @@ . Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) -. Implemented simple-mode status bars, which have a single text field. +. Implemented GFW:STATUS-BAR which currently allow a single text field. Multi-part status bars, and nested widget support, will be added in a future release. +. Implemented GFW:PROGRESS-BAR, which provides visual progress feedback. This + control can be configured for horizontal or vertical orientation, and can + display a segmented or continuous indicator. + . Simplified the mechanism for specifying fixed, non-resizable windows by adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK to do the right thing if that style flag has been specified. Modified: branches/graphic-forms-newtypes/src/packages.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/packages.lisp (original) +++ branches/graphic-forms-newtypes/src/packages.lisp Thu Apr 5 00:25:54 2007 @@ -555,6 +555,7 @@ #:preferred-size #:primary-p #:process-events + #:progress-bar #:redraw #:redrawing-p #:release-mouse Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp Thu Apr 5 00:25:54 2007 @@ -869,6 +869,8 @@ (defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) (defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) +(defconstant +pbs-smooth+ #x01) +(defconstant +pbs-vertical+ #x04) (defconstant +pbs-marquee+ #x08) (defconstant +pbs-smoothreverse+ #x10) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Thu Apr 5 00:25:54 2007 @@ -1,5 +1,5 @@ ;;;; -;;;; progressbar.lisp +;;;; progress-bar.lisp ;;;; ;;;; Copyright (C) 2007, Jack D. Unrue ;;;; All rights reserved. @@ -53,6 +53,10 @@ (defun pb-get-step (p-bar) "Returns the step increment for a progress bar." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-horz-flags)) +(defun pb-horz-flags (flags) + (logand flags (lognot gfs::+pbs-vertical+))) (declaim (inline pb-set-pos-absolute)) (defun pb-set-pos-absolute (p-bar pos) @@ -78,7 +82,50 @@ "Sets the step increment for a progress bar; returns the previous increment." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) +(declaim (inline pb-smooth-flags)) +(defun pb-smooth-flags (flags) + (logior flags gfs::+pbs-smooth+)) + (declaim (inline pb-stepit)) (defun pb-stepit (p-bar) "Advances the progress bar's position by its step increment and redraws it; returns the previous position." (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) + +(declaim (inline pb-vert-flags)) +(defun pb-vert-flags (flags) + (logior flags gfs::+pbs-vertical+)) + +;;; +;;; methods +;;; + +(defmethod compute-style-flags ((pbar progress-bar) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags +default-child-style+) + (style (style-of pbar))) + (loop for sym in style + do (ecase sym + ;; primary progress-bar styles + ;; + (:horizontal (setf std-flags (pb-horz-flags std-flags))) + (:vertical (setf std-flags (pb-vert-flags std-flags))) + + ;; styles that can be combined + ;; + (:smooth (setf std-flags (pb-smooth-flags std-flags))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((pbar progress-bar) &key parent &allow-other-keys) + (create-control pbar parent "" gfs::+icc-win95-classes+)) + +(defmethod preferred-size ((pbar progress-bar) width-hint height-hint) + (let ((size (gfs:make-size :width width-hint :height height-hint)) + (b-width (* (border-width pbar) 2))) + (if (<= width-hint 0) + (setf (gfs:size-width size) +default-widget-width+)) + (incf (gfs:size-width size) b-width) + (if (<= height-hint 0) + (setf (gfs:size-height size) + (floor (* (gfs::get-system-metrics gfs::+sm-cyvscroll+) 3) 4))) + (incf (gfs:size-height size) b-width) + size)) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Thu Apr 5 00:25:54 2007 @@ -218,7 +218,7 @@ (item-manager)) (define-control-class - progressbar + progress-bar "msctls_progress" 'event-select "This class represents controls that provide visual feedback for progress.")

1 0

[graphic-forms-cvs] r460 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Tue Apr 3 00:45:38 2007 New Revision: 460 Added: trunk/src/uitoolkit/widgets/progressbar.lisp Modified: trunk/NEWS.txt trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: initial steps toward progress-bar implementation; fixed typo in top-level override for pack method Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Tue Apr 3 00:45:38 2007 @@ -1,7 +1,10 @@ . Latest CFFI is required to take advantage of built-in support for the - stdcall calling convention (FIXME: change checked in this past Feb., need - to narrow down which snapshot actually has it). + stdcall calling convention. + +. Ported the library to Allegro CL 8.0. + +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) . Implemented simple-mode status bars, which have a single text field. Multi-part status bars, and nested widget support, will be added in a @@ -14,10 +17,6 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Ported the library to Allegro CL 8.0. - -. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) - . Implemented a new graphics context function GFG:CLEAR that is a convenient way to fill a window or image with a background color. Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Tue Apr 3 00:45:38 2007 @@ -143,6 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") + (:file "progressbar") (:file "event") (:file "scrolling-helper") (:file "scrollbar") Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Apr 3 00:45:38 2007 @@ -848,6 +848,34 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +;;; +;;; progress bar messages and style bits +;;; + +(defconstant +pbm-setrange+ #x0401) ; (WM_USER+1) +(defconstant +pbm-setpos+ #x0402) ; (WM_USER+2) +(defconstant +pbm-deltapos+ #x0403) ; (WM_USER+3) +(defconstant +pbm-setstep+ #x0404) ; (WM_USER+4) +(defconstant +pbm-stepit+ #x0405) ; (WM_USER+5) +(defconstant +pbm-setrange32+ #x0406) ; (WM_USER+6) +(defconstant +pbm-getrange+ #x0407) ; (WM_USER+7) +(defconstant +pbm-getpos+ #x0408) ; (WM_USER+8) +(defconstant +pbm-setbarcolor+ #x0409) ; (WM_USER+9) +(defconstant +pbm-setbkcolor+ #x2001) ; CCM_SETBKCOLOR +(defconstant +pbm-setmarquee+ #x040a) ; (WM_USER+10) +(defconstant +pbm-getstep+ #x040d) ; (WM_USER+13) +(defconstant +pbm-getbkcolor+ #x040e) ; (WM_USER+14) +(defconstant +pbm-getbarcolor+ #x040f) ; (WM_USER+15) +(defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) +(defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) + +(defconstant +pbs-marquee+ #x08) +(defconstant +pbs-smoothreverse+ #x10) + +(defconstant +pbst-normal+ #x0001) +(defconstant +pbst-error+ #x0002) +(defconstant +pbst-paused+ #x0003) + (defconstant +pderr-printercodes+ #x1000) (defconstant +pderr-setupfailure+ #x1001) (defconstant +pderr-parsefailure+ #x1002) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Apr 3 00:45:38 2007 @@ -309,6 +309,10 @@ (incupdate BOOL) (reserved :unsigned-char :count 32)) +(defcstruct pbrange + (low INT) + (high INT)) + (defctype rect-pointer :pointer) (defcstruct rect Added: trunk/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/progressbar.lisp Tue Apr 3 00:45:38 2007 @@ -0,0 +1,84 @@ +;;;; +;;;; progressbar.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) + +;;; +;;; helper functions +;;; + +(declaim (inline pb-get-pos)) +(defun pb-get-pos (p-bar) + "Returns the current position of a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getpos+ 0 0)) + +(defun pb-get-range (p-bar) + "Returns the range of a progress bar." + (cffi:with-foreign-object (r-ptr 'gfs::pbrange) + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getrange+ 0 (cffi:pointer-address r-ptr)) + (cffi:with-foreign-slots ((gfs::low gfs::high) r-ptr gfs::pbrange) + (gfs:make-span :start gfs::low :end gfs::high)))) + +(declaim (inline pb-get-step)) +(defun pb-get-step (p-bar) + "Returns the step increment for a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-set-pos-absolute)) +(defun pb-set-pos-absolute (p-bar pos) + "Sets the absolute position of a progress bar and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setpos+ (logand pos #xFFFF) 0)) + +(declaim (inline pb-set-pos-delta)) +(defun pb-set-pos-delta (p-bar delta) + "Updates the position of a progress bar by delta and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-deltapos+ (logand delta #xFFFF) 0)) + +(defun pb-set-range (p-bar span) + "Sets the range of a progress bar; returns the previous range." + (let ((result (gfs::send-message (gfs:handle p-bar) + gfs::+pbm-setrange32+ + (logand (gfs:span-start span) #xFFFFFFFF) + (logand (gfs:span-end span) #xFFFFFFFF)))) + (gfs:make-span :start (gfs::lparam-low-word result) + :end (gfs::lparam-high-word result)))) + +(declaim (inline pb-set-step)) +(defun pb-set-step (p-bar increment) + "Sets the step increment for a progress bar; returns the previous increment." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) + +(declaim (inline pb-stepit)) +(defun pb-stepit (p-bar) + "Advances the progress bar's position by its step increment and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Apr 3 00:45:38 2007 @@ -195,7 +195,7 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) -(defmethod pack ((win window)) +(defmethod pack ((win top-level)) (if (find :fixed-size (style-of win)) (let ((size (gfw:preferred-size win -1 -1))) (setf (gfw:minimum-size win) size Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Tue Apr 3 00:45:38 2007 @@ -218,6 +218,12 @@ (item-manager)) (define-control-class + progressbar + "msctls_progress" + 'event-select + "This class represents controls that provide visual feedback for progress.") + +(define-control-class scrollbar "scrollbar" 'event-scroll

1 0

[graphic-forms-cvs] r459 - in branches/graphic-forms-newtypes: . src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Tue Apr 3 00:45:18 2007 New Revision: 459 Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Log: initial steps toward progress-bar implementation; fixed typo in top-level override for pack method Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Tue Apr 3 00:45:18 2007 @@ -1,7 +1,10 @@ . Latest CFFI is required to take advantage of built-in support for the - stdcall calling convention (FIXME: change checked in this past Feb., need - to narrow down which snapshot actually has it). + stdcall calling convention. + +. Ported the library to Allegro CL 8.0. + +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) . Implemented simple-mode status bars, which have a single text field. Multi-part status bars, and nested widget support, will be added in a @@ -14,10 +17,6 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Ported the library to Allegro CL 8.0. - -. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) - . Implemented a new graphics context function GFG:CLEAR that is a convenient way to fill a window or image with a background color. Modified: branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd ============================================================================== --- branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd (original) +++ branches/graphic-forms-newtypes/graphic-forms-uitoolkit.asd Tue Apr 3 00:45:18 2007 @@ -143,6 +143,7 @@ (:file "menu") (:file "menu-item") (:file "menu-language") + (:file "progressbar") (:file "event") (:file "scrolling-helper") (:file "scrollbar") Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-constants.lisp Tue Apr 3 00:45:18 2007 @@ -848,6 +848,34 @@ (defconstant +out-screen-outline-precis+ 9) (defconstant +out-ps-only-precis+ 10) +;;; +;;; progress bar messages and style bits +;;; + +(defconstant +pbm-setrange+ #x0401) ; (WM_USER+1) +(defconstant +pbm-setpos+ #x0402) ; (WM_USER+2) +(defconstant +pbm-deltapos+ #x0403) ; (WM_USER+3) +(defconstant +pbm-setstep+ #x0404) ; (WM_USER+4) +(defconstant +pbm-stepit+ #x0405) ; (WM_USER+5) +(defconstant +pbm-setrange32+ #x0406) ; (WM_USER+6) +(defconstant +pbm-getrange+ #x0407) ; (WM_USER+7) +(defconstant +pbm-getpos+ #x0408) ; (WM_USER+8) +(defconstant +pbm-setbarcolor+ #x0409) ; (WM_USER+9) +(defconstant +pbm-setbkcolor+ #x2001) ; CCM_SETBKCOLOR +(defconstant +pbm-setmarquee+ #x040a) ; (WM_USER+10) +(defconstant +pbm-getstep+ #x040d) ; (WM_USER+13) +(defconstant +pbm-getbkcolor+ #x040e) ; (WM_USER+14) +(defconstant +pbm-getbarcolor+ #x040f) ; (WM_USER+15) +(defconstant +pbm-setstate+ #x0410) ; (WM_USER+16) +(defconstant +pbm-getstate+ #x0411) ; (WM_USER+17) + +(defconstant +pbs-marquee+ #x08) +(defconstant +pbs-smoothreverse+ #x10) + +(defconstant +pbst-normal+ #x0001) +(defconstant +pbst-error+ #x0002) +(defconstant +pbst-paused+ #x0003) + (defconstant +pderr-printercodes+ #x1000) (defconstant +pderr-setupfailure+ #x1001) (defconstant +pderr-parsefailure+ #x1002) Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp Tue Apr 3 00:45:18 2007 @@ -320,6 +320,10 @@ (incupdate BOOL) (reserved :unsigned-char :count 32)) +(defcstruct pbrange + (low INT) + (high INT)) + (define-foreign-type rect-pointer-type () () (:actual-type :pointer) (:simple-parser rect-pointer)) Added: branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp ============================================================================== --- (empty file) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/progressbar.lisp Tue Apr 3 00:45:18 2007 @@ -0,0 +1,84 @@ +;;;; +;;;; progressbar.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) + +;;; +;;; helper functions +;;; + +(declaim (inline pb-get-pos)) +(defun pb-get-pos (p-bar) + "Returns the current position of a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getpos+ 0 0)) + +(defun pb-get-range (p-bar) + "Returns the range of a progress bar." + (cffi:with-foreign-object (r-ptr 'gfs::pbrange) + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getrange+ 0 (cffi:pointer-address r-ptr)) + (cffi:with-foreign-slots ((gfs::low gfs::high) r-ptr gfs::pbrange) + (gfs:make-span :start gfs::low :end gfs::high)))) + +(declaim (inline pb-get-step)) +(defun pb-get-step (p-bar) + "Returns the step increment for a progress bar." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-getstep+ 0 0)) + +(declaim (inline pb-set-pos-absolute)) +(defun pb-set-pos-absolute (p-bar pos) + "Sets the absolute position of a progress bar and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setpos+ (logand pos #xFFFF) 0)) + +(declaim (inline pb-set-pos-delta)) +(defun pb-set-pos-delta (p-bar delta) + "Updates the position of a progress bar by delta and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-deltapos+ (logand delta #xFFFF) 0)) + +(defun pb-set-range (p-bar span) + "Sets the range of a progress bar; returns the previous range." + (let ((result (gfs::send-message (gfs:handle p-bar) + gfs::+pbm-setrange32+ + (logand (gfs:span-start span) #xFFFFFFFF) + (logand (gfs:span-end span) #xFFFFFFFF)))) + (gfs:make-span :start (gfs::lparam-low-word result) + :end (gfs::lparam-high-word result)))) + +(declaim (inline pb-set-step)) +(defun pb-set-step (p-bar increment) + "Sets the step increment for a progress bar; returns the previous increment." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-setstep+ (logand increment #xFFFF) 0)) + +(declaim (inline pb-stepit)) +(defun pb-stepit (p-bar) + "Advances the progress bar's position by its step increment and redraws it; returns the previous position." + (gfs::send-message (gfs:handle p-bar) gfs::+pbm-stepit+ 0 0)) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Tue Apr 3 00:45:18 2007 @@ -195,7 +195,7 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) -(defmethod pack ((win window)) +(defmethod pack ((win top-level)) (if (find :fixed-size (style-of win)) (let ((size (gfw:preferred-size win -1 -1))) (setf (gfw:minimum-size win) size Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-classes.lisp Tue Apr 3 00:45:18 2007 @@ -218,6 +218,12 @@ (item-manager)) (define-control-class + progressbar + "msctls_progress" + 'event-select + "This class represents controls that provide visual feedback for progress.") + +(define-control-class scrollbar "scrollbar" 'event-scroll

1 0

[graphic-forms-cvs] r458 - trunk
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:39:40 2007 New Revision: 458 Modified: trunk/NEWS.txt Log: sync up NEWS.txt with newtypes branch Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Mon Apr 2 22:39:40 2007 @@ -3,6 +3,14 @@ stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). +. Implemented simple-mode status bars, which have a single text field. + Multi-part status bars, and nested widget support, will be added in a + future release. + +. Simplified the mechanism for specifying fixed, non-resizable windows by + adding a new GFW:TOP-LEVEL style called :FIXED-SIZE and enhancing GFW:PACK + to do the right thing if that style flag has been specified. + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner.

1 0

[graphic-forms-cvs] r457 - in trunk: docs/manual src/demos/unblocked src/uitoolkit/widgets
by junrue＠common-lisp.net 03 Apr '07

03 Apr '07

Author: junrue Date: Mon Apr 2 22:37:50 2007 New Revision: 457 Modified: trunk/docs/manual/gfw-symbols.xml trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/status-bar.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: implemented new top-level style :fixed-size and modified gfw:pack to set min and max sizes when :fixed-size has been set; added another optional parameter to CREATE-CONTROL convenience function to allow control initializers to pass params to their implementations of COMPUTE-STYLE-FLAGS Modified: trunk/docs/manual/gfw-symbols.xml ============================================================================== --- trunk/docs/manual/gfw-symbols.xml (original) +++ trunk/docs/manual/gfw-symbols.xml Mon Apr 2 22:37:50 2007 @@ -1419,6 +1419,12 @@ </enum> One or more of the following optional styles: <enum> + <argument name=":fixed-size"> + <description> + The resulting window cannot be dragged to a new size, but a layout + manager can still resize it programmatically. + </description> + </argument> <argument name=":horizontal-scrollbar"/> <argument name=":status-bar"/> <argument name=":vertical-scrollbar"/> Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Mon Apr 2 22:37:50 2007 @@ -112,7 +112,7 @@ :style :vertical :spacing +spacing+ :margins +margin+) - :style '(:workspace :status-bar))) + :style '(:fixed-size :workspace :status-bar))) (setf (gfw:menu-bar *unblocked-win*) menubar) (setf *scoreboard-panel* (make-instance 'scoreboard-panel :parent *unblocked-win* @@ -126,10 +126,7 @@ :buffer-size tile-buffer-size))) (setf (gfw:text *unblocked-win*) "UnBlocked") - (setf (gfw:resizable-p *unblocked-win*) nil) - (let ((size (gfw:preferred-size *unblocked-win* -1 -1))) - (setf (gfw:minimum-size *unblocked-win*) size - (gfw:maximum-size *unblocked-win*) size)) + (gfw:pack *unblocked-win*) (new-unblocked nil nil) (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Apr 2 22:37:50 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; control.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 @@ -45,10 +45,10 @@ (if (and (zerop (gfs::init-common-controls ic-ptr)) (/= (gfs::get-last-error) 0)) (warn 'gfs:win32-warning :detail "init-common-controls failed")))) -(defun create-control (ctrl parent text icc-flags &optional id) +(defun create-control (ctrl parent text icc-flags &optional id extra-data) (initialize-comctl-classes icc-flags) (multiple-value-bind (std-style ex-style) - (compute-style-flags ctrl) + (compute-style-flags ctrl extra-data) (let ((hwnd (create-window (system-classname-of ctrl) (or text " ") (gfs:handle parent) Modified: trunk/src/uitoolkit/widgets/status-bar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/status-bar.lisp (original) +++ trunk/src/uitoolkit/widgets/status-bar.lisp Mon Apr 2 22:37:50 2007 @@ -104,11 +104,16 @@ (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)) + (let ((extra-bits (if (first extra-data) 0 gfs::+sbars-sizegrip+))) + (values (logior gfs::+ws-child+ gfs::+ws-visible+ extra-bits) 0))) (defmethod initialize-instance :after ((self status-bar) &key parent &allow-other-keys) - (let ((hctl (create-control self parent "" gfs::+icc-win95-classes+))) + (let ((hctl (create-control self + parent + "" + gfs::+icc-win95-classes+ + nil + (find :fixed-size (style-of parent))))) (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))))) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Mon Apr 2 22:37:50 2007 @@ -111,13 +111,10 @@ ;; styles that can be combined ;; -#| - (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) - (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) -|# + (:fixed-size + (setf std-flags (logand std-flags + (lognot (logior gfs::+ws-maximizebox+ + gfs::+ws-thickframe+))))) (:horizontal-scrollbar (setf std-flags (logior std-flags gfs::+ws-hscroll+))) (:status-bar) ;; nothing to do, but need to allow this style symbol @@ -198,6 +195,13 @@ (when (and (maximum-size self) min-size) (update-top-level-resizability self (gfs:equal-size-p min-size (maximum-size self))))) +(defmethod pack ((win window)) + (if (find :fixed-size (style-of win)) + (let ((size (gfw:preferred-size win -1 -1))) + (setf (gfw:minimum-size win) size + (gfw:maximum-size win) size))) + (call-next-method)) + (defmethod preferred-size ((self top-level) width-hint height-hint) (declare (ignore width-hint height-hint)) (let ((size (call-next-method))

1 0