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