Vizualization of percolation paths

I have done a similar thing for transport in porous media using the image processing functions. It may be different to what you are after but here's the code: First I create a dictionary of nodes

ClearAll[dictionary, im, seep];
dictionary[dimensions_Integer, size_Integer] /; (size < dimensions) :=
   dictionary[dimensions, size] = 
   Module[{cross, horiz, vert, empty, im},
    im = Image[#, "Bit"] &;
    cross = 
     im@SparseArray[{i_, 
          j_} /; (dimensions/2 + size/2 > i && 
            dimensions/2 - size/2 < i) || (dimensions/2 + size/2 > j &&
             dimensions/2 - size/2 < j) -> 1., {dimensions, 
        dimensions}];
    horiz = 
     im@SparseArray[{i_, 
          j_} /; (dimensions/2 + size/2 > i && 
           dimensions/2 - size/2 < i) -> 1., {dimensions, dimensions}];
    vert = 
     im@SparseArray[{i_, 
          j_} /; (dimensions/2 + size/2 > j && 
           dimensions/2 - size/2 < j) -> 1., {dimensions, dimensions}];
    empty = im@ConstantArray[0, {dimensions, dimensions}];
    {cross, horiz, vert, empty}
    ];

then I populate a grid using preferred weights for these nodes:

im[prob_] /; prob < 1 := 
  ImageAssemble@
   RandomChoice[{1, 0, 0, prob} -> dictionary[20, 3], {30, 30}];

and finally I trace the morphological components of the resulting network:

seep[a_Image] := With[{im = Binarize@Rasterize@a},
  MorphologicalComponents@im // Colorize
  ];

then I can wrap a manipulate around this to control the different probabilities of having a cut away node:

Manipulate[seep@im@prob, {prob, 0.1, 1}]

percolation

It's a little more versatile than what I show as you can populate nodes with only-horizontal or only-vertical paths as you can see by running:

dictionary[20, 3]

enter image description here

and you can adjust the width of the paths by changing the second parameter in the dictionary which is relevant for porous media but probably not in your case. I seem to remember it's a little buggy if you go to really large networks but it was sufficient for a student project.


I've taken Graph based road. Let me leave the styling to you:

gr = GridGraph[{10, 10}];

The top row is the one with Range[10]*10 vertices and the bottom one with 10*Range[0,9]+1. Don't know how to shortly transpose this so will leave it so.

topRow = 10 Range[10];
bottomRow = 10 Range[0, 9] + 1;

Manipulate[

 deleted = RandomSample[
      (*the top and the bottom row can not be dropped*)
   Complement[Range[100], topRow, bottomRow], 
   n
 ];

 gr2 = VertexDelete[gr, deleted];

    (*taking shortest paths to the bottom for each top vertex.*)
    (* could be more than one for each*)

 paths = Table[
   MinimalBy[
    FindShortestPath[gr2, start, #] & /@ (bottomRow),
    Length
   ],
   {start, topRow}
 ];

 HighlightGraph[
    HighlightGraph[
       gr, {Style[deleted, White]}, 
       VertexSize -> 1.5, VertexShape -> Graphics@{White, Disk[]}
    ],
    Table[
       Style[PathGraph /@ paths[[i]], [email protected], Hue[i/10]],
       {i, 10}
    ], 
    ImageSize -> {500, 500}, ImagePadding -> 25
 ],
 {n, 1, 80, 1}
]

enter image description here


Kuba beat me to this, but I'll post it anyway since it's slightly different. This gives control over the initial and final positions within the graph, and attempts to keep some of the styling elements,

n = 10;
g = SetProperty[GridGraph[{n, n}], 
   VertexCoordinates -> Flatten[Array[{#2, #1} &, {n, n}], 1]];
Manipulate[
 g2 = EdgeDelete[g, # <-> _ & /@ list];
 HighlightGraph[
  g2, PathGraph[FindShortestPath[g2, ninitial, nfinal]]],
 {{nholes, 10, 
   Dynamic[Row[{Style[
       "\!\(\*SubscriptBox[\(N\), \(cut\\\ away\)]\)= ", Italic, 14, 
       Blue], Style[nholes, 14, Blue]}]]},
  1, 100, 1, Appearance -> "Open"},
 {{list, RandomSample[Range[n n], 10]}, ControlType -> None},
 {{ninitial, 5, 
   Dynamic[Row[{Style["\!\(\*SubscriptBox[\(N\), \(initial\)]\)= ", 
       Italic, 14, Blue], Style[ninitial, 14, Blue]}]]}, 1, 10, 1, 
  Appearance -> "Open"},
 {{nfinal, 95, 
   Dynamic[Row[{Style["\!\(\*SubscriptBox[\(N\), \(final\)]\)= ", 
       Italic, 14, Blue], Style[nfinal, 14, Blue]}]]}, 91, 100, 1, 
  Appearance -> "Open"},
 Button["Generate", {ngen = nholes; 
   list = RandomSample[Range[n n], ngen]}]]

enter image description here