Author: junrue Date: Tue Sep 26 00:52:07 2006 New Revision: 268
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/system/datastructs.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp trunk/src/uitoolkit/widgets/window.lisp Log: scrolling very close to working, but visual artifacts still produced during rapid resizing
Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Tue Sep 26 00:52:07 2006 @@ -224,12 +224,12 @@
@anchor{enable-scrollbars} @deffn GenericFunction enable-scrollbars self horizontal vertical -Specifying T for @var{horizontal} (@var{vertical}) reveals a -scrollbar to attached to the right-hand (bottom) of -@var{self}. Specifying @sc{nil} hides the scrollbar. These flags do -not affect scrolling behavior in @var{self} -- they only control -scrollbar visibility. See @ref{horizontal-scrollbar-p} and -@ref{vertical-scrollbar-p}. +Specifying T for @var{horizontal} (@var{vertical}) configures @var{self} +to have a scrollbar to attached to the right-hand (bottom) edge. The +visibility of each scrollbar then depends on the scrollbar visibility +policy configured for @var{self} and the state of the scrolling +viewport. Specifying @sc{nil} forceably hides each scrollbar. +See @ref{horizontal-scrollbar-p} and @ref{vertical-scrollbar-p}. @end deffn
@anchor{enabled-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 Tue Sep 26 00:52:07 2006 @@ -36,7 +36,7 @@ (defconstant +grid-cell-extent+ 50) (defconstant +grid-half-extent+ 25)
-(defvar *grid-model-size* (gfs:make-size :width 25 :height 16)) ; grid cells +(defvar *grid-model-size* (gfs:make-size :width 15 :height 10)) ; grid cells
(defvar *grid-char-size* (gfs:make-size))
@@ -47,7 +47,8 @@ :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) + (setf (gfw:maximum-size panel) panel-size + (gfw:minimum-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 (gfs:size-width panel-size))
Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Tue Sep 26 00:52:07 2006 @@ -61,7 +61,8 @@ (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") + (setf (gfw:text *scroll-tester-win*) "Scroll Tester" + (gfw:size *scroll-tester-win*) (gfs:make-size :width 300 :height 275)) (gfw:show *scroll-tester-win* t)))
(defun scroll-tester ()
Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Tue Sep 26 00:52:07 2006 @@ -53,3 +53,20 @@ (defun equal-size-p (size1 size2) (and (= (size-width size1) (size-width size2)) (= (size-height size1) (size-height size2)))) + +(defmethod cffi:free-translated-object (ptr (name (eql 'point-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free ptr)) + +(defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer))) + (if (null-pointer-p ptr) + (make-point) + (cffi:with-foreign-slots ((x y) ptr point) + (make-point :x x :y y)))) + +(defmethod cffi:translate-to-foreign ((lisp-pnt point) (name (eql 'point-pointer))) + (let ((ptr (cffi:foreign-alloc 'point))) + (cffi:with-foreign-slots ((x y) ptr point) + (setf x (point-x lisp-pnt) + y (point-y lisp-pnt))) + ptr))
Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Sep 26 00:52:07 2006 @@ -275,7 +275,7 @@ ("GetWindowOrgEx" get-window-org) BOOL (hdc HANDLE) - (point LPTR)) + (point point-pointer))
(defcfun ("MaskBlt" mask-blt) @@ -434,7 +434,7 @@ (hdc HANDLE) (x INT) (y INT) - (point LPTR)) + (point point-pointer))
(defun makerop4 (fore back) (logior (logand (ash back 8) #xFF000000) fore))
Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 26 00:52:07 2006 @@ -255,6 +255,8 @@ (cch UINT) (hbmpitem HANDLE))
+(defctype point-pointer :pointer) + (defcstruct point (x LONG) (y LONG))
Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 26 00:52:07 2006 @@ -377,12 +377,9 @@ (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)))) + (set-window-origin gc origin) + (incf (gfs:point-x pnt) (gfs:point-x origin)) + (incf (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)))))
Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Tue Sep 26 00:52:07 2006 @@ -34,6 +34,17 @@ (in-package :graphic-forms.uitoolkit.widgets)
;;; +;;; helper functions +;;; + +(defun obtain-top-child (window) + (let* ((layout (layout-of window)) + (top (top-child-of layout))) + (if top + top + (car (first (compute-layout layout window -1 -1)))))) + +;;; ;;; methods ;;;
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 Tue Sep 26 00:52:07 2006 @@ -66,26 +66,23 @@ (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))) + (let ((disp (dispatcher window))) + (let ((child (obtain-top-child window)) (step-incs (step-increments disp)) (delta-x 0) (delta-y 0)) (cond - ((eql axis :horizontal) + ((or (eql axis :horizontal) (eql axis :both)) (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) + ((or (eql axis :vertical) (eql axis :both)) (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) + (decf (gfs:point-x origin) delta-x) + (decf (gfs:point-y origin) delta-y) (scroll child delta-x delta-y nil 0)))) detail)
@@ -93,29 +90,43 @@ (if (or (<= (gfs:size-width amounts) 0) (<= (gfs:size-height amounts) 0)) (error 'gfs:toolkit-error :detail "invalid step increment")))
+(defun update-scrollbar-page-size (scrollbar viewport-width top-width step-size) + (if scrollbar + (setf (page-increment scrollbar) (* (1+ (min viewport-width top-width)) + step-size))) + scrollbar) + (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))))) + (top (obtain-top-child window))) (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))))))) + (update-scrollbar-page-size (obtain-horizontal-scrollbar window) + (gfs:size-width viewport-size) + (gfs:size-width top-size) + (gfs:size-width step-incs)) + (update-scrollbar-page-size (obtain-vertical-scrollbar window) + (gfs:size-height viewport-size) + (gfs:size-height top-size) + (gfs:size-height step-incs))))) + +(defun update-viewport-origin-for-resize (window) + (let* ((top (obtain-top-child window)) + (viewport-size (client-size window)) + (top-size (if top (size top) viewport-size)) + (origin (slot-value (dispatcher window) 'viewport-origin)) + (delta-x (- (+ (gfs:size-width viewport-size) (gfs:point-x origin)) (gfs:size-width top-size))) + (delta-y (- (+ (gfs:size-height viewport-size) (gfs:point-y origin)) (gfs:size-height top-size)))) + (if (and (> delta-x 0) (> (gfs:point-x origin) 0)) + (setf (gfs:point-x origin) (max 0 (- (gfs:point-x origin) delta-x))) + (setf delta-x 0)) + (if (and (> delta-y 0) (> (gfs:point-y origin) 0)) + (setf (gfs:point-y origin) (max 0 (- (gfs:point-y origin) delta-y))) + (setf delta-y 0)) +(format t "~a~%" origin) + (scroll top delta-x delta-y nil 0) + origin))
;;; ;;; methods @@ -124,11 +135,14 @@ (defmethod event-resize ((disp scrolling-event-dispatcher) (window window) size type) (declare (ignore size type)) (call-next-method) - (update-scrollbar-page-sizes window)) + (when (typep (layout-of window) 'heap-layout) + (update-scrollbar-page-sizes window) + (update-viewport-origin-for-resize window)))
(defmethod event-scroll ((disp scrolling-event-dispatcher) (window window) axis detail) (declare (ignore disp)) - (update-scrolling-state window axis detail)) + (when (typep (layout-of window) 'heap-layout) + (update-scrolling-state window axis detail)))
(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) (validate-step-values (step-increments self)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Tue Sep 26 00:52:07 2006 @@ -138,6 +138,15 @@ (defun release-mouse () (gfs::release-capture))
+(defun get-window-origin (gc) + (let ((pnt (gfs:make-point))) + (gfs::get-window-org (gfs:handle gc) pnt) + pnt)) + +(defun set-window-origin (gc pnt) + (gfs::set-window-org (gfs:handle gc) (gfs:point-x pnt) (gfs:point-y pnt) (cffi:null-pointer)) + pnt) + (defun scroll-children (window delta-x delta-y) (let ((specs (mapchildren window (lambda (parent child) (declare (ignore parent)) @@ -204,14 +213,24 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz)))))
(defmethod enable-scrollbars ((self window) horizontal vertical) - (let ((bits (get-native-style self))) + (let ((style (style-of self)) + (bits (get-native-style self))) (if horizontal - (setf bits (logior bits gfs::+ws-hscroll+)) - (setf bits (logand bits (lognot gfs::+ws-hscroll+)))) + (pushnew :horizontal-scrollbar style) + (progn + (setf style (remove :horizontal-scrollbar style)) + (update-native-style self (logand bits (lognot gfs::+ws-hscroll+))))) (if vertical - (setf bits (logior bits gfs::+ws-vscroll+)) - (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) - (update-native-style self bits))) + (pushnew :vertical-scrollbar style) + (progn + (setf style (remove :vertical-scrollbar style)) + (update-native-style self (logand bits (lognot gfs::+ws-vscroll+))))) + (setf (style-of self) style)) + (if (and (layout-of self) (layout-p self)) + (let ((size (client-size self))) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)))) + (update-scrollbar-page-sizes self) + (update-scrolling-state self :both))
(defmethod event-resize ((disp event-dispatcher) (self window) size type) (declare (ignore size type)) @@ -235,7 +254,7 @@ (gfs::set-focus (gfs:handle self)))
(defmethod horizontal-scrollbar-p ((self top-level)) - (test-native-style self gfs::+ws-hscroll+)) + (find :horizontal-scrollbar (style-of self)))
(defmethod image ((self window)) (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) @@ -322,7 +341,7 @@ (error 'gfs:disposed-error)))
(defmethod obtain-horizontal-scrollbar ((self window)) - (if (test-native-style self gfs::+ws-hscroll+) + (if (horizontal-scrollbar-p self) (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-horz+)))
(defmethod obtain-vertical-scrollbar :before ((self window)) @@ -330,7 +349,7 @@ (error 'gfs:disposed-error)))
(defmethod obtain-vertical-scrollbar ((self window)) - (if (test-native-style self gfs::+ws-vscroll+) + (if (vertical-scrollbar-p self) (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-vert+)))
(defmethod pack ((self window)) @@ -393,7 +412,7 @@ flags)
(defmethod vertical-scrollbar-p ((self top-level)) - (test-native-style self gfs::+ws-vscroll+)) + (find :vertical-scrollbar (style-of self)))
(defmethod window->display :before ((self window)) (if (gfs:disposed-p self)