[graphic-forms-cvs] r273 - trunk/src/uitoolkit/widgets

[junrue at common-lisp.net]

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 , at 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."))