September 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r268 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 26 Sep '06

26 Sep '06

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)

1 0

[graphic-forms-cvs] r267 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 25 Sep '06

25 Sep '06

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 -@defun update-scrolling-state @ref{event-dispatcher} @ref{window} &optional axis detail => symbol +@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+))))

1 0

[graphic-forms-cvs] r266 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 24 Sep '06

24 Sep '06

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 +@anchor{scroll} +@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-@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. +@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 +@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. +@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 +@anchor{scrolling-event-dispatcher} +@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. +@table @var +@item horizontal-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@item step-increments +A @ref{size} object describing how many pixels a single step in either +direction will jump, by default one pixel. +@item vertical-policy +One of the following keyword symbols describing a scrollbar visibility +policy: +@table @code +@item :always +The scrollbar is always visible, set to a disabled state if scrolling +is unnecessary. +@item :when-needed +The scrollbar is hidden when scrolling is unnecessary. +@end table +The default policy is @code{:always} +@end table +@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)

1 0

[graphic-forms-cvs] r265 - in trunk/src: tests/uitoolkit uitoolkit/widgets
by junrue＠common-lisp.net 23 Sep '06

23 Sep '06

Author: junrue Date: Fri Sep 22 23:33:53 2006 New Revision: 265 Modified: trunk/src/tests/uitoolkit/mock-objects.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/list-box.lisp trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/window.lisp Log: got rid of accessors for min-size and max-size slots of control and window, to further discourage direct access of those slots by application code Modified: trunk/src/tests/uitoolkit/mock-objects.lisp ============================================================================== --- trunk/src/tests/uitoolkit/mock-objects.lisp (original) +++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 22 23:33:53 2006 @@ -74,11 +74,9 @@ :initarg :actual-size :initform (gfs:make-size)) (max-size - :accessor max-size-of :initarg :max-size :initform (gfs:make-size :width +max-widget-size+ :height +max-widget-size+)) (min-size - :accessor min-size-of :initarg :min-size :initform (gfs:make-size)))) @@ -89,12 +87,12 @@ (gfs:make-point)) (defmethod gfw:minimum-size ((self mock-widget)) - (gfs:make-size :width (gfs:size-width (min-size-of self)) - :height (gfs:size-height (min-size-of self)))) + (gfs:make-size :width (gfs:size-width (slot-value self 'min-size)) + :height (gfs:size-height (slot-value self 'min-size)))) (defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint) (let ((size (gfs:make-size)) - (min-size (min-size-of self))) + (min-size (slot-value self 'min-size))) (if (< width-hint 0) (setf (gfs:size-width size) (gfs:size-width min-size)) (setf (gfs:size-width size) width-hint)) @@ -104,7 +102,7 @@ size)) (defmethod gfw:text-baseline ((self mock-widget)) - (floor (* (gfs:size-height (min-size-of self)) 3) 4)) + (floor (* (gfs:size-height (slot-value self 'min-size)) 3) 4)) (defmethod gfw:visible-p ((self mock-widget)) (visibility-of self)) 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 Fri Sep 22 23:33:53 2006 @@ -48,7 +48,7 @@ (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 (gfw::max-size-of panel))) + (assert (gfs:equal-size-p panel-size (slot-value panel 'gfw::max-size))) #| (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) (font (make-instance 'gfg:font :gc gc))) Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Fri Sep 22 23:33:53 2006 @@ -161,22 +161,22 @@ (setf (dispatcher self) (make-instance (class-name class)))))) (defmethod maximum-size ((self control)) - (max-size-of self)) + (slot-value self 'max-size)) (defmethod (setf maximum-size) (max-size (self control)) - (setf (max-size-of self) max-size) + (setf (slot-value self 'max-size) max-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) (defmethod minimum-size ((self control)) - (let ((size (min-size-of self))) + (let ((size (slot-value self 'min-size))) (if (null size) (preferred-size self -1 -1) size))) (defmethod (setf minimum-size) (min-size (self control)) - (setf (min-size-of self) min-size) + (setf (slot-value self 'min-size) min-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Fri Sep 22 23:33:53 2006 @@ -80,8 +80,8 @@ (if spec (let ((bounds (cdr spec))) (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds) - (min-size-of top) - (max-size-of top))) + (slot-value top 'min-size) + (slot-value top 'max-size))) (setf (cdr spec) bounds)))) (arrange-hwnds kid-specs (lambda (item) (if (eql top item) Modified: trunk/src/uitoolkit/widgets/list-box.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/list-box.lisp (original) +++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 22 23:33:53 2006 @@ -247,8 +247,8 @@ (defmethod preferred-size ((self list-box) width-hint height-hint) (let ((hwnd (gfs:handle self)) - (min-size (min-size-of self)) - (max-size (max-size-of self)) + (min-size (slot-value self 'min-size)) + (max-size (slot-value self 'max-size)) (size (gfs:make-size :width width-hint :height height-hint)) (b-width (* (border-width self) 2))) (cond Modified: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/scrollbar.lisp (original) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Fri Sep 22 23:33:53 2006 @@ -131,7 +131,7 @@ (let ((orient (orientation-of self))) (unless (or (= orient gfs::+sb-horz+) (= orient gfs::+sb-vert+)) (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation"))) - (setf (slot-value self 'dispatcher) nil)) + (setf (slot-value self 'dispatcher) nil)) ; standard scrollbars don't use dispatchers (defmethod page-increment ((self standard-scrollbar)) (destructuring-bind (limits pagesize pos trackpos) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 22 23:33:53 2006 @@ -147,11 +147,9 @@ :accessor pixel-point-of :initform nil) (max-size - :accessor max-size-of :initarg :maximum-size :initform nil) (min-size - :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior.")) @@ -219,11 +217,9 @@ (defclass window (widget layout-managed) ((max-size - :accessor max-size-of :initarg :maximum-size :initform nil) (min-size - :accessor min-size-of :initarg :minimum-size :initform nil)) (:documentation "Base class for user-defined widgets that serve as containers.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Sep 22 23:33:53 2006 @@ -284,10 +284,10 @@ tmp))) (defmethod maximum-size ((self window)) - (max-size-of self)) + (slot-value self 'max-size)) (defmethod (setf maximum-size) (max-size (self window)) - (setf (max-size-of self) max-size) + (setf (slot-value self 'max-size) max-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) @@ -296,10 +296,10 @@ size))) (defmethod minimum-size ((self window)) - (min-size-of self)) + (slot-value self 'min-size)) (defmethod (setf minimum-size) (min-size (self window)) - (setf (min-size-of self) min-size) + (setf (slot-value self 'min-size) min-size) (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)

1 0

[graphic-forms-cvs] r264 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 23 Sep '06

23 Sep '06

Author: junrue Date: Fri Sep 22 20:37:13 2006 New Revision: 264 Added: trunk/src/uitoolkit/widgets/scrollbar.lisp trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Modified: trunk/docs/manual/widget-functions.texinfo trunk/docs/manual/widget-types.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/scroll-grid-panel.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented standard scrollbar abstraction Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Fri Sep 22 20:37:13 2006 @@ -388,27 +388,27 @@ @end defun @anchor{obtain-horizontal-scrollbar} -@deffn GenericFunction obtain-horizontal-scrollbar self => widget -Returns a @ref{widget} representing the horizontal scrollbar attached +@deffn GenericFunction obtain-horizontal-scrollbar self => @ref{standard-scrollbar} +Returns an object representing the horizontal scrollbar attached to the bottom of @var{self}, if @var{self} is configured to have one and whether or not said scrollbar is currently visible; or returns @sc{nil} if @var{self} is not configured to have a horizontal scrollbar. Note that the widget returned by this function is not a @ref{control} -instance; it is instead an abstract of what is referred to in the Microsoft -documentation as a @emph{standard scrollbar}. +instance; rather, it is an abstraction of what Microsoft's documentation +refers to as a @emph{standard scrollbar}. See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}. @end deffn @anchor{obtain-vertical-scrollbar} -@deffn GenericFunction obtain-vertical-scrollbar self => widget -Returns a @ref{widget} representing the vertical scrollbar attached +@deffn GenericFunction obtain-vertical-scrollbar self => @ref{standard-scrollbar} +Returns an object representing the vertical scrollbar attached to the right side of @var{self}, if @var{self} is configured to have one and whether or not said scrollbar is currently visible; or returns @sc{nil} if @var{self} is not configured to have a vertical scrollbar. Note that the widget returned by this function is not a @ref{control} -instance; it is instead an abstract of what is referred to in the Microsoft -documentation as a @emph{standard scrollbar}. +instance; rather, it is an abstraction of what Microsoft's documentation +refers to as a @emph{standard scrollbar}. See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}. @end deffn Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Fri Sep 22 20:37:13 2006 @@ -142,6 +142,24 @@ A subclass of @ref{item} representing a @ref{menu} item. @end deftp +@anchor{standard-scrollbar} +@deftp Class standard-scrollbar orientation step-increment +This class encapsulates a @emph{standard scrollbar}, which +is Microsoft's term for a scrollbar-like component attached to +the right side or bottom of a window. This class is not meant +to be instantiated by application code. See @ref{obtain-horizontal-scrollbar} +and @ref{obtain-vertical-scrollbar}. +@table @var +@item orientation +This slot holds an internal value identifying this object as +either the horizontal or vertical scrollbar. +@item step-increment +This slot holds an integer value specifying how many pixels +to move the viewport when the scrollbar is stepped forward +or back. +@end table +@end deftp + @anchor{timer} @deftp Class timer id initial-delay delay A timer is a non-windowed object that generates events at a regular Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Fri Sep 22 20:37:13 2006 @@ -138,6 +138,8 @@ (:file "menu-item") (:file "menu-language") (:file "event") + (:file "scrolling-event-dispatcher") + (:file "scrollbar") (:file "window") (:file "root-window") (:file "top-level") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Sep 22 20:37:13 2006 @@ -435,7 +435,7 @@ #:iconified-p #:id-of #:initial-delay-of - #:horizontal-scrollbar + #:horizontal-policy-of #:image #:item-count #:item-height @@ -470,7 +470,9 @@ #:obtain-chosen-color #:obtain-displays #:obtain-event-time + #:obtain-horizontal-scrollbar #:obtain-primary-display + #:obtain-vertical-scrollbar #:owner #:pack #:page-increment @@ -513,7 +515,9 @@ #:text-height #:text-limit #:text-modified-p - #:thumb-size + #:thumb-limits + #:thumb-position + #:thumb-track-position #:tooltip-text #:top-child-of #:top-index @@ -523,7 +527,7 @@ #:trim-sizes #:undo-available-p #:update - #:vertical-scrollbar + #:vertical-policy-of #:visible-item-count #:visible-p #:with-color-dialog 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 Fri Sep 22 20:37:13 2006 @@ -33,18 +33,70 @@ (in-package #:graphic-forms.uitoolkit.tests) +(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-char-size* (gfs:make-size)) + (defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) (defun make-scroll-grid-panel (parent) - (let ((panel-size (gfs:make-size :width 1000 :height 800)) + (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+))) (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 (gfw::max-size-of panel))) +#| + (let* ((gc (make-instance 'gfg:graphics-context :widget panel)) + (font (make-instance 'gfg:font :gc gc))) + (unwind-protect + (let ((metrics (gfg:metrics gc font))) + (setf (gfs:size-width *grid-char-size*) (gfg:maximum-char-width metrics) + (gfs:size-height *grid-char-size*) (+ (gfg:ascent metrics) + (gfg:descent metrics)))) + (gfs:dispose font) + (gfs:dispose gc))) +|# + (setf (gfs:size-width *grid-char-size*) (floor +grid-half-extent+ 2) + (gfs:size-height *grid-char-size*) (floor +grid-half-extent+ 2)) panel)) (defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) + (declare (ignore window)) (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) (setf (gfg:background-color gc) color (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect)) + (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) + (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+)) + (first-col (floor (gfs:point-x pnt) +grid-cell-extent+)) + (last-col (floor (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 + for start-pnt = (gfs:make-point :y (* row +grid-cell-extent+)) + do (progn + (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x lr-pnt) + :y (gfs:point-y start-pnt))) + (loop for col from first-col upto last-col + for text = (format nil "~d ~d" col row) + for start-pnt = (gfs:make-point :x (* col +grid-cell-extent+)) + for text-pnt = (gfs:make-point :x (+ (* col +grid-cell-extent+) + (- +grid-half-extent+ + (gfs:size-width *grid-char-size*))) + :y (+ (* row +grid-cell-extent+) + (- +grid-half-extent+ + (gfs:size-height *grid-char-size*)))) + do (progn + (if (= row first-row) + (gfg:draw-line gc start-pnt (gfs:make-point :x (gfs:point-x start-pnt) + :y (gfs:point-y lr-pnt)))) + (gfg:draw-text gc text text-pnt '(:transparent)))))))) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Fri Sep 22 20:37:13 2006 @@ -55,7 +55,7 @@ :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) (panel (make-scroll-grid-panel *scroll-tester-win*))) (setf (gfw:menu-bar *scroll-tester-win*) menubar Added: trunk/src/uitoolkit/widgets/scrollbar.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/scrollbar.lisp Fri Sep 22 20:37:13 2006 @@ -0,0 +1,175 @@ +;;;; +;;;; scrollbar.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; helper functions +;;; + +(defun validate-scrollbar-type (type) + (unless (or (= type gfs::+sb-ctl+) (= type gfs::+sb-horz+) (= type gfs::+sb-vert+)) + (error 'gfs:toolkit-error :detail "invalid scrollbar type ID"))) + +(defun sb-get-info (scrollbar type) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (validate-scrollbar-type type) + (let ((hwnd (gfs:handle scrollbar))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize gfs::pos + gfs::minpos gfs::maxpos gfs::trackpos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-all+) + (gfs::get-scroll-info hwnd type info-ptr) + (list (gfs:make-span :start gfs::minpos :end gfs::maxpos) + gfs::pagesize + gfs::pos + gfs::trackpos))))) + +(defun sb-set-page-increment (scrollbar type amount) + (validate-scrollbar-type type) + (when (< amount 0) + (warn 'gfs:toolkit-warning :detail "negative scrollbar page increment") + (return-from sb-set-page-increment 0)) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (let ((hwnd (gfs:handle scrollbar))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pagesize) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-page+ + gfs::pagesize amount)) + (gfs::set-scroll-info hwnd type info-ptr 1))) + amount) + +(defun sb-set-thumb-limits (scrollbar type span) + (when (or (< (gfs:span-start span) 0) (< (gfs:span-end span) 0)) + (warn 'gfs:toolkit-warning :detail "negative scrollbar limit") + (return-from sb-set-thumb-limits nil)) + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (let ((hwnd (gfs:handle scrollbar))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::minpos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-range+ + gfs::minpos (gfs:span-start span) + gfs::maxpos (gfs:span-end span))) + (gfs::set-scroll-info hwnd type info-ptr 1))) + span) + +(defun sb-set-thumb-position (scrollbar type position) + (when (< position 0) + (warn 'gfs:toolkit-warning :detail "negative scrollbar position") + (return-from sb-set-thumb-position 0)) + ;; + ;; TODO: should check position against limits, but doing that + ;; is not cheap, whereas the application will be calling this + ;; method frequently to maintain the scrollbar's position; + ;; more thought needed. + ;; + (if (gfs:disposed-p scrollbar) + (error 'gfs:disposed-error)) + (let ((hwnd (gfs:handle scrollbar))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-pos+ + gfs::pos position)) + (gfs::set-scroll-info hwnd type info-ptr 1))) + position) + +;;; +;;; standard scrollbar implementation +;;; + +(defmethod gfs:dispose ((self standard-scrollbar)) + (setf (slot-value self 'gfs:handle) nil)) + +(defmethod initialize-instance :after ((self standard-scrollbar) &key) + (if (gfs:null-handle-p (gfs:handle self)) + (error 'gfs:disposed-error)) + (let ((orient (orientation-of self))) + (unless (or (= orient gfs::+sb-horz+) (= orient gfs::+sb-vert+)) + (error 'gfs:toolkit-error :detail "invalid standard scrollbar orientation"))) + (setf (slot-value self 'dispatcher) nil)) + +(defmethod page-increment ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pos trackpos)) + pagesize)) + +(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)) + (declare (ignore pagesize pos trackpos)) + limits)) + +(defmethod (setf thumb-limits) (span (self standard-scrollbar)) + (sb-set-thumb-limits self (orientation-of self) span)) + +(defmethod thumb-position ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pagesize trackpos)) + pos)) + +(defmethod (setf thumb-position) (position (self standard-scrollbar)) + (sb-set-thumb-position self (orientation-of self) position)) + +(defmethod thumb-track-position ((self standard-scrollbar)) + (destructuring-bind (limits pagesize pos trackpos) + (sb-get-info self (orientation-of self)) + (declare (ignore limits pagesize pos)) + trackpos)) + +;;; +;;; TBD: scrollbar control implementation +;;; Added: trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/widgets/scrolling-event-dispatcher.lisp Fri Sep 22 20:37:13 2006 @@ -0,0 +1,50 @@ +;;;; +;;;; scrolling-event-dispatcher.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.widgets) + +;;; +;;; 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"))) + +;;; +;;; methods +;;; + +(defmethod initialize-instance :after ((self scrolling-event-dispatcher) &key) + (validate-scrollbar-policies self)) Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Fri Sep 22 20:37:13 2006 @@ -39,6 +39,17 @@ (defclass event-dispatcher () () (:documentation "Instances of this class receive events on behalf of user interface objects.")) +(defclass scrolling-event-dispatcher (event-dispatcher) + ((horizontal-policy + :accessor horizontal-policy-of + :initarg :horizontal-policy + :initform :always) + (vertical-policy + :accessor vertical-policy-of + :initarg :vertical-policy + :initform :always)) + (:documentation "Instances of this class manage scrolling behavior in addition to other event processing.")) + (defvar *default-dispatcher* (make-instance 'event-dispatcher)) (defclass layout-managed () @@ -98,6 +109,17 @@ (defclass menu-item (item) () (:documentation "A subclass of item representing a menu item.")) +(defclass standard-scrollbar (event-source) + ((orientation + :reader orientation-of + :initarg :orientation + :initform nil) + (step-increment + :accessor step-increment + :initarg :step-increment + :initform 1)) + (:documentation "This class encapsulates a scrollbar attached to a window.")) + (defclass widget (event-source) ((style :accessor style-of Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Fri Sep 22 20:37:13 2006 @@ -405,8 +405,20 @@ (defgeneric (setf text-modified-p) (modified self) (:documentation "Sets self's modified flag.")) -(defgeneric thumb-size (self) - (:documentation "Returns an integer representing the width (or height) of this object's thumb.")) +(defgeneric thumb-limits (self) + (:documentation "Returns the lowest and highest allowed positions of self's thumb component.")) + +(defgeneric (setf thumb-limits) (span self) + (:documentation "Sets the lowest and highest allowed positions of self's thumb component.")) + +(defgeneric thumb-position (self) + (:documentation "Returns the position of self's thumb component.")) + +(defgeneric (setf thumb-position) (position self) + (:documentation "Sets the position of self's thumb component.")) + +(defgeneric thumb-track-position (self) + (:documentation "Returns self's current track position.")) (defgeneric tooltip-text (self) (:documentation "Returns the text that will appear within a tooltip when the mouse hovers over this object.")) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Fri Sep 22 20:37:13 2006 @@ -307,6 +307,22 @@ (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) +(defmethod obtain-horizontal-scrollbar :before ((self window)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod obtain-horizontal-scrollbar ((self window)) + (if (test-native-style self gfs::+ws-hscroll+) + (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-horz+))) + +(defmethod obtain-vertical-scrollbar :before ((self window)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod obtain-vertical-scrollbar ((self window)) + (if (test-native-style self gfs::+ws-vscroll+) + (make-instance 'standard-scrollbar :handle (gfs:handle self) :orientation gfs::+sb-vert+))) + (defmethod pack ((self window)) (unless (null (layout-of self)) (perform (layout-of self) self -1 -1))

1 0

[graphic-forms-cvs] r263 - in trunk: . src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 22 Sep '06

22 Sep '06

Author: junrue Date: Thu Sep 21 20:48:28 2006 New Revision: 263 Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Modified: trunk/NEWS.txt trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/misc-unit-tests.lisp trunk/src/tests/uitoolkit/scroll-tester.lisp trunk/src/uitoolkit/system/system-utils.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/heap-layout.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed bugs in setf of minimum and maximum sizes for windows; improved heap-layout such that it obeys the top child min and max sizes if any Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Thu Sep 21 20:48:28 2006 @@ -14,6 +14,15 @@ Additional list box control features will be provided in a future release. +. Implemented scrolling support: + + * new window styles :horizontal-scrollbar and :vertical-scrollbar + + * new event-scroll method for handling raw scrolling events + +. Improved GFW:HEAP-LAYOUT such that it obeys the top child's minimum and + maximum sizes, if any such sizes are set. + . Did some housecleaning of the item-manager protocol and heavily refactored the implementation of item-manager base functionality. @@ -23,6 +32,14 @@ . Fixed a silly bug in GFW:CHECKED-P (and GFW:SELECTED-P) for checkbox and radio button -style buttons. +. Fixed another silly bug, this one in the initialization of the paint + rectangle in the WM_PAINT message handling method; the correct rectangle + is now passed to GFW:EVENT-PAINT + +. Fixed a bug in the SETF methods for GFW:MAXIMUM-SIZE and GFW:MINIMUM-SIZE + for windows whereby the size value was not being set in the appropriate + slot if there were no layout set for the window. + ============================================================================== Release 0.5.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 20:48:28 2006 @@ -90,5 +90,6 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-grid-panel") (:file "scroll-tester") (:file "windlg"))))))))) Modified: trunk/src/tests/uitoolkit/misc-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/misc-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/misc-unit-tests.lisp Thu Sep 21 20:48:28 2006 @@ -187,3 +187,26 @@ (assert-false (gfs::remove-elements tmp (gfs:make-span :start 0 :end 0) #'reaam-test-make-array)))) + +(define-test clamp-size-test + (let ((min-size (gfs:make-size :width 10 :height 10)) + (max-size (gfs:make-size :width 100 :height 100)) + (test-sizes (loop for width in '(5 10 50 100 150) + for height in '(10 5 100 50 150) + collect (gfs:make-size :width width :height height))) + (expected-sizes-1 (loop for width in '(10 10 50 100 100) + for height in '(10 10 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-2 (loop for width in '(5 10 50 100 100) + for height in '(10 5 100 50 100) + collect (gfs:make-size :width width :height height))) + (expected-sizes-3 (loop for width in '(10 10 50 100 150) + for height in '(10 10 100 50 150) + collect (gfs:make-size :width width :height height)))) + (loop for min-size-1 in (list min-size nil min-size nil) + for max-size-1 in (list max-size max-size nil nil) + for exp-list in (list expected-sizes-1 expected-sizes-2 expected-sizes-3 test-sizes) + do (loop for test-size in test-sizes + for exp-size in exp-list + do (let ((clamped-size (gfs::clamp-size test-size min-size-1 max-size-1))) + (assert-true (gfs:equal-size-p exp-size clamped-size) exp-size test-size)))))) Added: trunk/src/tests/uitoolkit/scroll-grid-panel.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-grid-panel.lisp Thu Sep 21 20:48:28 2006 @@ -0,0 +1,50 @@ +;;;; +;;;; scroll-grid-panel.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defclass scroll-grid-panel-events (gfw:event-dispatcher) ()) + +(defun make-scroll-grid-panel (parent) + (let ((panel-size (gfs:make-size :width 1000 :height 800)) + (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 (gfw::max-size-of panel))) + panel)) + +(defmethod gfw:event-paint ((disp scroll-grid-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) Modified: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/scroll-tester.lisp (original) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 20:48:28 2006 @@ -47,31 +47,18 @@ (declare (ignore window)) (scroll-tester-exit disp nil)) -(defclass scroll-panel-events (gfw:event-dispatcher) ()) - -(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) - (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) - (setf (gfg:background-color gc) color - (gfg:foreground-color gc) color)) - (gfg:draw-filled-rectangle gc rect)) - (defun scroll-tester-internal () (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (let ((disp (make-instance 'scroll-tester-events)) - (panel-disp (make-instance 'scroll-panel-events)) (layout (make-instance 'gfw:heap-layout)) (menubar (gfw:defmenu ((:item "&File" :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp :layout layout - :style '(:frame))) + :style '(:workspace))) (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) - (panel (make-instance 'gfw:panel :dispatcher panel-disp - :parent *scroll-tester-win*)) - (panel-size (gfs:make-size :width 200 :height 200))) - (setf (gfw:minimum-size panel) panel-size - (gfw:maximum-size panel) panel-size - (gfw:menu-bar *scroll-tester-win*) menubar + (panel (make-scroll-grid-panel *scroll-tester-win*))) + (setf (gfw:menu-bar *scroll-tester-win*) menubar (gfw:top-child-of layout) panel (gfw:image *scroll-tester-win*) icons)) (gfw:show *scroll-tester-win* t))) Modified: trunk/src/uitoolkit/system/system-utils.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-utils.lisp (original) +++ trunk/src/uitoolkit/system/system-utils.lisp Thu Sep 21 20:48:28 2006 @@ -115,6 +115,21 @@ (list tree) (mapcan (function flatten) tree))) +(defun clamp-size (proposed-size min-size max-size) + (let ((clamped-size (make-size :width (gfs:size-width proposed-size) + :height (gfs:size-height proposed-size)))) + (when min-size + (if (< (gfs:size-width proposed-size) (gfs:size-width min-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width min-size))) + (if (< (gfs:size-height proposed-size) (gfs:size-height min-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height min-size)))) + (when max-size + (if (> (gfs:size-width proposed-size) (gfs:size-width max-size)) + (setf (gfs:size-width clamped-size) (gfs:size-width max-size))) + (if (> (gfs:size-height proposed-size) (gfs:size-height max-size)) + (setf (gfs:size-height clamped-size) (gfs:size-height max-size)))) + clamped-size)) + ;;; lifted from lispbuilder-windows/windows/util.lisp ;;; author: Frank Buss ;;; Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Thu Sep 21 20:48:28 2006 @@ -164,8 +164,8 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self control)) + (setf (max-size-of self) max-size) (unless (gfs:disposed-p self) - (setf (max-size-of self) max-size) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size)))) @@ -176,8 +176,8 @@ size))) (defmethod (setf minimum-size) (min-size (self control)) + (setf (min-size-of self) min-size) (unless (gfs:disposed-p self) - (setf (min-size-of self) min-size) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size)))) Modified: trunk/src/uitoolkit/widgets/heap-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/heap-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/heap-layout.lisp Thu Sep 21 20:48:28 2006 @@ -72,8 +72,17 @@ (if (layout-p container) (let ((top (top-child-of self)) (kid-specs (compute-layout self container width-hint height-hint))) - (unless top - (setf top (car (first kid-specs)))) + (let ((spec (if top + (find-if (lambda (x) (eql x top)) kid-specs :key #'car) + (progn + (setf top (car (first kid-specs))) + (first kid-specs))))) + (if spec + (let ((bounds (cdr spec))) + (setf (gfs:size bounds) (gfs::clamp-size (gfs:size bounds) + (min-size-of top) + (max-size-of top))) + (setf (cdr spec) bounds)))) (arrange-hwnds kid-specs (lambda (item) (if (eql top item) (logior +window-pos-flags+ gfs::+swp-showwindow+) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 20:48:28 2006 @@ -287,22 +287,24 @@ (max-size-of self)) (defmethod (setf maximum-size) (max-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (max-size-of self) max-size) + (setf (max-size-of self) max-size) + (unless (gfs:disposed-p self) (let ((size (constrain-new-size max-size (size self) #'min))) (setf (size self) size) - (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod minimum-size ((self window)) (min-size-of self)) (defmethod (setf minimum-size) (min-size (self window)) - (unless (or (gfs:disposed-p self) (null (layout-of self))) - (setf (min-size-of self) min-size) + (setf (min-size-of self) min-size) + (unless (gfs:disposed-p self) (let ((size (constrain-new-size min-size (size self) #'max))) (setf (size self) size) - (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size)) + (unless (null (layout-of self)) + (perform (layout-of self) self (gfs:size-width size) (gfs:size-height size))) size))) (defmethod pack ((self window))

1 0

[graphic-forms-cvs] r262 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
by junrue＠common-lisp.net 21 Sep '06

21 Sep '06

Author: junrue Date: Thu Sep 21 16:58:29 2006 New Revision: 262 Added: trunk/src/tests/uitoolkit/scroll-tester.lisp Modified: trunk/docs/manual/widget-functions.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed a silly WM_PAINT handling bug in initializing the paint rect; small improvement to window print-object; other miscellaneous tweaks Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 21 16:58:29 2006 @@ -271,7 +271,8 @@ @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a horizontal -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction image self => @ref{image} @@ -386,6 +387,32 @@ of these is the primary @ref{display}. @end defun +@anchor{obtain-horizontal-scrollbar} +@deffn GenericFunction obtain-horizontal-scrollbar self => widget +Returns a @ref{widget} representing the horizontal scrollbar attached +to the bottom of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a horizontal scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}. +@end deffn + +@anchor{obtain-vertical-scrollbar} +@deffn GenericFunction obtain-vertical-scrollbar self => widget +Returns a @ref{widget} representing the vertical scrollbar attached +to the right side of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a vertical scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}. +@end deffn + @anchor{obtain-primary-display} @defun obtain-primary-display => @ref{display} Return a display object that is regarded by the system as @@ -638,7 +665,8 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a vertical -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction visible-p self Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 16:58:29 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:scroll-tester #:widget-tester #:textedit #:unblocked @@ -89,4 +90,5 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 16:58:29 2006 @@ -0,0 +1,80 @@ +;;;; +;;;; scroll-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defvar *scroll-tester-win* nil) + +(defun scroll-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *scroll-tester-win*) + (setf *scroll-tester-win* nil) + (gfw:shutdown 0)) + +(defclass scroll-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp scroll-tester-events) window) + (declare (ignore window)) + (scroll-tester-exit disp nil)) + +(defclass scroll-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) + +(defun scroll-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) + (let ((disp (make-instance 'scroll-tester-events)) + (panel-disp (make-instance 'scroll-panel-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) + (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) + (panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *scroll-tester-win*)) + (panel-size (gfs:make-size :width 200 :height 200))) + (setf (gfw:minimum-size panel) panel-size + (gfw:maximum-size panel) panel-size + (gfw:menu-bar *scroll-tester-win*) menubar + (gfw:top-child-of layout) panel + (gfw:image *scroll-tester-win*) icons)) + (gfw:show *scroll-tester-win* t))) + +(defun scroll-tester () + (gfw:startup "Scroll Tester" #'scroll-tester-internal)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Sep 21 16:58:29 2006 @@ -372,11 +372,11 @@ gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (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)) (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)) (unwind-protect (event-paint (dispatcher widget) widget gc rct) (gfs:dispose gc) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 16:58:29 2006 @@ -193,12 +193,6 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((disp event-dispatcher) (self window) size type) - (declare (ignore size type)) - (unless (null (layout-of self)) - (let ((sz (client-size self))) - (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))) (if horizontal @@ -209,6 +203,12 @@ (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) (update-native-style self bits))) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) + (declare (ignore size type)) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -326,7 +326,8 @@ (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) + (if (not (gfs:disposed-p self)) + (format stream "size: ~a" (size self))))) (defmethod show ((self window) flag) (declare (ignore flag))

1 0

[graphic-forms-cvs] r261 - trunk/docs/website
by junrue＠common-lisp.net 14 Sep '06

14 Sep '06

Author: junrue Date: Thu Sep 14 00:46:04 2006 New Revision: 261 Modified: trunk/docs/website/download.html trunk/docs/website/index.html Log: website tweak Modified: trunk/docs/website/download.html ============================================================================== --- trunk/docs/website/download.html (original) +++ trunk/docs/website/download.html Thu Sep 14 00:46:04 2006 @@ -2,7 +2,7 @@ <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en"> <head> - <title>Graphic-Forms Source Control</title> + <title>Graphic-Forms Downloads</title> <link rel="stylesheet" type="text/css" href="style.css" /> <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" /> </head> @@ -10,7 +10,7 @@ <body> <div class="header"> - <h3>Graphic-Forms downloads</h3> + <h3>Graphic-Forms Downloads</h3> </div> <p>Graphic-Forms is distributed in source code form. Please choose from @@ -19,8 +19,7 @@ <ul> <li> <a href="http://sourceforge.net/project/showfiles.php?group_id=163034">Download</a> - a release tarball. File hosting courtesy of - <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a><p/> + a release tarball.<p/> </li> <li> <a href="http://common-lisp.net/faq.shtml">Download</a> Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Thu Sep 14 00:46:04 2006 @@ -91,6 +91,8 @@ LispWorks is a trademark of <a href="http://www.lispworks.com/">LispWorks Ltd</a>. All other trademarks used are owned by their respective owners.</p> + <a href="http://sourceforge.net"><IMG src="http://sourceforge.net/sflogo.php?group_id=20959" width="88" height="31" border="0" alt="SourceForge Logo"></a><p/> + <div class="footer"> <a class="footerleft" href="http://common-lisp.net">common-lisp.net home</a> Copyright © 2006 by <a href="http://home.earthlink.net/~jdunrue/">Jack D. Unrue</a>

1 0

[graphic-forms-cvs] r260 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 14 Sep '06

14 Sep '06

Author: junrue Date: Wed Sep 13 23:44:06 2006 New Revision: 260 Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget.lisp trunk/src/uitoolkit/widgets/window.lisp Log: added some missing scrollbar-related methods to window Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Wed Sep 13 23:44:06 2006 @@ -192,7 +192,7 @@ (defgeneric header-visible-p (self) (:documentation "Returns T if the object's header is visible; nil otherwise.")) -(defgeneric horizontal-scrollbar (self) +(defgeneric horizontal-scrollbar-p (self) (:documentation "Returns T if this object currently has a horizontal scrollbar; nil otherwise.")) (defgeneric iconify (self flag) @@ -432,7 +432,7 @@ (defgeneric update-native-style (self flags) (:documentation "Modifies self's native style flags and refreshes self's visual appearance.")) -(defgeneric vertical-scrollbar (self) +(defgeneric vertical-scrollbar-p (self) (:documentation "Returns T if this object currently has a vertical scrollbar; nil otherwise.")) (defgeneric visible-item-count (self) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Wed Sep 13 23:44:06 2006 @@ -206,9 +206,21 @@ (if flag (redraw self))) +(defmethod enable-scrollbars :before ((self widget) horizontal vertical) + (declare (ignore horizontal vertical)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + (defmethod enabled-p ((self widget)) (/= (gfs::is-window-enabled (gfs:handle self)) 0)) +(defmethod horizontal-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod horizontal-scrollbar-p ((self widget)) + nil) + (defmethod image :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -430,6 +442,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error))) +(defmethod vertical-scrollbar-p :before ((self widget)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod vertical-scrollbar-p ((self widget)) + nil) + (defmethod visible-p :before ((self widget)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Wed Sep 13 23:44:06 2006 @@ -193,12 +193,22 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((d event-dispatcher) (self window) size type) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) (declare (ignore size type)) (unless (null (layout-of self)) (let ((sz (client-size self))) (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))) + (if horizontal + (setf bits (logior bits gfs::+ws-hscroll+)) + (setf bits (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))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -214,6 +224,9 @@ (defmethod give-focus ((self window)) (gfs::set-focus (gfs:handle self))) +(defmethod horizontal-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-hscroll+)) + (defmethod image ((self window)) (let ((small (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-small+ 0)) (large (gfs::send-message (gfs:handle self) gfs::+wm-geticon+ gfs::+icon-big+ 0)) @@ -334,6 +347,9 @@ gfs::+swp-nozorder+))) flags) +(defmethod vertical-scrollbar-p ((self top-level)) + (test-native-style self gfs::+ws-vscroll+)) + (defmethod window->display :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

1 0

[graphic-forms-cvs] r259 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 12 Sep '06

12 Sep '06

Author: junrue Date: Tue Sep 12 01:35:09 2006 New Revision: 259 Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: added scroll event testing to event-tester Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Sep 12 01:35:09 2006 @@ -157,6 +157,14 @@ @end table @end macro +@macro window-scrollbar-style{orientation,location} +@item :\orientation\-scrollbar +This style keyword configures a window to have a \orientation\ +scrollbar attached on the \location\. This style is a prerequisite +for scrolling functionality. The visibility policy for the scrollbar +can be configured via FIXME FIXME +@end macro + @c ==========================End Macros ============================= @copying Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Sep 12 01:35:09 2006 @@ -702,6 +702,14 @@ This initarg is used to specify the @ref{parent} window of the panel. @end deffn +@deffn Initarg :style +@begin-primary-style-choices{} +@item :border +This style keyword causes the panel to maintain a thin border. +@window-scrollbar-style{horizontal,bottom} +@window-scrollbar-style{vertical,right} +@end-primary-style-choices +@end deffn @end deftp @anchor{root-window} @@ -728,10 +736,12 @@ @anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that are self-contained and parented to +This class represents @ref{window}s that are self-contained and parented to the @ref{root-window}. Except when created with the @code{:borderless} or @code{:palette} styles, they are resizable and have title bars -(also called @samp{captions}). +(also called @samp{captions}). They may have scrollbars if either of the +@code{:horizontal-scrollbar} or @code{:vertical-scrollbar} styles are +specified, with further control over scrollbar visibility being possible. @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -765,9 +775,11 @@ using the @sc{color_appworkspace} Win32 color scheme. @end-primary-style-choices @begin-optional-style-choices +@window-scrollbar-style{horizontal,bottom} @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. +@window-scrollbar-style{vertical,right} @end-optional-style-choices @end deffn @end deftp Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Sep 12 01:35:09 2006 @@ -416,6 +416,7 @@ #:event-pre-move #:event-pre-resize #:event-resize + #:event-scroll #:event-select #:event-session #:event-timer Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Sep 12 01:35:09 2006 @@ -59,6 +59,45 @@ (declare (ignore widget)) (exit-event-tester)) +(defun initialize-scrollbars () + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::pagesize) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask (logior gfs::+sif-page+ gfs::+sif-range+ gfs::+sif-disablenoscroll+) + gfs::maxpos 500 + gfs::pagesize 50)) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-horz+ info-ptr 0) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-vert+ info-ptr 0))) + +(defun update-scrollbars (axis detail) + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (let ((which-sb (if (eql axis :vertical) gfs::+sb-vert+ gfs::+sb-horz+)) + (hwnd (gfs:handle *event-tester-window*))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos gfs::pagesize + gfs::minpos gfs::maxpos gfs::trackpos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-all+) + (gfs::get-scroll-info hwnd which-sb info-ptr) + (case detail + (:start (setf gfs::pos gfs::minpos)) + (:end (setf gfs::pos gfs::maxpos)) + (:step-back (setf gfs::pos (- gfs::pos 5))) + (:step-forward (setf gfs::pos (+ gfs::pos 5))) + (:page-back (setf gfs::pos (- gfs::pos gfs::pagesize))) + (:page-forward (setf gfs::pos (+ gfs::pos gfs::pagesize))) + (:thumb-track (setf gfs::pos gfs::trackpos))) + (gfs::set-scroll-info hwnd which-sb info-ptr 1))))) + (defun text-for-modifiers () (format nil "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" @@ -137,6 +176,15 @@ (gfw:obtain-event-time) (text-for-modifiers))) +(defun text-for-scroll (axis detail) + (format nil + "~a scroll: ~s detail: ~s time: 0x~x ~s" + (incf *event-counter*) + axis + detail + (gfw:obtain-event-time) + (text-for-modifiers))) + (defmethod gfw:event-activate ((d event-tester-window-events) window) (setf *event-tester-text* (text-for-activation "window activated")) (gfw:redraw window)) @@ -174,13 +222,16 @@ (defmethod gfw:event-move ((d event-tester-window-events) window pnt) (setf *event-tester-text* (text-for-move pnt)) - (gfw:redraw window) - 0) + (gfw:redraw window)) (defmethod gfw:event-resize ((d event-tester-window-events) window size type) (setf *event-tester-text* (text-for-size type size)) - (gfw:redraw window) - 0) + (gfw:redraw window)) + +(defmethod gfw:event-scroll ((d event-tester-window-events) window axis detail) + (update-scrollbars axis detail) + (setf *event-tester-text* (text-for-scroll axis detail)) + (gfw:redraw window)) (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ()) @@ -240,7 +291,8 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) + (initialize-scrollbars) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 12 01:35:09 2006 @@ -834,6 +834,11 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000) +(defconstant +sb-horz+ 0) +(defconstant +sb-vert+ 1) +(defconstant +sb-ctl+ 2) +(defconstant +sb-both+ 3) + (defconstant +sb-lineup+ 0) (defconstant +sb-lineleft+ 0) (defconstant +sb-linedown+ 1) @@ -850,6 +855,13 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8) +(defconstant +sif-range+ #x0001) +(defconstant +sif-page+ #x0002) +(defconstant +sif-pos+ #x0004) +(defconstant +sif-disablenoscroll+ #x0008) +(defconstant +sif-trackpos+ #x0010) +(defconstant +sif-all+ #x0017) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2) 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 12 01:35:09 2006 @@ -329,6 +329,15 @@ (rgbred BYTE) (rgbreserved BYTE)) +(defcstruct scrollinfo + (cbsize UINT) + (fmask UINT) + (minpos INT) + (maxpos INT) + (pagesize UINT) + (pos INT) + (trackpos INT)) + (defcstruct size (cx LONG) (cy LONG)) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Sep 12 01:35:09 2006 @@ -436,6 +436,13 @@ (hwnd HANDLE)) (defcfun + ("GetScrollInfo" get-scroll-info) + BOOL + (hwnd HANDLE) + (bar INT) + (info LPTR)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -667,6 +674,14 @@ (item-info LPTR)) (defcfun + ("SetScrollInfo" set-scroll-info) + INT + (hwnd HANDLE) + (bar INT) + (info LPTR) + (redraw BOOL)) + +(defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 12 01:35:09 2006 @@ -143,9 +143,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val)) -(defun dispatch-scroll-notification (widget axis wparam-hi) +(defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget))) - (case wparam-hi + (case wparam-lo (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) ; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) @@ -351,14 +351,14 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + (dispatch-scroll-notification widget :horizontal (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + (dispatch-scroll-notification widget :vertical (lo-word wparam)))) 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Sep 12 01:35:09 2006 @@ -56,13 +56,16 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+)) - (mapc #'(lambda (sym) - (cond + (loop for sym in (style-of self) + do (ecase sym ;; styles that can be combined ;; - ((eq sym :border) - (setf std-flags (logior std-flags gfs::+ws-border+))))) - (style-of self)) + (:border + (setf std-flags (logior std-flags gfs::+ws-border+))) + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags gfs::+ws-ex-controlparent+))) (defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 12 01:35:09 2006 @@ -68,47 +68,28 @@ ;;; methods ;;; -(defmethod compute-style-flags ((win top-level) &rest extra-data) +(defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; -#| - ((eq sym :hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) -|# - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :borderless) + (loop for sym in (style-of self) + do (ecase sym + ;; pre-packaged combinations of window styles + ;; + (:borderless (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :palette) + (:palette (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :miniframe) + (:miniframe (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -117,22 +98,40 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((or (eq sym :workspace) (eq sym :frame)) + (:frame + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)) + (:workspace (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (style-of win)) + (setf ex-flags 0)) + + ;; styles that can be combined + ;; +#| + (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) + (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags))) -(defmethod gfs:dispose ((win top-level)) - (let ((m (menu-bar win))) +(defmethod gfs:dispose ((self top-level)) + (let ((m (menu-bar self))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) (delete-widget (thread-context) (gfs:handle m)))) (call-next-method)) -(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) +(defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -140,21 +139,21 @@ (setf text *default-window-title*)) (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace (style-of win)) + (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func owner text))) + (init-window self classname register-func owner text))) (defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self)) (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size)))) -(defmethod menu-bar :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod menu-bar :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfs:handle win)))) +(defmethod menu-bar ((self top-level)) + (let ((hmenu (gfs::get-menu (gfs:handle self)))) (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) @@ -162,13 +161,13 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m))) -(defmethod (setf menu-bar) :before ((m menu) (win top-level)) +(defmethod (setf menu-bar) :before ((m menu) (self top-level)) (declare (ignore m)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error))) -(defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfs:handle win)) +(defmethod (setf menu-bar) ((m menu) (self top-level)) + (let* ((hwnd (gfs:handle self)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) (unless (gfs:null-handle-p hmenu)

1 0