How can I draw such faceted triangle patterns?

Question

Is it possible to create such patterns with Mathematica?

See design.SE for details on how to do that with Photoshop and http://matthew.wagerfield.com/flat-surface-shader/ for animated version.

Somehow related: Artistic image vectorization.

Answer 1

Here is something fun:

DynamicModule[
  {col1=Red, col2=Yellow, dist,s=.35, refreshPrimitives, primitives
  , at1={0,2,0},at2={0,2,0},tempN=.1,noise=.1}
, Panel @ Grid[
    { { Dynamic[
          ControlActive[
            #
          , ImageEffect[Setting@#,{"PoissonNoise",noise}]
        ]& @ Dynamic @ Graphics3D[
           {EdgeForm@None,primitives}
        , ViewPoint->{0,0,10^5}
        , Boxed->False
        , Lighting -> {
            {"Point", Dynamic @ col1, {1,1,1}, Dynamic@at1}
          , {"Point", Dynamic @ col2, {0,0,1}, Dynamic@at2}
          }
        , ImageSize->800
        ] , SynchronousUpdating -> False]
      , Grid[{
          {"normals spread",Slider[Dynamic@s,{.1,5}]}
        , {"noise level",Slider[Dynamic[tempN,{Automatic,(noise=tempN)&}],{0,.5}]}
        , {}
        , {"top right color",ColorSlider@Dynamic@col1}
        , {"attenuation",Column[Slider[Dynamic[at1[[#]]],{0,5}]&/@Range[3]]}
        , {}
        , {"bottom left color",ColorSlider@Dynamic@col2}
        , {"attenuation",Column[Slider[Dynamic[at2[[#]]],{0,5}]&/@Range[3]]}
        , {}
        , {Button["Reset primitives",refreshPrimitives[]]}
        }, Alignment->{Left,Center}
        ]
      } 
    }
  , BaseStyle->ImageSizeMultipliers->{1, 1}
  ]
, Initialization:>(
    refreshPrimitives[]:= primitives=Polygon[
      Append[0]/@#
    , VertexNormals->ConstantArray[  Dynamic[s] RandomReal[{-1,1},3]+{0,0,1},3]
    ]& @@@ MeshPrimitives[ 
      DiscretizeRegion[Rectangle[],MaxCellMeasure->.05], 2
    ];
    refreshPrimitives[]
  )
]

Answer 2

Essentially the same approach as anderstood's. I use a triangulation of a square and a random piecewise-linear height function. The colors come from the interplay between different light sources.

R = DiscretizeRegion[Rectangle[]];
gc = GraphicsComplex[
   Join[MeshCoordinates[R], 
    RandomVariate[
     NormalDistribution[0, 0.01], {MeshCellCount[R, 0], 1}], 2],
   GraphicsGroup[{Blend[{Yellow, Red}, 0.25], EdgeForm[], 
     MeshCells[R, 2]}]
   ];
Graphics3D[
 gc,
 ViewPoint -> {0, 0, 1},
 ViewAngle -> Pi/6,
 Boxed -> False,
 Lighting -> {
   {"Point", Blend[{Yellow, Red}, 0.9] , {1, 1, 1}},
   {"Point", Blend[{Yellow, Red}, 0.0] , {-1, -1, 1}}
   }
 ]

This is a total view of the scene; the spheres indicate the positions of the light sources.

Graphics3D[{
  gc,
  Glow@Blend[{Yellow, Red}, 0.9] , Sphere[{1, 1, 1}, 0.1],
  Glow@Blend[{Yellow, Red}, 0.0] , Sphere[{-1, -1, 1}, 0.1]
  },
 Boxed -> True,
 Lighting -> {
   {"Point", Blend[{Yellow, Red}, 0.9] , {1, 1, 1}},
   {"Point", Blend[{Yellow, Red}, 0.] , {-1, -1, 1}}
   }
 ]

Answer 3

Using the first part from this old answer of mine,

ClearAll["Global`*"]
a = .25;                     (*side length*)
c:=.15 RandomReal[{-1, 1}];  (*random shifting*)
d = .15;
n = 3;                       (*n+1 rectangles in the x direc.*)
m = 2;                       (*m+1 rectangles in the y direc.*)

s =  NestList[{#[[2]],#[[2]]+{a+c,0},#[[2]]+{a+c,a+c},#[[3]],#[[2]]} &,{{0,0},{a+c,0},{a+c,a+c},{0,a+c},{0,0}},n];
AppendTo[s,{#[[2]],#[[2]]+{a,0},#[[2]]+{a,a},#[[3]],#[[2]]}&[Last[s]]];
f[x_] := Module[{k=FoldList[{#1[[2]],#2[[3]],#2[[3]]+{c,a+c},#1[[3]],#1[[2]]}&,{#[[4]],#[[3]],#[[3]]+{c,a+c},#[[4]]+{c,a+c},#[[4]]}&[x[[1]]],Rest@x]},
                 k[[1,4,1]]=0;
                 k[[n+2,3,1]]=x[[-1,2,1]];
                 k];
q = NestList[f,s,m];
Table[q[[-1,j,3,2]]=q[[-1,j,4,2]]=(m+1)a,{j,1,n+2}];
q = Partition[#,2]&/@Partition[Flatten[q],10];
ListPlot[q,Joined->True,Axes->False]

And now the colour:

Show[Graphics[{RGBColor[1, .5 + .2 RandomReal[], .2 RandomReal[]], Polygon[#]}] & /@ q]

You can also add a little blending to mimic the gradient:

Blend[{%, Graphics[Polygon[{{0, 0}, {Max[q], 0}, {Max[q], 1.5}, {0, 1.5}}, VertexColors -> {Orange, Darker@Red, Darker@Red, Orange}]]}, .4]

You can play around with the parameters to get more accurate graphics. Have fun!

---

Instead of Blend, you can also archive a gradient by using

Show[Graphics[{RGBColor[1, .5 + .2 RandomReal[] - .07 Total[First /@ #]/Max[q], .2 RandomReal[]], Polygon[#]}] & /@ q]

which makes the colours slightly more... vibrant?, which may or may not be what you are looking for.

Answer 4

This needs to be adjusted, but that is a starting point.

Mesh generation By adding noise to a regular triangular mesh:

n = 10;
m = n/2;
pts = Table[{i + .5*Mod[j, 2], j} + 0.2*RandomReal[{-1, 1}, {2}], {i, 
    1, n}, {j, 1, m}];
triangles = Flatten[{Table[Triangle[
             {pts[[i + 1, j]], pts[[i, j + 1]], pts[[i + k, j + k]]}
             ], {i, 1, n - 1}, {j, 1, m - 1}, {k, 0, 1}]}]

Define a color The following defines a color based on the $x$ position of the triangle centroid, with noise (from black to red, basically).

col[triangle_] := 
 With[{center = RegionCentroid[triangle]}, 
  RGBColor[RandomReal[center[[1]]/n + {-.1, .1}], 0.1, 0.0]]

Result Draw each triangle with its corresponding color:

Graphics[Table[{col[triangles[[i]]], triangles[[i]]}, 
          {i, 1, Length@triangles}], PlotRangePadding -> 0]

Possible improvements:

• The color could be adjusted for a better match (in particular, yellow is almost missing).
• The lines and aliasing should be removed.

Edit Using Antialising -> False, Blend and cropping the output with n = 20:

  col[triangle_] := 
 With[{center = RegionCentroid[triangle]}, 
  Blend[{Yellow, Red}, center[[1]]/n + RandomReal[{-.2, .2}]]]

 Style[Graphics[
  Table[{col[triangles[[i]]], triangles[[i]]}, {i, 1, 
    Length@triangles}], PlotRangePadding -> 0, 
  PlotRange -> {{2, n - 2}, {2, m - 2}}], Antialiasing -> False]

Answer 5

TriangulateMesh[MeshRegion[{{0, 0}, {2, 0}, {2, 1}, {0, 1}}, Polygon[{1, 2, 3, 4}]], 
 ImageSize -> 900, MaxCellMeasure -> .025, 
 MeshCellHighlight -> {{2, _} :>   Directive[Antialiasing -> True, 
   EdgeForm[], ColorData["SolarColors"][RandomReal[{.1, .8}]]]}]

Use MaxCellMeasure->{"Area" -> 0.01} and RandomReal[] (in place of RandomReal[{.1, .8}] to get

Answer 6

I sample a rectangle from {-xmax,-ymax} to {xmax,ymax} with somewhat evenly spaced points, using a modification of the answer by Andy Ross here. This allows for different extents in the horizontal and vertical directions.

mySpacedPoints = 
   Compile[{{n, _Integer}, {xmax, _Real}, {ymax, _Real}, {minD, _Real}},
      Block[{data={{RandomReal[xmax{-1,1}],RandomReal[ymax{-1,1}]}}, k=1, rv, temp},
            While[k < n,
                  rv = {RandomReal[xmax {-1, 1}], RandomReal[ymax {-1, 1}]};
                  temp = Transpose[Transpose[data] - rv];
                  If[Min[Map[Norm, temp]] > minD, data = Join[data, {rv}]; k++]
            ];
            data],
      CompilationTarget :> "C", RuntimeOptions -> "Speed"];

I also use the suggestion by @Mr.Wizard here to remove the faint lines between polygons. That is, Antialiasing->False.

More complicated blend functions are possible. I just used the horizontal coordinate of the polygon centroid.

Block[{xmax = 10., ymax = 6., p, mesh, poly, centroids, colours},
   SeedRandom[25];
   p = mySpacedPoints[70, xmax, ymax, 0.1];
   mesh = DelaunayMesh[p];

   poly = Map[ Polygon[p[[#]]] &, MeshCells[mesh, 2][[All, 1]]];

   centroids = Map[Mean[#[[1]]] &, poly];

   colours = Map[
                 Blend[{Yellow, Orange, Darker@Red}, (# + xmax)/(2 xmax)] &, 
                 centroids[[All, 1]]];

   (* add random perturbation to colours *)
   colours = 
      RGBColor @@@ ((List @@@ colours) + 
                    RandomReal[0.01 {-1, 1}, {Length[poly], 3}]);

   Graphics[
      {Antialiasing -> False, EdgeForm[{}],
       Transpose[{colours, poly}]
      }, ImageSize -> 500, Background -> Black
   ]
]

Answer 7

Manipulate[
 ListDensityPlot[Map[Flatten, Transpose[{pts, Range[Length[pts]]}]],
  PlotRange -> {{0, 10}, {0, 10}},
  InterpolationOrder -> 0,
  Mesh -> All,
  ImageSize -> 600,
  ColorFunction -> (Blend[{LightRed, Darker[Red]}, #] &),
  FrameTicks -> False],
 {{pts, RandomReal[{0, 10}, {15, 2}]}, {0, 0}, {10, 10}, Locator, 
  LocatorAutoCreate -> True}]

and feel free to change the color function.