graphic-forms-cvs

Download

graphic-forms-cvs@common-lisp.net

October 2006

1 participants
102 discussions

[graphic-forms-cvs] r280 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 01 Oct '06

01 Oct '06

Author: junrue Date: Sun Oct 1 00:58:28 2006 New Revision: 280 Modified: trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp Log: scrollbar controls now getting created Modified: trunk/src/tests/uitoolkit/widget-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/widget-tester.lisp (original) +++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Oct 1 00:58:28 2006 @@ -213,30 +213,58 @@ (defun thumb->string (thing) (format nil "~d" (gfw:thumb-position thing))) -(defun populate-scrollbar-test-panel () +(defun populate-slider-test-panel () (let* ((panel-disp (make-instance 'widget-tester-panel-events)) - (layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)) + (layout1 (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4)) + (layout2 (make-instance 'gfw:flow-layout :style '(:horizontal) :margins 4 :spacing 4)) + (layout3 (make-instance 'gfw:flow-layout :style '(:horizontal) :margins 4 :spacing 4)) (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp :parent *widget-tester-win* - :layout layout)) - (label-1 (make-instance 'gfw:label :parent outer-panel - :text "00")) + :layout layout1)) + (panel-1 (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout layout2)) + (label-1 (make-instance 'gfw:label :parent panel-1 + :text "0 ")) (sl-1-cb (lambda (disp slider axis detail) (declare (ignore disp axis detail)) (setf (gfw:text label-1) (thumb->string slider)))) - (sl-1 (make-instance 'gfw:slider :parent outer-panel + (sl-1 (make-instance 'gfw:slider :parent panel-1 :callback sl-1-cb :outer-limits (gfs:make-span :start 0 :end 10))) - (label-2 (make-instance 'gfw:label :parent outer-panel - :text "00")) + (label-3 (make-instance 'gfw:label :parent panel-1 + :text "0 ")) + (sb-1-cb (lambda (disp scrollbar axis detail) + (declare (ignore disp axis detail)) + (setf (gfw:text label-3) (thumb->string scrollbar)))) + (sb-1 (make-instance 'gfw:scrollbar :parent panel-1 + :callback sb-1-cb + :outer-limits (gfs:make-span :start 0 :end 10))) + (panel-2 (make-instance 'gfw:panel :dispatcher panel-disp + :parent outer-panel + :layout layout3)) + (label-2 (make-instance 'gfw:label :parent panel-2 + :text "0 ")) (sl-2-cb (lambda (disp slider axis detail) (declare (ignore disp axis detail)) (setf (gfw:text label-2) (thumb->string slider)))) - (sl-2 (make-instance 'gfw:slider :parent outer-panel + (sl-2 (make-instance 'gfw:slider :parent panel-2 :callback sl-2-cb :style '(:vertical :auto-ticks :ticks-after :ticks-before) - :outer-limits (gfs:make-span :start 0 :end 10)))) - (declare (ignore sl-1 sl-2)) + :outer-limits (gfs:make-span :start 0 :end 10))) + (label-4 (make-instance 'gfw:label :parent panel-2 + :text "0 ")) + (sb-2-cb (lambda (disp scrollbar axis detail) + (declare (ignore disp axis detail)) + (setf (gfw:text label-4) (thumb->string scrollbar)))) + (sb-2 (make-instance 'gfw:scrollbar :parent panel-2 + :callback sb-2-cb + :style '(:vertical) + :outer-limits (gfs:make-span :start 0 :end 10)))) + (declare (ignore sl-1 sl-2 sb-1 sb-2)) + (gfw:pack panel-1) + (gfw:pack panel-2) + (gfw:pack outer-panel) outer-panel)) (defun widget-tester-internal () @@ -246,7 +274,7 @@ :style '(:frame))) (let* ((layout (gfw:layout-of *widget-tester-win*)) (test-panels (list (populate-list-box-test-panel) - (populate-scrollbar-test-panel))) + (populate-slider-test-panel))) (select-lb-callback (lambda (disp item) (declare (ignore disp item)) (setf (gfw:top-child-of layout) (first test-panels)) Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sun Oct 1 00:58:28 2006 @@ -41,7 +41,7 @@ (logand orig-flags (lognot gfs::+sbs-vert+))) (defun sb-vertical-flags (orig-flags) - (logior orig-flags (lognot gfs::+sbs-vert+))) + (logior orig-flags gfs::+sbs-vert+)) (defun validate-scrollbar-type (type) (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+)) @@ -238,8 +238,12 @@ (:vertical (setf std-flags (sb-vertical-flags std-flags))))) (values std-flags 0))) -(defmethod initialize-instance :after ((self scrollbar) &key parent &allow-other-keys) - (create-control self parent "" gfs::+icc-standard-classes+)) +(defmethod initialize-instance :after ((self scrollbar) &key outer-limits page-increment parent &allow-other-keys) + (create-control self parent "" gfs::+icc-standard-classes+) + (if outer-limits + (setf (outer-limits self) outer-limits)) + (if page-increment + (setf (page-increment self) page-increment))) (defmethod outer-limits ((self scrollbar)) (if (gfs:disposed-p self) @@ -270,6 +274,19 @@ (error 'gfs:disposed-error)) (sb-set-page-increment self gfs::+sb-ctl+ amount)) +(defmethod preferred-size ((self scrollbar) width-hint height-hint) + (let ((size (gfs:make-size))) + (if (find :vertical (style-of self)) + (setf (gfs:size-width size) (vertical-scrollbar-width) + (gfs:size-height size) +default-widget-height+) + (setf (gfs:size-width size) +default-widget-width+ + (gfs:size-height size) (horizontal-scrollbar-height))) + (if (>= width-hint 0) + (setf (gfs:size-width size) width-hint)) + (if (>= height-hint 0) + (setf (gfs:size-height size) height-hint)) + size)) + (defmethod thumb-position ((self scrollbar)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))

1 0

[graphic-forms-cvs] r279 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 01 Oct '06

01 Oct '06

Author: junrue Date: Sat Sep 30 23:52:59 2006 New Revision: 279 Modified: trunk/docs/manual/widget-types.texinfo trunk/src/tests/uitoolkit/widget-tester.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/slider.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-constants.lisp Log: implemented scroll notification dispatch for sliders; fixed some slider geometry problems; added WS_TABSTOP to the default child control style bitmask Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Sat Sep 30 23:52:59 2006 @@ -474,11 +474,26 @@ @end deffn @end-control-subclass +@begin-control-subclass{scrollbar, +This class represents a @ref{control} having a proportional sliding-thumb +component and step arrows at either end., +event-scroll} +@control-callback-initarg{slider,event-scroll} +@deffn Initarg :style +@begin-primary-style-choices{} +@item :horizontal +This style keyword configures the scrollbar to be oriented horizontally. +@item :vertical +This style keyword configures the scrollbar to be oriented vertically. +@end-primary-style-choices +@end deffn +@end-control-subclass + @begin-control-subclass{slider, This class represents a @ref{control} having a sliding-thumb component and optional tick marks., -event-select} -@control-callback-initarg{slider,event-select} +event-scroll} +@control-callback-initarg{slider,event-scroll} @deffn Initarg :outer-limits This initarg accepts a @ref{span} that describes the minimum and maximum possible slider positions. @@ -504,9 +519,9 @@ This style keyword configures the slider to be oriented vertically. @end-primary-style-choices @begin-optional-style-choices -@item :no-border -By default, a slider is drawn with a border; this style keyword -disables that feature. +@item :border +By default, a slider is drawn without a border; this style keyword +enables a border around the control. @item :ticks-after Specifies that the slider should display its tick marks to the right of (or below) the control. This style can @@ -515,10 +530,10 @@ 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} +@c @item :tooltip +@c Specifies that the slider should display a +@c tooltip showing its current position. The side on which the +@c tooltip appears can be configured with XXXXXX @end-optional-style-choices @end deffn @end-control-subclass 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 23:52:59 2006 @@ -210,13 +210,33 @@ (gfw:delete-all lb2) outer-panel)) +(defun thumb->string (thing) + (format nil "~d" (gfw:thumb-position thing))) + (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)) + (layout (make-instance 'gfw:flow-layout :style '(:vertical) :spacing 4 :margins 4)) + (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *widget-tester-win* + :layout layout)) + (label-1 (make-instance 'gfw:label :parent outer-panel + :text "00")) + (sl-1-cb (lambda (disp slider axis detail) + (declare (ignore disp axis detail)) + (setf (gfw:text label-1) (thumb->string slider)))) + (sl-1 (make-instance 'gfw:slider :parent outer-panel + :callback sl-1-cb + :outer-limits (gfs:make-span :start 0 :end 10))) + (label-2 (make-instance 'gfw:label :parent outer-panel + :text "00")) + (sl-2-cb (lambda (disp slider axis detail) + (declare (ignore disp axis detail)) + (setf (gfw:text label-2) (thumb->string slider)))) + (sl-2 (make-instance 'gfw:slider :parent outer-panel + :callback sl-2-cb + :style '(:vertical :auto-ticks :ticks-after :ticks-before) + :outer-limits (gfs:make-span :start 0 :end 10)))) + (declare (ignore sl-1 sl-2)) outer-panel)) (defun widget-tester-internal () @@ -239,7 +259,7 @@ :submenu ((:item "E&xit" :callback #'widget-tester-exit))) (:item "&Panels" :submenu ((:item "&List Boxes" :callback select-lb-callback) - (:item "&Scrollbars" :callback select-sb-callback))))))) + (:item "&Sliders" :callback select-sb-callback))))))) (setf (gfw:menu-bar *widget-tester-win*) menubar (gfw:top-child-of layout) (first test-panels) (gfw:image *widget-tester-win*) (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico")))) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sat Sep 30 23:52:59 2006 @@ -50,7 +50,7 @@ (defmethod compute-style-flags ((self button) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) + (let ((std-flags +default-child-style+) (style (style-of self))) (loop for sym in style do (cond Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Sat Sep 30 23:52:59 2006 @@ -48,7 +48,7 @@ (defmethod compute-style-flags ((self edit) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+)) + (let ((std-flags +default-child-style+) (style (style-of self))) (loop for sym in style do (ecase sym Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sat Sep 30 23:52:59 2006 @@ -36,7 +36,8 @@ (defparameter *callback-info* '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) (gfw:event-modify . (gfw:event-source)) - (gfw:event-select . (gfw:event-source)))) + (gfw:event-select . (gfw:event-source)) + (gfw:event-scroll . (gfw:event-source symbol symbol)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Sep 30 23:52:59 2006 @@ -142,16 +142,24 @@ (detail (case wparam-lo (#.gfs::+sb-top+ :start) ; (#.gfs::+sb-left+ :start) +; (#.gfs::+tb-top+ :start) (#.gfs::+sb-bottom+ :end) ; (#.gfs::+sb-right+ :end) +; (#.gfs::+tb-bottom+ :end) (#.gfs::+sb-lineup+ :step-back) ; (#.gfs::+sb-lineleft+ :step-back) +; (#.gfs::+tb-linedown+ :step-back) (#.gfs::+sb-linedown+ :step-forward) ; (#.gfs::+sb-lineright+ :step-forward) +; (#.gfs::tsb-linedown+ :step-forward) (#.gfs::+sb-pageup+ :page-back) ; (#.gfs::+sb-pageleft+ :page-back) +; (#.gfs::+tb-pageup+ :page-back) (#.gfs::+sb-pagedown+ :page-forward) ; (#.gfs::+sb-pageright+ :page-forward) +; (#.gfs::+tb-pagedown+ :page-forward) +; (#.gfs::+tb-thumbposition+ :thumb-position) +; (#.gfs::+tb-thumbtrack+ :thumb-track) (#.gfs::+sb-thumbposition+ :thumb-position) (#.gfs::+sb-thumbtrack+ :thumb-track)))) (event-scroll disp widget axis detail))) @@ -343,15 +351,19 @@ 0))) (defmethod process-message (hwnd (msg (eql gfs::+wm-hscroll+)) wparam lparam) - (declare (ignore lparam)) - (let ((widget (get-widget (thread-context) hwnd))) + (let ((widget (get-widget (thread-context) + (if (zerop lparam) + hwnd + (cffi:make-pointer (logand #xFFFFFFFF lparam)))))) (if widget (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))) + (let ((widget (get-widget (thread-context) + (if (zerop lparam) + hwnd + (cffi:make-pointer (logand #xFFFFFFFF lparam)))))) (if widget (dispatch-scroll-notification widget :vertical (gfs::lparam-low-word wparam)))) 0) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Sat Sep 30 23:52:59 2006 @@ -182,7 +182,7 @@ (defmethod compute-style-flags ((self list-box) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+ gfs::+lbs-notify+ + (let ((std-flags (logior +default-child-style+ gfs::+lbs-notify+ gfs::+ws-vscroll+ gfs::+ws-border+)) (style (style-of self))) (loop for sym in style Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sat Sep 30 23:52:59 2006 @@ -37,6 +37,12 @@ ;;; helper functions ;;; +(defun sb-horizontal-flags (orig-flags) + (logand orig-flags (lognot gfs::+sbs-vert+))) + +(defun sb-vertical-flags (orig-flags) + (logior orig-flags (lognot gfs::+sbs-vert+))) + (defun validate-scrollbar-type (type) (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+)) (error 'gfs:toolkit-error :detail "invalid scrollbar type ID"))) @@ -219,5 +225,68 @@ trackpos)) ;;; -;;; TBD: scrollbar control implementation +;;; scrollbar control implementation ;;; + +(defmethod compute-style-flags ((self scrollbar) &rest extra-data) + (declare (ignore extra-data)) + (let ((std-flags +default-child-style+) + (style (style-of self))) + (loop for sym in style + do (ecase sym + (:horizontal (setf std-flags (sb-horizontal-flags std-flags))) + (:vertical (setf std-flags (sb-vertical-flags std-flags))))) + (values std-flags 0))) + +(defmethod initialize-instance :after ((self scrollbar) &key parent &allow-other-keys) + (create-control self parent "" gfs::+icc-standard-classes+)) + +(defmethod outer-limits ((self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self gfs::+sb-ctl+) + (declare (ignore pagesize pos trackpos)) + limits)) + +(defmethod (setf outer-limits) (span (self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (sb-set-thumb-limits self gfs::+sb-ctl+ span)) + +(defmethod owner ((self scrollbar)) + (parent self)) + +(defmethod page-increment ((self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self gfs::+sb-ctl+) + (declare (ignore limits pos trackpos)) + pagesize)) + +(defmethod (setf page-increment) (amount (self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (sb-set-page-increment self gfs::+sb-ctl+ amount)) + +(defmethod thumb-position ((self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self gfs::+sb-ctl+) + (declare (ignore limits pagesize trackpos)) + pos)) + +(defmethod (setf thumb-position) (position (self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (sb-set-thumb-position self gfs::+sb-ctl+ position)) + +(defmethod thumb-track-position ((self scrollbar)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self gfs::+sb-ctl+) + (declare (ignore limits pagesize pos)) + trackpos)) Modified: trunk/src/uitoolkit/widgets/slider.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/slider.lisp (original) +++ trunk/src/uitoolkit/widgets/slider.lisp Sat Sep 30 23:52:59 2006 @@ -44,12 +44,7 @@ (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) @@ -68,8 +63,8 @@ (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+))) +(defun sl-border-flags (orig-flags) + (logior orig-flags gfs::+ws-border+)) ;;; ;;; methods @@ -77,7 +72,7 @@ (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+)) + (let ((std-flags +default-child-style+) (style (style-of self))) (loop for sym in style do (ecase sym @@ -90,10 +85,12 @@ ;; styles that can be combined ;; - (:no-border (setf std-flags (sl-no-border-flags std-flags))) - (:ticks-after (setf std-flags (sl-ticks-after-flags std-flags))) + (:border (setf std-flags (sl-border-flags std-flags))) + (:ticks-after) ; will be handled below (:ticks-before (setf std-flags (sl-ticks-before-flags std-flags))) (:tooltip (setf std-flags (sl-tooltip-flags std-flags))))) + (if (and (find :ticks-before style) (find :ticks-after style)) + (setf std-flags (sl-ticks-both-flags std-flags))) (values std-flags 0))) (defmethod initialize-instance :after ((self slider) &key outer-limits parent &allow-other-keys) @@ -170,10 +167,10 @@ (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))) + (setf (gfs:size-width size) (floor (* (vertical-scrollbar-width) 5) 2) + (gfs:size-height size) (+ (* 10 numticks) b-width)) + (setf (gfs:size-width size) (+ (* 10 numticks) b-width) + (gfs:size-height size) (floor (* (horizontal-scrollbar-height) 5) 2))) (if (>= width-hint 0) (setf (gfs:size-width size) width-hint)) (if (>= height-hint 0) 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 23:52:59 2006 @@ -171,7 +171,11 @@ :initform nil) (min-size :initarg :minimum-size - :initform nil)) + :initform nil) + (system-classname + :accessor system-classname-of + :initform nil + :allocation :class)) ; subclasses will shadow this slot (:documentation "The base class for widgets having pre-defined native behavior.")) (defmacro define-control-class (classname system-classname callback-event-name &optional docstring mixins) @@ -180,8 +184,8 @@ :accessor callback-event-name-of :initform ,callback-event-name :allocation :class) - (,(intern "SYSTEM-CLASSNAME") - :reader ,(intern "SYSTEM-CLASSNAME-OF") + (system-classname + :reader system-classname-of :initform ,system-classname :allocation :class)) ,(if (typep docstring 'string) `(:documentation ,docstring) `(:documentation "")))) @@ -214,13 +218,13 @@ (define-control-class scrollbar "scrollbar" - 'event-select + 'event-scroll "This class represents an individual scrollbar control.") (define-control-class slider "msctls_trackbar32" - 'event-select + 'event-scroll "This class represents a slider (or trackbar) control.") (defclass color-dialog (widget) () Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-constants.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-constants.lisp Sat Sep 30 23:52:59 2006 @@ -95,7 +95,9 @@ (defconstant +vk-right-alt+ #xA5) (eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+)) + (defconstant +default-child-style+ (logior gfs::+ws-child+ + gfs::+ws-tabstop+ + gfs::+ws-visible+)) (defconstant +default-widget-width+ 64) (defconstant +default-widget-height+ 64) (defconstant +estimated-text-size+ 32) ; bytes

1 0