How can I get the color of overlapping disks to be equal in any order?

Question

When Graphics is used, necessarily the objects come in order. This affects which ones obscure others. When Opacity is not 1, it also affects the color. I would like the color of overlaps to depend only on the colors of the objects and their opacities and not on the order. Can this be done? For example, this simple code illustrates the problem:

 Graphics[{Opacity[.5], 
 Inner[{#1, #2} &, {Red, Blue, Red}, {Disk[{0, 0}, 1], 
 Disk[{1, 0}, 1], Disk[{2, 0}, 1]}, List]}]

The result is this:

Further info in response to the wonderful answers received so far: I will use this in Manipulate with the disks (or perhaps rectangles) moving around at random. There will also be many of them, such as 1000. So time is important and thus using all permutations is out of consideration (for this particular application).

I have now tested the suggestions. Unfortunately, rasterizing and computing with that takes much too long. If I sort, then that will not give what I want either. So no answer seems to work, sadly.

In response to @Mr.Wizard, here is my example. It is not minimal, but you will want to experiment with various things, I think. In the end, it is not too bad; I used Opacity[0.1] to handle my aesthetic complaint.

    Manipulate[
 If[startover == "start over", 
  current = PadRight[{}, nmparticles, {{-torus/2, 0}, {torus/2, 0}}]; 
  startover = False]; 
 While[run, Pause[1/rate]; 
  If[Length[current] == nmparticles, 
   current = 
    Clip[current + 
      RandomVariate[
       NormalDistribution[0, 1], {nmparticles, 2}], {-torus, torus}], 
   current = 
    PadRight[current, nmparticles, {{-torus/2, 0}, {torus/2, 0}}]]]; 
 Dynamic@Show[
   Graphics[{Opacity[.1], 
     Transpose[{Table[If[OddQ[i], Red, Blue], {i, Length[current]}], 
       Disk[#, 1] & /@ current}]}, 
    PlotRange -> {{-torus, torus}, {-torus, torus}}, 
    ImageSize -> {475, 475}]], 
 Style["             Diffusion", 
  Large], Delimiter, {{run, False, "run"}, {True, 
   False}}, {{nmparticles, 2, "number of particles"}, 1, 5000, 1, 
  Appearance -> "Labeled"},
 {{rate, 10, "rate"}, 3, 1000, 1, 
  Appearance -> "Labeled"}, {{torus, 20, "half-size of box"}, 3, 100, 
  1, Appearance -> "Labeled"}, {{startover, False, 
   ""}, {"start over"}, ControlType -> Setter, Background -> LightRed},
 ControlPlacement -> Right, 
 Initialization :> (current = {{-torus/2, 0}, {torus/2, 0}})]

Answer 1

I haven't tested this outside of this one single example, and I don't have more time at the moment, but perhaps this is useful:

disks = {{Red, Blue, Red}, Disk /@ {{0, 0}, {1, 0}, {2, 0}}}\[Transpose];

Graphics[{Opacity[1/3], disks, Opacity[1/4], Reverse[disks]}]

I don't claim that this is in any way exact but it may get you close.

---

I think the 1/3 and 1/4 opacity reverse blend is theoretically exact for only two layers, though rendering is one RGB value off. For more layers it becomes increasingly poor, but with three layers it is still visually close. Without and with this method:

disks = {{Red, Green, Blue, Red, Green}, 
    Disk /@ {{0, 0}, {1, 1}, {1, 0}, {2, 0}, {1, -1}}}\[Transpose];

Row[{
  Graphics[{Opacity[1/2], disks}, ImageSize -> 250],
  Graphics[{Opacity[1/3], disks, Opacity[1/4], Reverse[disks]}, ImageSize -> 250]
}]

Close examination will show a variation of seven values (in the 0 to 255 range) in the RGB channels of the inner "petals" but I think this will pass as correct if not scrutinized.

With rasterization we can merely average values which of course blends in an order-independent way:

Image[Graphics[#, PlotRange -> 1.05 {{-1, 3}, {-2, 2}}], ImageSize -> 250] & /@ disks;

ImageAdjust[Image @ Mean[ImageData /@ %], {0, 0, 3}]

---

Update

Sorry it took me so long to get back to this. I'm not sure if there is a specific visual effect you are striving for, but based on your demo I think Rahul Narain's method is applicable. As an example please use:

correct = ImageAdjust[Image@#, 0, {0.98, 1}] &;

And then change your code to read:

. . . Dynamic @ correct @ Show[Graphics[{Opacity[1/255], . . .

Sample output:

It seems like it gets the idea across.

Answer 2

Taking an idea from @rasher's answer, I'd argue that the ideal result is the average of all possible orderings of the objects.

disks = Inner[{#1, #2} &, {Red, Blue, Red, Blue, 
    Red}, {Disk[{0, 0}, 1], Disk[{1, 0}, 1], Disk[{2, 0}, 1], 
    Disk[{1, 1}, 1], Disk[{-.5, 1}, 1]}, List];
reference = 
 Image@Mean[
   ImageData@Rasterize@Graphics[{Opacity[0.5], #}] & /@ 
    Permutations[disks]]

(This does not have the problem with small Opacity that @belisarius pointed out.)

---

Of course, this is pretty slow. Here's a much quicker approximation; one that should even work for Graphics3D objects.

First we reduce the opacity so that the results are less order-dependent. We'll also extract the "alpha channel" while we're at it (actually, this is one minus the alpha channel):

g = Graphics[{Opacity[0.1], disks}]
ga = Graphics[{Opacity[0.1], {Black, Last@#} & /@ disks}]

Then we transform the colours so that they match what you would get with an Opacity of 0.5 instead of 0.1:

c1 = ImageData@Rasterize[g];
a1 = ImageData@Rasterize[ga];
a2 = a1^(Log[1 - 0.5]/Log[1 - 0.1]);
c2 = Quiet[1 - (1 - a2)/(1 - a1) (1 - c1)] /. Indeterminate -> 1;
result = Image[c2]

This is nearly identical to the "ideal" result above.

Two clear limitations are worth mentioning. One, of course, we had to Rasterize the graphics, so this isn't great if you really want a vector result. Two, we've lost colour depth by turning the Opacity down, so if you do this on graphics with smooth shading, it'll still work, but you'll start to see banding due to colour quantization. It would help if we could Rasterize with a higher colour depth, but unfortunately that doesn't seem to be possible.

---

Just for fun, here's a 3D example:

Answer 3

If you don't care about the "right" colour of the overlaps and only care about having reproducible results, the simplest thing you could do is define a function that does the ordering for you and group the graphics primitives by colour:

ordering[disks_] := Sort@GatherBy[disks, First@# &];

so now defining

disks = {{Red, Green, Blue, Red, Green}, 
    Disk /@ {{0, 0}, {1, 1}, {1, 0}, {2, 0}, {1, -1}}}\[Transpose];
moredisks = Inner[{#1, #2} &, {Red, Blue, Red, Blue, Red}, {Disk[{0, 0}, 1], 
   Disk[{1, 0}, 1], Disk[{2, 0}, 1], Disk[{1, 1}, 1], 
   Disk[{-.5, 1}, 1]}, List];

at least you get consistent results for colour blends:

Row[{Graphics[{Opacity[0.5], disks}], 
  Graphics[{Opacity[0.5], ordering[disks]}]}]

Row[{Graphics[{Opacity[0.5], moredisks}], 
  Graphics[{Opacity[0.5], ordering[moredisks]}]}]

From here maybe you can take MR Wizard's idea further using an opacity of 1/3 for an ordered and 1/4 for a reverse ordered set of disks or use the permutations idea not on the disks but on however many colours you have.

Answer 4

Perhaps something along this line might be helpful:

disks = Inner[{#1, #2} &, {Red, Blue, Red, Blue, Red}, 
              {Disk[{0, 0}, 1], Disk[{1, 0}, 1], Disk[{2, 0}, 1], 
               Disk[{1, 1}, 1], Disk[{-.5, 1}, 1]}, List];

Graphics[{Opacity[.01], Permutations[disks]}]

Note the adjustment to Opacity (perhaps can be done automagically based on length of permutations), and be aware that as number of items grows, permutations can get out of hand...