Vizualization of percolation paths

Question

I did a simple demonstration to illustrate the percolation theory for my students. The content is a conductive square network possessing electrodes at its top and bottom edges. Some randomly chosen knots of the network are cut away. The network is graphically shown by black lines, while to show the cut knot I place a white disk over it. Here is the code:

   perc1[n_Integer] := Module[{i, j, lst, lst1, m},
   lnHor = 
    Graphics[{Thick, Table[Line[{{0.5, i}, {10.5, i}}], {i, 1, 10}]}];
   lnVer = 
    Graphics[{Thick, Table[Line[{{j, 0.5}, {j, 10.5}}], {j, 1, 10}]}];
   lst = DeleteDuplicates[
     Table[{RandomInteger[{1, 10}], RandomInteger[{1, 10}]}, {3000}]];
    lst1 = Drop[lst, Length[lst] - n];
   disks = Graphics[{White, Table[Disk[lst1[[m]], 0.3], {m, 1, n}]}];
   el1 = Graphics[{Black, Thickness[0.03], 
      Line[{{0.5, 0.5}, {10.5, 0.5}}]}];
   el2 = Graphics[{Black, Thickness[0.03], 
      Line[{{0.2, 10.5}, {10.5, 10.5}}]}];
   wir1 = Graphics[Line[{{5, 10.5}, {5, 11}}]];
   wir2 = Graphics[Line[{{5, 0.5}, {5, 0.}}]];
   Column[{
     Row[{Style[
        "x = \!\(\*FractionBox[SubscriptBox[\(N\), \(cut\\\ away\)], \
SubscriptBox[\(N\), \(total\)]]\) = ", Italic, 14], n/100 // N}],
     Show[{lnHor, lnVer, disks, el1, el2, wir1, wir2}, 
      ImageSize -> 350, PlotRange -> {{0, 11}, {0, 11}}]}, 
    Alignment -> Center]];
percolation1 = 
 Manipulate[
  perc1[n], {{n, 10, 
    Dynamic[Row[{Style[
        "\!\(\*SubscriptBox[\(N\), \(cut\\\ away\)]\)= ", Italic, 14, 
        Blue], Style[n, 14, Blue]}]]}, 1, 100, 1, 
   Appearance -> Labeled}, ControlPlacement -> Top, 
  SaveDefinitions -> True]

That' s what you see:

When moving the slider one varies the number of the knots cut away. This works.

Now my question: It would be nice, if I could in addition show by some color marking possible percolation paths (that is, those contours along which the current can flow from the top to bottom electrode in a given configuration). It should vary dynamically when moving the slider.

Any idea?

Answer 1

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}
]

Answer 2

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}]

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]

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.

Answer 3

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]}]]