Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

A unit distance graph is a graph that is embeddable in the plane so that every edge has length 1.

UnitDistanceQ[input_]:=Module[
    {g, x, F, v, min, nod, gl},
    g = input;
    gl = Length[g]; (* Vertex Count *)
    (* 2 vertex count variables x1, x2, etc... *)
    x = Table[Symbol@@ToExpression["x" <> ToString[i]], {i, 1, 2*gl}]; 
    (* The force to minimize is the squared error of the lengths *) 
    F = \!\(
\*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(gl\)]\(
\*UnderoverscriptBox[\(\[Sum]\), \(j = 1\), \(gl\)]g[[i, j]] \((\((x[[2  i]] - x[[2  j]])\)^2 + \((x[[2  i - 1]] - x[[2  j - 1]])\)^2 - 1)\)^2\)\);
    (* Initial vertex positions *)  
    v = Table[gl*Random[], {i, 1, 2*gl}];
    (* Minimization *)  
    {min, nod} = FindMinimum[F, Transpose[{x,v}], Method->"QuasiNewton"];
    (* Output Solution *)       
    If[min < 10^-3,
        Print[{min,nod}];
        GraphPlot[g, VertexCoordinateRules -> 
            Thread[Range[gl] -> Partition[ x /. nod, 2]],
        AspectRatio -> Automatic, 
        VertexLabeling -> None, 
        ImageSize->Small]
    ]
]

For example, the golomb graph is unit distance.

 g = Graph[
          UndirectedEdge @@@ {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 6}, {3, 
             8}, {4, 5}, {4, 9}, {4, 10}, {5, 6}, {5, 10}, {6, 7}, {6, 
             10}, {7, 8}, {7, 10}, {8, 9}, {8, 10}, {9, 10}}];
    m = AdjacencyMatrix[g];
    UnitDistanceQ[m]
    (* gives
        FindMinimum::sdprec: Line search unable 
             to find a sufficient decrease in the function value with 
             MachinePrecision digit precision. >> 
*)

So the question is how to check for a unit distance embedding as fast as possible, my code is not working yet but I think something along these lines will work...

My iterative approach works well for the golomb graph when run many times

enter image description here

This is a great question and cool algorithms could be invented here!

share|improve this question
    
Would you kindly explain how the function UnitDistance is meant to work? –  David Carraher Aug 27 '12 at 22:52
    
It lays out a graph with random vertex positions and then iteratively moves them to decrease the energy functional F which makes every edge become unit distance for instance: Quiet@Reap[ Table[i = UnitDistanceQ[m]; If[i =!= Null, Sow[i]], {100}]][[2]] –  M.R. Aug 27 '12 at 22:59
    
Thanks for the explanation. Interesting approach. Btw, if g is a graph, you'll want to use VertexCount rather than Length to determine the number of vertices. –  David Carraher Aug 27 '12 at 23:02
    
In my code g is the adj matrix, bad name i guess. –  M.R. Aug 27 '12 at 23:08
    
Ok. That clarifies things. –  David Carraher Aug 27 '12 at 23:11
show 2 more comments

3 Answers

I do not know how to compute whether a graph is a unit distance graph.

However, if you know the name of a graph you can ask Mathematica directly. For example,

GraphData["GolombGraph"]
GraphData["GolombGraph", "UnitDistance"]

golomb

As you may know, graphs that Mathematica classifies as unit distance graphs are the following:

Cases[{#, GraphData[#, "UnitDistance"]} & /@ GraphData[], {g_, True} :> g]
Length@%

unit distance graphs

454

share|improve this answer
1  
I know about GraphData and it is a nice repository, but does not answer the question. –  M.R. Aug 27 '12 at 22:01
add comment

If your graph is not one of the ones known to Mathematica then this might help.

e = {(x1 - x2)^2 + (y1 - y2)^2 == 1, (x1 - x3)^2 + (y1 - y3)^2 == 1,
     (x1 - x4)^2 + (y1 - y4)^2 == 1, (x2 - x3)^2 + (y2 - y3)^2 == 1,
     (x4 - x5)^2 + (y4 - y5)^2 == 1, (x5 - x6)^2 + (y5 - y6)^2 == 1,
     (x6 - x7)^2 + (y6 - y7)^2 == 1, (x7 - x8)^2 + (y7 - y8)^2 == 1,
     (x8 - x9)^2 + (y8 - y9)^2 == 1, (x9 -x10)^2 + (y9 -y10)^2 == 1, 
     x1 == 0, y1 == 0, x2 == 1, y2 == 0};
Reduce[e, {x1,y1,x2,y2,x3,y3,x4,y4,x5,y5,x6,y6,x7,y7,x8,y8,x9,y9,x10,y10}]

That pins a couple of points to the paper and very rapidly determines and returns a couple of choices for positions of some of your subsequent points. You could use that result to fairly quickly determine if there are no satisfactory positions for the rest of your points. Choice of which equations to include has a significant effect on the speed of finding solutions. Sometimes adding an equation will speed it up, others will substantially slow it down. I don't know if you wait long enough whether it would find a solution for all your points.

share|improve this answer
    
This is a nice approach, but I'm trying want a general approximation algorithm: a function to run on any and all graphs. –  M.R. Aug 27 '12 at 23:01
add comment

Basically along the lines suggested by Bill Simpson. The equation setup could perhaps be done with more elegance. Still, it's fairly short code.

isUnitDistance[graph_] := Module[
  {verts, edges, n, coords, p, x, soln},
  verts = VertexList[graph];
  edges = EdgeList[graph];
  n = Length[verts];
  verts = verts /. Thread[verts -> Range[n]];
  coords = Array[x, {n, 2}];
  {x[1, 1], x[1, 2], x[2, 1], x[2, 2]} = {0, 0, 1, 0};
  p[j_] := {x[j, 1], x[j, 2]};
  polys = 
   Map[(p[#[[1]]] - p[#[[2]]]).(p[#[[1]]] - p[#[[2]]]) - 1 &, edges];
  Quiet[soln = NSolve[polys]];
  If[soln === {}, False, True]
  ]

For run time, don't expect miracles. More than a very few vertices and it could go into overtime.

SeedRandom[111111];
gg = Graph@
  Union[Sort /@ (RandomInteger[{1, 8}, {20, 2}] /. {j_, j_} :> 
       Sequence[])]

(Still running after 2+ minutes.)

Could try to do similarly using NMinimize on sums of squares of distances minus 1. That's just a heuristic though, and a failure to attain a positive result is not a strong indication that no such solution exists.

share|improve this answer
    
Running my original function many times works much faster than this: Quiet@Reap[ Table[i = UnitDistanceQ[m]; If[i =!= Null, Sow[i]], {100}]][[2]] However the coordinates are not exact solutions, is there a way to rederive them? –  M.R. Aug 28 '12 at 3:37
    
I prefer the iterative method because of speed but also because you can see the local minima as interesting embeddings in themselves. –  M.R. Aug 28 '12 at 3:41
add comment

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.