10
$\begingroup$

enter image description here

This picturel can be generated like this

pos={{1,4},{1,8},{1,9},{2,2},{2,3},{2,4},{2,5},{2,6},{2,8},{2,9},{3,2},{3,6},{4,1},{4,2},{4,3},{4,4},{4,5},{4,6},{4,7},{4,8},{5,2},{5,7},{6,2},{6,5},{6,6},{6,7},{7,2},{7,5},{7,8},{8,2},{8,4},{8,5},{8,6},{8,7},{8,8},{8,9},{9,2}};
m=SparseArray[pos->0,{9,9},1];
ArrayPlot[m,Mesh->All]

Although I got the result, but in an hard coded way, lack of flexibility

g = Graph[Range[81], 
  UndirectedEdge @@@ {36 -> 35, 17 -> 26, 26 -> 35, 35 -> 44, 
    44 -> 53, 17 -> 16, 16 -> 15, 15 -> 14, 14 -> 13, 13 -> 12, 
    12 -> 11, 11 -> 10, 6 -> 15, 15 -> 24, 24 -> 33, 33 -> 42, 
    42 -> 51, 51 -> 60, 60 -> 59, 59 -> 58, 58 -> 49, 49 -> 40, 
    40 -> 39, 39 -> 38, 29 -> 38, 38 -> 47, 47 -> 56, 56 -> 65, 
    65 -> 74, 66 -> 65, 71 -> 72, 72 -> 81, 81 -> 80, 80 -> 71, 
    53 -> 52, 51 -> 52, 60 -> 69}, { 
   VertexCoordinates -> Tuples[Range[9], 2]}, VertexLabels -> "Name"]
FindPath[%, 36, 74, Infinity, All]
HighlightGraph[g, PathGraph[#]] & /@ %

enter image description here

$\endgroup$
11
$\begingroup$

You can use NearestNeighborGraph with pos directly:

nng = NearestNeighborGraph[pos, VertexCoordinates -> RotationTransform[-Pi/2][pos], 
  VertexLabels->"Name"]

enter image description here

Row[HighlightGraph[nng, Subgraph[nng, #], ImageSize -> 300] & /@ 
  FindPath[nng, {1, 4}, {8, 9}, ∞, All], Spacer[5]]

enter image description here

If a binary matrix m is given as input, you can use pos = SparseArray[m]["NonzeroPositions"] before the first line of code above.

To show ArrayPlot and the graph together we need to translate the vertex coordinates to align with cells in ArrayPlot:

Show[ArrayPlot[SparseArray[pos -> 1], ColorRules -> {1->Opacity[.5, Yellow]}, Mesh -> All],
  NearestNeighborGraph[pos, 
  VertexCoordinates -> TranslationTransform[{-.5, 9.50}]@RotationTransform[-Pi/2][pos], 
  VertexLabels -> "Name"]]

enter image description here

Use IndexGraph @ NearestNeighborGraph[...] above to replace each vertex with its index:

enter image description here

$\endgroup$
6
$\begingroup$

Maybe this helps. It requires Szabolcs' package "IGraphM`". It is very easy to install and it provides many useful tools for working with graphs.

Needs["IGraphM`"]

A = Reverse@(1 - m);
R = ArrayMesh[Normal@A];
{i, j} = Transpose@UpperTriangularize[IGMeshCellAdjacencyMatrix[R, 2, 2], 1][ "NonzeroPositions"];

vertices = A["NonzeroPositions"][[All, {2, 1}]];
edges = Transpose[{vertices[[i]], vertices[[j]]}];


G = Graph[vertices, UndirectedEdge @@@ edges,
 VertexCoordinates -> vertices,
 VertexLabels -> "Name"
 ]

enter image description here

An now, we can request all paths:

paths = FindPath[G, {4, 9}, {9, 2}, Infinity, All];
GraphicsRow[
 HighlightGraph[G, Subgraph[G, #]] & /@ paths, 
 ImageSize -> Full
 ]

enter image description here

$\endgroup$
6
$\begingroup$

I'd do it like this with IGraph/M:

mesh = ArrayMesh@Normal[1 - m]

enter image description here

g = IGMeshCellAdjacencyGraph[mesh, 2, VertexCoordinates -> Automatic, 
  VertexLabels -> Automatic]

enter image description here

There are two paths:

paths = FindPath[g, {2, 1}, {2, 36}, Infinity, All]

Length[paths]
(* 2 *)

If PathGraph didn't dislike certain vertex names that are lists, we could show them like this:

HighlightGraph[g, PathGraph[#]] & /@ paths

To work around this limitation, we define our own pathGraph function:

pathGraph[path_] := Graph[UndirectedEdge @@@ Partition[path, 2, 1]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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