[graphic-forms-cvs] r278 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sat Sep 30 16:43:31 UTC 2006
Author: junrue
Date: Sat Sep 30 12:43:30 2006
New Revision: 278
Modified:
trunk/docs/manual/widget-functions.texinfo
trunk/docs/manual/widget-types.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/widget-tester.lisp
trunk/src/uitoolkit/system/system-utils.lisp
trunk/src/uitoolkit/widgets/control.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/scrollbar.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
trunk/src/uitoolkit/widgets/slider.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
slider controls now getting created, more work needed; renamed thumb-limits GF to outer-limits and added inner-limits
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Sat Sep 30 12:43:30 2006
@@ -283,6 +283,18 @@
an image or an icon-bundle.
@end deffn
+ at anchor{inner-limits}
+ at deffn GenericFunction inner-limits self => @ref{span}
+(setf (@strong{inner-limits} @var{self}) @var{span})@*
+
+Certain @ref{control}s having the concept of a range of values within
+which a selector may be positioned also allow the indicator to
+be further constrained to a narrower range, e.g., @ref{slider}.
+By default, this function returns the same span that @ref{outer-limits}
+does. If the @sc{setf} function is used to set a sub-range, @var{self}'s
+visual style will be updated and the indicator restricted appropriately.
+ at end deffn
+
@anchor{item-count}
@deffn GenericFunction item-count self => integer
Returns the number of instances of @ref{item} subclasses contained within
@@ -419,6 +431,18 @@
being the primary.
@end defun
+ at anchor{outer-limits}
+ at deffn GenericFunction outer-limits self => @ref{span}
+(setf (@strong{outer-limits} @var{self}) @var{span})@*
+
+Returns a span representing the widest range of start and end
+positions to which the indicator within @var{self} may be set. The
+ at sc{setf} function allows this span to be modified. Application code
+is responsible for synchronizing the range with its content model.
+Certain controls also allow the actual range of positions to be
+further constrained; @xref{inner-limits}.
+ at end deffn
+
@anchor{owner}
@deffn GenericFunction owner self
Returns the @var{owner} of @var{self}, which may be different from
@@ -672,17 +696,6 @@
other cases there is no text component at all.
@end deffn
- at anchor{thumb-limits}
- at deffn GenericFunction thumb-limits self => @ref{span}
-(setf (@strong{thumb-limits} @var{self}) @var{span})@*
-
-Returns a span representing the start and end positions to which the
-scrollbar @var{self} may be set. The @sc{setf} function allows this
-span to be modified. Application code is responsible for managing the
-thumb limits in relation to the content model that will be scrolled
-within a @ref{window}. @xref{thumb-position}.
- at end deffn
-
@anchor{thumb-position}
@deffn GenericFunction thumb-position self => integer
(setf (@strong{thumb-position} @var{self}) @var{integer})@*
@@ -691,7 +704,7 @@
scroll thumb for @var{self}. The @sc{setf} function allows
the position to be modified. A @ref{scrolling-event-dispatcher}
instance will manage the thumb position for the @ref{window}
-to which it is assigned. @xref{thumb-limits}.
+to which it is assigned. @xref{outer-limits}.
@end deffn
@anchor{undo-available-p}
Modified: trunk/docs/manual/widget-types.texinfo
==============================================================================
--- trunk/docs/manual/widget-types.texinfo (original)
+++ trunk/docs/manual/widget-types.texinfo Sat Sep 30 12:43:30 2006
@@ -475,10 +475,20 @@
@end-control-subclass
@begin-control-subclass{slider,
-This class represents a @ref{control} having a slider component and optional
-tick marks.,
+This class represents a @ref{control} having a sliding-thumb component
+and optional tick marks.,
event-select}
@control-callback-initarg{slider,event-select}
+ at deffn Initarg :outer-limits
+This initarg accepts a @ref{span} that describes the minimum and maximum
+possible slider positions.
+ at end deffn
+ at deffn Initarg :page-increment
+TODO
+ at end deffn
+ at deffn Initarg :step-increment
+TODO
+ at end deffn
@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.}
@@ -494,9 +504,6 @@
This style keyword configures the slider to be oriented vertically.
@end-primary-style-choices
@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.
@item :no-border
By default, a slider is drawn with a border; this style keyword
disables that feature.
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sat Sep 30 12:43:30 2006
@@ -264,7 +264,9 @@
#:menu-item
#:panel
#:root-window
+ #:scrollbar
#:scrolling-event-dispatcher
+ #:slider
#:timer
#:top-level
#:widget
@@ -438,6 +440,7 @@
#:initial-delay-of
#:horizontal-policy-of
#:image
+ #:inner-limits
#:item-count
#:item-height
#:item-id
@@ -474,6 +477,7 @@
#:obtain-horizontal-scrollbar
#:obtain-primary-display
#:obtain-vertical-scrollbar
+ #:outer-limits
#:owner
#:pack
#:page-increment
@@ -516,7 +520,6 @@
#:text-height
#:text-limit
#:text-modified-p
- #:thumb-limits
#:thumb-position
#:thumb-track-position
#:tooltip-text
Modified: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-grid-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Sat Sep 30 12:43:30 2006
@@ -51,11 +51,11 @@
(gfw:minimum-size panel) panel-size)
(assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size)))
(let ((scrollbar (gfw:obtain-horizontal-scrollbar parent)))
- (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size))
+ (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-width panel-size))
(gfw:thumb-position scrollbar) 0)
(gfs:dispose scrollbar))
(let ((scrollbar (gfw:obtain-vertical-scrollbar parent)))
- (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size))
+ (setf (gfw:outer-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size))
(gfw:thumb-position scrollbar) 0)
(gfs:dispose scrollbar))
#|
Modified: trunk/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/widget-tester.lisp Sat Sep 30 12:43:30 2006
@@ -210,20 +210,41 @@
(gfw:delete-all lb2)
outer-panel))
+(defun populate-scrollbar-test-panel ()
+ (let* ((panel-disp (make-instance 'widget-tester-panel-events))
+ (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp
+ :parent *widget-tester-win*
+ :layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4))))
+ (make-instance 'gfw:label :parent outer-panel :text "some nice slider label")
+ (make-instance 'gfw:slider :parent outer-panel :outer-limits (gfs:make-span :start 0 :end 10))
+ outer-panel))
+
(defun widget-tester-internal ()
(setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
- (let ((disp (make-instance 'widget-tester-events))
- (layout (make-instance 'gfw:heap-layout))
- (menubar (gfw:defmenu ((:item "&File"
- :submenu ((:item "E&xit" :callback #'widget-tester-exit)))))))
- (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher disp
- :layout layout
- :style '(:frame)))
+ (setf *widget-tester-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'widget-tester-events)
+ :layout (make-instance 'gfw:heap-layout)
+ :style '(:frame)))
+ (let* ((layout (gfw:layout-of *widget-tester-win*))
+ (test-panels (list (populate-list-box-test-panel)
+ (populate-scrollbar-test-panel)))
+ (select-lb-callback (lambda (disp item)
+ (declare (ignore disp item))
+ (setf (gfw:top-child-of layout) (first test-panels))
+ (gfw:layout *widget-tester-win*)))
+ (select-sb-callback (lambda (disp item)
+ (declare (ignore disp item))
+ (setf (gfw:top-child-of layout) (second test-panels))
+ (gfw:layout *widget-tester-win*)))
+ (menubar (gfw:defmenu ((:item "&File"
+ :submenu ((:item "E&xit" :callback #'widget-tester-exit)))
+ (:item "&Panels"
+ :submenu ((:item "&List Boxes" :callback select-lb-callback)
+ (:item "&Scrollbars" :callback select-sb-callback)))))))
(setf (gfw:menu-bar *widget-tester-win*) menubar
- (gfw:top-child-of layout) (populate-list-box-test-panel)
- (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))
- (gfw:pack *widget-tester-win*)
- (gfw:show *widget-tester-win* t)))
+ (gfw:top-child-of layout) (first test-panels)
+ (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))))
+ (gfw:pack *widget-tester-win*)
+ (gfw:show *widget-tester-win* t))
(defun widget-tester ()
(gfw:startup "Widget Tester" #'widget-tester-internal))
Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp (original)
+++ trunk/src/uitoolkit/system/system-utils.lisp Sat Sep 30 12:43:30 2006
@@ -143,6 +143,18 @@
(if (typep obj 'gfs:native-object)
(gfs:dispose obj)))
+(declaim (inline lparam-high-word))
+(defun lparam-high-word (lparam)
+ (ash (logand #xFFFF0000 lparam) -16))
+
+(declaim (inline lparam-low-word))
+(defun lparam-low-word (lparam)
+ (logand #x0000FFFF lparam))
+
+(declaim (inline make-lparam))
+(defun make-lparam (hi lo)
+ (logior (ash (logand lo #xFFFF) 16) (logand hi #xFFFF)))
+
;;;
;;; convenience macros
;;;
Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp (original)
+++ trunk/src/uitoolkit/widgets/control.lisp Sat Sep 30 12:43:30 2006
@@ -54,7 +54,7 @@
(gfs:handle parent)
std-style
ex-style
- (or id (increment-widget-id (thread-context))))))
+ id)))
(setf (slot-value ctrl 'gfs:handle) hwnd)
(subclass-wndproc hwnd)
(put-widget (thread-context) ctrl)
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sat Sep 30 12:43:30 2006
@@ -81,12 +81,6 @@
(when (funcall msg-filter gm msg-ptr)
(return-from message-loop gfs::wparam)))))))
-(defmacro hi-word (lparam)
- `(ash (logand #xFFFF0000 ,lparam) -16))
-
-(defmacro lo-word (lparam)
- `(logand #x0000FFFF ,lparam))
-
(defun key-down-p (key-code)
"Return T if the key corresponding to key-code is currently down."
(= (logand (gfs::get-async-key-state key-code) #x8000) #x8000))
@@ -100,8 +94,8 @@
(w (get-widget tc hwnd))
(pnt (mouse-event-pnt tc)))
(when w
- (setf (gfs:point-x pnt) (lo-word lparam))
- (setf (gfs:point-y pnt) (hi-word lparam))
+ (setf (gfs:point-x pnt) (gfs::lparam-low-word lparam))
+ (setf (gfs:point-y pnt) (gfs::lparam-high-word lparam))
(funcall fn (dispatcher w) w pnt btn-symbol)))
0)
@@ -109,7 +103,7 @@
(let ((wndproc-val (gfs::get-class-long hwnd gfs::+gclp-wndproc+)))
(if (zerop wndproc-val)
(error 'gfs:win32-error :detail "get-class-long failed"))
- wndproc-val))
+ (logand wndproc-val #xFFFFFFFF)))
(defun subclass-wndproc (hwnd)
(if (zerop (gfs::set-window-long hwnd
@@ -197,8 +191,8 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam)
(let* ((tc (thread-context))
- (wparam-hi (hi-word wparam))
- (wparam-lo (lo-word wparam))
+ (wparam-hi (gfs::lparam-high-word wparam))
+ (wparam-lo (gfs::lparam-low-word wparam))
(owner (get-widget tc hwnd)))
; (format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam)
(if owner
@@ -227,7 +221,7 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
(declare (ignore hwnd lparam)) ; FIXME: handle system menus
(let* ((tc (thread-context))
- (item (get-item tc (lo-word wparam))))
+ (item (get-item tc (gfs::lparam-low-word wparam))))
(unless (null item)
(let ((d (dispatcher item)))
(unless (null d)
@@ -269,7 +263,7 @@
(declare (ignore lparam))
(let* ((tc (thread-context))
(widget (get-widget tc hwnd))
- (ch (code-char (lo-word wparam))))
+ (ch (code-char (gfs::lparam-low-word wparam))))
(when widget
(event-key-down (dispatcher widget) widget (virtual-key tc) ch)))
0)
@@ -277,7 +271,7 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
(declare (ignore lparam))
(let* ((tc (thread-context))
- (wparam-lo (lo-word wparam))
+ (wparam-lo (gfs::lparam-low-word wparam))
(ch (gfs::map-virtual-key wparam-lo 2))
(w (get-widget tc hwnd)))
(setf (virtual-key tc) wparam-lo)
@@ -288,7 +282,7 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
(declare (ignore lparam))
(let ((tc (thread-context)))
- (let* ((wparam-lo (lo-word wparam))
+ (let* ((wparam-lo (gfs::lparam-low-word wparam))
(ch (gfs::map-virtual-key wparam-lo 2))
(w (get-widget tc hwnd)))
(when w
@@ -352,14 +346,14 @@
(declare (ignore lparam))
(let ((widget (get-widget (thread-context) hwnd)))
(if widget
- (dispatch-scroll-notification widget :horizontal (lo-word wparam))))
+ (dispatch-scroll-notification widget :horizontal (gfs::lparam-low-word wparam))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam)
(declare (ignore lparam))
(let ((widget (get-widget (thread-context) hwnd)))
(if widget
- (dispatch-scroll-notification widget :vertical (lo-word wparam))))
+ (dispatch-scroll-notification widget :vertical (gfs::lparam-low-word wparam))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)
Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrollbar.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sat Sep 30 12:43:30 2006
@@ -133,6 +133,19 @@
(error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation")))
(setf (slot-value self 'dispatcher) nil)) ; standard scrollbars don't use dispatchers
+(defmethod outer-limits ((self standard-scrollbar))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (destructuring-bind (limits pagesize pos trackpos)
+ (sb-get-info self (orientation-of self))
+ (declare (ignore pagesize pos trackpos))
+ limits))
+
+(defmethod (setf outer-limits) (span (self standard-scrollbar))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (sb-set-thumb-limits self (orientation-of self) span))
+
(defmethod owner ((self standard-scrollbar))
(parent self))
@@ -184,19 +197,6 @@
(t
(warn 'gfs:toolkit-warning :detail "parent dispatcher is wrong type")))))
-(defmethod thumb-limits ((self standard-scrollbar))
- (if (gfs:disposed-p self)
- (error 'gfs:disposed-error))
- (destructuring-bind (limits pagesize pos trackpos)
- (sb-get-info self (orientation-of self))
- (declare (ignore pagesize pos trackpos))
- limits))
-
-(defmethod (setf thumb-limits) (span (self standard-scrollbar))
- (if (gfs:disposed-p self)
- (error 'gfs:disposed-error))
- (sb-set-thumb-limits self (orientation-of self) span))
-
(defmethod thumb-position ((self standard-scrollbar))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
Modified: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Sat Sep 30 12:43:30 2006
@@ -43,7 +43,7 @@
(defun compute-scrolling-delta (scrollbar step-size detail)
(let ((page-size (page-increment scrollbar))
- (limits (thumb-limits scrollbar))
+ (limits (outer-limits scrollbar))
(curr-pos (thumb-position scrollbar)))
(let ((new-pos (case detail
(:start (gfs:span-start limits))
Modified: trunk/src/uitoolkit/widgets/slider.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/slider.lisp (original)
+++ trunk/src/uitoolkit/widgets/slider.lisp Sat Sep 30 12:43:30 2006
@@ -90,12 +90,118 @@
;; 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)))
-(defmethod initialize-instance :after ((self slider) &key parent &allow-other-keys)
- (create-control self parent "" gfs::+icc-win95-classes+))
+(defmethod initialize-instance :after ((self slider) &key outer-limits parent &allow-other-keys)
+ (create-control self parent "" gfs::+icc-win95-classes+)
+ (setf (gfg:background-color self)
+ (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))
+ (if outer-limits
+ (setf (outer-limits self) outer-limits)))
+
+(defmethod inner-limits ((self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let ((hwnd (gfs:handle self)))
+ (gfs:make-span :start (gfs::send-message hwnd gfs::+tbm-getselstart+ 0 0)
+ :end (gfs::send-message hwnd gfs::+tbm-getselend+ 0 0))))
+
+(defmethod (setf inner-limits) (limits (self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (unless (test-native-style self gfs::+tbs-enableselrange+)
+ (update-native-style self (logior (get-native-style self) gfs::+tbs-enableselrange+)))
+ (let ((start (gfs:span-start limits))
+ (end (gfs:span-end limits)))
+ (if (or (< start 0) (< end 0))
+ (error 'gfs:toolkit-error :detail "negative slider thumb limit"))
+ (gfs::send-message (gfs:handle self)
+ gfs::+tbm-setsel+
+ 1
+ (if (<= start end)
+ (gfs::make-lparam start end)
+ (gfs::make-lparam end start))))
+ limits)
+
+(defmethod outer-limits ((self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let ((hwnd (gfs:handle self)))
+ (gfs:make-span :start (gfs::send-message hwnd gfs::+tbm-getrangemin+ 0 0)
+ :end (gfs::send-message hwnd gfs::+tbm-getrangemax+ 0 0))))
+
+(defmethod (setf outer-limits) (limits (self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (let ((start (gfs:span-start limits))
+ (end (gfs:span-end limits)))
+ (if (or (< start 0) (< end 0))
+ (error 'gfs:toolkit-error :detail "negative slider thumb limit"))
+ (gfs::send-message (gfs:handle self)
+ gfs::+tbm-setrange+
+ 1
+ (if (<= start end)
+ (gfs::make-lparam start end)
+ (gfs::make-lparam end start))))
+ limits)
+
+(defmethod page-increment ((self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-getpagesize+ 0 0))
+
+(defmethod (setf page-increment) (amount (self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (if (< amount 0)
+ (error 'gfs:toolkit-error :detail "negative slider page increment"))
+ (if (< amount (step-increment self))
+ (warn 'gfs::toolkit-warning :detail "slider page increment less than step increment"))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-setpagesize+ 0 amount)
+ amount)
+
+(defmethod preferred-size ((self slider) width-hint height-hint)
+ (let* ((b-width (* (border-width self) 2))
+ (limits (outer-limits self))
+ (numticks (- (gfs:span-end limits) (gfs:span-start limits)))
+ (size (gfs:make-size)))
+ (if (find :vertical (style-of self))
+ (setf (gfs:size-width size) (* (vertical-scrollbar-width) 2)
+ (gfs:size-height size) (+ (* 8 numticks) b-width))
+ (setf (gfs:size-width size) (+ (* 8 numticks) b-width)
+ (gfs:size-height size) (* (horizontal-scrollbar-height) 2)))
+ (if (>= width-hint 0)
+ (setf (gfs:size-width size) width-hint))
+ (if (>= height-hint 0)
+ (setf (gfs:size-height size) height-hint))
+ size))
+
+(defmethod step-increment ((self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-getlinesize+ 0 0))
+
+(defmethod (setf step-increment) (amount (self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (if (< amount 0)
+ (error 'gfs:toolkit-error :detail "negative slider step increment"))
+ (if (> amount (page-increment self))
+ (warn 'gfs::toolkit-warning :detail "slider step increment greater than page increment"))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-setlinesize+ 0 amount)
+ amount)
+
+(defmethod thumb-position ((self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-getpos+ 0 0))
+
+(defmethod (setf thumb-position) (pos (self slider))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (gfs::send-message (gfs:handle self) gfs::+tbm-setpos+ 1 pos)
+ (gfs::send-message (gfs:handle self) gfs::+tbm-getpos+ 0 0)) ; might have been adjusted
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat Sep 30 12:43:30 2006
@@ -176,8 +176,8 @@
(defmacro define-control-class (classname system-classname callback-event-name &optional docstring mixins)
`(defclass ,classname `,(control , at mixins)
- ((,(intern "CALLBACK-EVENT-NAME")
- :accessor ,(intern "CALLBACK-EVENT-NAME-OF")
+ ((callback-event-name
+ :accessor callback-event-name-of
:initform ,callback-event-name
:allocation :class)
(,(intern "SYSTEM-CLASSNAME")
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat Sep 30 12:43:30 2006
@@ -207,6 +207,12 @@
(defgeneric (setf image) (image self)
(:documentation "Sets self's image object."))
+(defgeneric inner-limits (self)
+ (:documentation "Returns the lowest and highest allowed positions of self's indicator."))
+
+(defgeneric (setf inner-limits) (span self)
+ (:documentation "Sets the lowest and highest allowed positions of self's indicator."))
+
(defgeneric item-count (self)
(:documentation "Returns the number of items contained within self."))
@@ -288,6 +294,12 @@
(defgeneric obtain-vertical-scrollbar (self)
(:documentation "Returns a scrollbar object if self has been configured to have one horizontally."))
+(defgeneric outer-limits (self)
+ (:documentation "Returns the lowest and highest possible positions of self's indicator."))
+
+(defgeneric (setf outer-limits) (span self)
+ (:documentation "Sets the lowest and highest possible positions of self's indicator."))
+
(defgeneric owner (self)
(:documentation "Returns self's owner (which is not necessarily the same as parent)."))
@@ -417,12 +429,6 @@
(defgeneric (setf text-modified-p) (modified self)
(:documentation "Sets self's modified flag."))
-(defgeneric thumb-limits (self)
- (:documentation "Returns the lowest and highest allowed positions of self's thumb component."))
-
-(defgeneric (setf thumb-limits) (span self)
- (:documentation "Sets the lowest and highest allowed positions of self's thumb component."))
-
(defgeneric thumb-position (self)
(:documentation "Returns the position of self's thumb component."))
More information about the Graphic-forms-cvs
mailing list