[graphic-forms-cvs] r275 - in trunk: . docs/manual src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 29 03:34:15 UTC 2006
Author: junrue
Date: Thu Sep 28 23:34:15 2006
New Revision: 275
Added:
trunk/src/uitoolkit/widgets/slider.lisp
Modified:
trunk/docs/manual/widget-types.texinfo
trunk/graphic-forms-uitoolkit.asd
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/widgets/scrollbar.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
Log:
started work on slider control
Modified: trunk/docs/manual/widget-types.texinfo
==============================================================================
--- trunk/docs/manual/widget-types.texinfo (original)
+++ trunk/docs/manual/widget-types.texinfo Thu Sep 28 23:34:15 2006
@@ -474,6 +474,47 @@
@end deffn
@end-control-subclass
+ at begin-control-subclass{slider,
+This class represents a @ref{control} having a slider component and optional
+tick marks.,
+event-select}
+ at control-callback-initarg{slider,event-select}
+ at deffn Initarg :style
+ at begin-primary-style-choices{By default\, sliders are oriented horizontally
+with a tick mark below the control at the beginning and end of its range.}
+ at item :auto-ticks
+Specifies that the slider will display a tick mark for
+each increment in its value range. Compare with @code{:no-ticks}.
+ at item :horizontal
+This style keyword configures the slider to be oriented horizontally.
+ at item :no-ticks
+Specifies that the slider will not display any tick marks. Compare
+with @code{:auto-ticks}.
+ at item :vertical
+This style keyword configures the slider to be oriented vertically.
+ at end-primary-style-choices
+ at begin-optional-style-choices
+ at item :constrained-range
+Specifies that the slider restricts (and highlights) a subset of the
+total range; the subset is indicated with triangles instead of dashes.
+ at item :no-border
+By default, a slider is drawn with a border; this style keyword
+disables that feature.
+ at item :ticks-after
+Specifies that the slider should display its tick marks
+to the right of (or below) the control. This style can
+be combined with @code{:ticks-before}.
+ at item :ticks-before
+Specifies that the slider should display its tick marks
+to the left of (or above) the control. This style can
+be combined with @code{:ticks-after}.
+ at item :tooltip
+Specifies that the slider should display a
+tooltip showing its current position. The side on which the
+tooltip appears can be configured with @strong{FIXME}
+ at end-optional-style-choices
+ at end deffn
+ at end-control-subclass
@node Windows and dialogs
@subsection Windows and dialogs
Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd (original)
+++ trunk/graphic-forms-uitoolkit.asd Thu Sep 28 23:34:15 2006
@@ -140,6 +140,7 @@
(:file "event")
(:file "scrolling-event-dispatcher")
(:file "scrollbar")
+ (:file "slider")
(:file "window")
(:file "root-window")
(:file "top-level")
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Thu Sep 28 23:34:15 2006
@@ -36,21 +36,26 @@
;;;
;;; control class names
;;;
-(defparameter *button-classname* "button")
-(defparameter *edit-classname* "edit")
-(defparameter *listbox-classname* "listbox")
-(defparameter *static-classname* "static")
+(defparameter *button-classname* "button")
+(defparameter *edit-classname* "edit")
+(defparameter *listbox-classname* "listbox")
+(defparameter *scrollbar-classname* "scrollbar")
+(defparameter *static-classname* "static")
+(defparameter *trackbar-classname* "msctls_trackbar32")
;;;
;;; registered message names
;;;
-(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify")
-(defparameter *sharevistringa* "commdlg_ShareViolation")
-(defparameter *fileokstringa* "commdlg_FileNameOK")
-(defparameter *colorokstringa* "commdlg_ColorOK")
-(defparameter *setrgbstringa* "commdlg_SetRGBColor")
-(defparameter *helpmsgstringa* "commdlg_help")
-(defparameter *findmsgstringa* "commdlg_FindReplace")
+(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify")
+(defparameter *sharevistringa* "commdlg_ShareViolation")
+(defparameter *fileokstringa* "commdlg_FileNameOK")
+(defparameter *colorokstringa* "commdlg_ColorOK")
+(defparameter *setrgbstringa* "commdlg_SetRGBColor")
+(defparameter *helpmsgstringa* "commdlg_help")
+(defparameter *findmsgstringa* "commdlg_FindReplace")
+
+(defconstant +wm-user+ #x0400)
+(defconstant +wm-app+ #x8000)
(defconstant +ad-counterclockwise+ 1)
(defconstant +ad-clockwise+ 2)
@@ -887,6 +892,17 @@
(defconstant +sb-right+ 7)
(defconstant +sb-endscroll+ 8)
+(defconstant +sbs-horz+ #x0000)
+(defconstant +sbs-vert+ #x0001)
+(defconstant +sbs-topalign+ #x0002)
+(defconstant +sbs-leftalign+ #x0002)
+(defconstant +sbs-bottomalign+ #x0004)
+(defconstant +sbs-rightalign+ #x0004)
+(defconstant +sbs-sizeboxtopleftalign+ #x0002)
+(defconstant +sbs-sizeboxbottomrightalign+ #x0004)
+(defconstant +sbs-sizebox+ #x0008)
+(defconstant +sbs-sizegrip+ #x0010)
+
(defconstant +sif-range+ #x0001)
(defconstant +sif-page+ #x0002)
(defconstant +sif-pos+ #x0004)
@@ -1066,6 +1082,16 @@
(defconstant +sw-forceminimize+ 11)
(defconstant +sw-max+ 11)
+(defconstant +tb-lineup+ 0)
+(defconstant +tb-linedown+ 1)
+(defconstant +tb-pageup+ 2)
+(defconstant +tb-pagedown+ 3)
+(defconstant +tb-thumbposition+ 4)
+(defconstant +tb-thumbtrack+ 5)
+(defconstant +tb-top+ 6)
+(defconstant +tb-bottom+ 7)
+(defconstant +tb-endtrack+ 8)
+
(defconstant +swp-nosize+ #x0001)
(defconstant +swp-nomove+ #x0002)
(defconstant +swp-nozorder+ #x0004)
@@ -1082,6 +1108,49 @@
(defconstant +swp-defererase+ #x2000)
(defconstant +swp-asyncwindowpos+ #x4000)
+(defconstant +tbm-getpos+ +wm-user+)
+(defconstant +tbm-getrangemin+ (+ +wm-user+ 1))
+(defconstant +tbm-getrangemax+ (+ +wm-user+ 2))
+(defconstant +tbm-gettic+ (+ +wm-user+ 3))
+(defconstant +tbm-settic+ (+ +wm-user+ 4))
+(defconstant +tbm-setpos+ (+ +wm-user+ 5))
+(defconstant +tbm-setrange+ (+ +wm-user+ 6))
+(defconstant +tbm-setrangemin+ (+ +wm-user+ 7))
+(defconstant +tbm-setrangemax+ (+ +wm-user+ 8))
+(defconstant +tbm-cleartics+ (+ +wm-user+ 9))
+(defconstant +tbm-setsel+ (+ +wm-user+ 10))
+(defconstant +tbm-setselstart+ (+ +wm-user+ 11))
+(defconstant +tbm-setselend+ (+ +wm-user+ 12))
+(defconstant +tbm-getptics+ (+ +wm-user+ 14))
+(defconstant +tbm-getticpos+ (+ +wm-user+ 15))
+(defconstant +tbm-getnumtics+ (+ +wm-user+ 16))
+(defconstant +tbm-getselstart+ (+ +wm-user+ 17))
+(defconstant +tbm-getselend+ (+ +wm-user+ 18))
+(defconstant +tbm-clearsel+ (+ +wm-user+ 19))
+(defconstant +tbm-setticfreq+ (+ +wm-user+ 20))
+(defconstant +tbm-setpagesize+ (+ +wm-user+ 21))
+(defconstant +tbm-getpagesize+ (+ +wm-user+ 22))
+(defconstant +tbm-setlinesize+ (+ +wm-user+ 23))
+(defconstant +tbm-getlinesize+ (+ +wm-user+ 24))
+(defconstant +tbm-getthumbrect+ (+ +wm-user+ 25))
+(defconstant +tbm-getchannelrect+ (+ +wm-user+ 26))
+(defconstant +tbm-setthumblength+ (+ +wm-user+ 27))
+(defconstant +tbm-getthumblength+ (+ +wm-user+ 28))
+
+(defconstant +tbs-autoticks+ #x0001)
+(defconstant +tbs-vert+ #x0002)
+(defconstant +tbs-horz+ #x0000)
+(defconstant +tbs-top+ #x0004)
+(defconstant +tbs-bottom+ #x0000)
+(defconstant +tbs-left+ #x0004)
+(defconstant +tbs-right+ #x0000)
+(defconstant +tbs-both+ #x0008)
+(defconstant +tbs-noticks+ #x0010)
+(defconstant +tbs-enableselrange+ #x0020)
+(defconstant +tbs-fixedlength+ #x0040)
+(defconstant +tbs-nothumb+ #x0080)
+(defconstant +tbs-tooltips+ #x0100)
+
(defconstant +tpm-leftbutton+ #x0000)
(defconstant +tpm-rightbutton+ #x0002)
(defconstant +tpm-leftalign+ #x0000)
@@ -1256,8 +1325,6 @@
(defconstant +wm-printclient+ #x0318)
(defconstant +wm-appcommand+ #x0319)
(defconstant +wm-themechanged+ #x031A)
-(defconstant +wm-user-base+ #x0400)
-(defconstant +wm-app-base+ #x8000)
(defconstant +ws-overlapped+ #x00000000)
(defconstant +ws-popup+ #x80000000)
Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrollbar.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrollbar.lisp Thu Sep 28 23:34:15 2006
@@ -173,7 +173,7 @@
(defmethod (setf step-increment) (amount (self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (uness (>= amount 0)
+ (unless (>= amount 0)
(warn 'gfs:toolkit-warning :detail "negative step increment"))
(let ((disp (dispatcher (parent self))))
(cond
Added: trunk/src/uitoolkit/widgets/slider.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/slider.lisp Thu Sep 28 23:34:15 2006
@@ -0,0 +1,98 @@
+;;;;
+;;;; slider.lisp
+;;;;
+;;;; Copyright (C) 2006, 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
+;;;
+
+(defun sl-auto-ticks-flags (orig-flags)
+ (logior (logand orig-flags (lognot gfs::+tbs-noticks+)) gfs::+tbs-autoticks+))
+
+(defun sl-no-ticks-flags (orig-flags)
+ (setf orig-flags (logand orig-flags (lognot (logior gfs::+tbs-top+ gfs::+tbs-left+))))
+ (logior (logand orig-flags (lognot gfs::+tbs-autoticks+)) gfs::+tbs-noticks+))
+
+(defun sl-ticks-after-flags (orig-flags)
+ (setf orig-flags (logand orig-flags (lognot gfs::+tbs-both+)))
+ (logand orig-flags (lognot gfs::+tbs-top+)))
+
+(defun sl-ticks-before-flags (orig-flags)
+ (setf orig-flags (logand orig-flags (lognot gfs::+tbs-both+)))
+ (logior orig-flags gfs::+tbs-top+))
+
+(defun sl-ticks-both-flags (orig-flags)
+ (setf orig-flags (logand orig-flags (lognot gfs::+tbs-top+)))
+ (logior orig-flags gfs::+tbs-both+))
+
+(defun sl-horizontal-flags (orig-flags)
+ (logand orig-flags (lognot gfs::+tbs-vert+)))
+
+(defun sl-sel-range-flags (orig-flags)
+ (logior orig-flags gfs::+tbs-enableselrange+))
+
+(defun sl-tooltip-flags (orig-flags)
+ (logior orig-flags gfs::+tbs-tooltips+))
+
+(defun sl-vertical-flags (orig-flags)
+ (logior orig-flags gfs::+tbs-vert+))
+
+(defun sl-no-border-flags (orig-flags)
+ (logand orig-flags (lognot gfs::+ws-border+)))
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((self slider) &rest extra-data)
+ (declare (ignore extra-data))
+ (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+ws-border+))
+ (style (style-of self)))
+ (loop for sym in style
+ do (ecase sym
+ ;; primary slider styles
+ ;;
+ (:horizontal (setf std-flags (sl-horizontal-flags std-flags)))
+ (:vertical (setf std-flags (sl-vertical-flags std-flags)))
+ (:auto-ticks (setf std-flags (sl-auto-ticks-flags std-flags)))
+ (:no-ticks (setf std-flags (sl-no-ticks-flags std-flags)))
+
+ ;; styles that can be combined
+ ;;
+ (:constrained-range (setf std-flags (sl-sel-range-flags std-flags)))
+ (:no-border (setf std-flags (sl-no-border-flags std-flags)))
+ (:ticks-after (setf std-flags (sl-ticks-after-flags std-flags)))
+ (:ticks-before (setf std-flags (sl-ticks-before-flags std-flags)))
+ (:tooltip (setf std-flags (sl-tooltip-flags std-flags)))))
+ (values std-flags 0)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Thu Sep 28 23:34:15 2006
@@ -198,7 +198,7 @@
(define-control-class
list-box
'event-select
- "The list-box class represents the standard listbox control."
+ "The list-box class represents a listbox control."
(item-manager))
(define-control-class
More information about the Graphic-forms-cvs
mailing list