[graphic-forms-cvs] r279 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Oct 1 03:53:00 UTC 2006
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
+ at begin-control-subclass{scrollbar,
+This class represents a @ref{control} having a proportional sliding-thumb
+component and step arrows at either end.,
+event-scroll}
+ at control-callback-initarg{slider,event-scroll}
+ at deffn Initarg :style
+ at begin-primary-style-choices{}
+ at item :horizontal
+This style keyword configures the scrollbar to be oriented horizontally.
+ at item :vertical
+This style keyword configures the scrollbar to be oriented vertically.
+ at end-primary-style-choices
+ at end deffn
+ at end-control-subclass
+
@begin-control-subclass{slider,
This class represents a @ref{control} having a sliding-thumb component
and optional tick marks.,
-event-select}
- at control-callback-initarg{slider,event-select}
+event-scroll}
+ at 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
- at item :no-border
-By default, a slider is drawn with a border; this style keyword
-disables that feature.
+ at 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}.
- at 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}
+ at c @item :tooltip
+ at c Specifies that the slider should display a
+ at c tooltip showing its current position. The side on which the
+ at 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
More information about the Graphic-forms-cvs
mailing list