How can I draw such faceted triangle patterns?

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[] ) ] 

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}} } ] 

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.

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] 

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[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 ] ] 

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.