[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