Author: junrue Date: Tue Mar 28 13:16:14 2006 New Revision: 79
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: implemented rounded rectangle drawing functions; refactored drawing-tester program
Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Tue Mar 28 13:16:14 2006 @@ -891,6 +891,14 @@ draw an outline for the rectangle. @end deffn
+@deffn GenericFunction draw-filled-rounded-rectangle self rect arc-size +Fills the interior of a rectangle with rounded corners in the current +background color. The current foreground color, pen width, and pen +style will be used to draw an outline for the rectangle. The rounding +of the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. +@end deffn + @deffn GenericFunction draw-image self image point Draws @code{image} in the receiver at the specified @ref{point}. @end deffn @@ -940,6 +948,13 @@ nothing. See also @ref{draw-polygon}. @end deffn
+@deffn GenericFunction draw-rounded-rectangle self rect arc-size +Draws the outline of a rectangle with rounded corners using the +current foreground color, pen width, and pen style. The rounding of +the corners is determined by an ellipse whose height and width are +determined by @code{arc-size}. +@end deffn + @deffn GenericFunction draw-rectangle self rect Draws the outline of a rectangle in the current foreground color, using the current pen width and style.
Modified: trunk/src/tests/uitoolkit/drawing-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/drawing-tester.lisp (original) +++ trunk/src/tests/uitoolkit/drawing-tester.lisp Tue Mar 28 13:16:14 2006 @@ -76,215 +76,93 @@ (unless (null func) (funcall func gc))))
-(defun draw-bezier-test (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 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-bezier gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) - (setf (gfg:pen-width gc) 3) - (setf (gfg:pen-style gc) (second pen-styles)) - (gfg:draw-bezier 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)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 90) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 90) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:pen-width gc) 1) - (setf (gfg:pen-style gc) (third pen-styles)) - (gfg:draw-bezier 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)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 180) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 180) - :y (gfs:point-y ctrl-pnt-2))) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (gfg:draw-bezier 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)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-1) 270) - :y (gfs:point-y ctrl-pnt-1)) - (gfs:make-point :x (+ (gfs:point-x ctrl-pnt-2) 270) - :y (gfs:point-y ctrl-pnt-2)))) - -(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))) - - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join)) - (funcall filled-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) 3) - (setf (gfg:pen-style gc) '(:solid)) - (funcall filled-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) - (funcall filled-draw-fn 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:background-color gc)) - (funcall filled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)) - - (setf (gfs:point-x pnt) 15) - (incf (gfs:point-y pnt) (+ (gfs:size-height size) 10)) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (setf (gfg:pen-width gc) 5) - (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap)) - (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) 3) - (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)) - (incf (gfs:point-x pnt) (+ (gfs:size-width size) 10)) - (setf (gfg:foreground-color gc) (gfg:background-color gc)) - (funcall unfilled-draw-fn gc (make-instance 'gfs:rectangle :location pnt :size size)))) +(defun clone-point (orig) + (gfs:make-point :x (gfs:point-x orig) :y (gfs:point-y orig)))
-(defun draw-ellipses (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-ellipse #'gfg:draw-ellipse)) +(defun clone-size (orig) + (gfs:make-size :width (gfs:size-width orig) :height (gfs:size-height orig)))
-(defun select-ellipses (disp item time rect) - (declare (ignore disp time rect)) - (update-drawing-item-check item) - (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) - (gfw:redraw *drawing-win*)) +(defun set-gc-params (gc column filled) + (ecase column + (0 + (setf (gfg:foreground-color gc) gfg:*color-blue*) + (setf (gfg:background-color gc) gfg:*color-green*) + (if filled + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dashdotdot :bevel-join))) + (progn + (setf (gfg:pen-width gc) 5) + (setf (gfg:pen-style gc) '(:dot :round-join :flat-endcap))))) + (1 + (setf (gfg:pen-width gc) 3) + (if filled + (setf (gfg:pen-style gc) '(:solid)) + (setf (gfg:pen-style gc) '(:dot)))) + (2 + (setf (gfg:pen-width gc) 1) + (setf (gfg:pen-style gc) '(:solid))) + (3 + (setf (gfg:foreground-color gc) (gfg:background-color gc))))) + +(defun draw-rectangular (gc rect arc-size delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (if arc-size + (funcall draw-fn gc rect arc-size) + (funcall draw-fn gc rect)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-start-end (gc start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-rect-start-end (gc rect start-pnt end-pnt delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc rect start-pnt end-pnt) + (loop for pnt in (list start-pnt end-pnt) do (incf (gfs:point-x pnt) delta-x)) + (incf (gfs:point-x (gfs:location rect)) delta-x))) + +(defun draw-points (gc points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc points) + (loop for pnt in points do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-points (gc start-pnt points delta-x draw-fn filled) + (dotimes (i 4) + (set-gc-params gc i filled) + (funcall draw-fn gc start-pnt points) + (loop for pnt in (append (list start-pnt) points) do (incf (gfs:point-x pnt) delta-x)))) + +(defun draw-start-end-controls (gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 delta-x draw-fn) + (dotimes (i 4) + (set-gc-params gc i nil) + (funcall draw-fn gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) + (loop for pnt in (list start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2) do (incf (gfs:point-x pnt) delta-x))))
(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))) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (start-pnt (gfs:make-point :x 15 :y 60)) + (end-pnt (gfs:make-point :x 75 :y 25)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10))) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-chord t) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-chord nil) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-arc nil)))
(defun select-arcs (disp item time rect) (declare (ignore disp time rect)) @@ -297,9 +175,7 @@ (end-pnt (gfs:make-point :x 70 :y 32)) (ctrl-pnt-1 (gfs:make-point :x 40 :y 0)) (ctrl-pnt-2 (gfs:make-point :x 40 :y 65))) - (setf (gfg:background-color gc) gfg:*color-green*) - (setf (gfg:foreground-color gc) gfg:*color-blue*) - (draw-bezier-test gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 '((:dashdotdot :bevel-join) (:solid) (:solid))) + (draw-start-end-controls gc start-pnt end-pnt ctrl-pnt-1 ctrl-pnt-2 85 #'gfg:draw-bezier) (let ((poly-pnts (list (list (gfs:make-point :x 40 :y 100) (gfs:make-point :x 35 :y 200) (gfs:make-point :x 300 :y 180)) @@ -309,7 +185,7 @@ (setf (gfg:foreground-color gc) gfg:*color-blue*) (setf (gfg:pen-width gc) 3) (setf (gfg:pen-style gc) '(:dot :square-endcap)) - (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 100) poly-pnts)))) + (gfg:draw-poly-bezier gc (gfs:make-point :x 10 :y 110) poly-pnts))))
(defun select-beziers (disp item time rect) (declare (ignore disp time rect)) @@ -317,29 +193,54 @@ (setf (draw-func-of *drawing-dispatcher*) #'draw-beziers) (gfw:redraw *drawing-win*))
+(defun draw-ellipses (gc) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10))) + (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-ellipse t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-ellipse nil))) + +(defun select-ellipses (disp item time rect) + (declare (ignore disp time rect)) + (update-drawing-item-check item) + (setf (draw-func-of *drawing-dispatcher*) #'draw-ellipses) + (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)))))) + (let ((pnt-1 (gfs:make-point :x 15 :y 60)) + (pnt-2 (gfs:make-point :x 75 :y 30)) + (pnt-3 (gfs:make-point :x 40 :y 10)) + (delta-x 75) + (delta-y 60)) + (draw-points gc + (list (clone-point pnt-1) (clone-point pnt-2) (clone-point pnt-3)) + delta-x + #'gfg:draw-filled-polygon + t) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) delta-y))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polygon + nil) + (draw-points gc + (mapcar #'(lambda (pnt) (gfs:make-point :x (gfs:point-x pnt) + :y (+ (gfs:point-y pnt) (* delta-y 2)))) + (list pnt-1 pnt-2 pnt-3)) + delta-x + #'gfg:draw-polyline + nil) + (draw-start-end gc + (gfs:make-point :x (gfs:point-x pnt-1) :y (+ (gfs:point-y pnt-1) (* delta-y 3))) + (gfs:make-point :x (gfs:point-x pnt-2) :y (+ (gfs:point-y pnt-2) (* delta-y 3))) + delta-x + #'gfg:draw-line + nil)))
(defun select-lines (disp item time rect) (declare (ignore disp time rect)) @@ -348,7 +249,22 @@ (gfw:redraw *drawing-win*))
(defun draw-rects (gc) - (draw-rectangular-tests gc #'gfg:draw-filled-rectangle #'gfg:draw-rectangle)) + (let* ((rect-pnt (gfs:make-point :x 15 :y 10)) + (rect-size (gfs:make-size :width 80 :height 50)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (+ (gfs:size-height rect-size) 10)) + (arc-size (gfs:make-size :width 10 :height 10))) + (draw-rectangular gc rect arc-size delta-x #'gfg:draw-filled-rounded-rectangle t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-filled-rectangle t) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect arc-size delta-x #'gfg:draw-rounded-rectangle nil) + (incf (gfs:point-y rect-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rectangular gc rect nil delta-x #'gfg:draw-rectangle nil)))
(defun select-rects (disp item time rect) (declare (ignore disp time rect)) @@ -357,58 +273,20 @@ (gfw:redraw *drawing-win*))
(defun draw-wedges (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 35 :y 75)) - (end-pnt (gfs:make-point :x 85 :y 35)) - (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge 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) 35) - (setf (gfs:point-x end-pnt) 85) - (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-pie-wedge 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-pie-wedge 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-pie-wedge 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-pie-wedge gc (make-instance 'gfs:rectangle :location rect-pnt :size rect-size) start-pnt end-pnt))) + (let* ((rect-pnt (gfs:make-point :x 5 :y 10)) + (rect-size (gfs:make-size :width 80 :height 65)) + (rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (delta-x (+ (gfs:size-width rect-size) 10)) + (delta-y (gfs:size-height rect-size)) + (start-pnt (gfs:make-point :x 35 :y 75)) + (end-pnt (gfs:make-point :x 85 :y 35))) + + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-filled-pie-wedge t) + (incf (gfs:point-y rect-pnt) delta-y) + (incf (gfs:point-y start-pnt) delta-y) + (incf (gfs:point-y end-pnt) delta-y) + (setf rect (make-instance 'gfs:rectangle :location (clone-point rect-pnt) :size rect-size)) + (draw-rect-start-end gc rect (clone-point start-pnt) (clone-point end-pnt) delta-x #'gfg:draw-pie-wedge nil)))
(defun select-wedges (disp item time rect) (declare (ignore disp time rect))
Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Tue Mar 28 13:16:14 2006 @@ -107,6 +107,19 @@ (+ (gfs:point-y pnt) (gfs:size-height size)))) (error 'gfs:toolkit-error :detail (format nil "~a failed" name)))))
+(defun call-rounded-rect-function (fn name hdc rect arc-size) + (let ((pnt (gfs:location rect)) + (size (gfs:size rect))) + (if (zerop (funcall fn + hdc + (gfs:point-x pnt) + (gfs:point-y pnt) + (+ (gfs:point-x pnt) (gfs:size-width size)) + (+ (gfs:point-y pnt) (gfs:size-height size)) + (gfs:size-width arc-size) + (gfs:size-height arc-size))) + (error 'gfs:toolkit-error :detail (format nil "~a failed" name))))) + (defun call-rect-and-range-function (fn name hdc rect start-pnt end-pnt) (let ((rect-pnt (gfs:location rect)) (rect-size (gfs:size rect))) @@ -232,45 +245,6 @@ (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-pie-wedge ((self graphics-context) rect start-pnt end-pnt) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (with-null-brush (self) - (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) - -(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) - (if (gfs:disposed-p self) - (error 'gfs:disposed-error)) - (unless (null points) - (let ((tmp (loop for triplet in points - append (list (second triplet) (third triplet) (first triplet))))) - (push start-pnt tmp) - (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) - -(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) - (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) - ;;; FIXME: consider preserving this version as a "fast path" ;;; rectangle filler. ;;; @@ -298,6 +272,11 @@ (cffi:null-pointer)))))) |#
+(defmethod draw-filled-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size)) + ;;; ;;; TODO: support addressing elements within bitmap as if it were an array ;;; @@ -353,6 +332,51 @@ 0 0 gfs::+blt-srccopy+))))) (gfs::delete-dc memdc)))
+(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-pie-wedge ((self graphics-context) rect start-pnt end-pnt) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-and-range-function #'gfs::pie "pie" (gfs:handle self) rect start-pnt end-pnt))) + +(defmethod draw-poly-bezier ((self graphics-context) start-pnt points) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (unless (null points) + (let ((tmp (loop for triplet in points + append (list (second triplet) (third triplet) (first triplet))))) + (push start-pnt tmp) + (call-points-function #'gfs::poly-bezier "poly-bezier" (gfs:handle self) tmp)))) + +(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) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rect-function #'gfs::rectangle "rectangle" (gfs:handle self) rect))) + +(defmethod draw-rounded-rectangle ((self graphics-context) rect size) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error)) + (with-null-brush (self) + (call-rounded-rect-function #'gfs::round-rect "round-rect" (gfs:handle self) rect size))) + (defmethod draw-text ((self graphics-context) text (pnt gfs:point)) (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 Tue Mar 28 13:16:14 2006 @@ -87,7 +87,7 @@ (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) +(defgeneric draw-filled-rounded-rectangle (self rect size) (:documentation "Fills the interior of the rectangle with rounded corners."))
(defgeneric draw-filled-wedge (self rect start-pnt end-pnt) @@ -117,7 +117,7 @@ (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) +(defgeneric draw-rounded-rectangle (self rect size) (:documentation "Draws the outline of the rectangle with rounded corners."))
(defgeneric draw-text (self text pnt)
Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Tue Mar 28 13:16:14 2006 @@ -297,6 +297,17 @@ (y2 INT))
(defcfun + ("RoundRect" round-rect) + BOOL + (hdc HANDLE) + (rectleft INT) + (recttop INT) + (rectright INT) + (rectbottom INT) + (width INT) + (height INT)) + +(defcfun ("SelectObject" select-object) HANDLE (hdc HANDLE)