Hi Priyan,
there are two steps in the problem: extraction of the regions from the picture and extraction of the perimeters from every region. The first step can be performed via precise binarization.
image = ColorNegate@ColorConvert[Import["http://upload.wikimedia.org/wikipedia/commons/c/c7/Sri_Lanka_divisions.png"], "Grayscale"];
size = ImageDimensions[image];
imageXY[{y_, x_}] := {x, size[[2]] + 1 - y};
We need two parameters:
threshold = {0.225, 0.275};
minRegionArea = 17;
The first one is the thresholds for binarization and the last one is the minimal area of a region. The first parameters can be found form the image histogram:
ImageHistogram[image, FrameTicks -> {Range[0, 1, 0.1], None}, ImageSize -> 900]
One can see that the second most popular color is inside the thresholds chosen. The binarization and regions can be found as follows:
image2 = Binarize[image, threshold];
components = MorphologicalComponents[image2, 0, CornerNeighbors -> False];
count = ComponentMeasurements[components, "Count"];
One can see that there are a lot of small artefacts, thus we need to remove them:
areas = Union[Last /@ count];
ListPlot[areas, Frame -> True, ImageSize -> 900, PlotRange -> All, PlotRangePadding -> None,
Prolog -> {Orange, Line[{Scaled[{minRegionArea/Length@areas, 0}], Scaled[{minRegionArea/Length@areas, 1}]}]}]
The value of minRegionArea is demonstrated by the orange line in the figure below:
regionNames = First /@ Select[count, Last[#] > minRegionArea &];
The most hard part is to extract boundaries. The first step is to find the position of the morphological perimeters:
positions = Table[Position[components ImageData[MorphologicalPerimeter[image2, CornerNeighbors -> True], "Bit"], name], {name, regionNames}];
This function works really slow so be patient. Then we need two auxiliary functions:
boxSides[pt_] := Partition[{pt + {-(1/2), -(1/2)}, pt + {1/2, -(1/2)}, pt + {1/2, 1/2}, pt + {-(1/2), 1/2}}, 2, 1, 1];
signarure[pts_] := Positive@Total[Det /@ Partition[pts, 2, 1, 1]];
The first one yields the sides of the box around each pixel in the counterclockwise order. The second one gives True if the sequence of points corresponds to a contour ordered counterclockwise. The core is the following function:
contour[pts_] := Module[{vectors = Join @@ (boxSides /@ pts),
vertices, edges,
graph, tours},
vertices = Union[First /@ vectors];
edges = vectors /. Thread[vertices -> Range@Length@vertices];
graph = Graph[DirectedEdge @@@ Complement[edges, Intersection[edges, Reverse /@ edges]]];
tours = (First /@ First@FindPostmanTour@Subgraph[graph, #]) & /@ ConnectedComponents@graph;
vertices[[First@Select[tours, signarure[vertices[[#]]] &]]]]
The idea is to merge all small contours around each pixel so that only boundaries remain, then the function "signarure" helps us to find the single outer boundary, e.g.,
n = 1;
Graphics[{ColorData[2, "ColorList"][[5]], Polygon[First /@ boxSides[#]] & /@ positions[[n]],
{ColorData[2, "ColorList"][[1]], Thick, Line[Append[#, First@#] &[contour[positions[[n]]]]]}}]
The red line is the boundary we need.
perimeters = ParallelMap[contour, positions]; // AbsoluteTiming
(* {10.821194, Null} *)
boundaries = Map[imageXY, perimeters, {2}];
Unfortunately, this function works terribly slow thus I have to use ParallelMap. The list "boundaries" contains boundaries required.
All regions can be demonstrated as follows:
colors = Join @@ Table[ColorData[n, "ColorList"], {n, 1, 60}];
Graphics[Table[{colors[[n]], Polygon[boundaries[[n]]]}, {n, Length[boundaries]}], ImageSize -> size]
The
Mathematica file is in the appachment.
Attachments:
