Finding a function that fits the shape of an image

Question

How can I find a function that fits the given shape of an image? Or instead extract a point set from the shape and then find an interpolating function fits the shape.

An example image is attached.

Answer 1

The following is something I made while trying to solve another (similar) problem

(*FindCurvedPath Replacement*)
ClearAll[findCurvedPath2, findClosedPath2];
findClosedPath2[inptList_, cutoff_] := Append[#, #[[1]]] &@
                                                   findCurvedPath2[inptList, cutoff]
findCurvedPath2[inptList_, cutoff_] := Block[{
                        $RecursionLimit = Max[20, Round[ 2.1 Length@inptList]],
                    $IterationLimit = Max[20, Round[ 2.1 Length@inptList]]},
                            findCurvedPath2[Rest@inptList, inptList[[1 ;; 1]], cutoff]]
findCurvedPath2[{}, outList_, cutoff_] := outList
findCurvedPath2[inptList_, outList_, cutoff_] := 
               findCurvedPath2[Delete[inptList, #],
               If[EuclideanDistance[inptList[[#]], Last@outList] < cutoff, 
                  Append[outList, inptList[[#]]], outList], cutoff] &@
                  First@Nearest[inptList -> Automatic, Last@outList]

(*Two methodsfor calculating the perimeter curve for an Image*)
ClearAll[findPerimeterPath];
findPerimeterPath[i_Image, cutoff_, OptionsPattern[{Method -> EdgeDetect}]] :=
 Module[{perimPts},
  Switch[OptionValue[Method],
   MorphologicalPerimeter,
   perimPts = ImageValuePositions[MorphologicalPerimeter[Binarize[i, {0, .5}]], 1],
   EdgeDetect,
   perimPts = ImageValuePositions[Thinning@EdgeDetect@i, 1]];
 findClosedPath2[perimPts, cutoff]]

(*For your image*)
ii = Import["https://i.stack.imgur.com/Z7rKJ.jpg"];
i1 = ColorNegate@FillingTransform[ColorNegate@Binarize[ii, .9]];
cutoff = Norm@ImageDimensions@i1/50 // N;
fcp2 = findPerimeterPath[i1, cutoff, Method -> MorphologicalPerimeter];
f = Interpolation /@ Transpose@fcp2;
pp = ParametricPlot[Through[f[x]], {x, 1, Length@fcp2}, Axes -> False]  

Now you can proceed the same way with the holes:

Needs["DifferentialEquations`InterpolatingFunctionAnatomy`"];
i1 = DeleteSmallComponents[ColorNegate[Binarize[ii]], 5] // ColorNegate;
(* leave out components 0, 1 and 2*)
mcR = (UnitStep[# - 3] # &@MorphologicalComponents[i1]);
compsR = Rest@DeleteDuplicates@Flatten@mcR;
iR = Table[Image@Unitize[mcR - ConstantArray[r, Dimensions@mcR]], {r, compsR}];
cutoff = Norm@ImageDimensions@i1/50 // N;
fcp2R = findPerimeterPath[#, cutoff] & /@ iR;
fR = Table[Interpolation[fcp2R[[n]][[All, #]]] & /@ Range@2, {n, Length@fcp2R}];
pp1 = ParametricPlot[ Through[#[x]],
             {x, 1, InterpolatingFunctionDomain[#[[1, 1]]][[1, 1, 2]]}] & /@ fR;

Show[pp, pp1]  

Answer 2

Since your image is binary, you can just pick out the top-most point in each column of the data matrix:

img = Import["https://i.stack.imgur.com/Z7rKJ.jpg"];
dat = Transpose[ImageData@EdgeDetect[img]];
{c, r} = Dimensions[dat];
points = r - Min[Flatten@Position[dat[[#]], 1]] & /@ Range[c];
np = Interpolation[points, InterpolationOrder -> 1]; 
Plot[np[x], {x, 1, c}, AspectRatio -> Automatic, ImageSize -> 600]

Answer 3

I was stuck for a while with a not really acceptable result, but then @belisarius posted his answer and I was able to refine my code with the usage of his findCurvedPath2 function. So I am able to post my solution to the problem.

First, import and process the image:

img = Binarize@Import["https://i.stack.imgur.com/Z7rKJ.jpg", "JPEG"];
imgc = ColorNegate@Closing[ColorNegate@img, 10];
edge = ColorNegate@Thinning@Dilation[EdgeDetect@imgc, 1];
edgeData = {0, ImageDimensions[imgc][[2]]} - #*{-1, 1} & /@ 
Reverse /@ Position[ImageData@edge, 0];

Then, I wrote my own method to sort the edge pixels:

dist[{u_, v_}, {x_, y_}] := 10 (x - u) - (u - x) + 10 Abs[v - y]

first = Sort[edgeData][[1]];
odata = DeleteCases[edgeData, first];
ndata = {first};
Dynamic[{Length[ndata], np}]
While[Length[odata] > 1,
 p = ndata[[-1]];
 np = Nearest[odata, p, DistanceFunction -> dist][[1]];
 AppendTo[ndata, np];
 odata = DeleteCases[odata, np];
 ]

Here's where I'd become stuck, because the result was problematic:

Then, I improved the sorting with findCurvedPath2 borrowed from @belisarius' answer, and cleaned it up a bit:

ndata2 = findCurvedPath2[ndata];
d = Differences[ndata2];
s = Select[d, Max@Abs@# > 10 &];
sp = Flatten[Position[d, #] & /@ s, 1];
ndata2s = Delete[ndata2, DeleteDuplicates@Join[sp, sp + 1]][[;; -3]];

The result was very close to the real silhouette:

The only thing left was to interpolate the sorted data:

curve = Interpolation@MapIndexed[{#2[[1]], #1} &, ndata2s];
ParametricPlot[curve[t], {t, 1, Length[ndata2s]}, 
 ImageSize -> ImageDimensions@imgc, AspectRatio -> Automatic, 
 PlotRange -> {{0, Max[edgeData]}, All}]