Artistic image vectorization

Question

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.

Answer 1

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}

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]

Answer 2

Let's get a low-res image:

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", %]

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] 

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]

Answer 3

Take an image:

Grayscale, flip, and smooth it:

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

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

Make it as big as you please:

Export["sw.png", lcp, ImageSize -> 1280]

Answer 4

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

Some more examples:

One can then save the image for printing:

gfx = bubbled[img, 2, 3, 1]
Export[NotebookDirectory[] <> "gfx.pdf", gfx]

Answer 5

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

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

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

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

Answer 6

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=

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]

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]

And one more image I love the most:

It was made from this image.

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

Answer 7

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}

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]

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...

Answer 8

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 =

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

Apologies if this image has copyright implications...