[graphic-forms-cvs] r74 - 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 04:52:48 UTC 2006
Author: junrue
Date: Sun Mar 26 23:52:47 2006
New Revision: 74
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
trunk/src/uitoolkit/system/system-constants.lisp
Log:
implemented draw-arc, draw-chord, and draw-filled-chord graphics functions
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sun Mar 26 23:52:47 2006
@@ -797,11 +797,62 @@
Returns the bits-per-pixel depth of the object.
@end deffn
+ at anchor{draw-arc}
+ at deffn GenericFunction draw-arc self rect start-pnt end-pnt
+Draws an arc whose curve is formed by the ellipse bound by
+ at code{rect}, in a counter-clockwise direction from the point
+ at code{start-point} where it intersects a radial originating at the
+center of the bounding rectangle. The arc ends at the point
+ at code{end-pnt} where it intersects another radial also originating at
+the center of the rectangle. The shape is drawn using the current pen
+style, pen width, and foreground color. If @code{start-pnt} and
+ at code{end-pnt} are the same, a complete ellipse is drawn. See also
+ at ref{draw-chord}.
+ at end deffn
+
+ at anchor{draw-chord}
+ at deffn GenericFunction draw-chord self rect start-pnt end-pnt
+Draws a closed shape comprised of:
+ at itemize @bullet
+ at item
+an arc whose curve is formed by the ellipse bound by @code{rect}, in a
+counter-clockwise direction from the point @code{start-point} where it
+intersects a radial originating at the center of the bounding
+rectangle. The arc ends at the point @code{end-pnt} where it
+intersects another radial also originating at the center of the
+rectangle.
+ at item
+a line drawn between start-pnt and end-pnt
+ at end itemize
+The shape is drawn using the current pen style, pen width and
+foreground color. If @code{start-pnt} and @code{end-pnt} are the
+same, a complete ellipse is drawn. See also @ref{draw-arc}.
+ at end deffn
+
+ at anchor{draw-filled-chord}
+ at deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt
+Draws a closed shape comprised of:
+ at itemize @bullet
+ at item
+an arc whose curve is formed by the ellipse bound by @code{rect}, in a
+counter-clockwise direction from the point @code{start-point} where it
+intersects a radial originating at the center of the bounding
+rectangle. The arc ends at the point @code{end-pnt} where it
+intersects another radial also originating at the center of the
+rectangle.
+ at item
+a line drawn between start-pnt and end-pnt
+ at end itemize
+The shape is drawn using the current pen style, pen width and
+foreground color and filled with the current background color. If
+ at code{start-pnt} and @code{end-pnt} are the same, a complete ellipse
+is drawn.
+ 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. See also @ref{background-color},
- at ref{foreground-color}, @ref{pen-style}, and @ref{pen-width}.
+draw an outline for the rectangle.
@end deffn
@deffn GenericFunction draw-image self im pnt
@@ -810,8 +861,7 @@
@deffn GenericFunction draw-rectangle self rect
Draws the outline of a rectangle in the current foreground color,
-using the current pen width and style. See also @ref{background-color},
- at ref{pen-style} and @ref{pen-width}.
+using the current pen width and style.
@end deffn
@deffn GenericFunction draw-text self text pnt
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Mar 26 23:52:47 2006
@@ -132,7 +132,9 @@
#:depth
#:descent
#:draw-arc
+ #:draw-chord
#:draw-filled-arc
+ #:draw-filled-chord
#:draw-filled-oval
#:draw-filled-polygon
#:draw-filled-rectangle
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/drawing-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/drawing-tester.lisp Sun Mar 26 23:52:47 2006
@@ -35,6 +35,20 @@
(defvar *drawing-dispatcher* nil)
(defvar *drawing-win* nil)
+(defvar *last-checked-drawing-item* nil)
+
+(defun update-drawing-item-check (item)
+ (unless (null *last-checked-drawing-item*)
+ (gfw:check *last-checked-drawing-item* nil))
+ (gfw:check item t))
+
+(defun find-checked-item (disp menu time)
+ (declare (ignore disp time))
+ (dotimes (i (gfw:item-count menu))
+ (let ((item (gfw:item-at menu i)))
+ (when (gfw:checked-p item)
+ (setf *last-checked-drawing-item* item)
+ (return)))))
(defun drawing-exit-fn (disp item time rect)
(declare (ignore disp item time rect))
@@ -62,6 +76,91 @@
(unless (null func)
(funcall func gc))))
+(defun draw-arcs (gc)
+ (let ((rect-pnt (gfs:make-point :x 15 :y 10))
+ (rect-size (gfs:make-size :width 80 :height 65))
+ (start-pnt (gfs:make-point :x 15 :y 60))
+ (end-pnt (gfs:make-point :x 75 :y 25))
+ (delta-x 0)
+ (delta-y 0))
+
+ (setf (gfg:background-color gc) gfg:*color-green*)
+ (setf (gfg:foreground-color gc) gfg:*color-blue*)
+ (setf (gfg:pen-width gc) 5)
+ (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))
+ (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (setf delta-x (+ (gfs:size-width rect-size) 10))
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 3)
+ (setf (gfg:pen-style gc) '(:solid))
+ (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 1)
+ (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:foreground-color gc) (gfg:background-color gc))
+ (gfg:draw-filled-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+
+ (setf (gfs:point-x rect-pnt) 15)
+ (setf (gfs:point-x start-pnt) 15)
+ (setf (gfs:point-x end-pnt) 75)
+ (setf delta-y (gfs:size-height rect-size))
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-y pnt) delta-y))
+ (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-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (setf delta-x (+ (gfs:size-width rect-size) 10))
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 3)
+ (setf (gfg:pen-style gc) '(:dot))
+ (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 1)
+ (setf (gfg:pen-style gc) '(:solid))
+ (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:foreground-color gc) (gfg:background-color gc))
+ (gfg:draw-chord gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+
+ (setf (gfs:point-x rect-pnt) 15)
+ (setf (gfs:point-x start-pnt) 15)
+ (setf (gfs:point-x end-pnt) 75)
+ (setf delta-y (gfs:size-height rect-size))
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-y pnt) delta-y))
+ (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-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 3)
+ (setf (gfg:pen-style gc) '(:dot))
+ (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:pen-width gc) 1)
+ (setf (gfg:pen-style gc) '(:solid))
+ (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)
+ (loop for pnt in (list rect-pnt start-pnt end-pnt)
+ do (incf (gfs:point-x pnt) delta-x))
+ (setf (gfg:foreground-color gc) (gfg:background-color gc))
+ (gfg:draw-arc gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt)))
+
+(defun select-arcs (disp item time rect)
+ (declare (ignore disp time rect))
+ (update-drawing-item-check item)
+ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
+ (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)))
@@ -79,7 +178,7 @@
(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:*color-green*)
+ (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)
@@ -101,17 +200,21 @@
(gfg:draw-rectangle gc (make-instance 'gfs:rectangle :location pnt :size size))))
(defun select-rects (disp item time rect)
- (declare (ignore disp item time rect))
+ (declare (ignore disp time rect))
+ (update-drawing-item-check item)
(setf (draw-func-of *drawing-dispatcher*) #'draw-rects)
(gfw:redraw *drawing-win*))
(defun run-drawing-tester-internal ()
+ (setf *last-checked-drawing-item* nil)
(let ((menubar (gfw:defmenu ((:item "&File"
:submenu ((:item "E&xit" :callback #'drawing-exit-fn)))
(:item "&Tests"
- :submenu ((:item "&Rectangles" :checked :callback #'select-rects)))))))
+ :callback #'find-checked-item
+ :submenu ((:item "&Arcs and Chords" :checked :callback #'select-arcs)
+ (:item "&Rectangles" :callback #'select-rects)))))))
(setf *drawing-dispatcher* (make-instance 'drawing-win-events))
- (setf (draw-func-of *drawing-dispatcher*) #'draw-rects)
+ (setf (draw-func-of *drawing-dispatcher*) #'draw-arcs)
(setf *drawing-win* (make-instance 'gfw:top-level :dispatcher *drawing-dispatcher*
:style '(:style-workspace)))
(setf (gfw:menu-bar *drawing-win*) menubar)
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sun Mar 26 23:52:47 2006
@@ -125,6 +125,48 @@
(gfs::delete-dc (gfs:handle self)))
(setf (slot-value self 'gfs:handle) nil))
+(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"))))
+
+(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))))
+
+(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"))))
+
(defmethod draw-filled-rectangle ((self graphics-context) (rect gfs:rectangle))
(if (gfs:disposed-p self)
(error 'gfs:disposed-error))
Modified: trunk/src/uitoolkit/graphics/graphics-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-generics.lisp (original)
+++ trunk/src/uitoolkit/graphics/graphics-generics.lisp Sun Mar 26 23:52:47 2006
@@ -60,10 +60,10 @@
(defgeneric depth (self)
(:documentation "Returns the bits-per-pixel depth of the object."))
-(defgeneric draw-arc (self rect start-pnt end-pnt direction)
+(defgeneric draw-arc (self rect start-pnt end-pnt)
(:documentation "Draws the outline of an elliptical arc within the specified rectangular area."))
-(defgeneric draw-chord (self rect start-pnt end-pnt direction)
+(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-filled-chord (self rect start-pnt end-pnt)
@@ -81,7 +81,7 @@
(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."))
-(defgeneric draw-filled-wedge (self rect start-pnt end-pnt direction)
+(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)
Modified: trunk/src/uitoolkit/system/gdi32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/gdi32.lisp (original)
+++ trunk/src/uitoolkit/system/gdi32.lisp Sun Mar 26 23:52:47 2006
@@ -40,6 +40,19 @@
(load-foreign-library "msimg32.dll")
(defcfun
+ ("Arc" arc)
+ BOOL
+ (hdc HANDLE)
+ (leftrect INT)
+ (toprect INT)
+ (rightrect INT)
+ (bottomrect INT)
+ (startx INT)
+ (starty INT)
+ (endx INT)
+ (endy INT))
+
+(defcfun
("BitBlt" bit-blt)
BOOL
(hdc HANDLE)
@@ -53,6 +66,19 @@
(rop DWORD))
(defcfun
+ ("Chord" chord)
+ BOOL
+ (hdc HANDLE)
+ (rectleft INT)
+ (recttop INT)
+ (rectright INT)
+ (rectbottom INT)
+ (radial1x INT)
+ (radial1y INT)
+ (radial2x INT)
+ (radial2y INT))
+
+(defcfun
("CreateBitmap" create-bitmap)
HANDLE
(width INT)
@@ -234,6 +260,12 @@
(hgdiobj HANDLE))
(defcfun
+ ("SetArcDirection" set-arc-direction)
+ INT
+ (hdc HANDLE)
+ (direction INT))
+
+(defcfun
("SetBkColor" set-bk-color)
COLORREF
(hdc HANDLE)
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sun Mar 26 23:52:47 2006
@@ -36,6 +36,9 @@
(defconstant +button-classname+ "button")
(defconstant +static-classname+ "static")
+(defconstant +ad-counterclockwise+ 1)
+(defconstant +ad-clockwise+ 2)
+
(defconstant +bi-rgb+ 0)
(defconstant +bi-rle8+ 1)
(defconstant +bi-rle4+ 2)
More information about the Graphic-forms-cvs
mailing list