How can I draw such faceted triangle patterns?

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. 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[{
, {"noise level",Slider[Dynamic[tempN,{Automatic,(noise=tempN)&}],{0,.5}]}
, {}
, {"top right color",ColorSlider@Dynamic@col1}
, {"attenuation",Column[Slider[Dynamic[at1[[#]]],{0,5}]&/@Range]}
, {}
, {"bottom left color",ColorSlider@Dynamic@col2}
, {"attenuation",Column[Slider[Dynamic[at2[[#]]],{0,5}]&/@Range]}
, {}
, {Button["Reset primitives",refreshPrimitives[]]}
}, Alignment->{Left,Center}
]
}
}
, BaseStyle->ImageSizeMultipliers->{1, 1}
]
, Initialization:>(
refreshPrimitives[]:= primitives=Polygon[
Append/@#
, VertexNormals->ConstantArray[  Dynamic[s] RandomReal[{-1,1},3]+{0,0,1},3]
]& @@@ MeshPrimitives[
DiscretizeRegion[Rectangle[],MaxCellMeasure->.05], 2
];
refreshPrimitives[]
)
]

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}}
}
] • Cute way to show the light sources. I'll have to keep that in mind for future use... – b3m2a1 Jan 18 '18 at 1:08
• Also if you want it to be anti-aliased like in the original image, take the average of every 4x4 block of pixels. – MCMastery Jan 18 '18 at 16:18
• @MCMastery You mean like this? img = Rasterize[g, ImageSize -> 500, RasterSize -> 2000];? – Henrik Schumacher Jan 18 '18 at 21:00
• @HenrikSchumacher Sorry I don't use Mathematica, I mean to generate an image 4x the size you need, then take the average of every 4x4 group of pixels. This makes it smoother. What you wrote looks like what I mean though, FWIW – MCMastery Jan 19 '18 at 15:04

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[{#[],#[]+{a+c,0},#[]+{a+c,a+c},#[],#[]} &,{{0,0},{a+c,0},{a+c,a+c},{0,a+c},{0,0}},n];
AppendTo[s,{#[],#[]+{a,0},#[]+{a,a},#[],#[]}&[Last[s]]];
f[x_] := Module[{k=FoldList[{#1[],#2[],#2[]+{c,a+c},#1[],#1[]}&,{#[],#[],#[]+{c,a+c},#[]+{c,a+c},#[]}&[x[]],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.

• This was fun! Suggestions are very much welcome. – AccidentalFourierTransform Jan 18 '18 at 3:07
• To fix: those images were generated with n=7 and m=5 instead of n=3 and m=2. – AccidentalFourierTransform Jan 18 '18 at 3:38

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[]/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[]/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] 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 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;
p = mySpacedPoints[70, xmax, ymax, 0.1];
mesh = DelaunayMesh[p];

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

centroids = Map[Mean[#[]] &, 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
]
] 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. 