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

Question

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[[6]]], 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[[6]] 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[2];
distances = With[{tr = Transpose[pts]}, Function[point, Sqrt[Total[(point - tr)^2]]] /@ pts];
am = UnitStep[r - distances] - IdentityMatrix@Length[pts];

AdjacencyGraph[am, VertexCoordinates -> 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.

Answer 1

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[2], 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]