[graphic-forms-cvs] r182 - in trunk: docs/manual src src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Jul 7 17:53:02 UTC 2006
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
+ at anchor{with-graphics-context}
+ at 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
+ at ref{image}. If @code{thing} is not specified, then the macro creates
+a graphics-context compatible with the @ref{display}.
+ at 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
+ , at 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 ()
More information about the Graphic-forms-cvs
mailing list