Author: junrue Date: Mon Mar 27 18:29:40 2006 New Revision: 76

Modified: trunk/docs/manual/api.texinfo 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: implement line, polyline, and polygon drawing functions

Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Mon Mar 27 18:29:40 2006 @@ -862,14 +862,45 @@ color. @end deffn

+@deffn GenericFunction draw-filled-polygon self points +Fills the interior of a closed shape comprised by the line segments +defined by @code{points} in the current background color. The current +foreground color, pen width, and pen style will be used to draw the +line segments. If @code{points} contains less than three points, then +this function does nothing. +@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 draw an outline for the rectangle. @end deffn

-@deffn GenericFunction draw-image self im pnt -Draws the given image in the receiver at the specified coordinates. +@deffn GenericFunction draw-image self image point +Draws @code{image} in the receiver at the specified @ref{point}. +@end deffn + +@deffn GenericFunction draw-line self start-point end-point +Draws a line from @code{start-point} to @code{end-point} using the +current pen style, pen width, and foreground color. +@end deffn + +@anchor{draw-polygon} +@deffn GenericFunction draw-polygon self points +Draws a series of connected line segments determined by the list of +@code{points} using the current pen style, pen width, and foreground +color. The last point in the list is connected with the first. If +@code{points} contains less than three points, then this function does +nothing. See also @ref{draw-polyline}. +@end deffn + +@anchor{draw-polyline} +@deffn GenericFunction draw-polyline self points +Draws a series of connected line segments determined by the list of +@code{points} using the current pen style, pen width, and foreground +color. The last point in the list is not connected with the first. If +@code{points} contains less than two points, then this function does +nothing. See also @ref{draw-polygon}. @end deffn

@deffn GenericFunction draw-rectangle self rect

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 18:29:40 2006 @@ -76,7 +76,53 @@ (unless (null func) (funcall func gc))))

-(defun draw-simple-rectangular-tests (gc filled-draw-fn unfilled-draw-fn) +(defun draw-line-test (gc start-pnt end-pnt pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (gfg:draw-line gc start-pnt end-pnt) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 90) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 90) + :y (gfs:point-y end-pnt))) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 180) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 180) + :y (gfs:point-y end-pnt))) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (gfg:draw-line gc + (gfs:make-point :x (+ (gfs:point-x start-pnt) 270) + :y (gfs:point-y start-pnt)) + (gfs:make-point :x (+ (gfs:point-x end-pnt) 270) + :y (gfs:point-y end-pnt)))) + +(defun draw-lines-test (gc draw-fn points pen-styles) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) (first pen-styles)) + (funcall draw-fn gc points) + (setf (gfg:pen-width gc) 3) + (setf (gfg:pen-style gc) (second pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 90) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) (third pen-styles)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 180) + :y (gfs:point-y pnt))) + points)) + (setf (gfg:foreground-color gc) (gfg:background-color gc)) + (funcall draw-fn gc (mapcar #'(lambda (pnt) (gfs:make-point :x (+ (gfs:point-x pnt) 270) + :y (gfs:point-y pnt))) + points))) + +(defun draw-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)))

@@ -107,7 +153,6 @@ (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)) @@ -116,7 +161,7 @@ (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)) + (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse))

(defun select-ellipses (disp item time rect) (declare (ignore disp time rect)) @@ -209,8 +254,38 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs) (gfw:redraw *drawing-win*))

+(defun draw-lines (gc) + (let ((orig-points (list (gfs:make-point :x 15 :y 60) + (gfs:make-point :x 75 :y 30) + (gfs:make-point :x 40 :y 10)))) + (setf (gfg:background-color gc) gfg:*color-green*) + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (draw-lines-test gc #'gfg:draw-filled-polygon orig-points '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-lines-test gc + #'gfg:draw-polygon + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 60))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (draw-lines-test gc + #'gfg:draw-polyline + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 120))) + orig-points) + '((:dot :round-join :flat-endcap) (:dot) (:solid))) + (let ((tmp (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) 180))) + orig-points))) + (draw-line-test gc (first tmp) (second tmp) '((:dot :round-join :flat-endcap) (:dot) (:solid)))))) + +(defun select-lines (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-lines) + (gfw:redraw *drawing-win*)) + (defun draw-rects (gc) - (draw-simple-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle))

(defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -226,6 +301,7 @@ :callback #'find-checked-item :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs) (:item "&Ellipses" :callback #'select-ellipses) + (:item "&Lines and Polylines" :callback #'select-lines) (: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 18:29:40 2006 @@ -55,11 +55,11 @@ (return-from compute-pen-style (logior gfs::+ps-cosmetic+ gfs::+ps-null+))) (setf tmp (intersection style (mapcar #'first main-styles))) (if (/= (length tmp) 1) - (error 'gfs:toolkit-error :detail "one main pen style keyword is required")) + (error 'gfs:toolkit-error :detail "main pen style keyword [:alternate | :dash | :dashdotdot | :dot | :solid] is required")) (setf native-style (logior native-style (cdr (assoc (car tmp) main-styles)))) (setf tmp (intersection style (mapcar #'first endcap-styles))) (if (> (length tmp) 1) - (error 'gfs:toolkit-error :detail "only one end cap pen style keyword is allowed")) + (error 'gfs:toolkit-error :detail "only one end cap pen style keyword [:flat-endcap | :round-endcap | :square-endcap] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) endcap-styles)) 0))) (unless (null tmp) @@ -67,7 +67,7 @@ gfs::+ps-geometric+))) (setf tmp (intersection style (mapcar #'first join-styles))) (if (> (length tmp) 1) - (error 'gfs:toolkit-error :detail "only one join pen style keyword is allowed")) + (error 'gfs:toolkit-error :detail "only one join pen style keyword [:bevel-join | :miter-join | :round-join] is allowed")) (setf native-style (logior native-style (if tmp (cdr (assoc (car tmp) join-styles)) 0))) (unless (null tmp) @@ -122,6 +122,23 @@ (gfs:point-y end-pnt))) (error 'gfs:win32-error :detail (format nil "~a failed" name)))))

+(defun call-points-function (fn name hdc points) + (let* ((count (length points)) + (array (cffi:foreign-alloc 'gfs::point :count count))) + (unwind-protect + (progn + (loop for pnt in points + with i = 0 + do (progn + (cffi:with-foreign-slots ((gfs::x gfs::y) + (cffi:mem-aref array 'gfs::point i) gfs::point) + (setf gfs::x (gfs:point-x pnt)) + (setf gfs::y (gfs:point-y pnt))) + (incf i))) + (if (zerop (funcall fn hdc array count)) + (error 'gfs:win32-error :detail (format nil "~a failed" name)))) + (cffi:foreign-free array)))) + (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro with-null-brush ((gc) &body body) (let ((hdc (gensym)) @@ -173,13 +190,13 @@ (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-chord self rect start-pnt end-pnt))) + (call-rect-and-range-function #'gfs::chord "chord" (gfs:handle 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))) + (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect)))

(defmethod draw-filled-chord ((self graphics-context) rect start-pnt end-pnt) (if (gfs:disposed-p self) @@ -191,16 +208,40 @@ (error 'gfs:disposed-error)) (call-rect-function #'gfs::ellipse "ellipse" (gfs:handle self) rect))

+(defmethod draw-filled-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points))) + (defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))

+(defmethod draw-line ((self graphics-context) start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) (list start-pnt end-pnt))) + +(defmethod draw-polygon ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 3) + (with-null-brush (self) + (call-points-function #'gfs::polygon "polygon" (gfs:handle self) points)))) + +(defmethod draw-polyline ((self graphics-context) points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (< (length points) 2) + (call-points-function #'gfs::polyline "polyline" (gfs:handle self) points))) + (defmethod draw-rectangle ((self graphics-context) (rect gfs:rectangle)) (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (with-null-brush (self) - (draw-filled-rectangle self rect))) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle 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 18:29:40 2006 @@ -76,43 +76,37 @@ (: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.")) + (:documentation "Fills the interior of the closed polygon defined by points."))

(defgeneric draw-filled-rectangle (self rect) (:documentation "Fills the interior of a rectangle in the current background color."))

(defgeneric draw-filled-rounded-rectangle (self rect arc-width arc-height) - (:documentation "Fills the interior of the rectangle with rounded corners in the current background color.")) + (:documentation "Fills the interior of the rectangle with rounded corners."))

(defgeneric draw-filled-wedge (self rect start-pnt end-pnt) - (:documentation "Fills the interior of an elliptical arc within the rectangle in the current background color.")) - -(defgeneric draw-focus (self rect) - (:documentation "Draws a rectangle having the appearance of a focus rectangle.")) + (:documentation "Fills the interior of an elliptical arc within the rectangle."))

(defgeneric draw-image (self im pnt) (:documentation "Draws the given image in the receiver at the specified coordinates."))

-(defgeneric draw-line (self pnt-1 pnt-2) - (:documentation "Draws a line using the foreground color between (x1, y1) and (x2, y2).")) - -(defgeneric draw-oval (self rect) - (:documentation "Draws the outline of an oval in the foreground color with the specified rectangular area.")) +(defgeneric draw-line (self start-pnt end-pnt) + (:documentation "Draws a line using the foreground color between start-pnt and end-pnt."))

(defgeneric draw-point (self pnt) (:documentation "Draws a pixel in the foreground color at the specified point."))

(defgeneric draw-polygon (self points) - (:documentation "Draws the closed polygon defined by the list of points in the current foreground color.")) + (:documentation "Draws the closed polygon defined by the list of points."))

(defgeneric draw-polyline (self points) - (:documentation "Draws the polyline defined by the list of points in the current foreground color.")) + (:documentation "Draws the polyline defined by the list of points."))

(defgeneric draw-rectangle (self rect) (:documentation "Draws the outline of a rectangle in the current foreground color."))

(defgeneric draw-rounded-rectangle (self rect arc-width arc-height) - (:documentation "Draws the outline of the rectangle with rounded corners in the current foreground color.")) + (:documentation "Draws the outline of the rectangle with rounded corners."))

(defgeneric draw-text (self text pnt) (:documentation "Draws the given string in the current font and foreground color, with (x, y) being the top-left coordinate of a bounding box for the string."))

Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Mon Mar 27 18:29:40 2006 @@ -254,6 +254,20 @@ (rop DWORD))

(defcfun + ("Polygon" polygon) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun + ("Polyline" polyline) + BOOL + (hdc HANDLE) + (points LPTR) + (count INT)) + +(defcfun ("Rectangle" rectangle) BOOL (hdc HANDLE)