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)