[graphic-forms-cvs] r76 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Mon Mar 27 23:29:40 UTC 2006
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
+ at 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.
+ 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
draw an outline for the rectangle.
@end deffn
- at deffn GenericFunction draw-image self im pnt
-Draws the given image in the receiver at the specified coordinates.
+ at deffn GenericFunction draw-image self image point
+Draws @code{image} in the receiver at the specified @ref{point}.
+ at end deffn
+
+ at 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.
+ at end deffn
+
+ at anchor{draw-polygon}
+ at deffn GenericFunction draw-polygon self points
+Draws a series of connected line segments determined by the list of
+ at code{points} using the current pen style, pen width, and foreground
+color. The last point in the list is connected with the first. If
+ at code{points} contains less than three points, then this function does
+nothing. See also @ref{draw-polyline}.
+ at end deffn
+
+ at anchor{draw-polyline}
+ at deffn GenericFunction draw-polyline self points
+Draws a series of connected line segments determined by the list of
+ at 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
+ at 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)
More information about the Graphic-forms-cvs
mailing list