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.

Yesterday the hedcut style was brought up in chat. How can we create a hedcut-like style automatically in Mathematica, using a photograph as a starting point?

I am looking to create a similar artistic feel, not necessarily reproduce the hedcut style precisely.

Relevant resources:

Sample portraits to work with:

@Silvia's idea from yesterday:

 GaussianMatrix[2.7], Method -> "TSVD"]

Mathematica graphics Mathematica graphics

My own failed first attempt (the part that detect line directions may be useful to people who work on answers):

Mathematica graphics Mathematica graphics

img = Import[

(* "Real" images support negative numbers---for convenience *)

img = Image[ColorConvert[img, "GrayLevel"], "Real"];
img = ImageRotate[img, Right];

(* horizontal and vertical components of the gradient;
   the direction can be computed using ArcTan *)
gv = ImageCorrelate[img, ( {
     {0, -1, 0},
     {0, 0, 0},
     {0, 1, 0}
    } )];
gh = ImageCorrelate[img, ( {
     {0, 0, 0},
     {1, 0, -1},
     {0, 0, 0}
    } )];

g = GradientFilter[img, 1];

(* verify the number of white pixels in Binarize[g] *)
Count[ImageData@Binarize[g], 1, Infinity]

(* create small strokes along the outlines *)
outline = 
 With[{point = RandomChoice[Position[ImageData@Binarize[g], 1], 1500]},
    Rotate[Disk[#1, {4, 1}], #2] &,
     ArcTan @@@ 
      Transpose[{Extract[ImageData[gh], point], 
        Extract[ImageData[gv], point]}]}

(* try to tone down plain grey/dark backgrounds *)
detail = ImageAdjust@
   ImageMultiply[ColorNegate@ImageAdjust@EntropyFilter[img, 15], 2]]

coords = Outer[List, #2, #1] & @@ Range /@ ImageDimensions[img];

fill = With[{point = 
     Join @@ ImageData@ImageClip@ColorNegate[detail] -> 
      Join @@ coords, 5000]},
    Rotate[Disk[#1, {3, 0.8}], #2] &,
     ArcTan @@@ 
      Transpose[{Extract[ImageData[gh] + 10 $MachineEpsilon, point], 
        Extract[ImageData[gv], point]}]}

Show[fill, outline]

Note: I'm not fond of Putin, but his portrait I linked to seems to be easier to handle than some others.


Second attempt, based on @Silvia's suggestion to try ContourPlot and wxffles's image vectorization approach. It's better, but still not achieving that feel.

Mathematica graphics

img = Import["http://i.stack.imgur.com/YajUp.jpg"]

baseimg = 
  ColorConvert[ImageReflect@CurvatureFlowFilter[img], "GrayScale"];

(* Here we could simply use 


but the following approach gives a better balanced image *)

if = Interpolation[ImageLevels[baseimg]];

cif = Derivative[-1][if];

cifmax = cif[1];

f[x_] := cif[x]/cifmax

ct = Block[{x},
   x /. First@FindRoot[f[x] == p, {x, 0.5, 0, 1}], {p, 0, 1, 0.02}]

lcp = ListContourPlot[ImageData[baseimg], Frame -> False, 
  Contours -> ct, 
  ContourStyle -> (Dashing[{#, 1/50}] &) /@ ((1 - ct)/50), 
  PlotRange -> {0, 1}, AspectRatio -> Automatic, 
  ContourShading -> None]
share|improve this question
Hey, that's Feynman! :-) –  stevenvh Jul 25 '12 at 9:33
Surely you must be joking, Mr stevenvh ? –  TomD Jul 25 '12 at 10:39
I like the failed attempt on Putin! –  gogoolplex Jul 25 '12 at 14:53
I think the hardest part for generating a hedcut is to find a way to reflect the natural texture. I think it's indeed a big challenge, maybe some AI methods are needed? For example a human face, in order to find "good" texturization, maybe it is necessary to construct a 3D face model from the original picture. –  Silvia Jul 25 '12 at 15:51

5 Answers 5

up vote 37 down vote accepted

In this answer I've tried to use different shading styles for different graylevels in the image. First load the image, convert to grayscale, and get its dimensions.

img = ColorConvert[Import["UZg4t.jpg"], "Grayscale"];
dim = ImageDimensions[img];

The next step is to create different shading styles.The example hedcut image uses dots and lines for shading, so that's what we'll use. Here I've shamelessly stolen code from R.M's answer for the dot pattern. I use a set of black dots, and also a set of gray ones. I've also created sets of wavy horizontal and vertical lines in the same style. The parameter di controls the dot interval - larger values will result in more spaced out dots and lines. We will also need parts of the image in solid white and solid black, so the last two lines create graphics for those.

di = 4;  (* di is the dot interval *)
gr[x__] := Graphics[x, ImageSize -> dim, PlotRangePadding -> 0];
dots = gr @ Table[{Disk[{Clip[i + 2 Sin[16 Pi j/#2], {1, #1}], Clip[j + 2 Sin[16 Pi i/#1],
 {1, #2}]}, 1]}, {i, 1., #1, di}, {j, 1., #2, di}] &@@ dim;
paledots = gr @ {GrayLevel[0.7], dots[[1]]};
hlines = gr @ Table[Line[Table[{Clip[i + 2 Sin[16 Pi j/#2], {1, #1}], Clip[j + 2 Sin[16 Pi i/#1],
 {1, #2}]},{i, 1., #1, di}]], {j, 1., #2, di}] &@@ dim;
vlines = gr @ Table[Line[Table[{Clip[j + 2 Sin[16 Pi i/#1], {1, #2}], Clip[i + 2 Sin[16 Pi j/#2],
 {1, #1}]},{i, 1., #1, di}]], {j, 1., #2, di}] &@@ Reverse[dim];
black = gr[{}, Background -> Black];
white = gr[{}, Background -> White];

Next we need to create images from these graphics corresponding to 7 shades from black to white. The darkest shade is pure black. The next lightest shade after black is cross-hatching (both vertical and horizontal lines) plus dots, the next is just cross hatching without the dots, then just horizontal lines, then just dots, then the pale (gray) dots and finally pure white. Note that for the the "cross-hatching plus dots", we need to translate the dots by half a dot interval in both x and y, to make the dots appear in the gaps between the lines rather than on top of them.

shades = Image /@ {black, Show[hlines, vlines, dots /. Disk[x_, r_] :> Disk[x + di/2, r]],
Show[hlines, vlines], hlines, dots, paledots, white};

Close up, the shades look like this:

enter image description here

Zoomed out, we can see that these shading styles approximate a sequence of gray levels from black to white :

enter image description here

The key step in the routine comes next. We use ColorQuantize to compress the image into 7 gray levels. The idea is that each of these 7 gray levels will be replaced with the 7 shades we have built.

qimg = ColorQuantize[img, Length@shades, Dithering -> False];

The quantized image looks like this :

enter image description here

Next we split the quantized image into 7 separate "region" images. Each region image picks out the parts of the quantized image with the corresponding gray levels.

levels = Cases[ImageLevels[qimg], {val_, _?Positive} :> val];
regions = Table[ImageApply[1 - Unitize[# - x, 0.01] &, qimg], {x, levels}];

The region images look like this:

enter image description here

A bit of tinkering is needed here. The first region image, which corresponds to solid black, should not have any large blocks in it or there will be large blocks of solid black in the final picture, which isn't very hedcut-like. In this example the jacket is going to come out as a solid block of black. The solution is to move these large areas into the second region image, so they will come out shaded with "cross-hatching plus dots". Note that we don't want to remove all the black areas, as they are especially useful for the eyes.

We can use DeleteSmallComponents to isolate the large blocks from the first region image:

bigblackareas = DeleteSmallComponents[regions[[1]]];

enter image description here

Now we can subtract this from the first region image and add it to the second:

regions[[1]] = ImageSubtract[regions[[1]], bigblackareas];
regions[[2]] = ImageAdd[regions[[2]], bigblackareas];

The first two region images now look like this. The jacket and tie have will now be shaded using "cross-hatching plus dots" instead of solid black.

enter image description here

We are nearly there now. The next step is to multiply each region image by its corresponding shade image and add them all together:

combined = Fold[ImageAdd, First[#], Rest[#]] &@ MapThread[ImageMultiply, {regions,shades}];

enter image description here

The last step is to add some outlines. These can be obtained by binarizing the result of a GradientFilter:

outlines = Binarize @ ColorNegate @ GradientFilter[img, 2];

enter image description here

To get the final image the outlines are combined with the shaded image, and Gaussian filter applied to soften everything slightly.

GaussianFilter[ImageMultiply[combined, outlines], 1]

enter image description here

Another couple of examples using the same procedure :

enter image description here

enter image description here

Thanks to R.M, Jagra, DGrady and Szabolcs for code, comments and ideas.

share|improve this answer
Nice implementation for some of @Jagra's comments. The edges are a bit jerky, especially in the second photo - have you thought about smoothing them? –  DGrady Jul 25 '12 at 21:32
Very nice!$\phantom{}$ –  rm -rf Jul 25 '12 at 21:39
@DGrady, I tried applying a Gaussian filter to the image before extracting the outlines, but it didn't come out very well. –  Simon Woods Jul 25 '12 at 21:47
You guys are scary good at Mathematica. ;-) –  JohnD Jul 26 '12 at 0:44
@Szabolcs, that's a great idea. What I've ended up doing is using the additional dark pattern as you suggest, plus solid black, so 7 quantization levels in total. Any large areas of solid black then get changed to the dark pattern. This gives a better result than the MinDetect approach and doesn't require tweaking any parameters (at least on the images I have tried). Code update coming up. –  Simon Woods Jul 27 '12 at 20:40

A very long time ago I spent several months working in a photo processing office. Copy cameras, film, and retouching by hand served as the state of the art tools of the day. No commercial personal computers existed at the time, so no Photoshop and no digital anything.

The business had a master of photographic image processing. He would produce all sorts of graphic images from photographs. He did astonishing work.

I saw him tak a multi-step approach to get the kind of “hedcut” style you describe.

Take a close look at your first image.

enter image description here

While it seems like a simple abstraction of a photograph it actually has a great deal going on in it.

The overall image has a nearly unbroken line outlining it, only broken in the hairline left of center and across the bottom. Th left and right edges appear simply cropped.

Whomever made this (whether by hand or machine) has defined several areas within the image and treated them with different masks or screens.

They include:

  • hair crosshatched,
  • face pixilated (dots),
  • jacket (2 sections) crosshatched
  • neck nearly vertical lines
  • shirt pixilation shadowing the outline
  • tie nearly vertical lines
  • eyes outlined
  • pupils solid black with tiny highlights

Look closely and you may see even more.

The artist/image-processor has outline each of these areas then they deliberately fudged some of the juxtapositions between areas to produce a more hand created look.

The guy I used to know used masks and high contrast images to decompose a photographic image into the pieces he wanted then manipulated the individual pieces with screens of lines, points, or hatching then reassembled all of the pieces.

He did all of this mechanically without resorting to retouching (painting on the photograph), so theoretically Mathematica should give one the ability to do a great deal of this.

But, I recommend not underestimating the complexity of the problem. Break it down then build it back up.

I’ll give some thought to Mathematica techniques to do this when I have a bit more time.

share|improve this answer
+1 for not underestimating the complexity of the problem –  Silvia Jul 25 '12 at 15:57
Of course I'm not expecting to create a perfect imitation of the style. Maybe not even a close one. I agree with you that it's impossible to create it without making intelligent decisions, for example that a square pattern fits the jacket and should follow its natural lines (which are probably not even clear in the original photograph, but both the artist and the viewer know what jackets are like, so the artist uses a textile-like pattern that follows the lines of the body; he uses dots only for the face; etc.) –  Szabolcs Jul 25 '12 at 16:02
What I'm looking for is an engraving-like result, reminiscent of hedcuts. RM's answer is a good example. It's clearly not the same thing, but it has a certain resemblance to these kinds of prints (especially the Photoshop version he based his Mathematica code on). –  Szabolcs Jul 25 '12 at 16:02
@Szabolcs -- I largely agree, but I do think one could (with sufficient thought and time) automate a great deal of this. Identify a face, identify hair, identify a shirt from a jacket, treat each piece differently (dots, hatches, lines, ...), outline each piece, identify the direction of a light source and fudge edges accordingly or maybe by some random process. I can at least imagine an algorithm that could do this. Writing the algorithm is admittedly another matter ;-) –  Jagra Jul 25 '12 at 16:18

Here's a first-pass at a Hedcut style image using Mathematica

enter image description here

This is how it was done:

  1. First, obtain the image and convert to gray scale:

    img = ColorConvert[Import["http://i.stack.imgur.com/RjE3P.jpg"], "Grayscale"];

    enter image description here

  2. Next, create a disk layer and give it a wavy pattern:

    dots = Graphics[Table[{Disk[{i, j}, 1]}, {i, 1, 300, 4}, {j, 1, 460, 4}] /. 
        Disk[{x_, y_}, r_] :> Disk[{
            Clip[x + 2 Sin[16 π y/#2], {1, #1}], 
            Clip[y + 2 Sin[16 π x/#1], {1, #2}]}, 
        ] & @@ ImageDimensions@img

    enter image description here

  3. Now I create a "corrected" disk layer with each disk coloured according to the GrayLevel in the original image

    layer = dots /. Disk[c_, r_] :> With[
        {val = ImageData[img, DataReversed -> True][[Sequence @@ Reverse@Round@c]]}, 
        {GrayLevel[val], Disk[c, r]}

    enter image description here

  4. Finally, impose this layer onto the original image and set the opacity accordingly, which should give you the final image above.

    SetAlphaChannel[ImageMultiply[Lighter@img, layer], ColorNegate@Binarize[img, 0.9]]
share|improve this answer
Can you post something that's not Putin? Feyman or Asimov maybe? –  Szabolcs Jul 25 '12 at 15:29
Because the Putin image was the easiest to make look fine for almost anything I tried, and I was wondering if this method looks good on other images too. –  Szabolcs Jul 25 '12 at 15:31
You can always use Lenna, everyone's favorite image processing centerfold. –  s0rce Jul 25 '12 at 15:32
i.stack.imgur.com/HeY9W.png -- nice –  Szabolcs Jul 25 '12 at 15:32
@Szabolcs Typically Hedcut images are done only for portraits and the background is always white. So if you want to try on a random image from the internet, the background must be first adjusted, else you'll have black dots on gray bg, which doesn't look so nice and the effect is lost. For this reason, it won't work on Lena either. At least, not out of the box –  rm -rf Jul 25 '12 at 15:37

I've elaborated the engraving method for this purpose. Now we can use any set of arbitrary curves, not just a spiral. In this particular case these curves are B-splines which can be adjusted by user.

enter image description here

The result looks like this:

enter image description here

The crucial thing here is to get optimal relationship between the maximum thickness and resulting image size. As I've seen from my experimrnts the best results are achieved when the final image is big:

enter image description here

Some experience is needed to get good results. The main thing is to get some curves aligned along edges.

Here comes the code:

img = '[paste an image here]';
nl = 7;(* number of control points for B-splines*)
nc = 90;(* number of contours*)
pdg = 50;(* padding *)
maxth = 3;(*maximum thickness*)
is = 300; (* resulting image size *)
bw = True;(* black on white background *)
active = True;
{w, h} = ImageDimensions@img;
rimg = Rasterize@img;
pr = {{-pdg, w + pdg}, {-pdg, h + pdg}};
pts = Table[{i, 0}, {i, 0, w, w/(nl - 1)}]~Join~
   Table[{i, h}, {i, 0, w, w/(nl - 1)}];
refine[pts_, maxlen_] := Block[{prev, len},
   prev = pts[[1]];
   Reap[Scan[(If[(len = Norm[# - prev]) <= maxlen, Sow@#,
         Sow /@ 
          Most@Table[(1 - t) # + t prev, {t, 0, 1, 1/
         ]; prev = #) &, pts]][[2, 1]]];

getDots[pn_] := Block[{splines, alldots, splitter, splitdots},
   splines = BSplineFunction /@ controlPts[pn];
   alldots = 
    ParametricPlot[#[t], {t, 0, 1}][[1, 1, 3, 2, 1]] & /@ splines;
   alldots = refine[#, 1] & /@ alldots;
   splitter[{x_, y_}] := 0 <= x <= w && 0 <= y <= h;
   splitdots = SplitBy[#, splitter] & /@ alldots;
   Flatten[DeleteCases[#, _?(! splitter[#[[1]]] &)] & /@ splitdots, 1]

engrave[img_, dots_, th_, bw_: True, opts__] := 
  Block[{color, ath, getLines, lines},
   getLines[pts_] := (color = Mean@ImageValue[img, #];
       If[bw, color = 1 - color];
       {AbsoluteThickness[th color], Line@#}
       ) & /@ Partition[pts, 2, 1];
   lines = getLines /@ dots;
   Graphics[{CapForm["Round"], If[bw, Black, White]}~Join~lines, 
    Background -> If[bw, White, Black], opts]

controlPts[pn_] := 
  Transpose@MapThread[Table[(1 - t) #1 + t #2, {t, 0, 1, 1/nc}] &, pn];

(* interface *)
   Row[{Slider[Dynamic@nc, {20, 200, 1}], Spacer[20], 
     Dynamic[ToString[nc] <> " contours"]}],
       Graphics[{Opacity[0.5], Green}~
         Join~(BSplineCurve /@ controlPts[pn = Partition[pts, nl]])~
         Join~{Red, Thickness[Large], Line /@ pn},
        ImageSize -> 400, AspectRatio -> Automatic
        ], PlotRange -> pr, Background -> White]~Magnify~2
      Dynamic@bw, {True -> "Black on white", 
       False -> "White on black"}],
     "  Thickness  ", SetterBar[Dynamic@maxth, Range[2, 7, 0.5]]
   Row[{"Image size   ", SetterBar[Dynamic@is, Range[300, 700, 50]],
        If[active, " Engrave "~Style~Bold, "  Working... "],
        active = False; FinishDynamic[];
         Print@engrave[img, getDots@pn, maxth, bw, ImageSize -> is];
        active = True; FinishDynamic[],
        Enabled -> Dynamic@active
      DynamicEvaluationTimeout -> 100

Note that there is a possibilty to make a white engraving on black background -- sometimes this gives more effective result.

Here is the zip-file with all processed test portraits (someone please put this to the proper place).

share|improve this answer
I'd like to share the results I've got from all the test images in PDF format. Can anyone suggest the most appropriate place to put the archive?.. –  faleichik Jul 27 '12 at 15:24
I control the stackmma github account which was intended for such purposes. See this answer for some context. Right now, I host attachments from posts and for the blog. Just ping me in chat with a link (from dropbox or elsewhere) and I'll upload them to the account –  rm -rf Jul 27 '12 at 16:05
Or maybe just link it from the post and ping somebody with access and ask them to change the link to a permanent one. You can ping me too in chat (European time zone), and you can email the file to my address too if you like. –  Szabolcs Jul 27 '12 at 17:17
Szabolcs, @RM, I've put the link in the end of the post. If it is appropriate, could you upload the file to the stackmma account? –  faleichik Jul 28 '12 at 19:46

Here's a simple answer that uses the built-in image filtering operation along with a customized thresholding. The idea of the adaptive thresholding is that in each neighborhood, the value of the current pixel is compared to the Mean throughout the neighborhood: if the pixel is larger than a given percentage of that Mean, then set it to 1, otherwise set it to 0. It's adaptive in the sense that the actual threshold used for binarization is slightly different in each neighborhood.

adaptThresh[x_, threshRat_] := Module[{center, thisPix}, 
    center = (First[Dimensions[x]] + 1)/2;
    thisPix = x[[center, center]];
    Boole[thisPix > threshRat Mean[Flatten[x]]]];

This can then be applied to images using the ImageFilter command. For example, on Mr. Putin:

img = Import["http://i.stack.imgur.com/qaZpG.jpg"];
GraphicsRow[{img, ImageFilter[adaptThresh[#, 0.9] &, img, 3]}, ImageSize -> 500]

enter image description here

Here the 0.95 is the threshold and 3 is the size of the neighborhood. Of course, Mr Putin is easy. When trying some of the others, it is worthwhile fiddling a bit with the two parameters:

img = ColorConvert[Import["http://i.stack.imgur.com/eQtVz.jpg"],"Grayscale"];
GraphicsRow[{img, ImageFilter[adaptThresh[#, 0.83] &, img, 4]}, ImageSize -> 500]

enter image description here

img = Import["http://i.stack.imgur.com/YajUp.jpg"];
GraphicsRow[{img, ImageFilter[adaptThresh[#, 0.84] &, img, 6]}, ImageSize -> 500]

enter image description here

GraphicsRow[{img,ImageFilter[adaptThresh[#, 0.95] &, img, 6]}, ImageSize -> 500]

enter image description here

The results are often much more satisfactory if the background is light and uniform. Here's an old president.

img = Import[ "http://upload.wikimedia.org/wikipedia/commons/thumb/c/ce/President_Andrew_Johnson.jpg/180px-President_Andrew_Johnson.jpg"];
GraphicsRow[{img, ImageFilter[adaptThresh[#, 0.95] &, img, 4]}, ImageSize -> 500]

enter image description here

share|improve this answer

Your Answer


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.