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.
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[{
{"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}}
}
]
img = Rasterize[g, ImageSize -> 500, RasterSize -> 2000];
?
$\endgroup$
Jan 18, 2018 at 21:00
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.
n=7
and m=5
instead of n=3
and m=2
.
$\endgroup$
Jan 18, 2018 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[[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:
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.