# Calculate dual graph of planar Graphics map

This diagram from a Wikipedia article illustrates what I hope to accomplish in Mathematica:

I have a planar map in Graphics format. Here are two very simple examples with the same dual:

map1 = Graphics[{
Orange, Rectangle[{0, 0}],
Blue,   Rectangle[{1, 0}],
Red,    Rectangle[{2, 0}]
}];
map2 = Graphics[{
Orange, Disk[{0, 0}, 3],
Blue,   Disk[{0, 0}, 2],
Red,    Disk[{0, 0}, 1]
}];
Column[{map1, map2}]


I would like to write a function dual to find the dual graph of such a map. For example:

dual[map1]

(* Graph[{Orange -> Blue, Blue -> Red}] *)

dual[map2]

(* Graph[{Orange -> Blue, Blue -> Red}] *)


I might look into purchasing a copy of Mathematica in Action since I’ve heard that Chapter 17 contains some relevant code for finding the dual in the supplemental MapColoring package. It looks like the book uses the older (pre-version 8) Combinatorica graphs. Still, I’m not sure how to transform the map from Graphics into a better format.

Note: The following needs a properly color quantized image as input. Color quantization for general images is a problem on its own that depends on many factors and is not addressed below.

First we will go step by step, then wrapping up all of it in a function:

Import some discrete-colored image:

ii = Import["http://i.stack.imgur.com/9vdgV.png"]


Then we find the list of colors in that image:

ru = Union@Flatten[ImageData@ii, 1]
(* {{1., 0., 0., 1.}, {1., 0.882353, 0., 1.}} *)


For each color we separate in different binary images

selCol[i_Image, col_] := ImageApply[1 - Unitize@Tr[# - col] &, i]
cols = selCol[ii, #] & /@ ru


Now, for each of these images we separate the Morphological Components and we form a new array where each of them is represented by a different number. Perhaps there is an easier way, but the following works:

cs = Fold[#1 + Unitize@#2 Max@#1 + #2 &,  MorphologicalComponents/@ cols];
Colorize@cs


For each component we need its neighbors to build up the edges:

nei = ComponentMeasurements[cs, "Neighbors"]
(* {1 -> {2, 4, 6, 8, 10}, 2 -> {1}, 4 -> {1}, 6 -> {1}, 8 -> {1}, 10 -> {1}} *)


And so we build our edges:

edges = DeleteDuplicates[Sort /@ Union @@ Thread /@ nei]
(* {1 -> 2, 1 -> 4, 1 -> 6, 1 -> 8, 1 -> 10} *)


Finally, for coloring the vertex we want to recover which color in the original image correspond to each vertex number:

ucs = Union@Flatten@cs;
colCorr = Extract[ImageData[ii], #] & /@ Position[cs, #, 2, 1] & /@ ucs
(* {{{1., 0., 0., 1.}}, {{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}},
{{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}}, {{1., 0.882353, 0., 1.}}}
*)


we now build the vertex coloring rules:

vStyle = Thread[ Rule[ucs, RGBColor @@@ Flatten[colCorr, 1]]]
(*
{1 -> RGBColor[1., 0., 0., 1.],
2 -> RGBColor[1., 0.882353, 0., 1.],
4 -> RGBColor[1., 0.882353, 0., 1.],
6 -> RGBColor[1., 0.882353, 0., 1.],
8 -> RGBColor[1., 0.882353, 0., 1.],
10 -> RGBColor[1., 0.882353, 0., 1.]}
*)


And finally the Graph:

Graph[edges, VertexSize -> 0.2, VertexStyle -> vStyle, VertexLabels -> "Name"]


So now we will pack it into one function:

mkDual[ii_Image, OptionsPattern[{CornerNeighbors -> False}]] :=
Module[{selCol, ru, cols, cs, nei, edges, ucs, colCorr, vStyle},
selCol[i_Image, col_] := ImageApply[1 - Unitize@Tr[# - col] &, i];
ru = Union@Flatten[ImageData@ii, 1];
cols = selCol[ii, #] & /@ ru;
cs = Fold[#1 + Unitize@#2 Max@#1 + #2 &,  MorphologicalComponents[#,
CornerNeighbors -> OptionValue[CornerNeighbors]] & /@ cols];
nei = ComponentMeasurements[cs, "Neighbors"];
edges = DeleteDuplicates[Sort /@ Union @@ Thread /@ nei];
ucs = Union@Flatten@cs;
colCorr = Extract[ImageData[ii], #] & /@ Position[cs, #, 2, 1] & /@ ucs;
vStyle = Thread[Rule[ucs, RGBColor @@@ Flatten[colCorr, 1]]];
Graph[edges, VertexSize -> 0.2, VertexStyle -> vStyle, VertexLabels -> "Name"]]


and use it on color-quantized images of some country flags

riq = Import /@
{"http://i.stack.imgur.com/TqpFO.png","http://i.stack.imgur.com/ZQwSA.png",
"http://i.stack.imgur.com/SyIt7.png","http://i.stack.imgur.com/g334k.png",
"http://3.bp.blogspot.com/-vRxXWRa_4zk/UXz62fD9wRI/AAAAAAAAAs8/9bFvYHh8ozg/s1600/Antwerp+Flag.png"};
GraphicsGrid@Partition[Flatten[{#, mkDual[#, CornerNeighbors -> True]} & /@ riq[[1 ;; 4]]],  2]


{#, mkDual[#, CornerNeighbors -> False]} &@riq[[5]]


• How do I determine the second argument to MorphologicalPerimeter? The .25 value doesn’t work automatically for most maps I try, like these: CountryData[#, "Flag"] /@ {"Burma", "Canada", "China", "Jamaica", "Malaysia"}
– hftf
Aug 7 '15 at 22:15
• @hftf What would be the desired result for (for example) "Canada"? Aug 7 '15 at 22:53
• {Red -> White, Red -> White, Red -> White}.
– hftf
Aug 7 '15 at 22:59
• @hftf Nah, that images may seem to have "plain" colors, but they haven't !Mathematica graphics Aug 7 '15 at 23:26
• I'm using the latest Mathematica. I believe the country flags now use vector Graphics.
– hftf
Aug 8 '15 at 2:40