Revisions to Finding all minimal paths in site percolation?

added 1204 characters in body

Source Link

edited Jul 9, 2016 at 23:19

2.6k
2
20
30

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

rightSide = Complement[Table[i, {i, 581, 600}], deleteMe]
Table[FindShortestPath[H, 1, i], {i, rightSide}]
Table[Length[FindShortestPath[H, 1, i]], {i, rightSide}]
shortest = Table[FindShortestPath[H, 1, i], {i, rightSide}][[4]];
HighlightGraph[H, PathGraph[shortest]]

that is the shortest path of length 47 between the vertex 1 and the left side. Next I need to do this over each site on the right side to find the shortest path between the right side and the left side

paths = Table[
   Table[FindShortestPath[H, j, i], {i, rightSide}], {j, leftSide}];
pathLengths = Table[
  Table[Length[paths[[k]][[h]]], {k, Length[paths]}],
  {h, Length[paths[[]][[1]]]}]
Histogram[pathLengths, 50]
pathLengths // Max
FindShortestPath[H, rightSide[[17]], leftSide[[13]]]
HighlightGraph[H, PathGraph[%]]
Pick[pathLengths, pathLengths // Positive]

where the zero entries tell me that there are sites from which no path to the other side. So we need to look for positive entries only to find the minimal paths and we found it to be of 33 size.

The largest pairwise minimal path length is 53 and it turns out to be between 1-596.

FindShortestPath[H, rightSide[[13]], leftSide[[1]]]
HighlightGraph[H, PathGraph[%]]

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

rightSide = Complement[Table[i, {i, 581, 600}], deleteMe]
Table[FindShortestPath[H, 1, i], {i, rightSide}]
Table[Length[FindShortestPath[H, 1, i]], {i, rightSide}]
shortest = Table[FindShortestPath[H, 1, i], {i, rightSide}][[4]];
HighlightGraph[H, PathGraph[shortest]]

that is the shortest path of length 47 between the vertex 1 and the left side. Next I need to do this over each site on the right side to find the shortest path between the right side and the left side.

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

rightSide = Complement[Table[i, {i, 581, 600}], deleteMe]
Table[FindShortestPath[H, 1, i], {i, rightSide}]
Table[Length[FindShortestPath[H, 1, i]], {i, rightSide}]
shortest = Table[FindShortestPath[H, 1, i], {i, rightSide}][[4]];
HighlightGraph[H, PathGraph[shortest]]

that is the shortest path of length 47 between the vertex 1 and the left side. Next I need to do this over each site on the right side to find the shortest path between the right side and the left side

paths = Table[
   Table[FindShortestPath[H, j, i], {i, rightSide}], {j, leftSide}];
pathLengths = Table[
  Table[Length[paths[[k]][[h]]], {k, Length[paths]}],
  {h, Length[paths[[]][[1]]]}]
Histogram[pathLengths, 50]
pathLengths // Max
FindShortestPath[H, rightSide[[17]], leftSide[[13]]]
HighlightGraph[H, PathGraph[%]]
Pick[pathLengths, pathLengths // Positive]

where the zero entries tell me that there are sites from which no path to the other side. So we need to look for positive entries only to find the minimal paths and we found it to be of 33 size.

The largest pairwise minimal path length is 53 and it turns out to be between 1-596.

FindShortestPath[H, rightSide[[13]], leftSide[[1]]]
HighlightGraph[H, PathGraph[%]]

added 296 characters in body

Source Link

edited Jul 9, 2016 at 21:35

hhh

2.6k
2
20
30

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

leftSiderightSide = Tuples[{Table[iComplement[Table[i, {i, coDimension581, 600}], {1}}];deleteMe]
rightSideTable[FindShortestPath[H, =1, Tuples[{i], {dimensioni, rightSide}]
Table[Length[FindShortestPath[H, Table[i1, i]], {i, coDimensionrightSide}]
shortest = Table[FindShortestPath[H, 1, i], {i, rightSide}];][[4]];
HighlightGraph[H, PathGraph[shortest]]

that is under construction Table[FindShortestPath[H, i, j], {i, leftSide}, {j, rightSide}] freezing computer, not yet sure howthe shortest path of length 47 between the vertex 1 and the left side. Next I need to usedo this over each site on the FindShortest nowright side to find the shortest path between the right side and the left side.

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

leftSide = Tuples[{Table[i, {i, coDimension}], {1}}];
rightSide = Tuples[{{dimension}, Table[i, {i, coDimension}]}];

that is under construction Table[FindShortestPath[H, i, j], {i, leftSide}, {j, rightSide}] freezing computer, not yet sure how to use the FindShortest now.

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

rightSide = Complement[Table[i, {i, 581, 600}], deleteMe]
Table[FindShortestPath[H, 1, i], {i, rightSide}]
Table[Length[FindShortestPath[H, 1, i]], {i, rightSide}]
shortest = Table[FindShortestPath[H, 1, i], {i, rightSide}][[4]];
HighlightGraph[H, PathGraph[shortest]]

that is the shortest path of length 47 between the vertex 1 and the left side. Next I need to do this over each site on the right side to find the shortest path between the right side and the left side.

Source Link

created Jul 9, 2016 at 21:10

hhh

2.6k
2
20
30

Solution based on the GridGraph

SeedRandom[10801];
dimension = 20;
coDimension = 30;
percProbability = 0.7;    
deleteMe = 
  Pick[Table[i, {i, dimension*coDimension}], 
   Table[RandomReal[] > percProbability, {i, 
     dimension*coDimension}]];
G = GridGraph[{dimension, coDimension}, VertexLabels -> "Name", 
   ImagePadding -> 30];
G = SetProperty[G, VertexCoordinates -> GraphEmbedding[G]];
H = VertexDelete[G, deleteMe]
FindShortestPath[H, 1, 600]
HighlightGraph[H, PathGraph[%]]

that finds the shortest path from the site 1 to the site 600. And next I want to find the shortest path from the left side to the right side

leftSide = Tuples[{Table[i, {i, coDimension}], {1}}];
rightSide = Tuples[{{dimension}, Table[i, {i, coDimension}]}];

that is under construction Table[FindShortestPath[H, i, j], {i, leftSide}, {j, rightSide}] freezing computer, not yet sure how to use the FindShortest now.

Stack Exchange Network

Return to Answer