[graphic-forms-cvs] r267 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Sep 25 16:12:29 UTC 2006
Author: junrue
Date: Mon Sep 25 12:12:28 2006
New Revision: 267
Modified:
trunk/docs/manual/widget-functions.texinfo
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/scroll-tester.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
some more pieces of the scrolling puzzle
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Mon Sep 25 12:12:28 2006
@@ -653,10 +653,13 @@
before this function returns.
@end deffn
- at defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol
+ at defun update-scrolling-state @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}
+updated. The dispatcher assigned to @var{window} must be an instance of
+(or an instance of a subclass of) @ref{scrolling-event-dispatcher}.
+
+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
@@ -664,7 +667,8 @@
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.
+behalf of a window when set as that window's dispatcher. Application
+code may also call this function as needed.
@end defun
@anchor{update-from-items}
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 Mon Sep 25 12:12:28 2006
@@ -43,18 +43,18 @@
(defclass scroll-grid-panel-events (gfw:event-dispatcher) ())
(defun make-scroll-grid-panel (parent)
- (let ((panel-size (gfs:make-size :width (* (gfs:size-width *grid-model-size*) +grid-cell-extent+)
- :height (* (gfs:size-height *grid-model-size*) +grid-cell-extent+)))
+ (let ((panel-size (gfs:make-size :width (1+ (* (gfs:size-width *grid-model-size*) +grid-cell-extent+))
+ :height (1+ (* (gfs:size-height *grid-model-size*) +grid-cell-extent+))))
(panel (make-instance 'gfw:panel :dispatcher (make-instance 'scroll-grid-panel-events)
: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)))
+ (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (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)))
+ (setf (gfw:thumb-limits scrollbar) (gfs:make-span :end (gfs:size-height panel-size))
(gfw:thumb-position scrollbar) 0)
(gfs:dispose scrollbar))
#|
@@ -79,14 +79,13 @@
(gfg:foreground-color gc) color))
(gfg:draw-filled-rectangle gc rect)
(setf (gfg:foreground-color gc) gfg:*color-black*
- (gfg:pen-style gc) '(:solid :flat-endcap)
- (gfg:pen-width gc) 2)
+ (gfg:pen-style gc) '(:solid :flat-endcap))
(let* ((pnt (gfs:location rect))
(size (gfs:size rect))
(first-row (floor (gfs:point-y pnt) +grid-cell-extent+))
- (last-row (floor (gfs:size-height size) +grid-cell-extent+))
+ (last-row (floor (+ (gfs:point-y pnt) (gfs:size-height size)) +grid-cell-extent+))
(first-col (floor (gfs:point-x pnt) +grid-cell-extent+))
- (last-col (floor (gfs:size-width size) +grid-cell-extent+))
+ (last-col (floor (+ (gfs:point-x pnt) (gfs:size-width size)) +grid-cell-extent+))
(lr-pnt (gfs:make-point :x (* +grid-cell-extent+ (gfs:size-width *grid-model-size*))
:y (* +grid-cell-extent+ (gfs:size-height *grid-model-size*)))))
(loop for row from first-row upto last-row
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-tester.lisp Mon Sep 25 12:12:28 2006
@@ -47,18 +47,6 @@
(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))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Mon Sep 25 12:12:28 2006
@@ -365,22 +365,27 @@
(declare (ignore wparam lparam))
(let ((widget (get-widget (thread-context) hwnd)))
(if widget
- (let ((rct (gfs:make-rectangle)))
- (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct)
- (cffi:with-foreign-slots ((gfs::rcpaint-x
- gfs::rcpaint-y
- gfs::rcpaint-width
- gfs::rcpaint-height)
- ps-ptr gfs::paintstruct)
- (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr))))
- (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x
- :y gfs::rcpaint-y))
- (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width
- :height gfs::rcpaint-height))
+ (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct)
+ (cffi:with-foreign-slots ((gfs::rcpaint-x gfs::rcpaint-y
+ gfs::rcpaint-width gfs::rcpaint-height)
+ ps-ptr gfs::paintstruct)
+ (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))
+ (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y))
+ (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height))
+ (disp (dispatcher widget)))
(unwind-protect
- (event-paint (dispatcher widget) widget gc rct)
+ (let ((parent (gfw:parent widget)))
+ (when (and parent (typep (dispatcher parent) 'scrolling-event-dispatcher))
+ (let ((origin (slot-value (dispatcher parent) 'viewport-origin)))
+ (gfs::set-window-org (gfs:handle gc)
+ (- (gfs:point-x origin))
+ (- (gfs:point-y origin))
+ (cffi:null-pointer))
+ (decf (gfs:point-x pnt) (gfs:point-x origin))
+ (decf (gfs:point-y pnt) (gfs:point-y origin))))
+ (event-paint disp widget gc (gfs:make-rectangle :location pnt :size size)))
(gfs:dispose gc)
- (gfs::end-paint hwnd ps-ptr))))))
+ (gfs::end-paint hwnd ps-ptr)))))
(error 'gfs:toolkit-error :detail "no object for hwnd")))
0)
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 Mon Sep 25 12:12:28 2006
@@ -38,61 +38,97 @@
;;;
(defun clamp-scroll-pos (pos total-steps page-size)
- (setf pos (min pos (- total-steps page-size)))
+ (setf pos (min pos (1+ (- 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))))
+(defun compute-scrolling-delta (scrollbar step-size detail)
+ (let ((page-size (page-increment scrollbar))
+ (limits (thumb-limits scrollbar))
+ (curr-pos (thumb-position scrollbar)))
+ (let ((new-pos (case detail
+ (:start (gfs:span-start limits))
+ (:end (gfs:span-end limits))
+ (:step-back (1- curr-pos))
+ (:step-forward (1+ curr-pos))
+ (: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))
+ (setf (thumb-position scrollbar) new-pos)
+ (* (- curr-pos new-pos) step-size))))
+
+(defun update-scrolling-state (window &optional axis detail)
+ (unless axis
+ (return-from update-scrolling-state nil))
+ (unless detail
+ (setf detail :thumb-position))
+ (let ((layout (layout-of window))
+ (disp (dispatcher window)))
+ (unless (typep layout 'heap-layout)
+ (return-from update-scrolling-state nil))
+ (let ((child (top-child-of (layout-of window)))
+ (step-incs (step-increments disp))
+ (delta-x 0)
+ (delta-y 0))
+ (cond
+ ((eql axis :horizontal)
+ (let ((scrollbar (obtain-horizontal-scrollbar window)))
+ (setf delta-x (compute-scrolling-delta scrollbar (gfs:size-width step-incs) detail))
+ (gfs:dispose scrollbar)))
+ ((eql axis :vertical)
+ (let ((scrollbar (obtain-vertical-scrollbar window)))
+ (setf delta-y (compute-scrolling-delta scrollbar (gfs:size-height step-incs) detail))
+ (gfs:dispose scrollbar))))
+ (let ((origin (slot-value disp 'viewport-origin)))
+ (incf (gfs:point-x origin) delta-x)
+ (incf (gfs:point-y origin) delta-y)
+ (scroll child delta-x delta-y nil 0))))
detail)
-(defun validate-step-values (step-increments)
- (if (or (<= (gfs:size-width step-increments) 0) (<= (gfs:size-height step-increments) 0))
+(defun validate-step-values (amounts)
+ (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0))
(error 'gfs:toolkit-error :detail "invalid step increment")))
+(defun update-scrollbar-page-sizes (window)
+ (let ((disp (dispatcher window))
+ (viewport-size (client-size window))
+ (top nil)
+ (scrollbar nil)
+ (layout (layout-of window)))
+ (unless (and layout (typep layout 'heap-layout))
+ (return-from update-scrollbar-page-sizes nil))
+ (setf top (top-child-of layout))
+ (unless top
+ (setf top (car (first (compute-layout layout window -1 -1)))))
+ (let ((step-incs (step-increments disp))
+ (top-size (if top (size top) viewport-size)))
+ (setf scrollbar (obtain-horizontal-scrollbar window))
+ (if scrollbar
+ (setf (page-increment scrollbar) (* (1+ (min (gfs:size-width viewport-size)
+ (gfs:size-width top-size)))
+ (gfs:size-width step-incs))))
+ (setf scrollbar (obtain-vertical-scrollbar window))
+ (if scrollbar
+ (setf (page-increment scrollbar) (* (1+ (min (gfs:size-height viewport-size)
+ (gfs:size-height top-size)))
+ (gfs:size-height step-incs)))))))
+
;;;
;;; methods
;;;
+(defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type)
+ (declare (ignore size type))
+ (call-next-method)
+ (update-scrollbar-page-sizes window))
+
(defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail)
- (update-scrolling-state disp window axis detail))
+ (declare (ignore disp))
+ (update-scrolling-state window axis detail))
(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key)
(validate-step-values (step-increments self)))
@@ -106,7 +142,3 @@
(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 Mon Sep 25 12:12:28 2006
@@ -51,7 +51,9 @@
(vertical-policy
:accessor vertical-policy-of
:initarg :vertical-policy
- :initform :always))
+ :initform :always)
+ (viewport-origin
+ :initform (gfs:make-point)))
(:documentation "Instances of this class manage scrolling behavior in addition to other event processing."))
(defvar *default-dispatcher* (make-instance 'event-dispatcher))
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Mon Sep 25 12:12:28 2006
@@ -358,7 +358,7 @@
(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+)))
+ (let ((flags gfs::+sw-invalidate+))
(if (> millis 0)
(let ((tmp (ash (logand millis #xFFFF) 16)))
(setf flags (logior flags tmp gfs::+sw-smoothscroll+))))
More information about the Graphic-forms-cvs
mailing list