Index: Backends/CLX/medium.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp,v
retrieving revision 1.91
diff -u -r1.91 medium.lisp
--- Backends/CLX/medium.lisp	15 Nov 2009 11:27:26 -0000	1.91
+++ Backends/CLX/medium.lisp	19 Dec 2012 13:52:07 -0000
@@ -806,6 +806,13 @@
                                  (max 0 (min #xFFFF (- bottom top)))
                                  filled)))))))
 
+(defun xrender-scale-color (r g b a)
+  "Scale a rgba color from [0:1]^4 space to the [0:#xffff]^4 space."
+  (list (min #xffff (max 0 (round (* #xffff r))))
+        (min #xffff (max 0 (round (* #xffff g))))
+        (min #xffff (max 0 (round (* #xffff b))))
+        (min #xffff (max 0 (round (* #xffff a))))))
+
 #+CLX-EXT-RENDER
 (defmethod medium-draw-rectangle-using-ink* ((medium clx-medium) (ink climi::uniform-compositum)
                                              x1 y1 x2 y2 filled)
@@ -819,19 +826,13 @@
               (y2 (round-coordinate y2)))
           (multiple-value-bind (r g b) (color-rgb (slot-value ink 'climi::ink))
             (let ((a (opacity-value (slot-value ink 'climi::mask))))
-              ;; Hmm, XRender uses pre-multiplied alpha, how useful!
-              (setf r (min #xffff (max 0 (round (* #xffff a r))))
-                    g (min #xffff (max 0 (round (* #xffff a g))))
-                    b (min #xffff (max 0 (round (* #xffff a b))))
-                    a (min #xffff (max 0 (round (* #xffff a)))))
               (let ((picture (clx-medium-picture medium)))
-                (xlib:render-fill-rectangle picture :over (list r g b a)
+                (xlib:render-fill-rectangle picture :over (xrender-scale-color r g b a)
                                             (max #x-8000 (min #x7FFF x1))
                                             (max #x-8000 (min #x7FFF y1))
                                             (max 0 (min #xFFFF (- x2 x1)))
                                             (max 0 (min #xFFFF (- y2 y1))))))))))))
 
-
 (defmethod medium-draw-rectangles* ((medium clx-medium) position-seq filled)
   (assert (evenp (length position-seq)))
   (with-transformed-positions ((sheet-native-transformation
Index: Examples/clim-fig.lisp
===================================================================
RCS file: /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp,v
retrieving revision 1.34
diff -u -r1.34 clim-fig.lisp
--- Examples/clim-fig.lisp	23 Jan 2008 23:07:55 -0000	1.34
+++ Examples/clim-fig.lisp	19 Dec 2012 13:52:29 -0000
@@ -32,7 +32,7 @@
 	string))
 
 (defun draw-figure (pane x y x1 y1 &key fastp cp-x1 cp-y1 cp-x2 cp-y2)
-  (with-slots (line-style current-color fill-mode constrict-mode)
+  (with-slots (line-style current-color opacity fill-mode constrict-mode)
       *application-frame*
     (let* ((radius-x (- x1 x))
            (radius-y (- y1 y))
@@ -65,7 +65,7 @@
                       :to-head t :head-width 20 :head-length 20))
         (:rectangle
          (draw-rectangle* pane x y x1 y1 :filled fill-mode
-                          :ink current-color
+                          :ink (climi::make-uniform-compositum current-color opacity)
                           :line-style line-style))
         (:ellipse
          (draw-ellipse* pane x y radius-x 0 0 radius-y
@@ -169,8 +169,7 @@
 	     :label " "
 	     :activate-callback
              #'(lambda (gadget)
-                 (setf (clim-fig-current-color (gadget-client gadget))
-                       color))
+                 (setf (clim-fig-current-color (gadget-client gadget)) color))
 	     :width width :height height
              :background color :foreground color
 	     :normal color :pushed-and-highlighted color
@@ -205,6 +204,7 @@
    (redo-list :initform nil :accessor clim-fig-redo-list)
    (current-color :initform +black+ :accessor clim-fig-current-color)
    (line-style :initform (make-line-style) :accessor clim-fig-line-style)
+   (opacity :initform 1 :accessor clim-fig-opacity)
    (fill-mode :initform nil :accessor clim-fig-fill-mode)
    (constrict-mode :initform nil :accessor clim-fig-constrict-mode)
    (status :initform nil :accessor clim-fig-status))
@@ -229,6 +229,18 @@
                       :decimal-places 0
 		      :height 50
 		      :orientation :horizontal)
+   (opacity-slider :slider
+                   :label "Opacity"
+                   :value 1
+                   :min-value 0
+                   :max-value 1
+                   :value-changed-callback
+                   #'(lambda (gadget value)
+                       (setf (clim-fig-opacity (gadget-client gadget)) value))
+                   :show-value-p t
+                   :decimal-places 1
+                   :number-of-quanta 10
+                   :orientation :horizontal)
    (round-shape-toggle :toggle-button
                        :label "Round Cap/Joint"
                        :value nil
@@ -310,6 +322,7 @@
              (list red-button magenta-button yellow-button white-button)
              (list turquoise-button grey-button brown-button orange-button))
            line-width-slider
+           opacity-slider
            round-shape-toggle
            (horizontally () fill-mode-toggle constrict-toggle)
            point-button line-button arrow-button