Smooth curves in a raster image

Question

I have a *.bmp image, e.g. this one:

I need to smooth boundaries of the thick curves and save it in a vector graphics form. Is there a simple way how to do that in Mathematica 10? I know it is probably an easy task, but can't figure it out. Thank you.

Answer 1

I would like to have curves with smooth boundaries and the lines across them, with sharp corners in intersection.

Part 1: isolate the boundaries

Import the image and remove the frame:

img = Import["https://i.sstatic.net/SJwTu.png"];
img1 = ImagePad[img, -4]

Remove the white borders excepting the left border (we'll need it at the next steps):

border = BorderDimensions[ImageTake[img1, 20]];
img2 = ImagePad[img1, -border + {{4, 0}, {0, 0}}]

Find positions of the pixels of the horizontal lines and make them white:

horizontalLinesPos = {All, #2} & @@@ PixelValuePositions[ImageTake[img2, All, 1], 0];
img3 = ReplacePixelValue[img2, horizontalLinesPos -> 1]

Find internal perimeters of the black components:

img4 = MorphologicalTransform[ColorNegate@img3, "Remove"]

At this step we get a problem. We have to decide what to do with the horizontal "tails" like this:

ArrayPlot[1 - ImageData[ImageTake[img4, {51, 67}, {334, 351}]], Mesh -> True, 
 ImageSize -> 400]

Since such "tails" correspond to actual data points (represented as black pixels on the original image), it is reasonable to keep them.

Now we have to remove the horizontal and vertical borders excepting at the left where the vertical border actually is a continuation of the curve. And we have to keep the "tails" at the same time. For this purpose it is better to start again from the img2:

img3 = MorphologicalTransform[ColorNegate@img2, "Remove", Padding -> 1];
img4 = ReplacePixelValue[img3, horizontalLinesPos -> 0]

Part 2: extract the curves

masks = ComponentMeasurements[img4, "Mask"];

curves = Transpose[Reverse@#]["NonzeroPositions"] & /@ masks[[;; , 2]];

horLines = Join[{∞}, Mean /@ Split[horizontalLinesPos[[;; , 2]], Abs[#1 - #2] == 1 &], {0}]

{∞, 508, 342, 175, 0}

dataLines = 
  DeleteCases[
   Flatten[#, 1] & /@ 
    Transpose[PadRight[
      Table[Select[curves, horLines[[i]] > Min[#[[;; , 2]]] > horLines[[i + 1]] &], 
        {i, Length[horLines] - 1}], Automatic, Missing[]]], {Missing[], Missing[]}, {2}];

ListPlot[dataLines]

Part 3: smooth the curves

There are infinitely many possible ways to perform the smoothing. For recovering the original data points the approach shown by nikie in this answer seems the most appropriate. If the goal is just to obtain smoothed boundaries, one can use approaches shown in this thread.

Answer 2

The smoothing of the edges can be accomplished using one of the edge-preserving smoothing functions. For example, the PeronaMakil filter gives:

img = ImagePad[Import["https://i.sstatic.net/SJwTu.png"], -4];
edges = EdgeDetect[PeronaMalikFilter[img, 20, 100]]

Another similar filter is the CurvatureFlowFilter.