[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