Author: junrue Date: Wed Sep 27 21:09:57 2006 New Revision: 273
Modified: trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: added missing defgenerics; implemented define-control-class macro; made dispatch-scroll-notification slightly nicer
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Wed Sep 27 21:09:57 2006 @@ -144,22 +144,23 @@ ret-val))
(defun dispatch-scroll-notification (widget axis wparam-lo) - (let ((disp (dispatcher widget))) - (case wparam-lo - (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) -; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) - (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) -; (#.gfs::+sb-right+ (event-scroll disp widget axis :end)) - (#.gfs::+sb-lineup+ (event-scroll disp widget axis :step-back)) -; (#.gfs::+sb-lineleft+ (event-scroll disp widget axis :step-back)) - (#.gfs::+sb-linedown+ (event-scroll disp widget axis :step-forward)) -; (#.gfs::+sb-lineright+ (event-scroll disp widget axis :step-forward)) - (#.gfs::+sb-pageup+ (event-scroll disp widget axis :page-back)) -; (#.gfs::+sb-pageleft+ (event-scroll disp widget axis :page-back)) - (#.gfs::+sb-pagedown+ (event-scroll disp widget axis :page-forward)) -; (#.gfs::+sb-pageright+ (event-scroll disp widget axis :page-forward)) - (#.gfs::+sb-thumbposition+ (event-scroll disp widget axis :thumb-position)) - (#.gfs::+sb-thumbtrack+ (event-scroll disp widget axis :thumb-track))))) + (let ((disp (dispatcher widget)) + (detail (case wparam-lo + (#.gfs::+sb-top+ :start) +; (#.gfs::+sb-left+ :start) + (#.gfs::+sb-bottom+ :end) +; (#.gfs::+sb-right+ :end) + (#.gfs::+sb-lineup+ :step-back) +; (#.gfs::+sb-lineleft+ :step-back) + (#.gfs::+sb-linedown+ :step-forward) +; (#.gfs::+sb-lineright+ :step-forward) + (#.gfs::+sb-pageup+ :page-back) +; (#.gfs::+sb-pageleft+ :page-back) + (#.gfs::+sb-pagedown+ :page-forward) +; (#.gfs::+sb-pageright+ :page-forward) + (#.gfs::+sb-thumbposition+ :thumb-position) + (#.gfs::+sb-thumbtrack+ :thumb-track)))) + (event-scroll disp widget axis detail)))
(defun obtain-event-time () (gfs::get-message-time))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Wed Sep 27 21:09:57 2006 @@ -132,6 +132,24 @@ (defclass caret (widget) () (:documentation "The caret class provides an i-beam typically representing an insertion point."))
+(defclass item-manager () + ((sort-predicate + :accessor sort-predicate-of + :initarg :sort-predicate + :initform nil) + (items + ;; FIXME: allow subclasses to set initial size? + :initform (make-array 7 :fill-pointer 0 :adjustable t)) + (text-provider + :accessor text-provider-of + :initarg :text-provider + :initform nil) + (image-provider + :accessor image-provider-of + :initarg :image-provider + :initform nil)) + (:documentation "A mix-in for objects composed of sub-elements.")) + (defclass control (widget) ((brush-color :accessor brush-color-of @@ -156,23 +174,49 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior."))
-(defclass button (control) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-select - :allocation :class)) ; shadowing same slot from event-source - (:documentation "This class represents selectable controls that issue notifications when clicked.")) - -(defclass edit (control) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-modify - :allocation :class)) ; shadowing same slot from event-source - (:documentation "This class represents a control in which the user may enter and edit text.")) +(defmacro define-callback-slot (callback-event-name) + `(,(intern "CALLBACK-EVENT-NAME") + :accessor ,(intern "CALLBACK-EVENT-NAME-OF") + :initform ,callback-event-name + :allocation :class)) + +(defmacro define-control-class (classname callback-event-name &optional docstring mixins) + `(defclass ,classname `,(control ,@mixins) + ((,(intern "CALLBACK-EVENT-NAME") + :accessor ,(intern "CALLBACK-EVENT-NAME-OF") + :initform ,callback-event-name + :allocation :class)) + ,(if (typep docstring 'string) `(:documentation ,docstring) `(:documentation "")))) + +(define-control-class + button + 'event-select + "This class represents selectable controls that issue notifications when clicked.") + +(define-control-class + edit + 'event-modify + "This class represents a control in which the user may enter and edit text.")
(defclass label (control) () (:documentation "This class represents non-selectable controls that display a string or image."))
+(define-control-class + list-box + 'event-select + "The list-box class represents the standard listbox control." + (item-manager)) + +(define-control-class + scrollbar + 'event-select + "This class represents an individual scrollbar control.") + +(define-control-class + slider + 'event-select + "This class represents a slider (or trackbar) control.") + (defclass color-dialog (widget) () (:documentation "This class represents the standard color chooser dialog."))
@@ -185,31 +229,6 @@ (defclass font-dialog (widget) () (:documentation "This class represents the standard font dialog."))
-(defclass item-manager () - ((sort-predicate - :accessor sort-predicate-of - :initarg :sort-predicate - :initform nil) - (items - ;; FIXME: allow subclasses to set initial size? - :initform (make-array 7 :fill-pointer 0 :adjustable t)) - (text-provider - :accessor text-provider-of - :initarg :text-provider - :initform nil) - (image-provider - :accessor image-provider-of - :initarg :image-provider - :initform nil)) - (:documentation "A mix-in for objects composed of sub-elements.")) - -(defclass list-box (control item-manager) - ((callback-event-name - :accessor callback-event-name-of - :initform 'event-select - :allocation :class)) ; shadowing same slot from event-source - (:documentation "The list-box class represents the standard listbox control.")) - (defclass menu (widget item-manager) ((callback-event-name :accessor callback-event-name-of
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 27 21:09:57 2006 @@ -282,6 +282,12 @@ (defgeneric moveable-p (self) (:documentation "Returns T if the object is moveable; nil otherwise."))
+(defgeneric obtain-horizontal-scrollbar (self) + (:documentation "Returns a scrollbar object if self has been configured to have one horizontally.")) + +(defgeneric obtain-vertical-scrollbar (self) + (:documentation "Returns a scrollbar object if self has been configured to have one horizontally.")) + (defgeneric owner (self) (:documentation "Returns self's owner (which is not necessarily the same as parent)."))
@@ -291,6 +297,9 @@ (defgeneric page-increment (self) (:documentation "Return an integer representing the configured page size for the object."))
+(defgeneric (setf page-increment) (amount self) + (:documentation "Configures self's page size for scrolling.")) + (defgeneric parent (self) (:documentation "Returns the object's parent."))
@@ -379,7 +388,10 @@ (:documentation "Sets the size of self in its parent's coordinate system."))
(defgeneric step-increment (self) - (:documentation "Return an integer representing the configured step size for the object.")) + (:documentation "Return an integer representing the configured step size for self.")) + +(defgeneric (setf step-increment) (amount self) + (:documentation "Configures self's step size for scrolling."))
(defgeneric text (self) (:documentation "Returns self's text."))