[mcclim-cvs] CVS mcclim

[ahefner]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv5329

Modified Files:
	graphics.lisp 
Log Message:
Added draw-rounded-rectangle* function.


--- /project/mcclim/cvsroot/mcclim/graphics.lisp	2006/12/23 11:41:23	1.56
+++ /project/mcclim/cvsroot/mcclim/graphics.lisp	2007/02/05 02:58:46	1.57
@@ -651,10 +651,12 @@
       (with-medium-options (sheet args)
         (if (coordinate<= y-radius x-radius)
             (let ((x1 (- center-x x-radius)) (x2 (+ center-x x-radius))
-                  (y1 (- center-y y-radius)) (y2 (+ center-y y-radius)))              
+                  (y1 (- center-y y-radius)) (y2 (+ center-y y-radius)))
               (if filled
-                  (draw-rectangle* sheet x1 y1 x2 y2)
-                  (draw-lines* sheet (list x1 y1 x2 y1 x1 y2 x2 y2)))              
+                  ;; Kludge coordinates, sometimes due to rounding the lines don't connect.
+                  (draw-rectangle* sheet (floor x1) y1 (ceiling x2) y2)
+                  (draw-lines* sheet (list (floor x1) y1 (ceiling x2) y1
+                                           (floor x1) y2 (ceiling x2) y2)))
               (draw-circle* sheet x1 center-y y-radius
                             :filled filled
                             :start-angle (* pi 0.5)
@@ -1023,3 +1025,72 @@
 			 :ink (transform-region
 			       (make-translation-transformation x y)
 			       pattern))))))
+
+(defun draw-rounded-rectangle* (sheet x1 y1 x2 y2
+                                      &rest args &key
+                                      (radius 7)
+                                      (radius-x radius)
+                                      (radius-y radius)
+                                      (radius-left  radius-x)
+                                      (radius-right radius-x)
+                                      (radius-top    radius-y)
+                                      (radius-bottom radius-y)
+                                      filled &allow-other-keys)
+  "Draw a rectangle with rounded corners"
+
+  (apply #'invoke-with-drawing-options sheet
+    (lambda (medium)
+      (declare (ignore medium))
+      (let ((medium sheet))
+        (if (not (and (>= (- x2 x1) (* 2 radius-x))
+                      (>= (- y2 y1) (* 2 radius-y))))
+            (draw-rectangle* medium x1 y1 x2 y2)       
+            (with-grown-rectangle* ((ix1 iy1 ix2 iy2) (x1 y1 x2 y2)
+                                    :radius-left   (- radius-left)
+                                    :radius-right  (- radius-right)
+                                    :radius-top    (- radius-top)
+                                    :radius-bottom (- radius-bottom))
+              (let ((zl (zerop radius-left))
+                    (zr (zerop radius-right))
+                    (zt (zerop radius-top))
+                    (zb (zerop radius-bottom)))
+                (if filled
+                    (progn              ; Filled
+                      (unless (or zl zt)
+                        (draw-ellipse* medium ix1 iy1 radius-left  0 0 radius-top    :filled t))
+                      (unless (or zr zt)
+                        (draw-ellipse* medium ix2 iy1 radius-right 0 0 radius-top    :filled t))
+                      (unless (or zl zb)
+                        (draw-ellipse* medium ix1 iy2 radius-left  0 0 radius-bottom :filled t))
+                      (unless (or zr zb)
+                        (draw-ellipse* medium ix2 iy2 radius-right 0 0 radius-bottom :filled t))
+                      (draw-rectangle* medium x1 iy1 x2 iy2 :filled t)
+                      (draw-rectangle* medium ix1 y1 ix2 iy1 :filled t)
+                      (draw-rectangle* medium ix1 iy2 ix2 y2 :filled t))                    
+                    (progn              ; Unfilled
+                      (unless (or zl zt)
+                        (draw-ellipse* medium ix1 iy1 (- radius-left) 0 0 (- radius-top)
+                                       :start-angle (/ pi 2) :end-angle pi
+                                       :filled nil))
+                      (unless (or zr zt)
+                        (draw-ellipse* medium ix2 iy1 (- radius-right) 0 0 (- radius-top)
+                                       :start-angle 0 :end-angle (/ pi 2)
+                                       :filled nil))
+                      (unless (or zl zb)
+                        (draw-ellipse* medium ix1 iy2 (- radius-left) 0 0 (- radius-bottom)
+                                       :start-angle pi :end-angle (* 3/2 pi)
+                                       :filled nil))
+                      (unless (or zr zb)
+                        (draw-ellipse* medium ix2 iy2 (- radius-right) 0 0 (- radius-bottom)
+                                       :start-angle (* 3/2 pi)
+                                       :filled nil))
+                      (labels ((fx (y p x1a x2a x1b x2b) (draw-line* medium (if p x1a x1b) y (if p x2a x2b) y))
+                               (fy (x p y1a y2a y1b y2b) (draw-line* medium x (if p y1a y1b) x (if p y2a y2b))))
+                        (fx y1 zt x1 x2 ix1 ix2)
+                        (fy x1 zl y1 y2 iy1 iy2)
+                        (fx y2 zb x1 x2 ix1 ix2)
+                        (fy x2 zr y1 y2 iy1 iy2)))))))))
+   (with-keywords-removed (args '(:radius :radius-x :radius-y
+                                  :radius-left :radius-right
+                                  :radius-top  :radius-bottom))
+     args)))