# Vizualization of percolation paths

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?

• You would like all paths from some point on the bottom to some point on the top that are still valid after the creation of the holes? Apr 18, 2016 at 10:10
• @JasonB Yes, all possible paths. Of course I am primarily interested in the pathes in the situation close to the threshold. Apr 18, 2016 at 11:06
• @user929304 Thank you for your question. There is no need to remove it. The problem I had is different with respect to one you referred to. I am not making any research on this subject or any demonstration of my research. My task is to make a demonstration for a lecture for my students. I need to very clearly and easily show the students, what is the percolation phenomenon. I need to readily illustrate some its main features. So everything must be clearly visible and easily noticeable. Anyway, thank you very much for you interest and your ideas. Nov 9, 2017 at 15:06

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]], Thickness@.01, Hue[i/10]],
{i, 10}
],
ImageSize -> {500, 500}, ImagePadding -> 25
],
{n, 1, 80, 1}
]


• Thank you. It is OK for my purpose, but looks strangely in the JournalArticle StyleSheet. Have you an idea, why? Apr 18, 2016 at 11:36
• @AlexeiBoulbitch It seems that GridGraph[{10, 10}, VertexLabels -> None] in JurnalArticle doesn't care about VertexLabels spec. I hope there is a good explanation for that... I'd post a question about that.
– Kuba
Apr 18, 2016 at 11:41
• @AlexeiBoulbitch asked: mathematica.stackexchange.com/q/112971/5478
– Kuba
Apr 19, 2016 at 6:33

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.

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