[graphic-forms-cvs] r79 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
junrue at common-lisp.net
junrue at common-lisp.net
Tue Mar 28 18:16:15 UTC 2006
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
+ at 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}.
+ at 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
+ at 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}.
+ at 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)
More information about the Graphic-forms-cvs
mailing list