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 +@anchor{draw-arc} +@deffn GenericFunction draw-arc self rect start-pnt end-pnt +Draws 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. 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-chord}. +@end deffn + +@anchor{draw-chord} +@deffn GenericFunction draw-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: +@itemize @bullet +@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. +@item +a line drawn between start-pnt and end-pnt +@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}. +@end deffn + +@anchor{draw-filled-chord} +@deffn GenericFunction draw-filled-chord self rect start-pnt end-pnt +Draws a closed shape comprised of: +@itemize @bullet +@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. +@item +a line drawn between start-pnt and end-pnt +@end itemize +The shape is drawn using the current pen style, pen width and +foreground color and filled with the current background color. If +@code{start-pnt} and @code{end-pnt} are the same, a complete ellipse +is drawn. +@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}, -@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}, -@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)