38
$\begingroup$

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

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[{[email protected], 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["https://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;
Length[pts1]
pts1 = RandomChoice[pts1, 1000];
Graphics[{[email protected], 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]
Show@Table[
pts1 = {#, RandomChoice[pts]} & /@ pts;
pts1 = Select[pts1, 10 < EuclideanDistance @@ # < 50 &];
Graphics[{[email protected], 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.

Improve this question
$\endgroup$
9
  • 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, 2016 at 12:54
  • $\begingroup$ Thanks, @Dunlop, that was really interesting. I am going to modify my question based on that. $\endgroup$
    – Sumit
    Sep 12, 2016 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, 2016 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, 2016 at 16:34
  • $\begingroup$ @Rahul take a look at the documentation for Radon. You'll see it's InverseRadon. $\endgroup$
    – Searke
    Sep 12, 2016 at 16:36

3 Answers 3

Reset to default
33
$\begingroup$ 
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}]] &,
   inverseDualRadon]

enter image description here

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

enter image description here

Improve this answer
$\endgroup$
3
  • 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, 2016 at 14:58
  • $\begingroup$ @Sumit: Yes, exactly what you said. But I have no more free time to do it... $\endgroup$
    – user484
    Sep 13, 2016 at 15:18
  • 3
    $\begingroup$ An explanation for how this method works is now here. $\endgroup$
    – user484
    Sep 17, 2016 at 8:11
11
$\begingroup$

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]

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.

Improve this answer
$\endgroup$
2
  • $\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, 2016 at 10:16
  • $\begingroup$ It looks like wall relief... $\endgroup$
    – J. M.'s missing motivation ♦
    Oct 2, 2016 at 4:00
9
$\begingroup$

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.

Improve this answer
$\endgroup$
1
  • 2
    $\begingroup$ If participation of active users drops in seven days may god have mercy on our souls. $\endgroup$
    – Sascha
    Sep 13, 2016 at 18:53

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.