How to create a new “person curve”?

Wolfram|Alpha has a whole collection¹ of parametric curves that create images of famous people. To see them, enter WolframAlpha["person curve"] into a Mathematica notebook, or person curve into Wolfram|Alpha. You get a mix of scientist, politicians and media personalities, such as Albert Einstein, Abraham Lincoln and PSY:

The W|A parametric people curves are constructed from a combination of trigonometric and step functions. This suggests that the images might have been created by parametrising a sequence of contours... which is backed up by some curves being based of famous photos, e.g., the W|A curve for PAM Dirac:

is clearly based on the Dirac portrait used in Wikipedia:

Here's a animation showing each closed contour of Abraham Lincoln's portrait as the plot parameter $t$ increases by $2\pi$ units:

Since the functions are so complicated, I can't believe that they were manually constructed. For example, the function to make Abe's bow tie is (for $8\pi < t < 10\pi$)
The full parametric curve for Abe has 56 such curves tied together with step functions and takes many pages to display.

So my question is:

How can I use Mathematica to take an image and produce a good looking "people curve"?

Answers can start from line art and just automatically parametrise the lines or they can start from a picture/portrait and identify a set of contours that are then parametrised. Or any other (semi)automated approach that you can think of.

¹ At the time of posting this question, it has 37 such curves.

-
Could you please explain why you "can't believe that these were hand written"? –  belisarius Jan 13 '13 at 4:57
@belisarius: I've added an example of part of the output from WolframAlpha["Abraham Lincoln curve", {{"EquationsPod:PlaneCurve", 1}, "FormulaData"}]. Not even the most downtrodden intern would be able to hand write such a mathematical function. Although, I admit, it could be hand traced and the traces parametrised - thus the line art comment in my question. –  Simon Jan 13 '13 at 5:14
Given that the coefficients of $t$ inside the sinusoids are 1, 2, 3, ..., this is probably just the Fourier representation of a parametric curve. I'd guess they manually traced the curve as a polygon, took the discrete Fourier transform, and kept just enough of the lowest-order modes to make the curve look right. See also: Ptolemy and Homer (Simpson). –  Rahul Jan 13 '13 at 5:32
Another demonstration: TracingContourLinesInPhotographicImages gets a handle on contour lines. –  Michael E2 Jan 13 '13 at 14:11
The method called "Fourier Descriptors" does something similar: demonstrations.wolfram.com/preview.html?draft/46249/000012/… –  bill s Jan 13 '13 at 17:37

This now has been discussed in Wolfram blog posts by Michael Trott:

Here is one of the example apps from blog - go read it in full - fun! Don't miss the link to download the notebook with complete code and apps at the end of the blog.

-
Nice picture of Newton. But why does his shirt have so many buttons? –  Daniel Lichtblau May 17 '13 at 19:36
@DanielLichtblau Newton was known to dress up in disguises and roam the streets of London in order to catch the counterfeiters. As Warden, and afterwards Master, of the Royal Mint, Newton estimated that 20 percent of the coins taken in during The Great Recoinage of 1696 were counterfeit. Counterfeiting was high treason, punishable by the felon's being hanged, drawn and quartered. Despite this, convicting the most flagrant criminals could be extremely difficult. However, Newton proved to be equal to the task. Disguised as a habitué of bars and taverns, he gathered much of that evidence himself. –  Vitaliy Kaurov May 17 '13 at 19:49
Ironically, it was Newton himself who was drawn above. In portrait form, suitable for hanging in ones quarters. But I digress. –  Daniel Lichtblau May 17 '13 at 20:33

This shows a way to parametrise a line using the method suggested by Rahul Narain in a comment, i.e. using Fourier to approximate the data with a set of sinusoids. I use Rationalize to convert all the reals back to rationals, this isn't necessary but it makes the expression look more like those used in Wolfram Alpha.

param[x_, m_, t_] := Module[{f, n = Length[x], nf},
f = Chop[Fourier[x]][[;; Ceiling[Length[x]/2]]];
nf = Length[f];
Total[Rationalize[
2 Abs[f]/Sqrt[n] Sin[Pi/2 - Arg[f] + 2. Pi Range[0, nf - 1] t], .01][[;; Min[m, nf]]]]]

tocurve[Line[data_], m_, t_] := param[#, m, t] & /@ Transpose[data]


tocurve will take a Line, a number of modes m and a symbolic parameter t and return a parametrisation of the line data. Because of the implied periodicity of the data in Fourier it will only work properly on closed lines.

The hard part is getting a good set of lines from the image of a person. Here's a much simpler example using ListContourPlot to extract the outline of a silhouette.

First load an image and do a bit of preprocessing to ensure a nice contour:

img = Import[

img = Binarize[img~ColorConvert~"Grayscale"~ImageResize~500~Blur~3]~Blur~3;


Now extract contours and plot the parametrised curve with 500 modes:

lines = Cases[Normal@ListContourPlot[Reverse@ImageData[img], Contours -> {0.5}], _Line, -1];

ParametricPlot[Evaluate[tocurve[#, 500, t] & /@ lines], {t, 0, 1}, Frame -> True, Axes -> False]


With fewer modes the detail starts to smooth out. Here's the 30 mode curve:

The parametrisation consists of sinusoids:

curves // Short


-
That is pretty impressing! May I ask where curves comes from? –  Stefan Jan 28 '13 at 18:26

This was supposed to be a comment to Simon's answer, but it's gotten too long. Still, I wanted to share a somewhat cleaned-up version of Simon's Fourier-fitting function param[] (which I have renamed to FourierCurve[]):

FourierCurve[x_, m_, t_, tol_: 0.01] := Module[{rat = Rationalize[#, tol] &, fc},
fc = Take[Chop[Fourier[x, FourierParameters -> {-1, 1}]], Min[m, Ceiling[Length[x]/2]]];
2 rat[Abs[fc]].Cos[Pi (2 Range[0, Length[fc] - 1] t - rat[Arg[fc]/Pi])]]


This has the virtue of returning a function that genuinely closes up; more precisely, if f[t_] = FourierCurve[pts, modes, t], then f[0] == f[1]. (The indiscriminate use of Rationalize[] in the earlier version prevented a nice closure of the resulting curve.)

As Rahul alludes to in his comment, this is more or less the "epicycle" approach of Ptolemy for determining the paths of planetary orbits.

Of course, Fourier fitting can also be applied to space curves as well as plane curves. Here's an example:

{f[t_], g[t_], h[t_]} = FourierCurve[#, 20, t] & /@
KnotData["FigureEight", "SpaceCurve"]["ValuesOnGrid"];

ParametricPlot3D[{f[t], g[t], h[t]}, {t, 0, 1}, Axes -> None, Boxed -> False,
Method -> {"TubePoints" -> 20}, PlotStyle -> Blue, ViewPoint -> Top] /.
Line[pts_, rest___] :> Tube[pts, 1/8, rest]


Since most of the knots given in KnotData[] have their space curves given as InterpolatingFunction[] objects, you can use this approach if you prefer to have explicit parametric expressions for those knots.

-
(This isn't yet my official return; I found some spare time and decided to exploit it.) –  Ｊ. Ｍ. Feb 7 '13 at 2:53
Spare time is hard to come by sometimes... I'll find some one day and come back to evaluating and accepting one of these answers –  Simon Apr 22 '13 at 10:35