# Generating a graph object where vertices are pixel coordinates and edges represent two pixels being in the same Moore neighborhood

I have a list of integer pixel positions, pts, and I wish to create one or more graph objects where vertices at these pixel positions share an edge if they are within one-anothers 8-cell Moore neighborhoods. To clarify what I mean by "one or more graph objects", I mean that the above process might generate disconnected graphs.

For an example, consider the contour pixels from my previous question: (Generating a list of contour pixels for a morphological component).

shape = Import["http://pixelduke.files.wordpress.com/2010/01/jnbdec2008-hello-world-example2.png"];
m = MorphologicalComponents[ColorNegate[ImageCrop[shape, {300, 100}]]];

mlist = Thinning[EdgeDetect[Image[m /. x_Integer /; x =!= # -> 0 // Rescale]]] & /@ Range[Length[ComponentMeasurements[m, "Count"]]];

pts = Position[ImageData[mlist[]], 1];
Graphics[Point[pts]]


Where pts is an example set of pixel positions to be transformed into a graph object. In this case, there should be two disconnected graphs since mlist[] represents the contour of the "o" in "Hello, World.".

I've seen other solutions for generating random geometric graphs here, for example (Is it possible for me to explicitly specify a point list for SpatialGraphDistribution?) however, is there a more efficient way to do this provided my connectivity rule?

Here's the way to do it using the method of Szabolcs from Is it possible for me to explicitly specify a point list for SpatialGraphDistribution?:

r = Sqrt;
distances = With[{tr = Transpose[pts]}, Function[point, Sqrt[Total[(point - tr)^2]]] /@ pts];
am = UnitStep[r - distances] - IdentityMatrix@Length[pts];



However, this is much too slow for larger points sets where we have something like Length[pts] = 10000 or so.

Also, and this may be grounds for a separate question, after construction of these simplified geometric graph objects, I would like to have some method of pruning away vertices when: (a) the vertex is strictly connected to two nearest-neighbors / has degree two, and (b) when the edges from the vertex to its two nearest neighbors fall along the same line / it is colinear with its two nearest-neighbors. In other words, I want to find the minimum set of vertices to give the set of connected edges the same morphology / geometry. It strikes me that there ought to be an automated routine for this in Mathematica 9, however, I can't seem to hunt one down.

Here is a iterative method using Nest which seems to be faster then the approach you showed

dist = Compile[{{p1, _Real, 1}, {p2, _Real, 1}},
Norm[p1 - p2] <= Sqrt, Parallelization -> True,
RuntimeAttributes -> {Listable}];

connect[ptsIn_List] :=
With[{idMap =
Dispatch[Rule @@@ Transpose[{ptsIn, Range[Length[ptsIn]]}]]},
Flatten[
Last@Reap@Nest[
Function[pts, With[{fst = First[pts], rst = Rest[pts]},
With[{neigh = Pick[rst /. idMap, dist[fst, rst]],
id = fst /. idMap},
Sow[UndirectedEdge[id, #] & /@ neigh];
rst
]
]
], ptsIn, Length[ptsIn] - 1]
]
]


An example with about 5000 points finished in 7 seconds on my laptop. Here a smaller one

pts = (Reverse /@
Position[ImageData[#, "Bit", DataReversed -> True],
1]) &@(ImageSubtract[Dilation[#, 1], #] &[
Binarize[
ColorNegate@Rasterize[Style["Mathematica", 20], "Image"]]]);
Graph[Range[Length[pts]], connect[pts], VertexCoordinates -> pts] 