Skip to main content

generative art - How to create hedcut style images?



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:


ImageDeconvolve[Import["http://www.alleba.com/blog/wp-content/photos/put001.jpg"],

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[
"http://www.stars-portraits.com/img/portraits/stars/j/jimi-hendrix/jimi-hendrix-by-BikerScout.jpg"]

(* "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]},
Graphics@MapThread[
Rotate[Disk[#1, {4, 1}], #2] &,
{point,
ArcTan @@@
Transpose[{Extract[ImageData[gh], point],

Extract[ImageData[gv], point]}]}
]
]


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


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

fill = With[{point =
RandomChoice[
Join @@ ImageData@ImageClip@ColorNegate[detail] ->
Join @@ coords, 5000]},
Graphics@MapThread[
Rotate[Disk[#1, {3, 0.8}], #2] &,
{point,
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.




Update:



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

ct=Table[p,{p,0,1,0.02}];


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},
Table[
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]

Answer



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.


Comments

Popular posts from this blog

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...