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[{Opacity@0.2, Line[{100 #2 - #, 100 # - #2}] & @@@ pts1}]

enter image description here

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[{Opacity@0.2, Line[circlepoint[#, 200]] & /@ RandomChoice[pts1, 1000]}]

enter image description here

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["http://i.stack.imgur.com/TvEzF.png"];

enter image description here

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;
pts1 = RandomChoice[pts1, 1000];
Graphics[{Opacity@0.2, Line[circlepoint[#, radius]] & /@ pts1}]

enter image description here enter image description here

Another approach with small lines:

img1 = ColorConvert[img, "GrayScale"];

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

enter image description here enter image description here

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.

  • 2
    $\begingroup$ This is not an answer. But if you check out the work of the artist Petros Vrellis (artof01.com/vrellis/works/knit.html) it could be interesting as he uses algorithms to produce similar images from chords inside a circle. $\endgroup$ – Dunlop Sep 12 '16 at 12:54
  • $\begingroup$ Thanks, @Dunlop, that was really interesting. I am going to modify my question based on that. $\endgroup$ – Sumit Sep 12 '16 at 14:37
  • $\begingroup$ There are many ways of doing this. If I had to be clever about this, maybe I would consider looking into the Radon transform which maps lines to points $\endgroup$ – Searke Sep 12 '16 at 16:26
  • $\begingroup$ @Searke: I was just looking into that. The map from distributions on lines to the resulting intensities on points is the dual Radon transform, so what we want is probably its inverse. Hmm, Ctrl+F "dual", not found... $\endgroup$ – user484 Sep 12 '16 at 16:34
  • $\begingroup$ @Rahul take a look at the documentation for Radon. You'll see it's InverseRadon. $\endgroup$ – Searke Sep 12 '16 at 16:36
radon = Radon[ColorNegate@ColorConvert[img, "Grayscale"]]

enter image description here

{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}]] &,

enter image description here

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

enter image description here

  • 1
    $\begingroup$ That's great @Rahul. Now the stupid question - since it is a bunch of straight lines, is it possible to get any information about the lines - coordinates, equation - anything? I guess something can be done by using individual white point of lines and using an inverse transformation rule. $\endgroup$ – Sumit Sep 13 '16 at 14:58
  • $\begingroup$ @Sumit: Yes, exactly what you said. But I have no more free time to do it... $\endgroup$ – user484 Sep 13 '16 at 15:18
  • 3
    $\begingroup$ An explanation for how this method works is now here. $\endgroup$ – user484 Sep 17 '16 at 8:11

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.


enter image description here

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.

  • $\begingroup$ Thanks, @Searke. This is really nice (and serial I would say). Well, I don't know anything about Radon, so I am not sure how to transform those line into straight lines. Any suggestion? $\endgroup$ – Sumit Sep 13 '16 at 10:16
  • $\begingroup$ It looks like wall relief... $\endgroup$ – J. M.'s torpor Oct 2 '16 at 4:00

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

enter image description here

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.

  • 2
    $\begingroup$ If participation of active users drops in seven days may god have mercy on our souls. $\endgroup$ – Sascha Sep 13 '16 at 18:53

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.