[graphic-forms-cvs] r268 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Sep 26 04:52:08 UTC 2006
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
- at 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
- at 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)
More information about the Graphic-forms-cvs
mailing list