[graphic-forms-cvs] r430 - in trunk: docs/manual src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Jan 31 14:17:45 UTC 2007
Author: junrue
Date: Wed Jan 31 09:17:41 2007
New Revision: 430
Modified:
trunk/docs/manual/gfg-symbols.xml
trunk/docs/manual/gfw-symbols.xml
trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/tests/uitoolkit/hello-world.lisp
trunk/src/tests/uitoolkit/layout-tester.lisp
trunk/src/tests/uitoolkit/scroll-grid-panel.lisp
trunk/src/tests/uitoolkit/scroll-text-panel.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/graphics/graphics-generics.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/top-level.lisp
Log:
Modified: trunk/docs/manual/gfg-symbols.xml
==============================================================================
--- trunk/docs/manual/gfg-symbols.xml (original)
+++ trunk/docs/manual/gfg-symbols.xml Wed Jan 31 09:17:41 2007
@@ -794,6 +794,33 @@
<!-- GENERIC FUNCTIONS -->
+ <generic-function name="clear">
+ <syntax>
+ <arguments>
+ <argument name="graphics-context">
+ <description>
+ A <reftopic>gfg:graphics-context</reftopic> on which to draw.
+ </description>
+ </argument>
+ <argument name="color">
+ <description>
+ The <reftopic>gfg:color</reftopic> with which to fill the
+ window associated with <arg0/>.
+ </description>
+ </argument>
+ </arguments>
+ <return>
+ <emphasis>undefined</emphasis>
+ </return>
+ </syntax>
+ <description>
+ Fills the window associated with <arg0/> using <arg1/>.
+ </description>
+ <seealso>
+ <reftopic>colors</reftopic>
+ </seealso>
+ </generic-function>
+
<generic-function name="draw-arc">
<syntax>
<arguments>
Modified: trunk/docs/manual/gfw-symbols.xml
==============================================================================
--- trunk/docs/manual/gfw-symbols.xml (original)
+++ trunk/docs/manual/gfw-symbols.xml Wed Jan 31 09:17:41 2007
@@ -843,7 +843,7 @@
used.
</para>
<para role="normal">
- Like other system dialogs in Graphic-Forms, file-dialog is derived from
+ Like other system dialogs in Graphic-Forms, color-dialog is derived from
<reftopic>gfw:widget</reftopic> rather than <reftopic>gfw:dialog</reftopic>
since the majority of its functionality is implemented by the system. A
future release will provide a customization mechanism.
@@ -3867,7 +3867,7 @@
return the same value by default as would <reftopic>gfw:preferred-size</reftopic>.
</para>
<para role="normal">
- If the new minimum size provided via the SET function is larger than the
+ If the new minimum size provided via the SETF function is larger than the
current size, the widget is resized to the new minimum.
</para>
</description>
Modified: trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp
==============================================================================
--- trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp (original)
+++ trunk/src/demos/unblocked/double-buffered-event-dispatcher.lisp Wed Jan 31 09:17:41 2007
@@ -46,10 +46,7 @@
:initform nil)))
(defmethod clear-buffer ((self double-buffered-event-dispatcher) gc)
- (let ((image (image-buffer-of self)))
- (setf (gfg:background-color gc) *background-color*)
- (setf (gfg:foreground-color gc) *background-color*)
- (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfg:size image)))))
+ (gfg:clear gc *background-color*))
(defmethod dispose ((self double-buffered-event-dispatcher))
(let ((image (image-buffer-of self)))
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Wed Jan 31 09:17:41 2007
@@ -200,6 +200,7 @@
#:background-pattern
#:blue-mask
#:blue-shift
+ #:clear
#:clipped-p
#:clipping-rectangle
#:color->rgb
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Wed Jan 31 09:17:41 2007
@@ -66,10 +66,8 @@
(drawing-exit-fn self nil))
(defmethod gfw:event-paint ((self drawing-win-events) window gc rect)
- (declare (ignore rect))
- (setf (gfg:background-color gc) gfg:*color-white*)
- (setf (gfg:foreground-color gc) gfg:*color-white*)
- (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))
+ (declare (ignore window rect))
+ (gfg:clear gc gfg:*color-white*)
(let ((func (draw-func-of self)))
(unless (null func)
(funcall func gc))))
Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp (original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Jan 31 09:17:41 2007
@@ -48,10 +48,8 @@
(exit-fn disp nil))
(defmethod gfw:event-paint ((disp hellowin-events) window gc rect)
- (declare (ignore rect))
- (setf (gfg:background-color gc) gfg:*color-white*)
- (setf (gfg:foreground-color gc) gfg:*color-white*)
- (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window)))
+ (declare (ignore window rect))
+ (gfg:clear gc gfg:*color-white-smoke*)
(setf (gfg:background-color gc) gfg:*color-red*)
(setf (gfg:foreground-color gc) gfg:*color-green*)
(gfg:draw-text gc "Hello World!" (gfs:make-point)))
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Jan 31 09:17:41 2007
@@ -73,10 +73,8 @@
:initform 0)))
(defmethod gfw:event-paint ((self layout-tester-widget-events) window gc rect)
- (declare (ignore rect))
- (setf (gfg:background-color gc) gfg:*color-white*)
- (setf (gfg:foreground-color gc) gfg:*color-white*)
- (gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
+ (declare (ignore window rect))
+ (gfg:clear gc gfg:*color-white*))
(defclass test-panel (gfw:panel) ())
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 Wed Jan 31 09:17:41 2007
@@ -77,10 +77,7 @@
(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:clear gc gfg:*color-button-face*)
(setf (gfg:foreground-color gc) gfg:*color-black*
(gfg:pen-style gc) '(:solid :flat-endcap))
(let* ((pnt (gfs:location rect))
Modified: trunk/src/tests/uitoolkit/scroll-text-panel.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/scroll-text-panel.lisp (original)
+++ trunk/src/tests/uitoolkit/scroll-text-panel.lisp Wed Jan 31 09:17:41 2007
@@ -107,9 +107,7 @@
(defmethod gfw:event-paint ((disp scroll-text-panel-events) window gc rect)
(declare (ignore window))
- (setf (gfg:background-color gc) gfg:*color-white*
- (gfg:foreground-color gc) gfg:*color-white*)
- (gfg:draw-filled-rectangle gc rect)
+ (gfg:clear gc gfg:*color-white*)
(setf (gfg:foreground-color gc) gfg:*color-black*
(gfg:font gc) (font-of disp))
(let* ((metrics (gfg:metrics gc (font-of disp)))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Wed Jan 31 09:17:41 2007
@@ -219,6 +219,28 @@
(gfs::set-dc-brush-color hdc rgb)
(gfs::set-bk-color hdc rgb)))
+(defmethod clear ((self graphics-context) (color color))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (setf (background-color self) color
+ (foreground-color self) color)
+ (let* ((hdc (gfs:handle self))
+ (hwnd (gfs::window-from-dc hdc)))
+ (if (gfs:null-handle-p hwnd)
+ (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC")
+ (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
+ (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom)
+ wi-ptr gfs::windowinfo)
+ (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
+ (if (zerop (gfs::get-window-info hwnd wi-ptr))
+ (warn 'gfs:win32-warning :detail "get-window-info failed")
+ (gfs::with-rect (rect-ptr)
+ (setf gfs::top 0
+ gfs::left 0
+ gfs::bottom gfs::clientbottom
+ gfs::right gfs::clientright)
+ (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer)))))))))
+
(defmethod gfs:dispose ((self graphics-context))
(gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+))
(gfs::delete-object (pen-handle-of self))
@@ -282,31 +304,6 @@
(error 'gfs:disposed-error))
(call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))
-;;; FIXME: consider preserving this version as a "fast path"
-;;; rectangle filler.
-;;;
-#|
-(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
- (if (gfs:disposed-p self)
- (error 'gfs:disposed-error))
- (let ((hdc (gfs:handle self))
- (pnt (gfs:location rect))
- (size (gfs:size rect)))
- (gfs::with-rect (rect-ptr)
- (setf gfs::top (gfs:point-y pnt)
- gfs::left (gfs:point-x pnt)
- gfs::bottom (+ (gfs:point-y pnt) (gfs:size-height size))
- gfs::right (+ (gfs:point-x pnt) (gfs:size-width size)))
- (gfs::ext-text-out hdc
- (gfs:point-x pnt)
- (gfs:point-y pnt)
- gfs::+eto-opaque+
- rect-ptr
- ""
- 0
- (cffi:null-pointer)))))
-|#
-
(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size)
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Wed Jan 31 09:17:41 2007
@@ -39,6 +39,9 @@
(defgeneric (setf background-color) (color self)
(:documentation "Sets the current background color."))
+(defgeneric clear (self color)
+ (:documentation "Fills self with the specified color."))
+
(defgeneric data-object (self &optional gc)
(:documentation "Returns the data structure representing the raw form of self."))
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Wed Jan 31 09:17:41 2007
@@ -838,6 +838,11 @@
(rct LPTR))
(defcfun
+ ("WindowFromDC" window-from-dc)
+ HANDLE
+ (hdc HANDLE))
+
+(defcfun
("WindowFromPoint" window-from-point)
HANDLE
(pnt :pointer))
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Wed Jan 31 09:17:41 2007
@@ -187,7 +187,7 @@
(gfs::send-message (gfs:handle sbar)
gfs::+wm-size+
(event-wparam event)
- (event-lparam event))))
+ (logand (event-lparam event) #xFFFFFFFF))))
(call-next-method))
(defmethod initialize-instance :after ((self dialog) &key owner text &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 Wed Jan 31 09:17:41 2007
@@ -152,7 +152,7 @@
(gfs::send-message (gfs:handle sbar)
gfs::+wm-size+
(event-wparam event)
- (event-lparam event))))
+ (logand (event-lparam event) #xFFFFFFFF))))
(call-next-method))
(defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys)
More information about the Graphic-forms-cvs
mailing list