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

+@begin-control-subclass{slider, +This class represents a @ref{control} having a slider component and optional +tick marks., +event-select} +@control-callback-initarg{slider,event-select} +@deffn Initarg :style +@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.} +@item :auto-ticks +Specifies that the slider will display a tick mark for +each increment in its value range. Compare with @code{:no-ticks}. +@item :horizontal +This style keyword configures the slider to be oriented horizontally. +@item :no-ticks +Specifies that the slider will not display any tick marks. Compare +with @code{:auto-ticks}. +@item :vertical +This style keyword configures the slider to be oriented vertically. +@end-primary-style-choices +@begin-optional-style-choices +@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. +@item :no-border +By default, a slider is drawn with a border; this style keyword +disables that feature. +@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}. +@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}. +@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} +@end-optional-style-choices +@end deffn +@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