27

17

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.

27

17

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.

39

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["http://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]
```

14

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

```
img = Import["http://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]
```

I lost a nice statue! – Dr. belisarius – 2015-02-25T13:53:34.507

@belisarius - Don't you hate it when that happens? But really -- if we are looking for a 1D interpolating function, something is going to get lost. You could do a 2D function, but how to deal with all the separated components? – bill s – 2015-02-25T13:55:47.847

13

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["http://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}]
```

Sorry, I needed to change my code. Perhaps you want to test with the new one or recover the old one from the edit history – Dr. belisarius – 2015-08-14T14:35:27.730

That's a tough image, but I guess you could start with

– dr.blochwave – 2015-02-25T13:05:35.200`ImageCorners[img]`

as per http://reference.wolfram.com/language/ref/ImageCorners.htmlPlease give examples of input, output and define silhouette. – Kuba – 2015-02-25T13:17:05.260

3

You may start with the people therein

– Dr. belisarius – 2015-02-25T13:26:43.933See also Making Formulas... for Everything - From Pi to the Pink Panther to Sir Isaac Newton

– Chris Degnen – 2015-02-25T16:56:23.017