15
$\begingroup$

Roman Verostko

Roman Verostko was born in 1929 in Tars, Pennsylvania. In the early 1980's, following 30 years of painting, he began executing algorithmic drawings with a pen plotter. Today his studio includes a network of computers coupled to pen plotters driven with his own software. By 1987 Verosko created the world's first software driven 'brushed' paintings with oriental brushes mounted on his plotter.

enter image description here

Portrait of Roman Verostko, 2011, Victoria and Albert Museum, London. This machine portrait was drawn by Paul, an installation working with a camera and a robotic arm, developed by french artist Patrick Tresset.

Verostko now lives in Minneapolis, Minnesota, where he taught at the Minneapolis College of Art and Design (MCAD) from 1968 to 1994. His drawings have been featured in over 30 exhibitions worldwide. The Victoria and Albert Museum, London, owns 50 Verostko drawings.

FF 2004

enter image description here

Roman Verostko, FF 2004 (50 cm by 76 cm)

FF 2004 presents a drawing accompanied with lines of 'non-rational' glyphs without any meaning. Other similar works present glyphs coded with texts from sources such as Darwin and Shakespeare.

Reproduction attempt

col = ColorData["WatermelonColors"] /@ Subdivide[18]

enter image description here

f = x^4 - 25 x^2 + 30 x;

plot =
 Show @ Table[
   Plot[f - y, {x, -4 - y/100, 6 - y/100},
    AspectRatio -> 1,
    Axes -> False,
    ImageSize -> 320,
    PlotRange -> {{-6, 6}, {All, 350}},
    PlotStyle -> {Thickness[0.002], col[[RandomInteger[{1, 19}]]]}],
   {y, -200, 800, 10}]

glyphs =
 Grid @ Partition[
   Table[
    ListCurvePathPlot[
      RandomReal[{-5, 5}, {RandomInteger[{2, 4}], RandomInteger[{4, 16}]}],
      AspectRatio -> 1,
      Axes -> False,
      Frame -> False,
      GridLines -> None,
      ImageSize -> 20, 
      PlotStyle -> GrayLevel[0.3]] /. Line :> BSplineCurve,
    112],
   8]

Grid[{{plot, glyphs}}]

enter image description here

Question

My reproduction attempt misses some crucial features. First of all, I couldn't find an equation or translation which would produce the two tight folds. And I don't know how to produce and integrate the hairy structure at the left.

Thank you in advance for your answers and suggestions.

$\endgroup$
5
  • 5
    $\begingroup$ I think your question open ended. Someone will attempt to answer the second part of your question about FF 2004. Then, as already happened in the past, you will suddenly change your mind and accept a solution reproducing another aspect. Please, state clearly in your post what drawing you wish to mimic with MA. Notice also that one reason to close a post is "Needs more focus. This question currently includes multiple questions in one. It should focus on one problem only." $\endgroup$
    – yarchik
    Commented May 1 at 11:15
  • 6
    $\begingroup$ My question clearly states two points ("tight folds") and ("hairy structure"). $\endgroup$
    – eldo
    Commented May 1 at 11:22
  • 3
    $\begingroup$ I am probably a bit too tired, because instead of Tars, Pennsylvania I understood Transylvania... oh well it could have been worse $\endgroup$
    – bmf
    Commented May 1 at 12:18
  • $\begingroup$ So you don't you want an answer for the glyphs section? $\endgroup$ Commented May 2 at 17:16
  • $\begingroup$ I could add the glyphs section myself. I would expect an answer similar to cvgmt's (hairy structure at the left and two tight folds). $\endgroup$
    – eldo
    Commented May 2 at 17:25

4 Answers 4

10
$\begingroup$

The key feature of glyphs section that is missed in OP code is that the artist uses only about 28 different glyphs - he uses them as alphabet a, b, c, .., z plus . and space . In some other artist's works the glyphs represent meaningful text. In this particular work it is just random meaningless text.

(*code for hairs*)

c = RGBColor[#/255] & /@ {{224, 193, 193}, {161, 134, 132}, {107, 78, 
     77}, {163, 187, 180}, {224, 151, 147}, {26, 26, 26}, {122, 163, 
     99}, {151, 194, 131}, {225, 92, 92}, {180, 215, 193}};


data1 = {{3.3, 10}, {4.5, 9.2}, {5.7, 8.3}, {7, 7.5}, {8.2, 
    6.9}, {9.4, 6.7}, {10.7, 7.1}, {11.9, 8.2}, {13.1, 9.6}, {14.4, 
    10.1}, {15.6, 10.1}};
data2 = {{0, 0.5}, {0.4, 1.5}, {0.7, 2.2}, {1, 2.4}, {1.5, 2.4}, {2, 
    2}, {2.3, 1.9}, {2.8, 2.15}, {3.3, 2.2}, {3.8, 2.2}, {4.4, 
    1.9}, {5, 1.1}, {5.6, 0.5}, {6.2, 0.1}, {6.8, 0}, {7.5, 
    0.3}, {8.2, 1}, {8.7, 1.6}, {9, 2}, {9.5, 2.7}, {10, 3.3}};

gra1 = Table[
   BSplineCurve[# + {Interpolation[data1, n], 
        n} & /@ (data2 + {RandomReal[{0, 0.06}, 2], 
        Splice[Table[{0, 0}, Length[data2] - 2]], 
        RandomReal[{0, 0.06}, 2]})], {n, 15.6, 3.3, -0.03}];

gra2 = BSplineCurve[{#[[1]], (#[[1]] + 2 #[[2]])/3 + {0, 3/2} + 
       RandomReal[{-0.5, 0.5}, 2], (2 #[[1]] + 1 #[[2]])/3 + {0, -1} +
        RandomReal[{-0.5, 0.5}, 2], 
      RandomReal[{0, 0.1}, 2] + #[[2]]}] & /@ 
   Transpose[{Table[{Interpolation[data1, n] + 2.9, n + 2.15}, {n, 
       3.3, 15.6, 0.1/10}], # - {4.2, 0} & /@ 
      Table[{Interpolation[data1, n] + 2.9, n + 2.15}, {n, 3.3, 15.6, 
        0.1/10}]}];


hairs = Graphics[{Opacity[
     0.4], {BSplineCurve[
      Table[{Interpolation[data1, n] + 2.9, n + 2.15}, {n, 3.3, 15.6, 
        0.3}]]}, Riffle[RandomChoice[c, Length[gra1]], gra1], 
    Riffle[RandomChoice[c, Length[gra2]], gra2]}, ImageSize -> 500];

(*code for glyphs*)

alphabet = 
  Table[Table[RandomReal[{0, 1}, {RandomInteger[{3, 5}], 2}], 3], 28];

gap = 1.5;

glyphs = Graphics[{MapIndexed[
     Translate[#, 
       gap*QuotientRemainder[#2[[1]] - 1, 
         14]] &, (BSplineCurve /@ (Insert[
         RandomChoice[alphabet, 16*14], {}, Table[{8*14 + 1}, 14]]))],
     Texture[
     ImageTake[ExampleData[{"ColorTexture", "YellowMarble"}], All, 
      30]], Polygon[# + {8*gap + 0.25, 0} & /@ {{0, 0}, {0, 
        13*gap + 1}, {0.5, 13*gap + 1}, {0.5, 0}}, 
     VertexTextureCoordinates -> Automatic]}, ImageSize -> 500];

Row[{hairs, glyphs}]

enter image description here

$\endgroup$
1
  • $\begingroup$ Thanks, azerbajdzan, looks like an art forgery $\endgroup$
    – eldo
    Commented May 5 at 7:07
16
$\begingroup$

Perhaps this is a start. We can find an appropriate 3D surface and view point to sample mesh lines on.

Something like this:

SeedRandom[3];
Plot3D[Sin[x + y^2], {x, -3, 3}, {y, -2, 2}, 
  Mesh -> {0, 200}, MeshStyle -> AbsoluteThickness[3.5], PlotPoints -> 100, 
  Axes -> False, Boxed -> False, PlotStyle -> None, BoundaryStyle -> None, 
  ViewPoint -> {0.06682203171603632`, 1.15070864169298`, 3.1814154771124237`}, 
  ViewVertical -> {-0.05450557476367566`, -0.9386131234012394`, 0.3406384401365345`}, 
  ImageSize -> 1024
] /. l_Line :> {ColorData["WatermelonColors"][RandomReal[{0, 1}]], l}

The RegionFunction option can be fed into Plot3D to restrict the plot domain and give the 'wiggly effect' of the boundary in the artwork.

To get the 'folding' you could Show two 3D plots together.

$\endgroup$
1
  • 1
    $\begingroup$ Thanks, Greg, an interesting alternative $\endgroup$
    – eldo
    Commented May 5 at 7:04
15
$\begingroup$

Method-1

  • We add a pertabation p[x_, y_]= {y*Cos[y], x*Sin[x]} to the identity transformation {x,y}|->{x,y} to get the wave effect.
  • Add another pertabation {RandomReal[{0, .2}], RandomReal[{0, .1}]}*p[x,y]; to get the hairy structure,such construction need to be updated later.
col = ColorData["WatermelonColors"] /@ Subdivide[18];
p[x_, y_] := {y*Cos[y], x*Sin[x]};
F[x_, y_] := {x, y} + .4 p[x, y];
G[x_, y_] := 
  F[x, y] + {RandomReal[{0, .1}], RandomReal[{0, .2}]}*p[x, y];
colors = RandomChoice[col, 19];
{fig1, fig2} = {ParametricPlot[
    Table[F[x, y], {y, Subdivide[-π, π, 18*4]}] // 
     Evaluate, {x, -π, 2 π}, 
    PlotStyle -> Thread[{Thickness[.001], colors}], Axes -> False, 
    ImageSize -> 300], 
   ParametricPlot[
    Table[G[x, y], {y, Subdivide[-π, π, 18*8]}] // 
     Evaluate, {x, -π, 2  π}, 
    PlotStyle -> Thread[{Thickness[.002], Darker /@ colors}], 
    Axes -> False, ImageSize -> 300, 
    RegionFunction -> Function[{x, y, u, v}, u < -.5]]};
Show[fig1, fig2]

enter image description here

Method-2

  • Do not using Table.
  • Change the color ratio.
  • Make the hairs from the same initial points.
  • Set the SplineDegree to make the BezierCurve relatively smoothing.
  • Set two factors {factor1, factor2} to control the scale of the hairs.
Clear["Global`*"];
p[x_, y_] := {y*Cos[y], x*Sin[x]};
F[x_, y_] := {x, y} + .4      p[x, y];
{factor1, factor2} = {.3, .4};
G[x_, y_] := 
  F[x, y] + 
   Boole[x < -.5]*{RandomReal[{0, factor1}], 
     RandomReal[{0, factor2}]}*p[x, y];
col = ColorData["WatermelonColors"] /@ Subdivide[18];
n = 200;
colors = RandomChoice[Join[ConstantArray[1, 18], {3}] -> col, n + 1];
SetOptions[ParametricPlot, PlotStyle -> None, Frame -> False, 
  Axes -> False, BoundaryStyle -> None, ImageSize -> Large, 
  Exclusions -> None];
fig1 := ParametricPlot[
   F[x, y], {x, -π, 2   π}, {y, -π, π}, 
   MeshFunctions -> {#3 &, #4 &}, 
   Mesh -> {{-.5}, Thread[{Subdivide[-π, π, n], colors}]}, 
   MeshStyle -> {Opacity[1], AbsoluteThickness[2]}];
fig2 := ParametricPlot[
   G[x, y], {x, -π, 2   π}, {y, -π, π}, 
   MeshFunctions -> {#4 &}, 
   Mesh -> {Thread[{Subdivide[-π, π, n], Darker /@ colors}]}, 
   RegionFunction -> Function[{x, y, u, v}, u <= -.5], 
   MeshStyle -> {Opacity[1], AbsoluteThickness[1]}];
fig := Show[fig1, 
  Normal[fig2] /. 
   Line[pts_] :> {AbsoluteThickness[2], 
     BezierCurve[pts, SplineDegree -> Length[pts]]}]
fig

enter image description here

  • Animation
ani = ListAnimate[Table[fig, 30]]

enter image description here

Method-3

Try to use the heat equation to spread the wave effect.( propagate a random red wave effect to a random blue wave effect)

Clear["Global`*"];
k = 8;
v00 = .1;
v01 = .2;
data1 = Join[{{0, v00}}, 
   Thread[{Subdivide[0.1, .9, k], RandomReal[{0, .3}, k + 1]}], {{1, 
     0.25}}];
data2 = Join[{{0, v01}}, 
   Thread[{Subdivide[0.1, .9, k], RandomReal[{0, .3}, k + 1]}], {{1, 
     0.15}}];
data3 = Join[{{0, v00}}, 
   Thread[{Subdivide[0.1, .9, k], RandomReal[{0, .1}, k + 1]}], {{1, 
     v01}}];
f = Interpolation[data1, 
   InterpolationOrder -> 6]; (* f[t]  is the heat source on x=0*)
g = Interpolation[data2, 
   InterpolationOrder -> 6];  (* g[t]  is the heat source on x=1*)
h = Interpolation[data3, 
   InterpolationOrder -> 
    6];  (* h[x]  is the heat distribution at t=0*)
Plot[{f[t], g[t]}, {t, 0, 1}, PlotStyle -> {Red, Blue, Green}, 
 PlotRange -> All, AspectRatio -> Automatic]
sol = NDSolve[{D[u[t, x], t] == D[u[t, x], x, x], u[0, x] == h[x], 
    u[t, 0] == f[t], u[t, 1] == g[t]}, u, {t, 0, 1}, {x, 0, 1}, 
   Method -> {"MethodOfLines", 
     "SpatialDiscretization" -> "FiniteElement"}];
viewpoint = {0.1, .5, -.2};
F[x_, y_] := 
  RotationMatrix[{viewpoint, {0, 0, -1}}] . {x, y, 
     u[x, y] /. sol[[1]]} // Most;
{factor1, factor2} = {.05, .05};
G[x_, y_] := 
  F[x, y] + 
   Boole[x < .2]*{RandomReal[{0, factor1}], 
     RandomReal[{0, factor2}]}*(F[x, y] - {x, y});
col = ColorData["WatermelonColors"] /@ Subdivide[18];
n = 200;
colors = RandomChoice[Join[ConstantArray[1, 18], {3}] -> col, n + 1];
SetOptions[ParametricPlot, PlotStyle -> None, Frame -> False, 
  Axes -> False, BoundaryStyle -> None, ImageSize -> Large, 
  Exclusions -> None];
fig1 = ParametricPlot[F[x, y] // Evaluate, {x, 0, 1}, {y, 0, 1}, 
   MeshFunctions -> {#3 &, #4 &}, 
   Mesh -> {{.2}, 
     ReplacePart[
      Thread[{Subdivide[0, 1, n], 
        colors}], {1 -> {0, 
         Directive@{AbsoluteThickness[5], Opacity[1], Red}}, -1 -> {1,
          Directive@{Opacity[1], AbsoluteThickness[5], Blue}}}]}, 
   MeshStyle -> {Opacity[1], AbsoluteThickness[2]}, 
   Method -> {"BoundaryOffSet" -> False}];
fig2 := ParametricPlot[G[x, y], {x, 0, 1}, {y, 0, 1}, 
   MeshFunctions -> {#4 &}, 
   Mesh -> {Thread[{Subdivide[0, 1, n], Darker /@ colors}]}, 
   RegionFunction -> Function[{x, y, u, v}, u <= .2], 
   MeshStyle -> {Opacity[1], AbsoluteThickness[2]}];
fig := Show[fig1, 
  Normal[fig2] /. 
   Line[pts_] :> {AbsoluteThickness[2], 
     BezierCurve[pts, SplineDegree -> 3]}]
fig

enter image description here

$\endgroup$
4
  • 2
    $\begingroup$ I do not see how your solution improve on OP. I think it comes to some unhealthy competition, where some people very quickly post some solutions, and then update it ad infinitum. $\endgroup$
    – yarchik
    Commented May 1 at 11:19
  • 4
    $\begingroup$ @yarchik "Needs to be updated" is just my humble statement, because I have higher requirements for my answer. I won't answer a question without being 120% sure. $\endgroup$
    – cvgmt
    Commented May 1 at 11:24
  • $\begingroup$ Thank you, cvgmt, your answers are a tutorial of advanced graphics $\endgroup$
    – eldo
    Commented May 5 at 7:03
  • $\begingroup$ @eldo excellent question. $\endgroup$
    – cvgmt
    Commented May 5 at 8:07
12
$\begingroup$

Starting with 3 curves (top, bottom, trajectory) and generating the plot from the top curve to the bottom curve along the trajectory.

Using a similar method for generating curves like the one that Daniel Huber used here: Bridget Riley - Movement in Squares and Circles

Update: Dynamically updating the plot based on locators selection:

SeedRandom[1];
DynamicModule[{pts1, pts2, pts3, bf1, bf2, bf3, top, bottom, 
  trajectory, transformation},
 (*Default settings*)   
 (*
 pts1={#,1.5}&/@Subdivide[1,6];
 pts2={#,.75}&/@Subdivide[1,6];
 pts3={#,1}&/@Subdivide[1,6];
 *)
 
 pts1 = {{0.5, 1.11}, {0.52, 1.25}, {0.78, 1.23}, {0.81, 
    1.03}, {1.04, 1.44}, {1.5, 0.83}, {1.68, 1.29}};
 pts2 = {{0.42, 0.29}, {0.55, 0.51}, {0.83, 0.5}, {0.93, 
    0.28}, {1.38, 0.69}, {1.32, 0.07}, {1.73, 0.54}};
 pts3 = {{1.79, 0.84}, {1.41, 1.37}, {.99, 1.42}, {0.59, 
    1.94}, {0.99, 1.71}, {1.66, 1.}, {0.95, 1.51}};
 
 transformation[p1_, p2_, p3_, t_] := (1 - t) p1 + t  p2 + 
   t^2 (1 - t) (p3 - (1 - t^3) p1 - t  p2);    
 
 Column[{
   Row[{
     LocatorPane[Dynamic[pts1], 
      Dynamic[bf1 = BSplineFunction[pts1[[#]] & /@ Range[7]];
       Column[{ParametricPlot[bf1[x], {x, 0, 1}, 
          PlotRange -> {{0, 2}, {0, 2}}, PlotStyle -> Red, 
          ImageSize -> Medium]
         , Dynamic[Style[Round[pts1, .01], Red, Italic, 8]]}]]],
           
     LocatorPane[Dynamic[pts2], 
      Dynamic[bf2 = BSplineFunction[pts2[[#]] & /@ Range[7]];
       Column[{ParametricPlot[bf2[x], {x, 0, 1}, 
          PlotRange -> {{0, 2}, {0, 2}}, PlotStyle -> Green, 
          ImageSize -> Medium]
         , 
         Dynamic[Style[Round[pts2, .01], Darker@Green, Italic, 8]]}]]],
           
     LocatorPane[Dynamic[pts3], 
      Dynamic[bf3 = BSplineFunction[pts3[[#]] & /@ Range[7]];
       Column[{ParametricPlot[bf3[x], {x, 0, 1}, 
          PlotRange -> {{0, 2}, {0, 2}}, PlotStyle -> Blue, 
          ImageSize -> Medium]
         , Dynamic[Style[Round[pts3, .01], Blue, Italic, 8]]}]]]
         }],
     Dynamic[
          top = bf1 /@ Subdivide[1, 30];
          bottom = bf2 /@ Subdivide[1, 30];
          trajectory = bf3;
          Graphics[{
         Table[{Thin, Blend[{Lighter[Red, .2], RandomChoice[
           ColorData["WatermelonColors"] /@ Subdivide[15]]}, 2]
        , BSplineCurve[Table[transformation[top[[i]], bottom[[i]], 
           trajectory[i/Length[top]], t], {i, Length[top]}]]}
          , {t, 0, 1, .003}], 
         Table[{Thin, Opacity[.8], Darker@RandomChoice[{Brown, Purple}]
        , BSplineCurve[Threaded[RandomReal[.03, {2}]] + 
          Table[transformation[top[[i]], bottom[[i]], 
            trajectory[i/Length[top]], t], {i, 1, 16 , 2}]] }
       , {t, 0, 1, .002}]}, ImageSize -> Large]
        ]}]]

enter image description here

enter image description here

Original post:

 Row[{
  Manipulate[(bf1 = BSplineFunction[pts[[#]] & /@ Range[6]];
    ParametricPlot[bf1[x], {x, 0, 1}, PlotRange -> {{0, 2}, {0, 2}}, 
     PlotStyle -> Red, ImageSize -> Medium])
   , {{pts, {#, 1} & /@ Subdivide[1, 5]}, {0, 0}, {2, 2}, Locator}, 
   TrackedSymbols :> {pts}]
  , Manipulate[(bf2 = BSplineFunction[pts[[#]] & /@ Range[6]];
    ParametricPlot[bf2[x], {x, 0, 1}, PlotRange -> {{0, 2}, {0, 2}}, 
     PlotStyle -> Green, ImageSize -> Medium])
   , {{pts, {#, 1} & /@ Subdivide[1, 5]}, {0, 0}, {2, 2}, Locator}, 
   TrackedSymbols :> {pts}]
  , Manipulate[(bf3 = BSplineFunction[pts[[#]] & /@ Range[6]];
    ParametricPlot[bf3[x], {x, 0, 1}, PlotRange -> {{0, 2}, {0, 2}}, 
     PlotStyle -> Blue,  ImageSize -> Medium])
   , {{pts, {#, 1} & /@ Subdivide[1, 5]}, {0, 0}, {2, 2}, Locator}, 
   TrackedSymbols :> {pts}]
  }
 ]

enter image description here

top = bf1 /@ Subdivide[1, 30];
bottom = bf2 /@ Subdivide[1, 30];
trajectory = bf3;
transformation[p1_, p2_, p3_, t_] :=
  (1 - t) p1 + t p2 + t^2 (1 - t) (p3 - (1 - t^3) p1 - t  p2)
 Graphics[{
  Table[{Thin, RandomChoice[ColorData["WatermelonColors"] /@ Subdivide[12]]
    , BSplineCurve[
        Table[transformation[top[[i]], bottom[[i]], trajectory[i/Length[top]], t]
    , {i, Length[top]}]]} , {t, 0, 1, .003}]
  , Table[{Thin, RandomChoice[{Brown, Black}]
    , BSplineCurve[
       Threaded[RandomReal[.05, {2}]]
        + Table[transformation[top[[i]], bottom[[i]], trajectory[i/Length[top]], t]
    , {i, 1, 12}]] }, {t, 0, 1, .002}]
  }]

enter image description here

Using a slightly different transformation:

transformation[p1_, p2_, p3_, t_] := 
  (1 - t)  p1 + t^1.5  p2 + t^2  (1 - t)  (p3 - (1 - t^3)  p1 - t   p2)

enter image description here

$\endgroup$
2
  • $\begingroup$ Thanks you, vindobina, for another great answer $\endgroup$
    – eldo
    Commented May 5 at 7:05
  • $\begingroup$ Thanks again, eldo, for this excellent series of math-art questions. That's a great opportunity for learning about new aspects/relationships between art and math. $\endgroup$
    – vindobona
    Commented May 5 at 8:23

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.