[graphic-forms-cvs] r266 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Sep 24 06:54:59 UTC 2006
Author: junrue
Date: Sun Sep 24 02:54:04 2006
New Revision: 266
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/scroll-tester.lisp
trunk/src/uitoolkit/system/gdi32.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/layout.lisp
trunk/src/uitoolkit/widgets/scrollbar.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-constants.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
more progress towards scroll-tester actually working
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Sun Sep 24 02:54:04 2006
@@ -522,6 +522,17 @@
decorations are modified appropriately.
@end deffn
+ at anchor{scroll}
+ at deffn GenericFunction scroll self delta-x delta-y children-p millis
+Scrolls @var{self} by a number of pixels right or down equal to the
+integer values @var{delta-x} and @var{delta-y}; either delta value
+may be negative in order to scroll left or up. When @var{children-p}
+is non- at sc{nil}, the children of @var{self} are scrolled as well.
+When @var{millis} is greater than zero, the system will animate
+the scrolling operation within the specified number of milliseconds.
+Paint events are delivered for the areas needing to be repainted.
+ at end deffn
+
@deffn GenericFunction select self flag
Sets @var{self} to the selected state if @var{flag} is not @sc{nil}
or to the unselected state if @sc{nil}.
@@ -642,6 +653,20 @@
before this function returns.
@end deffn
+ at defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol
+Call this function to respond to a scrolling event so that the content
+of @var{window} can be scrolled and @var{window}'s scrollbar state(s)
+updated. The @var{axis} argument can be @code{:horizontal} or @code{:vertical}
+to request processing in the corresponding direction; or if unspecified,
+scroll processing will occur in both directions. The @var{detail} argument
+can be one of the values described for @ref{event-scroll}; or if
+unspecified, @code{:thumb-position} will be assumed. This function returns
+the value of the @var{detail} argument.
+
+Note that @ref{scrolling-event-dispatcher} calls this function on
+behalf of a window when set as that window's dispatcher.
+ at end defun
+
@anchor{update-from-items}
@deffn GenericFunction update-from-items self
Synchronizes @var{self}'s internal model (i.e., a native control's
Modified: trunk/docs/manual/widget-types.texinfo
==============================================================================
--- trunk/docs/manual/widget-types.texinfo (original)
+++ trunk/docs/manual/widget-types.texinfo Sun Sep 24 02:54:04 2006
@@ -142,6 +142,39 @@
A subclass of @ref{item} representing a @ref{menu} item.
@end deftp
+ at anchor{scrolling-event-dispatcher}
+ at deftp Class scrolling-event-dispatcher horizontal-policy step-increments vertical-policy
+This is a subclass of @ref{event-dispatcher} that is specialized for
+processing scrolling events on behalf of @ref{window}s.
+ at table @var
+ at item horizontal-policy
+One of the following keyword symbols describing a scrollbar visibility
+policy:
+ at table @code
+ at item :always
+The scrollbar is always visible, set to a disabled state if scrolling
+is unnecessary.
+ at item :when-needed
+The scrollbar is hidden when scrolling is unnecessary.
+ at end table
+The default policy is @code{:always}
+ at item step-increments
+A @ref{size} object describing how many pixels a single step in either
+direction will jump, by default one pixel.
+ at item vertical-policy
+One of the following keyword symbols describing a scrollbar visibility
+policy:
+ at table @code
+ at item :always
+The scrollbar is always visible, set to a disabled state if scrolling
+is unnecessary.
+ at item :when-needed
+The scrollbar is hidden when scrolling is unnecessary.
+ at end table
+The default policy is @code{:always}
+ at end table
+ at end deftp
+
@anchor{standard-scrollbar}
@deftp Class standard-scrollbar orientation step-increment
This class encapsulates a @emph{standard scrollbar}, which
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Sep 24 02:54:04 2006
@@ -264,6 +264,7 @@
#:menu-item
#:panel
#:root-window
+ #:scrolling-event-dispatcher
#:timer
#:top-level
#:widget
@@ -506,7 +507,7 @@
#:size
#:spacing-of
#:startup
- #:step-increment
+ #:step-increments
#:style-of
#:sub-menu
#:text
@@ -527,6 +528,7 @@
#:trim-sizes
#:undo-available-p
#:update
+ #:update-scrolling-state
#:vertical-policy-of
#:visible-item-count
#:visible-p
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 Sun Sep 24 02:54:04 2006
@@ -49,6 +49,14 @@
:parent parent)))
(setf (gfw:maximum-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 (1- (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 (1- (gfs:size-height panel-size)))
+ (gfw:thumb-position scrollbar) 0)
+ (gfs:dispose scrollbar))
#|
(let* ((gc (make-instance 'gfg:graphics-context :widget panel))
(font (make-instance 'gfg:font :gc gc)))
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-tester.lisp Sun Sep 24 02:54:04 2006
@@ -41,12 +41,24 @@
(setf *scroll-tester-win* nil)
(gfw:shutdown 0))
-(defclass scroll-tester-events (gfw:event-dispatcher) ())
+(defclass scroll-tester-events (gfw:scrolling-event-dispatcher) ())
(defmethod gfw:event-close ((disp scroll-tester-events) window)
(declare (ignore window))
(scroll-tester-exit disp nil))
+(defmethod gfw:event-resize ((disp scroll-tester-events) window size type)
+ (declare (ignore size type))
+ (let ((client-size (gfw:client-size window))
+ (scrollbar nil))
+ (setf scrollbar (gfw:obtain-horizontal-scrollbar window))
+ (if scrollbar
+ (setf (gfw:page-increment scrollbar) (gfs:size-width client-size)))
+ (setf scrollbar (gfw:obtain-vertical-scrollbar window))
+ (if scrollbar
+ (setf (gfw:page-increment scrollbar) (gfs:size-height client-size))))
+ (call-next-method))
+
(defun scroll-tester-internal ()
(setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*))
(let ((disp (make-instance 'scroll-tester-events))
@@ -61,6 +73,7 @@
(setf (gfw:menu-bar *scroll-tester-win*) menubar
(gfw:top-child-of layout) panel
(gfw:image *scroll-tester-win*) icons))
+ (setf (gfw:text *scroll-tester-win*) "Scroll Tester")
(gfw:show *scroll-tester-win* t)))
(defun scroll-tester ()
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Sun Sep 24 02:54:04 2006
@@ -272,6 +272,12 @@
(lpm LPTR))
(defcfun
+ ("GetWindowOrgEx" get-window-org)
+ BOOL
+ (hdc HANDLE)
+ (point LPTR))
+
+(defcfun
("MaskBlt" mask-blt)
BOOL
(hdest HANDLE)
@@ -422,5 +428,13 @@
(hdc HANDLE)
(color COLORREF))
+(defcfun
+ ("SetWindowOrgEx" set-window-org)
+ BOOL
+ (hdc HANDLE)
+ (x INT)
+ (y INT)
+ (point LPTR))
+
(defun makerop4 (fore back)
(logior (logand (ash back 8) #xFF000000) fore))
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Sep 24 02:54:04 2006
@@ -1007,6 +1007,17 @@
(defconstant +stn-enable+ 2)
(defconstant +stn-disable+ 3)
+;;;
+;;; commands for ScrollWindowEx()
+;;;
+(defconstant +sw-scrollchildren+ #x0001)
+(defconstant +sw-invalidate+ #x0002)
+(defconstant +sw-erase+ #x0004)
+(defconstant +sw-smoothscroll+ #x0010)
+
+;;;
+;;; commands for ShowWindow()
+;;;
(defconstant +sw-hide+ 0)
(defconstant +sw-shownormal+ 1)
(defconstant +sw-normal+ 1)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 24 02:54:04 2006
@@ -631,6 +631,18 @@
(pnt :pointer))
(defcfun
+ ("ScrollWindowEx" scroll-window)
+ INT
+ (hwnd HANDLE)
+ (dx INT)
+ (dy INT)
+ (scrollrect LPTR)
+ (cliprect LPTR)
+ (updatergn HANDLE)
+ (updaterect LPTR)
+ (flags UINT))
+
+(defcfun
("SendMessageA" send-message)
LRESULT
(hwnd HANDLE)
Modified: trunk/src/uitoolkit/widgets/layout.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout.lisp (original)
+++ trunk/src/uitoolkit/widgets/layout.lisp Sun Sep 24 02:54:04 2006
@@ -33,12 +33,6 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+
- gfs::+swp-noownerzorder+
- gfs::+swp-noactivate+
- gfs::+swp-nocopybits+)))
-
;;;
;;; helper functions
;;;
Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/scrollbar.lisp (original)
+++ trunk/src/uitoolkit/widgets/scrollbar.lisp Sun Sep 24 02:54:04 2006
@@ -142,10 +142,6 @@
(defmethod (setf page-increment) (amount (self standard-scrollbar))
(sb-set-page-increment self (orientation-of self) amount))
-(defmethod (setf step-increment) :after (amount (self standard-scrollbar))
- (if (< amount 0)
- (warn 'gfs:toolkit-warning :detail "negative scrollbar step increment")))
-
(defmethod thumb-limits ((self standard-scrollbar))
(destructuring-bind (limits pagesize pos trackpos)
(sb-get-info self (orientation-of self))
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 Sun Sep 24 02:54:04 2006
@@ -37,14 +37,76 @@
;;; helper functions
;;;
-(defun validate-scrollbar-policies (disp)
- (unless (and (find (horizontal-policy-of disp) '(:always :when-needed))
- (find (vertical-policy-of disp) '(:always :when-needed)))
- (error 'gfs:toolkit-error :detail "invalid scrollbar policy")))
+(defun clamp-scroll-pos (pos total-steps page-size)
+ (setf pos (min pos (- total-steps page-size)))
+ (max pos 0))
+
+(defun update-scrolling-state (disp window &optional axis detail)
+ (unless detail
+ (setf detail :thumb-position))
+ (unless axis
+ (if (horizontal-scrollbar-p window)
+ (update-scrolling-state disp window :horizontal detail))
+ (if (vertical-scrollbar-p window)
+ (update-scrolling-state disp window :vertical detail))
+ (return-from update-scrolling-state detail))
+ (let ((scrollbar nil)
+ (step-incs (step-increments disp))
+ (step-size 0))
+ (ecase axis
+ (:horizontal
+ (setf scrollbar (obtain-horizontal-scrollbar window)
+ step-size (gfs:size-width step-incs)))
+ (:vertical
+ (setf scrollbar (obtain-vertical-scrollbar window)
+ step-size (gfs:size-height step-incs))))
+ (let* ((page-size (page-increment scrollbar))
+ (limits (thumb-limits scrollbar))
+ (curr-pos (thumb-position scrollbar))
+ (new-pos (case detail
+ (:start (gfs:span-start limits))
+ (:end (gfs:span-end limits))
+ (:step-back (- curr-pos step-size))
+ (:step-forward (+ curr-pos step-size))
+ (:page-back (- curr-pos page-size))
+ (:page-forward (+ curr-pos page-size))
+ (:thumb-position curr-pos)
+ (:thumb-track (thumb-track-position scrollbar))
+ (otherwise curr-pos))))
+ (setf new-pos (clamp-scroll-pos new-pos
+ (- (gfs:span-end limits) (gfs:span-start limits))
+ page-size))
+ (ecase axis
+ (:horizontal (scroll window (- new-pos curr-pos) 0 nil 0))
+ (:vertical (scroll window 0 (- new-pos curr-pos) nil 0)))
+ (setf (thumb-position scrollbar) new-pos))
+ (gfs:dispose scrollbar))
+ detail)
+
+(defun validate-step-values (step-increments)
+ (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0))
+ (error 'gfs:toolkit-error :detail "invalid step increment")))
;;;
;;; methods
;;;
+(defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail)
+ (update-scrolling-state disp window axis detail))
+
(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key)
- (validate-scrollbar-policies self))
+ (validate-step-values (step-increments self)))
+
+(defmethod print-object ((self scrolling-event-dispatcher) stream)
+ (print-unreadable-object (self stream :type t)
+ (format stream "horizontal policy: ~a " (horizontal-policy-of self))
+ (format stream "vertical policy: ~a " (vertical-policy-of self))
+ (format stream "step increments: ~a" (step-increments self))))
+
+(defmethod (setf step-increment) :after (amounts (self scrolling-event-dispatcher))
+ (validate-step-values amounts)
+ (setf (slot-value self 'step-increment) (gfs:copy-size amounts)))
+
+(defmethod (setf total-step-count) :after (amounts (self scrolling-event-dispatcher))
+ (validate-step-values amounts)
+ (setf (slot-value self 'step-increment) (gfs:copy-size amounts)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 24 02:54:04 2006
@@ -44,6 +44,10 @@
:accessor horizontal-policy-of
:initarg :horizontal-policy
:initform :always)
+ (step-increments
+ :accessor step-increments
+ :initarg :step-increments
+ :initform (gfs:make-size :width 1 :height 1))
(vertical-policy
:accessor vertical-policy-of
:initarg :vertical-policy
@@ -113,11 +117,7 @@
((orientation
:reader orientation-of
:initarg :orientation
- :initform nil)
- (step-increment
- :accessor step-increment
- :initarg :step-increment
- :initform 1))
+ :initform nil))
(:documentation "This class encapsulates a scrollbar attached to a window."))
(defclass widget (event-source)
Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-constants.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-constants.lisp Sun Sep 24 02:54:04 2006
@@ -98,4 +98,8 @@
(defconstant +default-child-style+ (logior gfs::+ws-child+ gfs::+ws-visible+))
(defconstant +default-widget-width+ 64)
(defconstant +default-widget-height+ 64)
- (defconstant +estimated-text-size+ 32)) ; bytes
+ (defconstant +estimated-text-size+ 32) ; bytes
+ (defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+
+ gfs::+swp-noownerzorder+
+ gfs::+swp-noactivate+
+ gfs::+swp-nocopybits+)))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 24 02:54:04 2006
@@ -327,8 +327,8 @@
(defgeneric retrieve-span (self)
(:documentation "Returns the span object indicating the range of values that are valid for the object."))
-(defgeneric scroll (self dest-pnt src-rect children-too)
- (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
+(defgeneric scroll (self delta-x delta-y children-p millis)
+ (:documentation "Scrolls the contents of self a specified number of pixels."))
(defgeneric select (self flag)
(:documentation "Set self into (or out of) the selected state."))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 24 02:54:04 2006
@@ -336,6 +336,11 @@
(defmethod resizable-p ((self widget))
nil)
+(defmethod scroll :before ((self widget) delta-x delta-y children-p millis)
+ (declare (ignore delta-x delta-y children-p millis))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
(defmethod select :before ((self widget) flag)
(declare (ignore flag))
(if (gfs:disposed-p self)
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sun Sep 24 02:54:04 2006
@@ -138,6 +138,16 @@
(defun release-mouse ()
(gfs::release-capture))
+(defun scroll-children (window delta-x delta-y)
+ (let ((specs (mapchildren window (lambda (parent child)
+ (declare (ignore parent))
+ (let ((pnt (location child))
+ (size (size child)))
+ (incf (gfs:point-x pnt) delta-x)
+ (incf (gfs:point-y pnt) delta-y)
+ (list child (gfs:make-rectangle :location pnt :size size)))))))
+ (arrange-hwnds specs (lambda (child) (declare (ignore child)) +window-pos-flags+))))
+
;;;
;;; methods
;;;
@@ -347,6 +357,22 @@
(if (not (gfs:disposed-p self))
(format stream "size: ~a" (size self)))))
+(defmethod scroll ((self window) delta-x delta-y children-p millis)
+ (let ((flags (logior gfs::+sw-erase+ gfs::+sw-invalidate+)))
+ (if (> millis 0)
+ (let ((tmp (ash (logand millis #xFFFF) 16)))
+ (setf flags (logior flags tmp gfs::+sw-smoothscroll+))))
+ (if children-p
+ (scroll-children self delta-x delta-y))
+ (gfs::scroll-window (gfs:handle self)
+ delta-x
+ delta-y
+ (cffi:null-pointer)
+ (cffi:null-pointer)
+ (cffi:null-pointer)
+ (cffi:null-pointer)
+ flags)))
+
(defmethod show ((self window) flag)
(declare (ignore flag))
(call-next-method)
More information about the Graphic-forms-cvs
mailing list