[graphic-forms-cvs] r75 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 27 06:21:14 UTC 2006
Author: junrue
Date: Mon Mar 27 01:21:13 2006
New Revision: 75
Modified:
trunk/docs/manual/api.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/drawing-tester.lisp
trunk/src/uitoolkit/graphics/graphics-context.lisp
trunk/src/uitoolkit/graphics/graphics-generics.lisp
trunk/src/uitoolkit/system/gdi32.lisp
Log:
implemented ellipse drawing functions; refactored shape drawing code
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon Mar 27 01:21:13 2006
@@ -829,6 +829,12 @@
same, a complete ellipse is drawn. See also @ref{draw-arc}.
@end deffn
+ at deffn GenericFunction draw-ellipse self rect
+Draws the outline of an ellipse whose center is the center of
+ at code{rect}. The shape is drawn using the current pen style, pen
+width, and foreground color.
+ at end deffn
+
@anchor{draw-filled-chord}
@deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt
Draws a closed shape comprised of:
@@ -849,6 +855,13 @@
is drawn.
@end deffn
+ at deffn GenericFunction draw-filled-ellipse self rect
+Fills the interior of an ellipse whose center is the center of
+ at code{rect}. The shape is drawn using the current pen style, pen
+width, and foreground color, and filled with the current background
+color.
+ at end deffn
+
@deffn GenericFunction draw-filled-rectangle self rect
Fills the interior of a rectangle in the current background color.
The current foreground color, pen width, and pen style will be used to
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Mon Mar 27 01:21:13 2006
@@ -133,16 +133,16 @@
#:descent
#:draw-arc
#:draw-chord
+ #:draw-ellipse
#:draw-filled-arc
#:draw-filled-chord
- #:draw-filled-oval
+ #:draw-filled-ellipse
#:draw-filled-polygon
#:draw-filled-rectangle
#:draw-filled-rounded-rectangle
#:draw-focus
#:draw-image
#:draw-line
- #:draw-oval
#:draw-point
#:draw-polygon
#:draw-polyline
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Mon Mar 27 01:21:13 2006
@@ -76,6 +76,54 @@
(unless (null func)
(funcall func gc))))
+(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn)
+ (let ((pnt (gfs:make-point :x 15 :y 15))
+ (size (gfs:make-size :width 80 :height 65)))
+
+ (setf (gfg:foreground-color gc) gfg:*color-blue*)
+ (setf (gfg:background-color gc) gfg:*color-green*)
+ (setf (gfg:pen-width gc) 5)
+ (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))
+ (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:pen-width gc) 3)
+ (setf (gfg:pen-style gc) '(:solid))
+ (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:pen-width gc) 1)
+ (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:foreground-color gc) (gfg:background-color gc))
+ (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+
+ (setf (gfs:point-x pnt) 15)
+ (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10))
+ (setf (gfg:foreground-color gc) gfg:*color-blue*)
+ (setf (gfg:pen-width gc) 5)
+ (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap))
+ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:pen-width gc) 3)
+ (setf (gfg:pen-style gc) '(:dot))
+ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+
+ (setf (gfg:pen-width gc) 1)
+ (setf (gfg:pen-style gc) '(:solid))
+ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))
+ (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
+ (setf (gfg:foreground-color gc) (gfg:background-color gc))
+ (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size))))
+
+(defun draw-ellipses (gc)
+ (draw-simple-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse))
+
+(defun select-ellipses (disp item time rect)
+ (declare (ignore disp time rect))
+ (update-drawing-item-check item)
+ (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses)
+ (gfw:redraw *drawing-win*))
+
(defun draw-arcs (gc)
(let ((rect-pnt (gfs:make-point :x 15 :y 10))
(rect-size (gfs:make-size :width 80 :height 65))
@@ -162,42 +210,7 @@
(gfw:redraw *drawing-win*))
(defun draw-rects (gc)
- (let ((pnt (gfs:make-point :x 15 :y 15))
- (size (gfs:make-size :width 80 :height 65)))
-
- (setf (gfg:foreground-color gc) gfg:*color-blue*)
- (setf (gfg:background-color gc) gfg:*color-green*)
- (setf (gfg:pen-width gc) 5)
- (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))
- (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:pen-width gc) 3)
- (setf (gfg:pen-style gc) '(:solid))
- (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:pen-width gc) 1)
- (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:foreground-color gc) (gfg:background-color gc))
- (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
-
- (setf (gfs:point-x pnt) 15)
- (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10))
- (setf (gfg:foreground-color gc) gfg:*color-blue*)
- (setf (gfg:pen-width gc) 5)
- (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap))
- (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:pen-width gc) 3)
- (setf (gfg:pen-style gc) '(:dot))
- (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:pen-width gc) 1)
- (setf (gfg:pen-style gc) '(:solid))
- (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))
- (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10))
- (setf (gfg:foreground-color gc) (gfg:background-color gc))
- (gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))))
+ (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle))
(defun select-rects (disp item time rect)
(declare (ignore disp time rect))
@@ -212,6 +225,7 @@
(:item "&Tests"
:callback #'find-checked-item
:submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs)
+ (:item "&Ellipses" :callback #'select-ellipses)
(:item "&Rectangles" :callback #'select-rects)))))))
(setf *drawing-dispatcher* (make-instance 'drawing-win-events))
(setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Mon Mar 27 01:21:13 2006
@@ -96,6 +96,45 @@
(unless (gfs:null-handle-p old-hpen)
(gfs::delete-object old-hpen)))))))
+(defun call-rect-function (fn name hdc rect)
+ (let ((pnt (gfs:location rect))
+ (size (gfs:size rect)))
+ (if (zerop (funcall fn
+ hdc
+ (gfs:point-x pnt)
+ (gfs:point-y pnt)
+ (+ (gfs:point-x pnt) (gfs:size-width size))
+ (+ (gfs:point-y pnt) (gfs:size-height size))))
+ (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))
+
+(defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt)
+ (let ((rect-pnt (gfs:location rect))
+ (rect-size (gfs:size rect)))
+ (if (zerop (funcall fn
+ hdc
+ (gfs:point-x rect-pnt)
+ (gfs:point-y rect-pnt)
+ (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size))
+ (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size))
+ (gfs:point-x start-pnt)
+ (gfs:point-y start-pnt)
+ (gfs:point-x end-pnt)
+ (gfs:point-y end-pnt)))
+ (error 'gfs:win32-error :detail (format nil "~a failed" name)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro with-null-brush ((gc) &body body)
+ (let ((hdc (gensym))
+ (tmp-hbr (gensym))
+ (orig-hbr (gensym)))
+ `(let* ((,hdc (gfs:handle ,gc))
+ (,tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
+ (,orig-hbr (gfs::select-object ,hdc ,tmp-hbr)))
+ (unwind-protect
+ (progn
+ , at body)
+ (gfs::select-object ,hdc ,orig-hbr))))))
+
;;;
;;; methods
;;;
@@ -128,66 +167,40 @@
(defmethod draw-arc ((self graphics-context) rect start-pnt end-pnt)
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((rect-pnt (gfs:location rect))
- (rect-size (gfs:size rect)))
- (if (zerop (gfs::arc (gfs:handle self)
- (gfs:point-x rect-pnt)
- (gfs:point-y rect-pnt)
- (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size))
- (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size))
- (gfs:point-x start-pnt)
- (gfs:point-y start-pnt)
- (gfs:point-x end-pnt)
- (gfs:point-y end-pnt)))
- (error 'gfs:win32-error :detail "arc failed"))))
+ (call-rect-and-range-function #'gfs::arc "arc" (gfs:handle self) rect start-pnt end-pnt))
(defmethod draw-chord ((self graphics-context) rect start-pnt end-pnt)
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let* ((hdc (gfs:handle self))
- (tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
- (orig-hbr (gfs::select-object hdc tmp-hbr)))
- (unwind-protect
- (draw-filled-chord self rect start-pnt end-pnt)
- (gfs::select-object hdc orig-hbr))))
+ (with-null-brush (self)
+ (draw-filled-chord self rect start-pnt end-pnt)))
+
+(defmethod draw-ellipse ((self graphics-context) rect)
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (with-null-brush (self)
+ (draw-filled-ellipse self rect)))
(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt)
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let ((rect-pnt (gfs:location rect))
- (rect-size (gfs:size rect)))
- (if (zerop (gfs::chord (gfs:handle self)
- (gfs:point-x rect-pnt)
- (gfs:point-y rect-pnt)
- (+ (gfs:point-x rect-pnt) (gfs:size-width rect-size))
- (+ (gfs:point-y rect-pnt) (gfs:size-height rect-size))
- (gfs:point-x start-pnt)
- (gfs:point-y start-pnt)
- (gfs:point-x end-pnt)
- (gfs:point-y end-pnt)))
- (error 'gfs:win32-error :detail "arc failed"))))
+ (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle self) rect start-pnt end-pnt))
+
+(defmethod draw-filled-ellipse ((self graphics-context) rect)
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error))
+ (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))
(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::rectangle hdc
- (gfs:point-x pnt)
- (gfs:point-y pnt)
- (+ (gfs:point-x pnt) (gfs:size-width size))
- (+ (gfs:point-y pnt) (gfs:size-height size)))))
+ (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))
(defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
- (let* ((hdc (gfs:handle self))
- (tmp-hbr (gfs::get-stock-object gfs::+null-brush+))
- (orig-hbr (gfs::select-object hdc tmp-hbr)))
- (unwind-protect
- (draw-filled-rectangle self rect)
- (gfs::select-object hdc orig-hbr))))
+ (with-null-brush (self)
+ (draw-filled-rectangle self rect)))
;;; FIXME: consider preserving this version as a "fast path"
;;; rectangle filler.
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Mon Mar 27 01:21:13 2006
@@ -66,11 +66,14 @@
(defgeneric draw-chord (self rect start-pnt end-pnt)
(:documentation "Draws a region bounded by the intersection of an ellipse and a line segment."))
+(defgeneric draw-ellipse (self rect)
+ (:documentation "Draws an ellipse defined by a rectangle."))
+
(defgeneric draw-filled-chord (self rect start-pnt end-pnt)
(:documentation "Fills a region bounded by the intersection of an ellipse and a line segment."))
-(defgeneric draw-filled-oval (self rect)
- (:documentation "Fills the interior of the oval defined by a rectangle in the current background color."))
+(defgeneric draw-filled-ellipse (self rect)
+ (:documentation "Fills the interior of the ellipse defined by a rectangle."))
(defgeneric draw-filled-polygon (self points)
(:documentation "Fills the interior of the closed polygon defined by points in the current background color."))
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 01:21:13 2006
@@ -152,6 +152,15 @@
(params LPTR))
(defcfun
+ ("Ellipse" ellipse)
+ BOOL
+ (hdc HANDLE)
+ (leftrect INT)
+ (toprect INT)
+ (rightrect INT)
+ (bottomrect INT))
+
+(defcfun
("ExtCreatePen" ext-create-pen)
HANDLE
(style DWORD)
More information about the Graphic-forms-cvs
mailing list