[graphic-forms-cvs] r262 - in trunk: . docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Thu Sep 21 20:58:30 UTC 2006
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
+ at anchor{obtain-horizontal-scrollbar}
+ at 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
+ at 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}.
+ at end deffn
+
+ at anchor{obtain-vertical-scrollbar}
+ at 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
+ at 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}.
+ at 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))
More information about the Graphic-forms-cvs
mailing list