Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

The question is how can we use Mathematica to create vectorized versions of low-resolution images? The goal is to get an image suitable for quality printing at any resolution.

Since "true" vectorization performed by various specialized software is a tough problem, I suggest to consider "artistic" approaches, which produce inexact, but beautiful version of the original. Colored implementations are highly appreciated.

share|improve this question
1  
This is also built into Inkscape: load the rose image (e.g.), go to Path > Trace Bitmap > Mode > Multiple scans and select (e.g.) color. –  Jens Jul 20 '12 at 0:07
    
By "vectorization" he probably meant that in Mathematica image data will be put into graphics primitives. I think the keyword here is "Artistic" though ;-) - meaning you can play with those graphics primitives. –  Vitaliy Kaurov Jul 20 '12 at 1:37
add comment

8 Answers

up vote 25 down vote accepted

This vectorisation attempts to represent the image with coloured triangles. The code selects a user defined number of sample points, with the selection weighted according to the image gradient, to obtain finer sampling in more detailed regions of the image. I use ListPlot3D to triangulate the sample points into a set of polygons - there is probably a neater way. The output from ListPlot3D is stripped of the third dimension and VertexColors are applied to the polygons based on the image colour at the sample points.

vectorise[img_,pts_]:=Module[{w,h,weights,points,plot,coords,polys,vcols},
{w,h}=ImageDimensions@img;
weights=Flatten@Transpose@ImageData[GradientFilter[img,2]];
points=Join[RandomSample[weights->Tuples[Range/@{w,h}],pts],{{1,1},{w,1},{1,h},{w,h}}];
plot=ListPlot3D[points/.{a_,b_}:>{a,b,0},InterpolationOrder->1,Boxed->False,Mesh->False,Axes->False,BoundaryStyle->None];
coords=plot[[1,1,All,;;2]]/.{a_,b_}:>{a,h+1-b};
polys=plot[[1,2,1,1,2,1,1,1]];
vcols=ImageValue[img,#]&/@coords;
Graphics[{GraphicsComplex[coords,Polygon[polys],VertexColors->vcols]}]]

Example:

img = ImageResize[ExampleData[{"TestImage", "Lena"}], 200];
vectorise[img, #] & /@ {100, 1000, 10000}

enter image description here

Having vectorised the image we can do silly things with the graphics:

rand=RandomReal[{-20,20},{10004,2}];
pic=vectorise[img,10000];
Export["fragmentlena.gif",Table[MapAt[#+rand (1-Cos[t])^2&,pic,{1,1,1}],{t,2\[Pi]/40,2\[Pi],2\[Pi]/40}],ImageSize->200,"DisplayDurations"->0.05,AnimationRepetitions->Infinity]

enter image description here

share|improve this answer
1  
A big +1! Gradient polygon coloring gives an extraordinary result, and the speed is impressive. This is the most profound approach so far, IMO. –  faleichik Jul 22 '12 at 18:09
add comment

Let's get a low-res image:

enter image description here

And put in in gray-scale mode:

gimg = ColorConvert[ImageResize[
        Import["http://i.stack.imgur.com/wtgxH.jpg"], 300], "Grayscale"];

Now extract the image data (pixel values) together with pixel indexes:

data = MapIndexed[Append[#2, #1] &, ImageData[gimg], {2}];

I, of course, couldn't pass on Voronoi styling. We will add random noise to perfectly integer pixel coordinates and make a mosaic animation:

Table[Rotate[ListDensityPlot[(MapThread[Append, {3 RandomReal[{-1, 1}, {Length[#], 2}], 
      ConstantArray[0, Length[#]]}] + #) &@Flatten[Transpose@data, 1][[1 ;; -1 ;; 15]], 
    InterpolationOrder -> 0, ColorFunction -> "GrayTones", 
    BoundaryStyle -> Directive[Black, Opacity[.2]], Frame -> False, 
    PlotRangePadding -> 0, AspectRatio -> Automatic, ImageSize -> 600], -Pi/2], {10}];

Export["test.gif", %]

enter image description here

And various outlandish coloring

Grid[Partition[Rotate[ListDensityPlot[(MapThread[
           Append, {3 RandomReal[{-1, 1}, {Length[#], 2}], 
            ConstantArray[0, Length[#]]}] + #) &@
       Flatten[Transpose@data, 1][[1 ;; -1 ;; 45]], 
      InterpolationOrder -> 0, ColorFunction -> #, 
      BoundaryStyle -> Directive[Black, Opacity[.2]], Frame -> False, 
      PlotRangePadding -> 0, AspectRatio -> Automatic, 
      ImageSize -> 300], -Pi/2] & /@ {"CherryTones", "CoffeeTones", 
    "DarkRainbow", "DeepSeaColors", "PlumColors", "Rainbow", 
    "StarryNightColors", "SunsetColors", "ValentineTones"}, 3], 
 Spacings -> 0] 

enter image description here

If we fix the noise sampling with SeedRandom and change only magnitude of the noise, we can create a sort of order-from-chaos appearance effect:

id = ParallelTable[Rotate[ListDensityPlot[(MapThread[
          Append, {SeedRandom[1]; 
           200 (1 - st^(1/8)) RandomReal[{-1, 1}, {Length[#], 2}], 
           ConstantArray[0, Length[#]]}] + #) &@
      Flatten[Transpose@data, 1][[1 ;; -1 ;; 15]], 
     InterpolationOrder -> 0, ColorFunction -> GrayLevel, 
     BoundaryStyle -> Opacity[.1], Frame -> False, 
     PlotRangePadding -> 0, AspectRatio -> Automatic, 
     ImageSize -> 350], -Pi/2], {st, 0.2, 1, .05}];

idd = id~Join~Table[id[[-1]], {7}];

Export["appear.gif", idd, ImageSize -> 350]

enter image description here

share|improve this answer
2  
This is a viable alternative to my interpretation of the question. +1 –  Mr.Wizard Jul 20 '12 at 6:07
1  
love your Voronoism! –  cormullion Jul 20 '12 at 8:25
    
Great job! Vitaliy, is it possible to take cell colors from the original color image?... Also, I would suggest to use data = MapIndexed[#2~Join~{#1} &, ImageData[gimg], {2}]; –  faleichik Jul 21 '12 at 9:50
    
@faleichik Thanks! Yes it is possible "to take cell colors from the original color image". ListDensityPlot produces graphics based on Polygon all of which can be extracted and put together with RGBColor function that was mapped on original ImageData. It's a bit tedious though ;) And good tip on Join - I use it myself when speed counts. See this on details how to extract polygons: alturl.com/hcbdv –  Vitaliy Kaurov Jul 24 '12 at 8:22
2  
@VitaliyKaurov very nice! Suggestion: For copy&paste&evaluate purposes it would be more comfortable if your image were imported via some URL. –  Yves Klett Jul 24 '12 at 9:04
show 5 more comments

Let me start from an approach which I believe has its own name, but unfortunately I don't know it. The idea is to generate circles whith radii depending on the intensity of corresponding and surrounding pixels.

img = Import["ExampleData/rose.gif"];
bubbled[img_, r_, delta_, rmax_] := 
  Block[{ker, data, radii, thresh = 0.99},
   ker = N[#/Total@Total@#] &@DiskMatrix[r];
   data = Map[Mean, ImageData[ImageConvolve[img, ker]], {2}];
   radii = Partition[data, {1, 1}, delta] /. {{a_?NumberQ}} -> a;
   Graphics@
    MapIndexed[If[#1 < thresh, Disk[#2, rmax Max[1 - #1, 0]]] &, 
     Reverse /@ (Transpose@radii), {2}]
   ];
is = 360;
Manipulate[
 Row[Show[#, ImageSize -> is] & /@ {img, bubbled[img, r, d, rmax]}],
 {{r, 1, "Smooth radius"}, 1, 10, 1, ControlType -> Setter},
 {{d, 3, "Offset"}, 1, 10, 1, ControlType -> Setter},
 {{rmax, Sqrt[2.]/2, "Maximum radius"}, 0.5, 1, 0.05}
 ]

enter image description here

Some more examples:

enter image description here

enter image description here

One can then save the image for printing:

gfx = bubbled[img, 2, 3, 1]
Export[NotebookDirectory[] <> "gfx.pdf", gfx]
share|improve this answer
    
One thing which I don't like is radii = Partition[data, {1, 1}, delta] /. {{a_?NumberQ}} -> a; I guess Flatten must be used here, but levelspecs are still a mystery for me. –  faleichik Jul 19 '12 at 22:53
7  
1  
@faleichik nice answer! Flatten[Partition[data, {1, 1}, delta], {{1}, {2, 3, 4}}] is what you're looking for, I think. –  Oleksandr R. Jul 20 '12 at 12:53
    
Brett, thank you, I didn't suspect it to be so simple :-) Many thanks to Oleksandr as well! I would never come to this myself... Need to make myself study the corresponding thread here on mma.se. –  faleichik Jul 21 '12 at 9:23
add comment

Take an image:

1

Grayscale, flip, and smooth it:

j = CurvatureFlowFilter[ImageReflect[ColorConvert[i, "Grayscale"]]]

2

Then let ListContourPlot do all the work!

lcp = ListContourPlot[ImageData[j], Frame -> False, Contours -> Table[p, {p, 0, 1, 0.025}],
  ColorFunction -> "GrayTones", ContourStyle -> None, PlotRange -> {0, 1}]

3

Make it as big as you please:

Export["sw.png", lcp, ImageSize -> 1280]
share|improve this answer
1  
You can use the DataReversed option to ImageData and avoid reflecting the image. (+1 BTW) –  Szabolcs Jul 20 '12 at 23:52
add comment

The following approach was suggested by cormullion in his answer, namely it is "spiral engraving". The idea is to approximate the image by short lines arranged in a spiral. The main issue is the lines lengths: they should depend on the spiral curvature and on the image details. I decided to implement this by extracting points from ParametricPlot and then spliting the lines which are longer than maxlen. Then each line is drawn with fradient colors from the corresponding pixels of the original image.

img=enter image description here

ptsSpiral[d_, tmax_, maxlen_] := Block[{pts, prev},
   (*
   d - the spiral "density",
   tmax - determines spiral length,
   maxlen - maximum line length in resulting splitting 
   *)
   pts = ParametricPlot[d # {Sin@#, Cos@#} &[t], {t, 0, tmax}, 
      PlotPoints -> 100][[1, 1, 3, 2, 1]];
   prev = pts[[1]];
   Reap[Scan[(
        If[(len = Norm[# - prev]) <= maxlen, Sow@#,
         Sow /@ 
          Most@Transpose[
            Range[prev, #, (# - prev)/Ceiling[len/maxlen]]]
         ]; prev = #) &
      , pts]
     ][[2, 1]]
   ];

spiralify[img_, pts_, th_] := Block[{c},
   c = ImageDimensions@img/2;
   Graphics[{AbsoluteThickness[th], 
     Line[pts, VertexColors -> ImageValue[img, c + # & /@ pts]]}]
   ];

img = ImageResize[img, {Automatic, 200}]
pts = ptsSpiral[0.25, 380, 2];
Show[spiralify[img, pts, 2], ImageSize -> 400]

enter image description here

Next thing we can try is to play with thickness rather than color: we draw black line with thickness depending on the intensity of corresponding pixels.

engrave[img_, pts_, maxth_] := Block[{c},
   c = (ImageDimensions@img)/2;
   Graphics[{CapForm[
      "Round"], {AbsoluteThickness[
         maxth (1 - Mean@ImageValue[img, #])], Line@#} & /@ 
      Partition[# + c & /@ pts, 2, 1]}]
   ];
pts = ptsSpiral[0.25, 399, 1];
engrave[ColorConvert[img, "Grayscale"], pts, 4]

enter image description here

And one more image I love the most:

enter image description here

It was made from this image.

And finally I must apologize for the second self-answer here...

share|improve this answer
2  
Why apologize for a self-answer, especially one inspired by another answer? SE explicitly encourages self-answers, so don't worry about it. +1 –  rcollyer Jul 25 '12 at 1:35
    
This is lovely! –  Yves Klett Jul 25 '12 at 6:30
    
That's really excellent - the last one is especially effective! –  cormullion Jul 25 '12 at 6:33
add comment

This is from an old notebook of mine. The girl from Ipanema, composed of 35,000 points. (Note true pointillism, perhaps someone can do that one as well.) Sorry about the messy code and the slow processing.

The idea is to randomly scatter disks in a rectangle, and colour them according to the corresponding points of the photo. More points with a higher density are used in regions of high detail or sharp transitions, fewer points elsewhere (to keep their number down).

img = Import["http://farm1.staticflickr.com/125/409696380_05f5c89a37_b_d.jpg"]

The Girl from Ipanema

etf = EntropyFilter[img, 12] // ImageAdjust
sdf = ColorConvert[StandardDeviationFilter[img, 5], "GrayScale"] // ImageAdjust
map = ImageAdd[sdf, etf] // ImageAdjust

Point size map

mapdata = ImageData[map];
data = ImageData[img];

{w, h} = ImageDimensions[img];

ch = RandomChoice[
         (Flatten[mapdata] + 0.1)^1.7 -> Join @@ Table[{i, j}, {i, h}, {j, w}], 
         35000];

spots = {data[[#1, #2]], {#2, -#1}, 15 (1.1 - mapdata[[#1, #2]])^1.8} & @@@ ch;
spots = Reverse@SortBy[spots, Last];

Graphics[{RGBColor[#1], Disk[#2, #3]} & @@@ spots,
 Background -> GrayLevel[0.75],
 PlotRange -> {{1, w}, {1, -h}}
]

Mathematica graphics

Another example (unfortunately I lost the original source photo and it's not as easy to google up as the other one above):

Mathematica graphics

share|improve this answer
4  
Your Google-fu is weak. Or maybe it only finds bikini... –  Mr.Wizard Jul 20 '12 at 9:01
    
@Mr.Wizard Did you search for the image itself? I forgot completely about that. I did this some 3 years ago, and I remember trying to find the big cat picture again, but I didn't manage at that time. –  Szabolcs Jul 20 '12 at 9:18
6  
I think I chose the wrong image for my answer ... :) –  cormullion Jul 20 '12 at 10:01
1  
@cormullion Not too late to change it though:) –  Ajasja Jul 20 '12 at 11:46
1  
@cormullion I´d second the motion to change ;-) –  Yves Klett Jul 20 '12 at 12:15
show 1 more comment

Well, this is really, really inefficient, but there you go:

comp = WatershedComponents[img, Method -> "Rainfall"];

imdat = ImageData[img];

colorrectangle[n_] := 
 With[{pos = Position[comp, n]}, {RGBColor[
    Mean[imdat[[Sequence @@ #]] & /@ pos]], 
   Rectangle[{#[[2]], -#[[1]]}] & /@ pos}]

newimg = Graphics[
   colorrectangle /@ 
    Range[Length[comp // Flatten // DeleteDuplicates]]];

Show[#, ImageSize -> 200, PlotRangePadding -> 0] & /@ {img, newimg}

Mathematica graphics

WatershedComponents returns the segements which are brute-forced to Rectangles and colored with the mean of the segment pixels in the image.

More effective renderingwise:

colorep[n_] := 
 With[{pos = Position[comp, n]}, 
  n -> RGBColor[Mean[imdat[[Sequence @@ #]] & /@ pos]]]

reps = Flatten[
    colorep /@ Range[Length[comp // Flatten // DeleteDuplicates]]] // 
   Dispatch;

ArrayPlot[comp, ColorRules -> reps, PlotRangePadding -> 0]

Mathematica graphics

It would be even better to get a vector outline of the segments and represent them as polygons. Then you´d get away from the 8-bit Nintendo look...

share|improve this answer
    
Do you know about this? wolfram.com/xid/0puzjr13y6-xn45v9 –  Vitaliy Kaurov Jul 20 '12 at 14:49
    
@VitaliyKaurov I knew it was somewhere ;-) Started on a vectorization idea but did not get to the end (yet). Still thought it might be worth putting it here in (potentially) intermediate state. –  Yves Klett Jul 22 '12 at 18:13
add comment

In this attempt, each row of the image is drawn as a polygon, like a mountain range, with the peaks and troughs controlled by the pixel values of the image data. These polygons are (clumsily) constructed and stacked one of top of the other. The idea is echoing the old artist engravers of earlier centuries, who used the varying thickness of engraved lines to suggest tone. Somewhere I've got an abandoned attempt at a spiral engraving thing like the work of some guy called Mellan.

i = enter image description here

im = ImagePad[i, 1, White]
{width, height} = ImageDimensions[im];
pixelData = Reverse[ImageData[im]];

rowToLine[r_, c_, amplitude_] := {
   firstPos = pixelData[[r]][[1]];
   (* add last point to complete polygon *)
   {Insert[
     Polygon[
      Partition[
       (* x coords are 1 to width, 
          y coords are row height + pixel value * amplitude *)
       Riffle[
        Range[1, c], r + (amplitude * pixelData[[r]])], 2]],
     {c, r + (amplitude * firstPos)}, 
     {1, -1}]}};

Manipulate[g = Graphics[{Opacity[opacity],
    EdgeForm[AbsoluteThickness[thickness]],
    face,
    Table[{rowToLine[row, width, x]}, {row, 1, height, step} ]}, 
   ImageSize -> 500],
  {x, 0, 5, 1}, 
 {{thickness, 0.1}, 0.1, 2},
 {step, 1, 12, 1}, 
 {{opacity, .5}, 0.1, 1}, 
 {face, Blue}]

manipulate

Apologies if this image has copyright implications...

share|improve this answer
13  
This face is copyrighted. You'll have to replace it with a non-hyperbolic heptagon to avoid being sued. –  rm -rf Jul 20 '12 at 14:12
1  
Could you explain the algorithm? –  rcollyer Jul 21 '12 at 20:00
    
@rcollyer good thinking, added context –  cormullion Jul 22 '12 at 9:38
1  
My, +1, then. I'd like to see if you could get the spiral engraving working, too. –  rcollyer Jul 22 '12 at 12:55
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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