Author: junrue Date: Fri Jul 7 13:52:59 2006 New Revision: 182 Modified: trunk/docs/manual/api.texinfo trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: created with-graphics-context macro to simplify common usage Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri Jul 7 13:52:59 2006 @@ -1356,6 +1356,14 @@ keyword. @xref{font-dialog}. @end deffn +@anchor{with-graphics-context} +@deffn Macro with-graphics-context (gc &optional thing) &body body +This macro manages a @ref{graphics-context} representing the underlying +device context of @code{thing}, which can be a @ref{widget} or an +@ref{image}. If @code{thing} is not specified, then the macro creates +a graphics-context compatible with the @ref{display}. +@end deffn + @node layout functions @section layout functions Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Fri Jul 7 13:52:59 2006 @@ -49,6 +49,13 @@ (setf *textedit-win* nil) (gfw:shutdown 0)) +(defun textedit-font (disp item time rect) + (declare (ignore disp item time rect)) + (gfw:with-graphics-context (gc *textedit-control*) + (gfw:with-font-dialog (*textedit-win* '(:no-effects) font color :gc gc :initial-font (gfg:font *textedit-control*)) + (if font + (setf (gfg:font *textedit-control*) font))))) + (defclass textedit-win-events (gfw:event-dispatcher) ()) (defmethod gfw:event-close ((disp textedit-win-events) window time) @@ -151,7 +158,7 @@ (:item "" :separator) (:item "Select &All"))) (:item "F&ormat" - :submenu ((:item "&Font..."))) + :submenu ((:item "&Font..." :callback #'textedit-font))) (:item "&Help" :submenu ((:item "&About TextEdit" :callback #'about-textedit))))))) (setf *textedit-win* (make-instance 'gfw:top-level :dispatcher (make-instance 'textedit-win-events) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Fri Jul 7 13:52:59 2006 @@ -64,13 +64,11 @@ :initform nil))) (defun draw-tiles-directly (panel shape-pnts kind) - (let ((gc (make-instance 'gfg:graphics-context :widget panel)) - (image-table (tile-image-table-of (gfw:dispatcher panel)))) - (unwind-protect - (loop for pnt in shape-pnts - do (let ((image (gethash kind image-table))) - (gfg:draw-image gc image (tiles->window pnt)))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc panel) + (let ((image-table (tile-image-table-of (gfw:dispatcher panel)))) + (loop for pnt in shape-pnts + do (let ((image (gethash kind image-table))) + (gfg:draw-image gc image (tiles->window pnt))))))) (defmethod dispose ((self tiles-panel-events)) (let ((table (tile-image-table-of self))) @@ -129,16 +127,13 @@ (setf (shape-pnts-of self) nil)) (defmethod update-buffer ((self tiles-panel-events)) - (let ((gc (make-instance 'gfg:graphics-context :image (image-buffer-of self))) - (image-table (tile-image-table-of self))) - (unwind-protect - (progn - (clear-buffer self gc) - (map-tiles #'(lambda (pnt kind) - (unless (= kind 0) - (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) - (game-tiles))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc (image-buffer-of self)) + (let ((image-table (tile-image-table-of self))) + (clear-buffer self gc) + (map-tiles #'(lambda (pnt kind) + (unless (= kind 0) + (gfg:draw-image gc (gethash kind image-table) (tiles->window pnt)))) + (game-tiles))))) (defclass tiles-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Fri Jul 7 13:52:59 2006 @@ -500,6 +500,7 @@ #:visible-p #:with-file-dialog #:with-font-dialog + #:with-graphics-context ;; conditions )) Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri Jul 7 13:52:59 2006 @@ -120,14 +120,12 @@ (defun choose-font-dlg (disp item time rect) (declare (ignore disp item time rect)) - (let ((gc (make-instance 'gfg:graphics-context :widget *main-win*))) - (unwind-protect - (gfw:with-font-dialog (*main-win* nil font color :gc gc) - (if color - (print color)) - (if font - (print (gfg:data-object font gc)))) - (gfs:dispose gc)))) + (gfw:with-graphics-context (gc *main-win*) + (gfw:with-font-dialog (*main-win* nil font color :gc gc) + (if color + (print color)) + (if font + (print (gfg:data-object font gc)))))) (defclass dialog-events (gfw:event-dispatcher) ()) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Fri Jul 7 13:52:59 2006 @@ -131,18 +131,15 @@ (let* ((color (gfg:background-color label)) (size (gfg:size image)) (bounds (gfs:make-rectangle :size size)) - (tmp-image (make-instance 'gfg:image :size size)) - (gc (make-instance 'gfg:graphics-context :image tmp-image))) - (unwind-protect - (progn - (setf (gfg:background-color gc) color) - (let ((orig-color (gfg:foreground-color gc))) - (setf (gfg:foreground-color gc) color) - (gfg:draw-filled-rectangle gc bounds) - (setf (gfg:foreground-color gc) orig-color)) - (gfg:draw-image gc image (gfs:location bounds)) - (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) - (gfs:dispose gc)) + (tmp-image (make-instance 'gfg:image :size size))) + (with-graphics-context (gc tmp-image) + (setf (gfg:background-color gc) color) + (let ((orig-color (gfg:foreground-color gc))) + (setf (gfg:foreground-color gc) color) + (gfg:draw-filled-rectangle gc bounds) + (setf (gfg:foreground-color gc) orig-color)) + (gfg:draw-image gc image (gfs:location bounds)) + (setf (pixel-point-of label) (gfs:copy-point tr-pnt))) (setf image tmp-image))) (if (/= orig-flags flags) (gfs::set-window-long hwnd gfs::+gwl-style+ flags)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Jul 7 13:52:59 2006 @@ -35,6 +35,22 @@ (defvar *check-box-size* nil) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro with-graphics-context ((gc &optional thing) &body body) + `(let ((,gc (cond + ((null ,thing) + (make-instance 'gfg:graphics-context)) ; DC compatible with display + ((typep ,thing 'gfw:widget) + (make-instance 'gfg:graphics-context :widget ,thing)) + ((typep ,thing 'gfg:image) + (make-instance 'gfg:graphics-context :image ,thing)) + (t + (error 'gfs:toolkit-error + :detail (format nil "~a is an unsupported type" ,thing)))))) + (unwind-protect + (progn + ,@body) + (gfs:dispose ,gc))))) (defun translate-and-dispatch (msg-ptr) (gfs::translate-message msg-ptr) @@ -187,17 +203,15 @@ (let ((size (gfw:size widget)) (b-width (border-width widget)) (font (gfg:font widget)) - (gc (make-instance 'gfg:graphics-context :widget widget)) (baseline 0)) - (unwind-protect - (let ((metrics (gfg:metrics gc font))) - (setf baseline (+ b-width - top-margin - (gfg:ascent metrics) - (floor (- (gfs:size-height size) - (+ (gfg:ascent metrics) (gfg:descent metrics))) - 2)))) - (gfs:dispose gc)) + (with-graphics-context (gc widget) + (let ((metrics (gfg:metrics gc font))) + (setf baseline (+ b-width + top-margin + (gfg:ascent metrics) + (floor (- (gfs:size-height size) + (+ (gfg:ascent metrics) (gfg:descent metrics))) + 2))))) baseline)) (defun check-box-size ()