5
$\begingroup$

VertexColors seems to blend colours unevenly, often with a "stripe" between vertices. Compare:

mix4[n_, col_] := 
    ArrayPlot[Table[Blend[{#, #2}, t], {t, 0, 1, 1/n}] & @@@ 
    Thread[Table[Blend[{#, #2}, t], {t, 0, 1, 1/n}] & @@@         
    {#, Reverse@#2} & @@ Partition[col,2]], Frame -> False];

(*
cols = RandomColor[4];
Grid[{{
Graphics[ Polygon[CirclePoints[4], VertexColors -> Part[cols, {3, 4, 1, 2}]]], mix4[100, cols]
}}]
*)

enter image description here

I would like to create polygons without the "stripe" that is characteristic of VertexColors. Is there any way of doing that?

Improve this question
$\endgroup$
2
  • 6
    $\begingroup$ This happens because the system uses linear interpolation over triangles. One (tedious) way to avoid it is to use a higher resolution than just the 4 corner points, and specify the colour at each point. One way is ArrayPlot, as you show here. Another way is to use DensityPlot, or to use DiscretizeRegion on your polygon and specify the colour at each internal vertex. $\endgroup$
    – Szabolcs
    Commented Sep 21, 2021 at 16:58
  • 1
    $\begingroup$ Related: mathematica.stackexchange.com/questions/16168/… $\endgroup$
    – Michael E2
    Commented Sep 22, 2021 at 11:34

1 Answer 1

Reset to default
5
$\begingroup$

Modifying @kglr 's code here, I have made a slight improvement, thanks to @Szabolcs ' comment:

n=5; cols={Red,Green,Blue,Yellow,Magenta};
mreg=DiscretizeRegion[Region[ Polygon[CirclePoints[n]]], MaxCellMeasure -> .5];
mc = MeshCoordinates[mreg];polys= MeshCells[mreg,2];

Grid[{{
Graphics[ Polygon[CirclePoints[n], VertexColors ->Join[cols,{Blend[cols]}]]],
Graphics[{EdgeForm[],  GraphicsComplex[mc, polys, VertexColors ->Join[cols,{Blend[cols]}]]}]
}}]

enter image description here

The rather long running time for

n=5;c=30; cols={Red,Green,Blue,Yellow,Magenta};pts=CirclePoints[n];
array=Select[Flatten[Table[{a,b},{a,-1,1,1/c},{b,-1,1,1/c}],1],
RegionMember[Polygon[N@CirclePoints[n]],N@#]&];
allpts=Flatten[Table[{Blend[cols,1/If[#==0,.001,#]&@
EuclideanDistance[t,#]&/@pts],Point@t},{t,array}],1];
Graphics[{PointSize[1./c],allpts, 
EdgeForm[{White,Thickness[.1]}],Opacity[0], 
Polygon[1.1N@CirclePoints[n]]}]

enter image description here

gives closer to desired result though.

Just for fun:

hex[cols_,n1_]:=Module[{n,c,k,pts,array},
n=6;c=3.5;k=(n1-1)c;pts=CirclePoints[n];
array={(#-k)/k,(#2+2)/k}&@@@#&/@DeleteDuplicates[Flatten[Table[CirclePoints[
{Sqrt[3] (1 j + k - 2 ) + Sqrt[3] (1 j + l - 2 ),3 k - 2 - 3 l}, 
{2, Pi/2}, 6], {j, #}, {k, #}, {l, #}],2],Sort@#==Sort@#2&]&@n1;
Graphics[{Flatten[Table[{Blend[cols,1/If[#==0,.001,#]&@
EuclideanDistance[Mean@t,#]^2&/@pts],Polygon@t},{t,array}],1]}]];

(*hex[{Red,Green,Blue,Yellow,Magenta,Orange},5]*)

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.