Drawing picture with straight lines (Petros Vrellis's Art)

Question

I am trying to extend Writing a word with straight lines for any picture/image. I guess the basic idea is to find a set of points in the image region and then draw random lines through them. Let's start with a simple example.

img = Import["http://cdn-4.freeclipartnow.com/d/6429-1/horse-head-simple-sketch.jpg"]
pts = PixelValuePositions[Binarize[img], Black];
pts1 = {#, RandomChoice[pts]} & /@ pts;
pts1 = Select[pts1, 10 < EuclideanDistance @@ # < 50 &];
npts1 = Length[pts1]
Graphics[{[email protected], Line[{100 #2 - #, 100 # - #2}] & @@@ pts1}]

Not good, but still a horse.

---

Petros Vrellis's Art

Thanks to Dunlop for sharing the link. I think it would be a neat work if the drawing can be presented in Petros Vrellis art form.

cen = Mean[pts1] // Round
pts1 = (# - cen) & /@ pts1;
npts1 = Length[pts1]

Now knit it on a circle

cp = {x, y} /. Solve[x^2 + y^2 == r^2 && y == m x + c, {x, y}] ;
circlepoint[{{x1_, y1_}, {x2_, y2_}}, r_] = cp /. {m -> (y2 - y1)/(x2 - x1 + 0.00001),
                                            c -> (y2 x1 - y1 x2)/(x1 - x2 + 0.00001)};

Graphics[{[email protected], Line[circlepoint[#, 200]] & /@ RandomChoice[pts1, 1000]}]

---

Now let's take a masterpiece.

(*img = Import["https://upload.wikimedia.org/wikipedia/commons/thumb/e/ec/Mona_Lisa,_by_Leonardo_da_Vinci,_from_C2RMF_retouched.jpg/687px-Mona_Lisa,_by_Leonardo_da_Vinci,_from_C2RMF_retouched.jpg"];
img = ImageTake[img, {80, 480}, {150, 550}]*)

img = Import["https://i.sstatic.net/TvEzF.png"];

To reduce the number of points, I start with the edges.

center = Round[ImageDimensions[img]/2]
radius = Norm[center + 10]

pts = PixelValuePositions[EdgeDetect[img, 10], White, 0.02];
pts = (# - center) & /@ pts;
ListPlot[pts, AspectRatio -> 1]

pts1 = {#, Last[Nearest[pts, #, 30]]} & /@ pts;
Length[pts1]
pts1 = RandomChoice[pts1, 1000];
Graphics[{[email protected], Line[circlepoint[#, radius]] & /@ pts1}]

Another approach with small lines:

img1 = ColorConvert[img, "GrayScale"];

pts0 = PixelValuePositions[img1, GrayLevel[#], 0.02] & /@ {0.1, 0.3, 0.5};
ListPlot[%, AspectRatio -> 1]
Show@Table[
pts1 = {#, RandomChoice[pts]} & /@ pts;
pts1 = Select[pts1, 10 < EuclideanDistance @@ # < 50 &];
Graphics[{[email protected], Line[{100 #2 - #, 100 # - #2}] & @@@ pts1}]
, {pts, pts0}]

Not good! Maybe I can change the opacity to create the effect of different shading for sets to make it better. A little improvement can be made by choosing the second point of the line within Nearest

pts1 = {#, Last@Nearest[pts, #, 30]} & /@ pts;

but that does not make it any good, and it is quite slow as well.

Now the question - How to make it better such that the final image looks more like the main image.

Answer 1

radon = Radon[ColorNegate@ColorConvert[img, "Grayscale"]]

{w, h} = ImageDimensions[radon];
lhalf = Table[N@Sin[π i/h], {i, 0, h - 1}, {j, 0, w - 1}];
inverseDualRadon = 
  Image@Chop@InverseFourier[lhalf Fourier[ImageData[radon]]];
k = 50;
lines = ImageApply[
  With[{p = Clip[k #, {0, 1}]}, RandomChoice[{1 - p, p} -> {0, 1}]] &,
   inverseDualRadon]

ColorNegate@
 ImageAdjust[
  InverseRadon[lines, ImageDimensions[img], Method -> None], 
  0, {0, k}]

Answer 2

Abstractly, you might consider using the Radon transform in some way.

It is closely related to what you are looking for mathematically:

I would first simplify the image considerably before working with it:

simpler = MeanShiftFilter[monalisa, 2, .05, MaxIterations -> 100]

We then want to make it grey and run InverseRadon on it (after switching black with white unless you want to do white thread on a black background)

toPoints = 
 InverseRadon[ColorNegate@ColorConvert[simpler, "GrayScale"]]

We can then binarize the image. This is like choosing some points to represent lines we will draw. Then we use the Randon Transform to bring it back into an image.

ImageAdjust@ColorNegate@Radon@Binarize[toPoints]

So the job here is to turn this into something concrete where you can get the actual lines. You'll probably want to do some kind of discrete version of this.

Answer 3

I think the coolest thing would be to write a genetic algorithm approach like this guy's where you would start with a random set of lines with coordinates that change in a way that "evolves" and let it do its thing.

The next best thing would be to look for a builtin and ImageLines kinda works here.

try = EdgeDetect[GaussianFilter[ColorConvert[img, "GrayScale"], 3], 4];
Graphics@({Opacity[.04], Line@#} & /@ ImageLines[try, .06, .004])

I say "kinda" because both the image I produced and the results of my experimentation with the function look more like a girl-ghost from a Korean horror film than a masterpiece depicting a dame with an ambiguous smile. Having said that, with some experimentation you might find a good combination of feature extraction before applying ImageLines and I am guessing that's the right direction.