[graphic-forms-cvs] r460 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Apr 3 04:45:39 UTC 2007
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
More information about the Graphic-forms-cvs
mailing list