[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms

[junrue]

Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms
In directory clnet:/tmp/cvs-serv23182

Modified Files:
	medium.lisp utils.lisp 
Log Message:
fix calculation of start and end points for MEDIUM-DRAW-ELLIPSE* (and thus
MEDIUM-DRAW-CIRCLE*)


--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp	2007/09/30 21:12:50	1.9
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/medium.lisp	2007/10/01 01:10:35	1.10
@@ -295,6 +295,78 @@
                           (gfg:draw-rectangle gc rect)))))))))
     (add-medium-to-render medium)))
 
+(defun compute-quad-point (center-x height angle)
+  (let* ((opp-len (/ height 2))
+         (hyp-len (/ opp-len (sin angle)))
+         (adj-len (sqrt (- (expt hyp-len 2) (expt opp-len 2)))))
+    (gfs:make-point :x (floor (+ center-x adj-len))
+                    :y (floor opp-len))))
+
+(defun compute-arc-point (center-x center-y width height radians)
+  (let ((angle (radians->degrees radians)))
+    (multiple-value-bind (count remainder)
+        (floor angle 360)
+      (if (> count 0)
+          (compute-arc-point center-x center-y width height remainder)
+          (cond
+            ((= angle 270)
+             (gfs:make-point :x (floor center-x)
+                             :y (+ (floor center-y) (floor height 2))))
+            ((> angle 270)
+             (compute-quad-point center-x height (- angle 270)))
+            ((= angle 180)
+             (gfs:make-point :x (- (floor center-x) (floor width 2))
+                             :y (floor center-y)))
+            ((> angle 180)
+             (compute-quad-point center-x height (- angle 180)))
+            ((= angle 90)
+             (gfs:make-point :x (floor center-x)
+                             :y (- (floor center-y) (floor height 2))))
+            ((> angle 90)
+             (compute-quad-point center-x height(- angle 90)))
+            ((= angle 0)
+             (gfs:make-point :x (+ (floor center-x) (floor width 2))
+                             :y (floor center-y)))
+            (t
+             (compute-quad-point center-x height angle)))))))
+
+(defmethod medium-draw-ellipse* ((medium graphic-forms-medium)
+                                 center-x center-y
+                                 radius-1-dx radius-1-dy
+                                 radius-2-dx radius-2-dy
+                                 start-angle end-angle
+                                 filled)
+  (unless (or (= radius-2-dx radius-1-dy 0)
+              (= radius-1-dx radius-2-dy 0))
+    (error "MEDIUM-DRAW-ELLIPSE* not for non axis-aligned ellipses."))
+  (when (target-of medium)
+    (gfw:with-graphics-context (gc (target-of medium))
+      (let ((color (ink-to-color medium (medium-ink medium))))
+        (if filled
+            (setf (gfg:background-color gc) color))
+        (setf (gfg:foreground-color gc) color))
+      (climi::with-transformed-position
+          ((sheet-native-transformation (medium-sheet medium))
+           center-x center-y)
+        (let* ((width (abs (+ radius-1-dx radius-2-dx)))
+               (height (abs (+ radius-1-dy radius-2-dy)))
+               (min-x (floor (- center-x width)))
+               (min-y (floor (- center-y height)))
+               (max-x (floor (+ center-x width)))
+               (max-y (floor (+ center-y height)))
+               (rect (coordinates->rectangle min-x min-y max-x max-y))
+               (start-pnt (compute-arc-point center-x center-y
+                                             width height
+                                             start-angle))
+               (end-pnt (compute-arc-point center-x center-y
+                                           width height
+                                           end-angle)))
+          (if filled
+              (gfg:draw-filled-pie-wedge gc rect start-pnt end-pnt)
+              (gfg:draw-arc gc rect start-pnt end-pnt)))))
+    (add-medium-to-render medium)))
+
+#|
 ;; FIXME: completely untested.  Not sure we're even using the right GFG h
 ;; functions.  Are start-point and end-point right?
 (defmethod medium-draw-ellipse* ((medium graphic-forms-medium) center-x center-y
@@ -320,19 +392,16 @@
                (max-y (floor (+ center-y radius-dy)))
                (rect (coordinates->rectangle min-x min-y max-x max-y))
                (start-point
-                (gfs:make-point :x (floor
-                                    (* (cos start-angle) radius-dx))
-                                :y (floor
-                                    (* (sin start-angle) radius-dy))))
+                (gfs:make-point :x (floor (* (cos start-angle) radius-dx))
+                                :y (floor (* (sin start-angle) radius-dy))))
                (end-point
-                (gfs:make-point :x (floor
-                                    (* (cos end-angle) radius-dx))
-                                :y (floor
-                                    (* (sin end-angle) radius-dy)))))
+                (gfs:make-point :x (floor (* (cos end-angle) radius-dx))
+                                :y (floor (* (sin end-angle) radius-dy)))))
           (if filled
               (gfg:draw-filled-pie-wedge gc rect start-point end-point)
-              (gfg:draw-pie-wedge gc rect start-point end-point)))))
+              (gfg:draw-arc gc rect start-point end-point)))))
     (add-medium-to-render medium)))
+|#
 
 ;; FIXME: completely untested.
 (defmethod medium-draw-circle* ((medium graphic-forms-medium)
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp	2007/09/09 03:47:08	1.3
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/utils.lisp	2007/10/01 01:10:35	1.4
@@ -44,3 +44,7 @@
   (loop for i from 0 below (length seq) by 2
         collect (gfs:make-point :x (floor (elt seq i))
                                 :y (floor (elt seq (+ i 1))))))
+
+(declaim (inline radians->degrees))
+(defun radians->degrees (rads)
+  (floor (* rads 180) pi))