17
$\begingroup$

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.

enter image description here

$\endgroup$
0

7 Answers 7

14
$\begingroup$

Here is something fun:

enter image description here

enter image description here

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[]
  )
]
$\endgroup$
13
$\begingroup$

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

enter image description here

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

enter image description here

$\endgroup$
4
  • 1
    $\begingroup$ Cute way to show the light sources. I'll have to keep that in mind for future use... $\endgroup$
    – b3m2a1
    Jan 18, 2018 at 1:08
  • $\begingroup$ Also if you want it to be anti-aliased like in the original image, take the average of every 4x4 block of pixels. $\endgroup$
    – MCMastery
    Jan 18, 2018 at 16:18
  • $\begingroup$ @MCMastery You mean like this? img = Rasterize[g, ImageSize -> 500, RasterSize -> 2000];? $\endgroup$ Jan 18, 2018 at 21:00
  • $\begingroup$ @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 $\endgroup$
    – MCMastery
    Jan 19, 2018 at 15:04
8
$\begingroup$

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]

enter image description here

And now the colour:

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

enter image description here

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]

enter image description here

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]

enter image description here

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

$\endgroup$
2
  • $\begingroup$ This was fun! Suggestions are very much welcome. $\endgroup$ Jan 18, 2018 at 3:07
  • $\begingroup$ To fix: those images were generated with n=7 and m=5 instead of n=3 and m=2. $\endgroup$ Jan 18, 2018 at 3:38
8
$\begingroup$

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]

enter image description here

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]

enter image description here

$\endgroup$
7
$\begingroup$
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}]]]}]

enter image description here

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

enter image description here

$\endgroup$
5
$\begingroup$

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

example triangle shading

$\endgroup$
5
$\begingroup$
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.

enter image description here

$\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.