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

+@deffn GenericFunction draw-ellipse self rect +Draws the outline of an ellipse whose center is the center of +@code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color. +@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

+@deffn GenericFunction draw-filled-ellipse self rect +Fills the interior of an ellipse whose center is the center of +@code{rect}. The shape is drawn using the current pen style, pen +width, and foreground color, and filled with the current background +color. +@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 + ,@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)